Perlbot/perlbuut
1
0
Fork 0
mirror of https://github.com/perlbot/perlbuut synced 2025-06-07 10:45:40 -04:00
Code Issues Releases Wiki Activity

Merge pull request #20 from shlomif/remove-dot-svns

Browse source 
Remove old **/.svn dirs.
This commit is contained in:
Ryan Voots 2018-04-23 15:16:08 -07:00 • committed by GitHub
commit e70ebe9f47
100 changed files with 0 additions and 8534 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
bin/.svn/dir-prop-base
View file

@ -1,5 +0,0 @@
K 13
svn:mergeinfo
V 0
END

198
bin/.svn/entries
View file

@ -1,198 +0,0 @@
10
dir
475
svn://erxz.com/bb3/branches/perlbuut/bin
svn://erxz.com/bb3
2009-10-03T22:53:42.528878Z
475
simcop
has-props
dcb1cea6-7f7e-4c78-8a22-148ace8ce36e
console
file
2009-10-03T22:54:20.000000Z
35d0f0f3f22d1c5c9269a11438e8b9bf
2009-10-03T22:53:42.528878Z
475
simcop
has-props
650
cpan_fetch.pl
file
2009-10-03T22:54:20.000000Z
a060d683a14b4caf9b955835d84928a2
2009-10-03T22:53:42.528878Z
475
simcop
190
bb3
file
2009-10-03T22:54:20.000000Z
19a8492fe2e1f4555b3e0420804bc08e
2009-10-03T22:53:42.528878Z
475
simcop
has-props
1416
evalserver_test.pl
file
2009-10-03T22:54:20.000000Z
6b3a1a206e0f305decc280b74a0a83f3
2009-10-03T22:53:42.528878Z
475
simcop
454
evalserver
file
2009-10-03T22:54:20.000000Z
a89e0e8f5969ec905d7641c00a8be339
2009-10-03T22:53:42.528878Z
475
simcop
has-props
540

5
bin/.svn/prop-base/bb3.svn-base
View file

@ -1,5 +0,0 @@
K 14
svn:executable
V 1
*
END

5
bin/.svn/prop-base/console.svn-base
View file

@ -1,5 +0,0 @@
K 14
svn:executable
V 1
*
END

5
bin/.svn/prop-base/evalserver.svn-base
View file

@ -1,5 +0,0 @@
K 14
svn:executable
V 1
*
END

62
bin/.svn/text-base/bb3.svn-base
View file

@ -1,62 +0,0 @@
#!/usr/bin/perl
use POSIX qw/setsid/;
use Getopt::Std;
my %OPTS;
# Localize the @ARGV so we preserve it
# since getopts destructively modifies it
# we need it to be intact so we can restart
# ourselves later.
BEGIN { local @ARGV=@ARGV; getopts("dm:M:c:p:", \%OPTS) };
# d daemon
# m only this role(s)
# M Every role but this Not Implemented
# c conf file
# p plugin conf file
# Guess we're being activated inside bin/, so go up a directory.
BEGIN {
if( not -e 'lib' and not -e 'etc' and -e 'bb3' ) {
chdir "..";
}
elsif( my @par_dirs = grep /tmp.*par.*cache-/, @INC ) {
# We're running under PAR!
chdir( ( grep /inc$/, @par_dirs ) [0] ); #Find the one that ends in inc/
mkdir "var"; # We need one of these..
}
elsif( $0 =~ '/' and $0 ne 'bin/bb3' ) {
my $path = $0;
$path =~ s{bin/bb3$}{};
chdir $path;
}
}
use lib 'lib';
use Bot::BB3;
use Data::Dumper;
Bot::BB3->new( {
main_conf_file => $OPTS{c} || 'etc/bb3.conf',
plugin_conf_file => $OPTS{p} || 'etc/plugins.conf',
only_roles => $OPTS{m},
} );
# Only daemonize if we're asked to.
if( $OPTS{d} ) {
setsid();
fork and exit;
open STDOUT, ">var/bb3.stdout" or die "Tried to reopen STDOUT to bb3.stdout: $!";
open STDERR, ">var/bb3.stderr" or die "Tried to reopen STDERR to bb3.stdout: $!";
close STDIN;
open my $fh, ">var/bb3.pid" or die "Failed to open pid file: $!";
print $fh $$;
close $fh;
}
POE::Kernel->run;
exit;

36
bin/.svn/text-base/console.svn-base
View file

@ -1,36 +0,0 @@
#!/usr/bin/perl
use strict;
use Term::ReadLine;
use IO::Socket::INET;
use Getopt::Std;
my %OPTS;
getopts( 'p:', \%OPTS );
my $connect_port = $OPTS{p} || 14401;
my $socket = IO::Socket::INET->new(
PeerHost => '127.0.0.1',
PeerPort => $connect_port,
ReuseAddr => 1,
Proto => 'tcp',
Type => SOCK_STREAM,
) or die "Failed to connect to localhost on $connect_port, try specifying a port with -p";
my $term = Term::ReadLine->new( "BB3 Console" );
my $prompt = "bb3> ";
while( defined( $_ = $term->readline($prompt) ) ) {
print $socket "$_\n";
my $output;
sysread $socket, $output, 4096;
$output =~ s/^CC: //;
print $output, "\n";
}

6
bin/.svn/text-base/cpan_fetch.pl.svn-base
View file

@ -1,6 +0,0 @@
__END__
http://cpan.mirror.facebook.com/authors/01mailrc.txt.gz
http://cpan.mirror.facebook.com/modules/02packages.details.txt.gz
http://cpan.mirror.facebook.com/modules/03modlist.data.gz

21
bin/.svn/text-base/evalserver.svn-base
View file

@ -1,21 +0,0 @@
#!/usr/bin/perl
# Guess we're being activated inside bin/, so go up a directory.
BEGIN { if( not -e 'lib' and not -e 'etc' and -e 'bb3' ) { chdir ".."; } }
use lib 'lib';
use EvalServer;
use POSIX qw/setsid/;
# Only daemonize if we're asked to.
if( $ARGV[0] eq '-d' ) {
# Crude daemonization
setsid();
fork and exit;
open STDOUT, ">var/evalserver.stdout" or die "Tried to reopen STDOUT to bb3.stdout: $!";
open STDERR, ">var/evalserver.stderr" or die "Tried to reopen STDERR to bb3.stdout: $!";
close STDIN;
}
EvalServer->start;

23
bin/.svn/text-base/evalserver_test.pl.svn-base
View file

@ -1,23 +0,0 @@
use POE::Filter::Reference;
use IO::Socket::INET;
use Data::Dumper;
my $filter = POE::Filter::Reference->new();
while( 1 ) {
print "Code: ";
my $code = <STDIN>;
my $socket = IO::Socket::INET->new( PeerAddr => '127.0.0.1', PeerPort => '14400' );
my $refs = $filter->put( [ { code => "$code" } ] );
print $socket $refs->[0];
local $/;
my $output = <$socket>;
print "OUTPUT: ", Dumper($filter->get( [ $output ] )), "\n";
$socket->close;
}

5
docs/.svn/dir-prop-base
View file

@ -1,5 +0,0 @@
K 13
svn:mergeinfo
V 0
END

334
docs/.svn/entries
View file

@ -1,334 +0,0 @@
10
dir
475
svn://erxz.com/bb3/branches/perlbuut/docs
svn://erxz.com/bb3
2009-10-03T22:53:42.528878Z
475
simcop
has-props
dcb1cea6-7f7e-4c78-8a22-148ace8ce36e
module_list
file
2009-10-03T22:54:20.000000Z
b0b9bb1eb56ed498ddae32c4f8c9b82b
2009-10-03T22:53:42.528878Z
475
simcop
526
said
file
2009-10-03T22:54:20.000000Z
23502f33387a03c10ea31dc6a0c40f51
2009-10-03T22:53:42.528878Z
475
simcop
2691
plugins
file
2009-10-03T22:54:20.000000Z
b9336859368d642906a04c17463a09e3
2009-10-03T22:53:42.528878Z
475
simcop
2499
modulelist2
file
2009-10-03T22:54:20.000000Z
29104ecfeafbd90619a0cace9358f49d
2009-10-03T22:53:42.528878Z
475
simcop
1532
writing_plugins
file
2009-10-03T22:54:20.000000Z
85f2cf1c4ac1d09756073a01f4ab3b80
2009-10-03T22:53:42.528878Z
475
simcop
10523
todo
file
2009-10-03T22:54:20.000000Z
036648498679c4c525bed38967ba24c6
2009-10-03T22:53:42.528878Z
475
simcop
214
daemons
file
2009-10-03T22:54:20.000000Z
44a6e62ea707ac1dc48d350b964b0b60
2009-10-03T22:53:42.528878Z
475
simcop
306
pluginmanager
file
2009-10-03T22:54:20.000000Z
4e8751dce708a400d4057bf1f007576e
2009-10-03T22:53:42.528878Z
475
simcop
333
quick_start
file
2009-10-03T22:54:20.000000Z
58e2bbac93cb143d57c77d4c79262170
2009-10-03T22:53:42.528878Z
475
simcop
8628

4
docs/.svn/text-base/daemons.svn-base
View file

@ -1,4 +0,0 @@
Long running commands spawned by the bot.
Register for inputs to receieve?
-- Is this necessary? I mean, plugins are pretty sexy now. The primary factoid case has been handled by the new fork/plugin model.
We may only need daemons for sending output on timers or outside events, eg, commits or rss feeds.

40
docs/.svn/text-base/module_list.svn-base
View file

@ -1,40 +0,0 @@
CORE
--------
BSD::Resource
Config::General
IO::Socket::INET
JavaScript::SpiderMonkey
Parse::RecDescent
POE
POE::Component::IRC
POE::Wheel::Run
POSIX
Scalar::Util
Storable
Text::Glob
Cache::FastMmap
Memoize
OPTIONAL
------------
CGI
DBD::SQLite
DBI
LWP::Simple
Net::Dict
POE::Filter::Reference
Text::Aspell
WWW::Shorten
WWW::RottenTomatoes
Finance::Quote
WWW::Shorten
XML::RSS::Parser
IMDB
Math::Farnsworth
Module::CoreList
POE::Component::Server::SimpleHTTP
Template
Text::Soundex
Geo::WeatherNWS
Weather::Underground

88
docs/.svn/text-base/modulelist2.svn-base
View file

@ -1,88 +0,0 @@
B::Deparse
Bot::BB3::ConfigParser
Bot::BB3::Logger
Bot::BB3::PluginConfigParser
Bot::BB3::PluginManager
Bot::BB3::PluginWrapper
Bot::BB3::Roles::Console
Bot::BB3::Roles::IRC
Bot::BB3::Roles::PasteBot
Bot::BB3::Roles::Skynet
Bot::BB3::Roles::SocketMessageIRC
Bot::BB3::Roles::Web
Bot::BB3::MacroQuote
BSD::Resource
Carp::Heavy
CGI
charnames
Config::General
Data::Dumper
HTTP::Status
Memoize
Parse::RecDescent
PerlIO
PerlIO::scalar
POE
POE::Component::IRC
POE::Component::IRC::Common
POE::Component::IRC::Plugin::AutoJoin
POE::Component::IRC::Plugin::Connector
POE::Component::IRC::Plugin::NickReclaim
POE::Component::IRC::State
POE::Component::Server::SimpleHTTP
POE::Component::IRC::Plugin
POE::Component::IRC::Constants
POE::Component::IRC::Qnet
POE::Component::IRC::Qnet::State
POE::Filter::Line
POE::Filter::Reference
POE::Filter::Stream
POE::Session
POE::Wheel::ReadWrite
POE::Wheel::Run
POE::Wheel::SocketFactory
POSIX
Scalar::Util
Socket
Storable
strict
Template
Text::Glob
Tie::Hash::NamedCapture
utf8
POE::Pipe
POE::Pipe::TwoWay
POE::Pipe::OneWay
DateTime::Format::Natural::Base
POE::Component::Pluggable::Constants
Bot::BB3::MacroQuote
CGI
Data::Dumper
DBD::SQLite
DBI
Geo::IP
IMDB
IO::Socket::INET
IPC::Open2
LWP::Simple
LWP::UserAgent
Math::Farnsworth
Math::Pari
Module::CoreList
Net::Dict
POE::Component::IRC::Common
POE::Filter::Reference
Scalar::Util
Storable
strict
strict
Text::Aspell
warnings
WWW::RottenTomatoes
WWW::Shorten
WWW::Shorten::Metamark
XML::RSS::Parser
Compress::Zlib
IO::File
IO::Seekable
IO::Handle

11
docs/.svn/text-base/pluginmanager.svn-base
View file

@ -1,11 +0,0 @@
Basic specification:
Read plugins.
Fork children.
Monitor children.
Wait for death.
Fork new child.
(Note, children required to die on schedule?)
Pass lines out to children, deal with output, pass output to main bot object.
Pre-fork model similar to apache. Plugin objects initialized after fork. Must not assume persistent state.

57
docs/.svn/text-base/plugins.svn-base
View file

@ -1,57 +0,0 @@
A plugin is implemented as a single file in the plugin directory. This is of course named 'plugins' unless otherwise specified in the bot's config file. Each file is executed and the return value (of the file!) is examined. If the return value is a subroutine, then it is taken as a basic plugin that executes in the 'main' phase of plugin handling and has no special configuration. If, on the other hand, the plugin returns a string, this is taken as the name of a package to call the method 'new' on to get an object. This object is then initialized and so forth then called with input in the normal course of plugin handling. Note that objects are still subject to the configuration specified in the plugin.conf file, but however, can do more configuration of how the main bot object interacts with the plugin, specifically when in the plugin loop they're activated and perhaps even a chance to preprocess or postprocess the output of other plugins. This is of course the 'advanced' method. Someday I'll actually document what the interface for all of this actually is.
File: echo.pm
#----------------START--------------
sub {
my( $said ) = @_;
print "You said: $said->{body}";
}
#-----------------EOF---------------
File: morecomplicated.pm
#----------------START--------------
package Bot::BB3::Plugin::Complicated;
sub new {
my( $class ) = @_;
return bless {}, $class;
}
sub initialize {
my( $self ) = @_;
#stuff
}
#Class name to execute
"Bot::BB3::Plugin::Complicated";
#-----------------EOF---------------
In particular note is the string returned, this is the name of the package to invoke. Note that you could use this as a dummy file to invoke modules installed elsewhere on the system, for example:
File: dummymodule.pm
#----------------START--------------
use MyModule::Somewhere;
"MyModule::Somewhere";
#-----------------EOF---------------
This simply calls 'use' to load the module and then returns the name.
Note that plugins who return a coderef are 'wrapped' by invoking Bot::BB3::PluginWrapper->new( $name, $coderef );
This provides the basic example for implementing a plugin object.
More Notes:
Plugins can check if the line has been handled before them.
Plugins activate only if configured to do so.
Plugins handle parsing..
Plugins need constants to return in certain situations.
Plugins have options to not handle the line, thus needing a NOT_HANDLED; constant?
Handled is the default I think?
Every plugin would have to return a constant.. maybe.

68
docs/.svn/text-base/quick_start.svn-base
View file

@ -1,68 +0,0 @@
The Quick Start Guide.
From a user's perspective, there are three main directories you should be interested in. These are etc/, bin/ and plugins/. More detailed explanations follow:
etc/ is the directory that contains all of the files necessary to configure the bot. At the moment it should only contain two files, bb3.conf and plugins.conf.
plugins.conf use a simple configuration language to control which plugins will respond in what channel and to what 'authorization' level. At the moment the syntax for the configuration language looks something like:
server "*" {
channel "#test" {
plugin "join" { access: op; addressed: true }
}
}
Essentially it's a series of nested filters that apply to the final set of conditions. The first filter is the "server" command, which attempts to match against the server name of whatever irc network generated the message the bot is attempting to reply to. The second filter is "channel" which obviously attempts to match against the channel the message was received on. Finally the "plugin" filter, again, matches against the specific plugin that it's trying to activate.
Note that you can use the '*' wildcard anywhere you could specify a specific string to cause that filter to always match. Also note you can have multiples of any section of the above example, that is, you can have multiple server blocks in the file, you can have multiple channel blocks inside a server block and so on. The configuration options are generally merged in an additive file, so if you have multiple blocks that have different conditions for the same plugin on the same channel on the same server, all of these conditions will have to be matched before it executes.
The final section of the above example is the actual "plugin" section, which again, tries to match against a specific plugin name and then applies the options listed inside the curly braces. In this case the two options being applied are 'access' and 'addressed'. The 'addressed' option controls whether or not the bot needs to have been addressed for this plugin to activate, in this case a value of true means it has to have been addressed, in the form of 'buubot: echo foo'. You can also specify 'false' to do the opposite, this is also useful for using a general filter to cause every plugin to be addressed and then setting specific ones to 'false' to let them respond without being addressed
The other option in the example is 'access' which simply controls what level of "authorization" might be required to activate the plugin. As of now there are only three levels of access, the default one which is what happens when you don't specify an access option, means anyone can use it. The second is 'op' which means you must currently be 'opped' in the channel where you're attempting to use the command. The last acceptable value is 'root' which means your hostmask much match the root_mask value in the etc/bb3.conf.
The second file in the etc/ directory is the bb3.conf file. Note that the bin/bb3 launching command automatically looks for a file named etc/bb3.conf to configure itself.
Obviously, this file contains directives used to configure which networks the bot connects to and under what name, along with root user, people to ignore, and various other plugin or role specific configuration directives. Technically this file uses syntax from the perl module Config::General, but you can think of it as the same language that Apache uses in its conf file, which can be summarized as <Foo bar> option_value 42 </Foo> where <Foo> starts a section named 'bar' and option_value 42 sets the option_value to 42, whatever thay may do.
The main configuration directive is named 'bot' and looks something like:
<bot buubot>
channel \#buubot
channel \#bottest
ignore avarbot
ignore otherbot
server irc.freenode.org
root_mask user@host.org
</bot>
The first section is the <bot buubot> part, which starts a new 'bot' section, which is ended by the corresponding </bot> tag, and specifies that the nickname of this bot, when it connects to the irc server, should be 'buubot'. Because that's an awesome name.
The second section is the 'channel' directive which specifies a list of channels to join as soon as the bot has connected. Each channel directive specifies a single channel, simply repeat it to join multiple. You can specify as many as the irc network will let you connect to. Note that you have to escape the # (\#) signs in the channel name, since this configuration language uses # to begin a comment.
The next section is the 'ignores', these simply take the name of an irc user for the bot to ignore, note that the bot will drop ALL input from any user whose nick matches the name specified. Again, you can specify multiple people to ignore simply by specifying the directive multiple times.
The next directive is really the only required one, and that is the 'server' command, which takes a single argument, the name of an irc server to attempt to connect to. In this case, irc.freenode.org, because I like freenode. Note that unlike the rest of the directives, you can only specify one 'server' directive. If you want to connect to multiple servers at the same time, simply create multiple <bot foo></bot> blocks, each one containing a different server directive.
The last directive is 'root_mask', which determines which users are able to use plugins with an 'access' set to 'root'. It matches fairly directly against your IRC hostmask, to set it to something similar.
There are a number of other configuration directives in the file, which mostly aren't that interesting, with the possible exception of the following:
<plugin_manager>
default_plugin factoids
</plugin_manager>
This block controls which plugin responds when the bot is addressed and it can't find a plugin that matches what the user said.
An example, if our bot was currently named 'buubot' and a user spoke to it as such: "buubot: echo foo bar", assuming you left the default plugin named 'echo' in the directory, buubot would match the 'echo' at the start of the string and then pass the rest of the arguments to the echo plugin. However, if a user spoke to the bot like "buubot: flibble", and assuming you didn't have a plugin named 'flibble' in your plugin directory, then it would activate the plugin specified as the 'default_plugin' in the above configuration section and pass that string to it. In this case, the default_plugin is configured to be 'factoids' which is the plugin that handles learning random strings based on user input, try 'help factoids' once the bot is running for more information.
You could set this default plugin to be any of the plugin in the plugins/directive, for example you might prefer to set it to the 'eval' plugin or anything else, if you prefer the bot to default to that.
Anyway, once you've configured the above files to your liking, you can actually launch the bot with the command bin/bb3. This launches the bot and attempts to get it connected to the irc networks you specified. Note that you can pass the flag '-d' to bin/bb3 to have it attempt to 'daemonize' itself and stop spewing output to your console. Also note that it really expects to be run from the base directory you checked out or downloaded, that is, you should have a folder named something containing bin, etc, plugins, lib and so forth, and you really should run this command from inside that directory with the command 'bin/bb3'.
The second interesting command in the bin directory is the 'evalserver' command which attempts to launch the evalserver. As a quick summary, the evalserver runs as a standalone tcp-socket based server which receives commands to evaluate, evaluates them and returns the output. By default it only listens to localhost connections on the port 14400, unfortunately this port can't be configured at the moment, if you want to change it just edit lib/EvalServer.pm and search for it.
Note that this server must be run as root, so it can perform the necessary security based actions of invoking 'chroot' and dropping its user and group id to the user 'nobody'. You're welcome to think this is moderately unsafe, but the code involved is relatively simple and easy to audit. The two files involved are lib/EvalServer.pm and lib/eval.pl, which performs the actual security based sections. In any case, unless you either find an actual hole or can come up with an alternate way to perform this, please refrain from commenting. I'll note that I've been running this server, as root, for over a year now on highly populated IRC channels, and have received no ill-effects.

37
docs/.svn/text-base/said.svn-base
View file

