Skip to content

Instantly share code, notes, and snippets.

@ubermuda

ubermuda/atnext.rb

Created August 19, 2008 09:56
Show Gist options
  • Save ubermuda/6166 to your computer and use it in GitHub Desktop.
Save ubermuda/6166 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
atnext.rb
# AtNext plugin
# todo
# implement $next :word [:from]
class AtNextPlugin < Plugin
def initialize()
super
@reminders = Array.new
@trash = Array.new
end
def help(plugin, topic = '')
return 'atnext lets you define a reminder triggered by a word'
end
def register_reminder(m, params)
@reminders.push({ :nick => m.source, :word => params[:word], :reminder => params[:reminder] })
#m.reply('reminder registered')
end
def listen(m)
@trash.each do |r|
if (m.source == r[:nick])
if (m.message == 'postpone')
@reminders.push(r)
end
@trash.delete(r)
return
end
end
@reminders.each do |r|
#m.reply('testing nick: ' + m.source + ' word: ' + m.message)
#m.reply('over nick ' + r[:nick] + ' word: ' + r[:word])
if (m.source == r[:nick] and m.message == r[:word])
m.reply(m.source.to_s + ': ' + r[:reminder].to_s)
@trash.push(r)
@reminders.delete(r)
end
end
end
end
plugin = AtNextPlugin.new
plugin.map('next :word *reminder', :action => 'register_reminder')
Raw
url.pl
#!/usr/bin/perl
use strict;
use vars qw($VERSION %IRSSI);
use Irssi;
use DBI;
$VERSION = '0.1';
%IRSSI = (
author => 'Geoffrey Bachelet',
contact => '[email protected]',
name => 'Debug Bot',
description => 'Quick Bot Script',
license => 'Not to be redistributed',
);
Irssi::signal_add('event privmsg', 'event_privmsg');
sub trim {
my $string = shift;
my $char = chop $string;
if ($char ne ' ') {
$string .= $char;
}
return $string;
}
our ($home, $url_regexp, %dbi, $dontgrab);
$home = '/home/ash/irssibot/debug/';
$url_regexp = `/usr/bin/perl -wT $home/scripts/library/url3.pl`;
%dbi = (
datasource => 'dbi:mysql:irssi_debug',
username => 'irssi',
password => '.jeJbLcPRxfr8ucL',
);
$dontgrab = 'pastey.net|paste2.org|pastie.caboo.se|pastebin|localhost|http:\/\/10.|example.com|r.phpug.se';
sub get_dbh {
return DBI->connect($dbi{'datasource'}, $dbi{'username'}, $dbi{'password'}) or die $DBI::errstr;
}
sub event_privmsg {
my ($server, $data, $nick, $mask) = @_;
my ($target, $text) = $data =~ /^(\S*)\s:(.*)/;
my $mode = 'public';
if ($target =~ /^debug/) {
$mode = 'query';
$target = $nick;
}
my $dbh = &get_dbh();
if ($text =~ /($url_regexp)/) {
if ($1 =~ /$dontgrab/) {
return 0;
}
my $sql = qq { INSERT INTO urls (url, context, channel, nick, datetime) VALUES(?, ?, ?, ?, NOW()) };
my $sth = $dbh->prepare($sql);
$sth->bind_param(1, $1);
$sth->bind_param(2, $text);
$sth->bind_param(3, $target);
$sth->bind_param(4, $nick);
if ($sth->execute()) {
print 'url registered: '.$1;
}
}
if (my ($id) = ($text =~ /^\$url del (\d+)$/)) {
if ($nick eq 'ash' || $nick eq 'mirmo') {
my $sql = qq { DELETE FROM urls WHERE id = ? };
my $sth = $dbh->prepare($sql);
$sth->bind_param(1, $id);
$sth->execute();
} else {
$server->command('MSG '.$target.' NAON !!!');
}
}
if (my ($id) = ($text =~ /^\$url( \d+)?$/)) {
my @rows;
if ($id ne '') {
@rows = $dbh->selectrow_array(qq { SELECT id, url FROM urls WHERE id = ? }, undef, $id);
} else {
@rows = $dbh->selectrow_array(qq { SELECT id, url FROM urls ORDER BY RAND() LIMIT 1 });
}
my ($id, $url) = @rows;
if ($id ne '') {
$server->command('MSG '.$target.' #'.$id.' '.$url);
} else {
$server->command('MSG '.$target.' url not found: '.$1);
}
}
if ($text =~ /^\$url like ([A-Za-z0-9_.%?-]+)( ([0-9]+))?$/) {
my $limit = $3 ? qq { LIMIT $3,5 } : 'LIMIT 5';
my $sql = qq { SELECT SQL_CALC_FOUND_ROWS id, url FROM urls WHERE url LIKE '%$1%' ORDER BY datetime DESC $limit };
my $sth = $dbh->prepare($sql);
$sth->execute();
my $counth = $dbh->prepare('SELECT FOUND_ROWS();');
$counth->execute();
my ($found_rows);
$counth->bind_columns(undef, \$found_rows);
$counth->fetch();
$server->command('MSG '.$target.' '.$found_rows.' urls matching your pattern');
my ($id, $url);
$sth->bind_columns(undef, \$id, \$url);
while ($sth->fetch()) {
$server->command('MSG '.$target.' #'.$id.' '.$url);
}
}
if ($text =~ /^\$url last$/) {
my $sql = qq { SELECT id, url FROM urls ORDER BY datetime DESC LIMIT 1 };
my $sth = $dbh->prepare($sql);
$sth->execute();
my ($id, $url);
$sth->bind_columns(undef, \$id, \$url);
while ($sth->fetch()) {
$server->command('MSG '.$target.' #'.$id.' '.$url);
}
}
if ($text =~ /^\$url tail$/) {
my $sql = qq { SELECT id, url FROM urls ORDER BY datetime DESC LIMIT 5 };
my $sth = $dbh->prepare($sql);
$sth->execute();
my ($_id, $_url);
$sth->bind_columns(undef, \$_id, \$_url);
while ($sth->fetch()) {
$server->command('MSG '.$target.' #'.$_id.' '.$_url);
}
}
if ($text =~ /^\$url info (\d+)$/) {
my $sql = qq { SELECT id, url, datetime, channel, nick FROM urls WHERE id = ? };
my $sth = $dbh->prepare($sql);
$sth->bind_param(1, $1);
$sth->execute();
my ($_id, $_url, $_datetime, $_channel, $_nick);
$sth->bind_columns(undef, \$_id, \$_url, \$_datetime, \$_channel, \$_nick);
while ($sth->fetch()) {
$server->command('MSG '.$target.' #'.$_id.' said by '.$_nick.' on '.$_channel.' at '.$_datetime);
}
}
}
Raw
url3.pl
#!/usr/local/bin/perl -wT
use Carp;
use strict;
# Be paranoid about using grouping!
my $nz_digit = '[1-9]';
my $nz_digits = "(?:$nz_digit\\d*)";
my $digits = '(?:\d+)';
my $space = '(?:%20)';
my $nl = '(?:%0[Aa])';
my $dot = '\.';
my $plus = '\+';
my $qm = '\?';
my $ast = '\*';
my $hex = '[a-fA-F\d]';
my $alpha = '[a-zA-Z]'; # No, no locale.
my $alphas = "(?:${alpha}+)";
my $alphanum = '[a-zA-Z\d]'; # Letter or digit.
my $xalphanum = "(?:${alphanum}|%(?:3\\d|[46]$hex|[57][Aa\\d]))";
# Letter or digit, or hex escaped letter/digit.
my $alphanums = "(?:${alphanum}+)";
my $escape = "(?:%$hex\{2})";
my $safe = '[$\-_.+]';
my $extra = "[!*'(),]";
my $national = '[{}|\\^~[\]`]';
my $punctuation = '[<>#%"]';
my $reserved = '[;/?:@&=]';
my $uchar = "(?:${alphanum}|${safe}|${extra}|${escape})";
my $xchar = "(?:${alphanum}|${safe}|${extra}|${reserved}|${escape})";
$uchar =~ s/\Q]|[\E//g; # Make string smaller, and speed up regex.
$xchar =~ s/\Q]|[\E//g; # Make string smaller, and speed up regex.
# URL schemeparts for ip based protocols:
my $user = "(?:(?:${uchar}|[;?&=])*)";
my $password = "(?:(?:${uchar}|[;?&=])*)";
my $hostnumber = "(?:${digits}(?:${dot}${digits}){3})";
my $toplabel = "(?:${alpha}(?:(?:${alphanum}|-)*${alphanum})?)";
my $domainlabel = "(?:${alphanum}(?:(?:${alphanum}|-)*${alphanum})?)";
my $hostname = "(?:(?:${domainlabel}${dot})*${toplabel})";
my $host = "(?:${hostname}|${hostnumber})";
my $hostport = "(?:${host}(?::${digits})?)";
my $login = "(?:(?:${user}(?::${password})?\@)?${hostport})";
# The predefined schemes:
# FTP (see also RFC959)
my $fsegment = "(?:(?:${uchar}|[?:\@&=])*)";
my $fpath = "(?:${fsegment}(?:/${fsegment})*)";
my $ftpurl = "(?:ftp://${login}(?:/${fpath}(?:;type=[AIDaid])?)?)";
# FILE
my $fileurl = "(?:file://(?:${host}|localhost)?/${fpath})";
# HTTP
my $hsegment = "(?:(?:${uchar}|[~;:\@&=])*)";
my $search = "(?:(?:${uchar}|[/;:\@&=])*)";
my $hpath = "(?:${hsegment}(?:/${hsegment})*)";
my $httpurl = "(?:http://${hostport}(?:/${hpath}(?:${qm}${search})?)?)";
# GOPHER (see also RFC1436)
my $gopher_plus = "(?:${xchar}*)";
my $selector = "(?:${xchar}*)";
my $gtype = ${xchar}; # Omitted parens!
my $gopherurl = "(?:gopher://${hostport}(?:/${gtype}(?:${selector}" .
"(?:%09${search}(?:%09${gopher_plus})?)?)?)?)";
# MAILTO (see also RFC822)
my $encoded822addr = "(?:$xchar+)";
my $mailtourl = "(?:mailto:$encoded822addr)";
# NEWS (see also RFC1036)
my $article = "(?:(?:${uchar}|[;/?:&=])+\@${host})";
my $group = "(?:${alpha}(?:${alphanum}|[_.+-])*)";
my $grouppart = "(?:${article}|${group}|${ast})";
my $newsurl = "(?:news:${grouppart})";
# NNTP (see also RFC977)
my $nntpurl = "(?:nntp://${hostport}/${group}(?:/${digits})?)";
# TELNET
my $telneturl = "(?:telnet://${login}/?)";
# WAIS (see also RFC1625)
my $wpath = "(?:${uchar}*)";
my $wtype = "(?:${uchar}*)";
my $database = "(?:${uchar}*)";
my $waisdoc = "(?:wais://${hostport}/${database}/${wtype}/${wpath})";
my $waisindex = "(?:wais://${hostport}/${database}${qm}${search})";
my $waisdatabase = "(?:wais://${hostport}/${database})";
# my $waisurl = "(?:${waisdatabase}|${waisindex}|${waisdoc})";
# Speed up: the 3 types share a common prefix.
my $waisurl = "(?:wais://${hostport}/${database}" .
"(?:(?:/${wtype}/${wpath})|${qm}${search})?)";
# PROSPERO
my $fieldvalue = "(?:(?:${uchar}|[?:\@&])*)";
my $fieldname = "(?:(?:${uchar}|[?:\@&])*)";
my $fieldspec = "(?:;${fieldname}=${fieldvalue})";
my $psegment = "(?:(?:${uchar}|[?:\@&=])*)";
my $ppath = "(?:${psegment}(?:/${psegment})*)";
my $prosperourl = "(?:prospero://${hostport}/${ppath}(?:${fieldspec})*)";
# LDAP (see also RFC1959)
# First. import stuff from RFC 1779 (Distinguished Names).
# We've modified things a bit.
my $dn_separator = "(?:[;,])";
my $dn_optional_space = "(?:${nl}?${space}*)";
my $dn_spaced_separator = "(?:${dn_optional_space}${dn_separator}" .
"${dn_optional_space})";
my $dn_oid = "(?:${digits}(?:${dot}${digits})*)";
my $dn_keychar = "(?:${xalphanum}|${space})";
my $dn_key = "(?:${dn_keychar}+|(?:OID|oid)${dot}${dn_oid})";
my $dn_string = "(?:${uchar}*)";
my $dn_attribute = "(?:(?:${dn_key}${dn_optional_space}=" .
"${dn_optional_space})?${dn_string})";
my $dn_name_component = "(?:${dn_attribute}(?:${dn_optional_space}" .
"${plus}${dn_optional_space}${dn_attribute})*)";
my $dn_name = "(?:${dn_name_component}" .
"(?:${dn_spaced_separator}${dn_name_component})*" .
"${dn_spaced_separator}?)";
# RFC 1558 defines the filter syntax, but that requires a PDA to recognize.
# Since that's too powerful for Perl's REs, we allow any char between the
# parenthesis (which have to be there.)
my $ldap_filter = "(?:\(${xchar}+\))";
# This is from RFC 1777. It defines an attributetype as an 'OCTET STRING',
# whatever that is.
my $ldap_attr_type = "(?:${uchar}+)"; # I'm just guessing here.
# The RFCs aren't clear.
# Now we are at the grammar of RFC 1959.
my $ldap_attr_list = "(?:${ldap_attr_type}(?:,${ldap_attr_type})*)";
my $ldap_attrs = "(?:${ldap_attr_list}?)";
my $ldap_scope = "(?:base|one|sub)";
my $ldapurl = "(?:ldap://(?:${hostport})?/${dn_name}" .
"(?:${qm}${ldap_attrs}" .
"(?:${qm}${ldap_scope}(?:${qm}${ldap_filter})?)?)?)";
# RFC 2056 defines the format of URLs for the Z39.50 protocol.
my $z_database = "(?:${uchar}+)";
my $z_docid = "(?:${uchar}+)";
my $z_elementset = "(?:${uchar}+)";
my $z_recordsyntax = "(?:${uchar}+)";
my $z_scheme = "(?:z39${dot}50[rs])";
my $z39_50url = "(?:${z_scheme}://${hostport}" .
"(?:/(?:${z_database}(?:${plus}${z_database})*" .
"(?:${qm}${z_docid})?)?" .
"(?:;esn=${z_elementset})?" .
"(?:;rs=${z_recordsyntax}" .
"(?:${plus}${z_recordsyntax})*)?))";
# RFC 2111 defines the format for cid/mid URLs.
my $url_addr_spec = "(?:(?:${uchar}|[;?:@&=])*)";
my $message_id = $url_addr_spec;
my $content_id = $url_addr_spec;
my $cidurl = "(?:cid:${content_id})";
my $midurl = "(?:mid:${message_id}(?:/${content_id})?)";
# RFC 2122 defines the Vemmi URLs.
my $vemmi_attr = "(?:(?:${uchar}|[/?:@&])*)";
my $vemmi_value = "(?:(?:${uchar}|[/?:@&])*)";
my $vemmi_service = "(?:(?:${uchar}|[/?:@&=])*)";
my $vemmi_param = "(?:;${vemmi_attr}=${vemmi_value})";
my $vemmiurl = "(?:vemmi://${hostport}" .
"(?:/${vemmi_service}(?:${vemmi_param}*))?)";
# RFC 2192 for IMAP URLs.
# Import from RFC 2060.
# my $imap4_astring = "";
# my $imap4_search_key = "";
# my $imap4_section_text = "";
my $imap4_nz_number = $nz_digits;
my $achar = "(?:${uchar}|[&=~])";
my $bchar = "(?:${uchar}|[&=~:\@/])";
my $enc_auth_type = "(?:${achar}+)";
my $enc_list_mbox = "(?:${bchar}+)";
my $enc_mailbox = "(?:${bchar}+)";
my $enc_search = "(?:${bchar}+)";
my $enc_section = "(?:${bchar}+)";
my $enc_user = "(?:${achar}+)";
my $i_auth = "(?:;[Aa][Uu][Tt][Hh]=(?:${ast}|${enc_auth_type}))";
my $i_list_type = "(?:[Ll](?:[Ii][Ss][Tt]|[Ss][Uu][Bb]))";
my $i_mailboxlist = "(?:${enc_list_mbox}?;[Tt][Yy][Pp][Ee]=${i_list_type})";
my $i_uidvalidity = "(?:;[Uu][Ii][Dd][Vv][Aa][Ll][Ii][Dd][Ii][Tt][Yy]=" .
"${imap4_nz_number})";
my $i_messagelist = "(?:${enc_mailbox}(?:${qm}${enc_search})?" .
"(?:${i_uidvalidity})?)";
my $i_section = "(?:/;[Ss][Ee][Cc][Tt][Ii][Oo][Nn]=${enc_section})";
my $i_uid = "(?:/;[Uu][Ii][Dd]=${imap4_nz_number})";
my $i_messagepart = "(?:${enc_mailbox}(?:${i_uidvalidity})?${i_uid}" .
"(?:${i_section})?)";
my $i_command = "(?:${i_mailboxlist}|${i_messagelist}|${i_messagepart})";
my $i_userauth = "(?:(?:${enc_user}(?:${i_auth})?)|" .
"(?:${i_auth}(?:${enc_user})?))";
my $i_server = "(?:(?:${i_userauth}\@)?${hostport})";
my $imapurl = "(?:imap://${i_server}/(?:$i_command)?)";
# RFC 2224 for NFS.
my $nfs_mark = '[\$\-_.!~*\'(),]';
my $nfs_unreserved = "(?:${alphanum}|${nfs_mark})";
$nfs_unreserved =~ s/\Q]|[//g;
my $nfs_pchar = "(?:${nfs_unreserved}|${escape}|[:\@&=+])";
my $nfs_segment = "(?:${nfs_pchar}*)";
my $nfs_path_segs = "(?:${nfs_segment}(?:/${nfs_segment})*)";
my $nfs_url_path = "(?:/?${nfs_path_segs})";
my $nfs_rel_path = "(?:${nfs_path_segs}?)";
my $nfs_abs_path = "(?:/${nfs_rel_path})";
my $nfs_net_path = "(?://${hostport}(?:${nfs_abs_path})?)";
my $nfs_rel_url = "(?:${nfs_net_path}|${nfs_abs_path}|${nfs_rel_path})";
my $nfsurl = "(?:nfs:${nfs_rel_url})";
# Combining all the different URL formats into a single regex.
my $url = join "|", $httpurl, $ftpurl, $newsurl, $nntpurl,
$telneturl, $gopherurl, $waisurl, $mailtourl,
$fileurl, $prosperourl, $ldapurl, $z39_50url,
$cidurl, $midurl, $vemmiurl, $imapurl,
$nfsurl;
print $url, "\n";
__END__
Raw
xdebug.pl
#!/usr/bin/perl
use strict;
use vars qw($VERSION %IRSSI);
use Irssi;
use DBI;
$VERSION = '1';
%IRSSI = (
author => 'Geoffrey Bachelet',
contact => '[email protected]',
name => 'eXtended Debug Bot',
description => 'Extended Quick Bot Script',
license => 'Not to be redistributed',
);
Irssi::signal_add('message public', 'event_privmsg');
Irssi::signal_add('message irc action', 'event_privmsg');
our ($home, %dbi, @active_chans, $dbh, @triggers, $regex_label, $last_trigger, $active, $my_nick);
$active = 1;
$my_nick = 'x?debug`?|k9';
$regex_label = '[a-z0-9_]+';
$home = '/home/ash/irssibot/debug/';
@active_chans = ('#/dev/null', '#phpmafia', '#kolibria', '#debug`', '#virmo');
%dbi = (
datasource => 'dbi:mysql:irssi_debug',
username => 'irssi',
password => '.jeJbLcPRxfr8ucL',
);
sub trim {
my $string = shift;
my $char = chop $string;
if ($char ne ' ') {
$string .= $char;
}
return $string;
}
sub in_array {
my $val = shift;
foreach my $elem(@_) {
if ($val eq $elem) {
return 1;
}
}
return 0;
}
sub get_dbh {
return DBI->connect($dbi{'datasource'}, $dbi{'username'}, $dbi{'password'}) or die $DBI::errstr;
}
sub load_triggers {
my $dbh = get_dbh();
my $sth = $dbh->prepare('SELECT id, regex, action, proba, label FROM triggers');
$sth->execute();
@triggers = ();
while (my $row = $sth->fetchrow_hashref()) {
push(@triggers, $row);
}
$dbh->disconnect();
}
sub trigger_exists {
my $label = shift;
my $dbh = get_dbh();
my $sql = qq { SELECT COUNT(*) FROM triggers WHERE label = ? };
my ($count) = $dbh->selectrow_array($sql, undef, $label);
return ($count > 0);
}
sub process_action {
my ($action, $nick, @backrefs) = @_;
if (my ($str) = ($action =~ /\{(.*)\}/g)) {
my $replacement = $str x scalar(@backrefs);
$action =~ s/\{$str\}/$replacement/
}
#my $regex = '\(([\d\s\w\!?\',.|]+)\)';
my $regex = '\((.*\|.*)\)';
while (my ($choices) = ($action =~ /$regex/)) {
print $choices;
my @choices = split(/\|/, $choices);
my $rand = int(rand(@choices));
$action =~ s/$regex/$choices[$rand]/;
}
$action =~ s/%nick/$nick/g;
my $output = sprintf($action, @backrefs);
return $output;
}
sub get_help {
my ($server, $target, $command) = @_;
SWITCH: {
if ($command eq 'add') {
$server->command('MSG '.$target.' xdebug: usage: $xdebug add $label "$regex" "$action" $proba');
last SWITCH;
}
if ($command eq 'set') {
$server->command('MSG '.$target.' xdebug: usage: $xdebug set $label $field $value');
last SWITCH;
}
if ($command eq 'show') {
$server->command('MSG '.$target.' xdebug: usage: $xdebug show $label[ $field]');
last SWITCH;
}
if ($command eq 'del') {
$server->command('MSG '.$target.' xdebug: usage: $xdebug del $label');
last SWITCH;
}
if ($command eq 'last') {
$server->command('MSG '.$target.' xdebug: usage: $xdebug last');
$server->command('MSG '.$target.' xdebug: usage: shows last triggered behavior\'s label');
last SWITCH;
}
if ($command eq 'test') {
$server->command('MSG '.$target.' xdebug: usage: $xdebug test $string');
$server->command('MSG '.$target.' xdebug: usage: tests $string against all triggers');
last SWITCH;
}
$server->command('MSG '.$target.' xdebug: help: add, set, show, del, last, test');
$server->command('MSG '.$target.' xdebug: help: try $xdebug help $command for help on a particular command');
}
}
load_triggers();
sub event_privmsg {
my ($server, $text, $nick, $address, $target) = @_;
my $mode = 'public';
if ($target =~ /^debug`?/) {
$mode = 'query';
$target = $nick;
}
if (1 || $target eq '#phpmafia') {
$dbh = get_dbh();
# XDEBUG !
if ($text =~ /^\$xdebug$/) {
$server->command('MSG '.$target.' xdebug: version '.$VERSION.'. try $xdebug help for help');
return 1;
}
# XDEBUG SLEEP & WAKE
if ($text =~ /^\$xdebug sleep/) {
$active = 0;
$server->command('MSG '.$target.' xdebug: night mates');
return 1;
}
if ($text =~ /^\$xdebug wakeup/) {
$active = 1;
$server->command('MSG '.$target.' xdebug: hey mates');
return 1;
}
if ($text =~ /^\$xdebug status/) {
$server->command('MSG '.$target.' xdebug: I\'m currently '.($active ? 'awake' : 'sleeping').', thanks for asking.');
return 1;
}
if (!$active || !in_array($target, @active_chans)) {
return 0;
}
# XDEBUG HELP
if ($text =~ /^\$xdebug help( (.*))?/) {
printf('XDEBUG: got help request from %s: %s', $nick, $2);
get_help($server, $target, $2);
return 1;
}
# XDEBUG SHOW
if ($text =~ /^\$xdebug show ($regex_label)( (regex|action|proba))?/) {
foreach my $row (@triggers) {
if ($row->{label} eq $1) {
if ($3 ne '') {
$server->command('MSG '.$target.' '.$3.': '.$row->{$3});
} else {
$server->command('MSG '.$target.' regex: '.$row->{regex});
$server->command('MSG '.$target.' action: '.$row->{action});
$server->command('MSG '.$target.' proba: '.$row->{proba});
}
return 1;
}
}
$server->command('MSG '.$target.' xdebug: error: no such trigger "'.$1.'"');
return 0;
}
# XDEBUG RELOAD
if ($text =~ /^\$xdebug reload$/) {
load_triggers();
$server->command('MSG '.$target.' xdebug: reload ok');
return 1;
}
# XDEBUG ADD
my ($label, $regex, $action, $proba);
if (($label, $regex, $action, $proba) = ($text =~ /^\$xdebug add ($regex_label) "(.+)" "(.+)" (\d+)/)) {
printf('XDEBUG: got insert request from %s: label: %s, regex: %s, action: %s, proba: %s', $nick, $label, $regex, $action, $proba);
if (trigger_exists($label)) {
$server->command('MSG '.$target.' xdebug: error: trigger with label "'.$label.'" already exists');
return 0;
}
my $sql = qq { INSERT INTO triggers (regex, action, proba, label) VALUES(?, ?, ?, ?) };
my $sth = $dbh->prepare($sql);
$sth->bind_param(1, $regex);
$sth->bind_param(2, $action);
$sth->bind_param(3, $proba);
$sth->bind_param(4, $label);
$sth->execute();
load_triggers();
$server->command('MSG '.$target.' xdebug: insert ok');
return 1;
}
# XDEBUG EDIT
my ($label, $field, $value);
if (($label, $field, $value) = ($text =~ /^\$xdebug set ($regex_label) (regex|action|proba|label) (.*)$/)) {
printf('XDEBUG: got update request from %s: label: %s, field: %s, value: %s', $nick, $label, $field, $value);
if ($field eq 'label') {
if (!($value =~ /^$regex_label$/)) {
$server->command('MSG '.$target.' xdebug: error: invalid label format (must match [a-z0-9]+)');
return 0;
}
if (trigger_exists($value)) {
$server->command('MSG '.$target.' xdebug: error: trigger with label "'.$value.'" already exists');
return 0;
}
}
my $sql = qq { UPDATE triggers SET $field = ? WHERE label = ? };
my $sth = $dbh->prepare($sql);
$sth->bind_param(1, $value);
$sth->bind_param(2, $label);
$sth->execute();
load_triggers();
$server->command('MSG '.$target.' xdebug: update ok');
return 1;
}
# XDEBUG DELETE
if ($text =~ /^\$xdebug del ($regex_label)/) {
my $label = $1;
printf('XDEBUG: got del request from %s: label: %s', $nick, $label);
my $sql = qq { DELETE FROM triggers WHERE label = ? };
my $sth = $dbh->prepare($sql);
$sth->bind_param(1, $label);
$sth->execute();
load_triggers();
$server->command('MSG '.$target.' xdebug: del ok');
return 1;
}
# XDEBUG WHAT WAS THAT
if ($text =~ /^\$xdebug last/) {
$server->command('MSG '.$target.' xdebug: last trigger was "'.$last_trigger.'"');
return 1;
}
# XDEBUG TEST
if (my ($test_string) = ($text =~ /^\$xdebug test (.*)/)) {
foreach my $row (@triggers) {
if (my @backrefs = ($test_string =~ /$row->{regex}/ig)) {
$server->command('MSG '.$target.sprintf(' xdebug: got trigger %s (regex: %s, backrefs: %d)', $row->{label}, $row->{regex}, scalar(@backrefs)));
}
}
return 1;
}
# XDEBUG DEBUG
if (my ($label, $test_string) = ($text =~ /^\$xdebug debug ($regex_label) (.*)/)) {
foreach my $row (@triggers) {
if ($row->{label} eq $label) {
if (my @backrefs = ($test_string =~ /$row->{regex}/ig)) {
$server->command('MSG '.$target.' xdebug: debug: string matched, backrefs following');
foreach my $backref (@backrefs) {
$server->command('MSG '.$target.' xdebug: debug: got backref: '.$backref);
}
} else {
$server->command('MSG '.$target.' xdebug: debug: string did not match (regex: '.$row->{regex});
}
}
}
return 1;
}
$dbh->disconnect();
}
foreach my $row (@triggers) {
if (my @backrefs = ($text =~ /$row->{regex}/ig)) {
my $rand = int(rand(100));
if ($text =~ /$my_nick/) {
printf('XDEBUG: message talked about me, look interested (original rand: %d)', $rand);
$rand = $rand / 2;
}
if ($text =~ /^$my_nick:/) {
printf('XDEBUG: message was adressed to me, be polite and answer (original rand: %d)', $rand);
$rand = 0;
}
$last_trigger = $row->{label};
printf('XDEBUG: got trigger %s [rand: %d/%d] [text: %s], [backrefs: %d]', $row->{regex}, $rand, $row->{proba}, $text, scalar(@backrefs));
if ($rand < $row->{proba}) {
my @actions = split(/\\n/, $row->{action});
for my $action (@actions) {
my $message = process_action($action, $nick, @backrefs);
$action = 'MSG';
if ($message =~ /^(ACTION )(.*)/) {
$message = $2;
$action = 'ACTION';
}
$server->command($action.' '.$target.' '.$message);
sleep 1;
}
}
}
}
}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment