http://www.perlmonks.org?node_id=135449

hi again monks..

i've been doing some hacking on what i think is the most fun project ive ever undertaken. this bot i've written has been growing over a period of about a year. i originally created it to replicate a bot on irc.openprojects.net's #perl, but found that it could do so much stuff that was useful that i just kept hacking on it.

i also used it as a way to teach a good friend of mine perl. i gave him ideas and helped him when he stumbled. eventually the friend took over the script and added some more stuff to it. a few months later, i found that i wanted to resume hacking on it, and grabbed the source from the friend.

in that period, i had grown a bit as a programmer, and also tackled some interesting problems at work which required innovative solutions. so this code that i had worked on 6-7 months ago was kind of... not fun to work on. so i began rewriting.

well, at the end of last weekend, the bot was over 1,300 lines. it took a couple seconds to even change the syntax of the bot. i also was frustrated with the problem of having to kill and restart the bot every time i spotted a bug, or it started to be annoying.

i scratched my head and decided i needed to be able to turn the functions on and off... but that wasnt just enough. i needed to be able to actually edit them without restarting it. so i decided to store the code in a database (since the bot uses a database quite extensively already), and load it in (and unload it) on the fly.

it turned out to be a LOT easier than i expected, and far more useful.

i think if you go over the code you'll notice the API is quite easy to use. anyone who can read basic perl can set up a perl mp3::napster bot with a minimum of trouble. its literally plug-and-play. especially without the database stuff.

so, here is the code for the bot. its very simple. in order to use it, you'd need the database set up. i'm willing to provide a schema to anyone who wants it, just mail me. i dont listen to the chatterbox much.

brother dep

