From 34a4d11667b0a734343f82d2adbaac23f738ad18 Mon Sep 17 00:00:00 2001 From: dms Date: Sat, 8 Sep 2001 12:27:55 +0000 Subject: [PATCH] - bot stats: "blah has blah... is ranked xx/yy (zz percentile)" - invalid factoids: "^or ", "^but " - factoid args: update request count and by. - db_pgsql.pl updated; patch contributed by lear@OPN. thanks! - added "_stats " to get all textstats about nick. (half working) - added highlighting to irctextcounter output - cpustats: show total % and parent/child ratio. - logger: use 6spaces instead of 5 for counter. - added support for Password argument for IRC. - typo in Freshmeat.pl (forgot ::) - Factoids/Misc.pl - moved validFactoid here (from Misc.pl). - - moved FactoidStuff (from Process.pl) - db_sql.pl - common between mysql/pgsql. git-svn-id: https://svn.code.sf.net/p/infobot/code/trunk/blootbot@513 c11ca15a-4712-0410-83d8-924469b57eb5 --- src/CommandStubs.pl | 96 ++++++++- src/Factoids/Misc.pl | 455 +++++++++++++++++++++++++++++++++++++++ src/Factoids/Update.pl | 5 +- src/IRC/Irc.pl | 9 +- src/IRC/IrcHooks.pl | 4 + src/IRC/Schedulers.pl | 17 ++ src/Misc.pl | 84 -------- src/Modules/Freshmeat.pl | 7 +- src/Modules/RootWarn.pl | 23 +- src/Process.pl | 363 ------------------------------- src/UserExtra.pl | 12 +- src/core.pl | 1 + src/db_mysql.pl | 12 +- src/db_pgsql.pl | 356 ++++++++++++++++++++++-------- src/db_sql.pl | 20 ++ src/logger.pl | 4 +- src/modules.pl | 5 +- 17 files changed, 902 insertions(+), 571 deletions(-) create mode 100644 src/Factoids/Misc.pl create mode 100644 src/db_sql.pl diff --git a/src/CommandStubs.pl b/src/CommandStubs.pl index 91dfc72..5e2754f 100644 --- a/src/CommandStubs.pl +++ b/src/CommandStubs.pl @@ -280,6 +280,11 @@ sub Modules { $itc =~ s/([^\w\s])/\\$1/g; my $z = join '|', split ' ', $itc; + if ($message =~ /^_stats(\s+(\S+))$/i) { + &textstats_main($2); + return; + } + if ($message =~ /^($z)stats(\s+(\S+))?$/i) { my $type = $1; my $arg = $3; @@ -292,7 +297,6 @@ sub Modules { &DEBUG("not using chan arg") if (!defined $c); my $sum = (&dbRawReturn("SELECT SUM(counter) FROM stats" ." WHERE ".$where ))[0]; - &DEBUG("type => $type, arg => $arg"); if (!defined $arg or $arg =~ /^\s*$/) { # this is way fucking ugly. @@ -319,9 +323,9 @@ sub Modules { } if (defined $sum) { - &pSReply("total count of '$type' on $c: $sum$topstr"); + &pSReply("total count of \037$type\037 on \002$c\002: $sum$topstr"); } else { - &pSReply("zero counter for '$type'."); + &pSReply("zero counter for \037$type\037."); } } else { my $x = (&dbRawReturn("SELECT SUM(counter) FROM stats". @@ -348,11 +352,11 @@ sub Modules { my $xtra = ""; if ($total and $good) { my $pct = sprintf("%.01f", 100*(1+$total-$i)/$total); - $xtra = ", ranked $i/$total (percentile: $pct %)"; + $xtra = ", ranked $i\002/\002$total (percentile: \002$pct\002 %)"; } my $pct1 = sprintf("%.01f", 100*$x/$sum); - &pSReply("$arg has said $type $x times ($pct1 %)$xtra"); + &pSReply("\002$arg\002 has said \037$type\037 \002$x\002 times (\002$pct1\002 %)$xtra"); } return; @@ -845,6 +849,88 @@ sub do_verstats { return; } +sub textstats_main { + my($arg) = @_; + + # even more uglier with channel/time arguments. + my $c = $chan; +# my $c = $chan || "PRIVATE"; + my $where = "channel=".&dbQuote($c) if (defined $c); + &DEBUG("not using chan arg") if (!defined $c); + my $sum = (&dbRawReturn("SELECT SUM(counter) FROM stats" + ." WHERE ".$where ))[0]; + + if (!defined $arg or $arg =~ /^\s*$/) { + # this is way fucking ugly. + &DEBUG("_stats: !arg"); + + my %hash = &dbGetCol("stats", "nick,counter", + $where." ORDER BY counter DESC LIMIT 3", 1); + my $i; + my @top; + + # unfortunately we have to sort it again! + # todo: make dbGetCol return hash and array? too much effort. + my $tp = 0; + foreach $i (sort { $b <=> $a } keys %hash) { + foreach (keys %{ $hash{$i} }) { + my $p = sprintf("%.01f", 100*$i/$sum); + $tp += $p; + push(@top, "\002$_\002 -- $i ($p%)"); + } + } + + my $topstr = ""; + &DEBUG("tp => $tp"); + if (scalar @top) { + $topstr = ". Top ".scalar(@top).": ".join(', ', @top); + } + + if (defined $sum) { + &pSReply("total count of \037$type\037 on \002$c\002: $sum$topstr"); + } else { + &pSReply("zero counter for \037$type\037."); + } + } else { + my %hash = &dbGetCol("stats", "type,counter", + "$where AND nick=".&dbQuote($arg) ); + + foreach (keys %hash) { + &DEBUG("_stats: hash{$_} => $hash{$_}"); + # ranking. + my @array = &dbGet("stats", "nick", + $where." ORDER BY counter", 1); + my $good = 0; + my $i = 0; + for($i=0; $i $i, good => $good, total => $total"); + } + + return; + + if (!defined $x) { # !defined. + &pSReply("$arg has not said $type yet."); + return; + } + + my $xtra = ""; + if ($total and $good) { + my $pct = sprintf("%.01f", 100*(1+$total-$i)/$total); + $xtra = ", ranked $i\002/\002$total (percentile: \002$pct\002 %)"; + } + + my $pct1 = sprintf("%.01f", 100*$x/$sum); + &pSReply("\002$arg\002 has said \037$type\037 \002$x\002 times (\002$pct1\002 %)$xtra"); + } +} + sub nullski { my ($arg) = @_; return unless (defined $arg); foreach (`$arg`) { &msg($who,$_); } } diff --git a/src/Factoids/Misc.pl b/src/Factoids/Misc.pl new file mode 100644 index 0000000..aa058e8 --- /dev/null +++ b/src/Factoids/Misc.pl @@ -0,0 +1,455 @@ +# +# Misc.pl: Miscellaneous stuff. +# Author: dms +# Version: v0.1 (20010906) +# Created: 20010906 +# + +if (&IsParam("useStrict")) { use strict; } + +# Usage: &validFactoid($lhs,$rhs); +sub validFactoid { + my ($lhs,$rhs) = @_; + my $valid = 0; + + for (lc $lhs) { + # allow the following only if they have been made on purpose. + if ($rhs ne "" and $rhs !~ /^/ and last; # '=>'. + /\;\;/ and last; # ';;'. + /\|\|/ and last; # '||'. + + /^\Q$ident\E[\'\,\: ]/ and last;# dupe addressed. + /^[\-\, ]/ and last; + /\\$/ and last; # forgot shift for '?'. + /^all / and last; + /^also / and last; + / also$/ and last; + / and$/ and last; + /^because / and last; + /^but / and last; + /^gives / and last; + /^h(is|er) / and last; + /^if / and last; + / is,/ and last; + / it$/ and last; + /^or / and last; + / says$/ and last; + /^should / and last; + /^so / and last; + /^supposedly/ and last; + /^to / and last; + /^was / and last; + / which$/ and last; + + # nasty bug I introduced _somehow_, probably by fixMySQLBug(). + /\\\%/ and last; + /\\\_/ and last; + + # weird/special stuff. also old blootbot or stock infobot bugs. + $rhs =~ /( \Q$ident\E's|\Q$ident\E's )/i and last; # ownership. + + # duplication. + $rhs =~ /^\Q$lhs /i and last; + last if ($rhs =~ /^is /i and / is$/); + + $valid++; + } + + return $valid; +} + +sub FactoidStuff { + # inter-infobot. + if ($msgType =~ /private/ and $message =~ s/^:INFOBOT://) { + ### identification. + &status("infobot <$nuh> identified") unless $bots{$nuh}; + $bots{$nuh} = $who; + + ### communication. + + # query. + if ($message =~ /^QUERY (<.*?>) (.*)/) { # query. + my ($target,$item) = ($1,$2); + $item =~ s/[.\?]$//; + + &status(":INFOBOT:QUERY $who: $message"); + + if ($_ = &getFactoid($item)) { + &msg($who, ":INFOBOT:REPLY $target $item =is=> $_"); + } + + return 'INFOBOT QUERY'; + } elsif ($message =~ /^REPLY <(.*?)> (.*)/) { # reply. + my ($target,$item) = ($1,$2); + + &status(":INFOBOT:REPLY $who: $message"); + + my ($lhs,$mhs,$rhs) = $item =~ /^(.*?) =(.*?)=> (.*)/; + + if ($param{'acceptUrl'} !~ /REQUIRE/ or $rhs =~ /(http|ftp|mailto|telnet|file):/) { + &msg($target, "$who knew: $lhs $mhs $rhs"); + + # "are" hack :) + $rhs = " are" if ($mhs eq "are"); + &setFactInfo($lhs, "factoid_value", $rhs); + } + + return 'INFOBOT REPLY'; + } else { + &ERROR(":INFOBOT:UNKNOWN $who: $message"); + return 'INFOBOT UNKNOWN'; + } + } + + # factoid forget. + if ($message =~ s/^forget\s+//i) { + return 'forget: no addr' unless ($addressed); + + my $faqtoid = $message; + if ($faqtoid eq "") { + &help("forget"); + return; + } + + $faqtoid =~ tr/A-Z/a-z/; + my $result = &getFactoid($faqtoid); + + if (defined $result) { + my $author = &getFactInfo($faqtoid, "created_by"); + my $count = &getFactInfo($faqtoid, "requested_count") || 0; + my $limit = &getChanConfDefault("factoidPreventForgetLimit", + 0, $chan); + + &DEBUG("forget: limit = $limit"); + &DEBUG("forget: count = $count"); + + if (IsFlag("r") ne "r") { + &msg($who, "you don't have access to remove factoids"); + return; + } + + return 'locked factoid' if (&IsLocked($faqtoid) == 1); + + # factoidPreventForgetLimit: + if ($limit and $count > $limit and (&IsFlag("o") ne "o")) { + &msg($who, "will not delete '$faqtoid', count > limit ($count > $limit)"); + return; + } + + if (&IsParam("factoidDeleteDelay") or &IsChanConf("factoidDeleteDelay")) { + if ($faqtoid =~ / #DEL#$/ and !&IsFlag("o")) { + &msg($who, "cannot delete it ($faqtoid)."); + return; + } + + &status("forgot (safe delete): <$who> '$faqtoid' =is=> '$result'"); + ### TODO: check if the "backup" exists and overwrite it + my $check = &getFactoid("$faqtoid #DEL#"); + + if (!defined $check or $check =~ /^\s*$/) { + if ($faqtoid !~ / #DEL#$/) { + my $new = $faqtoid." #DEL#"; + + my $backup = &getFactoid($faqtoid); + # this looks weird but does it work? + if ($backup) { + &DEBUG("forget: not overwriting backup: $faqtoid"); + } else { + &status("forget: backing up '$faqtoid'"); + &setFactInfo($faqtoid, "factoid_key", $new); + &setFactInfo($new, "modified_by", $who); + &setFactInfo($new, "modified_time", time()); + } + + } else { + &status("forget: not backing up $faqtoid."); + } + + } else { + &status("forget: not overwriting backup!"); + } + + } else { + &status("forget: <$who> '$faqtoid' =is=> '$result'"); + } + &delFactoid($faqtoid); + + &performReply("i forgot $faqtoid"); + + $count{'Update'}++; + } else { + &performReply("i didn't have anything called '$faqtoid'"); + } + + return; + } + + # factoid unforget/undelete. + if ($message =~ s/^un(forget|delete)\s+//i) { + return 'unforget: no addr' unless ($addressed); + + my $i = 0; + $i++ if (&IsParam("factoidDeleteDelay")); + $i++ if (&IsChanConf("factoidDeleteDelay")); + if (!$i) { + &performReply("safe delete has been disable so what is there to undelete?"); + return; + } + + my $faqtoid = $message; + if ($faqtoid eq "") { + &help("undelete"); + return; + } + + $faqtoid =~ tr/A-Z/a-z/; + my $result = &getFactoid($faqtoid." #DEL#"); + my $check = &getFactoid($faqtoid); + + if (!defined $result) { + &performReply("i didn't have anything ('$faqtoid') to undelete."); + return; + } + + if (defined $check) { + &performReply("cannot undeleted '$faqtoid' because it already exists?"); + return; + } + + &setFactInfo($faqtoid." #DEL#", "factoid_key", $faqtoid); + + ### delete info. modified_ isn't really used. + &setFactInfo($faqtoid, "modified_by", ""); + &setFactInfo($faqtoid, "modified_time", 0); + + &performReply("Successfully recovered '$faqtoid'. Have fun now."); + + $count{'Undelete'}++; + + return; + } + + # factoid locking. + if ($message =~ /^((un)?lock)(\s+(.*))?\s*?$/i) { + return 'lock: no addr 2' unless ($addressed); + + my $function = lc $1; + my $faqtoid = lc $4; + + if ($faqtoid eq "") { + &help($function); + return; + } + + if (&getFactoid($faqtoid) eq "") { + &msg($who, "factoid \002$faqtoid\002 does not exist"); + return; + } + + if ($function eq "lock") { + # strongly requested by #debian on 19991028. -xk + if (1 and $faqtoid !~ /^\Q$who\E$/i and &IsFlag("o") ne "o") { + &msg($who,"sorry, locking cannot be used since it can be abused unneccesarily."); + &status("Replace 1 with 0 in Process.pl#~324 for locking support."); + return; + } + + &CmdLock($faqtoid); + } else { + &CmdUnLock($faqtoid); + } + + return; + } + + # factoid rename. + if ($message =~ s/^rename(\s+|$)//) { + return 'rename: no addr' unless ($addressed); + + if ($message eq "") { + &help("rename"); + return; + } + + if ($message =~ /^'(.*)'\s+'(.*)'$/) { + my($from,$to) = (lc $1, lc $2); + + my $result = &getFactoid($from); + if (defined $result) { + my $author = &getFactInfo($from, "created_by"); + + if (&IsFlag("m") or $author =~ /^\Q$who\E\!/i) { + &msg($who, "It's not yours to modify."); + return; + } + + if ($_ = &getFactoid($to)) { + &performReply("destination factoid already exists."); + return; + } + + &setFactInfo($from,"factoid_key",$to); + + &status("rename: <$who> '$from' is now '$to'"); + &performReply("i renamed '$from' to '$to'"); + } else { + &performReply("i didn't have anything called '$from'"); + } + } else { + &msg($who,"error: wrong format. ask me about 'help rename'."); + } + + return; + } + + # factoid substitution. (X =~ s/A/B/FLAG) + if ($message =~ m|^(.*?)\s+=~\s+s([/,#])(.+?)\2(.*?)\2([a-z]*);?\s*$|) { + my ($faqtoid,$delim,$op,$np,$flags) = (lc $1, $2, $3, $4, $5); + return 'subst: no addr' unless ($addressed); + + # incorrect format. + if ($np =~ /$delim/) { + &msg($who,"looks like you used the delimiter too many times. You may want to use a different delimiter, like ':' or '#'."); + return; + } + + # success. + if (my $result = &getFactoid($faqtoid)) { + return 'subst: locked' if (&IsLocked($faqtoid) == 1); + my $was = $result; + + if (($flags eq "g" && $result =~ s/\Q$op/$np/gi) || $result =~ s/\Q$op/$np/i) { + if (length $result > $param{'maxDataSize'}) { + &performReply("that's too long"); + return; + } + &setFactInfo($faqtoid, "factoid_value", $result); + &status("update: '$faqtoid' =is=> '$result'; was '$was'"); + &performReply("OK"); + } else { + &performReply("that doesn't contain '$op'"); + } + } else { + &performReply("i didn't have anything called '$faqtoid'"); + } + + return; + } + + # Fix up $message for question. + my $question = $message; + for ($question) { + # fix the string. + s/^hey([, ]+)where/where/i; + s/\s+\?$/?/; + s/whois/who is/ig; + s/where can i find/where is/i; + s/how about/where is/i; + s/ da / the /ig; + + # clear the string of useless words. + s/^(stupid )?q(uestion)?:\s+//i; + s/^(does )?(any|ne)(1|one|body) know //i; + + s/^[uh]+m*[,\.]* +//i; + + s/^well([, ]+)//i; + s/^still([, ]+)//i; + s/^(gee|boy|golly|gosh)([, ]+)//i; + s/^(well|and|but|or|yes)([, ]+)//i; + + s/^o+[hk]+(a+y+)?([,. ]+)//i; + s/^g(eez|osh|olly)([,. ]+)//i; + s/^w(ow|hee|o+ho+)([,. ]+)//i; + s/^heya?,?( folks)?([,. ]+)//i; + } + + if ($addressed and $message =~ s/^no([, ]+)(\Q$ident\E\,+)?\s*//i) { + $correction_plausible = 1; + &status("correction is plausible, initial negative and nick deleted ($&)") if ($param{VERBOSITY}); + } else { + $correction_plausible = 0; + } + + my $result = &doQuestion($question); + if (!defined $result or $result eq $noreply) { + return 'result from doQ undef.'; + } + + if (defined $result and $result !~ /^0?$/) { # question. + &status("question: <$who> $message"); + $count{'Question'}++; + } elsif (&IsChanConf("perlMath") > 0 and $addressed) { # perl math. + &loadMyModule("perlMath"); + my $newresult = &perlMath(); + + if (defined $newresult and $newresult ne "") { + $cmdstats{'Maths'}++; + $result = $newresult; + &status("math: <$who> $message => $result"); + } + } + + if ($result !~ /^0?$/) { + &performStrictReply($result); + return; + } + + # why would a friendly bot get passed here? + if (&IsParam("friendlyBots")) { + return if (grep lc($_) eq lc($who), split(/\s+/, $param{'friendlyBots'})); + } + + # do the statement. + if (!defined &doStatement($message)) { + return; + } + + return unless ($addressed); + + if (length $message > 64) { + &status("unparseable-moron: $message"); +# &performReply( &getRandom(keys %{ $lang{'moron'} }) ); + $count{'Moron'}++; + + &performReply("You are moron \002#". $count{'Moron'} ."\002"); + return; + } + + &status("unparseable: $message"); + &performReply( &getRandom(keys %{ $lang{'dunno'} }) ); + $count{'Dunno'}++; +} + +1; diff --git a/src/Factoids/Update.pl b/src/Factoids/Update.pl index 68c0cfc..ee6c6a8 100644 --- a/src/Factoids/Update.pl +++ b/src/Factoids/Update.pl @@ -107,12 +107,13 @@ sub update { &performAddressedReply("okay"); - ### BROKEN!!! if (1) { # old + &setFactInfo($lhs,"factoid_value", $rhs); &setFactInfo($lhs,"created_by", $nuh); &setFactInfo($lhs,"created_time", time()); - &setFactInfo($lhs,"factoid_value", $rhs); } else { + ### BROKEN!!! + # I'd prefer to use dbReplace but it don't work. &dbReplace("factoids", ( factoid_key => $lhs, created_by => time(), diff --git a/src/IRC/Irc.pl b/src/IRC/Irc.pl index d6f81b6..46bb68a 100644 --- a/src/IRC/Irc.pl +++ b/src/IRC/Irc.pl @@ -97,6 +97,7 @@ sub irc { Ircname => $param{'ircName'}, ); $args{'LocalAddr'} = $param{'ircHost'} if ($param{'ircHost'}); + $args{'Password'} = $param{'ircPasswd'} if ($param{'ircPasswd'}); $conn = $irc->newconn(%args); @@ -440,6 +441,7 @@ sub joinchan { &status("joining $b_blue$chan$ob"); if (!$conn->join($chan)) { &DEBUG("joinchan: join failed. trying connect!"); + &clearIRCVars(); $conn->connect(); } } @@ -723,6 +725,11 @@ sub validChan { } if (exists $channels{$chan}) { + if ($chan eq "_default") { +# &WARN("validC: chan cannot be _default! returning 0!"); + return 0; + } + return 1; } else { return 0; @@ -752,7 +759,7 @@ sub clearChanVars { } sub clearIRCVars { -# &DEBUG("clearIRCVars() called!"); + &DEBUG("clearIRCVars() called!"); undef %channels; undef %floodjoin; diff --git a/src/IRC/IrcHooks.pl b/src/IRC/IrcHooks.pl index 7f2e7f8..b4b31f6 100644 --- a/src/IRC/IrcHooks.pl +++ b/src/IRC/IrcHooks.pl @@ -361,6 +361,7 @@ sub on_disconnect { &clearIRCVars(); if (!$self->connect()) { &WARN("not connected? help me. gonna call ircCheck() in 60s"); + &clearIRCVars(); &ScheduleThis(1, "ircCheck"); # &ScheduleThis(10, "ircCheck"); # &ScheduleThis(30, "ircCheck"); @@ -440,9 +441,12 @@ sub on_join { $chan = lc( ($event->to)[0] ); # CASING!!!! $who = $event->nick(); $msgType = "public"; + my $i = scalar(keys %{ $channels{$chan} }); + my $j = $cache{maxpeeps}{$chan} || 0; $chanstats{$chan}{'Join'}++; $userstats{lc $who}{'Join'} = time() if (&IsChanConf("seenStats")); + $cache{maxpeeps}{$chan} = $i if ($i > $j); &joinfloodCheck($who, $chan, $event->userhost); diff --git a/src/IRC/Schedulers.pl b/src/IRC/Schedulers.pl index a7d38c4..b5bca95 100644 --- a/src/IRC/Schedulers.pl +++ b/src/IRC/Schedulers.pl @@ -363,9 +363,17 @@ sub chanlimitCheck { return if ($_[0] eq "2"); } + my $str = join(' ', &ChanConfList("chanlimitcheck") ); + &DEBUG("chanlimitCheck: str => $str"); + foreach $chan ( &ChanConfList("chanlimitcheck") ) { next unless (&validChan($chan)); + if ($chan eq "_default") { + &WARN("chanlimit: we're doing $chan!! HELP ME!"); + next; + } + my $limitplus = &getChanConfDefault("chanlimitcheckPlus", 5, $chan); my $newlimit = scalar(keys %{ $channels{$chan}{''} }) + $limitplus; my $limit = $channels{$chan}{'l'}; @@ -466,6 +474,15 @@ sub netsplitCheck { delete $netsplit{$_}; } + # yet another hack. + foreach (keys %channels) { + my $i = $cache{maxpeeps}{$chan} || 0; + my $j = scalar(keys %{ $channels{$chan} }); + next unless ($i > 10 and 0.25*$i > $j); + + &DEBUG("netsplit: 0.25*max($i) > current($j); possible netsplit?"); + } + if ($delete) { my $j = scalar(keys %netsplit); &DEBUG("nsC: removed from netsplit list: (before: $count; after: $j)"); diff --git a/src/Misc.pl b/src/Misc.pl index a598234..0b39297 100644 --- a/src/Misc.pl +++ b/src/Misc.pl @@ -288,8 +288,6 @@ sub fixPlural { return $str; } - - ########## ### get commands. ### @@ -543,88 +541,6 @@ sub validExec { } } -# Usage: &validFactoid($lhs,$rhs); -sub validFactoid { - my ($lhs,$rhs) = @_; - my $valid = 0; - - for (lc $lhs) { - # allow the following only if they have been made on purpose. - if ($rhs ne "" and $rhs !~ /^/ and last; # '=>'. - /\;\;/ and last; # ';;'. - /\|\|/ and last; # '||'. - - /^\Q$ident\E[\'\,\: ]/ and last;# dupe addressed. - /^[\-\, ]/ and last; - /\\$/ and last; # forgot shift for '?'. - /^all / and last; - /^also / and last; - / also$/ and last; - / and$/ and last; - /^because / and last; - /^but / and last; - /^gives / and last; - /^h(is|er) / and last; - /^if / and last; - / is,/ and last; - / it$/ and last; - /^or / and last; - / says$/ and last; - /^should / and last; - /^so / and last; - /^supposedly/ and last; - /^to / and last; - /^was / and last; - / which$/ and last; - - # nasty bug I introduced _somehow_, probably by fixMySQLBug(). - /\\\%/ and last; - /\\\_/ and last; - - # weird/special stuff. also old blootbot or stock infobot bugs. - $rhs =~ /( \Q$ident\E's|\Q$ident\E's )/i and last; # ownership. - - # duplication. - $rhs =~ /^\Q$lhs /i and last; - last if ($rhs =~ /^is /i and / is$/); - - $valid++; - } - - return $valid; -} - # Usage: &hasProfanity($string); sub hasProfanity { my ($string) = @_; diff --git a/src/Modules/Freshmeat.pl b/src/Modules/Freshmeat.pl index a6a07c5..269eb3e 100644 --- a/src/Modules/Freshmeat.pl +++ b/src/Modules/Freshmeat.pl @@ -85,7 +85,7 @@ sub Freshmeat { sub showPackage { my ($pkg) = @_; my @fm = &::dbGet("freshmeat", "*", - "projectname_short=".&dbQuote($pkg) ); + "projectname_short=".&::dbQuote($pkg) ); if (scalar @fm) { #1: perfect match of name. my $retval; @@ -185,8 +185,9 @@ sub downloadIndex { ### lets get on with business. # set the last refresh time. fixes multiple spawn bug. &::dbSet("freshmeat", - { "projectname_short" => "_" }, - { "latest_version" => time() } + { "projectname_short" => "_" }, + { "latest_version" => time() + "desc_short" => "" } ); # &::dbRaw("LOCK", "LOCK TABLES freshmeat WRITE"); diff --git a/src/Modules/RootWarn.pl b/src/Modules/RootWarn.pl index 835c605..5c2cf62 100644 --- a/src/Modules/RootWarn.pl +++ b/src/Modules/RootWarn.pl @@ -50,17 +50,14 @@ sub rootWarn { $attempt++; ### TODO: OPTIMIZE THIS. # ok... don't record the attempt if nick==root. - if (1 and $nick ne "root") { # old - &dbSet("rootwarn", { nick => lc($nick) }, { attempt => $attempt }); - &dbSet("rootwarn", { nick => lc($nick) }, { time => time() }); - &dbSet("rootwarn", { nick => lc($nick) }, { host => $user."\@".$host }); - &dbSet("rootwarn", { nick => lc($nick) }, { channel => $chan }); - } else { # new. replace. TODO - &dbSet("rootwarn", "nick", lc($nick), "attempt", $attempt); - &dbSet("rootwarn", "nick", lc($nick), "time", time()); - &dbSet("rootwarn", "nick", lc($nick), "host", $user."\@".$host); - &dbSet("rootwarn", "nick", lc($nick), "channel", $chan); - } + return if ($nick eq "root"); + + &dbSet("rootwarn", { nick => lc($nick) }, { + attempt => $attempt, + time => time(), + host => $user."\@".$host, + channel => $chan, + } ); return; } @@ -80,8 +77,8 @@ sub CmdrootWarn { $reply = "there ".&fixPlural("has",$count) ." been \002$count\002 ". &fixPlural("rooter",$count) ." warned about root."; - if ($param{'DBType'} !~ /^mysql$/i) { - &FIXME("rootwarn does not yet support non-mysql."); + if ($param{'DBType'} !~ /^(pg|my)sql$/i) { + &FIXME("rootwarn does not yet support non-{my,pg}sql."); return; } diff --git a/src/Process.pl b/src/Process.pl index 255730f..dd3d80c 100644 --- a/src/Process.pl +++ b/src/Process.pl @@ -340,367 +340,4 @@ sub process { } } -sub FactoidStuff { - # inter-infobot. - if ($msgType =~ /private/ and $message =~ s/^:INFOBOT://) { - ### identification. - &status("infobot <$nuh> identified") unless $bots{$nuh}; - $bots{$nuh} = $who; - - ### communication. - - # query. - if ($message =~ /^QUERY (<.*?>) (.*)/) { # query. - my ($target,$item) = ($1,$2); - $item =~ s/[.\?]$//; - - &status(":INFOBOT:QUERY $who: $message"); - - if ($_ = &getFactoid($item)) { - &msg($who, ":INFOBOT:REPLY $target $item =is=> $_"); - } - - return 'INFOBOT QUERY'; - } elsif ($message =~ /^REPLY <(.*?)> (.*)/) { # reply. - my ($target,$item) = ($1,$2); - - &status(":INFOBOT:REPLY $who: $message"); - - my ($lhs,$mhs,$rhs) = $item =~ /^(.*?) =(.*?)=> (.*)/; - - if ($param{'acceptUrl'} !~ /REQUIRE/ or $rhs =~ /(http|ftp|mailto|telnet|file):/) { - &msg($target, "$who knew: $lhs $mhs $rhs"); - - # "are" hack :) - $rhs = " are" if ($mhs eq "are"); - &setFactInfo($lhs, "factoid_value", $rhs); - } - - return 'INFOBOT REPLY'; - } else { - &ERROR(":INFOBOT:UNKNOWN $who: $message"); - return 'INFOBOT UNKNOWN'; - } - } - - # factoid forget. - if ($message =~ s/^forget\s+//i) { - return 'forget: no addr' unless ($addressed); - - my $faqtoid = $message; - if ($faqtoid eq "") { - &help("forget"); - return; - } - - $faqtoid =~ tr/A-Z/a-z/; - my $result = &getFactoid($faqtoid); - - if (defined $result) { - my $author = &getFactInfo($faqtoid, "created_by"); - my $count = &getFactInfo($faqtoid, "requested_count") || 0; - my $limit = &getChanConfDefault("factoidPreventForgetLimit", - 0, $chan); - - &DEBUG("forget: limit = $limit"); - &DEBUG("forget: count = $count"); - - if (IsFlag("r") ne "r") { - &msg($who, "you don't have access to remove factoids"); - return; - } - - return 'locked factoid' if (&IsLocked($faqtoid) == 1); - - # factoidPreventForgetLimit: - if ($limit and $count > $limit and (&IsFlag("o") ne "o")) { - &msg($who, "will not delete '$faqtoid', count > limit ($count > $limit)"); - return; - } - - if (&IsParam("factoidDeleteDelay") or &IsChanConf("factoidDeleteDelay")) { - if ($faqtoid =~ / #DEL#$/ and !&IsFlag("o")) { - &msg($who, "cannot delete it ($faqtoid)."); - return; - } - - &status("forgot (safe delete): <$who> '$faqtoid' =is=> '$result'"); - ### TODO: check if the "backup" exists and overwrite it - my $check = &getFactoid("$faqtoid #DEL#"); - - if (!defined $check or $check =~ /^\s*$/) { - if ($faqtoid !~ / #DEL#$/) { - my $new = $faqtoid." #DEL#"; - - my $backup = &getFactoid($faqtoid); - # this looks weird but does it work? - if ($backup) { - &DEBUG("forget: not overwriting backup: $faqtoid"); - } else { - &status("forget: backing up '$faqtoid'"); - &setFactInfo($faqtoid, "factoid_key", $new); - &setFactInfo($new, "modified_by", $who); - &setFactInfo($new, "modified_time", time()); - } - - } else { - &status("forget: not backing up $faqtoid."); - } - - } else { - &status("forget: not overwriting backup!"); - } - - } else { - &status("forget: <$who> '$faqtoid' =is=> '$result'"); - } - &delFactoid($faqtoid); - - &performReply("i forgot $faqtoid"); - - $count{'Update'}++; - } else { - &performReply("i didn't have anything called '$faqtoid'"); - } - - return; - } - - # factoid unforget/undelete. - if ($message =~ s/^un(forget|delete)\s+//i) { - return 'unforget: no addr' unless ($addressed); - - my $i = 0; - $i++ if (&IsParam("factoidDeleteDelay")); - $i++ if (&IsChanConf("factoidDeleteDelay")); - if (!$i) { - &performReply("safe delete has been disable so what is there to undelete?"); - return; - } - - my $faqtoid = $message; - if ($faqtoid eq "") { - &help("undelete"); - return; - } - - $faqtoid =~ tr/A-Z/a-z/; - my $result = &getFactoid($faqtoid." #DEL#"); - my $check = &getFactoid($faqtoid); - - if (!defined $result) { - &performReply("i didn't have anything ('$faqtoid') to undelete."); - return; - } - - if (defined $check) { - &performReply("cannot undeleted '$faqtoid' because it already exists?"); - return; - } - - &setFactInfo($faqtoid." #DEL#", "factoid_key", $faqtoid); - - ### delete info. modified_ isn't really used. - &setFactInfo($faqtoid, "modified_by", ""); - &setFactInfo($faqtoid, "modified_time", 0); - - &performReply("Successfully recovered '$faqtoid'. Have fun now."); - - $count{'Undelete'}++; - - return; - } - - # factoid locking. - if ($message =~ /^((un)?lock)(\s+(.*))?\s*?$/i) { - return 'lock: no addr 2' unless ($addressed); - - my $function = lc $1; - my $faqtoid = lc $4; - - if ($faqtoid eq "") { - &help($function); - return; - } - - if (&getFactoid($faqtoid) eq "") { - &msg($who, "factoid \002$faqtoid\002 does not exist"); - return; - } - - if ($function eq "lock") { - # strongly requested by #debian on 19991028. -xk - if (1 and $faqtoid !~ /^\Q$who\E$/i and &IsFlag("o") ne "o") { - &msg($who,"sorry, locking cannot be used since it can be abused unneccesarily."); - &status("Replace 1 with 0 in Process.pl#~324 for locking support."); - return; - } - - &CmdLock($faqtoid); - } else { - &CmdUnLock($faqtoid); - } - - return; - } - - # factoid rename. - if ($message =~ s/^rename(\s+|$)//) { - return 'rename: no addr' unless ($addressed); - - if ($message eq "") { - &help("rename"); - return; - } - - if ($message =~ /^'(.*)'\s+'(.*)'$/) { - my($from,$to) = (lc $1, lc $2); - - my $result = &getFactoid($from); - if (defined $result) { - my $author = &getFactInfo($from, "created_by"); - - if (&IsFlag("m") or $author =~ /^\Q$who\E\!/i) { - &msg($who, "It's not yours to modify."); - return; - } - - if ($_ = &getFactoid($to)) { - &performReply("destination factoid already exists."); - return; - } - - &setFactInfo($from,"factoid_key",$to); - - &status("rename: <$who> '$from' is now '$to'"); - &performReply("i renamed '$from' to '$to'"); - } else { - &performReply("i didn't have anything called '$from'"); - } - } else { - &msg($who,"error: wrong format. ask me about 'help rename'."); - } - - return; - } - - # factoid substitution. (X =~ s/A/B/FLAG) - if ($message =~ m|^(.*?)\s+=~\s+s([/,#])(.+?)\2(.*?)\2([a-z]*);?\s*$|) { - my ($faqtoid,$delim,$op,$np,$flags) = (lc $1, $2, $3, $4, $5); - return 'subst: no addr' unless ($addressed); - - # incorrect format. - if ($np =~ /$delim/) { - &msg($who,"looks like you used the delimiter too many times. You may want to use a different delimiter, like ':' or '#'."); - return; - } - - # success. - if (my $result = &getFactoid($faqtoid)) { - return 'subst: locked' if (&IsLocked($faqtoid) == 1); - my $was = $result; - - if (($flags eq "g" && $result =~ s/\Q$op/$np/gi) || $result =~ s/\Q$op/$np/i) { - if (length $result > $param{'maxDataSize'}) { - &performReply("that's too long"); - return; - } - &setFactInfo($faqtoid, "factoid_value", $result); - &status("update: '$faqtoid' =is=> '$result'; was '$was'"); - &performReply("OK"); - } else { - &performReply("that doesn't contain '$op'"); - } - } else { - &performReply("i didn't have anything called '$faqtoid'"); - } - - return; - } - - # Fix up $message for question. - my $question = $message; - for ($question) { - # fix the string. - s/^hey([, ]+)where/where/i; - s/\s+\?$/?/; - s/whois/who is/ig; - s/where can i find/where is/i; - s/how about/where is/i; - s/ da / the /ig; - - # clear the string of useless words. - s/^(stupid )?q(uestion)?:\s+//i; - s/^(does )?(any|ne)(1|one|body) know //i; - - s/^[uh]+m*[,\.]* +//i; - - s/^well([, ]+)//i; - s/^still([, ]+)//i; - s/^(gee|boy|golly|gosh)([, ]+)//i; - s/^(well|and|but|or|yes)([, ]+)//i; - - s/^o+[hk]+(a+y+)?([,. ]+)//i; - s/^g(eez|osh|olly)([,. ]+)//i; - s/^w(ow|hee|o+ho+)([,. ]+)//i; - s/^heya?,?( folks)?([,. ]+)//i; - } - - if ($addressed and $message =~ s/^no([, ]+)(\Q$ident\E\,+)?\s*//i) { - $correction_plausible = 1; - &status("correction is plausible, initial negative and nick deleted ($&)") if ($param{VERBOSITY}); - } else { - $correction_plausible = 0; - } - - my $result = &doQuestion($question); - if (!defined $result or $result eq $noreply) { - return 'result from doQ undef.'; - } - - if (defined $result and $result !~ /^0?$/) { # question. - &status("question: <$who> $message"); - $count{'Question'}++; - } elsif (&IsChanConf("perlMath") > 0 and $addressed) { # perl math. - &loadMyModule("perlMath"); - my $newresult = &perlMath(); - - if (defined $newresult and $newresult ne "") { - $cmdstats{'Maths'}++; - $result = $newresult; - &status("math: <$who> $message => $result"); - } - } - - if ($result !~ /^0?$/) { - &performStrictReply($result); - return; - } - - # why would a friendly bot get passed here? - if (&IsParam("friendlyBots")) { - return if (grep lc($_) eq lc($who), split(/\s+/, $param{'friendlyBots'})); - } - - # do the statement. - if (!defined &doStatement($message)) { - return; - } - - return unless ($addressed); - - if (length $message > 64) { - &status("unparseable-moron: $message"); -# &performReply( &getRandom(keys %{ $lang{'moron'} }) ); - $count{'Moron'}++; - - &performReply("You are moron \002#". $count{'Moron'} ."\002"); - return; - } - - &status("unparseable: $message"); - &performReply( &getRandom(keys %{ $lang{'dunno'} }) ); - $count{'Dunno'}++; -} - 1; diff --git a/src/UserExtra.pl b/src/UserExtra.pl index 7079f6a..4912479 100644 --- a/src/UserExtra.pl +++ b/src/UserExtra.pl @@ -160,6 +160,7 @@ sub chaninfo { $new{$_} = $userstats{$_}{'Count'}; } + # todo: show top 3 with percentages? my($count) = (sort { $a <=> $b } keys %new)[0]; if ($count) { $reply .= ". \002$count\002 has said the most with a total of \002$new{$count}\002 messages"; @@ -693,19 +694,28 @@ sub userCommands { my $raw_perc2 = $cpu_usage2*100/$time; my $perc; my $perc2; + my $total; + my $ratio; if ($raw_perc > 1) { $perc = sprintf("%.01f", $raw_perc); $perc2 = sprintf("%.01f", $raw_perc2); + $total = sprintf("%.01f", $raw_perc+$raw_perc2); } elsif ($raw_perc > 0.1) { $perc = sprintf("%.02f", $raw_perc); $perc2 = sprintf("%.02f", $raw_perc2); + $total = sprintf("%.02f", $raw_perc+$raw_perc2); } else { # <=0.1 $perc = sprintf("%.03f", $raw_perc); $perc2 = sprintf("%.03f", $raw_perc2); + $total = sprintf("%.03f", $raw_perc+$raw_perc2); } + $ratio = sprintf("%.01f", 100*$perc/($perc+$perc2) ); - &pSReply("Total CPU usage: $cpu_usage s ... Percentage CPU used: $perc % (+childs: $perc2 %)"); + &pSReply("Total CPU usage: \002$cpu_usage\002 s ... ". + "Total used: \002$total\002 % ". + "(parent/child ratio: $ratio %)" + ); return; } diff --git a/src/core.pl b/src/core.pl index 4bda802..c869665 100644 --- a/src/core.pl +++ b/src/core.pl @@ -483,6 +483,7 @@ sub restart { if (!$conn->connected and time - $msgtime > 900) { &status("reconnecting because of uncaught disconnect \@ ".scalar(localtime) ); ### $irc->start; + &clearIRCVars(); $conn->connect(); ### return; } diff --git a/src/db_mysql.pl b/src/db_mysql.pl index 357f4a8..325069d 100644 --- a/src/db_mysql.pl +++ b/src/db_mysql.pl @@ -46,7 +46,7 @@ sub dbQuote { # Usage: &dbGet($table, $select, $where); sub dbGet { my ($table, $select, $where) = @_; - my $query = "SELECT $select FROM $table"; + my $query = "SELECT $select FROM $table"; $query .= " WHERE $where" if ($where); if (!defined $select) { @@ -463,7 +463,7 @@ sub searchTable { ##### ##### -# Usage: &getFactInfo($faqtoid, type); +# Usage: &getFactInfo($faqtoid, $type); # Note: getFactInfo does dbQuote sub getFactInfo { return &dbGet("factoids", $_[1], "factoid_key=".&dbQuote($_[0]) ); @@ -486,14 +486,6 @@ sub delFactoid { return 1; } -sub SQLDebug { - return unless (&IsParam("SQLDebug")); - - return unless (fileno SQLDEBUG); - - print SQLDEBUG $_[0]."\n"; -} - sub dbCreateTable { my($table) = @_; my(@path) = (".","..","../.."); diff --git a/src/db_pgsql.pl b/src/db_pgsql.pl index 73872de..3e32930 100644 --- a/src/db_pgsql.pl +++ b/src/db_pgsql.pl @@ -1,66 +1,78 @@ # # db_pgsql.pl: PostgreSQL database frontend. -# Author: dms -# Version: v0.1 (20000629) +# Author: dms +# Version: v0.2 (20010908) # Created: 20000629 # if (&IsParam("useStrict")) { use strict; } sub openDB { - $dbh = Pg::connectdb("dbname=$param{'DBName'}"); -# $dbh = Pg::setdbLogin($param{'SQLHost'}, , , , $param{'DBName'}, -# $param{'SQLUser'}, $param{'SQLPass'}); + my $connectstr="dbi:Pg:dbname=$param{DBName};"; + $connectstr.=";host=$param{SQLHost}" if(defined $param{'SQLHost'}); + $dbh = DBI->connect($connectstr, $param{'SQLUser'}, $param{'SQLPass'}); - if (PGRES_CONNECTION_OK eq $dbh->status) { - &status("Opened pgSQL connection to $param{'SQLHost'}"); + if (!$dbh->err) { + &status("Opened PgSQL connection to $param{'SQLHost'}"); } else { &ERROR("cannot connect to $param{'SQLHost'}."); - &ERROR("pgSQL: ".$dbh->errorMessage); + &ERROR("pgSQL: ".$dbh->errstr); + + &closePID(); &closeSHM($shm); &closeLog(); + exit 1; } } sub closeDB { - if (!$dbh) { - &WARN("closeDB: connection already closed?"); - return 0; - } + return 0 unless ($dbh); &status("Closed pgSQL connection to $param{'SQLHost'}."); $dbh->disconnect(); + return 1; } ##### # Usage: &dbQuote($str); sub dbQuote { - $_[0] =~ s/\'/\\\\'/g; - return "'$_[0]'"; + return $dbh->quote($_[0]); + + $_ = $_[0]; + s/'/\\'/g; + return "'$_'"; } ##### -# Usage: &dbGet($table, $primkey, $primval, $select); +# Usage: &dbGet($table, $select, $where); sub dbGet { - my ($table, $primkey, $primval, $select) = @_; - my $query = "SELECT $select FROM $table WHERE $primkey=". - &dbQuote($primval); + my ($table, $select, $where) = @_; + my $query = "SELECT $select FROM $table"; + $query .= " WHERE $where" if ($where); - my $res = $dbh->exec($query); - if (PGRES_TUPLES_OK ne $res->resultStatus) { - &ERROR("Get: $dbh->errorMessage"); + if (!defined $select) { + &WARN("dbGet: select == NULL. table => $table"); return; } - if (!$sth->execute) { - &ERROR("Get => '$query'"); - &ERROR("Get => $DBI::errstr"); + my $sth; + if (!($sth = $dbh->prepare($query))) { + &ERROR("Get: prepare: $DBI::errstr"); return; } - my @retval = $res->fetchrow; + &SQLDebug($query); + if (!$sth->execute) { + &ERROR("Get: execute: '$query'"); + $sth->finish; + return 0; + } + + my @retval = $sth->fetchrow_array; + + $sth->finish; if (scalar @retval > 1) { return @retval; @@ -72,19 +84,37 @@ sub dbGet { } ##### -# Usage: &dbGetCol($table, $primkey, $key, [$type]); +# Usage: &dbGetCol($table, $select, $where, [$type]); sub dbGetCol { - my ($table, $primkey, $key, $type) = @_; - my $query = "SELECT $primkey,$key FROM $table WHERE $key IS NOT NULL"; + my ($table, $select, $where, $type) = @_; + my $query = "SELECT $select FROM $table"; + $query .= " WHERE ".$where if ($where); my %retval; my $sth = $dbh->prepare($query); - &ERROR("GetCol => '$query'") unless $sth->execute; + &SQLDebug($query); + if (!$sth->execute) { + &ERROR("GetCol: execute: '$query'"); + $sth->finish; + return; + } - if (defined $type and $type == 1) { + if (defined $type and $type == 2) { + &DEBUG("dbgetcol: type 2!"); + while (my @row = $sth->fetchrow_array) { + $retval{$row[0]} = join(':', $row[1..$#row]); + } + &DEBUG("dbgetcol: count => ".scalar(keys %retval) ); + + } elsif (defined $type and $type == 1) { while (my @row = $sth->fetchrow_array) { # reverse it to make it easier to count. - $retval{$row[1]}{$row[0]} = 1; + if (scalar @row == 2) { + $retval{$row[1]}{$row[0]} = 1; + } elsif (scalar @row == 3) { + $retval{$row[1]}{$row[0]} = 1; + } + # what to do if there's only one or more than 3? } } else { while (my @row = $sth->fetchrow_array) { @@ -98,18 +128,108 @@ sub dbGetCol { } ##### -# Usage: &dbSet($table, $primkey, $primval, $key, $val); +# Usage: &dbGetColNiceHash($table, $select, $where); +sub dbGetColNiceHash { + my ($table, $select, $where) = @_; + $select ||= "*"; + my $query = "SELECT $select FROM $table"; + $query .= " WHERE ".$where if ($where); + my %retval; + + &DEBUG("dbGetColNiceHash: query => '$query'."); + + my $sth = $dbh->prepare($query); + &SQLDebug($query); + if (!$sth->execute) { + &ERROR("GetColNiceHash: execute: '$query'"); +# &ERROR("GetCol => $DBI::errstr"); + $sth->finish; + return; + } + + # todo: get column names, do $hash{$primkey}{blah} = ... + while (my @row = $sth->fetchrow_array) { + # todo: reverse it to make it easier to count. + } + + $sth->finish; + + return %retval; +} + +#### +# Usage: &dbGetColInfo($table); +sub dbGetColInfo { + my ($table) = @_; + +# my $query = "SELECT * FROM $table LIMIT 1;"; + my $query = "SHOW COLUMNS from $table"; + my %retval; + + my $sth = $dbh->prepare($query); + &SQLDebug($query); + if (!$sth->execute) { + &ERROR("GRI => '$query'"); + &ERROR("GRI => $DBI::errstr"); + $sth->finish; + return; + } + + if (0) { + %retval=%{$sth->fetchrow_hashref()}; + return keys %retval; + } + + my @cols; + while (my @row = $sth->fetchrow_array) { + push(@cols, $row[0]); + } + $sth->finish; + + return @cols; +} + +##### +# Usage: &dbSet($table, $primhash_ref, $hash_ref); +# Note: dbSet does dbQuote. sub dbSet { - my ($table, $primkey, $primval, $key, $val) = @_; - my $query; + my ($table, $phref, $href) = @_; + my $where = join(' AND ', map { + $_."=".&dbQuote($phref->{$_}) + } keys %{$phref} + ); - my $result = &dbGet($table,$primkey,$primval,$primkey); + my $result = &dbGet($table, join(',', keys %{$phref}), $where); + + my(@keys,@vals); + foreach (keys %{$href}) { + push(@keys, $_); + push(@vals, &dbQuote($href->{$_}) ); + } + + if (!@keys or !@vals) { + &WARN("dbset: keys or vals is NULL."); + return; + } + + my $query; if (defined $result) { - $query = "UPDATE $table SET $key=".&dbQuote($val). - " WHERE $primkey=".&dbQuote($primval); + my @keyval; + for(my$i=0; $i{$_}) ); + } + + $query = sprintf("INSERT INTO $table (%s) VALUES (%s)", + join(',',@keys), join(',',@vals) ); } &dbRaw("Set", $query); @@ -118,11 +238,16 @@ sub dbSet { } ##### -# Usage: &dbUpdate($table, $primkey, $primval, $key, $val); +# Usage: &dbUpdate($table, $primkey, $primval, %hash); sub dbUpdate { - my ($table, $primkey, $primval, $key, $val) = @_; + my ($table, $primkey, $primval, %hash) = @_; + my (@array); + + foreach (keys %hash) { + push(@array, "$_=".&dbQuote($hash{$_}) ); + } - &dbRaw("Update", "UPDATE $table SET $key=".&dbQuote($val). + &dbRaw("Update", "UPDATE $table SET ".join(', ', @array). " WHERE $primkey=".&dbQuote($primval) ); @@ -130,32 +255,85 @@ sub dbUpdate { } ##### -# Usage: &dbInsert($table, $primkey, $primval, $key, $val); +# Usage: &dbInsert($table, $primkey, $primval, %hash); sub dbInsert { - my ($table, $primkey, $primval, $key, $val) = @_; + my ($table, $primkey, $primval, %hash, $delay) = @_; + my (@keys, @vals); + my $p = ""; + + if ($delay) { + &DEBUG("dbI: delay => $delay"); + $p = " DELAYED"; + } - &dbRaw("Insert", "INSERT INTO $table ($primkey,$key) VALUES (". - &dbQuote($primval).",".&dbQuote($val).")" + foreach (keys %hash) { + push(@keys, $_); + push(@vals, &dbQuote($hash{$_})); + } + + &dbRaw("Insert($table)", "INSERT $p INTO $table (".join(',',@keys). + ") VALUES (".join(',',@vals).")" ); return 1; } ##### -# Usage: &dbSetRow($table, @values); -sub dbSetRow { - my ($table, @values) = @_; +# Usage: &dbReplace($table, %hash); +# Note: dbReplace does optional dbQuote. +sub dbReplace { + my ($table, %hash) = @_; + my (@keys, @vals); + my $iquery = "INSERT INTO $table "; + my $uquery = "UPDATE $table SET "; + + foreach (keys %hash) { + if (s/^-//) { # as is. + push(@keys, $_); + push(@vals, $hash{'-'.$_}); + } else { + push(@keys, $_); + push(@vals, &dbQuote($hash{$_})); + } + $uquery .= "$keys[-1] = $vals[-1], "; + } + $uquery = ~s/, $/;/; + $iquery .= "(". join(',',@keys) .") VALUES (". join(',',@vals) .");"; + + &DEBUG($query) if (0); + + if(!&dbRaw("Replace($table)", $iquery)) { + &dbRaw("Replace($table)", $uquery); + } + + return 1; +} + +##### +# Usage: &dbSetRow($table, $vref, $delay); +# Note: dbSetRow does dbQuote. +sub dbSetRow ($@$) { + my ($table, $vref, $delay) = @_; + my $p = ($delay) ? " DELAYED " : ""; + + # see 'perldoc perlreftut' + my @values; + foreach (@{ $vref }) { + push(@values, &dbQuote($_) ); + } - foreach (@values) { - $_ = &dbQuote($_); + if (!scalar @values) { + &WARN("dbSetRow: values array == NULL."); + return; } - return &dbRaw("SetRow", "INSERT INTO $table VALUES (". + return &dbRaw("SetRow", "INSERT $p INTO $table VALUES (". join(",", @values) .")" ); } ##### # Usage: &dbDel($table, $primkey, $primval, [$key]); +# Note: dbDel does dbQuote sub dbDel { my ($table, $primkey, $primval, $key) = @_; @@ -171,17 +349,15 @@ sub dbRaw { my ($prefix,$query) = @_; my $sth; - my $res = $dbh->exec($query); - if (PGRES_COMMAND_OK ne $res->resultStatus) { - &ERROR("Raw($prefix): $dbh->errorMessage"); + if (!($sth = $dbh->prepare($query))) { + &ERROR("Raw($prefix): $DBI::errstr"); return 0; } - &DEBUG("Raw: oid status => '$res->oidStatus'."); - + &SQLDebug($query); if (!$sth->execute) { &ERROR("Raw($prefix): => '$query'"); - &ERROR("Raw($prefix): $DBI::errstr"); + $sth->finish; return 0; } @@ -196,6 +372,7 @@ sub dbRawReturn { my @retval; my $sth = $dbh->prepare($query); + &SQLDebug($query); &ERROR("RawReturn => '$query'.") unless $sth->execute; while (my @row = $sth->fetchrow_array) { push(@retval, $row[0]); @@ -210,29 +387,19 @@ sub dbRawReturn { ##### ##### -# Usage: &countKeys($table); +# Usage: &countKeys($table, [$col]); sub countKeys { - my ($table) = @_; + my ($table, $col) = @_; + $col ||= "*"; - return (&dbRawReturn("SELECT count(*) FROM $table"))[0]; + return (&dbRawReturn("SELECT count($col) FROM $table"))[0]; } -##### NOT USED. -# Usage: &getKeys($table,$primkey); -sub getKeys { - my ($table,$primkey) = @_; - my @retval; - - my $query = "SELECT $primkey FROM $table"; - my $sth = $dbh->prepare($query); - - $sth->execute; - while (my @row = $sth->fetchrow_array) { - push(@retval, $row[0]); - } - $sth->finish; +# Usage: &sumKey($table, $col); +sub sumKey { + my ($table, $col) = @_; - return @retval; + return (&dbRawReturn("SELECT sum($col) FROM $table"))[0]; } ##### @@ -243,14 +410,23 @@ sub randKey { my $query = "SELECT $select FROM $table LIMIT $rand,1"; my $sth = $dbh->prepare($query); - $sth->execute; + &SQLDebug($query); + &WARN("randKey($query)") unless $sth->execute; my @retval = $sth->fetchrow_array; $sth->finish; return @retval; } +##### +# Usage: &deleteTable($table); +sub deleteTable { + &dbRaw("deleteTable($_[0])", "DELETE FROM $_[0]"); +} + +##### # Usage: &searchTable($table, $select, $key, $str); +# Note: searchTable does dbQuote. sub searchTable { my($table, $select, $key, $str) = @_; my $origStr = $str; @@ -273,7 +449,11 @@ sub searchTable { my $query = "SELECT $select FROM $table WHERE $key LIKE ". &dbQuote($str); my $sth = $dbh->prepare($query); - $sth->execute; + &SQLDebug($query); + if (!$sth->execute) { + &WARN("Search($query)"); + return; + } while (my @row = $sth->fetchrow_array) { push(@results, $row[0]); @@ -288,9 +468,10 @@ sub searchTable { ##### ##### -# Usage: &getFactInfo($faqtoid, [$what]); +# Usage: &getFactInfo($faqtoid, $type); +# Note: getFactInfo does dbQuote sub getFactInfo { - return &dbGet("factoids", "factoid_key", $_[0], $_[1]); + return &dbGet("factoids", $_[1], "factoid_key=".&dbQuote($_[0]) ); } ##### @@ -300,17 +481,20 @@ sub getFactoid { } ##### -# Usage: &setFactInfo($faqtoid, $type, $what); -sub setFactInfo { - &dbSet("factoids", "factoid_key", $_[0], $_[1], $_[2]); -} - +# Usage: &delFactoid($faqtoid); sub delFactoid { my ($faqtoid) = @_; &dbDel("factoids", "factoid_key",$faqtoid); - &status("DELETED $faqtoid"); + &status("DELETED '$faqtoid'"); + + return 1; +} +##### +# +sub checkTables { + &FIXME("pgsql: checkTables(@_);"); return 1; } diff --git a/src/db_sql.pl b/src/db_sql.pl new file mode 100644 index 0000000..e13c41b --- /dev/null +++ b/src/db_sql.pl @@ -0,0 +1,20 @@ +# +# db_mysql.pl: {my,pg}SQL database frontend. +# Author: dms +# Version: v0.1 (20010908) +# Created: 20010908 +# + +package main; + +if (&IsParam("useStrict")) { use strict; } + +sub SQLDebug { + return unless (&IsParam("SQLDebug")); + + return unless (fileno SQLDEBUG); + + print SQLDEBUG $_[0]."\n"; +} + +1; diff --git a/src/logger.pl b/src/logger.pl index 2ba4150..5601b91 100644 --- a/src/logger.pl +++ b/src/logger.pl @@ -282,9 +282,9 @@ sub status { if (&IsParam("VERBOSITY")) { if ($statcountfix) { - printf $_red."!%5d!".$ob." ", $statcount; + printf $_red."!%6d!".$ob." ", $statcount; } else { - printf $_green."[%5d]".$ob." ", $statcount; + printf $_green."[%6d]".$ob." ", $statcount; } # three uberstabs to Derek Moeller. diff --git a/src/modules.pl b/src/modules.pl index 83d7890..e0c881a 100644 --- a/src/modules.pl +++ b/src/modules.pl @@ -87,6 +87,7 @@ sub loadDBModules { &showProc(" (DBI // mysql)"); &status(" using MySQL support."); + require "$bot_src_dir/db_sql.pl"; require "$bot_src_dir/db_mysql.pl"; $moduleAge{"$bot_src_dir/db_mysql.pl"} = time(); @@ -99,11 +100,13 @@ sub loadDBModules { &showProc(" (Pg // postgreSQLl)"); &status(" using PostgreSQL support."); + require "$bot_src_dir/db_sql.pl"; require "$bot_src_dir/db_pgsql.pl"; + } elsif ($param{'DBType'} =~ /^dbm$/i) { &status(" using Berkeley DBM 1.85/2.0 support."); - &ERROR("dbm support is broken... you want it, you fix it!"); + &ERROR("dbm support is broken... if you want it, fix it yourself!"); &shutdown(); exit 1; -- 2.39.2