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;
}
[download]

--
Laziness, Impatience, Hubris, and Generosity.