#!/usr/bin/perl use warnings; use strict; use vars qw{ $dbh $nap $daemon %children $mynick $maintainer $debug $epoch }; use lib qw{ lib . }; use Carp qw{ cluck croak carp }; use Data::Dumper; use DBI; use MP3::Napster; use constant MSG_SERVER_NOSUCH => 404; use constant MSG_SERVER_PUBLIC => 403; use constant MSG_CLIENT_EMOTE => 824; use constant MSG_CLIENT_PRIVMSG => 205; $daemon = 1; $debug = 0; $epoch = time(); $daemon and daemonize(); database_initialize(); napster_initialize(); admin_initialize(); callbacks_initialize(); $nap -> run(); END { $dbh -> disconnect(); $nap -> disconnect(); exit 0; } sub daemonize { #exit if fork(); fork and exit; } sub database_initialize { my $DBD = "Pg"; my $dbname = "botdb"; my $dbhost = "localhost"; my $dbuser = "alex"; my $dbpass = ""; my @dbi_params = ( "dbi:".$DBD.":dbname=".$dbname.";host=".$dbhost, $dbuser, $dbpass, ); $dbh = DBI -> connect(@dbi_params) or croak "".DBI -> errstr."\n"; # this is kind of sucky, blame per +l. 1; } sub napster_initialize { my $config_sth = $dbh -> prepare(qq{ select username, password, server, port, channel from config }); $config_sth -> execute(); my ($username, $password, $server, $port, $channel) = map { @{ $_ } } @{ $config_sth -> fetchall_arrayref() }; $mynick = $username; $nap = MP3::Napster -> new( -server => qq{$server:$port} ); $nap -> login($username, $password) or croak "could not log in to server $server [". $nap -> error() . +"]\n"; $nap -> join_channel($channel); my $package = __PACKAGE__; %children = map { $_ => { } } grep { defined $_ and $_ } map { $_ =~ s/${package}::([A-Z_]+)/$1/ && $_ } keys %constant::declared; $children{MSG_SERVER_PUBLIC} -> { load_sub -> () } = \&load_sub; $children{MSG_SERVER_PUBLIC} -> { unload_sub -> () } = \&unload_ +sub; 1; } sub admin_initialize { # this does not work in darwin. $0 =~ s/.*/petunia -d/; # set up some maintainers my $maintainer_sth = $dbh -> prepare(qq{ select maintainer from config }); $maintainer_sth -> execute(); my (@maintainers) = grep { defined $_ } map { @{ $_ } } @{ $maintainer_sth -> fetchall_arrayref() }; $maintainer = join "|", @maintainers; $maintainer = qr{$maintainer}; undef $maintainer_sth; 1; } sub callbacks_initialize { carp "callbacks\n"; $nap -> callback (MSG_SERVER_NOSUCH, sub { server_error_messages($_[ +0], [@_[1..$#_]]) }); $nap -> callback (MSG_SERVER_PUBLIC, sub { public_messages($_[0], [@ +_[1..$#_]]) }); $nap -> callback (MSG_CLIENT_EMOTE, sub { emote_messages($_[0], [@_[ +1..$#_]]) }); $nap -> callback (MSG_CLIENT_PRIVMSG, sub { private_messages($_[0], +[@_[1..$#_]]) }); } sub server_error_messages { 1; } sub public_messages { my $nap_object = shift; my @args = @{ shift() }; my ($ec, $message) = @args; return unless my ($channel, $nick, $packet) = $message =~ /^(\S+) (\ +S+) (.*)/; return unless $nick !~ /^$mynick$/; if (!$daemon and $debug) { print "[ $ec ] [ $channel/$nick ] [ $packet ]\n"; } foreach my $child (keys %{ $children{MSG_SERVER_PUBLIC} }) { $children{MSG_SERVER_PUBLIC} -> {$child} -> ($channel, $nick, $pac +ket); } } sub emote_messages { 1; } sub private_message { 1; } # this is pretty cool. put a sub in that was in the database. sub load_sub { my ($thischan, $thisuser, $thismsg) = (@_); return "load_sub" if @_ == 0; return unless $thismsg =~ /^:load /; my ($sub_to_load) = $thismsg =~ /^:load (\S+)/; print "\t-> loading $sub_to_load\n"; my $selector = $dbh -> prepare(qq{ select code from subs where name = ? }); $selector -> execute($sub_to_load); my ($sub) = map { @{ $_ } } @{ $selector -> fetchall_arrayref() }; if (!$sub) { print "\t-> could not find $sub_to_load\n"; } else { eval $sub; { # yes, this is necessary. no strict qw{ refs }; $children{MSG_SERVER_PUBLIC} -> { &{$sub_to_load}() } = \&am +p;{$sub_to_load}; } if ($@) { $nap -> public_message("$sub_to_load had some problems:"); $nap -> public_message($@); return 0; } else { # it was probably good $nap -> public_message("$sub_to_load loaded without errors."); } } } sub unload_sub { my ($thischan, $thisuser, $thismsg) = (@_); return "unload_sub" if @_ == 0; return unless $thismsg =~ /^:unload /; my ($sub_to_unload) = $thismsg =~ /^:unload (\S+)/; # check if its extant and if its readonly and if its loaded. my $checker_sth = $dbh -> prepare(qq{ select name, readonly from subs where name = ? }); $checker_sth -> execute($sub_to_unload); my (@attrib) = map { @{ $_ } } @{ $checker_sth -> fetchall_arrayref( +) }; my ($name, $ro) = @attrib; if ($ro) { # this is a readonly sub, and we do not let the user remove it. $nap -> public_message( "sorry, $sub_to_unload is read-only." ); return 0; } elsif (not defined $children{MSG_SERVER_PUBLIC} -> {$sub_to_unload}) + { # the sub is not extant in the hash $nap -> public_message( "sorry, $sub_to_unload is not loaded." ); return 0; } else { # it is extant and rw delete $children{MSG_SERVER_PUBLIC} -> {$sub_to_unload}; $nap -> public_message( "$sub_to_unload removed." ); return 1; } return 0; }

--
Laziness, Impatience, Hubris, and Generosity.

Server Error (Error ID 1694622c2133047)

An error has occurred. The site administrators have been notified of the problem and will likely soon fix it. We thank you, for you're patients.