Baerbot ]|[

• Language: Perl
• Operating System: Unix/Linux

Baerbot is a quote bot for Internet Relay Chat (IRC) channels written in Perl.

The bot stores quotes in a MySQL database. Users in a chatroom may request quotes to be displayed , or added/removed if they are privileged to do so. A random quote from a user is displayed as a "welcome back" message when the user joins one of the bot's channels. A userlist is used to specify users privy to administrative commands.

Configuration is stored in $HOME/.baerbot, and options may also be specified on the comm and line. Baerbot is capable of backgrounding itself, which it does by default.

Download: baerbot.tar.gz

baerbot.pl:

################################################################################ ## Baerbot ]|[ IRC Quote Bot ## ----------------------------------------------------------------------------- ## Programmed by Correl J. Roush <correlr@phoenixinquis.net> ## ################################################################################ use strict; use Mysql; use POE qw( Component::IRC ); use POSIX qw( setsid getpid ); use Getopt::Long; ################################################################################ ## Globals ################################################################################ #------------------------------------------------------------------------------- # Program Globals our $VERSION = '0.95a'; # Baerbot]|[ Version our $DAEMON_PID; # PID, when daemonized my %USER_PREFIX = (); # Hash array for holding user prefixes i.e. +,%,@ my @ARGUMENTS = @ARGV; # Permanently retain program arguments my $dbh; # MySQL connection variable my %lastsearch = (); # Holds data from the most recent quote search #------------------------------------------------------------------------------- # Configuration Variables With Default Values my $CONFIG = ''; # Load a custom config file our $DAEMONIZE = 1; # Daemonize by default our $DEBUG = ''; # Debug OFF by default our $NICK = ''; # Bot's nickname our $REALNAME = ''; # Bot's real name our $SERVER = ''; # IRC server to connect to our $PORT = 6667; # Port to connect to on IRC server our $CHANNEL = ''; # Channel(s) the bot will join our $SHOW_HELP = ''; # Show help and exit our $SHOW_VERSION = ''; # Show version and exit our $MYSQL_HOST = '' ; # MySQL Server our $MYSQL_USER = ''; # MySQL User our $MYSQL_PASS = ''; # MySQL Password our $MYSQL_DB = ''; # MySQL Database our $MYSQL_TABLE = ''; # Quotes Table Name our @IRC_COMMANDS = (); # Commands to run after connecting our %USERS = (); # Userlist (for administrative commands) ################################################################################ ## Subroutines ################################################################################ #------------------------------------------------------------------------------- # Load configuration files and parse arguments # # * a config file specified on the commandline overrides values in the default # config file. # * commandline arguments override values in any config files sub configure { @ARGV = @ARGUMENTS; # Reload program arguments for proper rehashing #------------------------------------------------------------------------------- # Read default config file if( -e $ENV{HOME}.'/.baerbot' ) { do $ENV{HOME}.'/.baerbot'; } #------------------------------------------------------------------------------- # Parse commandline arguments GetOptions( 'config=s' => \$CONFIG, 'daemon!' => \$DAEMONIZE, 'debug|D' => \$DEBUG, 'nick=s' => \$NICK, 'realname=s' => \$REALNAME, 'server=s' => \$SERVER, 'port=i' => \$PORT, 'join|c=s' => \$CHANNEL, 'help|h' => \$SHOW_HELP, 'version|v' => \$SHOW_VERSION ); #------------------------------------------------------------------------------- # Read an additional config file supplied on the commandline if( -e $ENV{PWD}.'/'.$CONFIG ) { do $ENV{PWD}.'/'.$CONFIG; } elsif( -e $CONFIG ) { do $CONFIG; } #------------------------------------------------------------------------------- # Since the goal is to have arguments override config files, let's reread those # so they take effect... @ARGV = @ARGUMENTS; GetOptions( 'config=s' => \$CONFIG, 'daemon!' => \$DAEMONIZE, 'debug|D' => \$DEBUG, 'nick=s' => \$NICK, 'realname=s' => \$REALNAME, 'server=s' => \$SERVER, 'port=i' => \$PORT, 'join|c=s' => \$CHANNEL, 'help|h' => \$SHOW_HELP, 'version|v' => \$SHOW_VERSION ); #------------------------------------------------------------------------------- # Aaaaaaaaaaannnnnnnddd we're done :D } sub get_user_data { # Get user level from @USERS by hostmask my $umask = 'q|'.shift(@_).'|'; my $request = shift(@_); my @lines = keys %USERS; close FB; foreach my $line (@lines) { if( $line =~ /^([^\s]+![^\s]+@[^\s]+)$/ ) { my $re = 'q|'.$1.'|'; ( $re = quotemeta $re ) =~ s/\\\*/.*/g; if( $umask =~ $re ) { return $USERS{$line}; } } } return ( 0 ); } sub getquote { # Fetch a random quote, or a quote by it's id my $baleeted = shift(@_); if( not $baleeted =~ /^(accepted|pending|baleeted)$/ ) { $baleeted = 'accepted'; } my $id = shift(@_); my $result = $dbh->query( "select quote_id as id, quote_text as text, quote_rating as rating from $MYSQL_TABLE where baleeted = '" . $baleeted . "'" . ( $id ? " AND quote_id = $id" : "" ) ); if( !$id ) { $result->dataseek( rand( $result->numrows ) ); } my %row = $result->fetchhash; $row{'text'} =~ s/(\r|\n)/ /g; # Empty %lastsearch, since a non-search command was called %lastsearch = (); return %row; } sub searchquote { # Search a quote by its contents my $baleeted = shift(@_); if( not $baleeted =~ /^(accepted|pending|baleeted)$/ ) { $baleeted = 'accepted'; } my $search = shift(@_); $search =~ s/\s+/%/; my $dir = shift(@_); $dir = ( $dir eq 'DESC' ? $dir : 'ASC' ); my $sql = "select quote_id as id, quote_text as text, quote_rating as rating from $MYSQL_TABLE where baleeted = '" . $baleeted . "' AND quote_text like '%" . $search ."%' " . ( ( $lastsearch{'search'} eq $search ) && ( $lastsearch{'dir'} eq $dir ) && $lastsearch{'id'} ? " AND quote_id " . ( $dir eq "ASC" ? "> " : "< " ) . $lastsearch{'id'} : "" ) . " order by id $dir"; my $result = $dbh->query( $sql ); my %row = $result->fetchhash; $lastsearch{'search'} = $search; $lastsearch{'dir'} = $dir; $lastsearch{'id'} = $row{'id'}; $row{'remaining'} = $result->numrows - 1; $row{'text'} =~ s/(\r|\n)/ /g; return %row; } sub searchquote_nick { # Modified quote search to accurately find a person's own quote, for welcoming them back to the channel. my $nick = shift(@_); my $sql = "select quote_id as id, quote_text as text, quote_rating as rating from $MYSQL_TABLE where baleeted = 'accepted' AND ( quote_text like '%<" . $nick . ">%' OR quote_text like '%(" . $nick . ")%' OR quote_text like '%[" . $nick . "]%' OR quote_text like '%*" . $nick . "' )"; my $result = $dbh->query( $sql ); $result->dataseek( rand( $result->numrows ) ); my %row = $result->fetchhash; $row{'text'} =~ s/(\r|\n)/ /g; return %row; } sub delquote { # Mark a quote as removed my $id = shift(@_); $dbh->query( "update $MYSQL_TABLE set baleeted = 'baleeted' where quote_id = " . $id ); } sub acceptquote { # Mark a quote as accepted my $id = shift(@_); $dbh->query( "update $MYSQL_TABLE set baleeted = 'accepted' where quote_id = " . $id ); } sub addquote { # Add a quote to the database, marked as pending review by default my $quote = shift(@_); $dbh->query( "insert into $MYSQL_TABLE( quote_text ) values( " . $dbh->quote( $quote ) . " )" ); } sub parse_command { # Parse public and private messages for bot commands my $kernel = shift(@_); my $mask = shift(@_); my $target = shift(@_); my $command = shift(@_); my $args = shift(@_); my $ulevel = shift(@_); my $nick = $mask; $nick =~ s/^(.*)!.*$/$1/; my (%quote, $text ); if( $command =~ /^\.(p|b)?quote$/ ) { if( $1 && ( $ulevel <= 0 ) ) { return; } # Pending and Removed quotes visible to Operators only my $baleeted = ( !$1 ? 'accepted' : ( $1 eq 'p' ? 'pending' : 'baleeted' ) ); if( !$args ) { %quote = getquote( $baleeted ); $text = "[Quote #" . $quote{'id'} . "] " .$quote{'text'}; } elsif( $args =~ /^\d+$/ ) { %quote = getquote( $baleeted, $args ); $text = "[Quote #" . $quote{'id'} . "] " .$quote{'text'}; } else { %quote = searchquote( $baleeted, $args ); $text = "[Quote #" . $quote{'id'} . "] " .$quote{'text'} . " [" . $quote{'remaining'} . " quote(s) remaining]"; } if( !$quote{id} ) { $kernel->post( 'baerbot', 'privmsg', $target, "No matching quotes found" ); %lastsearch = (); } else { $kernel->post( 'baerbot', 'privmsg', $target, "$text" ); } } if( $command =~ /^\.(p|b)?lastquote$/ ) { if( $1 && ( $ulevel <= 0 ) ) { return; } # Pending and Removed quotes visible to Operators only my $baleeted = ( !$1 ? 'accepted' : ( $1 eq 'p' ? 'pending' : 'baleeted' ) ); if( !$args ) { %quote = searchquote( $baleeted, "", "DESC" ); $text = "[Quote #" . $quote{'id'} . "] " .$quote{'text'} . " [" . $quote{'remaining'} . " quote(s) remaining]"; } else { %quote = searchquote( $baleeted, $args, "DESC" ); $text = "[Quote #" . $quote{'id'} . "] " .$quote{'text'} . " [" . $quote{'remaining'} . " quote(s) remaining]"; } if( !$quote{id} ) { $kernel->post( 'baerbot', 'privmsg', $target, "No matching quotes found" ); %lastsearch = (); } else { $kernel->post( 'baerbot', 'privmsg', $target, "$text" ); } } if( $command eq ".ulevel" && ( !$args || $args =~ /^[^\s]+![^\s]+@[^\s]+$/ ) ) { $nick = $args ? $args : $mask; $nick =~ s/^(.*)!.*$/$1/; $kernel->post( 'baerbot', 'privmsg', $target, "User Level for " . ( $args ? $args : $mask ) . ": " . get_user_data( ( $args ? $args : $mask ) ) . " " . $USER_PREFIX{$target}{$nick} ); } if( $command eq ".info" ) { $kernel->post( 'baerbot', 'privmsg', $target, "Baerbot]|[ IRC Quote Bot $VERSION " . ( $DAEMONIZE ? "[daemon, PID " . getpid . "]" : "[standalone" . ( $DEBUG ? ", DEBUG" : "" ) . "]" ) ); } if( ( $USER_PREFIX{$target}{$nick} && $target =~ /#/ ) || $ulevel > 0 ) { # Commands for voiced / authorized users if( $command eq ".addquote" ) { if( $args ) { addquote( $args ); $kernel->post( 'baerbot', 'privmsg', $target, "Quote has been added to the database and is awaiting review." ); } } if( $USER_PREFIX{$target}{$nick} eq '+' && $ulevel <= 0 ) { return; } # Commands for halfopped / opped / authorized users if( $command eq ".delquote" ) { if( $args =~/^\d+$/ ) { delquote( $args ); $kernel->post( 'baerbot', 'privmsg', $target, "Quote #$args has been removed." ); } } if( $ulevel <= 0 ) { return; } # Commands for authorized users only if( $command eq ".acceptquote" ) { if( $args =~ /^\d+$/ ) { acceptquote( $args ); $kernel->post( 'baerbot', 'privmsg', $target, "Quote #$args has been accepted." ); } } if( $ulevel < 1000 ) { return; } # Commands for Owner ONLY if( $command eq ".die" ) { $kernel->post( 'baerbot', 'quit', 'Baerbot]|[' . ( $args ? ': ' . $args : '' ) ); } if( $command eq ".raw" && $args ) { $kernel->post( 'baerbot', 'sl', $args ); } if( $command eq ".eval" && $args ) { $kernel->post( 'baerbot', 'privmsg', $target, $args . ' = ' . eval( $args ) ); } if( $command eq ".rehash" ) { configure; $kernel->post( 'baerbot', 'privmsg', $target, 'Rehashed configuration.' ); } } } ################################################################################ ## Event Handlers ################################################################################ sub _start { my ($kernel) = $_[KERNEL]; $kernel->post( 'baerbot', 'register', 'all'); $kernel->post( 'baerbot', 'connect', { Debug => ( $DEBUG ? 1 : 0 ), Nick => $NICK, Server => $SERVER, Port => $PORT, Username => 'Baerbot', Ircname => $REALNAME } ); $kernel->sig( INT => "sigint" ); $kernel->sig( TERM => "sigterm" ); } sub irc_001 { # IRC Connected event my ($kernel) = $_[KERNEL]; $kernel->post( 'baerbot', 'mode', $NICK, '+i' ); foreach my $command (@IRC_COMMANDS) { print "EXECUTING $command\n"; $kernel->post( 'baerbot', 'sl', $command ); } $kernel->post( 'baerbot', 'join', $CHANNEL ); } sub irc_disconnected { my ($server) = $_[ARG0]; print "Lost connection to server $server.\n"; $_[KERNEL]->post( "baerbot", "unregister", "all" ); } sub irc_error { my $err = $_[ARG0]; print "Server error occurred! $err\n"; } sub irc_socketerr { my $err = $_[ARG0]; print "Couldn't connect to server: $err\n"; exit( 1 ); } sub sigint { my $kernel = $_[KERNEL]; $kernel->post( 'baerbot', 'quit', 'Baerbot]|[ (SIGINT)' ); $kernel->sig_handled(); } sub sigterm { my $kernel = $_[KERNEL]; $kernel->post( 'baerbot', 'quit', 'Baerbot]|[ (SIGTERM)' ); $kernel->sig_handled(); } sub _stop { my ($kernel) = $_[KERNEL]; print "Control session stopped.\n"; } sub irc_353 { # RPL_NAMES # Fill a table with nicknames and their prefixes, if applicable (+,%,@) my ($kernel, $msg) = @_[KERNEL, ARG1]; $msg =~ /(#.*?)\s+:(.*)$/; my ($chan,$names) = ($1, $2); my @nicklist = split( /\s+/, $names ); foreach my $nickname (@nicklist) { $nickname =~ /^(\+|%|@|\.|&|~)?(.*)$/; $USER_PREFIX{$chan}{$2} = $1; } } sub irc_msg { my ($kernel, $mask, $target, $msg) = @_[KERNEL, ARG0 .. ARG2]; my $target = $mask; $target =~ s/^(.*)!.*$/$1/; $msg =~ /([^ ]+)(\s+(.*))?/; my $command = $1; my $args = $3; my $ulevel = get_user_data( $mask ); parse_command( $kernel, $mask, $target, $command, $args, $ulevel ); } sub irc_public { my ($kernel, $mask, $target, $msg) = @_[KERNEL, ARG0 .. ARG2]; $target = @$target[0]; # $target is recieved as an array reference, we only want the first target for simplicity's sake. $msg =~ /([^ ]+)(\s+(.*))?/; my $command = $1; my $args = $3; my $ulevel = get_user_data( $mask ); parse_command( $kernel, $mask, $target, $command, $args, $ulevel ); } sub irc_join { my ($kernel, $mask, $chan) = @_[KERNEL, ARG0, ARG1]; my $join_nick = $mask; $join_nick =~ s/^(.*)!.*$/$1/; if( $join_nick eq $NICK ) { #Fetch /NAMES when joining a channel $kernel->post( 'baerbot', 'names', $chan ); return; } my %quote = searchquote_nick( $join_nick ); if( !$quote{'id'} ) { return; } $kernel->post( 'baerbot', 'privmsg', $chan, "[Welcome Back \002" . $join_nick . "\002][Quote #" . $quote{'id'} . "] " .$quote{'text'} ); } sub irc_mode { my ($kernel, $chan) = @_[KERNEL, ARG1]; if( not $chan =~ /#/ ) { return; } $kernel->post( 'baerbot', 'names', $chan ); } sub irc_nick { my ($kernel, $mask, $newnick) = @_[KERNEL, ARG0, ARG1]; my $nick = $mask; $nick =~ s/^(.*)!.*$/$1/; foreach my $channel (keys %USER_PREFIX) { my $chanhashref = $USER_PREFIX{$channel}; my %chanhash = %$chanhashref; foreach my $user (keys ( %chanhash ) ) { if( $user eq $nick ) { $USER_PREFIX{$channel}{$newnick} = $USER_PREFIX{$channel}{$user}; delete $USER_PREFIX{$channel}{$user}; } } } } sub irc_kick { my ($kernel, $chan, $nick) = @_[KERNEL, ARG1, ARG2]; if( $nick eq $NICK ) { $kernel->post( 'baerbot', 'join', $chan ); } } sub irc_ctcp_version { my ($kernel, $mask) = @_[KERNEL, ARG0]; my $nick = $mask; $nick =~ s/^(.*)!.*$/$1/; $kernel->post( 'baerbot', 'ctcpreply', $nick, "Baerbot]|[ IRC Quote Bot $VERSION " . ( $DAEMONIZE ? "[daemon, PID " . getpid . "]" : "[standalone" . ( $DEBUG ? ", DEBUG" : "" ) . "]" ) ); } ################################################################################ ## Program Code ################################################################################ #------------------------------------------------------------------------------- # Seed random number generator srand(); #------------------------------------------------------------------------------- # Read configuration and arguments configure; #------------------------------------------------------------------------------- # Act on configuration if( $SHOW_HELP ){ print "Baerbot]|[ IRC Quote Bot $VERSION Help\n\n" . "Usage: baerbot server [options]\n\n" . "\t--help -h Show this help text\n" . "\t--no-daemon Runs without forking\n" . "\t--debug -D Shows debug text (forces --no-daemon)\n\n" . "\t--config=/path/to/custom.conf Loads a custom config file\n\n" . "\t--nick=nickname Set the bot's nickname\n" . "\t--realname=name Set the bot's real name\n" . "\t--server=server Specify the IRC server to connect to\n" . "\t--port=port Specify the port to connect to (default=6667)\n" . "\t--join=#channel -c=#channel Specify the channel(s) to join to\n" . "\t\t\t\t\t(Separate multiple channels with commas)\n\n" . "\t--db-host=server MySQL server address\n" . "\t--db-user=user MySQL username\n" . "\t--db-pass=pass MySQL password\n" . "\t--db-database=dbname MySQL database\n" . "\t--db-table=tablename MySQL table\n\n"; exit( 0 ); } if( $SHOW_VERSION ) { print "$VERSION\n"; exit( 0 ); } if( $DEBUG ) { # Debug automatically disables daemonizing -- little hard to see debug info that way ;o)~ $DAEMONIZE = ''; } if( $DAEMONIZE ) { # Move the process into the background chdir '/' or die "Can't chdir to /: $!"; umask 0; defined( my $pid = fork ) or die "Can't fork: $!"; print "Backgrounding, PID=$pid\n" if $pid; open STDIN, '/dev/null' or die "Can't read /dev/null: $!"; open STDOUT, '/dev/null' or die "Can't write to /dev/null: $!"; open STDERR, '/dev/null' or die "Can't write to /dev/null: $!"; exit if $pid; setsid or die "Can't start a new session: $!"; } #------------------------------------------------------------------------------- # Set up database connection $dbh = Mysql->connect( $MYSQL_HOST, $MYSQL_DB, $MYSQL_USER, $MYSQL_PASS) or die "Error connecting to database: $!"; #------------------------------------------------------------------------------- # Register and activate the IRC client object POE::Component::IRC->new( 'baerbot' ) or die "Can't instantiate new IRC component!\n"; POE::Session->new( 'main' => [qw(_start _stop irc_001 irc_disconnected sigint sigterm irc_socketerr irc_error irc_353 irc_ctcp_version irc_msg irc_public irc_join irc_mode irc_nick irc_kick)] ); $poe_kernel->run(); exit 0;

baerbot.conf:

# Save this file to ~/.baerbot to use it. $DAEMONIZE = 1; # Daemonize by default $DEBUG = ''; # Debug OFF by default (setting this to 1 disables DAEMONIZE) $NICK = 'Baerbot]|['; # Bot's nickname $REALNAME = 'Baerbot]|['; # Bot's real name $SERVER = 'irc.ryucross.com'; # IRC server to connect to $PORT = 6667; # Port to connect to on IRC server $CHANNEL = '#mychannel'; # Channel(s) the bot will join $MYSQL_HOST = 'localhost'; # MySQL Server $MYSQL_USER = ''; # MySQL User $MYSQL_PASS = ''; # MySQL Password $MYSQL_DB = ''; # MySQL Database $MYSQL_TABLE = ''; # Quotes Table Name # The following raw commands will be run immediately after connecting to the irc server # This is useful for identifying to NickServ, for example, separated by commas @IRC_COMMANDS = ( # "NICKSERV :IDENTIFY password", ); # Userlist for administrative commands # Be sure to put ambiguous hostmasks last in the list, to prevent them from overriding # more specific masks. # # Any ulevel over 0 can moderate quotes (view pending/deleted, accept/remove quotes) # Only ulevels 1000+ may access owner commands (.die, .raw) %USERS = ( # 'nick!user@my.host.mask' => 1000, );