@ -1,37 +0,0 @@
The said object is the heart of the bb3 communication system. Specifically it's the only argument passed to plugins of various types. It contains all of the knowledge necessary to respond to a single IRC line (or other forms of communication). The values are as follows:
$said = {
body_raw => The exact text that it was sent
body => The potentially parsed results of the body. Note that several things modify
it at the moment. For example, the name of the bot is removed if it is
found at the start. In some cases, if the leading text matches the name
of a command, it is also removed.
recommended_args => An array ref of words in the text.
Note that this only exists for 'command' type plugins.
It's just a guess to save some time, it's split on whitespace
or similar.
channel => The channel that it was seen in. In the case of IRC this is of the form
#channel, but other roles use channel names starting with *, for example,
*irc_msg or *dcc_send or even *web for the web based interface.
addressed => Whether or not the bot detected its name at the beginning
sender_raw => The raw description of the person who sent the text`
name => The irc nick of the person who sent the line
ircname => The irc username of the sender.
host => The host of the person who sent the text
server => The server it was seen on
pci_id => The POE::Component::IRC ID, obviously internal use only.
my_name => The current name of the bot who saw it.
special_commands => This is an arrayref of arrayrefs, elements that are used as
arguments to $poe_component_irc->yield, if they start with pci_
that is: special_commands => [ [ 'pci_join', '#foo', '#bar' ] ]; causes:
$pci->yield( 'join', => '#foo', '#bar' );
If the command starts with pm_ it calls the specified method on the
$plugin_manager object that executed this plugin. If it starts with
bb3_ it calls the method on the parent bb3 object that spawned the
plugin_manager in the first place.
parent_session => This is added by the plugin_manager to record which session sent
us the $said event in the first place. Mostly internal use.
by_root => Set to 1 if the line was "spoken" by someone who matches the root_mask
by_chan_op => Set to 1 if the line was "spoken" by someone who currently has
operator status in the channel he spoke the line in.
};

6
docs/.svn/text-base/todo.svn-base
View file

@ -1,6 +0,0 @@
Add cron type plugin.
Decide how rss works. Especially with cron.
Create website. Document ways to talk to the bot. Document plugins. Document install.
Modify color based output to try to avoid coloring a file.

100
docs/.svn/text-base/writing_plugins.svn-base
View file

@ -1,100 +0,0 @@
Plugins come in two forms. The first form is a simple subroutine ref. The second is a complex object.
In the first case, simply define an annonymous subroutine reference in a file in the appropriate directory (typically the one named 'plugins') with the file name being the name of the command you want. You can do other things other than define an annonymous sub, but make sure that the subref is the last value to be returned. This subroutine ref is encapsulated as part of a larger object and then executed whenever the bot sees a string that matches the name of the file, which is also the command name. The subroutine is passed two arguments, the first is $said, which is documented in docs/said, and the second is the $plugin_manager object, which isn't really documented.
As mentioned, $said contains all of the necessary information for you to respond to the user who triggered your plugin. The most relevant fields of $said are as follows:
body: This is the text sent to the bot. Note that if it was addressed to the bot, by prefixing the sentence with the bot's current name, this is stripped. The command name, which caused this particular plugin to be triggered, is also stripped. That is, if the bot was named 'bb3' and the example command was named 'echo', then the string "bb3: echo: hello world" would generate a body field of "hello world".
raw_body: The exact text sent to the bot, includes bot name, command name, and so on.
recommended_args: This is an array ref of whitespace split text that is supposed to be a decent guess as to how you should interpret the text sent to you. "echo foo bar" would generate a recommended args of ['foo','bar'].
See docs/said for more complete documentation of the $said 'object'.
Simple plugins can use print to communicate back to the caller. They should also be able to return a value from the end of the subroutine that will be displayed to the user.
Plugins also use the __DATA__ handle to store documentation for themselves.
Example, echo.pm:
sub {
my( $said, $pm ) = @_;
print $said->{body};
}
__DATA__
Example echo plugin. Outputs whatever it sees.
--- END OF EXAMPLE ---
There are a couple of key points. The first is the file name, in this case, 'echo.pm'. This filename determines the command name the plugin will by activated against. The .pm suffix is also important since the bot will ignore files that don't end in .pm.
The second is the arguments passed to the sub. All simple plugins take two arguments, $said and $pm. $said is the object mentioned above. $pm is the Bot::BB3::PluginManager object, which is the internal object that handles loading and dispatching to the various plugins. It's mostly useful for accessing configuration information about the bot or for getting references to other plugins. 99% of plugins will never need to use this object. For a moderately simple example of using this object to access other plugins, see plugins/help.pm.
The next point is the 'print' and the and $said->{body}. The routine that activates this plugin used a tied STDOUT to allow 'print' to be used for outputting text, so you can't get too clever. $said->{body} is, as mentioned frequently, the remainder of the text that caused the bot to activate this plugin, minus the bot name and the command name.
The last bit, the __DATA__ section, is of course the documentation for the plugin and is read by plugins/help.pm and possibly other areas in order to provide helpful information to the user.
Complicated plugins, or at least, not simple plugins, allow for much more flexibility in how you define and interact with events from the bot. They're also the only way to respond to every line the bot reads without having to be activated by a specific command string.
These types of plugins need to declare a module/package and return a string that contains the name of the package that the PluginManager will invoke new on to get a plugin object.
The only two required methods for a 'complex' plugin are 'new' and 'command'. new is invoked by the PluginManager as it loads all of the plugins it finds in the plugins/ directory and should return an object. For a variety of mostly silly reasons, at the moment the object has to be of the type 'blessed hash' and contain the following key/value pairs in the hash. If you don't like this, send a patch.
The blessed hash should contain a 'name' field, containing the name that the plugin should be activated by, as well as the 'opts' key, which points to a hashref containing option=>value pairs. There are four supported options that may be present in the 'opts' hash. They are, handler, command, preprocess and postprocess. One or more of these has to be set or the plugin will never be activated. The exact meanings are as follows:
command => 1
This causes the bot to activate your plugin as a simple command, which is incidentally how the above documented 'simple plugins' are implemented. In short it looks for the name of your plugin at the beginning of the string followed by some optional delimiter characters (such as : or ,) and then calls your plugin's ->command method.
handler => 1
This causes the bot to activate your plugin on every line that the bot sees. It calls the method ->handle.
preprocess => 1
This causes your plugin to be invoked on every line the bot sees, before any other plugin is activated. Note that you are simply passed a $said object, but this is the same object that every other plugin will see, so you can modify it at will.
postprocess => 1
Much the same as preprocess, this causes your plugin to be invoked after every other plugin has finished. You are passed $said and a reference to the output of all of the previous plugins that you may modify as you wish.
The command method. This is the method that actually does all the work for your plugin and is invoked by the PluginManager depending on the criteria defined above in the opts hash. It is passed: $self, $said, $pm. $self and $said are your object and the said object obviously and $pm is the PluginManager object as mentioned above. Note that 'handle' options invoke the 'handle' method instead.
This method is expected to return a list of two items. Note that this is a list and not an array reference. This first item should be a string, either 'handled' or an empty string ''. The second item is another string containing the text you wish to output to the user.
Digression: Plugin Chains. When a line is seen by the bot, it creates a plugin chain, that is, a list of all the plugins the bot thinks might be activated for that line, such as commands that match or handlers that always activate and so on. However, in an attempt to ensure that only a single plugin is actually activated per line, each plugin can return either 'handled' or '' as the first item it returns. If the string is 'handled' then the plugin chain is aborted at that point and the output as of that point is the final output from the bot for that line. Note that you can return an empty string as the first item, thus saying you haven't actually handled the line, but still output text by returning it as the second item. This text will be prepended to whatever else is output by other plugins down the line of the chain. Note that all 'simple plugins' always return 'handled' when they're called. Note that 'handler' plugins can't return handled, their output is always concatenated onwards.
Example, FlibbleEcho.pm:
package Bot::BB3::Plugin::FlibbleEcho;
sub new {
my( $class ) = @_;
my $self = bless {}, $class;
$self->{name} = "echo";
$self->{opts} = { command => 1 };
return $self;
}
sub postload {
my( $self, $pm ) = @_;
Create_Database();
}
sub initialize {
my( $self, $pm, $cache ) = @_;
$self->{cache} = $cache;
# Create database handle maybe
}
sub command {
my( $self, $said, $pm ) = @_;
return( 'handled', "Flibble! $said->{body}" );
}
"Bot::BB3::Plugin::FlibbleEcho";
__DATA__
The flibble echo. Prepends flibble to whatever string it sees and returns the string! Responds to echo.
-------- End of Example ----------
Again, there are some interesting points. The first is the package declaration, this is necessary for us to create our perl object later. Note we stick it inside the Bot::BB3::Plugin namespace, this isn't a requirement, but it at least makes a pretense at organization.
The next is the new method where we create the object. The two interesting sub points are the 'name' key which specifies our name and the 'opts' hash which specifies that we should be treated as a 'command', which if you will recall, causes our plugin to be activated when our 'name' is detected at the beginning of a string. Note that despite the fact that the file name is 'FlibbleEcho' we declare our name to be 'echo' and are activated based on that declared name. That is to say, in the case of 'complex plugins', the file name is irrelevant.
At the end obviously we return our self as a standard object creation method.
The postload method is called directly after the plugin is instantiated by the pluginmanager and before the pluginmanager forks off its children. It is useful for performing any 'setup' operations you need done before the plugin is in actual use by the bot.
The initialize method is called on every plugin loaded directly after the pluginmanager forks its children, so it will be called on each plugin for ever child spawned. It varies from the rest of the methods by being passed a $cache object which conforms to the Cache interface. Note that every plugin gets the same cache object, even across forks. This is useful for IPC and storing temporary values. For example, the 'more' plugin is implemented by saving the data in this cache.
The command subroutine is very simple in this example, we simply assign our arguments to local variables and then return. We return a string of 'handled' to denote the fact that we've successfully responded to this command and then the text we want to output, which in this case is the string Flibble! prepended to whatever text the user has written.
At the end of the plugin we return a string, which should be the name of the package we declared at the beginning. This is the package name that the PluginManager will call new on to create this object for this plugin. Note that you could actually simply 'use' another package and then return the name of that package, instead of actually implementing the entire plugin in side this file.
Again at the very end is the __DATA__ section which contains our help text.

5
etc/.svn/dir-prop-base
View file

@ -1,5 +0,0 @@
K 13
svn:mergeinfo
V 0
END

96
etc/.svn/entries
View file

@ -1,96 +0,0 @@
10
dir
475
svn://erxz.com/bb3/branches/perlbuut/etc
svn://erxz.com/bb3
2009-10-03T22:53:42.528878Z
475
simcop
has-props
dcb1cea6-7f7e-4c78-8a22-148ace8ce36e
plugins.conf
file
487
2009-10-05T14:25:14.000000Z
7c9758bae26f06475cb3988ea75c2548
2009-11-24T01:05:35.791810Z
487
simcop
388
bb3.conf
file
487
2009-11-24T00:47:29.000000Z
6ecd3ff71fb0c9faf09d38c61f75435c
2009-11-24T01:05:35.791810Z
487
simcop
1416

83
etc/.svn/text-base/bb3.conf.svn-base
View file

@ -1,83 +0,0 @@
<be>
# change this to point to the actual directory where you store quotes
quotes_dir /home/buu/p/bb2/trunk/quotes
</be>
http_plugin_port 1092
<Roles>
<socketmessageirc>
enabled no
port 10091
</socketmessageirc>
<console>
enabled no
port 10092
</console>
<web>
enabled no
</web>
<pastebot>
enabled no
hostname erxz.com:10081
alias_url = http://erxz.com/bb3pb
</pastebot>
</Roles>
# Change this to be bot specific?
<plugin_manager>
default_plugin factoids
</plugin_manager>
<bot perlbot>
channel \#buubot
channel \#\#turtles
channel \#perlcafe
channel \#webgui
channel \#citadel
channel \#modperl
channel \#perl
channel \#ipv6
channel \#perlbot
channel \#mrtg
channel \#ipv6-fr
channel \#freebsd-fr
channel \#botpark
channel \#css
channel \#modus
ignore buubot
ignore avarbot
ignore jeval
ignore gumbybrain
ignore perlbot
ignore buubot3
ignore loudbot
ignore serfbot
ignore farnsworth
ignore frogbot
ignore EvanCarroll
ignore EvanCarrol
ignore EvanCaroll
ignore EvanCarol
ignore EC
server localhost
username perlbuutfreenode
password perlbuut
port 6668
root_mask n=simcop23@p3m/member/simcop2387
</bot>
<bot perlbot>
channel \#freenode-perl-cabal
server localhost
username perlbuutmagnet
password perlbuut
port 6668
root_mask ~simcop238@erxz.com
</bot>

13
etc/.svn/text-base/plugins.conf.svn-base
View file

@ -1,13 +0,0 @@
server "*" {
channel "*" {
plugin "*" { addressed: true }
plugin "join" { access: root; addressed: true }
plugin "part" { access: op }
plugin "reload_plugins" { access: root }
plugin "restart" { access: root }
plugin "conf_dump" { access: root; }
plugin "save_config" { access: root; }
plugin "conf" { access: root; }
plugin "karma_modify" { addressed: false; }
}
}

5
lib/.svn/dir-prop-base
View file

@ -1,5 +0,0 @@
K 13
svn:mergeinfo
V 0
END

102
lib/.svn/entries
View file

@ -1,102 +0,0 @@
10
dir
475
svn://erxz.com/bb3/branches/perlbuut/lib
svn://erxz.com/bb3
2009-10-03T22:53:42.528878Z
475
simcop
has-props
dcb1cea6-7f7e-4c78-8a22-148ace8ce36e
jail
dir
eval.pl
file
2009-10-03T22:54:20.000000Z
1cd271f250952a825ac64590a5db7682
2009-10-03T22:53:42.528878Z
475
simcop
has-props
7271
Bot
dir
EvalServer.pm
file
2009-10-03T22:54:20.000000Z
89cccf6bbe65af76f437521edace7a6d
2009-10-03T22:53:42.528878Z
475
simcop
5460

5
lib/.svn/prop-base/eval.pl.svn-base
View file

@ -1,5 +0,0 @@
K 14
svn:executable
V 1
*
END

238
lib/.svn/text-base/EvalServer.pm.svn-base
View file

@ -1,238 +0,0 @@
package EvalServer;
use POE;
use POE::Wheel::SocketFactory;
use POE::Wheel::ReadWrite;
use POE::Filter::Reference;
use POE::Filter::Line;
use POE::Filter::Stream;
use POE::Wheel::Run;
use strict;
sub start {
my( $class ) = @_;
my $self = $class->new;
my $session = POE::Session->create(
object_states => [
$self => [ qw/
_start _stop
socket_new socket_fail socket_read socket_write
spawn_eval eval_read eval_err eval_close eval_stdin
dead_child timeout
/ ],
]
);
POE::Kernel->run();
}
sub new {
return bless {}, shift;
}
sub spawn_eval {
my( $self, $kernel, $args, $parent_id ) = @_[OBJECT,KERNEL,ARG0,ARG1];
my $filename = 'eval.pl';
if( not -e $filename ) {
$filename = "lib/$filename";
}
warn "Spawning Eval: $args->{code}\n";
my $wheel = POE::Wheel::Run->new(
Program => [ 'perl', $filename ],
ProgramArgs => [ ],
CloseOnCall => 1, #Make sure all of the filehandles are closed.
Priority => 10, #Let's be nice!
StdoutEvent => 'eval_read',
StderrEvent => 'eval_err',
StdinEvent => 'eval_stdin',
CloseEvent => 'eval_close',
StdinFilter => POE::Filter::Line->new,
StdoutFilter => POE::Filter::Stream->new(),
StderrFilter => POE::Filter::Stream->new(),
);
warn "Storing Eval id: ", $wheel->ID, "\n";
$self->{ eval_wheels }->{ $wheel->ID } = { wheel => $wheel, parent_id => $parent_id };
$wheel->put( $args->{code} );
warn "Adding delay for 12 seconds: ", $wheel->ID;
$kernel->delay_set( timeout => 12, $wheel->ID );
}
sub timeout {
my( $self, $wheel_id ) = @_[OBJECT,ARG0];
warn "Got a timeout idea for $wheel_id";
my $wheel = $self->{ eval_wheels }->{ $wheel_id }->{ wheel }
or return; # Our wheel has gone away already.
warn "Trying to kill: ", $wheel->PID;
kill( 9, $wheel->PID );
}
sub _append_output {
my $self = shift; #Decrement @_ !
my( $cur_session, $kernel, $results, $id ) = @_[SESSION,KERNEL,ARG0,ARG1];
warn "AT UNDERSCORE: @_\n";
warn "Attempting to append: $self, $results, $id\n";
#return unless $results =~ /\S/;
my $output_buffer = $self->{ wheel_outputs }->{ $id } ||= [];
push @$output_buffer, $results;
warn "Checking length: ", scalar( @$output_buffer );
if( @$output_buffer > 1000 ) { # Lets not be silly
warn "Attempting to force a timeout using $cur_session";
$kernel->call( $cur_session->ID, timeout => $id ); #Force a timeout. Go away spammy outputs.
my $wheel = $self->{ eval_wheels }->{ $id }->{ wheel };
if( $wheel ) { $wheel->pause_stdout };
$kernel->call( $cur_session->ID, eval_close => $id );
}
}
sub eval_read {
#my( $self, $cur_session, $kernel, $results, $id ) = @_[OBJECT,SESSION,KERNEL,ARG0,ARG1];
my( $self ) = @_[OBJECT];
$self->_append_output( @_ );
}
sub eval_err {
my( $self, $error ) = @_[OBJECT,ARG0];
$self->_append_output( @_ );
}
sub eval_stdin {
my( $self, $id ) = @_[OBJECT,ARG0];
warn "STDIN EVENT\n";
#We've successfully flushed our output to the eval child
#so shutdown the wheel's stdin
my $wheel = $self->{ eval_wheels }->{ $id }->{ wheel};
$wheel->shutdown_stdin;
}
sub eval_close {
my( $self, $id ) = @_[OBJECT,ARG0];
warn "CLOSE EVENT\n";
# Sorry.
# I should find a better way someday.
warn "Looking for id: $id\n";
my $wheel_struct = delete $self->{ eval_wheels }->{ $id };
return unless $wheel_struct;
# Get our parent's ID
my $parent_id = $wheel_struct->{ parent_id };
warn "Found parent: $parent_id\n";
my $parent_wheel = $self->{ socket_wheels }->{ $parent_id };
# Send the results back to our client
my $outputs = delete $self->{ wheel_outputs }->{ $id };
warn "Close, my outputs: ", Dumper( $outputs );
# Not sure how we end up without a $parent_wheel, but we shouldn't die
if( $parent_wheel ) {
if( $outputs and @$outputs ) {
$parent_wheel->put( [ join '', @$outputs ] );
}
else {
$parent_wheel->put( [ ] );
}
}
}
sub _start {
my( $self, $kernel ) = @_[OBJECT,KERNEL];
warn "Eval Server starting\n";
$self->{socket_factory} = POE::Wheel::SocketFactory->new(
BindAddress => "127.0.0.1",
BindPort => '14400',
SuccessEvent => 'socket_new',
FailureEvent => 'socket_fail',
Reuse => 'on',
);
warn "Ready for connections...\n";
$kernel->sig( 'CHLD' => 'dead_child' );
}
sub socket_new {
my( $self, $handle ) = @_[OBJECT,ARG0];
warn "Got a socket\n";
my $wheel = POE::Wheel::ReadWrite->new(
Handle => $handle,
Driver => POE::Driver::SysRW->new(),
Filter => POE::Filter::Reference->new(),
InputEvent => 'socket_read',
FlushedEvent => 'socket_write',
ErrorEvent => 'socket_error',
);
warn "Storing socket as : ", $wheel->ID, "\n";
$self->{socket_wheels}->{ $wheel->ID } = $wheel;
}
sub socket_fail {
warn "SOCKET FAIL: $_[ARG0],$_[ARG1]\n";
}
sub socket_read {
my( $object, $kernel, $input, $wheel_id ) = @_[OBJECT,KERNEL,ARG0,ARG1];
use Data::Dumper;
warn "Got Input: ", Dumper $input;
$kernel->yield( spawn_eval => $input, $wheel_id );
}
sub socket_write {
my( $self, $id ) = @_[OBJECT,ARG0];
warn "SOCKET_WRITE!\n";
# We've received our single chunk of output for this
# response so remove the wheel.
my $wheel = delete $self->{socket_wheels}->{ $id };
$wheel->shutdown_input();
$wheel->shutdown_output();
}
sub socket_error {
my( $self, $id ) = @_[OBJECT,ARG0];
warn "Socket failed!\n";
delete $self->{socket_wheels}->{ $id };
}
sub _stop {
}
sub dead_child {
#Do nothing
#Side effect is the child is already reaped
}
1;

319
lib/.svn/text-base/eval.pl.svn-base
View file

@ -1,319 +0,0 @@
#!/usr/bin/perl
use strict;
use Data::Dumper;
use Scalar::Util; #Required by Data::Dumper
use BSD::Resource;
use File::Glob;
use POSIX;
# This sub is defined here so that it is defined before the 'use charnames'
# command. This causes extremely strange interactions that result in the
# deparse output being much longer than it should be.
sub deparse_perl_code {
my( $code ) = @_;
my $sub = eval "no strict; no warnings; no charnames; sub{ $code\n }";
if( $@ ) { print "Error: $@"; return }
my $dp = B::Deparse->new("-p", "-q", "-x7");
my $ret = $dp->coderef2text($sub);
$ret =~ s/\{//;
$ret =~ s/package (?:\w+(?:::)?)+;//;
$ret =~ s/ no warnings;//;
$ret =~ s/\s+/ /g;
$ret =~ s/\s*\}\s*$//;
print $ret;
}
use utf8; eval "\$\343\201\257 = 42"; # attempt to automatically load the utf8 libraries.
use charnames qw(:full);
use PerlIO;
use PerlIO::scalar;
# Required for perl_deparse
use B::Deparse;
# Javascript Libs
BEGIN{ eval "use JavaScript::SpiderMonkey;"; }
my $JSENV_CODE = do { local $/; open my $fh, "deps/env.js"; <$fh> };
require 'bytes_heavy.pl';
use Tie::Hash::NamedCapture;
uc "\x{666}"; #Attempt to load unicode libraries.
binmode STDOUT, ":utf8"; # Enable utf8 output.
BEGIN{ eval "use PHP::Interpreter;"; }
# Evil Ruby stuff
BEGIN{ eval "use Ruby qw/rb_eval/;"; }
BEGIN { $SIG{SEGV} = sub { die "Segmentation Fault\n"; } } #Attempt to override the handler Ruby installs.
# Evil K20 stuff
BEGIN {
local $@;
eval "use Language::K20;";
unless( $@ ) {
Language::K20::k20eval( "2+2\n" ); # This eval loads the dynamic components before the chroot.
# Note that k20eval always tries to output to stdout so we
# must end the command with a \n to prevent this output.
}
}
BEGIN { chdir "var/"; $0="../$0"; } # CHDIR to stop inline from creating stupid _Inline directories everywhere
# Inline::Lua doesn't seem to provide an eval function. SIGH.
BEGIN { eval 'use Inline Lua => "function lua_eval(str) return loadstring(str) end";'; }
BEGIN { chdir ".."; $0=~s/^\.\.\/// } # Assume our earlier chdir succeded. Yay!
# Evil python stuff
BEGIN { eval "use Inline::Python qw/py_eval/;"; }
# Evil J stuff
BEGIN { eval "use Jplugin;"; }
use Carp::Heavy;
use Storable qw/nfreeze/; nfreeze([]); #Preload Nfreeze since it's loaded on demand
my $code = do { local $/; <STDIN> };
# Close every other filehandle we may have open
# this is probably legacy code at this point since it was used
# inside the original bb2 which forked to execute this code.
opendir my $dh, "/proc/self/fd" or die $!;
while(my $fd = readdir($dh)) { next unless $fd > 2; POSIX::close($fd) }
# Get the nobody uid before we chroot.
my $nobody_uid = getpwnam("nobody");
die "Error, can't find a uid for 'nobody'. Replace with someone who exists" unless $nobody_uid;
# Set the CPU LIMIT.
# Do this before the chroot because some of the other
# setrlimit calls will prevent chroot from working
# however at the same time we need to preload an autload file
# that chroot will prevent, so do it here.
setrlimit(RLIMIT_CPU, 10,10);
# Root Check
if( $< != 0 )
{
die "Not root, can't chroot or take other precautions, dying\n";
}
# The chroot section
chdir("./jail") or
do {
mkdir "./jail";
chdir "./jail" or die "Failed to find a jail live in, couldn't make one either: $!\n";
};
chroot(".") or die $!;
# Here's where we actually drop our root privilege
$)="$nobody_uid $nobody_uid";
$(=$nobody_uid;
$<=$>=$nobody_uid;
POSIX::setgid($nobody_uid); #We just assume the uid is the same as the gid. Hot.
die "Failed to drop to nobody"
if $> != $nobody_uid
or $< != $nobody_uid;
my $kilo = 1024;
my $meg = $kilo * $kilo;
my $limit = 50 * $meg;
(
setrlimit(RLIMIT_DATA, $limit, $limit )
and
setrlimit(RLIMIT_STACK, $limit, $limit )
and
setrlimit(RLIMIT_NPROC, 1,1)
and
setrlimit(RLIMIT_NOFILE, 0,0)
and
setrlimit(RLIMIT_OFILE, 0,0)
and
setrlimit(RLIMIT_OPEN_MAX,0,0)
and
setrlimit(RLIMIT_LOCKS, 0,0)
and
setrlimit(RLIMIT_AS,$limit,$limit)
and
setrlimit(RLIMIT_VMEM,$limit, $limit)
and
setrlimit(RLIMIT_MEMLOCK,100,100)
and
setrlimit(RLIMIT_CPU, 10,10)
)
or die "Failed to set rlimit: $!";
#setrlimit(RLIMIT_MSGQUEUE,100,100);
die "Failed to drop root: $<" if $< == 0;
close STDIN;
$code =~ s/^\s*(\w+)\s*//
or die "Failed to parse code type! $code";
my $type = $1;
# Chomp code..
$code =~ s/\s*$//;
# Choose which type of evaluation to perform
# will probably be a dispatch table soon.
if( $type eq 'perl' or $type eq 'pl' ) {
perl_code($code);
}
elsif( $type eq 'javascript' ) {
javascript_code($code);
}
elsif( $type eq 'php' ) {
php_code($code);
}
elsif( $type eq 'deparse' ) {
deparse_perl_code($code);
}
elsif( $type eq 'k20' ) {
k20_code($code);
}
elsif( $type eq 'rb' or $type eq 'ruby' ) {
ruby_code($code);
}
elsif( $type eq 'py' or $type eq 'python' ) {
python_code($code);
}
elsif( $type eq 'lua' ) {
lua_code($code);
}
elsif( $type eq 'j' ) {
j_code($code);
}
exit;
#-----------------------------------------------------------------------------
# Evaluate the actual code
#-----------------------------------------------------------------------------
sub perl_code {
my( $code ) = @_;
local $@;
local @INC;
local $_;
$code = "no strict; no warnings; package main; $code";
my $ret = eval $code;
local $Data::Dumper::Terse = 1;
local $Data::Dumper::Quotekeys = 0;
local $Data::Dumper::Indent = 0;
local $Data::Dumper::Useqq = 1;
my $out = ref($ret) ? Dumper( $ret ) : "" . $ret;
print $out;
if( $@ ) { print "ERROR: $@" }
}
sub javascript_code {
my( $code ) = @_;
local $@;
my $js = JavaScript::SpiderMonkey->new;
$js->init;
# This is great evil!
JavaScript::SpiderMonkey::JS_ForceLatest( $js->{context} );
# Set up the Environment for ENVJS
$js->property_by_path("Envjs.profile", 0);
$js->function_set("print", sub { print @_ } );
for( qw/log debug info warn error/ ) {
$js->eval("Envjs.$_=function(x){}");
}
$js->eval($JSENV_CODE) or die $@;
my $modified_code = qq!
var ret = eval("\Q$code\E");
if( ret === null ) {
"null"
}
else if( typeof ret == "object" || typeof ret == "array" ) {
ret.toSource();
}
else { ret }
!;
print $js->ret_eval($modified_code);
if( $@ ) { print "ERROR: $@"; }
}
sub ruby_code {
my( $code ) = @_;
local $@;
print rb_eval( $code );
}
sub php_code {
my( $code ) = @_;
local $@;
#warn "PHP - [$code]";
my $php = PHP::Interpreter->new;
$php->set_output_handler(\ my $output );
$php->eval("$code;");
print $php->get_output;
#warn "ENDING";
if( $@ ) { print "ERROR: $@"; }
}
sub k20_code {
my( $code ) = @_;
$code =~ s/\r?\n//g;
Language::K20::k20eval( '."\\\\r ' . int(rand(2**31)) . '";' . "\n"); # set random seed
Language::K20::k20eval( $code );
}
sub python_code {
my( $code ) = @_;
py_eval( $code, 2 );
}
sub lua_code {
my( $code ) = @_;
#print lua_eval( $code )->();
my $ret = lua_eval( $code );
print ref $ret ? $ret->() : $ret;
}
sub j_code {
my( $code ) = @_;
Jplugin::jplugin( $code );
}

65
lib/Bot/.svn/entries
View file

@ -1,65 +0,0 @@
10
dir
475
svn://erxz.com/bb3/branches/perlbuut/lib/Bot
svn://erxz.com/bb3
2009-10-03T22:53:42.528878Z
475
simcop
dcb1cea6-7f7e-4c78-8a22-148ace8ce36e
BB3.pm
file
2009-10-03T22:54:20.000000Z
f2b19e514106047a357d6bc11cfaf54b
2009-10-03T22:53:42.528878Z
475
simcop
6143
BB3
dir

280
lib/Bot/.svn/text-base/BB3.pm.svn-base
View file

@ -1,280 +0,0 @@
package Bot::BB3;
use POE;
use POE::Session;
use POE::Wheel::Run;
use POE::Filter::Reference;
use Memoize qw/memoize/;
use Bot::BB3::ConfigParser;
use Bot::BB3::PluginManager;
use Bot::BB3::PluginConfigParser;
use Bot::BB3::Logger;
use Data::Dumper;
use strict;
sub new {
my( $class, $args ) = @_;
$args->{main_conf_file} ||= 'etc/bb3.conf';
$args->{plugin_conf_file} ||= 'etc/plugins.conf';
my $self = bless { args => $args }, $class;
$self->parse_main_conf( $args->{main_conf_file} );
$self->parse_plugin_conf( $args->{plugin_conf_file} );
$self->_initialize();
$self->_spawn_plugin_manager(); #Must be before spawn_pci, sigh
$self->_spawn_roles( $args->{only_roles} );
return $self;
}
#------------------------------------------------------------------------------
# Init methods
#------------------------------------------------------------------------------
sub _initialize {
my( $self ) = @_;
# WE create a session solely to register for
# a SIGINT handler, this is suboptimal
# but I don't know if it's required.
POE::Session->create(
object_states => [
$self => [qw/_start SIGINT/]
]
);
return 1;
}
sub _spawn_plugin_manager {
my( $self ) = @_;
$self->{ plugin_manager } = Bot::BB3::PluginManager->new(
$self->{ conf },
$self->{ plugin_conf },
$self,
);
}
sub _spawn_roles {
my( $self, $role_list ) = @_;
my $conf = $self->get_conf;
if( $role_list ) {
for( split /\s*,\s*/, $role_list ) { #We should never have spaces anyway
$self->_load_role( $_ ); # I hope they passed the correct module name..
}
}
else { #Load every Role we can find
for my $inc ( @INC ) {
for( glob "$inc/Bot/BB3/Roles/*" ) {
next unless s/\.pm$//;
s/^\Q$inc\///;
s{/}{::}g;
my $role_name = $_;
$role_name =~ s/^Bot::BB3::Roles:://;
warn "Role Name: $role_name";
warn "enabled: $conf->{roles}->{lc $role_name}->{enabled}\n";
unless(
exists $conf->{roles}->{lc $role_name}->{enabled}
and not $conf->{roles}->{lc $role_name}->{enabled}
) {
$self->_load_role( $_ );
}
}
}
}
}
sub _load_role {
my( $self, $role ) = @_;
warn "Attempting to load $role\n";
local $@;
eval "require $role;"; # Avoid having to turn Foo::Bar back in to Foo/Bar.pm..
if( $@ ) { warn "Failed to load $role: $@\n"; return; }
warn "Spawning $role\n";
$self->{$role} = $role->new(
$self->get_conf,
$self->{plugin_manager}, #Hack, maybe.. plugin_manager needs to be loaded first.
);
}
#------------------------------------------------------------------------------
# Public Methods
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
# Accessors
#------------------------------------------------------------------------------
sub get_conf {
$_[0]->{conf};
}
sub restart {
if( not -x $^X ) {
error "Can't restart ourself because [$^X], our executable, is no longer executable!";
return;
}
if( not -e $0 or not -r _ or -s _ < 100 ) {
error "Can't restart ourself because our bot probram [$0] is no longer in a useful state!";
return;
}
exec $^X, $0, @ARGV;
}
sub parse_main_conf {
my( $self, $conf_file ) = @_;
debug "Parsing config file [$conf_file]";
if( not -e $conf_file or not -r _ ) {
error "Failed to read conf_file [$conf_file]";
exit 1;
}
my $conf = Bot::BB3::ConfigParser->parse_file( $conf_file )
or die "Failed to parse a conf file! $BB3::Conf::PARSE_ERROR\n";
unless( keys %$conf ) {
error "Failed to successfully read [$conf_file]!";
exit 1;
}
my %conf_defaults = (
start_plugin_children => 4,
max_plugin_children => 10,
child_handle_count => 100,
http_plugin_port => 10080,
pastebot_plugin_port => 10081,
);
for( keys %conf_defaults ) {
#Sigh, where is my //=
$conf->{$_} = $conf_defaults{ $_ }
unless defined( $conf->{$_} );
}
debug Dumper $conf;
$self->{conf} = $conf;
return 1;
}
sub parse_plugin_conf {
my( $self, $conf_file ) = @_;
my $conf = Bot::BB3::PluginConfigParser->parse_file( $conf_file )
or die "Failed to parse Plugin Config File: $!\n";
$self->{plugin_conf} = $conf;
}
sub save_main_conf {
my( $self ) = @_;
my $conf = $self->get_conf;
my $conf_filename = $self->{args}->{main_conf_file};
if( not $conf_filename or not -e $conf_filename or not -w _ ) {
error "Couldn't find a valid file to write our conf to, tried [$conf_filename], " .
" either doesn't exist or not writable";
return;
}
Bot::BB3::ConfigParser->save_file( $conf_filename, $conf );
}
sub change_conf {
my( $self, $path, $value ) = @_;
my $conf = $self->get_conf;
if( $value =~ s/^\s*\[\s*// and $value =~ s/\s*\]\s*$// ) {
$value = [ split /\s*,\s*/, $value ];
}
warn "Change_conf initiated";
my $ref = $conf;
my @parts = split /\./, $path;
my $final_key = pop @parts;
for( @parts ) {
if( ref $ref eq 'HASH' ) {
$ref = $ref->{$_};
}
elsif( ref $ref eq 'ARRAY' ) {
$ref = $ref->[$_];
}
else {
error "Passed a path that didn't lead us properly down the rabbit hole. $path";
return;
}
}
warn "change_conf $ref -> $final_key -> $value";
return unless $ref and $final_key and length $value;
warn "Set something: ", $ref->{$final_key} = $value;
warn "New value: $ref->{$final_key}";
use Data::Dumper;
warn Dumper $ref;
warn Dumper $conf;
}
#------------------------------------------------------------------------------
# POE Methods
#------------------------------------------------------------------------------
sub _start {
my( $self, $kernel, $session ) = @_[OBJECT,KERNEL,SESSION];
$kernel->sig( INT => 'SIGINT' );
}
# This is called by a sigints. We ask the plugin manager
# to kill its children. We have to yield a exit call
# otherwise the plugin_manager's yield won't get processed.
# The above issue should be fixed by switching to the
# kernel->call interface. Delete this comment when verified.
sub SIGINT {
my( $self, $kernel ) = @_[OBJECT,KERNEL];
warn "Oh gads, SIGINT\n";
$self->{plugin_manager}->call( 'please_die' );
$kernel->stop;
exit;
}
1;

235
lib/Bot/BB3/.svn/entries
View file

@ -1,235 +0,0 @@
10
dir
475
svn://erxz.com/bb3/branches/perlbuut/lib/Bot/BB3
svn://erxz.com/bb3
2009-10-03T22:53:42.528878Z
475
simcop
dcb1cea6-7f7e-4c78-8a22-148ace8ce36e
Roles
dir
PluginManager.pm
file
476
2009-10-03T22:57:00.000000Z
3751182102a375087e40cca2bdf0ac29
2009-10-03T22:56:07.617451Z
476
simcop
17890
Logger.pm
file
2009-10-03T22:54:20.000000Z
49cf6477a067563ce902030fce806a5e
2009-10-03T22:53:42.528878Z
475
simcop
1128
MacroQuote.pm
file
2009-10-03T22:54:20.000000Z
2b55ae7ecca3fa5aff53016230c180fe
2009-10-03T22:53:42.528878Z
475
simcop
695
PluginWrapper.pm
file
2009-10-03T22:54:20.000000Z
663f0da688e8e2ebda03cdd14057b2b2
2009-10-03T22:53:42.528878Z
475
simcop
830
PluginConfigParser.pm
file
2009-10-03T22:54:20.000000Z
fcb4c41a5af270686e2b889049d1ada5
2009-10-03T22:53:42.528878Z
475
simcop
1097
ConfigParser.pm
file
2009-10-03T22:54:20.000000Z
6fc5957258ffdc3d5dee40f558545fd5
2009-10-03T22:53:42.528878Z
475
simcop
1546

66
lib/Bot/BB3/.svn/text-base/ConfigParser.pm.svn-base
View file

@ -1,66 +0,0 @@
package Bot::BB3::ConfigParser;
use Config::General;
use Bot::BB3::Logger;
use strict;
sub parse_file {
my( $class, $file ) = @_;
my $conf = {
Bot::BB3::ConfigParser->get_cg_object($file)->getall
};
# This is attempting to distinguish between the options such as:
# <bot MyBotName> </bot>
# and <bot> botname MyBotName </bot>
# type configurations also it handles either multiple
# bots or a single bot. Stupid config general.
# The ->botname bit is a check to make sure we're not dealing with
# a single <bot></bot> defined.
if( $conf->{bot} and ref $conf->{bot} eq 'HASH' and not $conf->{bot}->{botname} ) {
my $bots = $conf->{bot};
my @connections;
while( my( $botname, $options ) = each %$bots )
{
# More attempts at making Config::General behave itself.
next unless ref $options;
for my $options ( ref $options eq 'ARRAY' ? @$options : $options )
{
$options->{botname} = $botname;
push @connections, $options;
}
}
$conf->{bot} = \@connections;
}
# Again, specifically dealing with <bot></bot> thingy. SIGH.
elsif( $conf->{bot}->{botname} ) {
$conf->{bot} = [ $conf->{bot} ];
}
return $conf;
}
sub save_file {
my( $class, $filename, $conf ) = @_;
my $obj = Bot::BB3::ConfigParser->get_cg_object;
# Note that we tend to lose comments doing this..
$obj->save_file( $filename, $conf );
}
sub get_cg_object {
my( $class, $file ) = @_;
return Config::General->new(
-ConfigFile => $file,
-LowerCaseNames => 1,
-UseApacheInclude => 1,
-AutoTrue => 1
);
}
1;

64
lib/Bot/BB3/.svn/text-base/Logger.pm.svn-base
View file

@ -1,64 +0,0 @@
package Bot::BB3::Logger;
use strict;
use Term::ANSIColor qw/:constants/;
sub import {
my( $class ) = @_;
my $calling_package = caller;
no strict;
for( qw/debug log warn error/ ) {
*{"${calling_package}::$_"} = \&$_;
}
}
# goto &foo; automatically calls foo and passes it @_.
# it also removes the current subroutine from the callstack
# and yes I mostly do it for amusment.
sub debug {
unshift @_, 'debug';
goto &write_message;
}
sub log {
unshift @_, 'log';
goto &write_message;
}
sub warn {
unshift @_, 'warn';
goto &write_message;
}
sub error {
unshift @_, 'error';
goto &write_message;
}
my %COLOR_MAP = (
error => RED,
warn => YELLOW,
log => CYAN,
debug => MAGENTA,
);
sub write_message {
my( $level, @message ) = @_;
my( $package, $filename, $line, $sub ) = caller(1); # Ignore the rest of the args
my $message = "@message";
$sub =~ s/^${package}:://;
my $level_color = $COLOR_MAP{$level};
my $reset = RESET;
my $white = WHITE; # This is actually sort of gray..
# Default output
print STDERR "[$level_color$level$reset] $white$package - $line - $sub$reset: $message\n";
}
1;

20
lib/Bot/BB3/.svn/text-base/MacroQuote.pm.svn-base
View file

@ -1,20 +0,0 @@
# This package defines the quoting methods common between the
# quote and arg plugins.
package Bot::BB3::MacroQuote;
sub quote {
my($m,$s) = @_;
if ("z" eq $m) { # no-op
return $s;
} elsif ("c" eq $m || "d" eq $m) { # c-like quoting (without or with double-quote delimiter)
$s =~ s/([\x00\x01\n\r\x10\"\#\$\'\@\\])/sprintf"\\x%02x",ord$1/ge;
return "d" eq $m ? qq["$s"] : $s;
} elsif ("e" eq $m || "f" eq $m) { # quote almost everything
$s =~ s/(\W)/sprintf"\\x%02x",ord$1/ge;
return "f" eq $m ? qq["$s"] : $s;
} elsif ("h" eq $m) { # pack byte to two hex digits each, if nothing else this must work
return unpack "H*", $s;
} else { # unknown quoting mode
return $s;
}
}
1;

47
lib/Bot/BB3/.svn/text-base/PluginConfigParser.pm.svn-base
View file

@ -1,47 +0,0 @@
package Bot::BB3::PluginConfigParser;
use strict;
use Parse::RecDescent;
use Bot::BB3::Logger;
local $/;
my $grammar = <DATA>;
my $parser = Parse::RecDescent->new( $grammar );
sub parse_file {
my( $package, $filename ) = @_;
open my $fh, "< $filename" or die "$filename: $!";
local $/;
my $filecontents = <$fh>;
$parser->start( $filecontents );
}
1;
__DATA__
start: server(s)
{ $item[1] }
server: 'server' server_name '{' channel(s) '}'
{ [ $item[1], $item[2], $item[4] ] }
channel: 'channel' channel_name '{' plugin(s) '}'
{ [ $item[1], $item[2], $item[4] ] }
plugin: 'plugin' plugin_name '{' option(s?) '}'
{ [ $item[1], $item[2], { map @$_, @{$item[4]} } ] }
option: key ':' value semicolon(?)
{ [$item[1], $item[3]] }
semicolon: ';'
server_name: quoted_string | /[\w.]+/ | '*'
{ $item[1] }
channel_name: quoted_string | /#\w+/ | '*'
{ $item[1] }
plugin_name: quoted_string | /\w+/ | '*'
{ $item[1] }
key: quoted_string | /\w+/
{ $item[1] }
value: quoted_string | /\w+/
{ $item[1] }
quoted_string: /"[^"]+"/
{ my $str = $item[1]; $str =~ s/^"//; $str =~ s/"$//; $str }

771
lib/Bot/BB3/.svn/text-base/PluginManager.pm.svn-base
View file

@ -1,771 +0,0 @@
package Bot::BB3::PluginManager;
use Bot::BB3::PluginWrapper;
use Bot::BB3::Logger;
use POE;
use Data::Dumper;
use Text::Glob qw/match_glob/;
use Memoize;
use strict;
sub new {
my( $class, $main_conf, $plugin_conf, $bb3 ) = @_;
my $self = bless {
main_conf => $main_conf,
plugin_conf => $plugin_conf,
bb3 => $bb3, # A bit hacky, only used for special commands from plugin at the moment
}, $class;
$self->{child_cache} = $self->create_cache;
$self->_load_plugins();
$self->{session} = POE::Session->create(
object_states => [
$self => [ qw/
_start execute_said handle_said_queue adjust_child_count
please_die child_flushed child_output child_err child_fail
child_close child_die child_time_limit
/ ]
]
);
return $self;
}
#---------------------
# Helpers and accessors
#---------------------
sub yield {
my ( $self, $event, @args ) = @_;
warn "YIELD CALLED: $event\n";
return POE::Kernel->post( $self->{session}, $event, @args );
}
sub call {
my ( $self, $event, @args ) = @_;
warn "CALL CALLED: $event\n";
return POE::Kernel->call( $self->{session}, $event, @args );
}
sub get_main_conf {
return $_[0]->{main_conf};
}
sub get_plugin_conf {
return $_[0]->{plugin_conf};
}
sub get_plugins {
my( $self ) = @_;
return $self->{plugins};
}
sub get_plugin {
my( $self, $name ) = @_;
# Loops are cool.
# O(n) but nobody cares because it's rarely used.
# HA HA THIS IS A LIE.
for( @{ $self->{plugins} } ) {
if( $name eq $_->{name} ) {
return $_;
}
if( $_->{aliases} ) {
for my $alias ( @{ $_->{aliases} } ) {
return $_ if $name eq $alias;
}
}
}
return;
}
memoize( 'get_plugin' ); #Fixes that pesk O(n) thingy.
sub kill_children {
my( $self ) = @_;
for( values %{ $self->{children} } ) {
warn "KILLING: ", $_->{wheel}->PID, ": ",
kill( 9, $_->{wheel}->PID ); #DIE DIE DIE
}
}
sub reload_plugins {
my( $self ) = @_;
delete $self->{plugins};
$self->_load_plugins();
# In theory we just kill our children and they're
# automatically respawned by the various child
# death handlers.
$self->kill_children();
}
sub create_cache {
my( $self ) = @_;
eval { require Cache::FastMmap; }
and return Cache::FastMmap->new( share_file => "var/cache-fastmmap", init_file => 1 );
eval { require Cache::Mmap; }
and return Cache::Mmap->new( "var/cache-mmap", { buckets => 89, bucketsize => 64 * 1024 } );
eval { require Cache::File; }
and return Cache::File->new( cache_root => 'var/cache-file', default_expires => '6000 sec' );
die "Failed to properly create a cache object! Please install Cache::FastMmap, Cache::Mmap or Cache::File\n";
}
#---------------------
# Loading methods
#---------------------
sub _load_plugins {
my( $self ) = @_;
my $plugin_dir = $self->{main_conf}->{plugin_dir} || 'plugins';
opendir my $dh, $plugin_dir or die "Failed to open plugin dir: $plugin_dir: $!\n";
while( defined( my $file = readdir $dh ) ) {
next unless $file =~ /\.pm$/;
local $@;
local *DATA; # Prevent previous file's __DATA__
# sections being read for this new file.
my $plugin_return = do "$plugin_dir/$file";
if( not $plugin_return or $@ ) {
error "Failed to load plugin: $plugin_dir/$file $@\n";
next;
}
(my $name = $file) =~ s/\.pm$//;
my $plugin_obj;
my $help_text;
if( ref $plugin_return eq 'CODE' ) {
$plugin_obj = Bot::BB3::PluginWrapper->new( $name, $plugin_return );
$help_text = join '', <DATA>;
}
elsif( ref $plugin_return eq '' ) { #String representing package name, I hope
local $@;
eval {
$plugin_obj = $plugin_return->new();
# Fo' Realz.
# strict won't let me abuse typeglob symbolic refs properly!
no strict;
if( *{"${plugin_return}::DATA"}{IO} ) {
$help_text = join '', readline *{"${plugin_return}::DATA"};
}
};
if( not $plugin_obj or $@ ) {
warn "Failed to instantiate $plugin_return from $plugin_dir/$file $@\n";
next;
}
}
if( not $plugin_obj ) {
warn "Failed to get a plugin_obj from $plugin_dir/$file for unknown reasons $plugin_return.\n";
next;
}
$plugin_obj->{help_text} = $help_text;
push @{ $self->{plugins} }, $plugin_obj;
}
$self->_pre_build_plugin_chain();
$self->_pre_load_default_plugin();
for my $plugin ( @{ $self->{plugins} } ) {
local $@;
$plugin->can("postload") and
eval { $plugin->postload($self) };
if( $@ ) { warn "$plugin->{name}: postload failed: $@"; }
}
return scalar @{ $self->{plugins} };
}
sub _pre_build_plugin_chain {
my( $self ) = @_;
my $plugins = $self->{plugins};
my( $pre,$post,$commands,$handlers );
for my $plugin ( @$plugins ) {
my $opts = $plugin->{opts};
if( $opts->{pre_process} ) {
push @$pre, $plugin;
}
if( $opts->{post_process} ) {
push @$post, $plugin;
}
if( $opts->{command} ) {
$commands->{ $plugin->{name} } = $plugin;
if( $plugin->{aliases} ) {
$commands->{ $_ } = $plugin
for @{ $plugin->{aliases} };
}
}
if( $opts->{handler} ) {
push @$handlers, $plugin;
}
}
$self->{plugin_chain} = {
pre_process => $pre,
post_process => $post,
commands => $commands,
handlers => $handlers
};
}
sub _pre_load_default_plugin {
my( $self ) = @_;
if( my $default = $self->{main_conf}->{plugin_manager}->{default_plugin} ) {
if( not ref $default ) { $default = [$default] } # Clean up Config::General randomness
my @default_chain;
for( @$default ) {
my @plugins = split " ", $_; #I'm not really sure what the format is. Also, magic split.
for( @plugins ) {
my $plugin = $self->get_plugin( $_ );
if( $plugin ) { push @default_chain, $plugin }
}
}
$self->{default_plugin_chain} = \@default_chain;
}
else {
$self->{default_plugin_chain} = [];
}
}
#--------------------------------
# Executed inside the forked child
#--------------------------------
sub _start_plugin_child {
my( $self ) = @_;
srand; # We deliberately call srand since when we fork all children will have the same initial seed
#POE::Kernel->run; # Attempt to suppress the warning about ->run never being called.
for( @{ $self->get_plugins } ) {
if( $_->can('initialize') ) {
local $@;
eval { $_->initialize($self, $self->{child_cache}) };
if( $@ ) { warn "$_->{name} failed to initialize: $@"; }
}
}
my $filter = POE::Filter::Reference->new;
binmode( STDIN ); binmode( STDOUT );
my $handled_counter = 0;
while( 1 ) {
my $stream;
sysread STDIN, $stream, 4096
or die "Child $$ failed to read: $!\n";
my $filter_refs = $filter->get( [$stream] );
for my $said ( @$filter_refs ) {
$handled_counter++;
#-----
# Execute chain
#-----
my $chain = $self->_create_plugin_chain( $said );
# Only add the default if we're being addressed
if( $said->{addressed} ) {
push @{ $chain->[1] }, @{ $self->{default_plugin_chain} }; # Append default plugins to the command section
# of the plugin chain
}
my $results = $self->_execute_plugin_chain( $said, $chain );
warn "Got some output: [$results]\n";
if( $results !~ /\S/ and $said->{addressed} ) {
#$results = "Couldn't match input.";
}
#----
# Output
#----
#if( length $results and $results =~ /\S/) {
# Always output something so the handler knows we're done.
for( @{$filter->put([ [$said, $results] ])} ) {
syswrite STDOUT, $_;
}
#}
}
if( $handled_counter > $self->{main_conf}->{child_handle_count} ) {
last;
}
}
warn "$$: Fell off the end, exiting\n";
# Exit the child
exit;
}
sub _create_plugin_chain {
my( $self, $said ) = @_;
my $pre_built_chains = $self->{plugin_chain};
my( $pre, $post ) = @{$pre_built_chains}{ qw/pre_process post_process/ };
my $handlers = $self->_filter_plugin_list( $said, $pre_built_chains->{ handlers } );
;
#---
# Parse said/commands
#---
my $commands = $pre_built_chains->{commands};
my $command_list = $self->_parse_for_commands( $said, $commands );
return [ $pre, $command_list, $handlers, $post ];
}
sub _parse_for_commands {
my( $self, $said, $commands ) = @_;
my $command_re = join '|', map "\Q$_", keys %$commands;
$command_re = qr/$command_re/; #TODO move to _pre_build_chains and switch to Trie
if( $said->{body} =~ s/^\s*($command_re)[ \t:,;.-]\s*(.+)/$2/
or $said->{body} =~ s/^\s*($command_re)\s*$// ) {
my $found_command = $1;
my $args = $2;
my $command = $commands->{ $found_command };
warn "found $found_command - $args\n";
# takes and returns array ref
my $filter_check = $self->_filter_plugin_list( $said, [$command] );
if( @$filter_check ) { # So check if the one argument passed
# Return an array ref..
$said->{recommended_args} = [ split /\s+/, $args ];
$said->{command_match} = $found_command;
return $filter_check;
}
}
return [];
}
sub _filter_plugin_list {
my( $self, $said, $plugins ) = @_;
my @chain;
for( @$plugins ) {
my $conf = $self->plugin_conf( $_->{name}, $said->{server}, $said->{channel} );
# Explicitly skip addressed checks for special channels
if( $said->{channel} !~ /^\*/ ) {
next if $conf->{addressed} and not $said->{addressed};
}
next if $conf->{access} eq 'op' and not ( $said->{by_chan_op} or $said->{by_root} );
next if $conf->{access} eq 'root' and not $said->{by_root};
push @chain, $_;
}
return \@chain;
}
sub _execute_plugin_chain {
my( $self, $said, $chain ) = @_;
my( $pre, $commands, $handlers, $post ) = @$chain;
for( @$pre ) {
$_->pre_process( $said, $self );
}
my $total_output = [];
for( @$commands ) {
local $@;
my( $return, $output ) = eval { $_->command( $said, $self ) };
if( $@ ) { push @$total_output, "Error: $@"; next; }
warn "$_->{name} - $return - $output\n";
push @$total_output, $output;
if( $return eq 'handled' ) {
last;
}
}
for( @$handlers ) {
local $@;
my( $output ) = eval { $_->handle( $said, $self ) };
if( $@ ) { push @$total_output, "Error: $@"; next; }
push @$total_output, $output;
}
my $output = join " ", @$total_output;
for( @$post ) {
$_->post_process( $said, $self, \$output );
}
return $output;
}
#--------------------------------
# Note, really queues the event.
# Should definitely only be called by
# external users at this point..
sub execute_said {
my( $self, $kernel, $sender, $said ) = @_[OBJECT,KERNEL,SENDER,ARG0];
$said->{parent_session} = $sender->ID unless $said->{parent_session};
warn "Queuing said.. $said->{body}\n";
push @{ $self->{said_queue} }, $said;
$self->yield( 'handle_said_queue' );
}
sub handle_said_queue {
my( $self, $kernel ) = @_[OBJECT,KERNEL];
my $queue = $self->{said_queue};
my $children = [ values %{ $self->{children} } ];
return unless $queue and @$queue;
while( defined( my $said = shift @$queue ) ) {
warn "Queuing $said\n";
for( @$children ) {
warn "Checking ", $_->{wheel}->PID, ": $_->{queue}";
if( not $_->{queue} ) {
$_->{queue} = $said;
$_->{wheel}->put( $said );
$said->{attempts}++;
warn "Queueing $said for ", $_->{wheel}->PID;
last;
}
}
}
if( $queue and @$queue ) {
$kernel->delay( handle_said_queue => 2 );
}
}
# Helper method!
sub _spawn_child {
my( $self ) = @_;
my $child = POE::Wheel::Run->new(
Program => sub { $self->_start_plugin_child; },
NoSetSid => 1, #Ensure that SIGINTS to the main process kill our children
StdioFilter => POE::Filter::Reference->new,
StderrFilter => POE::Filter::Line->new,
StdinEvent => 'child_flushed',
StdoutEvent => 'child_output',
StderrEvent => 'child_err',
ErrorEvent => 'child_fail',
CloseEvent => 'child_close',
);
#push @{ $self->{children} }, $child;
my $child_struct = {
wheel => $child,
graceful_shutdown => 0,
queue => 0,
};
$self->{children}->{ $child->ID } = $child_struct;
$self->{children_by_pid}->{ $child->PID } = $child->ID;
warn "Created child: ", $child->ID;
$poe_kernel->sig_child( $child->PID, 'child_die' );
}
# This is probably called multiple times every time a child dies
# so we need to make sure it gracefully handles all of the possible
# cases.
sub child_die {
my( $self, $pid ) = @_[OBJECT,ARG1];
my $id = delete $self->{children_by_pid}->{$pid};
return unless $id;
# Delete child operation
warn "Deleting: $id";
my $child = delete $self->{children}->{$id};
return unless $child;
# If the dead child had a queue ready then we requeue to make sure it
# gets handled eventually.
# If the $said has been tried a couple of times it's probably causing
# the child to die some how, so we skip it.
if( $child->{queue} and $child->{queue}->{attempts} < 2 ) {
#TODO methodize! (unshift and handle)
unshift @{ $self->{said_queue} }, $child->{queue};
$self->yield( 'handle_said_queue' );
}
# Go go gadget reproduction.
$self->_spawn_child;
}
#---------------------------------------------
# Getters
#---------------------------------------------
sub get_children {
return values %{ $_[0]->{children} };
}
#---------------------------------------------
sub _start {
my( $self, $kernel ) = @_[OBJECT,KERNEL];
my $start_child_count = $self->{main_conf}->{start_plugin_children};
for( 1 .. $start_child_count ) {
$self->_spawn_child();
}
$kernel->delay_set( 'adjust_child_count', 5 );
}
sub adjust_child_count {
my( $self, $kernel ) = @_[OBJECT,KERNEL];
#for( @w
}
sub child_flushed {
my( $self, $kernel, $child_id ) = @_[OBJECT,KERNEL,ARG0];
my $child = $self->{children}->{$child_id};
$child->{flush_time} = time;
$kernel->delay_set( child_time_limit => 25, $child_id, $child->{queue} );
warn "Flushed to child $child_id\n";
}
sub child_output {
my( $self, $kernel, $output, $child_id ) = @_[OBJECT,KERNEL,ARG0,ARG1];
my( $said, $text ) = @$output;
warn "Got some child output! $text\n";
my $child = $self->{children}->{$child_id};
warn "Deleting child queue: $child_id, $child->{queue}";
$child->{queue} = undef;
$self->yield('handle_said_queue');
#TODO turn into a method (respond to parent)
my $parent = $said->{parent_session};
if( my $commands = delete $said->{special_commands} ) {
for( @$commands ) {
my $name = shift @$_;
if( $name =~ s/^pci_// ) {
$kernel->post( $parent => handle_special_commands => $said, $name, @$_ );
}
elsif( $name =~ s/^pm_// ) {
$self->$name( @$_ );
}
elsif( $name =~ s/^bb3_// ) {
$self->{bb3}->$name( @$_ );
}
}
}
#if( length $text and $text =~ /\S/) {
# Always post back to our user.
$kernel->post( $parent => 'plugin_output', $said, $text );
#}
}
sub child_err {
my( $self, $err_output, $child_id ) = @_[OBJECT,ARG0,ARG1];
return unless $err_output =~ /\S/;
warn "\n\tChild $child_id: $err_output\n";
}
sub child_fail {
my( $self, $op, $err_num, $err_str, $child_id ) = @_[OBJECT,ARG0,ARG1,ARG2,ARG3];
my $child = $self->{children}->{$child_id};
return unless $child;
warn "Crap, our child $child_id failed: $op $err_num $err_str\n";
$self->yield( child_die => $child->{wheel}->PID );
}
sub child_close {
my( $self, $child_id ) = @_[OBJECT,ARG0];
my $child = $self->{children}->{$child_id};
return unless $child;
warn "Child $child_id closed\n";
$self->yield( child_die => $child->{wheel}->PID );
}
sub child_time_limit {
my( $self, $kernel, $child_id, $queue_ref ) = @_[OBJECT,KERNEL,ARG0,ARG1];
my $child = $self->{children}->{$child_id};
warn "Checking the time limit on $child_id";
if( $child and $child->{queue} == $queue_ref ) {
if( time() - $child->{flush_time} > 20 ) {
warn "Killing $child_id because $child->{flush_time} is more than 20 ago from ", time();
kill 9, $child->{wheel}->PID;
}
else {
$kernel->delay_set( child_time_limit => 10, $child_id, $queue_ref );
}
}
# If they don't match, child has already responded and we can ignore it.
}
sub please_die {
my( $self, $kernel ) = @_[OBJECT,KERNEL];
$self->kill_children();
}
#-------------------
# Slightly less random cruft.
# Used by plugins. Move to common
# plugin base class?
#-------------------
sub create_table {
my( $self, $dbh, $table_name, $create_table_sql ) = @_;
local $@;
eval {
$dbh->do("SELECT * FROM $table_name LIMIT 1");
};
if( $@ =~ /no such table/ ) {
# Race Conditions could cause two threads to create this table.
local $@;
eval {
$dbh->do( $create_table_sql );
};
# Stupid threading issues.
# All of the children try to do this at the same time.
# Suppress most warnings.
if( $@ and $@ !~ /already exists/ and $@ !~ /database schema has changed/ ) {
error "Failed to create table: $@\n";
}
#Success!
}
elsif( $@ ) {
error "Failed to access dbh to test table: $@";
warn "Caller: ", join " ", map "[$_]", caller;
}
}
#-------------------------------------------
# Random cruft
# Should probably be moved somewhere.
#-------------------------------------------
{
my %plugin_conf_cache;
sub plugin_conf
{
my( $self, $command, $server, $channel ) = @_;
my $plugin_conf = $self->{plugin_conf};
if( local $_ = $plugin_conf_cache{$server}->{$channel}->{$command} ) {
return $_;
}
my $opts = {};
for( @$plugin_conf )
{
my $glob = $_->[1];
if( match_glob( lc $glob, lc $server ) )
{
for( @{ $_->[2] } )
{
if( match_glob( lc $_->[1], lc $channel ) )
{
for( @{ $_->[2] } )
{
if( match_glob( lc $_->[1], lc $command ) )
{
my $new_opts = $_->[2];
$opts = { %$opts, %$new_opts };
}
}
}
}
}
}
# Convert 'false' type strings into perl false values.
for( keys %$opts )
{
my $v = $opts->{$_};
if( $v eq 'false' or $v eq 'null' or $v eq 'off' or $v eq 0 )
{
$opts->{$_} = undef;
}
}
$plugin_conf_cache{$server}->{$channel}->{$command} = $opts;
return $opts;
}
}
1;

56
lib/Bot/BB3/.svn/text-base/PluginWrapper.pm.svn-base
View file

@ -1,56 +0,0 @@
package Bot::BB3::PluginWrapper;
use strict;
{
package PluginWrapper::WrapSTDOUT;
sub TIEHANDLE {
my( $class, $buffer_ref ) = @_;
return bless { buffer => $buffer_ref }, $class;
}
sub PRINT {
my( $self, @args ) = @_;
${ $self->{buffer} } .= join $", @args;
return 1;
}
sub PRINTF {
my( $self, $format, @args ) = @_;
${ $self->{buffer} } .= sprintf $format, @args;
return 1;
}
}
sub new {
my( $class, $name, $coderef ) = @_;
my $self = bless { coderef => $coderef, name => $name }, $class;
$self->{opts} = {
command => 1,
};
return $self;
}
sub command {
my( $self, $said, $pm ) = @_;
my( $name ) = $self->{name};
my $output;
local *STDOUT;
tie *STDOUT, 'PluginWrapper::WrapSTDOUT', \$output;
$self->{coderef}->($said,$pm);
untie *STDOUT;
return( 'handled', $output );
}
1;

198
lib/Bot/BB3/Roles/.svn/entries
View file

@ -1,198 +0,0 @@
10
dir
475
svn://erxz.com/bb3/branches/perlbuut/lib/Bot/BB3/Roles
svn://erxz.com/bb3
2009-10-03T22:53:42.528878Z
475
simcop
dcb1cea6-7f7e-4c78-8a22-148ace8ce36e
SocketMessageIRC.pm
file
2009-10-03T22:54:20.000000Z
10275c1032b5d50d7e178744819a469a
2009-10-03T22:53:42.528878Z
475
simcop
1666
IRC.pm
file
476
2009-10-03T22:57:00.000000Z
ecb2d397d28a39c350728a2f504a70b3
2009-10-03T22:56:07.617451Z
476
simcop
has-props
14353
Web.pm
file
476
2009-10-03T22:57:00.000000Z
669673837edc7d1a4285a93495e80b33
2009-10-03T22:56:07.617451Z
476
simcop
has-props
3341
PasteBot.pm
file
2009-10-03T22:54:20.000000Z
0aac2e184b8116ec32a22f354ff7876b
2009-10-03T22:53:42.528878Z
475
simcop
7515
Console.pm
file
476
2009-10-03T22:57:00.000000Z
38ec47f6cca221c35dbbc31c2960891e
2009-10-03T22:56:07.617451Z
476
simcop
has-props
2857

5
lib/Bot/BB3/Roles/.svn/prop-base/Console.pm.svn-base
View file

@ -1,5 +0,0 @@
K 13
svn:mergeinfo
V 0
END

5
lib/Bot/BB3/Roles/.svn/prop-base/IRC.pm.svn-base
View file

@ -1,5 +0,0 @@
K 13
svn:mergeinfo
V 0
END

5
lib/Bot/BB3/Roles/.svn/prop-base/Web.pm.svn-base
View file

@ -1,5 +0,0 @@
K 13
svn:mergeinfo
V 0
END

142
lib/Bot/BB3/Roles/.svn/text-base/Console.pm.svn-base
View file

@ -1,142 +0,0 @@
package Bot::BB3::Roles::Console;
use POE;
use POE::Session;
use POE::Wheel::SocketFactory;
use strict;
use Bot::BB3::Logger;
sub new {
my( $class, $conf, $pm ) = @_;
my $self = bless { conf => $conf, pm => $pm }, $class;
$self->spawn_session;
return $self;
}
sub spawn_session {
my( $self ) = @_;
$self->{session} = POE::Session->create(
object_states => [
$self => [
qw/_start
socket_new factory_fail
socket_read socket_write plugin_output/
]
]
);
return $self;
}
sub _start {
my( $self ) = @_[OBJECT];
$self->{socket_factory} = POE::Wheel::SocketFactory->new(
BindAddress => "127.0.0.1",
BindPort => $self->{conf}->{roles}->{console}->{port} || 10041,
SuccessEvent => 'socket_new',
FailureEvent => 'factory_fail',
Reuse => 'on',
);
}
sub socket_new {
my( $self, $handle ) = @_[OBJECT,ARG0];
warn "Got a socket: $handle\n";
my $wheel = POE::Wheel::ReadWrite->new(
Handle => $handle,
Driver => POE::Driver::SysRW->new,
InputFilter => POE::Filter::Line->new,
OutputFilter => POE::Filter::Stream->new,
InputEvent => 'socket_read',
FlushedEvent => 'socket_write',
ErrorEvent => 'socket_error',
);
$self->{wheels}->{$wheel->ID} = $wheel;
}
sub socket_error {
my( $self, $op, $errstr, $errnum, $id ) = @_[OBJECT,ARG0..ARG3];
#TODO figure out which errors we don't care about.
warn "Socket Error: $op - $errstr - $errnum\n";
delete $self->{wheels}->{$id};
}
sub factory_fail {
my( $self, $op, $errstr, $errnum, $id ) = @_[OBJECT,ARG0..ARG3];
warn "Help, I'm falling! $op - $errstr $errnum";
#Attempt a respawn
delete $self->{session};
# TODO look for ways to stop a session?
$self->spawn_session;
}
sub socket_write {
my( $self, $id ) = @_[OBJECT,ARG0];
warn "Written some data to $id\n";
}
sub socket_read {
my( $self, $input, $id ) = @_[OBJECT,ARG0,ARG1];
#$input is a line containing a command
s/^\s+//,s/\s+$// for $input;
my( $command, @args ) = split /\s+/, $input;
# Command disabled since we don't have access
# to that object any more.
my %special_commands = (
#'list_pcis' => sub {
#my $ic=$self->{parent}->{irc_components};
#for( keys %$ic ) {
#$self->{wheels}->{$id}->put( "$_: " . $ic->{$_}->server_name . "\n" );
#}
#},
);
if( exists $special_commands{$command} ) {
$special_commands{$command}->();
}
else {
my $said = {
body => $input,
raw_body => $input,
my_name => 'CommandConsole',
addressed => 1,
recommended_args => \@args,
channel => '*special',
name => 'CC',
ircname => 'CC',
host => '*special',
server => '*special',
pci_id => $id,
};
$self->{pm}->yield( execute_said => $said );
}
}
sub plugin_output {
my( $self, $said, $output ) = @_[OBJECT,ARG0,ARG1];
my $wheel_id = $said->{pci_id};
$self->{wheels}->{$wheel_id}->put( "$output\n" );
}
1;

546
lib/Bot/BB3/Roles/.svn/text-base/IRC.pm.svn-base
View file

@ -1,546 +0,0 @@
package Bot::BB3::Roles::IRC;
use Bot::BB3::Logger;
use POE;
use POE::Session;
use POE::Wheel::Run;
use POE::Filter::Reference;
use POE::Component::IRC::Common qw/parse_user l_irc/;
use POE::Component::IRC::State;
use POE::Component::IRC::Plugin::AutoJoin;
use POE::Component::IRC::Plugin::Connector;
use POE::Component::IRC::Plugin::NickReclaim;
use Memoize qw/memoize/;
use Data::Dumper;
use Socket;
use utf8;
use strict;
sub new {
my( $class, $conf, $plugin_manager ) = @_;
my $self = bless { conf => $conf, pm => $plugin_manager }, $class;
my $bots = $self->{conf}->{bot};
warn Dumper $bots;
for( @$bots ) {
warn "Spawning Bot: ", Dumper $_;
# Blah blah evil
my $ip = `/sbin/ifconfig | perl -nle' if( /inet addr:(\\d+\\.\\d+\\.\\d+\\.\\d+)/ ) { print \$1; exit }'`;
# This is to fix a bug with dcc not recognizing our ip..
my $poco_irc = POE::Component::IRC::State->spawn(
nick => $_->{nick} || $_->{botname},
username => $_->{username} || $_->{nick} || $_->{botname},
$_->{password} ? (password => $_->{password}) : (),
server => $_->{server},
port => $_->{port} || 6667,
ircname => $_->{ircname} || $_->{nick} || $_->{botname},
);
# Fixes a bug where our remote IP was being sent as 0.0.0.0
# TODO remove obviously, but maybe add a configuration option to do this.
# set to 'dynamic' or a host/ip name.
$poco_irc->{dcc}->nataddr($ip); #Hideously violate encapsulation because I think we need to..
$poco_irc->plugin_add(
AutoJoin => POE::Component::IRC::Plugin::AutoJoin->new(
Channels => $_->{channel}
)
);
$poco_irc->plugin_add( Connector => POE::Component::IRC::Plugin::Connector->new );
$poco_irc->plugin_add( Reclaim => POE::Component::IRC::Plugin::NickReclaim->new( poll => 120 ) );
my $pci_id = $poco_irc->session_id;
$self->{bot_confs}->{ $pci_id } = $_;
$self->{irc_components}->{ $pci_id } = $poco_irc;
$self->_build_ignore_hash( $pci_id, $_ );
}
$self->{session} = POE::Session->create(
object_states => [
$self => [ qw/
_start
irc_001
irc_public
irc_ctcp_action
irc_join
irc_invite
irc_msg
irc_registered
irc_474
irc_dcc_request
irc_dcc_start
irc_dcc_chat
irc_ctcp_chat
plugin_output
handle_special_commands
external_message
clear_dynamic_ignore
channel_list
stop_talking
start_talking
comfuckpong
/
]
],
);
return $self;
}
sub _build_ignore_hash {
my( $self, $pci_id, $pci_conf ) = @_;
for( @{ $pci_conf->{ignore} } ) {
$self->{bot_ignores}->{$pci_id}->{l_irc $_} = $pci_id;
}
}
#------------------------------------------------------------------------------
# PUBLIC METHODS
#------------------------------------------------------------------------------
sub comfuckpong
{
my ($sender, $kernel, $heap) = @_[SENDER, KERNEL, HEAP];
my $d = $heap->{irc}->server_name();
$heap->{irc}->yield( quote => "PONG $d\n");
$kernel->delay_add(comfuckpong => 50);
}
sub get_bot_conf {
my( $self, $poco_irc ) = @_;
my $id = ( ref $poco_irc ) ? $poco_irc->session_id : $poco_irc;
return $self->{bot_confs}->{ $id };
}
sub get_aliases {
my( $self, $pci ) = @_;
my $conf = $self->get_bot_conf( $pci );
my @alias_return;
my $aliases = $conf->{alias};
if( not ref $aliases ) { $aliases = [ $aliases ]; }
my $aliase_res = $conf->{alias_re};
if( not ref $aliase_res ) { $aliase_res = [ $aliase_res ] }
return [ grep defined, @$aliase_res, map "\Q$_", grep defined, @$aliases ];
}
memoize( 'get_aliases' );
sub get_component {
my( $self, $pci_id ) = @_;
return $self->{irc_components}->{ $pci_id };
}
sub is_ignored {
my( $self, $said ) = @_;
my $lc_nick = l_irc $said->{name};
my $lc_body = l_irc $said->{body};
if( exists $self->{bot_ignores}->{$said->{pci_id}}->{$lc_nick} ) {
return 1;
}
my $msg_queue = $self->{dynamic_ignores}->{$said->{pci_id}}->{$lc_nick} ||= [];
push @$msg_queue, $lc_body;
$poe_kernel->delay_set( clear_dynamic_ignore => 10, $said->{pci_id}, $lc_nick );
my $match_count;
for( @$msg_queue ) {
if( $_ eq $lc_body ) {
if( ++$match_count > 4 ) {
return 1;
}
}
}
return;
}
sub dispatch_said {
my( $self, $said ) = @_;
use Data::Dumper;
warn "DISPATCH_SAID $said->{pci_id} = $said->{channel}\n";
warn Dumper $self->{squelched_channels};
if( $self->{squelched_channels}->{$said->{pci_id}}->{lc $said->{channel}}
and not $said->{addressed}
) {
return;
}
warn "Sending on execute_said\n";
$self->{pm}->yield( execute_said => $said );
}
#------------------------------------------------------------------------------
# POE STATES
#------------------------------------------------------------------------------
sub _start {
my( $self, $kernel, $session ) = @_[OBJECT,KERNEL,SESSION];
$kernel->signal( $kernel, 'POCOIRC_REGISTER', $session->ID, 'all' );
$kernel->alias_set( __PACKAGE__ );
}
sub stop_talking {
my( $self, $poco_id, $channel ) = @_[OBJECT,ARG0,ARG1];
warn "RECEIVED STOP TALKING: $poco_id, $channel\n";
$self->{squelched_channels}->{$poco_id}->{lc $channel} = 1;
}
sub start_talking {
my( $self, $poco_id, $channel ) = @_[OBJECT,ARG0,ARG1];
delete $self->{squelched_channels}->{$poco_id}->{lc $channel};
}
sub irc_registered {
my( $self, $sender, $kernel, $pci ) = @_[OBJECT,SENDER,KERNEL,ARG0];
$pci->yield( connect => {} );
}
sub _said {
my( $self, $sender, $kernel ) = @_[OBJECT,SENDER,KERNEL];
my $caller = ((caller(1))[3]);
$caller =~ /:([^:]+)$/ and $caller = $1;
my $pci = $self->get_component($sender->ID);
my $said = {};
$said->{server} = $pci->server_name;
$said->{my_name} = $pci->nick_name;
$said->{pci_id} = $pci->session_id;
#--------------------------
# Method Specific Logic
#--------------------------
if( $caller eq 'irc_public' ) {
$said->{ sender_raw } = $_[ARG0];
$said->{ body_raw } = $_[ARG2];
$said->{ channel } = $_[ARG1]->[0];
}
elsif( $caller eq 'irc_msg' ) {
$said->{ sender_raw } = $_[ARG0];
$said->{ body_raw } = $_[ARG2];
$said->{ channel } = '*irc_msg';
$said->{ addressed } = 1;
}
elsif( $caller eq 'irc_ctcp_action' ) {
$said->{ sender_raw } = $_[ARG0];
$said->{ body_raw } = $_[ARG2];
$said->{ channel } = $_[ARG1]->[0];
}
elsif( $caller eq 'irc_dcc_chat' ) {
$said->{ body_raw } = $_[ARG3];
$said->{ channel } = '*dcc_chat';
$said->{ addressed } = 1;
# We only get the IP Address from the dcc_chat events so we need to try to
# turn it back in to a hostname, since that's usually what we have here
# Presumably the irc server is normally doing a rdns lookup anyway
# which is what we're trying to emulate here.
# In this case we pack the IP address and an arbitrary port (80) in to a
# magically opaque struct and then unpack it back in to .. something
# using sockaddr_in and then we can get the hostname from gethostbyaddr
my $addr_struct = pack_sockaddr_in( 80, inet_aton($_[ARG4]) );
my($port,$iaddr)=sockaddr_in($addr_struct);
$said->{ host } = gethostbyaddr($iaddr,AF_INET());
# Recreate the sender_raw in the form of nick!nick@hostname so our root check
# later on will work properly
$said->{ sender_raw } = $_[ARG1] . '!' . $_[ARG1] . '@' . $said->{host};
}
else {
die "ERROR, _said called by unknown caller: $caller";
}
#--------------------------
my @user_info = parse_user( $said->{ sender_raw } );
for( qw/name ircname host/ ) {
if( not defined $user_info[0] ) {
last;
}
$said->{$_} = shift @user_info;
}
#--------------------------
# Check for our own name
#--------------------------
$said->{body} = $said->{body_raw};
if( $said->{my_name} ) { #TODO verify that we need this if check.
my $body = $said->{body_raw};
my $aliases = $self->get_aliases( $pci );
my $name_re = "(?:" . join( "|", map "(?:$_)", $said->{my_name}, @$aliases ) . ")";
if( $body =~ s/^\s*($name_re)\b\s*[;:,. \t-]?\s*// ) {
$said->{body} = $body;
$said->{addressed} = 1;
$said->{addressed_as} = $1;
}
}
#--------------------------
#--------------------------
# Permission Checks
#--------------------------
my $conf = $self->get_bot_conf( $pci );
my $root_mask = $conf->{root_mask};
$said->{by_root} = ( $said->{ sender_raw } =~ $root_mask );
$said->{by_chan_op} = $pci->is_channel_operator( $said->{channel}, $said->{name} );
warn Data::Dumper->Dump([[$pci->nick_channels($said->{name})]], ["NICK_CHANS"]);
$said->{in_my_chan} = ($pci->nick_channels($said->{name})) ? 1 : 0;
return $said;
}
sub irc_public {
my( $self ) = @_[OBJECT];
my $said = _said( @_ );
if( $self->is_ignored( $said ) ) {
warn "Ignoring $said->{name}\n";
return;
}
warn "Yielding to execute_said\n";
warn Dumper $said;
$self->dispatch_said( $said );
}
sub irc_msg {
my( $self ) = @_[OBJECT];
my $said = _said( @_ );
return if $self->is_ignored( $said );
$self->dispatch_said( $said );
}
sub irc_ctcp_action {
my( $self ) = @_[OBJECT];
my $said = _said( @_ );
}
sub irc_join {
my( $self ) = @_[OBJECT];
}
sub irc_invite {
my( $self, $kernel, $sender, $inviter, $channel ) = @_[OBJECT,KERNEL,SENDER,ARG0,ARG1];
$kernel->post( $sender, join => $channel );
}
# Naturally this is called after we've successfully
# connected to an irc server so we queue up some
# channel joins and so forth.
sub irc_001 {
my( $self, $kernel, $sender ) = @_[OBJECT,KERNEL,SENDER];
my $bot_conf = $self->get_bot_conf( $sender->ID );
my $channels = $bot_conf->{channel};
# GIANT HACK
if( $bot_conf->{server} =~ /freenode/ ) {
open my $fh, "/home/buu/nickservpass" or goto HACKEND; #sorry
my $pass = <$fh>;
chomp $pass;
$kernel->post( $sender, privmsg => 'nickserv', "identify $pass" );
}
HACKEND:
# END HACK
$kernel->delay_add(comfuck=>50);
# May be an array ref.
for( ref $channels ? @$channels : $channels ) {
$kernel->post( $sender, join => $_ );
}
}
sub irc_474 {
my( $self, @args ) = @_[OBJECT,ARG0..$#_];
warn "Error, banned from channel: @args\n";
}
# Triggered by a delay_set whenever a line is added to dynamic_ignores
sub clear_dynamic_ignore {
my( $self, $pci_id, $nick ) = @_[OBJECT,ARG0,ARG1];
shift @{$self->{dynamic_ignores}->{$pci_id}->{$nick}};
}
sub irc_ctcp_chat {
my( $self, $sender, $user, $target ) = @_[OBJECT,SENDER,ARG0,ARG1];
my $pci = $self->get_component( $sender->ID );
warn "Matching: ", $pci->nick_name, " against $target->[0]\n";
if( l_irc($pci->nick_name) eq l_irc($target->[0]) ) {
$pci->yield( dcc => (parse_user $user)[0], 'CHAT' );
}
}
sub irc_dcc_request {
my( $self, $sender, $user, $type, $cookie ) = @_[OBJECT,SENDER,ARG0,ARG1,ARG3];
my $pci = $self->get_component( $sender->ID );
if( lc($type) eq 'chat' ) {
$pci->yield( dcc_accept => $cookie );
}
}
# Should always be chat events at the moment..
sub irc_dcc_start {
my( $self, $sender, $cookie, $nick ) = @_[OBJECT,SENDER,ARG0,ARG1];
my $welcome = <<'WELCOME';
____ ____ __ _____ ____
/ __ )__ ____ __/ __ )____ / /_ _ _|__ / / __ \
/ __ / / / / / / / __ / __ \/ __/ | | / //_ < / / / /
/ /_/ / /_/ / /_/ / /_/ / /_/ / /_ | |/ /__/ // /_/ /
/_____/\__,_/\__,_/_____/\____/\__/ |___/____(_)____/
WELCOME
$welcome .= "Hello $nick. Welcome to BuuBot's dcc chat.\nAll plugins are available, try 'plugins' and 'help plugins' for a list.";
$poe_kernel->post( $sender => dcc_chat => $cookie, $welcome );
}
sub irc_dcc_chat {
my( $self, $sender, $cookie, $nick, $text ) = @_[OBJECT,SENDER,ARG0,ARG1,ARG3];
my $pci = $self->get_component( $sender->ID );
my $said = _said( @_ );
$said->{dcc_id} = $cookie;
return if $self->is_ignored( $said );
warn "================================== HOST $_[ARG4] =========================\n";
use Data::Dumper;
warn Dumper $said;
$self->dispatch_said( $said );
}
#-----------------------------------------------------------------------------
# PUBLIC POE API
#-----------------------------------------------------------------------------
sub external_message {
my( $self, $server, $nick, $channel, $message ) = @_[OBJECT,ARG0,ARG1,ARG2,ARG3];
warn "Received external message, $server, $nick, $channel, $message\n";
for my $pci_id ( keys %{ $self->{bot_confs} } ) {
my $conf = $self->{bot_confs}->{$pci_id};
my $poco_irc = $self->get_component($pci_id);
if( $conf->{server} eq $server
and ( $conf->{nick} eq $nick or $conf->{botname} eq $nick )
and exists $poco_irc->channels()->{$channel}
) {
warn "Sending private message: $pci_id, $channel, $message\n";
$self->get_component($pci_id)->yield( privmsg => $channel => $message );
}
}
}
sub channel_list {
my( $self, $kernel, $sender ) = @_[OBJECT,KERNEL,SENDER];
my $channels;
for( keys %{ $self->{irc_components} } ) {
my $poco_irc = $self->{irc_components}->{$_};
my $poco_conf = $self->{bot_confs}->{$_};
$channels->{ $poco_conf->{server} }
->{ $poco_conf->{nick} || $poco_conf->{botname} }
= [ keys %{ $poco_irc->channels } ];
}
return $channels;
}
sub plugin_output {
my( $self, $said, $text ) = @_[OBJECT,ARG0,ARG1];
utf8::decode( $text );
return unless $text =~ /\S/;
$text =~ s/\0/\\0/g; # Replace nulls to prevent them truncating strings we attempt to output.
my $pci = $self->get_component( $said->{pci_id} );
# sub send_text( $said, $text ) !
if( $said->{channel} eq '*irc_msg' ) {
my $messages_sent = 0;
MESSAGES: for my $text ( split /\r?\n/, $text ) {
# Send multiple messages if we're talking in a private chat
# Note that in the future we'll probably want to generalize channels
# that receive multiple lines and those that don't..
while( length $text ) {
my $substr = substr( $text, 0, 400, '' );
$pci->yield( privmsg => $said->{name} => $substr );
# Try to avoid sending too many lines, since it may be annoying
# and it tends to prevent the bot from sending other messages.
last MESSAGES if $messages_sent++ > 5;
}
}
}
elsif ( $said->{channel} eq '*dcc_chat' ) {
$pci->yield( dcc_chat => $said->{dcc_id} => $text );
}
else {
$text =~ s/\r?\n/ /g;
$pci->yield( privmsg => $said->{channel} => "$said->{name}: $text" );
}
}
sub handle_special_commands {
my( $self, $kernel, $said, @command ) = @_[OBJECT,KERNEL,ARG0,ARG1..$#_];
my $pci = $self->get_component($said->{pci_id});
$pci->yield( @command );
}
1;

337
lib/Bot/BB3/Roles/.svn/text-base/PasteBot.pm.svn-base
View file

@ -1,337 +0,0 @@
package Bot::BB3::Roles::PasteBot;
use POE;
use POE::Component::Server::SimpleHTTP;
use HTTP::Status;
use CGI;
use Template;
use strict;
our( $INDEX_HTML, $RECEIVED_PASTE_HTML, $DISPLAY_PASTE_HTML );
sub new {
my( $class, $conf, $pm ) = @_;
my $self = bless { conf => $conf, pm => $pm }, $class;
$self->{hostname} = $conf->{roles}->{pastebot}->{hostname} || "127.0.0.1";
$self->{hostname} =~ s{^\s*http:/?/?}{};
# TODO I think this is slightly duplicating the above data
# Note that it can default to empty though..
$self->{alias_url} = $conf->{roles}->{pastebot}->{alias_url};
$self->{session} = POE::Session->create(
object_states => [
$self => [ qw/_start display_page index display_paste receive_paste/ ]
]
);
eval {
$self->dbh->do(
"CREATE TABLE paste (
paste_id INTEGER PRIMARY KEY AUTOINCREMENT,
author VARCHAR(200),
summary VARCHAR(250),
paste LONGTEXT,
date_time INTEGER
)"
);
};
return $self;
}
# This method may be called as either a class method or an object method
# so we have to have some ugly branches to account for it.
sub dbh {
my( $self ) = @_;
if( ref $self and $self->{dbh} and $self->{dbh}->ping ) {
return $self->{dbh};
}
my $dbh = DBI->connect( "dbi:SQLite:dbname=var/pastes.db", "", "", {RaiseError => 1, PrintError => 0} )
or die "Failed to create DBI connection to var/pastes.db, this is a Big Problem! $!";
if( ref $self ) {
$self->{dbh} = $dbh;
}
return $dbh;
}
# This is a public method that can be called as a class method
# therefor $self may be a class or an object.
sub get_paste {
my( $self, $paste_id ) = @_;
my $paste = $self->dbh->selectrow_hashref(
"SELECT author,summary,paste,date_time FROM paste WHERE paste_id = ? LIMIT 1",
undef,
$paste_id
);
return $paste;
}
sub insert_paste {
my( $self, $nick, $summary, $paste )= @_;
my $dbh = $self->dbh;
$dbh->do(
"INSERT INTO paste
(author, summary, paste, date_time)
VALUES (?,?,?,?)
",
undef,
$nick,
$summary,
$paste,
time
);
my $id = $dbh->last_insert_id( undef, undef, undef, undef );
return $id;
}
sub _start {
my( $self, $kernel ) = @_[OBJECT,KERNEL];
my $conf = $self->{conf};
# Create it here so it acts as a child
$self->{server} = POE::Component::Server::SimpleHTTP->new(
PORT => $conf->{pastebot_plugin_port},
ADDRESS => $conf->{pastebot_plugin_addr} || undef,
ALIAS => 'pb_httpd_alias',
HANDLERS => [
{
DIR => '^/paste/\d+',
SESSION => "pastebot_role",
EVENT => "display_paste",
},
{
DIR => '^/paste_submit',
SESSION => "pastebot_role",
EVENT => "receive_paste",
},
{
DIR => '^/',
SESSION => "pastebot_role",
EVENT => "index",
},
]
);
$kernel->alias_set( "pastebot_role" );
$kernel->sig("DIE" => 'sig_DIE' );
}
sub display_page {
my( $self, $resp, $html ) = @_[OBJECT,ARG0,ARG1,ARG2];
warn "Display Page Activating: $resp\n";
$resp->code(RC_OK);
$resp->content_type("text/html");
$resp->content( $html );
$_[KERNEL]->post( pb_httpd_alias => 'DONE' => $resp );
}
sub index {
my( $self, $kernel, $req, $resp ) = @_[OBJECT,KERNEL,ARG0,ARG1];
my $template = Template->new;
my $channels = $kernel->call("Bot::BB3::Roles::IRC", "channel_list")
or warn "Failed to call: $!";
my $context = {
channels => $channels,
alias_url => $self->{alias_url},
};
my $output_html;
$template->process( \$INDEX_HTML, $context, \$output_html )
or warn "Failed to process: $Template::ERROR\n";
$_[KERNEL]->yield( display_page => $resp, $output_html );
}
sub display_paste {
my( $self, $req, $resp ) = @_[OBJECT,ARG0,ARG1];
my $output_html = "<body>Invalid Paste ID</body>";
$req->uri =~ m{paste/(\d+)}
or goto CLEANUP;
my $paste_id = $1;
my $paste = $self->get_paste( $paste_id );
if( not $paste or not keys %$paste ) { goto CLEANUP; }
my $template = Template->new;
my $context = {
author => $paste->{author},
summary => $paste->{summary},
paste => $paste->{paste},
date_time => $paste->{date_time},
};
undef $output_html;
$template->process( \$DISPLAY_PASTE_HTML, $context, \$output_html );
CLEANUP:
$_[KERNEL]->yield( display_page => $resp, $output_html );
}
sub receive_paste {
my( $self, $req, $resp ) = @_[OBJECT,ARG0,ARG1];
warn "Request: ", $req->content;
my $query = CGI->new( $req->content );
my $input = $query->param("body");
warn "Attempting to handle request: $req $resp $input\n";
my $id = $self->insert_paste(
$query->param("nick"),
$query->param("summary"),
$query->param("paste"),
time
);
my $template = Template->new;
my $context = {
map { $_ => $query->param( $_ ) } qw/nick summary channel paste/,
id => $id,
alias_url => $self->{alias_url},
};
my $output;
$template->process( \$RECEIVED_PASTE_HTML, $context, \$output )
or warn $Template::ERROR;
$_[KERNEL]->yield( display_page => $resp, $output );
my $alert_channel = $query->param("channel");
if( $alert_channel !~ /^\s*---/ ) { # Ignore things like "---irc.freenode, skip server names
my($server,$nick,$channel) = split /:/,$alert_channel,3;
my $external_url = $self->{alias_url} || $self->{hostname};
$_[KERNEL]->post( "Bot::BB3::Roles::IRC", external_message => $server, $nick, $channel,
( $context->{nick} || "Someone" )
. " pasted a new file at $external_url/paste/$id - $context->{summary}"
);
}
}
sub sig_DIE {
# Do nothing, we're ignoring fatal errors from our child, poco-server-simplehttp. I think we don't need to respawn them.
}
$INDEX_HTML = <<'END_HTML';
<html>
<head>
<style>
#summary {
width: 60em;
}
#paste {
width: 80em;
height: 25em;
}
</style>
</head>
<body>
<h2>Welcome to the BB3 Pastebot.</h2>
<ol>
<li>Select the channel for the URL announcment.</li>
<li>Supply a nick for the announcement.</li>
<li>Supply a summary of the paste for the announcement.</li>
<li>Paste!</li>
<li>Submit the form with the Paste it! button.</li>
</ol>
<form action="[% alias_url %]/paste_submit" method="post">
<ol>
<li style="float: left">Channel:
<select name="channel" id="channel">
[% FOREACH server IN channels.keys %]
<option name="channel">----[% server %] </option>
[% FOREACH nick IN channels.$server.keys %]
[% FOREACH channel IN channels.$server.$nick %]
<option value="[% server %]:[% nick %]:[% channel %]">[% channel %]</option>
[% END %]
[% END %]
[% END %]
</select>
</li>
<li style="float: left; clear: right; margin-left: 10em;">Nick:
<input type="text" name="nick" id="nick">
</li>
<li style="clear: both;">Summary:
<input type="text" name="summary" id="summary">
</li>
<li>Paste:
<textarea name="paste" id="paste"></textarea>
</li>
<li>
<input type="submit" name="paster" value="Paste It!">
<input type="reset" value="Clear Form">
</li>
</ol>
</form>
</body>
</html>
END_HTML
$RECEIVED_PASTE_HTML = <<'END_HTML';
<html>
<head>
<style>
</style>
</head>
<body>
Stored as: <a href="[% alias_url %]/paste/[% id %]">Paste [% id %]</a>
<br> [% summary %] by [% nick %] <br>
<pre>[% paste | html %]</pre>
</body>
</html>
END_HTML
$DISPLAY_PASTE_HTML = <<'END_HTML';
<html>
<head>
<style>
#paste {
width: 95%;
background-color: rgb(230,230,230);
}
</style>
</head>
<body>
<h2> BB3 PasteBot</h2>
<h3>From [% author | html %]</h3>
<h4>[% summary | html %]</h4>
<pre id="paste">[% paste | html %]</pre>
</body>
</html>
END_HTML
1;

86
lib/Bot/BB3/Roles/.svn/text-base/SocketMessageIRC.pm.svn-base
View file

@ -1,86 +0,0 @@
package Bot::BB3::Roles::SocketMessageIRC;
use POE;
use POE::Wheel::SocketFactory;
use POE::Wheel::ReadWrite;
use Socket;
use strict;
sub new {
my( $class, $conf, $pm ) = @_;
my $self = bless { conf => $conf }, $class;
$self->{session} = POE::Session->create(
object_states => [
$self => [ qw/_start new_connection failed_connection read_line socket_error/ ]
]
);
return $self;
}
sub _start {
my( $self, $kernel ) = @_[OBJECT,KERNEL];
$kernel->alias_set( __PACKAGE__ );
$self->{socketfactory} = POE::Wheel::SocketFactory->new(
BindAddress => '127.0.0.1',
BindPort => ( $self->{conf}->{roles}->{socketmessageirc}->{port} || 10090 ),
SocketDomain => AF_INET(),
SocketType => SOCK_STREAM(),
SocketProtocol => 'tcp',
ListenQueue => 50,
Reuse => 'on',
SuccessEvent => 'new_connection',
FailureEvent => 'failed_connection',
);
}
sub new_connection {
my( $self, $socket ) = @_[OBJECT,ARG0];
my $wheel = POE::Wheel::ReadWrite->new(
Handle => $socket,
Driver => POE::Driver::SysRW->new,
Filter => POE::Filter::Line->new,
InputEvent => "read_line",
ErrorEvent => "socket_error",
);
$self->{rw_wheels}->{$wheel->ID} = $wheel; # save our reference
}
sub failed_connection {
}
sub read_line {
my( $self, $kernel, $line ) = @_[OBJECT,KERNEL,ARG0];
my( $server, $nick, $channel, $message ) = split/\s*:\s*/, $line, 4;
warn "Receiving irc message: $server,$nick,$channel,$message\n";
$kernel->post(
"Bot::BB3::Roles::IRC",
'external_message',
$server,
$nick,
$channel,
$message
);
}
sub socket_error {
my( $self, $wheel_id ) = @_[OBJECT,ARG3];
delete $self->{rw_wheels}->{$wheel_id};
}
1;

141
lib/Bot/BB3/Roles/.svn/text-base/Web.pm.svn-base
View file

@ -1,141 +0,0 @@
package Bot::BB3::Roles::Web;
use Bot::BB3::Logger;
use POE;
use POE::Component::Server::SimpleHTTP;
use HTTP::Status;
use CGI; #Heh.
use strict;
local $/;
my $HTML_TEMPLATE = <DATA>;
sub new {
my( $class, $conf, $plugin_manager ) = @_;
my $self = bless { conf => $conf, pm => $plugin_manager }, $class;
my $session = $self->{session} = POE::Session->create(
object_states => [
$self => [ qw/_start handle_request display_page plugin_output sig_DIE/ ]
]
);
return $self;
}
sub _start {
my( $self, $kernel ) = @_[OBJECT,KERNEL];
my $conf = $self->{conf};
warn '$conf{http}' . $conf->{http_plugin_port};
# Create it here so it acts as a child
$self->{server} = POE::Component::Server::SimpleHTTP->new(
PORT => $conf->{http_plugin_port},
ADDRESS => $conf->{http_plugin_addr} || undef,
ALIAS => 'web_httpd_alias',
HANDLERS => [
{
DIR => '^/request',
SESSION => "web_interface",
EVENT => "handle_request",
},
{
DIR => '^/',
SESSION => "web_interface",
EVENT => "display_page",
}
]
);
$kernel->alias_set( "web_interface" );
$kernel->sig("DIE" => 'sig_DIE' );
}
sub display_page {
my( $self, $req, $resp, $name, $output ) = @_[OBJECT,ARG0,ARG1,ARG2,ARG3];
my $html = $HTML_TEMPLATE;
warn "Display Page Activating: $req - $resp - $output\n";
if( $output ) {
$html =~ s/\%\%OUTPUT\%\%/$output/;
}
$resp->code(RC_OK);
$resp->content_type("text/html");
$resp->content( $html );
$_[KERNEL]->post( web_httpd_alias => 'DONE' => $resp );
}
my %RESP_MAP;
sub handle_request {
my( $self, $req, $resp, $name ) = @_[OBJECT,ARG0,ARG1,ARG2];
warn "Request: ", $req->content;
my $query = CGI->new( $req->content );
my $input = $query->param("body");
my @args = "2+2";
warn "Attempting to handle request: $req $resp $input\n";
# This is obviously silly but I'm unable to figure out
# the correct way to solve this =[
my $said = {
body => $input,
raw_body => $input,
my_name => 'WI',
addressed => 1,
recommended_args => \@args,
channel => '*web',
name => 'CC',
ircname => 'CC',
host => '*special', #TODO fix this to be an actual hostname!
# Make sure it isn't messed up by the alias feature..
server => '*special',
};
# Avoid passing around the full reference
$RESP_MAP{ "$resp" } = $resp;
$said->{pci_id} = "$resp";
$self->{pm}->yield( execute_said => $said );
}
sub plugin_output {
my( $self, $kernel, $said, $output ) = @_[OBJECT,KERNEL,ARG0,ARG1];
$output =~ s/^\s*CC://; # Clear the response name
my $resp = delete $RESP_MAP{ $said->{pci_id} };
$kernel->yield( display_page => undef, $resp, undef, $output );
}
sub sig_DIE {
# Do nothing, we're ignoring fatal errors from our child, poco-server-simplehttp. I think we don't need to respawn them.
}
1;
__DATA__
<html>
<head>
</head>
<body onload="document.getElementById('body_field').focus()">
Welcome to the BB3 web interface. You can interact with the bot by typing bot commands in to the text box below. It acts exactly as if you have typed the command in a private message to the bot. Try the command 'help' or 'plugins' (no quotes).
<form method="post" action="/request">
Input: <input type="text" name="body" id="body_field"> <input type="submit" value="go"> <br>
</form>
Output: %%OUTPUT%%
</body>
</html>

5
plugins/.svn/dir-prop-base
View file

@ -1,5 +0,0 @@
K 13
svn:mergeinfo
V 0
END

1510
plugins/.svn/entries
View file

File diff suppressed because it is too large Load diff

5
plugins/.svn/prop-base/host.pm.svn-base
View file

@ -1,5 +0,0 @@
K 13
svn:mergeinfo
V 0
END

5
plugins/.svn/prop-base/rss.pm.svn-base
View file

@ -1,5 +0,0 @@
K 13
svn:mergeinfo
V 0
END

38
plugins/.svn/text-base/arg.pm.svn-base
View file

@ -1,38 +0,0 @@
use Bot::BB3::MacroQuote ();
sub {
my( $said ) = @_;
my $flags = $said->{body};
my($quotemode, $wordnr, $auxfield) = ("z", 0, "macro_arg");
$flags =~ s/\&(\w+)// and
$auxfield = $1;
$flags =~ s/([a-zA-Z]+)// and
$quotemode = $1;
$flags =~ s/(-?[0-9]+)// and
$wordnr = $1;
my %auxfield_abbrev = (qw"
macro_arg macro_arg arg macro_arg a macro_arg
name name nick name n name
ircname ircname username ircname r ircname
host host h host
sender_raw sender_raw u sender_raw
channel channel c channel
by_chan_op by_chan_op o by_chan_op
server server s server network server
captured captured
");
my $f = $auxfield_abbrev{$auxfield};
my $str = $f && $said->{$f};
if (0 < $wordnr) {
$str = (split " ", $str)[$wordnr - 1];
} elsif ($wordnr < 0) {
$str = (split " ", $str, 1 - $wordnr)[-$wordnr];
}
print Bot::BB3::MacroQuote::quote($quotemode, $str);
}
__DATA__
Prints macro argument in a function macro factoid. Takes optional quoting mode letter or signed number for word splitting; or '&n' or '&c' etc to access extra info.

37
plugins/.svn/text-base/cache_check.pm.svn-base
View file

@ -1,37 +0,0 @@
package Bot::BB3::Plugin::CacheCheck;
use strict;
sub new {
my( $class ) = @_;
my $self = bless {}, $class;
$self->{name} = "cache_check";
$self->{opts} = {
command => 1,
};
return $self;
}
sub initialize {
my( $self, $pm, $cache ) = @_;
die "Failed to receive a cache during initialization: $cache"
unless $cache;
$self->{cache} = $cache;
}
sub command {
my( $self, $said, $pm ) = @_;
my $cache = $self->{cache};
my $key = "cache_check_counter";
$cache->set( $key => ( $cache->get( $key ) + 1 ) );
return( 'handled', "Counter: " . $cache->get( $key ) );
}
"Bot::BB3::Plugin::CacheCheck";

117
plugins/.svn/text-base/compose.pm.svn-base
View file

@ -1,117 +0,0 @@
package Bot::BB3::Plugin::Compose;
use strict;
sub new {
my( $class ) = @_;
my $self = bless {}, $class;
$self->{name} = 'compose';
$self->{opts} = {
command => 1,
};
return $self;
}
sub command {
my( $self, $said, $pm ) = @_;
my $results = compose( $said, $pm );
return('handled', $results);
}
# compose($body) does the main part of the composing,
# it should be in a module so both compose and factoid can call it.
# The calls should be wrapped around for security and stuff.
sub compose {
my($said, $pm) = @_;
my $str = $said->{body};
$str =~ /\A\s*((\S).*(\S))\s*\z/s or
return "Error: empty expression for compose";
my($expr, $openmark, $closemark) = ($1, $2, $3);
$openmark ne $closemark or
return "Error: identical open and close bracket marks for compose";
# we do things in two pass so we don't call any plugins if there are unbalanced parenthesis
my @toke;
my $depth = 0; my $finished = 0;
while ($expr =~ /\G(.*?)(?:(\Q$openmark\E)|\Q$closemark\E)/sg) {
my($part, $open) = ($1, defined($2));
$finished and
return "Error: unmatched closing parenthesis in compose";
push @toke, ["part", $part];
if ($open) {
push @toke, ["open"];
$depth++;
} else {
0 < --$depth or
$finished = 1;
0 <= $depth or
die "internal error: uncaught unmatched closing parenthesis in compose";
push @toke, ["close"];
}
}
0 == $depth or
return "Error: unmatched opening parenthesis in compose";
my @stack = ("");
for my $toke (@toke) {
my($op, $val) = @$toke;
if ("part" eq $op) {
$stack[-1] .= $val;
} elsif ("open" eq $op) {
push @stack, "";
} elsif ("close" eq $op) {
my $cmd = pop @stack;
#warn "cmd=|$cmd|";
my($success, $res) = runplugin($cmd, $said, $pm, 1 < @stack);
#warn "res=|$res|";
$success or
return $res;
$stack[-1] .= $res;
} else {
die "internal error: tokenizer found invalid token in compose";
}
}
1 == @stack or
die "internal error: execution stack unbalanced but the parenthesis were balanced in compose";
return $stack[0];
}
sub runplugin {
my( $cmd_string, $said, $pm, $captured ) = @_;
my( $cmd, $body ) = split " ", $cmd_string, 2;
defined($cmd) or
return( 0, "Error, cannot parse call to find command name, probably empty call in compose" );
defined($body) or $body = "";
my $plugin = $pm->get_plugin( $cmd )
or return( 0, "Compose failed to find a plugin named: $cmd" );
local $said->{body} = $body;
local $said->{recommended_args} = [ split /\s+/, $body ];
local $said->{command_match} = $cmd;
local $said->{nested} = 1; # everything called through compose is nested,
$captured and local $said->{captured} = 1;
# but things called on top-level of compose are captured only if the compose itself is captured
local $@;
my( $status, $results ) = eval { $plugin->command( $said, $pm ) };
if( $@ ) { return( 0, "Failed to execute plugin: $cmd because $@" ); }
else { return( 1, $results ) }
return( 0, "Error, should never reach here" );
}
"Bot::BB3::Plugin::Compose";
__DATA__
Supports composing multiple plugins together. That is, it allows you to feed the output of one plugin to another plugin. Syntax compose (eval (echo 2+2)). Note that it uses the first non whitespace character as the start-delimiter and the last non-whitespace as the end delimter.

51
plugins/.svn/text-base/conf.pm.svn-base
View file

@ -1,51 +0,0 @@
use Data::Dumper;
sub {
my( $said, $pm ) = @_;
my $conf = $pm->get_main_conf;
my( $path, $value ) = split " ", $said->{body}, 2;
my $ref = $conf;
for( split /\./, $path ) {
if( ref $ref eq 'HASH' ) {
$ref = $ref->{$_};
}
elsif( ref $ref eq 'ARRAY' ) {
$ref = $ref->[$_];
}
else {
print "Errored out at $ref";
return;
}
}
if( not length $ref ) {
print "Failed to find element for $path; try conf_dump";
return;
}
if( not length $value ) {
if( ref $ref ) {
$Data::Dumper::Terse = 1;
print Dumper $ref;
}
else {
print $ref;
}
return;
}
print "Attempting to set [$path] to [$value] - $ref";
push @{$said->{special_commands}}, [ bb3_change_conf => $path, $value ];
}
__DATA__
conf <string> [new value]. Displays a portion of the conf structure corresponding to the dot seperated string passed to this plugin. For example, the string "bot.0" will display the complete structure of the first bot defined in the config file. Can also be used to set the value by passing a second argument after the location specifier. New values can be either a single string to set a scalar argumnet, or a comma seperated string surrounded by [], such as [foo,bar,baz]. White space around the commas are removed. This argument is turned in to an arrayref, in other words, a multivalued argument for the config option specified.

19
plugins/.svn/text-base/conf_dump.pm.svn-base
View file

@ -1,19 +0,0 @@
use Config::General;
sub {
my( $said, $pm ) = @_;
my $main_conf = $pm->get_main_conf;
my $o = Config::General->new(
-ConfigFile => $file,
-LowerCaseNames => 1,
-UseApacheInclude => 1,
-AutoTrue => 1
);
print $o->save_string( $main_conf );
}
__DATA__
Dump the current configuration file

25
plugins/.svn/text-base/core.pm.svn-base
View file

@ -1,25 +0,0 @@
use Module::CoreList;
sub {
my( $said, $pm ) = @_;
my $module = $said->{recommended_args}->[0];
my $rev = Module::CoreList->first_release( $module );
if( $rev ) { print "Added to perl core as of $rev" }
else {
my @modules = Module::CoreList->find_modules(qr/$module/);
if ( @modules ){
print 'Found', scalar @modules, ':', join ',' ,
map {$_.' in '. Module::CoreList->first_release( $_ ) } @modules;
}
else {
print "Module $module does not appear to be in core. Perhaps capitalization matters or try using the 'cpan' command to search for it." }
}
}
__DATA__
Tells you when the module you searched for was added to the Perl Core, if it was.

8
plugins/.svn/text-base/echo.pm.svn-base
View file

@ -1,8 +0,0 @@
sub {
my( $said ) = @_;
print $said->{body};
}
__DATA__
Echo just prints its argument verbatim.

78
plugins/.svn/text-base/eval.pm.svn-base
View file

@ -1,78 +0,0 @@
# eval plugin for buubot3
package Bot::BB3::Plugin::Eval;
package Bot::BB3::Plugin::Eval;
use POE::Filter::Reference;
use IO::Socket::INET;
use Data::Dumper;
use strict;
sub new {
my( $class ) = @_;
my $self = bless {}, $class;
$self->{name} = 'eval';
$self->{opts} = {
command => 1,
};
$self->{aliases} = [ qw/jseval jeval phpeval pleval perleval deparse k20eval rbeval pyeval luaeval/ ];
return $self;
}
sub command {
my( $self, $said, $pm ) = @_;
my $code = $said->{"body"};
my $type = $said->{command_match};
$type =~ s/^\s*(\w+?)eval/$1/;
warn "Initial type: $type\n";
my %translations = (
js => 'javascript',
perl => 'perl',
pl => 'perl',
php => 'php',
deparse => 'deparse',
'k20' => 'k20',
'k' => 'k20',
'rb' => 'ruby',
'ruby' => 'ruby',
'py' => 'python',
'python' => 'python',
'lua' => 'lua',
'j' => 'j',
);
$type = $translations{$type};
if( not $type ) { $type = 'perl'; }
warn "Found $type: $code";
my $filter = POE::Filter::Reference->new();
my $socket = IO::Socket::INET->new( PeerAddr => '127.0.0.1', PeerPort => '14400' )
or die "error: cannot connect to eval server";
my $refs = $filter->put( [ { code => "$type $code" } ] );
print $socket $refs->[0];
local $/;
my $output = <$socket>;
$socket->close;
my $result = $filter->get( [ $output ] );
my $resultstr = $result->[0]->[0];
if (!$said->{captured} && $resultstr !~ /\S/) {
$resultstr = "No output.";
}
$resultstr =~ s/\x0a?\x0d//g; # Prevent sending messages to the IRC server..
return( 'handled', $resultstr );
}
"Bot::BB3::Plugin::Eval";
__DATA__
The eval plugin. Evaluates various different languages. Syntax, eval: code; also pleval deparse rbeval jseval pyeval phpeval k20eval luaeval jeval.

501
plugins/.svn/text-base/factoids.pm.svn-base
View file

@ -1,501 +0,0 @@
package Bot::BB3::Plugin::Factoids;
use DBI;
use DBD::SQLite;
use POE::Component::IRC::Common qw/l_irc/;
use Text::Soundex qw/soundex/;
use strict;
use Data::Dumper;
my $COPULA = join '|', qw/is are was isn't were being am/, "to be", "will be", "has been", "have been", "shall be", "can has", "wus liek", "iz liek", "used to be";
my $COPULA_RE = qr/\b(?:$COPULA)\b/i;
sub new {
my( $class ) = @_;
my $self = bless {}, $class;
$self->{name} = 'factoids'; # Shouldn't matter since we aren't a command
$self->{opts} = {
command => 1,
#handler => 1,
};
$self->{aliases} = [ qw/fact call/ ];
return $self;
}
sub dbh {
my( $self ) = @_;
if( $self->{dbh} and $self->{dbh}->ping ) {
return $self->{dbh};
}
my $dbh = $self->{dbh} = DBI->connect(
"dbi:SQLite:dbname=var/factoids.db",
"",
"",
{ RaiseError => 1, PrintError => 0 }
);
return $dbh;
}
sub postload {
my( $self, $pm ) = @_;
my $sql = "CREATE TABLE factoid (
factoid_id INTEGER PRIMARY KEY AUTOINCREMENT,
original_subject VARCHAR(100),
subject VARCHAR(100),
copula VARCHAR(25),
predicate TEXT,
author VARCHAR(100),
modified_time INTEGER,
soundex VARCHAR(4),
compose_macro CHAR(1) DEFAULT '0',
protected BOOLEAN DEFAULT '0'
)"; # Stupid lack of timestamp fields
$pm->create_table( $self->dbh, "factoid", $sql );
delete $self->{dbh}; # UGLY HAX GO.
# Basically we delete the dbh we cached so we don't fork
# with one active
}
# This whole code is a mess.
# Essentially we need to check if the user's text either matches a
# 'store command' such as "subject is predicate" or we need to check
# if it's a retrieve command such as "foo" or if it's a retrieve sub-
# command such as "forget foo"
# Need to add "what is foo?" support...
sub command {
my( $self, $said, $pm ) = @_;
return unless $said->{body} =~ /\S/; #Try to prevent "false positives"
my $call_only = $said->{command_match} eq "call";
my $subject = $said->{body};
if( !$call_only and $subject =~ /\s+$COPULA_RE\s+/ ) {
my @ret = $self->store_factoid( $said );
return( 'handled', "Failed to store $said->{body}" )
unless @ret;
return ('handled', "@ret") if ($ret[0] =~ /^insuff/i);
return( 'handled', "Stored @ret" );
}
else {
my $commands_re = join '|', qw/search relearn learn forget revisions literal revert protect unprotect/;
$commands_re = qr/$commands_re/;
my $fact_string;
if( !$call_only && $subject =~ s/^\s*($commands_re)\s+// ) {
my( $cmd_name ) = "get_fact_$1";
$fact_string = $self->$cmd_name($subject, $said->{name}, $said);
}
else {
$fact_string = $self->get_fact( $pm, $said, $subject, $said->{name}, $call_only );
}
if( $fact_string ) {
return( 'handled', $fact_string );
}
else {
return;
}
}
}
sub _clean_subject {
my( $subject ) = @_;
$subject =~ s/^\s+//;
$subject =~ s/\s+$//;
$subject =~ s/\s+/ /g;
# $subject =~ s/[^\w\s]//g; #comment out to fix punct in factoids
$subject = lc $subject;
return $subject;
}
sub _clean_subject_func { # for parametrized macros
my($subject, $variant) = @_;
my( $key, $arg );
if ($variant) {
$subject =~ /\A\s*(\S+(?:\s+\S+)?)(?:\s+(.*))?\z/s or return;
( $key, $arg ) = ( $1, $2 );
} else {
$subject =~ /\A\s*(\S+)(?:\s+(.*))?\z/s or return;
( $key, $arg ) = ( $1, $2 );
}
$key =~ s/[^\w\s]//g;
return $key, $arg;
}
sub store_factoid {
my( $self, $said) =@_;
my ($author, $body ) = ($said->{name}, $said->{body});
return unless $body =~ /^(?:\S+[:,])?\s*(.+?)\s+($COPULA_RE)\s+(.+)$/s;
my( $subject, $copula, $predicate ) = ($1,$2,$3);
my $compose_macro = 0;
return "Insufficient permissions for changing protected factoid [$subject]" if (!$self->_db_check_perm($subject,$said));
if( $subject =~ s/^\s*\@?macro\b\s*// ) { $compose_macro = 1; }
elsif( $subject =~ s/^\s*\@?func\b\s*// ) { $compose_macro = 2; }
elsif( $predicate =~ s/^\s*also\s+// ) {
my $fact = $self->_db_get_fact( _clean_subject( $subject ), $author );
$predicate = $fact->{predicate} . " " . $predicate;
}
return unless
$self->_insert_factoid( $author, $subject, $copula, $predicate, $compose_macro, $self->_db_get_protect($subject) );
return( $subject, $copula, $predicate );
}
sub _insert_factoid {
my( $self, $author, $subject, $copula, $predicate, $compose_macro, $protected ) = @_;
my $dbh = $self->dbh;
warn "Attempting to insert factoid: type $compose_macro";
my $key;
if ( $compose_macro == 2 ) {
($key, my $arg) = _clean_subject_func($subject, 1);
warn "*********************** GENERATED [$key] FROM [$subject] and [$arg]\n";
$arg =~ /\S/
and return;
}
else {
$key = _clean_subject( $subject );
}
return unless $key =~ /\S/;
$dbh->do( "INSERT INTO factoid
(original_subject,subject,copula,predicate,author,modified_time,soundex,compose_macro,protected)
VALUES (?,?,?,?,?,?,?,?,?)",
undef,
$key,
$subject,
$copula,
$predicate,
l_irc($author),
time,
soundex($key),
$compose_macro || 0,
$protected || 0,
);
return 1;
}
sub get_fact_protect {
my( $self, $subject, $name, $said ) = @_;
warn "===TRYING TO PROTECT [$subject] [$name]\n";
#XXX check permissions here
return "Insufficient permissions for protecting factoid [$subject]" if (!$self->_db_check_perm($subject,$said));
my $fact = $self->_db_get_fact( _clean_subject( $subject ), $name );
if (defined($fact->{predicate}))
{
$self->_insert_factoid( $name, $subject, $fact->{copula}, $fact->{predicate}, $fact->{compose_macro}, 1 );
return "Protected [$subject]";
}
else
{
return "Unable to protect nonexisting factoid [$subject]";
}
}
sub get_fact_unprotect {
my( $self, $subject, $name, $said ) = @_;
warn "===TRYING TO PROTECT [$subject] [$name]\n";
#XXX check permissions here
return "Insufficient permissions for unprotecting factoid [$subject]" if (!$self->_db_check_perm($subject,$said));
my $fact = $self->_db_get_fact( _clean_subject( $subject ), $name );
if (defined($fact->{predicate}))
{
$self->_insert_factoid( $name, $subject, $fact->{copula}, $fact->{predicate}, $fact->{compose_macro}, 0 );
return "Unprotected [$subject]";
}
else
{
return "Unable to unprotect nonexisting factoid [$subject]";
}
}
sub get_fact_forget {
my( $self, $subject, $name, $said ) = @_;
warn "===TRYING TO FORGET [$subject] [$name]\n";
#XXX check permissions here
return "Insufficient permissions for forgetting protected factoid [$subject]" if (!$self->_db_check_perm($subject,$said));
$self->_insert_factoid( $name, $subject, "is", " ", 0, $self->_db_get_protect($subject) );
return "Forgot $subject";
}
sub _fact_literal_format {
my($r) = @_;
($r->{protected}?"P:" : "" ).
("","macro ","func ")[$r->{compose_macro}] .
"$r->{subject} $r->{copula} $r->{predicate}";
}
sub get_fact_revisions {
my( $self, $subject, $name ) = @_;
my $dbh = $self->dbh;
my $revisions = $dbh->selectall_arrayref(
"SELECT factoid_id, subject, copula, predicate, author, compose_macro, protected
FROM factoid
WHERE original_subject = ?
ORDER BY modified_time DESC
", # newest revision first
{Slice=>{}},
_clean_subject( $subject ),
);
my $ret_string = join " ", map {
"[$_->{factoid_id} by $_->{author}: " . _fact_literal_format($_) . "]";
} @$revisions;
return $ret_string;
}
sub get_fact_literal {
my( $self, $subject, $name ) = @_;
my $fact = $self->_db_get_fact( _clean_subject( $subject ), $name );
return _fact_literal_format($fact);
}
sub get_fact_revert {
my( $self, $subject, $name, $said ) = @_;
my $dbh = $self->dbh;
#XXX check permissions here
return "Insufficient permissions for reverting protected factoid [$subject]" if (!$self->_db_check_perm($subject,$said));
$subject =~ s/^\s*(\d+)\s*$//
or return "Failed to match revision format";
my $rev_id = $1;
my $fact_rev = $dbh->selectrow_hashref(
"SELECT subject, copula, predicate, compose_macro
FROM factoid
WHERE factoid_id = ?",
undef,
$rev_id
);
my $protect = $self->_db_get_protect($fact_rev->{subject});
return "Bad revision id" unless $fact_rev and $fact_rev->{subject}; # Make sure it's valid..
# subject, copula, predicate
$self->_insert_factoid( $name, @$fact_rev{qw"subject copula predicate compose_macro"}, $protect);
return "Reverted $fact_rev->{subject} to revision $rev_id";
}
sub get_fact_learn {
my( $self, $body, $name, $said ) = @_;
$body =~ s/^\s*learn\s+//;
my( $subject, $predicate ) = split /\s+as\s+/, $body, 2;
#XXX check permissions here
return "Insufficient permissions for changing protected factoid [$subject]" if (!$self->_db_check_perm($subject,$said));
#my @ret = $self->store_factoid( $name, $said->{body} );
$self->_insert_factoid( $name, $subject, 'is', $predicate, 0 , $self->_db_get_protect($subject));
return "Stored $subject as $predicate";
}
*get_fact_relearn = \&get_fact_learn; #Alias..
sub get_fact_search {
my( $self, $body, $name ) = @_;
my $results = $self->dbh->selectall_arrayref(
"SELECT subject,copula,predicate
FROM factoid
WHERE subject like ?
GROUP BY subject", # Group by magically returns the right row first. I dunno.
{Slice => {}},
"%$body%",
);
if( $results and @$results ) {
my $ret_string;
for( @$results ) {
$ret_string .= "[" . _fact_literal_format($_) . "] ";
}
return $ret_string;
}
else {
return "No matches."
}
}
sub get_fact {
my( $self, $pm, $said, $subject, $name, $call_only ) = @_;
return $self->basic_get_fact( $pm, $said, $subject, $name, $call_only );
}
sub _db_check_perm {
my ($self, $subj, $said) = @_;
my $isprot = $self->_db_get_protect($subj);
warn "Checking permissions of [$subj] for [$said->{name}]";
warn Dumper($said);
#always refuse to change factoids if not in one of my channels
return 0 if (!$said->{in_my_chan});
#if its not protected no need to check if they are op or root;
return 1 if (!$isprot);
if ($isprot && ($said->{by_root} || $said->{by_chan_op}))
{
return 1;
}
#default case, $isprotect true; op or root isn't
return 0;
}
#get the status of the protection bit
sub _db_get_protect {
my( $self, $subj ) = @_;
$subj = _clean_subject($subj,1);
my $dbh = $self->dbh;
my $prot = ($dbh->selectrow_array( "
SELECT protected
FROM factoid
WHERE original_subject = ?
ORDER BY factoid_id DESC
",
undef,
$subj,
))[0];
return $prot;
}
sub _db_get_fact {
my( $self, $subj, $name ) = @_;
my $dbh = $self->dbh;
my $fact = $dbh->selectrow_hashref( "
SELECT factoid_id, subject, copula, predicate, author, modified_time, compose_macro, protected
FROM factoid
WHERE original_subject = ?
ORDER BY factoid_id DESC
",
undef,
$subj,
);
return $fact;
}
sub basic_get_fact {
my( $self, $pm, $said, $subject, $name, $call_only ) = @_;
my ($fact, $key, $arg);
my $key = _clean_subject($subject);
my $fact;
if( !$call_only ) {
$fact = $self->_db_get_fact($key, $name);
}
# Attempt to determine if our subject matches a previously defined
# 'macro' or 'func' type factoid.
# I suspect it won't match two word function names now.
for my $variant (0, 1) {
if (!$fact) {
($key, $arg) = _clean_subject_func($subject, $variant);
$fact = $self->_db_get_fact($key, $name, 1);
}
}
if( $fact->{predicate} =~ /\S/ ) {
if( $fact->{compose_macro} ) {
my $plugin = $pm->get_plugin("compose");
local $said->{macro_arg} = $arg;
local $said->{body} = $fact->{predicate};
local $said->{addressed} = 1; # Force addressed to circumvent restrictions? May not be needed!
return $plugin->command($said,$pm);
}
else {
return "$fact->{predicate}";
}
}
else {
my $soundex = soundex( _clean_subject($subject, 1) );
my $matches = $self->_soundex_matches( $soundex );
if( $matches and @$matches ) {
return "No factoid found. Did you mean one of these: " . join " ", map "[$_]", @$matches;
}
else {
return;
}
}
}
sub _soundex_matches {
my( $self, $soundex ) = @_;
my $dbh = $self->dbh;
my $rows = $dbh->selectall_arrayref(
"SELECT factoid_id,subject,predicate FROM factoid WHERE soundex = ? GROUP BY subject LIMIT 10",
undef,
$soundex
);
return [ map $_->[1], grep $_->[2] =~ /\S/, @$rows ];
}
"Bot::BB3::Plugin::Factoids";
__DATA__
Learn or retrieve persistent factoids. "foo is bar" to store. "foo" to retrieve. try "forget foo" or "revisions foo" or "literal foo" or "revert $REV_ID" too. "macro foo is [echo bar]" or "func foo is [echo bar [arg]]" for compose macro factoids. The factoids/fact/call keyword is optional except in compose. Search <subject> to search for factoids that match.

18
plugins/.svn/text-base/geoip.pm.svn-base
View file

@ -1,18 +0,0 @@
use Geo::IP;
sub {
my( $said, $pm ) = @_;
my $gi = Geo::IP->new(GEOIP_STANDARD);
print "Record for $said->{body}: ";
if( $said->{body} =~ /[a-zA-Z]/ ) {
print $gi->country_code_by_name( $said->{body} );
}
else {
print $gi->country_code_by_addr( $said->{body} );
}
}
__DATA__
geoip 192.168.32.45 or geoip example.com; returns the country associated with the resolved IP address.

31
plugins/.svn/text-base/head.pm.svn-base
View file

@ -1,31 +0,0 @@
use LWP::UserAgent;
sub {
my( $said ) = @_;
my $ua = LWP::UserAgent->new( agent => "BB3WebAgent! (mozilla)" );
my $url;
if( $said->{body} =~ m{(http://\S+)} ) {
$url = $1;
}
elsif( $said->{body} =~ /(\S+)/ ) {
$url = "http://$1";
}
else {
print "That doesn't look like a url..";
return;
}
my $resp = $ua->head( $url );
if( not $resp ) {
print "Couldn't fetch [$url] you failure";
return;
}
print "$url: " . $resp->code . ": " . $resp->message . ". " . $resp->header("server");
}
__DATA__
head http://url/; returns the response code and server type from a HEAD request for a particular url.

24
plugins/.svn/text-base/help.pm.svn-base
View file

@ -1,24 +0,0 @@
use strict;
sub {
my( $said, $pm ) = @_;
my $plugin_name = $said->{recommended_args}->[0];
if( length $plugin_name ) {
my $plugin = $pm->get_plugin( $plugin_name );
if( $plugin ) {
print $plugin->{help_text};
}
else {
print "Sorry, no plugin named $plugin_name found.";
}
}
else {
print "Provides help text for a specific command. Try 'help echo'. See also the command 'plugins' to list all of the currently loaded plugins.";
}
}
__DATA__
Attempts to find the help for a plugin. Syntax help PLUGIN.

47
plugins/.svn/text-base/host.pm.svn-base
View file

@ -1,47 +0,0 @@
#!/usr/bin/perl
use Net::DNS;
use strict;
use Data::Dumper;
my $foo=sub {
my( $said, $pm ) = @_;
my $host = $said->{recommended_args}->[0];
my $recordtype = $said->{recommended_args}->[1];
print "Couldn't find a host to check!" and return
unless $host;
$recordtype ||= "A";
my $res = Net::DNS::Resolver->new;
my $query = $res->query($host, $recordtype);
if ($query)
{
my @resu;
foreach my $rr ($query->answer)
{
next unless $rr->type eq $recordtype;
push @resu, $rr->string;
}
print "No $recordtype record found for $host" and return if (!@resu);
s/\s+/ /g for @resu;
print join(" :: ", @resu) and return;
}
else
{
print "query failed: ", $res->errorstring;
}
};
if ($0 =~ /host.pm$/)
{
$foo->({recommended_args=>['google.com','A']});
}
else
{
$foo;
}
__DATA__
Returns information about a host's DNS records

14
plugins/.svn/text-base/host_lookup.pm.svn-base
View file

@ -1,14 +0,0 @@
use DBI;
sub {
my( $said, $pm ) = @_;
my $dbh = DBI->connect("dbi:SQLite:dbname=var/hosts.db");
my $recs = $dbh->selectall_arrayref( "SELECT * FROM hosts where host = ?", {Slice=>{}}, $said->{body} );
print "$said->{body}: ", join ", ", map $_->{nick}, @$recs;
}
__DATA__
host_lookup <hostname>. Returns all of the nicks this bot has seen using the host name you specify.

13
plugins/.svn/text-base/join.pm.svn-base
View file

@ -1,13 +0,0 @@
sub {
my( $said, $pm ) = @_;
my @channels = grep /^#/, @{ $said->{recommended_args} };
push @{ $said->{special_commands} },
[ 'pci_join', @channels ];
print "Joining @{ $said->{recommended_args} }";
}
__DATA__
Attempts to join a list of channels. Syntax join #foo #bar #baz. Typically requires op or superuser.

42
plugins/.svn/text-base/karma.pm.svn-base
View file

@ -1,42 +0,0 @@
use POE::Component::IRC::Common qw/l_irc/;
use DBI;
use DBD::SQLite;
sub {
my( $said, $pm ) = @_;
my $body = $said->{body};
s/^\s+//, s/\s+$// for $body;
warn "KARMAPLUGIN";
use Data::Dumper;
warn Dumper $said;
my $dbh = DBI->connect(
"dbi:SQLite:dbname=var/karma.db",
"",
"",
{ RaiseError => 1, PrintError => 0 }
);
my $lirc = l_irc($said->{body}) || lc $said->{body};
warn "SUBJECT: $lirc";
my $karma = $dbh->selectrow_arrayref(
"SELECT sum(operation) FROM karma WHERE subject = ?",
undef,
$lirc,
);
if( $karma and @$karma) {
if ($karma->[0])
{
print "$body has karma of $karma->[0]";
}
else
{
print "$body has no karma";
}
}
}
__DATA__
karma <nickname>; returns the "karma" value for a user or arbitrary subject. Karma works by appending either ++ or -- to a word to modify its karma.

74
plugins/.svn/text-base/karma_modify.pm.svn-base
View file

@ -1,74 +0,0 @@
package Bot::BB3::Plugin::Karma_Modify;
use POE::Component::IRC::Common qw/l_irc/;
use DBI;
use DBD::SQLite;
sub new {
my( $class ) = @_;
my $self = bless {}, $class;
$self->{name} = "karma_modify"; # This shouldn't be necessary
$self->{opts}->{handler} = 1;
return $self;
}
sub dbh {
my( $self ) = @_;
if( $self->{dbh} and $self->{dbh}->ping ) {
return $self->{dbh};
}
my $dbh = $self->{dbh} = DBI->connect(
"dbi:SQLite:dbname=var/karma.db",
"",
"",
{ RaiseError => 1, PrintError => 0 }
);
return $dbh;
}
sub postload {
my( $self, $pm ) = @_;
my $sql = "CREATE TABLE karma (
karma_id INTEGER PRIMARY KEY AUTOINCREMENT,
subject VARCHAR(250),
operation TINYINT,
author VARCHAR(32),
modified_time INTEGER
)"; # Stupid lack of timestamp fields
$pm->create_table( $self->dbh, "karma", $sql );
delete $self->{dbh}; # UGLY HAX GO.
# Basically we delete the dbh we cached so we don't fork
# with one active
}
sub handle {
my( $self, $said, $pm ) = @_;
my $body = $said->{body};
if( $body =~ /\(([^\)]+)\)(\+\+|--)/ or $body =~ /(\w+)(\+\+|--)/ ) {
my( $subject, $op ) = ($1,$2);
if( $op eq '--' ) { $op = -1 } elsif( $op eq '++' ) { $op = 1 }
my $lirc = l_irc($subject) || lc $subject;
$self->dbh->do( "INSERT INTO karma (subject,operation,author,modified_time) VALUES (?,?,?,?)",
undef,
$lirc,
$op,
$said->{name},
scalar time,
);
}
return;
}
"Bot::BB3::Plugin::Karma_Modify";

63
plugins/.svn/text-base/more.pm.svn-base
View file

@ -1,63 +0,0 @@
package Bot::BB3::Plugin::More;
use strict;
sub new {
my( $class ) = @_;
my $self = bless {}, $class;
$self->{name} = 'more';
$self->{opts} = {
command => 1,
post_process => 1,
};
return $self;
}
sub initialize {
my( $self, $pm, $cache ) = @_;
$self->{cache} = $cache;
}
sub command {
my( $self, $said, $pm ) = @_;
my $text = $self->{cache}->get( "pager_$said->{name}" );
$self->{cache}->remove( "pager_$said->{name}" );
if( $text ) { return( 'handled', "...$text" ); }
else { return( 'handled', "Sorry, no more output" ); }
}
sub post_process {
my( $self, $said, $pm, $output_ref ) = @_;
return if $said->{channel} =~ /^\*/;
# Magic numbers are awesome.
# the usual max length for an irc message is around 425?
# Something like that.
# The actual max is usually 512 but you need room for nicks and command types.
if( length $$output_ref > 400 ) {
# Sanity checking, let's not store novels.
if( length $$output_ref > 1_000 ) {
my $new_out = $$output_ref = substr( $$output_ref, 0, 1_000 );
$$output_ref = $new_out;
warn "Sanity checking, new length: ", length $$output_ref;
}
my $new_text = substr( $$output_ref, 0, 350, '' );
$self->{cache}->set( "pager_$said->{name}", $$output_ref, "10 minutes" ); #Remainder
$$output_ref = $new_text;
$$output_ref .= "... [Output truncated. Use `more` to read more]";
}
}
"Bot::BB3::Plugin::More";
__DATA__
More acts as a pager. It automatically truncates output that is too long and saves it in a buffer based on your name. Use the command `more` to access the remainder of the text.

14
plugins/.svn/text-base/nick_lookup.pm.svn-base
View file

@ -1,14 +0,0 @@
use DBI;
sub {
my( $said, $pm ) = @_;
my $dbh = DBI->connect("dbi:SQLite:dbname=var/hosts.db");
my $recs = $dbh->selectall_arrayref( "SELECT * FROM hosts where nick = ?", {Slice=>{}}, $said->{body} );
print "$said->{body}: ", join ", ", map $_->{host}, @$recs;
}
__DATA__
nick_lookup <nickname>; returns all of the hostnames this bot has seen a particular nick name use.

12
plugins/.svn/text-base/part.pm.svn-base
View file

@ -1,12 +0,0 @@
sub {
my( $said, $pm ) = @_;
push @{$said->{special_commands}},
map { [ pci_part => $_ ] } @{$said->{recommended_args}}
;
print "Attempting to leave: @{$said->{recommended_args}} ";
}
__DATA__
Attempts to leave a list of channels. Syntax, part #foo #bar #baz. Note, does no sanity checking. Typically requires op or superuser.

23
plugins/.svn/text-base/plugins.pm.svn-base
View file

@ -1,23 +0,0 @@
package Bot::BB3::Plugin::Plugins;
use strict;
sub new {
my($class) = @_;
my $self = bless {}, $class;
$self->{"name"} = "plugins";
$self->{"opts"}->{"command"} = 1;
return $self;
}
sub command {
my($self, $said, $manager) = @_;
my $output = join(" ", sort map { $_->{name} } @{$manager->get_plugins});
#return( "handled", $output );
return( "handled", $output );
}
"Bot::BB3::Plugin::Plugins";
__DATA__
Returns a list of all of the loaded plugins for this bot. Syntax, plugins

14
plugins/.svn/text-base/quote.pm.svn-base
View file

@ -1,14 +0,0 @@
use Bot::BB3::MacroQuote ();
sub {
my( $said ) = @_;
$said->{body} =~ /\A\s*(\w+)\s?(.*)\z/s # note: only one space after the quoting mode so we can quote strings starting with space
or return;
my($mode, $str) = ($1, $2);
print Bot::BB3::MacroQuote::quote($mode, $str);
}
__DATA__
Escape a string to prepare for interpolation in an eval program code. Syntax is quote m string, with one space after quoting mode m which can be: z (no-op), c (c-like hex escapes), d (with delimiters), e, f, h.

14
plugins/.svn/text-base/reload_plugins.pm.svn-base
View file

@ -1,14 +0,0 @@
sub {
my( $said, $pm ) = @_;
push @{ $said->{special_commands} },
[ pm_reload_plugins => 1 ]
;
print "Attempting to reload plugins...";
}
__DATA__
Attempts to reload all of the plugins in the plugin directory. Has the effect of reloading any changed plugins or adding any new ones that have been added. Typically root only.

10
plugins/.svn/text-base/restart.pm.svn-base
View file

@ -1,10 +0,0 @@
sub {
my( $said, $pm ) = @_;
push @{$said->{special_commands}}, [ bb3_restart=> 1 ];
print "Attempting to restart..";
}
__DATA__
restart. Attempts to rexecute the bot in the exact manner it was first execute. This has the effect of reloading all config files and associated plugins. Typically root only.

22
plugins/.svn/text-base/rss.pm.svn-base
View file

@ -1,22 +0,0 @@
use XML::RSS::Parser;
use strict;
sub {
my( $said, $pm ) = @_;
my $feed_uri = $said->{recommended_args}->[0];
print "Couldn't find a url to fetch!" and return
unless $feed_uri;
my $parser = XML::RSS::Parser->new;
my $feed = $parser->parse_uri( $feed_uri ) #TODO check for http:// schema
or ( print "Couldn't parse $feed_uri because", $parser->errstr and return );
for( $feed->query("//item/title") ) {
print $_->text_content;
}
}
__DATA__
Returns small list of headlines from an RSS feed. Syntax, fetch_rss http://example/rss

20
plugins/.svn/text-base/rss_title.pm.svn-base
View file

@ -1,20 +0,0 @@
use XML::RSS::Parser;
use strict;
sub {
my( $said, $pm ) = @_;
my $feed_uri = $said->{recommended_args}->[0];
print "Couldn't find a url to fetch!" and return
unless $feed_uri;
my $parser = XML::RSS::Parser->new;
my $feed = $parser->parse_uri( $feed_uri ) #TODO check for http:// schema
or ( print "Couldn't parse $feed_uri because", $parser->errstr and return );
print +($feed->query("//item/title"))[0]->text_content;
}
__DATA__
Returns the first headline from a specified RSS feed.

27
plugins/.svn/text-base/rt.pm.svn-base
View file

@ -1,27 +0,0 @@
use WWW::RottenTomatoes;
# Construct it outside the sub so it can at least pretend to do some caching.
my $rt = WWW::RottenTomatoes->new;
sub {
my( $said, $pm ) = @_;
local $@;
my $movie_info = eval { $rt->movie_info( $said->{body} ) };
if( $@ ) {
print "Error fetching movie info: $@";
return;
}
if( $movie_info ) {
print "$movie_info->{title}: $movie_info->{rating} - ", @{ $movie_info->{bubbles} }[ rand @{ $movie_info->{bubbles} } ];
}
else {
print "Sorry failed to find a movie titled [$said->{body}]";
}
}
__DATA__
RottenTomatoes plugin. Syntax, rt Movie Title.

10
plugins/.svn/text-base/save_config.pm.svn-base
View file

@ -1,10 +0,0 @@
sub {
my( $said, $pm ) = @_;
push @{$said->{special_commands}}, [ bb3_save_main_conf => 1 ];
print "Attempting to save my config, note that it won't change anything until I restart.";
}
__DATA__
save_config. Attempts to write the current config structure back to the file it was originally read from. Hopefully you've modified it first. Note, may lose comments. Root only.

94
plugins/.svn/text-base/seen.pm.svn-base
View file

@ -1,94 +0,0 @@
package Bot::BB3::Plugin::Seen;
use POE::Component::IRC::Common qw/l_irc/;
use DBD::SQLite;
use strict;
sub new {
my( $class ) = @_;
my $self = bless {}, $class;
$self->{name} = "seen";
$self->{opts} = {
command => 1,
handler => 1,
};
return $self;
}
sub dbh {
my( $self ) = @_;
if( $self->{dbh} and $self->{dbh}->ping ) {
return $self->{dbh};
}
my $dbh = $self->{dbh} = DBI->connect( "dbi:SQLite:dbname=var/seen.db", "", "", { PrintError => 0, RaiseError => 1 } );
return $dbh;
}
sub postload {
my( $self, $pm ) = @_;
my $sql = "CREATE TABLE seen (
seen_id INTEGER PRIMARY KEY AUTOINCREMENT,
user VARCHAR(25),
lc_user VARCHAR(25),
message VARCHAR(250),
seen_date INTEGER
);";
$pm->create_table( $self->dbh, "seen", $sql );
delete $self->{dbh}; # UGLY HAX GO.
# Basically we delete the dbh we cached so we don't fork
# with one active
}
sub command {
my( $self, $said, $pm ) = @_;
my( $target ) = @{ $said->{recommended_args} };
my $seen = $self->dbh->selectrow_arrayref( "SELECT user,message,seen_date FROM seen WHERE lc_user = ?",
undef,
l_irc( $target )
);
if( $seen and @$seen and $seen->[0] ) {
return( 'handled', "I last saw $seen->[0] saying \"$seen->[1]\" at " . gmtime($seen->[2]) . " Z." );
}
else {
return( 'handled', "I don't think I've seen $target." );
}
}
sub handle {
my ( $self, $said, $pm ) = @_;
my $count = $self->dbh->do( "UPDATE seen SET user = ?, message = ?, seen_date = ? WHERE lc_user = ?",
undef,
$said->{name},
$said->{body},
time(),
l_irc( $said->{name} ),
);
if( $count == 0 ) {
$self->dbh->do( "INSERT INTO seen (user,lc_user,message,seen_date) VALUES ( ?,?,?,? )",
undef,
$said->{name},
l_irc($said->{name}),
$said->{body},
time(),
);
}
return;
}
"Bot::BB3::Plugin::Seen";
__DATA__
The seen plugin. Attempts to keep track of every user the bot has 'seen'. Use the syntax, seen user; to ask the bot when it last saw the user named 'user'.

11
plugins/.svn/text-base/shorten.pm.svn-base
View file

@ -1,11 +0,0 @@
use WWW::Shorten 'Metamark';
sub {
my( $said, $pm ) = @_;
print "New link: ", makeashorterlink($said->{body});
}
__DATA__
shorten <url> returns the "short form" of a url. Defaults to using xrl.us.

67
plugins/.svn/text-base/spell.pm.svn-base
View file

@ -1,67 +0,0 @@
package Bot::BB3::Plugin::Spell;
use Text::Aspell;
use strict;
sub new {
my( $class ) = @_;
my $self = bless {}, $class;
$self->{name} = 'spell';
$self->{opts} = {
command => 1,
handler => 1,
};
return $self;
}
sub handle {
my( $self, $said, $pm ) = @_;
my( undef, $ret ) = $self->_speller( $said, $pm, 'handle' );
# TODO fix this, we just get rid of 'handled'.
# Need to clean up this code to remove this.
return $ret;
}
sub command {
my( $self, $said, $pm ) = @_;
return $self->_speller( $said, $pm, 'command' );
}
sub _speller {
my( $self, $said, $pm, $type ) = @_;
my $speller = Text::Aspell->new
or die "Couldn't create a speller!";
$speller->set_option('lang','en_GB');
my $word;
if( $type eq 'command' ) { #Command Mode
$word = $said->{recommended_args}->[0];
}
else { #Text Search Mode
if( $said->{body} =~ /(\w+)\s*\(sp\??\)/ ) {
$word = $1;
}
}
if( $word ) {
if( $speller->check($word) ) {
return( 'handled', "$word seems to be correct!" );
}
else {
return( 'handled', "$word seems to be misspelt, perhaps you meant: " . join " ", $speller->suggest( $word ) );
}
}
return;
}
"Bot::BB3::Plugin::Spell";
__DATA__
Attempt to determine the correct spelling of a word. Operates in two modes, addressed, via the syntax spell word; or in passing when you use the string '(sp?)', without the quotes, after any word in any sentence.

57
plugins/.svn/text-base/unicode.pm.svn-base
View file

@ -1,57 +0,0 @@
# ------------------------
# Originally by Mauke at: http://mauke.ath.cx/stuff/perl/unip
# ------------------------
use Unicode::UCD 'charinfo';
use Encode qw/decode encode_utf8/;
use utf8;
use strict;
sub speng {
my $x = shift;
$x =~ /^0[0-7]+\z/ and return oct $x;
$x =~ /^(?:[Uu]\+|0[Xx])([[:xdigit:]]+)\z/ || (
length($x) > 1 && $x =~ /^([[:xdigit:]]*[A-Fa-f][[:xdigit:]]*)\z/
) and return hex $1;
$x =~ /^[0-9]+\z/ and return $x;
return map ord, split //, $x
}
sub unip {
my @pieces = @_;
my (@out, @err);
for (@pieces) {
my $chr = chr;
my $utf8 = join ' ', unpack '(H2)*', encode_utf8 $chr;
my $x;
unless ($x = charinfo $_) {
push @err, sprintf "U+%X (%s): no match found", $_, $utf8;
next;
}
push @out, "U+$x->{code} ($utf8): $x->{name} [$chr]";
}
\@err, \@out
}
# ------------------------
sub {
my( $said, $pm ) = @_;
utf8::decode( $said->{body} );
my ($err, $out) = unip map speng($_), split " ", $said->{body};
utf8::upgrade( $_ ) for @$err, @$out;
print "Error: @$err\n" if @$err;
print "@$out\n";
}
__DATA__
unicode U+2301; returns the unicode character and associated information given either a unicode character or one of the various ways you can specify a code point.

62
plugins/.svn/text-base/weather.pm.svn-base
View file

@ -1,62 +0,0 @@
use Geo::WeatherNWS;
use Weather::Underground;
use Data::Dumper;
use Geo::IATA;
use List::AllUtils qw/first/;
# Stefan Petrea
# stefan.petrea at gmail.com
# perlhobby.googlecode.com
my $solve_weather = sub {
my $arg = shift;
my $g = Geo::IATA->new;
my $location = first { defined $_->{icao} } @{$g->location($arg)};
my $weather = Weather::Underground->new( place => $location->{icao}, debug => 0 );
my $data = $weather->get_weather;
return ($weather,$data,$location->{location});
};
sub {
my( $said, $pm ) = @_;
my $arg = $said->{body};
s/^\s+//,s/\s+$// for $arg;
if( $arg =~ /^[kK]/ or $arg =~ /^\w{3}$/ ) {
my $w= Geo::WeatherNWS->new;
$w->getreporthttp( $arg );
print "$w->{code}: $w->{temperature_f} degrees, $w->{conditionstext} with a windchill of $w->{windchill_f}f and winds up to $w->{windspeedmph}mph";
}
else {
my $weather = Weather::Underground->new( place => $arg, debug => 0 );
my $data = $weather->get_weather;
my $resolved_location = "";
($weather,$data,$resolved_location) = $solve_weather->($arg) unless $data; # fix it if we have a problem
if( not $data or not @$data ) {
print "Failed to find weather for $arg";
return;
};
$data = $data->[0]; # We want the first one..
my $where =
$resolved_location
? "Resolved location->{$resolved_location}: "
: "$arg:";
print "$where $data->{temperature_fahrenheit} degrees, $data->{conditions} and winds up to $data->{wind_milesperhour}";
}
}
__DATA__
weather <zipcode> or weather <airport code>; attempts to retrieve the weather from a station associated with one of the names you pass it.

5
var/.svn/dir-prop-base
View file

@ -1,5 +0,0 @@
K 13
svn:mergeinfo
V 0
END

266
var/.svn/entries
View file

@ -1,266 +0,0 @@
10
dir
475
svn://erxz.com/bb3/branches/perlbuut/var
svn://erxz.com/bb3
2009-10-03T22:53:42.528878Z
475
simcop
has-props
dcb1cea6-7f7e-4c78-8a22-148ace8ce36e
karma.db
file
489
2009-11-24T20:34:38.000000Z
70ac6e5d8ac91f6750881c984b73713a
2009-11-24T21:26:47.850539Z
489
simcop
has-props
724992
factoids.db
file
488
2009-11-24T00:55:30.000000Z
62e89e9dfeff0a4424a163d1d03b2660
2009-11-24T11:22:27.703097Z
488
simcop
has-props
637952
pastes.db
file
488
2009-10-03T23:06:00.000000Z
7bba0ac438f61ea44c12a29617f77cc5
2009-11-24T11:22:27.703097Z
488
simcop
has-props
3072
hosts.db
file
488
2009-10-03T23:06:00.000000Z
d41d8cd98f00b204e9800998ecf8427e
2009-11-24T11:22:27.703097Z
488
simcop
0
tell.db
file
488
2009-10-03T23:06:00.000000Z
d869be1017f18a7bc7262d352ee8518a
2009-11-24T11:22:27.703097Z
488
simcop
has-props
3072
full_units.storable
file
2009-10-03T22:54:20.000000Z
934aecb527f0d24ad0a2e84b2d4564c4
2009-10-03T22:53:42.528878Z
475
simcop
has-props
870351
seen.db
file
489
2009-11-24T21:30:07.000000Z
dc84fe3544deb9ec7a067de035060613
2009-11-24T21:26:47.850539Z
489
simcop
has-props
6144

5
var/.svn/prop-base/factoids.db.svn-base
View file

@ -1,5 +0,0 @@
K 13
svn:mime-type
V 24
application/octet-stream
END

5
var/.svn/prop-base/full_units.storable.svn-base
View file

@ -1,5 +0,0 @@
K 13
svn:mime-type
V 24
application/octet-stream
END

5
var/.svn/prop-base/karma.db.svn-base
View file

@ -1,5 +0,0 @@
K 13
svn:mime-type
V 24
application/octet-stream
END

5
var/.svn/prop-base/pastes.db.svn-base
View file

@ -1,5 +0,0 @@
K 13
svn:mime-type
V 24
application/octet-stream
END

5
var/.svn/prop-base/seen.db.svn-base
View file

@ -1,5 +0,0 @@
K 13
svn:mime-type
V 24
application/octet-stream
END

5
var/.svn/prop-base/tell.db.svn-base
View file

@ -1,5 +0,0 @@
K 13
svn:mime-type
V 24
application/octet-stream
END

BIN
var/.svn/text-base/factoids.db.svn-base
View file

Binary file not shown.

BIN
var/.svn/text-base/full_units.storable.svn-base
View file

Binary file not shown.

0
var/.svn/text-base/hosts.db.svn-base
View file

BIN
var/.svn/text-base/karma.db.svn-base
View file

Binary file not shown.

BIN
var/.svn/text-base/pastes.db.svn-base
View file

Binary file not shown.

BIN
var/.svn/text-base/seen.db.svn-base
View file

Binary file not shown.

BIN
var/.svn/text-base/tell.db.svn-base
View file

Binary file not shown.