--- /dev/null
+Infobot (rebranded blootbot):
+ License: Artistic
+ Main Author:
+ - Tim Rike <Tim@Rikers.org>
+ Other Contributors:
+ - David Sobon <dms@users.sourceforge.net>
+ - Danny Jabbour [GmLB] <danny@opticaldelusion.org>
+ - Danny McGrath <djmcgrath@users.sourceforge.net>
+
+Infobot (original):
+ License: As perl (GPL & Artistic)
+ - Kevin A. Lenzo [oznoid] <lenzo@cs.cmu.edu>
+ - Patrick Cole [ltd] <???>
+
+Blootbot:
+ License: Artistic
+ Main Author:
+ - Tim Riker <Tim@Rikers.org>
+ Other Contributors:
+ - David Sobon <dms@users.sourceforge.net>
+ - Danny Jabbour [GmLB] <danny@opticaldelusion.org>
+
+Module-Reload: (idea taken)
+ License: Artistic
+ - Doug MacEachern <???>
+ - Joshua Pritikin <???>
+
+Module-Units:
+ License: GPL
+ - M-J. Dominus <mjd-perl-units-id-iut+buobvys+@plover.com>
+
+OnJoin:
+ - Corey Edwards <tensai@zmonkey.org>
+
+Quotes file (files/infobot.randtext):
+ - ??? Ask netgod/larne/is for dpkg's tcl
--- /dev/null
+Known bugs that should be dealt with soon as possible:
+
+ * "+sed" can currently be used to flood the boot off the network. Disable for now
+ * allows adding a "cmd:foo (.*)" factoid but not removing it (not sure if this still applies)
+ * Older CMD: foo's cannot be used or removed. Must be removed manually from the database with SQL
+ * !+topic list gives and incorrect error Failed. "You (#botpark) are not in #botpark, hey?"
+ * Bot tries to ask chanserv for OP's on any channel. Should be a chanset setting on a per channel basis
+ * News is currently stored in a file rather than the SQL table created for it
+ * bot doesnt seem to keep track of stat counters for "heh :) ...etc". Might be settings though and not a bug
+ * !help has size issues. Add's extra lines with only 1 or 2 help commands instead of one maximum size IRC msg
+ * FIXME: !WARN! ircCheck: we have a NULL chan in hash channels? removing!
--- /dev/null
+Method of installation.
+-----------------------
+
+- Copy files/sample/* to files/
+
+- Edit files/infobot.config, modify to taste.
+- Edit files/infobot.servers to modify list of IRC servers to connect.
+- Edit files/infobot.chan to set which channels to join.
+
+- Install the following Perl modules:
+ - Net::IRC perl module
+ - Debian: (apt-get install libnet-irc-perl)
+ - WWW::Search
+ - Debian: (apt-get install libwww-search-perl)
+ - LWP
+ - Debian: (apt-get install libwww-perl)
+ - HTML::Parser
+ - Debian: (apt-get install libhtml-parser-perl)
+
+- Choose your database:
+ - MySQL, read INSTALL.mysql (supported)
+ - SQLite, read INSTALL.sqlite (supported)
+ - SQLite2, read INSTALL.sqlite (supported)
+ - PgSQL, read INSTALL.pgsql (unsupported, may work)
+
+- There are "bugs" in the perl modules. Read INSTALL.patches on how to fix.
+
+- Finally, './infobot'
--- /dev/null
+INSTALL.mysql
+----------------
+
+- Install a MySQL server and the DBI Perl modules.
+ - Debian: (apt-get install mysql-server libdbd-mysql-perl)
+
+- Run 'mysqladmin -u root -p create <DB NAME>'
+ Where <DB NAME> is the same as specified in infobot.config.
+
+- Run 'setup/setup.pl'
+
+= Possible problems
+ - if connection to localhost is (short) refused, run
+ '/etc/init.d/mysql stop'
+ '/etc/init.d/mysql start'
+ - if connection for user is refused, reload grant tables with
+ 'mysqladmin -u root -p reload'
+
+* [OPTIONAL]
+ - run 'scripts/dbm2mysql.pl old-db' to convert dbm database file
+ to mysql.
+
+ADDITIONAL NOTES:
+-----------------
+You can add a new user manually by connecting to MySQL and performing these
+commands:
+
+ $ mysql -u root -p
+
+ mysql> CREATE DATABASE infobot;
+ mysql> GRANT USAGE ON *.* TO 'user'@'localhost' IDENTIFIED BY 'yourpassword';
+ mysql> GRANT ALL PRIVILEGES ON infobot.* TO 'user'@'localhost';
+
+FULL FACTOID DATABASE:
+----------------------
+You can get the data from the MySQL database that the apt bot uses on
+#debian at freenode (irc.freenode.net), at:
+
+ http://lain.cheme.cmu.edu/~apt/infobot/apt.sql.bz2
--- /dev/null
+INSTALL.patches
+-------------------
+
+- apply *.patch patches inside patches/
+ - cd /usr/lib/perl5/WWW/Search
+ patch -p0 < WWW::Search::Google.patch
+
+- alternatively, move the files from patches/
+ - mv patches/Google.pm /usr/lib/perl5/WWW/Search/
+
+Net::IRC DCC CHAT
+----------------------
+Unfortunately, Net::IRC 0.70 has buggy code that does not detect DCC CHAT
+properly. to patch:
+ cd /usr/share/perl5/Net/IRC/
+ cat ~bot/patches/Net_IRC_Connection_pm.patch | patch -p0
--- /dev/null
+Method of installation.
+-----------------------
+
+- Debian: (apt-get install postgresql)
+- Debian: (apt-get install libpg-perl)
+
+
+As of now, infobot has full pgsql support. It seems to be working 100%, but it
+assumes that you have precreated the database and user for now. As long as you
+already created the database and user and stored this info in the
+infobot.config, then the tables will automatically be created on startup. Until
+I get setup.pl fixed, run the following commands as root (or postgres if root
+doesnt have permission to create users/db's):
+
+> createuser --no-adduser --no-createdb --pwprompt --encrypted <user>
+> createdb --owner=<user> <dbname> [<description>]
+
+Dont forget to replace <user> and so forth with actual values you intend to use,
+and dont include the <>'s ;) If you run these commands, you should get a user
+with an encrypted password that cannot create new db's or user's (as it should
+be!), and the user will own the newly created database <dbname>. Congrats!
+
+If everything went fine, you should have everything infobot needs to use pgsql.
+Next simply cd to the base directory you installed the bot to and type:
+
+./infobot
+
+
+Thats it! Everything the bot needs should be automatically created when it loads
+for the first time.
+
+In the future I will try to get around to editing the setup.pl file to ask the
+same questions it does for mysql (your root password etc) so that you can skip
+manually creating the database/user. But for now, this should be just fine for
+most of you techies out there.
+
+
+----
+troubled@freenode
--- /dev/null
+INSTALL.sqlite
+----------------
+
+SQLite is a C library that implements an embeddable SQL database engine.
+Programs that link with the SQLite library can have SQL database access without
+running a separate RDBMS process. The distribution comes with a standalone
+command-line access program (sqlite) that can be used to administer an SQLite
+database and which serves as an example of how to use the SQLite library.
+
+infobot will create a file called <DBname>.sqlite and populate the tables for
+you if they do not already exist.
+
+- Install SQLite libraries and DBI Perl modules.
+ - Debian: (apt-get install libsqlite0 libdbd-sqlite-perl)
+
+other distros might need to build from sources.
+
+You may use either DBD::SQLite or DBD::SQLite2
+
+SQLite sources:
+
+http://www.hwaci.com/sw/sqlite/
+
+DBD::SQLite sources:
+
+http://search.cpan.org/author/MSERGEANT/DBD-SQLite/
+
+You will also need the normal Perl DBD stuff which should be included in your
+Perl distribution.
--- /dev/null
+
+
+
+
+ The "Artistic License"
+
+ Preamble
+
+The intent of this document is to state the conditions under which a
+Package may be copied, such that the Copyright Holder maintains some
+semblance of artistic control over the development of the package,
+while giving the users of the package the right to use and distribute
+the Package in a more-or-less customary fashion, plus the right to make
+reasonable modifications.
+
+Definitions:
+
+ "Package" refers to the collection of files distributed by the
+ Copyright Holder, and derivatives of that collection of files
+ created through textual modification.
+
+ "Standard Version" refers to such a Package if it has not been
+ modified, or has been modified in accordance with the wishes
+ of the Copyright Holder as specified below.
+
+ "Copyright Holder" is whoever is named in the copyright or
+ copyrights for the package.
+
+ "You" is you, if you're thinking about copying or distributing
+ this Package.
+
+ "Reasonable copying fee" is whatever you can justify on the
+ basis of media cost, duplication charges, time of people involved,
+ and so on. (You will not be required to justify it to the
+ Copyright Holder, but only to the computing community at large
+ as a market that must bear the fee.)
+
+ "Freely Available" means that no fee is charged for the item
+ itself, though there may be fees involved in handling the item.
+ It also means that recipients of the item may redistribute it
+ under the same conditions they received it.
+
+1. You may make and give away verbatim copies of the source form of the
+Standard Version of this Package without restriction, provided that you
+duplicate all of the original copyright notices and associated disclaimers.
+
+2. You may apply bug fixes, portability fixes and other modifications
+derived from the Public Domain or from the Copyright Holder. A Package
+modified in such a way shall still be considered the Standard Version.
+
+3. You may otherwise modify your copy of this Package in any way, provided
+that you insert a prominent notice in each changed file stating how and
+when you changed that file, and provided that you do at least ONE of the
+following:
+
+ a) place your modifications in the Public Domain or otherwise make them
+ Freely Available, such as by posting said modifications to Usenet or
+ an equivalent medium, or placing the modifications on a major archive
+ site such as uunet.uu.net, or by allowing the Copyright Holder to include
+ your modifications in the Standard Version of the Package.
+
+ b) use the modified Package only within your corporation or organization.
+
+ c) rename any non-standard executables so the names do not conflict
+ with standard executables, which must also be provided, and provide
+ a separate manual page for each non-standard executable that clearly
+ documents how it differs from the Standard Version.
+
+ d) make other distribution arrangements with the Copyright Holder.
+
+4. You may distribute the programs of this Package in object code or
+executable form, provided that you do at least ONE of the following:
+
+ a) distribute a Standard Version of the executables and library files,
+ together with instructions (in the manual page or equivalent) on where
+ to get the Standard Version.
+
+ b) accompany the distribution with the machine-readable source of
+ the Package with your modifications.
+
+ c) give non-standard executables non-standard names, and clearly
+ document the differences in manual pages (or equivalent), together
+ with instructions on where to get the Standard Version.
+
+ d) make other distribution arrangements with the Copyright Holder.
+
+5. You may charge a reasonable copying fee for any distribution of this
+Package. You may charge any fee you choose for support of this
+Package. You may not charge a fee for this Package itself. However,
+you may distribute this Package in aggregate with other (possibly
+commercial) programs as part of a larger (possibly commercial) software
+distribution provided that you do not advertise this Package as a
+product of your own. You may embed this Package's interpreter within
+an executable of yours (by linking); this shall be construed as a mere
+form of aggregation, provided that the complete Standard Version of the
+interpreter is so embedded.
+
+6. The scripts and library files supplied as input to or produced as
+output from the programs of this Package do not automatically fall
+under the copyright of this Package, but belong to whoever generated
+them, and may be sold commercially, and may be aggregated with this
+Package. If such scripts or library files are aggregated with this
+Package via the so-called "undump" or "unexec" methods of producing a
+binary executable image, then distribution of such an image shall
+neither be construed as a distribution of this Package nor shall it
+fall under the restrictions of Paragraphs 3 and 4, provided that you do
+not represent such an executable image as a Standard Version of this
+Package.
+
+7. C subroutines (or comparably compiled subroutines in other
+languages) supplied by you and linked into this Package in order to
+emulate subroutines and variables of the language defined by this
+Package shall not be considered part of this Package, but are the
+equivalent of input as in Paragraph 6, provided these subroutines do
+not change the language in any way that would cause it to fail the
+regression tests for the language.
+
+8. Aggregation of this Package with a commercial distribution is always
+permitted provided that the use of this Package is embedded; that is,
+when no overt attempt is made to make this Package's interfaces visible
+to the end user of the commercial distribution. Such use shall not be
+construed as a distribution of this Package.
+
+9. The name of the Copyright Holder may not be used to endorse or promote
+products derived from this software without specific prior written permission.
+
+10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
+WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+
+ The End
--- /dev/null
+infobot v1.5.0
+--------------
+
+INTRODUCTION
+ This bot is based upon blootbot, which was a fork of infobot-0.44.2 by
+Kevin Lenzo <lenzo@cs.cmu.edu>, which is now officially rebranded back to
+infobot! The basis of infobot is still there but _many_ wild features have
+been added. Along the way, a couple of typos were spotted in the original
+infobot source and fixed in this version. Without infobot, there would be no
+blootbot, and thus no infobot again, so all thanks to kevin for bringing
+infobot in the first place.
+
+
+FEATURES
+ * Additional information stored with factoids. (factinfo)
+ * Wide range of statistics for Bot, Factoids, IRC, Debian.
+ (status, factstats, ircstats, chanstats, cmdstats)
+ * Advanced topic management. (the first cool feature)
+ * Improved factoid search, allowing search by key or value.
+ * Freshmeat support (freshmeat.net)
+ * Debian Contents and Packages, search and info.
+ * ChanServ/NickServ (OPN) support.
+ * WWW-Search (eg: google for BLAH)
+ * Slashdot, Kernel and Freshmeat auto-update announcements.
+ * Units conversion (provided by external module, Units-Module)
+
+
+DESIGN
+ - Modularity. Ability to disable IRC or Factoid support.
+ - Funky pseudo Module autoloader support
+ - Eleet Forker() function
+
+
+IMPROVEMENTS
+ * log file is not opened and closed for each line of data
+ => unblocked logging is used.
+ * seen data is not flushed for each public message on IRC
+ => caching and flushing over an interval is used.
+
+
+HISTORY
+ As of 0.99pre1, blootbot supports mysql database in the hope to
+increase performance and to avoid borked over dbm's which occurred when
+the bot crashed (??). The mysql code is far larger (or perhaps twice
+as many functions) than expected even though a few functions were needed
+for DBM due to lack of table deficiencies.
+
+ As of 1.0.0pre1, blootbot takes advantage of Net::IRC. The
+change over was fairly comfortable (95% clean). Just minor problems here
+and there, mostly debugging and getting it right.
+
+ As of 1.0.0RC2, the old style DBM (Berkeley) has been ported
+back. It should work in all but 3 specific (countdown, factstats unreq)
+cases. preliminary pgsql support has been added but someone with pgperl
+knowledge needs to fix it up or at least unify the module with mysql.
+
+ As of 1.5.0, blootbot was rebranded back to infobot.
+
+
+INSTALLATION
+ - Read the included INSTALL file
+
+
+NOTICE
+ Be warned that this bot consumes quite a lot of memory upon start
+up and during usage. Right now, 7.4megs is used for old'ish perl, 8.3megs
+with perl 5.005. fork() is used but don't be alarmed at the memory usage
+as fork(), as I was told, uses COW (copy on write).
+
+ WARNING: enabling wingate support may involve complaints of some
+sort, probably because the telnet connection isn't closed properly.
+However, these people do not realize the potential of open wingates.
+
+ Please beta test it and report bugs as I have not had the time to
+test all modifications properly (and extensively). Suggestions are
+welcomed.
+
+ gp@OPN is currently working on a C version of infobot or
+blootbot, not based on the above source base. Core factoid code and
+mysql support works - but that is it.
+
+
+MODIFICATIONS
+ All modifications are that of the blootbot author unless otherwise
+specified, like none. See 'ChangeLog' for details. A list of future
+features listed in 'TODO'.
+
+ See 'USAGE' for complete list of commands with description
+(FIXME) and examples (FIXME). Yes, it is incomplete. It is better for
+you to find the cookies than for me to hand-feed them to you ;)
+
+ See 'EXAMPLES' for various usage of factoids and "hidden"
+variables. If you're hardcore, check out 'CommandStubs.pl' and
+'UserExtras.pl' for cool features.
+
+ topic [help] - Topic help.
+ topic add <topic> - Append <topic> to the current topic.
+ topic del <#> - Purge topic ID <#> from current topic.
+ topic list - List broken down summary of current topic.
+ topic mod s/old/new/ - Modify the topic using regex.
+ - Now supports , and # as delimiters.
+ topic mv <1> <type> <2> - <type>:
+ before - Move <1> before <2>
+ after - Move <1> after <2>
+ swap - Swap <1> and <2>
+ topic shuffle - Jumble the subtopics.
+
+ topic history - Show previous channel topics.
+ topic restore <#> - Restore channel topic to <#> on history
+ #list.
+
+==> Individual commands: NEW
+ (lobotomy|bequiet) -- [o] silence the bot.
+ (unlobotomy|benoisy) -- [o] unsilence the bot.
+
+ set <param> <value> -- ...
+ unset <param> -- ...
+
+
+NOTES
+ To administrate/control the bot remotely, this can only be done
+through DCC CHAT. /chat <BOT NICK>. All commands must be prepended by
+'.' otherwise it is sent to the bot chat net
+
+
+UNTESTED:
+ - user statistics shown by 'seen'. bug in this?
+ - User Information Services.
+ - new wingate caching/file-read code.
+ - disabling IRC/factoid support code.
+ - PG supports need to be worked and thoroughly tested.
+
+
+CONTRIBUTIONS
+ jCommons, is, netgod, mu and Mercury for attempting to break my
+modifications, aswell as giving suggestions and ideas in the early
+development stages. Bashing of modifications courtesy of larne, irq, lilo
+and \broken.
+
+ mu@OPN for the SAR (=~ s///) and Topic history patch.
+
+ someone emailed me a patch to fix up telnet but I accidently
+deleted the message together with the patch after replying to the guy. I
+hope to get that same guy to re-send me the patch...
+
+ MbM@OPN sent a patch to clean up behaviour of factoids
+(adding, removing, modifying). Thanks.
+
+
+CONTACT
+ Contributions of a patch, or anything, can be sent to
+<infobot-devel@lists.sourceforge.net>
+
+Some Documentation is on the website. Please see it for details or
+visit: http://infobot.sourceforge.net/
+
+
+IRC
+ If your looking to hang out on IRC, feel free. We can be found
+in the #infobot channel on irc.freenode.net. See you there!
--- /dev/null
+See INSTALL file on how to install the bot.
+
+Quick usage instructions:
+-------------------------
+
+DCC CHAT:
+.+chan #chan
+.chanset #chan +autojoin
+.chanset +autojoin
+.chanunset -autojoin
+.chanset -autojoin
+
+for list of configuration options, run:
+ perl scripts/findparam.pl
--- /dev/null
+TODO:
+ - Normalize the SQL tables a little better to reduce size and increase speed
+ - Keep the Changelog, TODO and BUGS files up to date. Clean things up a bit
+ - rename ^[+-] commands
+ - remind - like this and others: http://jibble.org/reminderbot/
+ - kill SHM and and move to a pipe
+ - add CIA like support - http://cia.navi.cx/
+ - add pastebot like support - http://sial.org/pbot/
+ - move nicks/server into sql table
+ - make channel flags be server/channel flags
+ - move channel flags to sql table, include initial state
+ - move praise from infobot.lang to "praise:<something>" in factoids?
+ - move lart from infobot.lang to "lart:<something>" in factoids?
+ - debian BTS frontend "bugs"
+ - !country
+ - !dinstall
+ - support DCC SEND of factoid (listkeys/listvals) that matched.
+ - news: show total requested count, users "registered", users
+ "ignored"
+ - add notes about news redesign to accomodate individual items
+ read - need to add id's to each item too.
+ - bind DCC CHAT service to port.
+ - man perlipc, search for service.
+ - do forking aswell.
+ - debian: "find -2.4.1" does not work but 2.4.1 does?
+ - $debug var needed.
+ - check if debian downloading files are proper.
+ - verbose: say why config option was enabled/enabled.
+ - registered flags for users/channels
+ - end of DynaConfig.pl
+ - use in UserDCC.. warn if value is not in list.
+ - add &checkSet() or &_chanset();
+ - attempt to move userDCC to hooks.
+ - need to modify parseCmdHooks for user flags?
+ - make timers below 5 or 10 mins non-random values.
+ - create a .csv import/export program
+-- EFFORT 1.
+ - make IRC/Schedulers.pl work 100%.
+ - intervals must be multiple of the smallest one otherwise
+ auto-fixed.
+ - make intervals chan-specific
+ - need to store info in $sched{$what}{$chan} =
+ time(); when last run or next run?
+
+Other TODO items may be listed on sourceforge. Please access it from the
+website or this link:
+http://sourceforge.net/pm/task.php?group_id=2241
+
+----------------------------------------------------
+------------ FUTURE, NON-IMPORTANT
+ - <greycat> ~country ua
+ - <irq_w> xk: add it :) and my imdb feature :)
+ - <greycat> xk: and ~bugs :)
+ - "HACKING" text file, documentation of where things start,
+ what "core" or reuseable functions are used and what for.
+ - web interface
+ - on join message - customizeable, option.
+ - addon to UserInfo but for channels?
+ - ^B's are removed (HOW?) from factoids.
+ - asking questions.... make more guesses
+ - throttling of "help topic": push-pull system of &msg().
+ - use autoloader properly.
+ - Module::<BLAH>::<CMD>
+ - make a global autoloader.
+ - support notification of author of deleted factoids,
+ - flag to hide owner of factoid.
+ - table data for DCC CHAT or misc table.
+ - dynamic user//configuration file upgrade:
+ - finer granuality(sp) of userlist/ignore file
+ - <el_gore> apt, find netconfig -- merge similar files.
+ - and same files(1 per package) for multiple packages.
+ - merge partial similar paths together.
+ - do some test cases to confirm code actually works as
+ proposed.
+
+++ /dev/null
-Blootbot:
- License: Artistic
- Main Author:
- - Tim Riker <Tim@Rikers.org>
- Other Contributors:
- - David Sobon <dms@users.sourceforge.net>
- - Danny Jabbour [GmLB] <danny@opticaldelusion.org>
-
-Module-Reload: (idea taken)
- License: Artistic
- - Doug MacEachern <???>
- - Joshua Pritikin <???>
-
-Module-Units:
- License: GPL
- - M-J. Dominus <mjd-perl-units-id-iut+buobvys+@plover.com>
-
-Infobot:
- License: As perl (GPL & Artistic)
- - Kevin A. Lenzo [oznoid] <lenzo@cs.cmu.edu>
- - Patrick Cole [ltd] <???>
-
-OnJoin:
- - Corey Edwards <tensai@zmonkey.org>
-
-Patches:
- - ...
-
-Quotes file (files/blootbot.randtext):
- - ??? Ask netgod/larne/is for dpkg's tcl
+++ /dev/null
-Known bugs that should be dealt with soon as possible:
-
- * "+sed" can currently be used to flood the boot off the network. Disable for now
- * allows adding a "cmd:foo (.*)" factoid but not removing it (not sure if this still applies)
- * Older CMD: foo's cannot be used or removed. Must be removed manually from the database with SQL
- * !+topic list gives and incorrect error Failed. "You (#botpark) are not in #botpark, hey?"
- * Bot tries to ask chanserv for OP's on any channel. Should be a chanset setting on a per channel basis
- * News is currently stored in a file rather than the SQL table created for it
- * bot doesnt seem to keep track of stat counters for "heh :) ...etc". Might be settings though and not a bug
- * !help has size issues. Add's extra lines with only 1 or 2 help commands instead of one maximum size IRC msg
- * FIXME: !WARN! ircCheck: we have a NULL chan in hash channels? removing!
+++ /dev/null
-2007-03-13 troubled
-
- * files/sample/blootbot.chan: Change the #debian-bots channel to
- #blootbot for publicity sake ;)
- * TODO: Minor edits
- * README: Mention IRC channel
- * src/IRC/IrcHelpers.pl: Fixed bug in "+sed" that caused the bot
- to flood itself off the network when passed large s///g;. A
- temporary limit of 255 charaters on the output has been enabled.
-
-2007-03-11 22:00 troubled
-
- * src/{Process.pl,UserExtra.pl}: Fixed bug with karma stats. It
- wasnt supplying the channel and causing a dupe pkey issue and
- also resulted in global stats instead of per channel. Stats
- are now per channel again. As a result, you should probably:
- DELETE FROM stats WHERE channel = 'PRIVATE' AND "type" = 'karma';
- to clean up since they will never match now, or be pointless to
- keep track of because karma can only be done in channel.
-
-2007-03-08 00:00 troubled
-
- * files/sample/blootbot.config: set tempDir changed to /tmp and
- changed pgsql to SUPPORTED!
- * src/dbi.pl: Fixed SQL comments (--) bug that prevented tables
- from being created during startup.
- * src/Modules/Factoids.pl: Typo for "factstats locked in selColHash
- was preventing it from finding the func. Also addressed a !WARN!
- issue about sorting a scalar.
- * src/dbi.pl: Altered checkTables() to pass $dbtype when creating
- tables. Table sql now called from setup/<$dbtype>/$table.sql
- * src/Modules/Topic.pl: Fixed topicAuthor when no topic existed
- and cleaned up original if statement to remove redundancy
- * Reorganized the setup/ dir. Put schema SQL for each db type
- into its own dir to allow customization. See the README file
- * src/dbi.pl: Simplified the pgsql "SHOW TABLES" SQL
-
-2007-03-07 14:06 troubled
-
- * setup/pgsql/: Added pgsql specific dir. To be completed later
- * setup/pgsql/pgsql-schema.sql: Import this file into an precreated
- database as per blootbot.config and pgsql should be good to go
- * INSTALL.pgsql: Changes to reflect semi-function pgsql progress
-
-2007-03-06 00:00 troubled
-
- * src/Process.pl: sqlReplace switched to sqlSet to fix pgsql.
- sqlReplace should be removed since its not pg friendly.
- There is no matching REPLACE INTO in pgsql.
- * src/Factoids/DBCommon.pl: &setFactInfo during ~unlock set
- time to NULL which Pgsql wants "0" since NOT NULL
- * src/Factoids/Update.pl: see Process.pl change
- * src/Misc.pl: see Process.pl change
- * src/dbi.pl: Added working PostgreSQL support! yay! ;)
- * src/Modules/botmail.pl: &sqlReplace -> &sqlSet; removed
- &sqlQuote (data already quoted and broke 1 msg only)
- * src/IRC/IrcHooks.pl: see Process.pl change
- * src/IRC/Schedulers.pl: see Process.pl change
-
-2005-02-18 00:00 timriker
-
- * CMD: is now cmd:
-
-2005-02-18 00:00 timriker
-
- * src/Factoids/Question.pl: minVolunteerLength now per channel
- * src/core.pl: getChanConf checks _default too
- * src/: "s/hasParam/IsChanConfOrWarn/"
- * src/: add handling for channel specific factoids:
- "#botpark logs" -> http://ibot.rikers.org/botpark
- factoidSearch is a space delimited list of prefixes to try
- * src/: kill %myModules - loadMyModule expects the CORRECT CASE basename
- * .: a ton of other crap that TimRiker never documented here
-
-2001-04-28 22:04 dms
-
- * src/IRC/: IrcHelpers.pl, IrcHooks.pl, Schedulers.pl: hookMode:
- change chan to nick. if deopped by chanserv, check it dont change
- channel limits during netsplit.
-
-2001-04-26 22:37 dms
-
- * src/: DynaConfig.pl, Process.pl, UserExtra.pl, core.pl,
- Factoids/Statement.pl, IRC/Irc.pl, IRC/IrcHelpers.pl,
- IRC/IrcHooks.pl, IRC/Schedulers.pl, Modules/News.pl: "~forget blah"
- now works. thanks to ElectricElf documented user flags
- public/private/notice send limit now configurable. thanks to EE
- added "countrystats" command.
- "blootbot: are you fixed now? :)" -- fixed. found by greycat
- use hasParam instead of IsParam in UserExtra.pl/userCommands()
- command "ord" handling fixed.
-
-2001-04-24 20:58 dms
-
- * src/: logger.pl, IRC/Irc.pl, IRC/IrcHelpers.pl, IRC/IrcHooks.pl,
- IRC/Schedulers.pl: fix more warnings
- set $ident in nick()
-
-2001-04-23 20:14 dms
-
- * src/: Process.pl, UserExtra.pl, logger.pl, IRC/Irc.pl,
- IRC/IrcHooks.pl, IRC/Schedulers.pl: allow join to join irrelevent of being on chan
- chanstats: count stats if exist - make perl happy
- misc cleanup of status()
- add time taken to join all channels, useless stats.
- disable notify code
- leakCheck: show stats on hash chanstats
- mkBackup: show age of file.
-
-2001-04-22 22:58 dms
-
- * src/IRC/IrcHooks.pl: fix on_targettoofast once and for all, hopefully.
-
-2001-04-22 22:01 dms
-
- * src/: UserExtra.pl, logger.pl: make sure chanstats don't flood
- don't throttle if it's a perl warn message
-
-2001-04-22 21:52 dms
-
- * src/Factoids/Reply.pl: woops... forgot this aswell
-
-2001-04-22 21:48 dms
-
- * src/Factoids/Reply.pl: disabled literal if factoid is requested via /msg by author; use literal
- instead
-
-2001-04-22 20:25 dms
-
- * src/IRC/: Irc.pl, IrcHooks.pl, Schedulers.pl: don't call chanservcheck in joinnextchan
- call chanservcheck in on_endofnames
- ircCheck "resets" itself if it thinks so
-
-2001-04-22 20:17 dms
-
- * src/: Factoids/Question.pl, Factoids/Reply.pl, IRC/Irc.pl,
- Modules/UserDCC.pl: part now warns if we're on a channel - allow it anyway.
- added "reset" to DCC CHAT
-
-2001-04-21 22:37 dms
-
- * TODO: todo list, for those who want to know what "new" features will be coming
-
-2001-04-20 21:27 dms
-
- * src/: Process.pl, IRC/Schedulers.pl: we didn't set modified_time for deleted factoids - fixed
- also... if final delete factoid list is >50... don't do it!
-
-2001-04-20 21:16 dms
-
- * src/: UserExtra.pl, IRC/Irc.pl: chagned notice lines/sec to 3
- made connectivity percentage 5 significant decimal places.
-
-2001-04-20 20:54 dms
-
- * src/: CommandStubs.pl, DynaConfig.pl, Misc.pl, Process.pl,
- UserExtra.pl, Factoids/Question.pl, Factoids/Reply.pl,
- Factoids/Statement.pl, IRC/Irc.pl, IRC/IrcHelpers.pl,
- IRC/IrcHooks.pl, IRC/Schedulers.pl, Modules/Debian.pl,
- Modules/DebianExtra.pl, Modules/Factoids.pl, Modules/Topic.pl,
- Modules/Units.pl, Modules/Uptime.pl, Modules/UserDCC.pl: converted %{$blah{$blah}} to %{ $blah{$blah} }
- added IRC hooks to catch failed channel joins
- chanserv function moved to joinNextChan
- created chanserv function for "common" use, chanServCheck
- changed cache{chanlimitChange} hash a little
- chanserv check removed from on_endofnames
- typo on on_invite - fixed.
- chanserv/ops removed from ircCheck()
- joinNextChan removed from ircCheck()
- added preliminary debian BTS frontend support
-
-2001-04-19 20:11 dms
-
- * src/Modules/News.pl: news: don't list new items if they don't have Text.
-
-2001-04-18 23:07 dms
-
- * src/: CommandStubs.pl, IRC/Irc.pl, IRC/IrcHooks.pl,
- IRC/Schedulers.pl: fixed seen ""
- added where debugging messages came from (functions)
- fixed reversed use of % in if statement, stupid me :)
- changed backup times for files again
-
-2001-04-18 22:51 dms
-
- * src/IRC/Irc.pl: forgot this one
-
-2001-04-18 22:50 dms
-
- * src/: UserExtra.pl, core.pl, IRC/Irc.pl, IRC/Schedulers.pl: added flood protection for notice()
- added connectivity percentage to ircstats.
- other changes forgotten
-
-2001-04-18 22:41 dms
-
- * src/IRC/IrcHooks.pl: fixed the following bugs:
- [57419] on_ttf: X1 Target change too fast. Please wait 50 seconds.
- [57604] !WARN! IsChanConf: lowercased chan. (Read error to
- boren-[adsl-63-197-68-132.dsl.snfc21.pacbell.net]: EOF from client)
-
-2001-04-18 22:30 dms
-
- * src/: core.pl, IRC/IrcHelpers.pl, IRC/Schedulers.pl,
- Modules/W3Search.pl: fix chanlimitChange time
- w3search => "blah for blah" fails - fixed.
-
-2001-04-17 23:56 dms
-
- * src/IRC/IrcHelpers.pl: ok... use "" around hashes that use _ bare.
-
-2001-04-17 23:34 dms
-
- * src/: core.pl, Modules/News.pl: ...
-
-2001-04-17 22:03 dms
-
- * src/Modules/News.pl: forgot to use \d+ for read shortcut
- other changes that the last commit missed or something
-
-2001-04-17 20:35 dms
-
- * src/core.pl: another round of useless changes
-
-2001-04-16 21:45 dms
-
- * src/: CommandStubs.pl, DynaConfig.pl, core.pl, IRC/Irc.pl,
- IRC/IrcHooks.pl, IRC/Schedulers.pl, Modules/News.pl: chanset: fixed the following problem.
- .chanset #debian +babeflish
- .chanset #debian -babeflish
- -chanunset #debian babelflish
- - yet another minor bug, use !msgType for dcc chat aswell.
- - selfflood proteciton for /msg
- - like 4/sec or 1k/sec
- - msgcount, msgbyte, msgtime
- - pubcount, pubbyte, pubtime
- - fixed other bugs.... weeeeeeee....
-
-2001-04-14 22:48 dms
-
- * src/IRC/: IrcHelpers.pl, Schedulers.pl: prevent erratic (multiple) changes of chan limit in short space of time.
- this would be a major problem in chanlimitVerify@IrcHelpers.pl since
- it's called for every join. Better safe than sorry.
-
-2001-04-14 20:17 dms
-
- * src/: Process.pl, core.pl, IRC/Irc.pl, IRC/IrcHooks.pl,
- IRC/Schedulers.pl, Modules/News.pl: IRC/IrcHooks.pl
- - forgot to reset msgType/who/chan
- after hookMsg in on_msg and on_public.
- - on_join: if bot joins, don't do wingate/bans
- and other useless stuff
- - on_join: set msgType for ICC.
- - on_part: set msgType/chan/who
- - on_quit: set msgType/chan/who
- - on_public: make chan global for ICC
- => should fix all bugs.
- => I have no idea how this worked so brokenly.
- News.pl - more more changes
-
-2001-04-14 00:45 dms
-
- * src/: core.pl, IRC/IrcHelpers.pl, IRC/IrcHooks.pl,
- IRC/Schedulers.pl, Modules/News.pl: another round of changes, damn it was hard to figure out why news wasn't
- appearing properly - I think we still have that problem but it's semi
- rare.
- - Also fixed netsplit problems, forgot a next line.
- - don't run all funky commands in on_join if netsplit is enabled.
- - other tiny things not worth mentioning.
-
-2001-04-13 23:23 dms
-
- * src/: IRC/IrcHelpers.pl, IRC/IrcHooks.pl, IRC/Schedulers.pl,
- Modules/Factoids.pl, Modules/News.pl: news: can make news compulsory (chanset +newsNotifyAll)
- and opt-out (news unnotify)
- irchooks: splitted into IrcHelpers.pl so we can reload it on the fly.
- factoids: added debugging for short factoids that may be botched up
- references
-
-2001-04-12 21:12 dms
-
- * src/: UserExtra.pl, db_mysql.pl, IRC/Schedulers.pl,
- Modules/News.pl, Modules/UserDCC.pl: news: added news->factoid redirection
- ton load of minor changes or bug fixes that cannot really be summarized
-
-2001-04-11 22:34 dms
-
- * src/: Process.pl, UserExtra.pl, db_mysql.pl, modules.pl,
- IRC/IrcHooks.pl, IRC/Schedulers.pl, Modules/Debian.pl,
- Modules/News.pl: A round of fixes:
- - added dbReplace but it's broken
- - debian infopackages shows dist
- - news user cache now works properly
- - "+" now works for all commands, not only for factoids
-
-2001-04-07 23:59 dms
-
- * src/Misc.pl: isStale is basically used by Debian.pl and we were using age in terms of
- seconds but the actual function was assuming it was in days - fixed.
-
-2001-04-07 20:07 dms
-
- * src/: modules.pl, IRC/Schedulers.pl: - now backup news file just in case.
- - Other changes we've not documented or small enough not to mention
-
-2001-04-07 20:07 dms
-
- * src/Modules/News.pl: - load file if we enabled option on the fly before re-run.
-
-2001-04-07 20:06 dms
-
- * src/CommandStubs.pl: - we now check if CODEREF exists.
-
-2001-04-07 20:06 dms
-
- * src/UserExtra.pl: - forgot Module for news.
-
-2001-04-07 20:05 dms
-
- * src/core.pl: - write opened files on shutdown/hup
-
-2001-04-06 22:05 dms
-
- * src/Modules/News.pl: When we did a symlink to all the set commands, the string was made
- static (set to "Text") so it was broken.
- also added link from Desc to Text
-
-2001-04-06 21:56 dms
-
- * src/Modules/News.pl: Just some more minor changes, to make some people happy, heh.
-
-2001-04-03 20:06 dms
-
- * src/: DynaConfig.pl, modules.pl, IRC/IrcHooks.pl,
- IRC/Schedulers.pl, Modules/News.pl: More clean ups, forgotten what they were, heh.
-
-2001-04-01 23:25 dms
-
- * src/Modules/News.pl: forgot to add this file, heh.
-
-2001-04-01 23:16 dms
-
- * src/modules.pl: finally nailed this "random" bug noticed by asuffield.
-
-2001-04-01 23:00 dms
-
- * files/blootbot.help: added help for news
-
-2001-04-01 23:00 dms
-
- * src/: Misc.pl, IRC/IrcHooks.pl: Second round of News changes and bug fixes, kudos to greycat
-
-2001-03-31 22:19 dms
-
- * src/: CommandStubs.pl, DynaConfig.pl, Process.pl, UserExtra.pl,
- core.pl, modules.pl, Factoids/Statement.pl, Factoids/Update.pl,
- IRC/Irc.pl, IRC/IrcHooks.pl, IRC/Schedulers.pl, Modules/UserDCC.pl: Many changes, basically added and integrated News, and bug fixes.
- Some more notes:
- CommandStubs.pl - fixed "kernel blah"
- Modules/UserDCC.pl - dont print $user when undefined.
- modules.pl - added News.pl
- Modules/News.pl - new feature.
- Process.pl - "blootbot: ok is <reply> :)" -- FIXED.
-
-2001-02-28 20:17 dms
-
- * src/IRC/Irc.pl: removed msg/say repeating code.
-
-2001-02-28 20:17 dms
-
- * src/Process.pl: don't backup #DEL# factoids. asuffield.
-
-2001-02-28 20:17 dms
-
- * src/Factoids/Question.pl: fix for endless loop. asuffield.
-
-2001-02-28 20:12 dms
-
- * src/IRC/IrcHooks.pl: msgtime updated in on_msg
-
-2001-02-28 20:10 dms
-
- * src/IRC/Schedulers.pl: make dead-connect detection better.
-
-2001-02-23 20:26 dms
-
- * src/CommandStubs.pl: strip trailing whitespaces, force use of quotes to enable trailing
- whitespace. requested by asuffield and \broken?.
-
-2001-02-23 20:25 dms
-
- * src/Process.pl: now use "or" instead of "and" operator for "rename".
-
-2001-02-23 20:24 dms
-
- * src/IRC/Irc.pl: closedcc debug
-
-2001-02-23 20:24 dms
-
- * src/IRC/Schedulers.pl: downlink check update?
-
-2001-02-20 21:01 dms
-
- * src/Factoids/Question.pl: - recursive factoid linking added.
-
-2001-02-20 21:01 dms
-
- * src/IRC/IrcHooks.pl: - lobotomy check in hookMsg
-
-2001-02-20 21:00 dms
-
- * src/Factoids/Update.pl: - reformatted totally
- - added preliminary append-to-linked-factoid support.
- - all return calls now return appropriately.
-
-2001-02-20 21:00 dms
-
- * src/: Misc.pl, UserExtra.pl: - added mkcrypt, fixed up "crypt" cmd.
-
-2001-02-20 20:59 dms
-
- * src/: CommandStubs.pl, core.pl, modules.pl: minor updates, warn fixes, removed comments
-
-2001-02-20 20:59 dms
-
- * src/IRC/Schedulers.pl: - lobotomy cache flush.
- - disable uptime if not loaded.
- - minor output update.
-
-2001-02-20 20:58 dms
-
- * src/Process.pl: - lobotomy warning now cached
- - use &mkcrypt()
-
-2001-02-20 20:58 dms
-
- * src/DynaConfig.pl: - preliminary check of masks in chan for matches.
- - ckpasswd, clean up.
-
-2001-02-20 20:58 dms
-
- * src/Modules/UserDCC.pl: - changed "m" to "n". asu.
- - flush lobotomy cache on "unlobotomy"
- - now use &mkcrypt()
-
-2001-02-17 21:42 dms
-
- * src/IRC/Schedulers.pl: - minor output update.
-
-2001-02-17 21:41 dms
-
- * src/UserExtra.pl: - removed '' from returns
- - preliminary stats for on/off-line time
-
-2001-02-17 21:41 dms
-
- * src/Modules/UserDCC.pl: - ".op" fixed. found by Rev
- - ".-ban" now removes the ban from the chan.
-
-2001-02-17 21:40 dms
-
- * src/IRC/Irc.pl: - sub "op" fixed.
- - added sub "unban"
-
-2001-02-17 21:40 dms
-
- * src/IRC/IrcHooks.pl: - added first time run checks.
- - on/off-line time stats
- - on_join ban now kicks with custom reason.
-
-2001-02-17 21:40 dms
-
- * src/Factoids/Reply.pl: literal update
-
-2001-02-17 21:39 dms
-
- * src/Process.pl: - typo in if statement for "forget" when users
- don't have +r flag. found by Rev
- - added "pass" cmd.
- - added "literal" factoid ask.
-
-2001-02-17 21:36 dms
-
- * src/core.pl: memusage support for open/free/net bsd added. patch from Kuma/Rev
-
-2001-02-13 23:50 dms
-
- * src/core.pl: update version of bot
-
-2001-02-13 23:47 dms
-
- * src/IRC/IrcHooks.pl: make nickserv work on more servers. requested by asuffield
-
-2001-02-13 23:35 dms
-
- * src/IRC/IrcHooks.pl: on-ban reason does not work... added debugging
-
-2001-02-13 23:28 dms
-
- * files/blootbot.help: updates from asuffield@OPN
-
-2001-02-13 23:18 dms
-
- * src/Modules/babel.pl: main:: fixes
-
-2001-02-13 23:04 dms
-
- * src/UserExtra.pl: - 'ascii' updates.
- - hex now honours "allowConv"
- - found by asuffield.
- - redir of a redir fixed.
-
-2001-02-13 22:30 dms
-
- * src/IRC/IrcHooks.pl: added reason on ban.
-
-2001-02-13 22:18 dms
-
- * src/Process.pl: safe delete did not run delFactoid, hah! found by asuffield
-
-2001-02-13 22:07 dms
-
- * src/IRC/Irc.pl: ban fixes.
-
-2001-02-13 22:06 dms
-
- * src/Modules/UserDCC.pl: - moved read-only stuff from DynaConfig to here.
- - added newpass
- - .chpass didn't use arg[0] for user.
-
-2001-02-13 22:03 dms
-
- * src/DynaConfig.pl: - now prevent ".chanset +blah 10"
- - recoded it a bit.
-
-2001-02-13 22:02 dms
-
- * src/IRC/IrcHooks.pl: - use "right way" to get keys from hash by checking if the hash ref
- even exists... perl automatically "creates" this and causes problems
- later on. (perldoc -f exists or defined)
- - anti-repeat should not apply to /msg
- - option to do kick on repeat... preliminary support.
- - casing fixes to DCC CHAT. (reported by Revenge@OPN)
-
-2001-02-13 22:01 dms
-
- * src/IRC/Schedulers.pl: errors from Schedulers (chanlimitcheck) are cached and shown only once.
-
-2001-02-13 22:00 dms
-
- * src/Modules/Factoids.pl: - added support to factstats (requested,requesters) of "total" value.
-
-2001-02-13 21:59 dms
-
- * src/Modules/babel.pl: debugging added
-
-2001-02-13 21:58 dms
-
- * src/Misc.pl: added debian-specific debug to isStale
-
-2001-02-11 22:25 dms
-
- * src/: CommandStubs.pl, Misc.pl, modules.pl, IRC/Schedulers.pl,
- Modules/Debian.pl: remaining stuff... should fix factoids problem I hope
-
-2001-02-10 00:47 dms
-
- * src/Modules/babel.pl: typo
-
-2001-02-10 00:29 dms
-
- * src/core.pl: slight change to ChanConfList to make schedulers work again
-
-2001-02-09 23:02 dms
-
- * src/: IRC/IrcHooks.pl, Process.pl: fixed up ignore code. discovered by debian@OPN
-
-2001-02-09 22:51 dms
-
- * src/IRC/Irc.pl: woops, use while instead of foreach for ircloop
-
-2001-02-09 22:48 dms
-
- * src/: Files.pl, core.pl: use static value for ircservers file
-
-2001-02-09 22:18 dms
-
- * src/core.pl: don't write user/chan file on HUP/restart. confirmed by asuffield
-
-2001-02-09 21:44 dms
-
- * src/Modules/UserDCC.pl: we did a sort() when we should not have for '.sched'
-
-2001-02-09 21:40 dms
-
- * src/CommandStubs.pl: changed FlatArg to ArrayArgs to make more sense. by default, we use flat-args
-
-2001-02-09 21:37 dms
-
- * src/IRC/IrcHooks.pl: forgot to set nuh for on_join; fixed up ban check on join.
-
-2001-02-09 21:23 dms
-
- * src/Process.pl: moved nick lock checking to lock only. detected by irq@OPN
-
-2001-02-09 21:18 dms
-
- * src/IRC/Irc.pl: added debugging info to ircloop... if irc() does not return ever, we'll have to take another approach to do connect-next-server-if-cant-connect
-
-2001-02-09 21:10 dms
-
- * src/UserExtra.pl: substitute the right vars in getReply when used in tell. found by asuffield
-
-2001-02-09 00:02 dms
-
- * src/IRC/IrcHooks.pl: this should fix ignores on global channels. found by 'debian'@OPN
-
-2001-02-08 23:51 dms
-
- * src/IRC/Schedulers.pl: divide by zero fix. thought I fixed it 2 weeks ago
-
-2001-02-08 23:50 dms
-
- * src/IRC/IrcHooks.pl: - pointless regex in on_dcc_chat_open that I was going to deal with on
- failed WHOIS (nuh) lookups... now we just compare against "GETTING-NOW"
- - on_quit debug info much cleaner now.
-
-2001-02-08 22:09 dms
-
- * src/CommandStubs.pl: we did not use flat args for forkers. found by asuffield.
-
-2001-02-08 22:00 dms
-
- * src/CommandStubs.pl: fix delayed task mechanism to verstats... we have to cache chan/nick/msgType.
-
-2001-02-08 21:57 dms
-
- * src/Shm.pl: possible fix for fork crashing and not detecting a crash from parent. warning included
-
-2001-02-08 21:52 dms
-
- * src/IRC/: IrcHooks.pl, Schedulers.pl: chan limit check code should now be disabled/re-enabled in relation to netsplits. discovered by asuffield
-
-2001-02-07 22:12 dms
-
- * src/Modules/UserDCC.pl: - list all schedulers and their respective time-of-next-run
-
-2001-02-07 22:11 dms
-
- * src/IRC/Schedulers.pl: - use CORE::system
-
-2001-02-07 22:11 dms
-
- * src/: Modules/Debian.pl, CommandStubs.pl: - finally (about three times) fixed search for "*bin*ssh*" for example,
- kudos to bod@OPN
- - also make searchDesc return list of packages and searchDescFE to output it.
- - use searchDescFE
-
-2001-02-06 21:10 dms
-
- * src/Modules/Debian.pl: Fixed by swapping dists hash around.
-
-2001-02-06 20:42 dms
-
- * src/Modules/Debian.pl: debugging added.
-
-2001-02-06 20:42 dms
-
- * src/Modules/Topic.pl: ok from "topic -mod" => /msg only!
-
-2001-02-06 20:42 dms
-
- * src/IRC/Schedulers.pl: - added auto backup of user/chan files
- - factoidCheck updates.
- - nick-in-use timer update.
-
-2001-02-06 20:41 dms
-
- * src/: Process.pl, core.pl: - converted %joinverb to %cache
-
-2001-02-06 20:41 dms
-
- * src/UserExtra.pl: - added 'unique user count' to chanstats.
- - wantnick updates
-
-2001-02-06 20:27 dms
-
- * src/IRC/IrcHooks.pl: - on_chat, forgot to set '$who'
- - clean up aswell.
- - converted %jointime to %cache
- - we check limit on each on_join now.
-
-2001-02-06 20:23 dms
-
- * src/DynaConfig.pl: split off chanset from UserDCC to here to do multiple chans
- - look at 1.19->1.20 to see changes
-
-2001-02-06 20:22 dms
-
- * src/Modules/UserDCC.pl: - Moved most of chanset to DynaConfig
- - Should be able to do multiple chans now, like ".chanset #chan1 #chan2
- #chan3 +autojoin"
- - if _default has option and ".chanunset #blah blah" or ".-chan #blah
- blah", set vars on all other channels but remove on the channel
- specific.
- - if '.-chan blah' is done and does not exist on _default, remove
- option from all channels.
- - command to list which chans have option defined/set for.
- - with respective values.
- - ".chanset <value>"
-
-2001-02-06 00:09 dms
-
- * src/Process.pl: final cruft from old static configuration file fixed... found by irq
-
-2001-02-06 00:04 dms
-
- * src/CommandStubs.pl: ok, that failed. lets now set $chan aswell
-
-2001-02-06 00:00 dms
-
- * src/CommandStubs.pl: verstats was using dynamic chan var...
-
-2001-02-05 23:45 dms
-
- * src/IRC/IrcHooks.pl: dont overwrite nuh{} if it already exists.
-
-2001-02-05 23:43 dms
-
- * src/Factoids/: Norm.pl, Question.pl: - remove front/rear whitespaces
- - trailing symbols should work now.
-
-2001-02-05 23:30 dms
-
- * src/IRC/IrcHooks.pl: - endofnames: chanserv ops should work now.
- - store topic irrevelent of setting.
- - call ->whois() if nuh is not found.
-
-2001-02-05 23:29 dms
-
- * src/Modules/UserDCC.pl: - prevent dupe uses of ".+chan"
- - when adding new chan, set autojoin.
-
-2001-02-05 23:29 dms
-
- * src/IRC/Schedulers.pl: - ircCheck => 120 interval.
- - dccStatus now only shows chan info where the dcc chat user is on
- _only_
- - added checking of %dcc hash for nuh hash checking.
-
-2001-02-05 22:32 dms
-
- * src/IRC/Schedulers.pl: defer leakCheck, increase interval.
-
-2001-02-05 22:31 dms
-
- * src/core.pl: comment out debugging
-
-2001-02-05 22:31 dms
-
- * src/IRC/IrcHooks.pl: - fixed when chan (msgType = private) is undefined.
-
-2001-02-04 20:23 dms
-
- * src/IRC/Irc.pl: reconnect if join fails
-
-2001-02-04 20:17 dms
-
- * src/IRC/Irc.pl: - output update
-
-2001-02-04 20:16 dms
-
- * src/IRC/IrcHooks.pl: - if in private, "is addressing" => "is /msg'ing".
- - dccStatus fix ups.
- - use ScheduleThis where possible.
-
-2001-02-04 20:14 dms
-
- * src/IRC/Schedulers.pl: typo for dccStatus fix :)
-
-2001-02-04 20:14 dms
-
- * src/Shm.pl: delForked: warn if name is source file.
-
-2001-02-04 20:13 dms
-
- * src/IRC/Schedulers.pl: - output update.
- - prevent "unknown msg" for shm.
- - typo for dcc hash. fixed.
- - forgot about users,chops,bans define in dccStatus. fixed.
-
-2001-02-04 20:13 dms
-
- * src/CommandStubs.pl: if more than 1/4 users from channel gave version replies, verstats is active.
-
-2001-02-04 20:12 dms
-
- * src/core.pl: remove mem increase from DCC CHAT - annoying.
-
-2001-02-04 00:01 dms
-
- * src/: IRC/Schedulers.pl, Modules/Slashdot3.pl: more configuration crud and not-thinking-correctly design errors
-
-2001-02-03 23:51 dms
-
- * src/UserExtra.pl: added support for old Modules() for telling.
-
-2001-02-03 23:48 dms
-
- * src/Misc.pl: added IsParam back to hasParam together with isChanConf
-
-2001-02-03 23:33 dms
-
- * src/Factoids/Statement.pl: minor typo when fixing this before
-
-2001-02-03 23:21 dms
-
- * src/Modules/Debian.pl: validPackage or indirectly generateIndex should work now for the time being
-
-2001-02-03 23:09 dms
-
- * src/Modules/Debian.pl: woops forgot a few old config vars; converted to new format
-
-2001-02-03 23:06 dms
-
- * src/Modules/Debian.pl: converted to new gCCD
-
-2001-02-03 22:46 dms
-
- * src/Modules/UserDCC.pl: more fixups.
-
-2001-02-03 22:35 dms
-
- * src/Modules/UserDCC.pl: now use delete in place of undef
-
-2001-02-03 22:23 dms
-
- * src/IRC/IrcHooks.pl: looks like the final touches to fully exploit dynamic configuration have been made
-
-2001-02-03 22:10 dms
-
- * src/IRC/IrcHooks.pl: debugging info
-
-2001-02-03 22:06 dms
-
- * src/Process.pl: move identify code before outsider checking
-
-2001-02-03 22:03 dms
-
- * src/: IRC/Irc.pl, IRC/IrcHooks.pl, Misc.pl: - $nuh{} fix up.
- - created on_dcc_open_chat for whois reply to get nuh.
- - getRandomInt - allow decimal.
-
-2001-02-03 20:52 dms
-
- * src/: Shm.pl, IRC/Schedulers.pl: - time stamping added.
- - dead/stale shm removal now works more intelligently.
- However, older code will attempt to hijack and remove it anyway.
- - check debian files with gzip -t.
- - all schedulers should be deferred now.
-
-2001-02-03 20:51 dms
-
- * src/IRC/IrcHooks.pl: don't allow those without HOSTS in the user file to DCC CHAT.
-
-2001-02-03 20:51 dms
-
- * src/Modules/UserDCC.pl: fixed '.chanset' code.
-
-2001-02-03 20:50 dms
-
- * src/IRC/Irc.pl: added _default to chan mask.
-
-2001-02-02 22:03 dms
-
- * src/IRC/Schedulers.pl: I think this is the set of missed old->dynamic config changes that had to be done
-
-2001-02-02 22:03 dms
-
- * src/Modules/UserDCC.pl: compress config params as muc has possible per line
-
-2001-02-02 21:42 dms
-
- * src/core.pl: forgot to initialize counter for Moron
-
-2001-02-02 21:42 dms
-
- * src/Misc.pl: check if int is defined for fixPlural
-
-2001-02-02 21:38 dms
-
- * src/: DynaConfig.pl, Misc.pl, core.pl, modules.pl,
- Factoids/Norm.pl, Factoids/Question.pl, Factoids/Reply.pl,
- Factoids/Update.pl: tiny changes that I've missed
-
-2001-02-02 21:36 dms
-
- * src/IRC/: IrcHooks.pl, Schedulers.pl: temporary ignores can be removed automatically once expired
-
-2001-02-02 21:21 dms
-
- * src/Process.pl: typo for ckpasswd
-
-2001-02-02 21:12 dms
-
- * src/Shm.pl: - if shmRead fails, try openSHM.
-
-2001-02-02 21:12 dms
-
- * src/Process.pl: - fixup for question handling.
-
-2001-02-02 21:12 dms
-
- * src/UserExtra.pl: - tell: command redirection added.
-
-2001-02-02 21:12 dms
-
- * src/Modules/UserDCC.pl: - fix undefined for '.chanset'
- - minor output update to '.bans'
-
-2001-02-02 21:11 dms
-
- * src/DynaConfig.pl: - undefining vars in wrong subs; fixed.
- - fixes reading user/chan files finally, again.
-
-2001-02-02 21:10 dms
-
- * src/: CommandStubs.pl, Modules/babel.pl: - fixes for babelfish
- - typo of IsChanConf for wwwsearch.
- - parseCmdHooks return vals fixed.
- - babel.pl: regex fixed -- works!!!
-
-2001-02-02 21:09 dms
-
- * src/: Modules/RootWarn.pl, Modules/Wingate.pl, IRC/Irc.pl,
- IRC/IrcHooks.pl, IRC/Schedulers.pl: - more fixes to new-style config, should be 99% of it.
- - convert IsParam() to IsChanConf()
- - IRC/IrcHooks.pl: minor output update
- - IRC/Schedulers.pl:
- - minor update.
- - make getChanConfDefault(PARAM,VALUE,CHAN) instead for convenience.
- - temp ignore removal checking loop fixed.
-
-2001-02-01 22:21 dms
-
- * src/core.pl: - write user/chan file in 'shutdown'
-
-2001-02-01 22:18 dms
-
- * src/Modules/UserDCC.pl: - wrong order in .+ignore
- - ".chanset #chan" fixup.
-
-2001-02-01 22:17 dms
-
- * src/IRC/Irc.pl: - getJoinChans, don't add _default
- - joinNextChan() - check nickServ_pass
-
-2001-02-01 22:15 dms
-
- * src/DynaConfig.pl: - prevent /^[+-]/ options being loaded.
- - ignore/ban lists now saved properly.
- - forgot about \+ :-)
- - verifyUser does caching now!
-
-2001-02-01 22:13 dms
-
- * src/IRC/Schedulers.pl: - SC for uptimeCycle
- - renamed *Cycle to *Loop
-
-2001-02-01 22:11 dms
-
- * src/IRC/IrcHooks.pl: - minor output (debug) removed.
- - new config conversion for rootWarn
-
-2001-02-01 22:06 dms
-
- * src/Process.pl: now use pass auth for 'identify'.
-
-2001-02-01 22:05 dms
-
- * src/Modules/Debian.pl: regex support for 'query' in &searchDesc()
-
-2001-01-31 22:53 dms
-
- * src/CommandStubs.pl: nickometer: there could be multiple results with the same version
- percentage - fixed. Also don't merge same percentages together like in
- other list (formListReply) statements.
-
-2001-01-31 22:31 dms
-
- * src/CommandStubs.pl: nickometer and verstats: sort descendingly
- nickometer: fix undefined warning
-
-2001-01-31 21:31 dms
-
- * src/Modules/Debian.pl: make $refresh global in this file... removed all duplicates of getting
- debianRefreshInterval config var.
-
-2001-01-31 21:28 dms
-
- * src/IRC/: Irc.pl, IrcHooks.pl: make $nickserv global and set to zero in Irc.pl
-
-2001-01-31 21:26 dms
-
- * src/Misc.pl: check if $age is NULL in &isStale()
-
-2001-01-31 21:18 dms
-
- * src/core.pl: &ChanConfList() typos
-
-2001-01-31 21:18 dms
-
- * src/Process.pl: added 'identify <PASS> [nick]'
-
-2001-01-31 21:18 dms
-
- * src/IRC/Irc.pl: added retval to &ban()
-
-2001-01-31 21:17 dms
-
- * src/Modules/UserDCC.pl: minor fix for ignoreAdd()
-
-2001-01-31 21:17 dms
-
- * src/DynaConfig.pl: prevent repetion in verifyUser.
-
-2001-01-31 21:17 dms
-
- * src/Modules/Freshmeat.pl: - now use gCCD
-
-2001-01-31 21:17 dms
-
- * src/IRC/IrcHooks.pl: - ignore code cleaned up.
- - ban on join added.
- - added 'b' to &hookMode()'s stats keeping.
-
-2001-01-31 21:16 dms
-
- * src/IRC/Schedulers.pl: - forgot about interval for floodCycle.
- - added nuh{} check to &leakCheck()
- - added chanserv checking to &ircCheck()
-
-2001-01-30 21:19 dms
-
- * src/Modules/Debian.pl: support for new dynamic configuration infrastructure
-
-2001-01-30 20:47 dms
-
- * src/IRC/Schedulers.pl: - typo for already-run check. should work now.
-
-2001-01-30 20:46 dms
-
- * src/Modules/UserDCC.pl: - added '.sched'
-
-2001-01-30 20:46 dms
-
- * src/Misc.pl: - pSReply hack for &help().
-
-2001-01-30 20:46 dms
-
- * src/Process.pl: - typo for return val of &Modules()
-
-2001-01-30 20:46 dms
-
- * src/DynaConfig.pl: - added removal of possible duplicate configuration entries when bot
- exits.
-
-2001-01-30 20:45 dms
-
- * src/: Shm.pl, core.pl, modules.pl, Modules/Uptime.pl: - minor update (output and redundant vars)
-
-2001-01-30 20:44 dms
-
- * src/IRC/IrcHooks.pl: prevent dupes in verstats collection.
-
-2001-01-30 20:44 dms
-
- * src/CommandStubs.pl: - added 'unknown/cloaked' stats item to verstats.
- - nickometer chan code cleanup.
-
-2001-01-29 23:04 dms
-
- * src/CommandStubs.pl: added 'verstats'
-
-2001-01-29 23:03 dms
-
- * src/Misc.pl: - strip ^chars update.
-
-2001-01-29 23:03 dms
-
- * src/IRC/Schedulers.pl: - fixed undefined stuff.
- - put return's in wrong position; fixed.
-
-2001-01-28 22:34 dms
-
- * src/core.pl: removed obsoleted old dyn code
-
-2001-01-28 22:03 dms
-
- * files/sample/sample.config.proposed: - obsoleted... why was it even added in the first place.
-
-2001-01-28 22:02 dms
-
- * ChangeLog, ChangeLog.old: - finally generated ChangeLog from CVS
- - moved old changelog to ChangeLog.old
-
-2001-01-28 22:00 dms
-
- * patches/: Connection.pm, Net::IRC.patch: - removed obsoleted files: it's now done in the bot code.
-
-2001-01-28 21:35 dms
-
- * files/: infobot.help, infobot.ignore, infobot.lang, infobot.lart,
- infobot.randtext, infobot.users, sample.config, sample.countdown,
- sample.insert: - obsoleted files removed
-
-2001-01-28 21:32 dms
-
- * src/: Misc.pl, Process.pl, Shm.pl, db_mysql.pl,
- Factoids/Question.pl, Factoids/Reply.pl, Factoids/Statement.pl,
- Factoids/Update.pl, IRC/Irc.pl, Modules/Debian.pl,
- Modules/DebianExtra.pl, Modules/Dict.pl, Modules/Factoids.pl,
- Modules/Freshmeat.pl, Modules/Kernel.pl, Modules/Quote.pl,
- Modules/Search.pl, Modules/Slashdot3.pl, Modules/Topic.pl,
- Modules/Units.pl, Modules/Uptime.pl, Modules/W3Search.pl,
- Modules/Wingate.pl, Modules/babel.pl, Modules/insult.pl,
- Modules/nickometer.pl: - Remaining files that were changed due to removal of $noreply or
- indirectly caused by the change over to dynamic configuration
-
-2001-01-28 21:15 dms
-
- * src/IRC/Schedulers.pl: - added dccStatus
-
-2001-01-28 21:14 dms
-
- * src/UserExtra.pl: - if - is used before -about, don't tell us about what was told.
- - ignorelist removed.
-
-2001-01-28 21:14 dms
-
- * src/modules.pl: - if core moduels fail to load, exit out properly.
-
-2001-01-28 21:14 dms
-
- * files/blootbot.help: - removed FIXME entries.
- - added several new entries for UserDCC. still incomplete.
-
-2001-01-28 21:13 dms
-
- * files/blootbot.ignore: -REMOVED
-
-2001-01-28 21:12 dms
-
- * src/IRC/IrcHooks.pl: - when someone attempts dcc chat, if verbosity > 1,
- show all info regarding that person.
-
-2001-01-28 21:12 dms
-
- * src/logger.pl: pre-config fix.
-
-2001-01-28 21:11 dms
-
- * src/Modules/UserDCC.pl: - added frontend to dynamic user/chan.
-
- - remove 99% of $noreply. WORKS
- - change 'main::' to '::' WORKS
-
- - ".set" and ".unset" obsoleted. WORKS
- - ".save" WORKS
- - ".chanset #chan +bool" WORKS
- - ".chanset #chan -bool" WORKS
- - ".chanset #chan" WORKS
- - ".chanunset #chan" WORKS
- - ".chanunset #chan WHAT" WORKS
- - ".chpass <user> [pass]" WORKS
- - ".chattr [user] +flag-flag" WORKS
- - ".chnick [user] [new-user]" WORKS
- - ".+host [user] [new mask]" WORKS
- - ".-host [user] [del mask]" WORKS
- - ".+ban [mask] [chan] [time] [reason]" WORKS
- - ".-ban [mask]" WORKS
- - ".whois [user]" WORKS
- - ".bans [chan]" (BOT) WORKS
- - ".banlist" (CHAN) DONE,TODO
- - ".+ignore <mask> [#channel] [time] <comment>" WORKS
- - ".-ignore <mask>" WORKS
- - ".ignore [chan]" WORKS,
- - ".adduser <nick>" DONE,TODO
- - ".deluser <nick>" DONE,TODO
- - ".+user <nick> <hostmask>" WORKS
- - ".-user <nick>" WORKS
- - ".chatset [channel] <setting>" DONE
- - ".+chan <#chan>" WORKS
- - ".-chan <#chan>" WORKS
- - ".chaninfo" WORKS
-
-2001-01-28 21:08 dms
-
- * files/sample/: sample.chan, sample.config, sample.config.example,
- sample.config.proposed, sample.countdown, sample.insert,
- sample.users: - new directory for sample configuration
-
-2001-01-28 21:04 dms
-
- * files/: blootbot.chan, blootbot.users: - NEW style config file.
-
-2001-01-28 21:02 dms
-
- * src/core.pl: - NEW dynamic user/chan stuff.
- - prevent doExit running twice.
- - loadMyModulesNow after chanfile!
- - added IsChanConf() and getChanConfList
-
-2001-01-28 21:00 dms
-
- * src/DynaConfig.pl: - NEW dynamic user/chan stuff.
-
-2001-01-28 20:50 dms
-
- * src/: User.pl, UserFile.pl: - REMOVED FILES.
-
-2001-01-28 20:50 dms
-
- * src/Files.pl: - removed userfile code.
- - removed ignore code.
-
-2001-01-28 20:49 dms
-
- * src/CommandStubs.pl: - aCH: don't remake hook hash.
- - pCH: warn if multiple matches are found.
- - added nickometer for channel.
-
-2001-01-18 21:46 dms
-
- * src/Modules/Debian.pl: ca.d.o does not do non-US any more
-
-2001-01-17 20:22 dms
-
- * src/Modules/Factoids.pl: used \* instead of / for days, founded by fooz
-
-2001-01-15 21:11 dms
-
- * src/Factoids/Update.pl: added checking of NULL rhs just in case.
-
-2001-01-15 21:10 dms
-
- * src/Modules/Factoids.pl: - fix for null factoids in factinfo.
- - added 'factstats nullfactoids'.
-
-2001-01-14 21:04 dms
-
- * src/Modules/Topic.pl: topic info now includes length
-
-2001-01-10 22:57 dms
-
- * src/IRC/Irc.pl: - cosmetic (useless) update.
-
-2001-01-10 22:56 dms
-
- * src/UserExtra.pl: - update to 'cpustats'.
-
-2001-01-10 22:55 dms
-
- * src/Misc.pl: - forgot [] around gettimeofday.
- - select() added before first fork msg.
-
-2001-01-10 22:55 dms
-
- * src/Shm.pl: - minor mods to addForked wrt time.
- - proper detection of dead forks.
-
-2001-01-10 22:54 dms
-
- * src/Modules/Debian.pl: quote typo@18,default==unstable
-
-2001-01-10 22:54 dms
-
- * src/modules.pl: - AUTOLOAD to ignore __
- - use eval on 'require'.
-
-2001-01-06 20:55 dms
-
- * src/Factoids/Reply.pl: - added smart_replace, finally fixed SARs for sure.
- still need to move numeric range replacement into the loop.
-
-2001-01-06 20:54 dms
-
- * src/: Net.pl, Modules/Debian.pl, Modules/Factoids.pl,
- Modules/Freshmeat.pl, Modules/Search.pl: - new time delta function
- - Debian.pl: \Q\E in validPackage
-
-2001-01-06 20:53 dms
-
- * src/IRC/Irc.pl: clearIRCVars update
-
-2001-01-06 20:53 dms
-
- * src/modules.pl: DNS.pl removed.
-
-2001-01-06 20:52 dms
-
- * src/Modules/DNS.pl: Removed this file.
-
-2001-01-06 20:52 dms
-
- * src/: CommandStubs.pl, UserExtra.pl: - more updates.
- - UserExtra.pl: added cpustats
- - CommandStubs: added UserFlag support
-
-2001-01-06 20:51 dms
-
- * src/: Misc.pl, Shm.pl, IRC/IrcHooks.pl: - forker (POSIX::_exit) fixes.
- - Misc.pl: added timedelta(renamed from gettimeofday),timeget.
-
-2001-01-03 21:44 dms
-
- * src/Net.pl: - &system typo.
-
-2001-01-03 21:43 dms
-
- * src/modules.pl: - DESTROY code removed.
-
-2001-01-03 21:42 dms
-
- * src/Misc.pl: - topic minor fix.
- - POSIX::_exit(0) added: fixes fork problem.
-
-2001-01-03 21:42 dms
-
- * src/Factoids/Update.pl: - allow SARing of factoids on _long_ factoids providing the new string
- is shorter than the subst string.
-
-2001-01-03 21:37 dms
-
- * files/blootbot.lang: - moron reply added.
-
-2001-01-03 21:37 dms
-
- * src/Factoids/Reply.pl: - Finally added proper recursive SARs
-
-2001-01-03 21:36 dms
-
- * src/Modules/Factoids.pl: - add 'days' to created_time output.
-
-2001-01-03 21:35 dms
-
- * src/Modules/Debian.pl: - "testing" changes (broken)
- - make search packages case insensitive.
- - non-US fixed... about time.
-
-2001-01-03 21:34 dms
-
- * src/Process.pl: - unified hook changes.
- - ignore >64 questions.
- - support moron language.
-
-2001-01-03 21:33 dms
-
- * src/UserExtra.pl: - start using hooks.
- - added moron counter to 'status'.
-
-2001-01-03 21:32 dms
-
- * src/CommandStubs.pl: - unified for global command hooks
-
-2001-01-03 21:31 dms
-
- * src/IRC/: Irc.pl, IrcHooks.pl: - floodjoinCheck.
- - note on endofmotd.
- - Moved ircstats from Irc.pl to on_endofmotd#IrcHooks.pl
-
-2000-12-29 22:46 dms
-
- * src/Process.pl: for join, ignore whether on a channel if we have power
-
-2000-12-29 22:05 dms
-
- * src/IRC/IrcHooks.pl: lowercase chan in on_kick, found by xsdg!
-
-2000-12-19 21:06 dms
-
- * src/Factoids/Reply.pl: forgot about int() in randnick - found by lunartear
-
-2000-12-18 21:40 dms
-
- * src/core.pl: debug to restart
-
-2000-12-18 21:38 dms
-
- * src/Net.pl: Remove &ERROR() since it's done by WARN.
-
-2000-12-18 21:35 dms
-
- * src/Modules/Debian.pl: stop searching if found>100
-
-2000-12-18 21:33 dms
-
- * src/Process.pl: ignore long unparseable messages.
-
-2000-12-16 20:32 dms
-
- * src/core.pl: hrm
-
-2000-12-16 20:31 dms
-
- * src/modules.pl: minor fix to loadmymodules
-
-2000-12-16 20:31 dms
-
- * LICENSE: - new file for license.
-
-2000-12-16 20:30 dms
-
- * src/Files.pl: userlist display now verbosity>1
-
-2000-12-16 20:30 dms
-
- * src/IRC/IrcHooks.pl: - use dccsay
- - show flags on dcc chat connection.
- - set type on on_dcc*
-
-2000-12-16 20:29 dms
-
- * src/IRC/Irc.pl: - &dccsay() added.
- - &dcc_close() added.
- - use dccsay in performStrictReply()
-
-2000-12-15 23:36 dms
-
- * src/Misc.pl: very nice typo for regex, Angel indirectly found this :)
-
-2000-12-15 22:39 dms
-
- * src/User.pl: forgot to reset userHandle
-
-2000-12-15 22:28 dms
-
- * src/core.pl: forgot about / in tempDir
-
-2000-12-15 22:25 dms
-
- * src/Modules/UserDCC.pl: added '.mode' for Netsnipe
-
-2000-12-12 23:12 dms
-
- * src/core.pl: change ~ to ENV{HOME}
-
-2000-12-11 20:26 dms
-
- * src/IRC/Schedulers.pl: chanlimitcheck: removed netsplit check
-
-2000-12-11 20:24 dms
-
- * src/IRC/IrcHooks.pl: netsplit timer added
-
-2000-12-10 20:55 dms
-
- * src/Shm.pl: &showProc in delForked()
-
-2000-12-10 20:54 dms
-
- * src/IRC/IrcHooks.pl: userHandle now global var
-
-2000-12-10 20:53 dms
-
- * src/User.pl: verifyUser finally fixed
-
-2000-12-10 20:52 dms
-
- * src/core.pl: tempdir fix
-
-2000-12-10 20:51 dms
-
- * src/Modules/: Freshmeat.pl, Kernel.pl, Slashdot3.pl: temp dir unified
-
-2000-12-10 20:49 dms
-
- * src/Modules/Debian.pl: - 'find *bin*ssh*' should work.
- - temp dir unified.
-
-2000-12-10 20:48 dms
-
- * src/Modules/Factoids.pl: - 'seefix' checks for self-redirects and removes if successful.
- - 'deadredir' reject long vals.
- - 'listfix' added.
-
-2000-12-09 21:26 dms
-
- * src/Modules/Topic.pl: removed/convert debug messages
-
-2000-12-09 21:04 dms
-
- * src/IRC/IrcHooks.pl: changed debug to status line
-
-2000-12-09 21:01 dms
-
- * src/IRC/Schedulers.pl: forgot to return for limitcheck + netsplit
-
-2000-12-08 21:09 dms
-
- * src/IRC/Schedulers.pl: renamed limitCheck to chanlimitCheck
-
-2000-12-04 21:31 dms
-
- * src/IRC/Schedulers.pl: Typos galore for logCycle, should be fixed
-
-2000-12-03 21:52 dms
-
- * src/IRC/Schedulers.pl: output cleanup
-
-2000-12-03 21:51 dms
-
- * src/Modules/Debian.pl: fallback on * properly
-
-2000-12-03 21:50 dms
-
- * src/Modules/W3Search.pl: Moved w3 regex here
-
-2000-12-03 21:48 dms
-
- * src/CommandStubs.pl: typo fixed
-
-2000-12-03 21:47 dms
-
- * src/CommandStubs.pl: Removed W3 regex
-
-2000-12-03 21:46 dms
-
- * src/Modules/Factoids.pl: Added 'factstats seefix'
-
-2000-12-03 21:46 dms
-
- * src/Misc.pl: validFactoid.
-
-2000-11-24 22:26 dms
-
- * src/Modules/Debian.pl: Contents for non-US is broken!
-
-2000-11-24 22:02 dms
-
- * src/Modules/Debian.pl: typo
-
-2000-11-24 20:23 dms
-
- * src/Misc.pl: - validFactoid.
- - fixString
-
-2000-11-24 20:17 dms
-
- * src/Modules/Freshmeat.pl: - prevent dupe errors.
- - support bz2/gz for appindex.
-
-2000-11-24 20:10 dms
-
- * src/Shm.pl: if name undefined, bail out
-
-2000-11-24 20:07 dms
-
- * src/modules.pl: use modulebase instead of modulefile for delForked()
-
-2000-11-23 23:10 dms
-
- * src/CommandStubs.pl: made freshmeat fork always
-
-2000-11-23 22:53 dms
-
- * src/Modules/Freshmeat.pl: changed core to www
-
-2000-11-23 22:22 dms
-
- * src/CommandStubs.pl: @args changed to flat
-
-2000-11-23 22:21 dms
-
- * src/: Misc.pl, Net.pl: debug messages removed
-
-2000-11-23 22:21 dms
-
- * src/Modules/Debian.pl: more cleanups. ^blah and blah$ workspico Debian.pl!
-
-2000-11-19 22:56 dms
-
- * src/Modules/Debian.pl: debug
-
-2000-11-19 22:56 dms
-
- * src/modules.pl: use AUTOLOAD to prevent crashes
-
-2000-11-19 22:55 dms
-
- * src/Net.pl: Reduced timeout by 10x
-
-2000-11-19 22:54 dms
-
- * src/UserExtra.pl: Fixed up tell to allow target == 'us'.
-
-2000-11-19 22:49 dms
-
- * src/IRC/IrcHooks.pl: Exit process if on_public hook is activated under fork
-
-2000-11-01 21:59 dms
-
- * src/UserExtra.pl: - fixed up tell.
- - 'cycle' changed a bit.
-
-2000-11-01 21:55 dms
-
- * src/IRC/Irc.pl: debug msg for mixed-case chan
-
-2000-11-01 21:54 dms
-
- * src/IRC/Schedulers.pl: - make sure we reschedule everything unless it's a non-recoverable error.
- - disable limit if split active in limitcheck.
- - enabled 'unlink' in logcycle.
-
-2000-10-04 00:08 dms
-
- * src/CommandStubs.pl: - we shifted args before using args[0]. fixed.
- - fixed broken 'convert' cmd.
-
-2000-10-03 01:33 dms
-
- * src/core.pl: version update
-
-2000-10-03 01:29 dms
-
- * src/modules.pl: minor change to reloadModule
-
-2000-10-03 01:26 dms
-
- * src/db_mysql.pl: added sth->finish in an attempt to prevent leaks
-
-2000-10-03 01:26 dms
-
- * src/CommandStubs.pl: alias to fm for freshmeat forgotten
-
-2000-10-03 01:23 dms
-
- * src/db_dbm.pl: minor update
-
-2000-10-03 01:20 dms
-
- * src/Modules/Freshmeat.pl: cleanup of comments
-
-2000-10-03 01:19 dms
-
- * src/IRC/Irc.pl: change timeout value for scheduler interval
-
-2000-10-03 01:12 dms
-
- * src/IRC/IrcHooks.pl: fixed - typo for join()
-
-2000-09-29 23:39 dms
-
- * src/CommandStubs.pl: tiny cleanup
-
-2000-09-29 23:10 dms
-
- * src/Modules/UserDCC.pl: Minor cleanup
-
-2000-09-29 23:03 dms
-
- * src/IRC/IrcHooks.pl: DCC fixed
-
-2000-09-25 20:08 dms
-
- * src/IRC/Irc.pl: fixed up performReply to be more intelligent
- when doing random stuff.
-
-2000-09-25 20:07 dms
-
- * src/Factoids/Question.pl: notfound uses @query now; removed origQuery
-
-2000-09-25 00:20 dms
-
- * src/logger.pl: close log then statuspico logger.pl!
-
-2000-09-24 19:53 dms
-
- * src/CommandStubs.pl: more changes
-
-2000-09-24 19:51 dms
-
- * src/Modules/Dict.pl: moved a few lines from CommandStubs.pl here
-
-2000-09-24 19:50 dms
-
- * src/Factoids/Question.pl: added 'debianForFactoid'.
- fixed question 'you suck'. found by cerb.
-
-2000-09-24 19:49 dms
-
- * src/core.pl: forgot 'next' in dir check
-
-2000-09-23 22:18 dms
-
- * scripts/setup_sql.pl: closed 114944 -- karma can't be a negative int
-
-2000-09-23 22:15 dms
-
- * src/core.pl: added check for dirs on startup
-
-2000-09-23 22:12 dms
-
- * src/Modules/Slashdot3.pl: moved temp dir check to core.pl
-
-2000-09-23 20:46 dms
-
- * src/Modules/Freshmeat.pl: removed some debug lines
-
-2000-09-23 20:45 dms
-
- * src/modules.pl: fixed up return vals for loadMyModule()
-
-2000-09-23 20:45 dms
-
- * src/Modules/RootWarn.pl: non-mysql stub
-
-2000-09-23 20:44 dms
-
- * src/CommandStubs.pl: more conversion to new code
-
-2000-09-23 20:43 dms
-
- * src/IRC/Schedulers.pl: one too many parens for seen stats; cleanup.
-
-2000-09-23 20:30 dms
-
- * src/logger.pl: repeat throttling added
-
-2000-09-22 19:56 dms
-
- * src/Modules/Debian.pl: minor update
-
-2000-09-22 19:56 dms
-
- * src/CommandStubs.pl: moved more functions to new hook scheme
-
-2000-09-22 19:55 dms
-
- * src/Shm.pl: forgot shmFlush() in closeSHM()
-
-2000-09-22 18:51 dms
-
- * files/sample.config: 'undelete' option
-
-2000-09-22 18:50 dms
-
- * src/IRC/Schedulers.pl: periodically check to delete deleted factoids
-
-2000-09-22 18:49 dms
-
- * src/Process.pl: added undelete command
-
-2000-09-22 18:49 dms
-
- * src/Files.pl: removed some verbosity.
-
-2000-09-22 18:48 dms
-
- * src/modules.pl: verbose on reload (time ago, delta time)
-
-2000-09-18 21:37 dms
-
- * src/IRC/Irc.pl: op (mode) does not work?
-
-2000-09-18 20:01 dms
-
- * src/Modules/Debian.pl: typo for searchDesc list element
-
-2000-09-18 19:47 dms
-
- * src/Misc.pl: minor text cleanup.
- removed checkPing.
-
-2000-09-18 19:47 dms
-
- * src/CommandStubs.pl: minor cleanup.
- Preliminary command hooks (event handlers) working!
-
-2000-09-18 19:46 dms
-
- * src/IRC/Schedulers.pl: Chanserv 2nd stage fail protection
- Added seen stats.
-
-2000-09-18 19:45 dms
-
- * src/Modules/Debian.pl: Added NULL check for &search*();
- Added stubs for archived revisions.
-
-2000-09-18 19:44 dms
-
- * src/Factoids/Question.pl: Trailing symbols (.!) ignored on question
- Founded by Flugh
-
-2000-09-18 19:43 dms
-
- * src/db_mysql.pl: sqldebug clean up; forgot a return line for GetCol
-
-2000-09-18 19:37 dms
-
- * src/IRC/Irc.pl: chanserv update to &joinNextChan()
-
-2000-09-18 19:36 dms
-
- * src/IRC/IrcHooks.pl: minor update
-
-2000-09-18 19:34 dms
-
- * src/User.pl: removed repetitive debug line
-
-2000-09-18 19:30 dms
-
- * src/Process.pl: removed feedback addressing. Issue raised by Flugh
-
-2000-09-16 22:12 dms
-
- * src/CommandStubs.pl: added ddesc for desc search
-
-2000-09-16 22:11 dms
-
- * src/Modules/Debian.pl: added &searchDesc() if &searchContents() fails
-
-2000-09-16 22:10 dms
-
- * src/IRC/Schedulers.pl: added NULL irc channel check
-
-2000-09-16 22:09 dms
-
- * src/core.pl: removed loggingstatus
-
-2000-09-16 21:57 dms
-
- * src/logger.pl: &status() changes. removed loggingstatus in favour of fileno().
-
-2000-09-16 21:23 dms
-
- * scripts/setup_sql.pl: another attempt for a fix
-
-2000-09-14 21:29 dms
-
- * scripts/: setup_sql.pl, setup_tables.pl, setup_users.pl: script merge, doc update
-
-2000-09-14 20:13 dms
-
- * src/: Files.pl, UserFile.pl, Modules/UserDCC.pl: status() -> &status()
-
-2000-09-14 20:12 dms
-
- * src/IRC/IrcHooks.pl: minor text fixup for umode
-
-2000-09-14 20:11 dms
-
- * src/IRC/Schedulers.pl: Added miscCheck(), now does reloadAllModules()
-
-2000-09-14 20:07 dms
-
- * src/modules.pl: ability to reload extra modules automatically
-
-2000-09-14 00:39 dms
-
- * src/Modules/Debian.pl: another installed-size prob fix
-
-2000-09-13 22:18 dms
-
- * src/Factoids/Reply.pl: Removed FIXME
-
-2000-09-13 22:07 dms
-
- * src/Misc.pl: stat used wrong time, [8] instead of [9]
-
-2000-09-13 22:03 dms
-
- * src/Misc.pl: changed some text, more debugging
-
-2000-09-13 22:02 dms
-
- * src/Modules/Debian.pl: hopefully last time it will be fixed
-
-2000-09-13 21:39 dms
-
- * src/Modules/Freshmeat.pl: forgot about blootbot_pid
-
-2000-09-13 21:38 dms
-
- * src/Modules/Debian.pl: non-us fixed!
-
-2000-09-13 21:36 dms
-
- * src/modules.pl: removed two debugging lines or so
-
-2000-09-13 21:19 dms
-
- * src/Modules/Debian.pl: Removed fixNonUS; added a hack for no contents file for woody non-US i386 at least.
-
-2000-09-13 21:03 dms
-
- * src/core.pl: bot: spit out memory change messages in DCC CHAT. TODO: DCCBroadcast should allow userflag arg.
-
-2000-09-12 23:33 dms
-
- * src/Modules/Topic.pl: Another regex topic fix
-
-2000-09-12 23:12 dms
-
- * src/db_mysql.pl: Fixed up stub dbGetRowInfo
-
-2000-09-10 22:40 dms
-
- * src/logger.pl: was opening sql debug file for read, not write. typo
-
-2000-09-10 01:09 dms
-
- * src/IRC/Schedulers.pl: changed verb level from 2 to 1 for seenFlush
-
-2000-09-10 00:36 dms
-
- * src/IRC/Schedulers.pl: debug for seenflush
-
-2000-09-10 00:30 dms
-
- * files/sample.config: SQLDebug line
-
-2000-09-10 00:28 dms
-
- * src/modules.pl: forgot to set module age if successfully loaded. split reloadModules into reloadAllModules and reloadModule. &reloadModule() now called by loadMyModule()
-
-2000-09-10 00:24 dms
-
- * src/logger.pl: supressed subroutine redefined warning. Added sql debug support (open/close)
-
-2000-09-10 00:19 dms
-
- * src/db_mysql.pl: Added sql debug support (print)
-
-2000-09-10 00:16 dms
-
- * src/Modules/UserDCC.pl: fixed/added global factoid SAR
-
-2000-09-09 22:41 dms
-
- * src/Modules/Topic.pl: fixed regex line, founded by Flugh
-
-2000-09-06 23:00 dms
-
- * src/Factoids/Update.pl: minor change
-
-2000-09-06 22:59 dms
-
- * src/logger.pl: 'use strict' issue
-
-2000-09-06 22:57 dms
-
- * src/Modules/UserDCC.pl: global SAR. only avail to +n and DCC.
-
-2000-09-06 22:56 dms
-
- * src/core.pl: fixed due to changes. (re: Flugh)
-
-2000-09-05 23:47 dms
-
- * scripts/: dbm2mysql.pl, mysql2txt.pl, setup_tables.pl,
- setup_users.pl, txt2mysql.pl: forgot to update these files in the root dir overhaul
-
-2000-09-05 01:55 dms
-
- * scripts/setup_users.pl: fixed up a bit
-
-2000-09-05 01:28 dms
-
- * src/logger.pl: stupid typo (carelessness) on my behalf
-
-2000-09-01 22:21 dms
-
- * src/UserExtra.pl: debug info for ircstats hash list
-
-2000-09-01 22:19 dms
-
- * src/IRC/IrcHooks.pl: added disconnect and connect stats, just debug info for now
-
-2000-09-01 21:18 dms
-
- * src/Modules/Topic.pl: prevent dupes to be added; added debugging info if bot is not permitted to add topics (+t/-o).
-
-2000-09-01 20:58 dms
-
- * src/IRC/Schedulers.pl: ircCheck now checks @joinchan for chans left to join, but should never happen.
-
-2000-09-01 20:56 dms
-
- * src/Modules/Debian.pl: debian: fixed broken files for woody's non-US
-
-2000-08-31 22:45 dms
-
- * src/CommandStubs.pl: lame warning fix for babel
-
-2000-08-31 22:41 dms
-
- * src/logger.pl: forgot a )
-
-2000-08-30 21:33 dms
-
- * src/Modules/Uptime.pl: Added catch just in case if forked
-
-2000-08-30 21:14 dms
-
- * src/Shm.pl: changes due to Debian.pl
-
-2000-08-30 21:12 dms
-
- * src/Modules/Debian.pl: minor changes, removed 'slink', changed 'stable' for 'potato'
-
-2000-08-30 21:09 dms
-
- * src/Factoids/Update.pl: added debugging info for '.,' and '.,' problems
-
-2000-08-30 20:42 dms
-
- * src/logger.pl: added $forkedtime, for debugging
-
-2000-08-30 20:19 dms
-
- * src/CommandStubs.pl: preliminary command hook support added
-
-2000-08-20 22:17 dms
-
- * src/Modules/UserDCC.pl: closed 17554 -- re-add part/leave to DCC CHAT only
-
-2000-08-20 21:58 dms
-
- * src/Modules/Debian.pl: we don't stop if debianDownload fails unless none of the files exist locally
-
-2000-08-20 21:46 dms
-
- * src/Modules/Debian.pl: shouldn't recursively call sP
-
-2000-08-20 21:33 dms
-
- * src/Misc.pl: double fork -> VERB(2), minor cosmetics
-
-2000-08-20 21:28 dms
-
- * src/IRC/IrcHooks.pl: if statement of seen swapped. DCC CHAT close ignored if forked.
-
-2000-08-20 21:25 dms
-
- * src/Factoids/Reply.pl: added randnick
-
-2000-08-20 21:24 dms
-
- * src/Modules/Debian.pl: check for stality in sP()
-
-2000-08-19 20:10 dms
-
- * files/sample.config: closed 17225 -- result of fixed bug
-
-2000-08-19 19:24 dms
-
- * src/: User.pl, IRC/IrcHooks.pl: closed 17225 -- seen only stores addressed messages. Also moved seen code from User.pl to IrcHooks.pl
-
-2000-08-19 18:44 dms
-
- * src/Modules/Topic.pl: closed 17447 -- 'topic info' should give more info
-
-2000-08-15 19:27 dms
-
- * src/Misc.pl: warning (typo) fixed
-
-2000-08-15 19:26 dms
-
- * files/sample.config: deprecated weather option/feature removed
-
-2000-08-15 19:24 dms
-
- * src/IRC/Schedulers.pl: ircCheck(): added full path for ipcs,ipcrm
-
-2000-08-15 19:21 dms
-
- * src/IRC/IrcHooks.pl: on_disconnect schedules ircCheck*( for 1800s
-
-2000-08-12 20:45 dms
-
- * src/UserExtra.pl: don't prevent wantnick from working in any case
-
-2000-08-12 20:43 dms
-
- * src/IRC/Schedulers.pl: Added getNickInUse()
-
-2000-08-12 20:42 dms
-
- * src/IRC/IrcHooks.pl: on_nick_taken calls getNickInUse() now
-
-2000-08-12 20:41 dms
-
- * src/logger.pl: use getPath() for create logdir for openLog()
-
-2000-08-12 20:38 dms
-
- * src/Misc.pl: typo for file in loadHelp() ... added getPath() for openLog()
-
-2000-08-11 21:28 dms
-
- * src/Factoids/Update.pl: closed 17031 -- Fix up appending to factoids
-
-2000-08-11 21:21 dms
-
- * src/Factoids/: Reply.pl, Update.pl: closed 17187 -- <factoid> are also <info>' doesn't work... also removed mailto:
-
-2000-08-11 21:10 dms
-
- * src/Modules/Math.pl: closed 17344 -- Maths.pl is borked in a way
-
-2000-08-11 20:53 dms
-
- * src/IRC/IrcHooks.pl: close 17091 completely... fix up on_nick IRC hook
-
-2000-08-11 20:48 dms
-
- * src/IRC/Schedulers.pl: closed 17091 -- chaninfo stats inconsistent after time
-
-2000-08-11 20:11 dms
-
- * src/modules.pl: Fixed problem with loadMyModules() caused by delForked()
-
-2000-08-11 20:10 dms
-
- * src/Modules/W3Search.pl: closed 17379 -- W3Search.pl gives duplicate output
-
-2000-08-04 23:19 dms
-
- * src/Factoids/Statement.pl: at -> mailto remnants from stock infobot removed
-
-2000-08-03 22:19 dms
-
- * src/logger.pl: status did not print output if config file was not loaded. Fixed by initializing VERBOSITY to 1
-
-2000-08-03 22:11 gmlb
-
- * INSTALL.patches: Readme update.
-
-2000-08-03 21:53 dms
-
- * src/Modules/Kernel.pl: forgot about blootbot -> bot
-
-2000-08-03 01:04 gmlb
-
- * INSTALL.mysql, INSTALL: Fixed some documentation typOs. (in the install docs)
-
-2000-08-01 21:41 dms
-
- * src/CommandStubs.pl: userinfo had wrong argument # set
-
-2000-07-31 22:57 gmlb
-
- * infobot:
- Removed old infobot. We are now using blootbot as the main script
-
-2000-07-31 22:37 dms
-
- * src/: IRC/Irc.pl, IRC/IrcHooks.pl, IRC/Schedulers.pl,
- Modules/Countdown.pl, Modules/Factoids.pl, Modules/Freshmeat.pl,
- Modules/Kernel.pl, Modules/Units.pl, Modules/Uptime.pl,
- Modules/Wingate.pl, Modules/babel.pl: cvs commit borked, continuing
-
-2000-07-31 22:31 dms
-
- * AUTHORS, INSTALL, README, blootbot, doc/old/TODO,
- files/blootbot.help, files/blootbot.ignore, files/blootbot.lang,
- files/blootbot.lart, files/blootbot.randtext, files/blootbot.users,
- files/ircII.servers, files/sample.config, scripts/botchk.sh,
- scripts/dbm2mysql.pl, scripts/insertDB.pl, scripts/mysql2txt.pl,
- scripts/setup_tables.pl, scripts/setup_users.pl,
- scripts/txt2mysql.pl, src/Misc.pl, src/Process.pl, src/core.pl,
- src/modules.pl, src/Factoids/Question.pl, src/Factoids/Reply.pl,
- src/Factoids/Statement.pl, src/Factoids/Update.pl: Changed $infobot_ to $bot_
- Changed infobot to blootbot where needed
- Renamed *infobot* to *blootbot*
-
-2000-07-31 20:47 dms
-
- * src/logger.pl: Added functionality to cycle all logs if exceeds specified size
-
-2000-07-31 20:33 dms
-
- * src/: CommandStubs.pl, UserExtra.pl, Modules/Topic.pl: changed NOREPLY to dollar noreply
-
-2000-07-31 20:10 dms
-
- * src/Modules/UserDCC.pl: send DCC message when using 'op'
-
-2000-07-30 08:33 gmlb
-
- * doc/README_TODO: Added README_TODO. It contains important info on the TODO list. READ!
-
-2000-07-30 08:01 gmlb
-
- * doc/: BUGS, Connection.pm, EXAMPLES, FAQ, Google.pm, TODO, USAGE,
- mysql.txt, notes.txt, pgsql.txt: Removing old doucments in /doc. They are archived in /doc/old. The newest documents will be on the website. See /doc/README_NOW for more information.
-
-2000-07-30 07:56 gmlb
-
- * doc/old/: BUGS, Connection.pm, EXAMPLES, FAQ, Google.pm, TODO,
- USAGE, mysql.txt, notes.txt, pgsql.txt: Moving documentation to /doc/old
-
-2000-07-30 07:51 gmlb
-
- * doc/README_NOW: Adding README_NOW. Please read it, as it contains very important DOC information
-
-2000-07-30 07:02 blootbot
-
- * AUTHORS: Updated personal info in AUTHORS file. Must talk to XK about title :)
-
-2000-07-30 00:11 dms
-
- * AUTHORS, patches/Connection.pm, patches/Google.pm: new/moved files
-
-2000-07-30 00:09 dms
-
- * INSTALL.patches, README, doc/USAGE, doc/modules.txt,
- files/sample.config, scripts/backup_table-slave.pl, src/Files.pl,
- src/Misc.pl, src/Net.pl, src/Shm.pl, src/UserExtra.pl, src/core.pl,
- src/db_dbm.pl, src/db_mysql.pl, src/db_pgsql.pl, src/logger.pl,
- src/modules.pl, src/Factoids/DBCommon.pl, src/Factoids/Update.pl,
- src/IRC/Irc.pl, src/IRC/IrcHooks.pl, src/IRC/Schedulers.pl,
- src/Modules/Countdown.pl, src/Modules/Debian.pl,
- src/Modules/DebianExtra.pl, src/Modules/Dict.pl,
- src/Modules/DumpVars.pl, src/Modules/Factoids.pl,
- src/Modules/Freshmeat.pl, src/Modules/Kernel.pl,
- src/Modules/RootWarn.pl, src/Modules/Slashdot3.pl,
- src/Modules/Topic.pl, src/Modules/Uptime.pl,
- src/Modules/UserDCC.pl, src/Modules/UserInfo.pl,
- src/Modules/Wingate.pl: changed email address
-
-2000-07-28 23:26 dms
-
- * files/infobot.config, files/sample.config, src/core.pl: loadConfig to spurt out correct message when infobot.config does not exist on fresh install
-
-2000-07-28 23:11 dms
-
- * MrInfo.uptime: delete stale files not needed for fresh installation
-
-2000-07-28 00:59 blootbot
-
- * ChangeLog: Added a line to ChangeLog. I hope to keep this more uptodate and start documentatio. -GmLB
-
-2000-07-28 00:10 blootbot
-
- * INSTALL, INSTALL.dbm, INSTALL.mysql, INSTALL.patches,
- INSTALL.pgsql, README, infobot, ChangeLog, MrInfo.uptime, doc/BUGS,
- doc/Connection.pm, doc/EXAMPLES, doc/FAQ, doc/Google.pm, doc/TODO,
- doc/USAGE, doc/modules.txt, doc/mysql.txt, doc/notes.txt,
- doc/pgsql.txt, files/infobot.config, files/infobot.help,
- files/infobot.ignore, files/infobot.lart, files/infobot.users,
- files/ircII.servers, files/sample.countdown,
- patches/Net::IRC.patch, patches/WWW::Search.patch,
- scripts/backup_table-master.sh, scripts/backup_table-slave.pl,
- scripts/botchk.sh, scripts/dbm2mysql.pl, scripts/dbm2txt.pl,
- scripts/fixbadchars.pl, scripts/insertDB.pl, scripts/makepasswd,
- scripts/mysql2txt.pl, scripts/oreilly_dumpvar.pl,
- scripts/oreilly_prettyp.pl, scripts/parse_warn.pl,
- scripts/setup_tables.pl, scripts/setup_users.pl,
- scripts/showvars.pl, scripts/txt2mysql.pl, scripts/vartree.pl,
- scripts/webbackup.pl, files/infobot.randtext, files/infobot.lang,
- files/sample.config, files/sample.insert, files/unittab,
- src/CommandStubs.pl, src/Files.pl, src/Misc.pl, src/Net.pl,
- src/Process.pl, src/Shm.pl, src/User.pl, src/UserExtra.pl,
- src/core.pl, src/db_dbm.pl, src/db_mysql.pl, src/db_pgsql.pl,
- src/interface.pl, src/logger.pl, src/modules.pl, src/IRC/Irc.pl,
- src/IRC/IrcHooks.pl, src/IRC/Schedulers.pl,
- src/Modules/Countdown.pl, src/Modules/DNS.pl,
- src/Modules/Debian.pl, src/Modules/Dict.pl,
- src/Modules/Freshmeat.pl, src/Modules/Kernel.pl,
- src/Modules/Quote.pl, src/Modules/RootWarn.pl,
- src/Modules/Search.pl, src/Modules/Slashdot3.pl,
- src/Modules/Topic.pl, src/Modules/Units.pl, src/Modules/Uptime.pl,
- src/Modules/UserInfo.pl, src/Modules/W3Search.pl,
- src/Factoids/DBCommon.pl, src/Factoids/Norm.pl,
- src/Factoids/Question.pl, src/Factoids/Reply.pl,
- src/Factoids/Statement.pl, src/Factoids/Update.pl,
- src/Modules/DebianExtra.pl, src/Modules/DumpVars.pl,
- src/Modules/Factoids.pl, src/Modules/Math.pl,
- src/Modules/UserDCC.pl, src/Modules/Wingate.pl,
- src/Modules/babel.pl, src/Modules/insult.pl,
- src/Modules/nickometer.pl:
- Trying to add 1.0.0. I hope it works. --GmLB
-
-2000-07-28 00:10 blootbot
-
- * INSTALL, INSTALL.dbm, INSTALL.mysql, INSTALL.patches,
- INSTALL.pgsql, README, infobot, ChangeLog, MrInfo.uptime, doc/BUGS,
- doc/Connection.pm, doc/EXAMPLES, doc/FAQ, doc/Google.pm, doc/TODO,
- doc/USAGE, doc/modules.txt, doc/mysql.txt, doc/notes.txt,
- doc/pgsql.txt, files/infobot.config, files/infobot.help,
- files/infobot.ignore, files/infobot.lart, files/infobot.users,
- files/ircII.servers, files/sample.countdown,
- patches/Net::IRC.patch, patches/WWW::Search.patch,
- scripts/backup_table-master.sh, scripts/backup_table-slave.pl,
- scripts/botchk.sh, scripts/dbm2mysql.pl, scripts/dbm2txt.pl,
- scripts/fixbadchars.pl, scripts/insertDB.pl, scripts/makepasswd,
- scripts/mysql2txt.pl, scripts/oreilly_dumpvar.pl,
- scripts/oreilly_prettyp.pl, scripts/parse_warn.pl,
- scripts/setup_tables.pl, scripts/setup_users.pl,
- scripts/showvars.pl, scripts/txt2mysql.pl, scripts/vartree.pl,
- scripts/webbackup.pl, files/infobot.randtext, files/infobot.lang,
- files/sample.config, files/sample.insert, files/unittab,
- src/CommandStubs.pl, src/Files.pl, src/Misc.pl, src/Net.pl,
- src/Process.pl, src/Shm.pl, src/User.pl, src/UserExtra.pl,
- src/core.pl, src/db_dbm.pl, src/db_mysql.pl, src/db_pgsql.pl,
- src/interface.pl, src/logger.pl, src/modules.pl, src/IRC/Irc.pl,
- src/IRC/IrcHooks.pl, src/IRC/Schedulers.pl,
- src/Modules/Countdown.pl, src/Modules/DNS.pl,
- src/Modules/Debian.pl, src/Modules/Dict.pl,
- src/Modules/Freshmeat.pl, src/Modules/Kernel.pl,
- src/Modules/Quote.pl, src/Modules/RootWarn.pl,
- src/Modules/Search.pl, src/Modules/Slashdot3.pl,
- src/Modules/Topic.pl, src/Modules/Units.pl, src/Modules/Uptime.pl,
- src/Modules/UserInfo.pl, src/Modules/W3Search.pl,
- src/Factoids/DBCommon.pl, src/Factoids/Norm.pl,
- src/Factoids/Question.pl, src/Factoids/Reply.pl,
- src/Factoids/Statement.pl, src/Factoids/Update.pl,
- src/Modules/DebianExtra.pl, src/Modules/DumpVars.pl,
- src/Modules/Factoids.pl, src/Modules/Math.pl,
- src/Modules/UserDCC.pl, src/Modules/Wingate.pl,
- src/Modules/babel.pl, src/Modules/insult.pl,
- src/Modules/nickometer.pl: Initial revision
-
-v1.0.0 (20000725): bug fixes mainly.
- - GmLB found that scripts/setup_*.pl didn't work. Fixed.
- - Fixed warning in Modules/Uptime.pl for clean install.
- - More fixes for scripts/*mysql*.pl from GmLB.
- - Added command 'hex'.
- - GmLB fixed mysql2txt.pl and txt2mysql.pl. You can now import and
- export to inforbot 'factpacks'.-
-
-v1.0.0RC3 (20000720): bug fixes mainly.
- - Debian.pl's infoPackages() now checks for incoming
- automatically and shows the new file.
- - irq/dan found the bot wouldn't run if a stale (invalid) pid
- file exists. Fixed.
- - Created &closeDCC(), &closePID()
- - Added factoid SAR of (3-123) => 53
-
-v1.0.0RC2 (20000707):
- - Ported back Berkerley DBM support. 95% of it works :)
- - Also added pgSQL support. Will not work out-of-the-box.
- - Updated README.
- - Fixed up 'modules.pl' a bit so if anything fails, it exits
- gracefully. Module reloading should work better now.
- - DCC CHAT commands now must have '.' prepended otherwise all text
- will me broadcasted to the dcc chat arena.
- - Removed command 'part'. Use 'kick' instead :)
- - 'random|cookie' now takes argument to narrow down randomness.
- - Merged 90% of MbM's@OPN modifications. Thanks.
- => bug fixes here and there
- => 'tell' fixed.
- => checks for owner of factoids for delete/modify factoids
- - Moved Factoids/db* to .
- - Misc stuff here and there.
-
-v1.0.0RC1 (20000701):
- - Added several hacks (run away fork) due to bot misbehaving.
- - Added deop.
- - Added ability to disable factoid support.
- - Reorganized source tree to be more modular.
- - Created dirs: IRC, Factoids.
- - moved partial core.pl and PerlMod.pl to modules.pl
- - renamed Modules.pl to CommandStubs.pl
- - Added command 'cycle'.
- - hardguy/max noted that insult was borked. It wasn't converted
- to the new fork format. Fixed but untested.
- - Added 'ircstats' command. forgot about DisconnectReason
- - Added to-expire-time on 'ignorelist'
- - Forgot to clear %ignoreList on loading the list.
- - moved 'ignorelist' from DCC-only to public/private msg.
-
-v1.0.0pre11 (20000601):
- - we call &ircloop() if we want to reconnect. Any harm to perl?
- - Wingate fixed yet again. maximum time for response is 6secs in
- order to cache maximum number of hosts.
- - Added ban() for Wingate.
- - Forgot about virtual host support when changed over to Net::IRC
- - process() still calls shmCycle() just in case.
- - Added limit to how many random things we can have in a factoid
- to prevent endless loops from occurring.
- - All debian stuff now fully forks -- good.
- - Failure on &loadMyModule() now deletes $forked{$label}.
- - if instructed to join a channel "manually", tell who did it on
- join.
- - Debian module now searches woody's non-US properly. Misc fixes
- here and there.
- - Removed non-working mysql table locking code.
- - Freshmeat.pl now uses LWP::Simple's getstore. How to load the
- file on-the-fly?
- - Looked at Modules-Reload and implemented idea in the bot.
- - Forgot about flushing uptime in scheduler.
- - Added unit conversion feature to bot, based on Units-Convert
- package (at CPAN).
- - Converted several scalars to hashes.
- - Added slashdot,freshmeat and kernel announcements of new stuff.
- - merged chanstats into one line, added top msg stats.
- - Wingate now does intelligent on-the-fly caching and flushing to
- a wingate file to prevent dupes. UNTESTED
- - "find pident potato" now works after few mods/hacks :)
- - ...
-
-v1.0.0pre10 (20000523):
- - Fixed minor problems in Debian.pl, I hope.
- => DebianDownload now calls generateIndex() if a download is
- successful.
- => More clean ups.
- => generateIncoming() forgot about checking stale of idxfile.
- - Modules in Modules/* now dynamically loaded. Using about ~200k
- less ram now.
- - Added support of user modes with param{ircUMODE}. Requested by
- Flugh.
- - hookMsg modified, we don't check ignore list if we're not
- addressed or minvollength is defined. flooding is now
- configurable by repeated message and total message, expire time
- and count, like eggdrop.
- - nickometer didn't reset the score. noticed by greycat+others.
- - &setupScheduler() scheduler is only called once.
- - UIS now supports proper locking and lock check.
- - verifyUser didn't set userHandle to 'default' if not found.
- - Added factoid reply support of '(blah1|blah2)?'
- - Added 'FAQ'.
- - Added DebianExtra.pl module to list bugs. a hack and ugly!
- - Finally fixed list of old topics in Topic.pl, courtesy of mux
- and nicholas_.
- - Removed usage of quotemeta, replaced with \Q\E pair for regex.
- - Included patches to modify stock-brokeness of perl modules.
- 'cd /usr/lib/perl5; cat *.patch| patch -p0'
- - Setup option whether to cache user online stats. Disabling will,
- for sure, won't bloat the bot by 2-4megs (but why that much?).
-
-v1.0.0pre9 (20000512):
- - Typo for outsider checking. Noticed when #debian flooder came
- back yet again :)
- - seenCycle was in minutes instead of days. fixed.
- - Added User Information Services module. requested by Flugh.
- => 'uinfo <nick>'
- => 'uinfo set <type> <what>'
- => 'uinfo unset <type>'
- - Added &IsNickInAnyChan($nick);
- - Added &DCCBroadcast($txt) to broadcast messages to all members
- of DCC CHAT.
- - &say() now changes '0' to 'zero' due to Net::IRC bug.
- - Added &GetNickInChans($nick);
- - Merged fooz's wingate scanner.
- - Added 'ignoreAutoExpire' to differentiate time for ignore due to
- flooding instead of 'ignore' through DCC CHAT.
- => remove time for 'ignore' through DCC CHAT?
- - Added &debianCheck() to check state of gzip'd files.
- - ...
-
-v1.0.0pre8 (20000505):
- - usual backlash from upgrade.
- - added 'useStrict' option to infobot.config.
- - added 'reload', to reload Core and Extras Modules. Does it
- reload only if the file has changed?
- - added preliminary (debug) code for ftpGet() for truncated
- downloads. regetting will be added soon afterwards.
- - minor fix for Debian.pl where a package exists but an
- incomplete Packages file may not have info on that package.
- - Modified on-the-fly ignore to be temporary. temporary ignore
- requested by jCommons.
- - added 'factstats requester'.
- - preliminary use of scheduler for &checkPing() in &on_init().
- no event hook on 'pong' :(((
- - Timers now use Net::IRC's scheduler, woohoo. Nice change over.
- Moved ProcessExtras.pl to Schedulers.pl.
- - Added 'factstats deadredir'.
- - Don't prevent auto-reconnecting due to disconnection.
- - Forgot initialization before any new IRC connection.
- - Added scheduler for checking IRC connection.
- - Fixed problem in Freshmeat module, if forked to download, would
- not continue with query. => now it does, nice hack.
- - Debian module should generate incoming index if does not exist.
- - Chatting can be done through DCC CHAT.
- - ...
-
-v1.0.0pre7 (20000426):
- - INSTALL and README updated.
- - auto-request for ops after joining all channels instead of after
- each channel join.
- - If factoid is requested by someone, show literally (no
- evaluation) if owner of factoid matches aswell as if requested
- privately(good idea?)
- - on_notice fixed and debugging info removed.
- - Added reconnect on HUP if we're not connected. I hope that it is
- set to 0 otherwise this solution is dead.
- - ';' added as address char.
- - maths bug found by NoNix4.
- eg: 6000.0/9.000 - 6.000/9.000 - 666.00001
- - nickometer bug (pi not defined) found by ddent. 'strict' cleanup.
- - Preliminary CLI code included. Good for local use.
- - typo in Topic.pl, found by jCommons. Fix for NULL topic.
- - minor Debian.pl update to deal with 'missing files' on download.
- - multi-shmwrite support added. looks like it doesn't "refresh"
- the value properly if written many times.
- - &verifyUser() only used if addressed.
- - Applied 'use strict' to all code. Also used 'use vars qw()'.
- - Added 'backlog #' to DCC CHAT. requested by jCommons.
- - ctcp version reply wrong; FIXED. found by fooz.
-
-v1.0.0pre6 (20000407):
- - README updated.
- - Added retry on failure to reconnect through on_disconnect();
- REMOVED -- this spun an endless loop.
- - Found why Googling didn't work. See README for fix.
- - Forgot about channel casing bugs (on_{join|part}) after
- changeover to Net::IRC.
- - Changed addForked() to cycle through fork list and delete stale
- forks in case a forked child dies unexpectedly.
- - Renamed allowOutsiders to disallowOutsiders just in case if the
- option is removed from the configuration.
-
-v1.0.0pre5 (20000331):
- - setup_users.pl. DBI*() => sql*().
- - 'topic add BLAH' on empty topic would bork. Why didn't I pick
- this up before?
- - Somehow I removed (or it wasn't there) 'my @results' from
- searchTable();
- - nickometer now uses loadPerlModule()... another 500 kB saved :)
- - repeat flood detection prevention added.
- - Added el-cheapo hash key counter... possible leak detector.
- - Added 'factstats lame' for short and most probably stupid
- factoids.
- - Weather module removed
- - Renamed 'join' to 'joinchan' to due warning//conflict raised
- with perl 5.005 (on potato not slink).
- - Disabled syscall (removes 300 kB on slink, 3megs on potato)
-
-v1.0.0pre4 (20000323): pseudo AutoLoader support.
- - 'infobot' now first loads core.pl and logger.pl.
- - timerExpire() fixed.
- - Added unique maintainer count to 'dstats'.
- - Added demand-on-load of external perl modules. Now we need
- dynamic(on demand) loading of 'Modules/*.pl' modules ;)
-
-v1.0.0pre3 (20000319):
- - Fixed Freshmeat.pl not to show duplicate packages found by
- 'name' and 'oneliner' search. Made showPackage() function.
- - Debian modules now does multi distro. (woody's non-us appears to
- be different structure so does not work :(, very crude hack...
- may not even work).
- - Added subfactoid randomising. eg: '(one|two|three)'.
- - 'dauthor' now works!
- - karma fixed... used the wrong var name.
- - Fixed doubling of text when message from 'nick' is ignored.
- - Added 'redir' to designate one factoid as master and duplicates
- as redirectors//slaves.
- - Added addressing recognition character(s) support. eg "!status".
- - Seen info now cached and flushed at intervals or upon exiting.
- - Added 'EXAMPLES' file to doc/.
- - Removed ancient '&channel()'.
- - Bug fixes after offshore installation of bot.
- - Debian output of 'info' fixed. looks like 'fm', heh.
- - Debian distro stats added. I'm competing with larne and his mods
- to dpkg@OPN#debian :) so far so good.
- - Forgot to close shm upon exit, heh :) However this does not
- prevent leakage when the bot crashes.
- - Parameter 'forking' now works, courtesy of generic &Forker()
- function, woohoo! Now we use &Forker() for _everything_.
- I had this in the todo list, removed it and decided to implement
- it once and for all.
- - More bug fixes when moved changes to 'apt'. Several "bug
- reports" sent from #debian, thanks!
- - Moved infobot communications _after_ ignore checking code.
- - babelfish changed format? disabled for the time being.
- - ...
-
-v1.0.0pre2 (20000310): BETA TEST RELEASE
- - Hacked multiple mysql connection support in.
- - Renamed DBI to SQL, including functions.
- - Added $ishost.
- - Added backup scripts to create and mirror tables.
- - listauth fixed.
- - Added parse_warn.pl to decipher warn messages from logs.
- - shm* now works. no more fork floods ;)
- - Applied fork protection on all forking modules.
- - Dict feature now supports specific retrival of definition,
- however, default is still random.
- - Debian feature now supports multiple sub distributions. This can
- be further extended to architecture (perhaps easily).
- - Added (but commented) larne's regex for debian search.
- - Added &hasParam() to include notification that a feature
- (command) requested is disabled in configuration.
- - Added dumping of memory stats.
- - Fixed broken timerExpire().
- - Added auto shutdown of bot if too much ram is used.
- - Modified seen feature, set to off by default.
- - UPDATE: fixed, about time.
- - Improved parse_warn.pl to be like "diff".
- - Dollar variable addition?? suggestions by ddent.
- - 'factstats dupe' now ignores '<REPLY> see'.
- - UPDATE: fixed.
- - Added random factoid timer.
- - Don't redownload file via getFTP() if local and remote sizes are
- the same.
- - Added $count{'Dunno'} for unanswered questions.
- - Fixed 'blah is also or' since we didn't allow 'or'.
- - Added 'factstats redir' to display factoid redirections.
- - Grep nick from list of nicks in IsNickInChan(). Bug found by
- Mercury.
- - Time taken and final xfer rate displayed in FTP.
- - Fixed bug where 'or' is eval'd in Math.pl. Return '' if eval()
- is not done. Bug found by dent.
- - Added 'factstats redir' to list working and non-working
- redirected (symlink) factoids.
- - cmdstats now sorted by highest->lowest usage.
- - ...
-
-v1.0.0pre1 (20000130):
- - Mostly converted to Net::IRC, quite nice, like the dbm to mysql
- change over :)
- - Removed IrcHooks.pl and CTCP.pl.
- - Moved hooks stuff to IrcHooks.pl.
- - Moved IrcExtras.pl to Irc.pl.
- - Removed ansi_control option. colors can be stripped within
- &status() anyway, like for logging.
- - Added DCC CHAT and DCC SEND support base.
- - DCC SEND: null file. due to fork()? Fixed anyway.
- - DCC CHAT: person's responsibility to close DCC CHAT.
-
-v0.99pre12 (20000125):
- - Added intelligent flood protection and removed factoid
- repetition prevention.
- - Modified Math.pl...
- - Unified tell code in Process.pl.
- - Moved variable fix and addresing code to IrcHooks.pl
- - Moved tell code from Question.pl to UserExtra.pl.
- - Found that % and \ were double backslashed; added it to invalid
- factoids. May have been caused by whoever unbacked up 'apt',
- cerb? :) May want to add a function to automatically fix badly
- formed factoids.
- - Added 'factstats profanity', with &hasProfanity($str).
- - Added functions for shared memory usage.
- Uses: prevent exploitation of forked processes.
- - Added 'factstats unrequested'.
- - stale variables (vhost_name) forgotten in changeover.
- - UPDATE:
- - Fixed major leak with cycling of flood messages, typo :)
-
-v0.99pre11 (20000123):
- - Fixes here and there...
- - Debian find now searches Package names. Fallback automatically
- to contents file search.
- - Fixed typo related to log cycling.
- - Added netsplit detection code.
- - Started DCC support... very early stages.
- - Replaced several 'foreach' statements with 'if' for efficiency.
- About 5 instances of code...
- - Debian contents search ignores man pages (unless search string
- obvious for man page). Suggested by sgore.
- - 'factstats locked' returns list instead of only count.
- - &DoModes() bug found by larne.
- - Used '$nick' instead of 'lc $nick' for $channels.
- Found by larne.
-
-v0.99pre10 (20000119):
- - Fixed bugs found when moved code to 'apt':
- - added '^' and '|' to $isnick.
- - removed 'local' and 'my' for some global vars.
- - Typos of some variable names.
- - More typos.
- - Debian.pl contents search is better now.
- - UPDATE: made changes suggested by greycat.
- - Added Packages query now...
- - Added &getRandomLineFromFile()
- - Added LART, random text, Channel limit adjuster.
- TODO => Wingate checker (NOT COMPLETED)...
- - Added &iseq() and &isne().
- - Help info is not cached any more => loaded each time help() is
- called.
- - Added %timer hash, timestamp when something was last done. The
- hash name is incorrectly named, eh?
- - Moved parts of Process.pl to ProcessExtra.pl.
- - Moved parts of User.pl to UserExtra.pl.
- - Moved myRoutines.pl to UserExtra.pl.
- - Moved Extras.pl to Modules.pl.
- - Removed fortran math due to poor code style.
- - Moved parts of Question.pl to UserExtra.pl.
-
-v0.99pre9 (20000115):
- - Added messagecount column for 'seen'. Not used as yet. It
- appears to be pointless, yes?
- - Cleaned up DBI.pl: made use of $dbh->quote(); added
- &DBIRawReturn(), &DBIInsert(), &DBIUpdate().
- - Forgot to clear $tell_obj after successful 'tell'. Founded by
- solomon.
- - Extra modules loaded only if enabled in config, may save some
- ram.
- - Math.pl cleaned up.
- - Added DumpVars.pl, now we know where things are being leaked.
- - Removed duplicate 'use IO::Socket'.
- - Typo in "disabled" locking code which didn't work :) Founded by
- washort.
-
-v0.99pre8 (20000110):
- - Bailout if critical configuration variables are not found.
- - Dict.pl works well now.
- - Topic.pl now uses %topic or @topic. Added 'topic info' which
- contains who and time info. How does @{$hash{$key}} work?
- - Used 'use diagnostics;'. Fixed most warnings.
- - Added &WARN().
- - Minor typo in &IsInvalid() on last statement, heh.
- - Fixed (DAILY) logging, finally. Was broken too many times.
- - Added &getLineFromFile() for debugging purposes. BROKEN
- - Added Debian search-engine frontend => Debian.pl.
- UPDATE: forget mysql, takes too long.
- - Added Countdown => Countdown.pl.
- - Made use of 'unless' instead of 'if !'.
- - Added &DBIRaw().
- - Addressing required on all commands.
- - Added &fixFileList() to simplify files with common directories.
- - RevHippie stumped me with the best method to write this,
- heh. Why do I always try to do things in 1 loop instead
- of 2 loops?
-
-v0.99pre7 (19991230):
- - Renamed some setup/DBI calls.
- - Simplified nickserv/chanserv code. chanserv opping may break
- though. Experimentation?
- - Fixed broken stuff scripts/* due to src/* modification.
- - Added table locking support. BROKEN.
- - param{'ident'} deprecated.
- - Removed param{'dbname'}, please rename the main table (with
- factoids) to factoids.*
- - Added ircII.servers support.
- - Fixed infobot, Setup.pl and Files.pl.
- - Freshmeat.pl fixed. Set the update time _before_ we update.
- - Added factoid renaming. "rename 'from' 'to'".
- - Added DBISetRow() for first time inserts, for Freshmeat.
- Removed (rather used raw) use of fixmysqlbug for DBISetRow()
- - Added 'seen random'; fixed randKey to work with 'seen'.
- - Added preliminary code for whatis frontend.
- - Added SIGHUP code for $SIG{HUP}.
- - Added more error protection in DBI.pl.
- - Moved logDate logging support to &status@Misc.pl.
- - Confirmed logging does not duplicate from child any more.
- - Added 'partialdupe' (not recommended) and '2long' to
- &FactStats();
- - ...
-
-v0.99pre6 (19991223):
- - Dict now fixed, courtesy of RevHippie and myself.
- - Applied patch from RevHippie.
- - Removed auto continuation code.
- - Fixed learn =~ /HUNGRY/;
- - Added $talkok and $learnok.
- - Removed $param{'nick'} in favour of $ident. Added $safeIdent for
- regex and made use of it.
- - Moved Help.pl, Ignore.pl, Params.pl and part of User.pl to
- Files.pl.
- - Removed Internic.pl and Traceroute.pl.
- - Fixed $isnick, renamed and fixed &purifyNick(). Added nick
- compliancy checks when connecting to IRC server.
- - Rewritten 'spell' code.
-
-v0.99pre5 (19991220): bug fix release.
- - setupmysql.pl, slightly different for potato.
- - dbm2mysql.pl
- - performReply(), removed $trailing. FIX LATER.
- - Freshmeat.pl, forgot about &main::, again.
- - logType, broken date value.
- - Fixed broken 'tell blah about what', readded $answer var.
- - minLengthBeforePrivate superseeds preferReply.
- - Forgot to use 'my' on three instances of $sth.
-
-v0.99pre4 (19991219):
- - Added 'dupe' for factstats.
- - Added illegal character detection in Statement.pl.
- - Unified output (and duplication) of factstats (and other) code
- to use one function, &formListReply(). Reduced code by at least
- 2k :)))
- - Minor modifications to &DBIGetCol();
- - Move +s flag to 'set search' in infobot.config.
- - Altered talkMethod to allow 'private' or 'default'. Made no
- sense to have it on public-only, heh.
- - friendlyBots will be kept to be compatible with other stock
- infobots but soon enough multiple mysql database support will be
- added. Will be quite nice once done.
- - Added maxListReplyCount and maxListReplyLen. Read infobot.config
- for details.
- - Replaced $refresh with freshmeatRefreshInterval to config.
- - Changed learn setting from ALWAYS to HUNGRY.
- - Reorganised Extras.pl, we shouldn't bail out if the command
- can be disabled as the person who runs the bot should have
- brains.
- - Moved some Process.pl stuff to myRoutines.pl.
- - ---
- - &searchBy*() allows ^ and $, like in regex (basically sar'd).
- removed $notexact variable.
- - Fixed 'no,blah is blah' bug.
- - Changed 'is also' char to ';;'.
- - Added &IsInvalid(); to unify Statement (when creating) and
- factstats/broken (when checking/verifying). Works like a charm
- :)))
- - Removed sane stuff; added infobot.ignore. I hope lenzo's
- ignoreList code works.
- - Fixed setupmysql.pl
- - Moved repeatIgnoreInterval to minRepeat*Reply where * is Private
- or Public.
- - Now preferReply works. Wasn't hard as it first looked.
- - Added global '+' flag support.
- - Fixed logging: added logType param; if logType =~ /DAILY/, new
- log is created daily. Date is time-of-day, aswell.
- - added &fixMySQLBug() => adds backslash to special chars.
-
-v0.99pre3 (19991216):
- - Fix connection bug where if host does not resolve, it appears
- that it's connection refused. Now non-resolving hosts are
- detected earlier. Found by some *.it (or .es??) guy.
- - Added 'sync in #s' when the bot has joined a channel... just
- like in BitchX.
- - Added txt2mysql.pl.
- - Removed instances of '^\s*' to '^' since $message can be
- manipulated in Process.pl.
- - Fixed Statement.pl so that it doesn't catch queries... it's a
- stupid idea any way.
- - Removed 'confused' in favour of 'dunno'.
- - Funny hack in performReply(). Stupid but it works.
- - Added 'host' column in seen table.
- - Made use of &gettimeofday() for freshmeat and search function.
-
-v0.99pre2 (19991213):
- - Made use of new database (directory) not to interfere with other
- crucial dbs.
- - Re-added &getKeys(), mysql's RLIKE wouldn't like "'" in the
- statement. If several of similar queries are required, better
- off using &getKeys().
- - Added two more conversion scripts.
-
-v0.99pre1 (19991211): personal release. MAJOR CHANGES.
- - create a script to add the blootbot user to the mysql server and
- prepare tables for use with the bot.
- - butchered Question.pl, Reply.pl, Statement.pl and Reply.pl.
- - main factoid db ported over; barely tested.
- - seen ported over; appears to work.
- - karma ported over; not tested at all.
- - freshmeat ported over; fix brokeness.
- - search (listvals and listkeys) ported over.
- - rootwarn ported over.
-
- - Use quotemeta in DBI.pl on special chars, especially ' :)
- - Added factstats 'broken' function.
- - Made use of multiple connections to avoid clashing... does
- clashing only occur when there's an INSERT/UPDATE or SELECT or
- both?
- - Changed $factoid to $faqtoid... good idea? how about $lhs?
- - Changed getKeys to countKeys to take advantage of mysql.
- - Added randKey to get random primkey,key from table.
- - Removed process() when msgType == 'public action'. Why would we
- want to care about actions anyway?
- - Fix public action; Added private action to &status().
- - Added &ERROR();
- - Made message and who flooding independent in IrcHooks.pl. Now we
- use %flood... should be expanded to use %ignoreList;
-
- NOTES...
- - DBI.pl has more functions than what DBMExtra.pl had in order to
- implement a table-like hash list.
- - &DBISet() always verifies if an entry already exists and does an
- UPDATE instead of an INSERT... flaw in mysql or my code???
- - &DBISet() can only set one (in UPDATE, two in INSERT), variable
- at a time. Does this impose a performance hit? like on seen.
- - ...
-
- TODO...
- - infobot.cgi not ported over.
- - weather not ported over.
- - add alarm call between while in Dict.pl.
-
-*************************************************
-************* CHANGE OVER TO MySQL **************
-*************************************************
-
-v0.18.2 (199912??): dropped.
- - Fix for Weather.pl.
- - Fix for Dict.pl.
- - ...
-
-v0.18.1 (19991130): last public release before database change over.
- - Modified &IsNickInChan() so that a foreach is done case
- insensitively against nick to prevent misses.
- - Added server "jump" support, requested by larne.
- - Added seenMaxDays, maximum number of days to keep seen info on
- someone, otherwise delete it.
- - Forgot to use $main:: in Freshmeat.pl and Weather.pl; fixed.
- - Changed userList format to $userList{$user}{$flag}{$what} = 1;
- Converted all code to use this userList format.
- - Changed version string to include OSname.
- - Replaced $locWho with $who or $origWho.
- - Removed hidden whitespaces and tabs at and of statments.
-
-v0.18.0 (19991128):
- - Post release typo fixes here and there.
- - Changed lc() to tr/A-Z/a-z/ where suitable.
- - Redid join command in Process.pl.
- - Cleaned up regex (mainly .* => \S+).
- - Found $ischan to be broken; fixed.
- - Changed Slashdot3.pl to have "joining" code like in DBMExtra.pl.
- - Made use of &nick() and &IsChan();
- - Added &kick() to Misc.pl; kick command to User.pl.
- - Added &IsNickInChan();
- - Fixed loading Param file before pidfile and other file related
- stuff.
- - User.pl
- - Revamped; removed unused functions.
- - Moved Set.pl to here.
- - Moved 4op code here.
- - Moved some functions from Process.pl to here.
- - Rewrote rehash command.
- - More casing fixes; debugging info _should_ help to find more.
- - Changed infobot.users.
-
-v0.17.0 (19991126):
- - Netsplit code prevented stats of signoffs; fixed.
- - Messed around with logging code to prevent control chars.
- - Removed exchange and excuse module because of brokeness.
- - Applied patch from RevHippie. Thanks!
- - Added delimiter support in addressing of hello msg.
- - Removed 'score' in karma.
- - Added 'learn' (ALWAYS or ADDRESSED) support. Normal
- operation == ADDRESSED. Bot won't respond voluntarily to
- factoids but will respond to learning.
- - Ability to turn off minVolunteerLength.
- - More changes to prevent chatter in unaddressed manner.
- - We remove any ansi or control chars when piping to the log file.
- RevHippie++.
- - Added 'thanks' language.
- - Typo in Freshmeat.pl; Fixed.
- - Added $rootwarnmode = passive || aggressive to satisfy lilo@OPN.
- default is passive.
- - Fixed mix up of fix in 'tell' code. I had the if statements the
- wrong way around.
- - Removed more debug code.
- - FactStats/author fixed; now multiple authors with the same stats
- are printed together.
- - Added logfile cycling w/ approx maximum size.
- - Changed infobot.config yet again. now it's much better than
- before. Some variables removed.
- - Added Unset support to Set.pl; Changed so anything can be set
- or unset.
- - Made use of &purifyNick() so regex doesn't break. $safeWho
- now defined earlier.
-
-v0.16.0 (19991122):
- - Applied bug fixes from infobot 0.44.3, added md5 password
- support (*BSD?).
- - Added &IsParam() to check existance of params the proper
- (strict) way.
- - Moved rootWarn stuff from Extras.pl to RootWarn.pl.
- - filenames (rootwarn and uptime) now not statically set.
- - Cleaned up config file and Setup.pl.
- - Fixed up &parsectcp() in CTCP.pl.
- - Changed ($ischan) to (\S+) in Irc.pl under PRIVMSG.
- - Major reorganisation of Misc.pl -- removed unused functions.
- - Moved some variables to 'infobot'.
- - Fixed ANSI typo by some loser; Changed format of &status()'s in
- Irc.pl, seems to look nice thus far.
- - Added "author" command under &FactStats() in DBMExtra.pl.
- - Added case insensitivity to &IsHostMatch() and search strings in
- DBMExtra.pl. Any more of these?
- - Removed disabled netsplit code.
- - Changed 'defined' to 'exists' on all hash lists, 'cept hashes
- created by opening db's.
- - Modified repeat code on modified_time. If this time is small,
- msgType is changed to 'private' for flooding reasons and
- max_time is reduced by half. latter appears not to work???
-
-v0.15.0 (19991112):
- - Quite funny that once the repeat code was moved to Question.pl
- factoid extension leakage was found. maths leakage was also
- happening but somehow is fixed when the repeat code was moved
- back.
- - Clean up of variable names in Reply.pl and Question.pl
- - Changed 'length' to 'eq ""' or 'ne ""' where possible.
- This should produce faster code but benchmarks prove this change
- is neglible. Guess perl is slow :)
- - Cleaned up and fixed 'tell <who> about <what>' code.
- - Set.pl fixed; Added DEBUG to allowable set list.
- - Volunteer code moved to top of Question.pl.
-
-v0.14.0 (19991110):
- - Message overflow fix in &FactStats().
- - Added 'factstats new' command to display new factoids in the
- last 24 hours.
- - Fixed up ping reply, requested by a few from #debian@OPN.
- - Re-added debugging of DBMExtra due to leakage of orthaned
- factoid extensions. Need to investigate and confirm the
- lowercase fix of factoids.
- - Two functions which used &mkRandom() now fixed due to poor
- effort in implementation. Added missing srand(). now the maximum
- length of 475 should not be exceeded, hopefully. it can be
- beefed up to 490 if needed.
-
-v0.13.0 (19991108):
- - Made use of &help() which uses infobot.help. This paves the way
- for NLS as suggested by njs.
- - Fixed up code on netjoin/netsplit in an effort to find
- statistics leakage. Added debugging info to netjoin/netsplit.
- - Fixed typo (three instances) in factinfo where time() was used
- instead of the data in the factoid extension. Found by larne.
- - Allow main thread to do a clean exit while the child does
- nothing. Possible fix for weird uptime info.
- - Removed sar of 'your|i|you|me' to prevent automated reverse
- persona which is better done by the user. Suggested by njs.
- - Cleaned up behaviour of &FixPlural(). Fixes a bug.
- - Repeat prevention code now replaced (moved aswell) to use
- factoid extensions
- - Fixed 'factstats requested' error.
-
-v0.12.6 (19991103): bugfix on bugfix release ;)
- - Fixed bug where you can't lock a factoid because the hostmatch
- ($thisnuh = "") failed. Found by wolfie.
- - Fixed up 512byte overflow in factstats[requested].
- - hm... wonder how I broke Weather.pl.
-
-v0.12.5 (19991101): Bugfix release
- - Fixed "bad" array in Freshmeat.pl. All appologies to scoop.
- [update: use array[5] if it exists, otherwise do as before.]
- - Removed some debugging info from DBMExtra.pl.
- - Fixed inconsistent chanstats behaviour in SignOff.
- [Update: forgot to delete the user info _after_ we do the stats]
- - Moved factoid stats count and repeat checking code to
- Question.pl. Now it works as planned :) :) :)
-
-v0.12.4 (19991028):
- - Added factstat and listauth commands.
- - 'topic add' now prepends subtopic not append.
- - Fixed up minor problem with 'topic restore last'.
- - Changed default of locking access to people who own their
- factoid or to registered ops. This should please #debian.
- - Reduced usage of @{$var} which cannot be really deleted cleanly.
- - Moved DBMExtra-related stuff from myRoutines.pl to DBMExtra.pl.
- - Added new functions &mkRandom() and &getRandom().
- - Changed all code (Search.pl) which used random to the one
- developed in DBMExtra.pl. => made code slightly smaller.
- - Cleaned up Search.pl to look nice.
- - Found yet another casing bug under TOPIC in Irc.pl.
- - Fixed bug where dbmextra queries where made on non-factoids like
- maths and probably karma.
-
-v0.12.3 (19991025):
- - Added while loop around connect which should prevent the bot
- from falling down (dying).
- - Forgot 'main::' for &getURL in Freshmeat.pl. Changed
- opening/closing code yet again. Removed checking on open
- read-only.
- - Changed Dict.pl to reply private only by default. '+' will allow
- public responses without suggestions/synonyms.
- - Added checking against pidfile. running two bots from the same
- dir at the same time using the same db == disaster. Ask #debian
- about it :)
- - Implemented Weather.pl.
-
-v0.12.1 (19991022):
- - Made distribution out of infobot -> blootbot.
- - Irc.pl was prone to be fucking up -- swapped (.*) to (\S+) where
- necessary. stab lenzo for this :) found more instances of this.
- [update: appears to trap too many of something, check
- 'chaninfo #chan' for info.]
- - Minor fix for Freshmeat.pl when opening/closing db.
- - Factoid extension code is ready for testing. possible in the
- future to add "factstats" for like: top 3 requested factoids.
- [update] added lock checking on sar and on updates ("no, "...)
-
-v0.12.0 (19991020): (v0.11.6 + bugfixes + trial)
- - Major shake-up of how addressing is handled -- damn it took me a
- long time to get this to work.
- - Changed command names in Topic.pl to &topicBlah().
- - Found and fixed (hopefully) all 7 channel casing bugs.
- - Moved freshmeat to use berkeley db instead of raw appindex.txt
- file. finally got it to work, seems 30% faster. Creating the db
- takes a long time though.
- - Added "set" command => Set.pl.
- - Added support of talkMethod which behaves much like lobotomy.
- In the future, talkMethod =~ /(lobotomy|none)/ may be used.
- - Purged: METAR2.pl, NOAA.pl, UAFlight.pl.
- - RootWarn only works if the bot is opped in the channel.
- - Created performStrictReply() from performReply().
- - Quote.pl and Internic.pl now work.
- - Fixed a few typos in myRoutines.pl
- - Removed bold on dictionary.
-
-v0.11.5 (19991012):
- - Fixed $chan to lowercase where appropriate.
- - Fixed volunteer reply code... I guess it worked before but now
- it is somewhat cleaner and easy to understand.
- - Added factoid owner database, requested by njs.
- - If public message is addressed to someone else, we ignore it.
- - Now support referer factoids ('blah is <REPLY> see erp'). if
- 'blah' is asked, the reply from 'erp' is given.
- - OPN allows part messages -- fixed in /PART/ for $chan.
-
-v0.11.3 (19991008):
- - Uptime.pl appears to be fixed after rewrite of getUptimeInfo.
- - Fixed up Freshmeat.pl for updating the index. Proxy is now
- optional.
- - Moved rootWarn to RootWarn.pl. Added hall-of-fame of losers.
- - Cleaned up bugs/typo here and there which may have caused the
- bot to behave in a weird manner.
-
-v0.11.2 (19991006):
- - ChanInfo now displays "statistics" just like our little friend
- BitchX.
- - Minor change in determining args on commands [myRoutines].
- - Added "cmdstats".
- - Added rootWarn checking on checks. Repeat offenders will be
- punished. Requested by larne. [update: we aren't so harsh now]
- - Added lc $chan where appropriate. damn uppercase channames.
-
-v0.11.1 (19991005):
- - all instances of undef on hash lists changed to delete which
- _now_ works. found minor bugs/typos related to DUI.
- - Now skip internic whois intro (13 lines) to fix bad output.
- - Forgot to subtract $i from $counter in chaninfo when full.
- [update: whole function changed, see above]
- - Now backup (and gzip) freshmeat index file.
-
-v0.11 (19991004): looks like a bug fix release :)
- - Fixed typo in reply of Topic.pl/&NewTopic().
- - Decreased max topic length allowed; now print it, too, for
- debugging.
- - Altered repeat code to only work on public. Flooders should be
- taken care of by the (allowOutsiders == 0) code. if not, there's
- 'lobotomy' :)
- - Added excess flood protection around &rawout();
- - Don't bother about outsiders if we haven't joined any channels.
- - Changed email address to one throughout modifications.
- New files have neato headers.
- - Uptime.pl fixed, didn't need to check against ($pid == $$)
- - Repeat-prevention code kind-of looks what it was before but this
- one, at least, works :). any problems, just bitch at me.
- - Added debugging code for chaninfo to diagnose "problem".
-
-v0.10 (19991001):
- - Added Uptime module.
- - Added Freshmeat module.
- - Dict now returns definition without suggestions (syn's) by
- default. Also cleaned up.
- - NickServ/ChanServ major clean up.
- - Join upon reconnect fix: set $joinchans = 0.
- - Fixed up Help.pl, added more help entries.
-
-v0.9b (19990925):
- - Did repeat-prevention code from scratch -- now works.
- [19991001 update]: multiplier is now 2 instead of 10.
- - Made reaction to "hello" more strict. the same should be done to
- "thanks", don't you think?
- - Converted remaining modules to use forking. should be no more
- bot lockups...
- - Changed maxhits to 20 for Search.
-
-v0.9 (19990924): +16K added to patch size.
- - More, more and more major changes.
- - Fixed up inappropriate usage of performReply.
- - Added lobotomy command to (un)silence the bot.
- - Added allowOutsiders toggle to prevent usage of the bot
- _outside_ the channels the bot is in.
- - Added $fullyaddressed, enabled if $addressed == 1 and
- $param{addressing} == REQUIRE.
- - Readded auto-continuity code. it is disable if not fully
- addressed. otherwise works as per normal.
- - Moved join-on-start-of-motd code to end-of-motd. If nickserv &&
- chanserv is enabled, IDENTIFY is done first. If okay, then we
- proceed to join channels.
- - When bot joins channel, summary of nicks (ops|voice|total) is
- given instead of NAMES list.
- - Chanserv support moved to "end of names".
- - Detection of nickserv (no such nick).
- - join channel if channel is on our joins list and if we're not on
- it (hrm, providing their client prevents it).
- - ...
-
-v0.8 (19990919): +50K patch from last version.
- - Major changes, particularly cleanups and fixed a few bugs:
- - Found 2 or so instances of $params{}. Either deleted or
- renamed to $param where appropriate.
- - Shortened foreach statements where possible.
- - Replaced duplicate code involving &say and &msg with
- &performReply($text,[0=rand,1=strict]). -- major shortcut and
- cleanup.
- - Added tracking of all users on channel(s). Users are
- deleted if they disappear for whatever reason with
- &DeleteUserInfo.
- - Tracking of channels now works; they are deleted if we disappear
- from any channel for whatever reason (hopefully).
- - 'forget' command _SHOULD_ be wrapped with $addressed.
- - Moved 'modes' from User.pl to myRoutines.pl as 'chaninfo'.
- - Added stock quote support by using mu's script. Thanks.
- - Added param{*} around stuff in myRoutines.pl for flexibility.
- - Added auto-join on invite if not on specific "join_channels"
- - Renamed &Timetostring to &Time2String and made use of it not
- only for status but for seen.
- - If $param{*} == false, it is now not defined.
- - Removed Auto-continuity code -- very evil for any bot commands
- other than non-intentionally requesting a factoid.
- - crypt command required "(" before passwd???
- - Removed stupid commands which just generate URLs for you to cut
- and paste.
- - repeatIgnoreInterval code _NOW_ works unlike before.
- - Added support for Topic.pl not to update topics if commands are
- prepended by '-'. Topics can be "rehashed" when either a) the
- next command is used without '-' or b) "rehash" is the next
- command.
- - &NewTopic takes two more args to prevent repetition and now does
- topic checking. Check code for details.
-
-v0.7 (19990914):
- - Major clean up: Search.pl now only uses the "is" dbm; final
- pair of parens in commands removed for legibility; Removed
- debugging for NickServ, ChanServ to go.
- - Added multiple subtopic delete ability. requested by Mercury.
- - Moved responses/replies to [files/infobot.lang]. Modified
- related functions to conform, including mine.
- - Fixed up Kernel.pl to use different type of sockets. Previous
- code somehow broke itself.
- - Added, but disabled, semi-working timer support. Need to ask
- lenzo some questions on how to implement it the best way.
- - Added channel (and offender's) notification if someone joins the
- channel with root. requested by #debian.
- - Added dict.org support. For now, it uses wordnet and returns a
- random definition. Could change in the future.
-
-v0.6 (19990903):
- - Added support for nickserv and chanserv, requested by is.
- - Updated README to describe new features and modifications. Do we
- need to elaborate on the modifications to the depth where it
- would exceed the size of the patch?
- - Minor clean up.
- - Removed assumed-continuity of messages -- should be used if
- addressing is in optional mode but would be bad in any situation
- if more than one infobot existed in the channel.
- - Added parsing of g flag to factoid sar.
-
-v0.5 (19990827):
- - Better way to confirm if bot is on channel now for topic
- management. Also added check for +o+t or -t. &DoModes() on
- server stuff, too?
- - Patch updated to work for infobot-0.44.2 only.
- - Found a bug in Irc.pl under "NAMES" where $u was used initially
- but trashed afterwards. => replaced $u w/ $_.
- - Lost track of a bug found by Mercury. Seems to be fixed now,
- somehow, heh.
-
-v0.4c (19990822):
- - Worked on random-cookie -- random responses can now be added
- (internally) with ease.
- - Noticed joeyh changing his nick to/from '||' which reminded me
- of something bad ;) hint: topic management.
- - One line patch to allow '|' in factoids; delimiter is now '||'.
-
-v0.4b (19990818):
- - Implemented patch from mu. Now it is possible to use the topic
- command through private messages to the bot instead of the
- channel.
- - Replaced SAR of \| with \|\| so we can still use the single
- pipes. Double pipes will be either removed or promote an error
- message. Found by Robot101. Added el-cheapo work-around if the
- last char of subtopic is |, kill it.
-
-v0.4a (19990816):
- - Added cheap fix (sleep 1, heh) to excess floods of 'topic
- history'. Is sleep 1 enough?
- - Added 'random' for random value{key} from database.
- Requested by jCommons.
-
-v0.4 (19990815):
- - Fixed topic history by replacing push with unshift. Now the
- history list is reversed and cycled properly.
- - Reversed Changes list. request by mu.
- - Totally fixed up topic history since it would break if
- 'topic add' was induced quickly. Now we only record topics set
- by us (for reasons) and onjoin topics (set by anyone).
- - Removed 'topic last/reset' because how do you know which topic
- is last? Better control with 'topic restore'.
-
-v0.3c (19990813):
- - Fixed 'topic mv 2 before 1' bug. Forgot to store 'move' topic
- before doing the foreach loop.
- - Touched up Kernel.pl in preparation for auto-notify feature.
-
-v0.3b (19990812):
- - Added version string to new files so we know which version
- of patch we're using (or used). There you go, Mercury ;)
- - Fixed up DecipherTopic to reject null subtopics. This would, if
- unchanged, (theoretically but not tried, luckily) produce a
- domino-effect of problems if the topic was to be changed.
- Update: check if the supposed null topic contains spaces
- within the nick component. If so, then it's not
- nick, therefore treat like ownerless subtopic.
- - Worked on README.
-
-v0.3a (19990810):
- - Changed back to use topic{chan} (now topicnow{chan}) since
- @topiclist{chan} (now @topichist{chan}) does not deal with dupes
- or blanks.
- - Renamed 'topic last' in preference to 'topic reset'. Original
- command can be used but is vague in meaning.
- - Fixed several typos made in Irc.pl.
- - Replaced 'defined' with 'length' in if statements.
-
-v0.3 (19990809):
- - Applied patch from mu for Irc.pl | Topic.pl.
- - Replaced %topic hash and $topiclast with @{$topiclist{chan}}.
- Much cleaner implementation. Thanks to mu for this. Fully
- implemented by xk.
- - Reworked on topicbyme (was topiclast), should work now.
-
-v0.2 (19990808):
- - Changed name of patch to funkystuph.
- - Added history/last/restore to Topic.pl by request of mu and is.
- - Reorganised help and order of commands in Topic.pl
- - Bot must be addressed to use commands.
- - Fixed bug if multiple infobots were in the channel.
- - One occurrence where Cipher was called instead of CipherTopic.
- - Fixed up Slashdot.pl. Problems: a) borked completely b) missed
- first headline. el-cheapo fix but it works.
-
-v0.1c (19990729):
- - Fixed long list{keys|values} bug, hopefully.
- - Now randomize key results from search.
- - If keys contain ',', underline to differentiate it.
- - Fixed possible DoS against Kernel.pl.
- - Bug fixed with Kernel.pl repeating itself.
- - Typo of @results [one occurrance of @result]
-
-v0.1b (19990723):
- - Fixed bug with &CipherTopic where, if no owner was found, it
- would just use NULL. [like "Topic ()"]
- - Added kernel feature.
- - Moved error messages to public/private, depending on behaviour.
- Help-related stuff is private(msg) only for convenience.
-
-v0.1a (19990721):
- - Misc cleanup, removed repeated code.
-
-v0.1 (19990720):
- - Initial release.
+++ /dev/null
-Method of installation.
------------------------
-
-- Copy files/sample/* to files/
-
-- Edit files/blootbot.config, modify to taste.
-- Edit files/blootbot.servers to modify list of IRC servers to connect.
-- Edit files/blootbot.chan to set which channels to join.
-
-- Install the following Perl modules:
- - Net::IRC perl module
- - Debian: (apt-get install libnet-irc-perl)
- - WWW::Search
- - Debian: (apt-get install libwww-search-perl)
- - LWP
- - Debian: (apt-get install libwww-perl)
- - HTML::Parser
- - Debian: (apt-get install libhtml-parser-perl)
-
-- Choose your database:
- - MySQL, read INSTALL.mysql (supported)
- - SQLite, read INSTALL.sqlite (supported)
- - SQLite2, read INSTALL.sqlite (supported)
- - PgSQL, read INSTALL.pgsql (unsupported, may work)
-
-- There are "bugs" in the perl modules. Read INSTALL.patches on how to fix.
-
-- Finally, './blootbot'
+++ /dev/null
-INSTALL.mysql
-----------------
-
-- Install a MySQL server and the DBI Perl modules.
- - Debian: (apt-get install mysql-server libdbd-mysql-perl)
-
-- Run 'mysqladmin -u root -p create <DB NAME>'
- Where <DB NAME> is the same as specified in blootbot.config.
-
-- Run 'setup/setup.pl'
-
-= Possible problems
- - if connection to localhost is (short) refused, run
- '/etc/init.d/mysql stop'
- '/etc/init.d/mysql start'
- - if connection for user is refused, reload grant tables with
- 'mysqladmin -u root -p reload'
-
-* [OPTIONAL]
- - run 'scripts/dbm2mysql.pl old-db' to convert dbm database file
- to mysql.
-
-ADDITIONAL NOTES:
------------------
-You can add a new user manually by connecting to MySQL and performing these
-commands:
-
- $ mysql -u root -p
-
- mysql> CREATE DATABASE blootbot;
- mysql> GRANT USAGE ON *.* TO 'user'@'localhost' IDENTIFIED BY 'yourpassword';
- mysql> GRANT ALL PRIVILEGES ON blootbot.* TO 'user'@'localhost';
-
-FULL FACTOID DATABASE:
-----------------------
-You can get the data from the MySQL database that the apt bot uses on
-#debian at freenode (irc.freenode.net), at:
-
- http://lain.cheme.cmu.edu/~apt/blootbot/apt.sql.bz2
+++ /dev/null
-INSTALL.patches
--------------------
-
-- apply *.patch patches inside patches/
- - cd /usr/lib/perl5/WWW/Search
- patch -p0 < WWW::Search::Google.patch
-
-- alternatively, move the files from patches/
- - mv patches/Google.pm /usr/lib/perl5/WWW/Search/
-
-Net::IRC DCC CHAT
-----------------------
-Unfortunately, Net::IRC 0.70 has buggy code that does not detect DCC CHAT
-properly. to patch:
- cd /usr/share/perl5/Net/IRC/
- cat ~bot/patches/Net_IRC_Connection_pm.patch | patch -p0
+++ /dev/null
-Method of installation.
------------------------
-
-- Debian: (apt-get install postgresql)
-- Debian: (apt-get install libpg-perl)
-
-
-As of now, blootbot has full pgsql support. It seems to be working 100%, but it
-assumes that you have precreated the database and user for now. As long as you
-already created the database and user and stored this info in the blootbot.config,
-then the tables will automatically be created on startup. Until I get setup.pl
-fixed, run the following commands as root (or postgres if root doesnt have
-permission to create users/db's):
-
-> createuser --no-adduser --no-createdb --pwprompt --encrypted <user>
-> createdb --owner=<user> <dbname> [<description>]
-
-Dont forget to replace <user> and so forth with actual values you intend to use,
-and dont include the <>'s ;) If you run these commands, you should get a user
-with an encrypted password that cannot create new db's or user's (as it should be!),
-and the user will own the newly created database <dbname>. Congrats!
-
-If everything went fine, you should have everything blootbot needs to use pgsql.
-Next simply cd to the base directory you installed the bot to and type:
-
-./blootbot
-
-
-Thats it! Everything the bot needs should be automatically created when it loads
-for the first time.
-
-In the future I will try to get around to editing the setup.pl file to ask the
-same questions it does for mysql (your root password etc) so that you can skip
-manually creating the database/user. But for now, this should be just fine for
-most of you techies out there.
-
-
-----
-troubled@freenode
+++ /dev/null
-INSTALL.sqlite
-----------------
-
-SQLite is a C library that implements an embeddable SQL database engine.
-Programs that link with the SQLite library can have SQL database access without
-running a separate RDBMS process. The distribution comes with a standalone
-command-line access program (sqlite) that can be used to administer an SQLite
-database and which serves as an example of how to use the SQLite library.
-
-blootbot will create a file called <DBname>.sqlite and populate the tables for
-you if they do not already exist.
-
-- Install SQLite libraries and DBI Perl modules.
- - Debian: (apt-get install libsqlite0 libdbd-sqlite-perl)
-
-other distros might need to build from sources.
-
-You may use either DBD::SQLite or DBD::SQLite2
-
-SQLite sources:
-
-http://www.hwaci.com/sw/sqlite/
-
-DBD::SQLite sources:
-
-http://search.cpan.org/author/MSERGEANT/DBD-SQLite/
-
-You will also need the normal Perl DBD stuff which should be included in your
-Perl distribution.
+++ /dev/null
-
-
-
-
- The "Artistic License"
-
- Preamble
-
-The intent of this document is to state the conditions under which a
-Package may be copied, such that the Copyright Holder maintains some
-semblance of artistic control over the development of the package,
-while giving the users of the package the right to use and distribute
-the Package in a more-or-less customary fashion, plus the right to make
-reasonable modifications.
-
-Definitions:
-
- "Package" refers to the collection of files distributed by the
- Copyright Holder, and derivatives of that collection of files
- created through textual modification.
-
- "Standard Version" refers to such a Package if it has not been
- modified, or has been modified in accordance with the wishes
- of the Copyright Holder as specified below.
-
- "Copyright Holder" is whoever is named in the copyright or
- copyrights for the package.
-
- "You" is you, if you're thinking about copying or distributing
- this Package.
-
- "Reasonable copying fee" is whatever you can justify on the
- basis of media cost, duplication charges, time of people involved,
- and so on. (You will not be required to justify it to the
- Copyright Holder, but only to the computing community at large
- as a market that must bear the fee.)
-
- "Freely Available" means that no fee is charged for the item
- itself, though there may be fees involved in handling the item.
- It also means that recipients of the item may redistribute it
- under the same conditions they received it.
-
-1. You may make and give away verbatim copies of the source form of the
-Standard Version of this Package without restriction, provided that you
-duplicate all of the original copyright notices and associated disclaimers.
-
-2. You may apply bug fixes, portability fixes and other modifications
-derived from the Public Domain or from the Copyright Holder. A Package
-modified in such a way shall still be considered the Standard Version.
-
-3. You may otherwise modify your copy of this Package in any way, provided
-that you insert a prominent notice in each changed file stating how and
-when you changed that file, and provided that you do at least ONE of the
-following:
-
- a) place your modifications in the Public Domain or otherwise make them
- Freely Available, such as by posting said modifications to Usenet or
- an equivalent medium, or placing the modifications on a major archive
- site such as uunet.uu.net, or by allowing the Copyright Holder to include
- your modifications in the Standard Version of the Package.
-
- b) use the modified Package only within your corporation or organization.
-
- c) rename any non-standard executables so the names do not conflict
- with standard executables, which must also be provided, and provide
- a separate manual page for each non-standard executable that clearly
- documents how it differs from the Standard Version.
-
- d) make other distribution arrangements with the Copyright Holder.
-
-4. You may distribute the programs of this Package in object code or
-executable form, provided that you do at least ONE of the following:
-
- a) distribute a Standard Version of the executables and library files,
- together with instructions (in the manual page or equivalent) on where
- to get the Standard Version.
-
- b) accompany the distribution with the machine-readable source of
- the Package with your modifications.
-
- c) give non-standard executables non-standard names, and clearly
- document the differences in manual pages (or equivalent), together
- with instructions on where to get the Standard Version.
-
- d) make other distribution arrangements with the Copyright Holder.
-
-5. You may charge a reasonable copying fee for any distribution of this
-Package. You may charge any fee you choose for support of this
-Package. You may not charge a fee for this Package itself. However,
-you may distribute this Package in aggregate with other (possibly
-commercial) programs as part of a larger (possibly commercial) software
-distribution provided that you do not advertise this Package as a
-product of your own. You may embed this Package's interpreter within
-an executable of yours (by linking); this shall be construed as a mere
-form of aggregation, provided that the complete Standard Version of the
-interpreter is so embedded.
-
-6. The scripts and library files supplied as input to or produced as
-output from the programs of this Package do not automatically fall
-under the copyright of this Package, but belong to whoever generated
-them, and may be sold commercially, and may be aggregated with this
-Package. If such scripts or library files are aggregated with this
-Package via the so-called "undump" or "unexec" methods of producing a
-binary executable image, then distribution of such an image shall
-neither be construed as a distribution of this Package nor shall it
-fall under the restrictions of Paragraphs 3 and 4, provided that you do
-not represent such an executable image as a Standard Version of this
-Package.
-
-7. C subroutines (or comparably compiled subroutines in other
-languages) supplied by you and linked into this Package in order to
-emulate subroutines and variables of the language defined by this
-Package shall not be considered part of this Package, but are the
-equivalent of input as in Paragraph 6, provided these subroutines do
-not change the language in any way that would cause it to fail the
-regression tests for the language.
-
-8. Aggregation of this Package with a commercial distribution is always
-permitted provided that the use of this Package is embedded; that is,
-when no overt attempt is made to make this Package's interfaces visible
-to the end user of the commercial distribution. Such use shall not be
-construed as a distribution of this Package.
-
-9. The name of the Copyright Holder may not be used to endorse or promote
-products derived from this software without specific prior written permission.
-
-10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
-IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-
- The End
+++ /dev/null
-This is out of date.
-
-
-
-
-
-
-blootbot v1.0.0 (20000729)
--------------------------
-
-INTRODUCTION
- This bot is based upon infobot-0.44.2 by kevin lenzo
-<lenzo@cs.cmu.edu>. The basis of infobot is still there but _many_ wild
-features have been added. Along the way, a couple of typos were spotted
-in the original infobot source and fixed in this version. Without infobot,
-there would be no blootbot so all thanks to kevin for bringing infobot in
-the first place.
-
-FEATURES
- * Additional information stored with factoids. (factinfo)
- * Wide range of statistics for Bot, Factoids, IRC, Debian.
- (status, factstats, ircstats, chanstats, cmdstats)
- * Advanced topic management. (the first cool feature)
- * Improved factoid search, allowing search by key or value.
- * Freshmeat support (freshmeat.net)
- * Debian Contents and Packages, search and info.
- * ChanServ/NickServ (OPN) support.
- * WWW-Search (eg: google for BLAH)
- * Slashdot, Kernel and Freshmeat auto-update announcements.
- * Units conversion (provided by external module, Units-Module)
-
- DESIGN
- - Modularity. Ability to disable IRC or Factoid support.
- - Funky pseudo Module autoloader support
- - Eleet Forker() function
-
-Improvements include:
- * log file is not opened and closed for each line of data
- => unblocked logging is used.
- * seen data is not flushed for each public message on IRC
- => caching and flushing over an interval is used.
-
-HISTORY
- As of 0.99pre1, blootbot supports mysql database in the hope to
-increase performance and to avoid borked over dbm's which occurred when
-the bot crashed (??). The mysql code is far larger (or perhaps twice
-as many functions) than expected even though a few functions were needed
-for DBM due to lack of table deficiencies.
-
- As of 1.0.0pre1, blootbot takes advantage of Net::IRC. The
-change over was fairly comfortable (95% clean). Just minor problems here
-and there, mostly debugging and getting it right.
-
- As of 1.0.0RC2, the old style DBM (Berkeley) has been ported
-back. It should work in all but 3 specific (countdown, factstats unreq)
-cases. preliminary pgsql support has been added but someone with pgperl
-knowledge needs to fix it up or at least unify the module with mysql.
-
-INSTALLATION
- - Read the included INSTALL file
-
-NOTICE
- Be warned that this bot consumes quite a lot of memory upon start
-up and during usage. Right now, 7.4megs is used for old'ish perl, 8.3megs
-with perl 5.005. fork() is used but don't be alarmed at the memory usage
-as fork(), as I was told, uses COW (copy on write).
-
- WARNING: enabling wingate support may involve complaints of some
-sort, probably because the telnet connection isn't closed properly.
-However, these people do not realize the potential of open wingates.
-
- Please beta test it and report bugs as I have not had the time to
-test all modifications properly (and extensively). Suggestions are
-welcomed.
-
- gp@OPN is currently working on a C version of infobot or
-blootbot, not based on the above source base. Core factoid code and
-mysql support works - but that is it.
-
-MODIFICATIONS
- All modifications are that of the blootbot author unless otherwise
-specified, like none. See 'ChangeLog' for details. A list of future
-features listed in 'TODO'.
-
- See 'USAGE' for complete list of commands with description
-(FIXME) and examples (FIXME). Yes, it is incomplete. It is better for
-you to find the cookies than for me to hand-feed them to you ;)
-
- See 'EXAMPLES' for various usage of factoids and "hidden"
-variables. If you're hardcore, check out 'CommandStubs.pl' and
-'UserExtras.pl' for cool features.
-
- topic [help] - Topic help.
- topic add <topic> - Append <topic> to the current topic.
- topic del <#> - Purge topic ID <#> from current topic.
- topic list - List broken down summary of current topic.
- topic mod s/old/new/ - Modify the topic using regex.
- - Now supports , and # as delimiters.
- topic mv <1> <type> <2> - <type>:
- before - Move <1> before <2>
- after - Move <1> after <2>
- swap - Swap <1> and <2>
- topic shuffle - Jumble the subtopics.
-
- topic history - Show previous channel topics.
- topic restore <#> - Restore channel topic to <#> on history
- #list.
-
-==> Individual commands: NEW
- (lobotomy|bequiet) -- [o] silence the bot.
- (unlobotomy|benoisy) -- [o] unsilence the bot.
-
- set <param> <value> -- ...
- unset <param> -- ...
-
-
-NOTES
- To administrate/control the bot remotely, this can only be done
-through DCC CHAT. /chat <BOT NICK>. All commands must be prepended by
-'.' otherwise it is sent to the bot chat net
-
-### UNTESTED:
- - user statistics shown by 'seen'. bug in this?
- - User Information Services.
- - new wingate caching/file-read code.
- - disabling IRC/factoid support code.
- - PG supports need to be worked and thoroughly tested.
-
-
-CONTRIBUTIONS
- jCommons, is, netgod, mu and Mercury for attempting to break my
-modifications, aswell as giving suggestions and ideas in the early
-development stages. Bashing of modifications courtesy of larne, irq, lilo
-and \broken.
-
- mu@OPN for the SAR (=~ s///) and Topic history patch.
-
- someone emailed me a patch to fix up telnet but I accidently
-deleted the message together with the patch after replying to the guy. I
-hope to get that same guy to re-send me the patch...
-
- MbM@OPN sent a patch to clean up behaviour of factoids
-(adding, removing, modifying). Thanks.
-
-
-CONTACT
- Contributions of a patch, or anything, can be sent to
-<dms@users.sourceforge.net>
-
-Some Documentation is on the website. Please see it for details or
-visit: http://sourceforge.net/docman/?group_id=8794
-
-IRC
- If your looking to hang out on IRC, feel free. We can be found
-in the #blootbot channel on irc.freenode.net. See you there!
+++ /dev/null
-See INSTALL file on how to install the bot.
-
-Quick usage instructions:
--------------------------
-
-DCC CHAT:
-.+chan #chan
-.chanset #chan +autojoin
-.chanset +autojoin
-.chanunset -autojoin
-.chanset -autojoin
-
-for list of configuration options, run:
- perl scripts/findparam.pl
+++ /dev/null
-TODO:
- - Normalize the SQL tables a little better to reduce size and increase speed
- - Keep the Changelog, TODO and BUGS files up to date. Clean things up a bit
- - rename ^[+-] commands
- - remind - like this and others: http://jibble.org/reminderbot/
- - kill SHM and and move to a pipe
- - add CIA like support - http://cia.navi.cx/
- - add pastebot like support - http://sial.org/pbot/
- - move nicks/server into sql table
- - make channel flags be server/channel flags
- - move channel flags to sql table, include initial state
- - move praise from blootbot.lang to "praise:<something>" in factoids?
- - move lart from blootbot.lang to "lart:<something>" in factoids?
- - debian BTS frontend "bugs"
- - !country
- - !dinstall
- - support DCC SEND of factoid (listkeys/listvals) that matched.
- - news: show total requested count, users "registered", users
- "ignored"
- - add notes about news redesign to accomodate individual items
- read - need to add id's to each item too.
- - bind DCC CHAT service to port.
- - man perlipc, search for service.
- - do forking aswell.
- - debian: "find -2.4.1" does not work but 2.4.1 does?
- - $debug var needed.
- - check if debian downloading files are proper.
- - verbose: say why config option was enabled/enabled.
- - registered flags for users/channels
- - end of DynaConfig.pl
- - use in UserDCC.. warn if value is not in list.
- - add &checkSet() or &_chanset();
- - attempt to move userDCC to hooks.
- - need to modify parseCmdHooks for user flags?
- - make timers below 5 or 10 mins non-random values.
- - create a .csv import/export program
--- EFFORT 1.
- - make IRC/Schedulers.pl work 100%.
- - intervals must be multiple of the smallest one otherwise
- auto-fixed.
- - make intervals chan-specific
- - need to store info in $sched{$what}{$chan} =
- time(); when last run or next run?
-
-Other TODO items may be listed on sourceforge. Please access it from the
-website or this link:
-http://sourceforge.net/pm/task.php?group_id=8794&group_project_id=3207&func=browse&set=open
-
-----------------------------------------------------
------------- FUTURE, NON-IMPORTANT
- - <greycat> ~country ua
- - <irq_w> xk: add it :) and my imdb feature :)
- - <greycat> xk: and ~bugs :)
- - "HACKING" text file, documentation of where things start,
- what "core" or reuseable functions are used and what for.
- - web interface
- - on join message - customizeable, option.
- - addon to UserInfo but for channels?
- - ^B's are removed (HOW?) from factoids.
- - asking questions.... make more guesses
- - throttling of "help topic": push-pull system of &msg().
- - use autoloader properly.
- - Module::<BLAH>::<CMD>
- - make a global autoloader.
- - support notification of author of deleted factoids,
- - flag to hide owner of factoid.
- - table data for DCC CHAT or misc table.
- - dynamic user//configuration file upgrade:
- - finer granuality(sp) of userlist/ignore file
- - <el_gore> apt, find netconfig -- merge similar files.
- - and same files(1 per package) for multiple packages.
- - merge partial similar paths together.
- - do some test cases to confirm code actually works as
- proposed.
-
--- useless statistics
-- 20010420:
-DEBUG: 373
-WARN: 129
-FIXME: 35
-status: 386
-TODO: 145
-
-20031111: scripts/output_stats.sh
-DEBUG: 384
-WARN: 167
-FIXME: 33
-status: 424
-ERROR: 123
-TODO: 91
-
-20050217: scripts/output_stats.sh
-DEBUG: 388
-WARN: 164
-FIXME: 43
-status: 436
-ERROR: 125
-TODO: 158
+++ /dev/null
-#!/usr/bin/perl
-
-# infobot -- copyright kevin lenzo (c) 1997-1999
-# blootbot -- copyright david sobon (c) 1999-infinity
-
-use strict;
-use vars qw($bot_base_dir $bot_src_dir $bot_misc_dir $bot_state_dir
- $bot_data_dir $bot_config_dir $bot_log_dir $bot_run_dir
- $bot_pid $memusage %param
-);
-
-BEGIN {
- if (@ARGV and -f $ARGV[0]) {
- # source passed config to allow $bot_*_dir to be set.
- do $ARGV[0];
- }
-
- # set any $bot_*_dir var's that aren't already set
- $bot_base_dir ||= '.';
- $bot_config_dir ||= 'files/';
- $bot_data_dir ||= 'files/';
- $bot_state_dir ||= 'files/';
- $bot_run_dir ||= '.';
- $bot_src_dir ||= "$bot_base_dir/src";
- $bot_log_dir ||= "$bot_base_dir/log";
- $bot_misc_dir ||= "$bot_base_dir/files";
-
- $bot_pid = $$;
-
- require "$bot_src_dir/logger.pl";
- require "$bot_src_dir/core.pl";
- require "$bot_src_dir/modules.pl";
-
- # load the configuration (params) file.
- &setupConfig();
-
- &showProc(); # to get the first value.
- &status("Initial memory usage: $memusage kB");
- &loadCoreModules();
- &loadDBModules();
- &loadFactoidsModules();
- &loadIRCModules();
-
- &status("Memory usage after loading modules: $memusage kB");
-}
-
-# prevent duplicate processes of the same bot
-&duperuncheck();
-
-# initialize everything
-&startup(); # first time initialization.
-&setup();
-
-if (!&IsParam("Interface") or $param{'Interface'} =~ /IRC/) {
- # launch the irc event loop
- &ircloop();
-} else {
- &cliloop();
-}
-
-exit 0; # just so you don't look farther down in this file :)
-
-# --- support routines
-
-# FIXME: add arguments, basically '-h' and '--help', heh.
-
-# added by the xk
-sub duperuncheck {
- my $pid = $$;
- my $file = $file{PID};
-
- if ( -f $file) {
- open(PIDFILE,$file) or die "error: cannot open $file.";
- my $thispid = <PIDFILE> || "NULL\n";
- close PIDFILE;
- chop $thispid;
-
- if ($thispid =~ /^\D$/) {
- &staus("warning: pidfile is invalid; wiping out.");
- } else {
- if ( -d "/proc/$thispid/") {
- &ERROR("bot is already running from this directory.");
- &ERROR("if this is incorrect, erase '*.pid'.");
- &ERROR("verify with 'ps -axu | grep $thispid'.");
- exit 1;
- } else {
- &status("warning: stale $file found; wiping.");
- }
- }
- }
-
- open(PIDFILE,">$file") or die "error: cannot write to $file.";
- print PIDFILE "$pid\n";
- close PIDFILE;
-
- return 0;
-}
-
-1;
+++ /dev/null
-# Revised: 20050224
-# Author: Tim Riker <Tim@Rikers.org>
-###
-
-main: I learn mainly by observing declarative statements such as "x is at http://www.xxx.com", and then reply when people ask things like "where can i find x?"
-
-action: This is used to override the usual response. "x is <action> does the hokey-pokey". When asked about x, the bot does this "* blootbot does the hokey-pokey"
-
-alternation: The || symbol in an entry causes an blootbot to choose one of the replies at random. "X is Y||Z" will produce "X is Y" or "X is Z" randomly.
-
-author: oznoid (mailto:lenzo@ri.cmu.edu) is my original author.
-
-dollar variables: D: To be used in factoids
-dollar variables: $Fdunno - ...
-dollar variables: $Fquestion - ...
-dollar variables: $Fupdate - ...
-dollar variables: $channel - channel from which the factoid was requested
-dollar variables: $date - current date (GMT)
-dollar variables: $day - day of week (full name, locale)
-dollar variables: $factoids - factoid count
-dollar variables: $host - hostname of factoid requester
-dollar variables: $ident - bot nick
-dollar variables: $lastspeaker - ...
-dollar variables: $memusage - ...
-dollar variables: $rand - random number, also $rand100.2
-dollar variables: $randnick - random nick
-dollar variables: $startTime - start time
-dollar variables: $time - current time (GMT)
-dollar variables: $uptime - ...
-dollar variables: $user - username of factoid requester
-dollar variables: $who - nick of factoid requester
-
-corrections: If I come back with "...but x is at http://xx.xx.xx" or something like that, and you want to change the entry, use "no, x is at http://sdfsdfsdf". The "No," tells me to supercede the existing value.
-corrections: you can append stuff to a factoid with "also". "x is also at ..."
-
-math: D: math expresions can be evaluated. This uses Perl syntax.
-math: E: 1+1
-math: + - add
-math: - - subtract
-math: * - multiply
-math: / - division
-math: ** - to the power
-math: pi - pi
-math: & - and
-math: | = or
-math: ^ - xor
-
-redirection: If a factoid x contains simply "<reply> see y", then when asked for x, I will deliver factoidor command result y instead.
-
-reply: There is a special tag, <reply>, that is used to override the usual response. Usually, a response is "X is Y", but it can be made "Y" by making the entry "X is <reply> Y".
-
-# now the commands...
-
-adduser: D: Administrative command to add new user to the .users file
-adduser: U: ## <user> <mask>
-adduser: E: ## bloot bloot!bloot@example.com
-
-addressing: It is a good idea if I stay in REQUIRE mode so that I won't yell out random crap if I listen in too hard. Currently there is no way to turn this off on-the-fly. (REQUIRE mode requires me to be addressed by name if I am to respond)
-
-babelfish: D: Frontend to babelfish translating service provided by http://babelfish.altavista.com/ Note that utf8 is used for non-ascii characters.
-babelfish: U: x <fromLang> <toLang> <words>
-babelfish: U: translate <fromLang> <toLang> <words>
-babelfish: E: x en de your cars rock
-
--ban: D: FIXME:
--ban: U: ## <mask|user>
--ban: E: ## *!*@owns.org
--ban: E: ## MoronMan
-
-+ban: D: FIXME:
-+ban: U: ## <mask|user> [chan] [time] [reason]
-+ban: E: ## *!*@owns.org #bots 60 stop flooding.
-+ban: E: ## *!*@*microsoft.com STOOPID
-+ban: E: ## MoronMan
-
-botmail: D: Send someone botmail
-botmail: U: ## {for <who>[:] <message>}|stats|check|read
-botmail: E: ## for infobot: you rock!
-botmail: E: ## stats
-botmail: E: ## check
-botmail: E: ## read
-
--chan: D: Leave a channel permanently
--chan: U: ## -#channel
--chan: E: ## -#botpark
-
-+chan: D: Join a channel permanently
-+chan: U: ## #channel
-+chan: E: ## #botpark
-
-chaninfo: D: Display channel statistics on Op, Ban, Deop, Unban, Part, Join, SignOff, PublicMsg, Kick and Topic
-chaninfo: U: ## [#channel]
-chaninfo: E: ##
-chaninfo: E: ## #botpark
-
-chanset: D: set a variable for a channel
-chanset: U: ## [#chan] [what] [val]
-chanset: E: ## #c +test
-chanset: E: ## #c -test
-chanset: E: ## #c test
-chanset: E: ## #c test 0
-chanset: E: ## #c test testing123
-
-chanunset: D: remove a variable from a channel
-chanunset: U: ## <#chan> [what]
-chanunset: E: ## #c
-chanunset: E: ## #c test
-
-chattr: D: Change flags on a user (see "help flags")
-chattr: U: ## <user> [flags]
-chattr: E: ## bloot +nmo
-chattr: E: ## bloot -ot
-chattr: E: ## bloot
-
-chnick: D: rename a nick (user) entry
-chnick: U: ## [nick] <new-nick>
-chnick: E: ## moron
-chnick: E: ## owner eleet
-
-chpass: D: Change a user's password
-chpass: U: ## [user] <pass>
-chpass: E: ## testing
-chpass: E: ## testing test0R
-
-contents: D: Debian Contents search only (no Packages)
-contents: U: ## <string> [dist]
-contents: E: ## strings.h
-contents: E: ## x11amp potato
-
-cookie: I can feed your appetite with random factoids.
-
-cpustats: cpustats dumps the bot's cpu usage this session
-
-crypt: It's good that you thought about encryption. I can do it for you.
-crypt: U: ## <salt> <string>
-crypt: E: ## 69 changeme
-crypt: E: ## $1$abcde changeme
-
-cycle: D: Causes me to cycle in the channel it's said, or in the named channel
-cycle: U: ## [channel]
-cycle: E: ##
-cycle: E: ## #botpark
-
-dauthor: D: Find Debian package maintainers, and list the packages they maintain
-dauthor: U: ## <string> [dist]
-dauthor: E: ## Wichert
-dauthor: E: ## Wichert potato
-
-dbugs: D: Show the current count of release critical bugs (latest versions)
-dbugs: U: ##
-
-deluser: D: Administrative command to remove a user from the .users file
-deluser: U: ## <user>
-deluser: E: ## bloot
-
-ddesc: D: Search the Description: lines in Debian packages
-ddesc: U: ## <string> [dist]
-ddesc: E: ## mule
-ddesc: E: ## mule potato
-
-dfind: D: Debian Packages (fallback to Contents) search
-dfind: U: ## <string> [dist]
-dfind: E: ## strings.h
-dfind: E: ## x11amp potato
-
-dict: D: DICT Protocol Client - likely dicts: elements web1913 wn gazetteer jargon foldoc easton hitchcock devils world02 vera
-dict: U: ## [entry num] <query>[/dict]
-dict: E: ## linux
-dict: E: ## 33 set/wn
-
-dns: D: Query DNS
-dns: U: ## <host|ip>
-dns: E: ## debian.org
-dns: E: ## 3.1.33.7
-
-do: D: operator command to do things in a channel
-do: U: ## <chan> <what>
-
-dstats: D: Show basic stats on the current size of the Debian distros
-dstats: U: ## [dist]
-dstats: E: ##
-dstats: E: ## potato
-
-factinfo: D: View statistical information about a particular factoid.
-factinfo: U: ## <factoid>
-factinfo: E: ## test
-
-factstats: D: Display statistical data (max of 15) about factoids.
-factstats: U: ## <type>
-factstats: == author -- top author of factoids.
-factstats: == deadredir -- ??
-factstats: == duplicate -- duplicate factoids.
-factstats: == listfix -- ??
-factstats: == locked -- locked factoids.
-factstats: == new -- recent addition of factoids.
-factstats: == nullfactoids -- ??
-factstats: == partdupe -- initial partial duplicate factoids.
-factstats: == profanity -- possibly offensive factoids.
-factstats: == redir -- redirection in factoids.
-factstats: == reqrate -- ??
-factstats: == requested -- most requested factoids.
-factstats: == requesters -- most requested factoids.
-factstats: == seefix -- ??
-factstats: == toolong -- factoid {key|value} exceeding specified length.
-factstats: == tooshort -- factoid {key|value} shorter than specified length.
-factstats: == total -- ??
-factstats: == unrequest -- unrequested factoids.
-factstats: == vandalism -- ??
-factstats: E: ## new
-
-forget: If I have an old/redundant factoid x, "forget x" will cause me to erase it.
-
-freshmeat: D: Frontend to www.freshmeat.net
-freshmeat: U: ## <query>
-freshmeat: E: ## blootbot
-
-hex: D: Convert ascii to hex
-hex: U: ## <string>
-hex: E: ## carrot
-
-httpdtype: D: Get httpd server software version / configuration
-httpdtype: U: ## <hostname>
-httpdtype: E: ## example.com
-
-ignore: D: ignore list management
-ignore: E: ## [mask chan expire comment]
-ignore: E: addignore guu!*@*
-
-ircstats: ircstats dumps some status information on the bot's IRC connection
-
-join: U: ## <#chan> [key]
-join: E: ## #botpark
-join: E: ## #botpark rules
-
-karma: Karma is a community rating system. Use "X++" to increase the karma, or "X--" to decrease it. Ask for ratings using "karma for X?"
-
-kernel: D: Frontend to linux.kernel.org's finger response.
-kernel: U: ##
-
-kick: U: ## <nick> [#chan] [message]
-kick: E: ## oznoid
-kick: E: ## larne #botpark
-kick: E: ## john #foo go away!
-
-lart: D: Luser Attitude Readjustment Tool
-lart: U: ## [#chan] <who>
-lart: E: ## lenzo infobot's bugginess
-lart: E: ## #perl everyone perl \=\= lamerville
-
-lc: D: lower case a given string
-lc: U: ## <string>
-lc: E: ## When will blootbot achieve world domination?
-
-listauth: D: Search the factoid extension db by creator
-listauth: U: ## <search>
-listauth: E: ## xk
-
-listkeys: D: Search the factoid database by key (factoid)
-listkeys: U: ## <regex>
-listkeys: E: ## blootbot
-
-listvalues: D: Search the factoid database by value (description)
-listvalues: U: ## <regex>
-listvalues: E: ## blootbot
-
-literal: used to get a raw factoid contents. Use _default to ignore factoidSearch path.
-literal: U: ## [_default|prefix] <factoid>
-literal: E: ## blootbot
-
-lobotomy: I can be given a lobotomy ([o] is required) if people start to abuse me. To bring me back to life, give me an unlobotomy
-
-lock: D: Factoid locking to prevent removal by others
-lock: U: ## <factoid>
-lock: E: ## abuse
-lock: N: By default, only registered "ops" on the bots or factoids matching the user's nick are able to lock factoids.
-lock: N: Requires factoid extension (extra) support enabled.
-
-md5: D: calculates the md5sum of a given string
-md5: U: ## <string>
-md5: E: ## When will blootbot achieve world domination?
-
-mode: set modes for a channel
-mode: U: ## <#chan> <mode>
-mode: E: ## #botpark +t
-mode: E: ## #botpark -i
-
-news: D: News functions
-news: U: ## [chan] <add,del,mod,set,latest,read,help>
-
-news add: D: Add news items
-news add: U: news [chan] add <title>
-news add: E: news add This is a test
-news add: see _news set Text_ aswell
-
-news set: D: Set stuff for news item
-news set: U: news [chan] set <item> <what> [value]
-news set: valid <what>: Expire, Text
-news set: E: news set 1 Text ok, this works
-news set: E: news set test Text and this is a test
-news set: E: news set test Text
-
-news set expire: D: Set expire for news item
-news set expire: U: news [chan] expire <what> <value>
-news set expire: value can be: Xd Xh Xm Xs
-news set expire: value can be: never
-news set expire: news expire 1 3days
-news set expire: news expire 2 +20d
-news set expire: news expire Test 30d 20h 10m 5s
-news set expire: news expire TEST never
-
-news del: D: Delete news item (requires +o or be author)
-news del: U: news [chan] del <item>
-news del: E: news del 1
-news del: E: news del test
-
-news mod: D: Modify a news item (todo: modify Text aswell)
-news mod: E: news [chan] mod <item> s/<from>/<to>/[g]
-news mod: E: news mod 1 s/test/Test/
-news mod: E: news mod test s/test/Test/g
-
-nickometer: D: Measures the lame-ness of a nick or channel
-nickometer: U: ## {nick,channel}
-nickometer: E: ## unknown_lamer
-nickometer: E: ## #botpark
-
-onjoin: D: get/set OnJoin message (needs chan option +OnJoin)
-onjoin: U: ## [#chan|_default] [-]<nick> [message]
-onjoin: E: ## blootbot Hey! It's another blootbot!
-
-ord: D: Convert ascii to decimal
-ord: U: ## <single character>
-ord: E: ## c
-
-page: D: Send someone a pager message
-page: U: ## <who> <message>
-page: E: ## infobot you rock!
-page: NOTE: this uses the "<who>'s pager" factoids for the From: and To: addresses of the format "example's pager" is "mailto:me@example.com"
-
-part: D: Leave a channel (DCC only)
-part: U: ## <#channel>
-part: E: ## #botpark
-part: NOTE: /kick is an alternative
-
-piglatin: D: translates english text into piglatin
-piglatin: U: ## <string>
-piglatin: E: ## When will blootbot achieve world domination?
-
-quote: D: Frontend to yahoo's online stock market share listing
-quote: U: ## <query...>
-quote: E: ## RHAT,MSFT
-
-rename: D: Factoid renaming
-rename: U: ## 'from' 'to'
-rename: E: ## 'infobot' 'blootbot'
-
-reverse: D: reverses a given string
-reverse: U: ## <string>
-reverse: E: ## When will blootbot achieve world domination?
-
-rot13: D: ROT13's a given string
-rot13: U: ## <string>
-rot13: E: ## guvf vf n ynzr rknzcyr
-
-say: D: operator command to say things in a channel
-say: U: ## <chan> <what>
-
-scramble: D: scrambles a given string
-scramble: U: ## <string>
-scramble: E: ## When will blootbot achieve world domination?
-
-search: U: ## <engine> for <string>
-search: E: ## google for blootbot
-
-seen: D: Report last seen time for somebody
-seen: U: ## <nick>
-seen: E: ## blootbot
-
-slashdot: D: News for nerds, Stuff that matters. [tm] (shows the headlines)
-slashdot: U: ##
-
-spell: You've guessed it right, I'm a spell checker. Give me any word and I can confirm whether it's good or bad.
-
-status: status dumps general status information
-
-tell: D: Tell someone about a factoid or command
-tell: U: ## <who> -?about <what>
-tell: E: ## me about blootbot
-tell: E: ## someone -about testing
-
-topic add: D: Add your own topic
-topic add: U: ## <topic>
-topic add: E: ## This is a test
-
-topic del: D: Delete one or two subtopics
-topic del: U: ## <#>
-topic del: E: ## 1
-topic del: E: ## 1-3,5
-topic del: E: ## last
-
-topic mod: D: Search and replace strings in the topic
-topic mod: U: ## <REGEX>
-topic mod: E: ## s/test/TEST/
-topic mod: E: ## s#msg test#/msg test#g
-
-topic mv: D: Move subtopics around.
-topic mv: U: ## <#> <before|after|swap> <#>
-topic mv: E: ## 1 after 2
-topic mv: E: ## first before last
-
-topic restore: D: Restores the topic to an earlier version
-topic restore: U: ## <#>
-topic restore: E: ## 3
-
-topic: Usage for 'topic [#chan] <params>':
-topic: ---------------- __Subtopic__:
-topic: add <TOPIC> - Append <TOPIC> to topic.
-topic: del <#> - Remove subtopic <#> from topic.
-topic: list - Display subtopics.
-topic: mod s/old/new/ - Search and replace topic.
-topic: mv <ARGS> - 'topic mv'.
-topic: shuffle - Randomly organize subtopics.
-topic: ---------------- __Topic__
-topic: history - Show previous topics.
-topic: restore <#> - Restore topic to <#>.
-topic: rehash - Rehash changes to topic.
-topic: info - Who and time info.
-topic: ---------------- __Misc__
-topic: about - Read the file :)
-topic: help - This screen.
-
-topic: NOTE: #chan arg is only required if command is sent over private message to nick, otherwise it is not needed if sent to the channel.
-topic: NOTE: commands can be preceeded? with '-' in order not to enforce changes to topic.
-topic: End of help.
-
-uc: D: upper case a given string
-uc: U: ## <string>
-uc: E: ## When will blootbot achieve world domination?
-
-unforget: If a factoid has been forgotten, "unforget x" will cause me to unerase it.
-
-unlobotomy: Not possible in real life, an unlobotomy will bring me back to life in the case of a lobotomy.
-
-unlock: D: Factoid unlocking to allow removal by others.
-unlock: U: ## <factoid>
-unlock: E: ## abuse
-
-uptime: D: Show the current uptime, and the top 3 uptimes recorded
-uptime: U: ##
-
-wantnick: If someone's taken my nick (I hope not) and I'm using some temporary nick, I can change back to my original nick if it's not taken (again).
-
-wikipedia: D: Frontend to the Wikipedia at http://www.wikipedia.org/wiki/ Note that utf8 is used for non-ascii characters.
-wikipedia: U: ## <topic>
-wikipedia: U: wiki <topic>
-wikipedia: E: wiki irc
-
-wtf: D: Interface to the BSD wtf command
-wtf: U: ## <abbreviation>
-wtf: E: ## iirc
-
--host: D: admin command to remove hostmask from a user account
--host: U: ## [user] <mask>
--host: E: ## *!*@owns.org
--host: E: ## owner leet!leet@*.heh.org
-
-+host: D: admin command to list or add hostmasks to a user account
-+host: U: ## [user] [<mask>]
-+host: E: ## owner
-+host: E: ## *!*@owns.org
-+host: E: ## owner leet!leet@*.heh.org
-
-flags: D: Flags for chattr command
-flags: D: "A" - bot administration over /msg (default is only via DCC CHAT)
-flags: D: "O" - dynamic ops (as on channel). (automatic +o)
-flags: D: "T" - add topics.
-flags: D: "a" - ask/request factoid.
-flags: D: "m" - modify factoid. (includes renaming)
-flags: D: "n" - bot owner, can "reload"
-flags: D: "o" - master of bot (automatic +amrt)
-flags: D: - can search on factoid strings shorter than 2 chars
-flags: D: - can tell bot to join new channels
-flags: D: - can [un]lock factoids
-flags: D: "r" - remove factoid.
-flags: D: "t" - teach/add factoid.
-
+++ /dev/null
-# blootbot.lang: configurable responses.
-# by the xk.
-###
-
-# Welcome reply: Things to say when people thank me.
-welcome
- no problem
- my pleasure
- sure thing
- no worries
- de nada
- de rien
- bitte
- pas de quoi
- gern geschehen
-
-# Dunno reply (when i recognize a query but can't answer it):
-dunno
- i don't know
- i haven't a clue
- no idea
- wish i knew
- bugger all, i dunno
- I give up, what is it?
- I don't know, could you explain it?
- I'm not sure, is it larger than a breadbox?
- parse error: dunno what the heck you're talking about
- are you using Windows?
- I wish you would RTFM.
- have you tried http://www.tldp.org/ ?
- KCI error, or a problem with the Keyboard-Chair Interface.
-
-# moron reply.
-moron
- You think I'm human? Think again!
- h0 h0 h0
- Hi, how's life?
- What do you want?
- Are you on drugs?
- Wassup G?
-
-# confuse/refuse learn.
-confused
- I think you lost me on that one
- what are you talking about?
-
-# Hello reply (ways to say hello):
-hello
- hello
- hi
- hey
- niihau
- bonjour
- hola
- salut
- que tal
- privet
- what's up
- moin moin
-
-# Cookie reply: added by the xk.
-cookie
- ACTION spins the wheel of knowledge and ponders... ##KEY... ##VALUE
- ACTION pulls out the cookie jar and finds ##KEY... ##VALUE
- Hey ##WHO, ##KEY is ##VALUE
-
-# Factoid reply:
-factoid
- methinks ##KEY is ##VALUE
- i heard ##KEY is ##VALUE
- i guess ##KEY is ##VALUE
- from memory, ##KEY is ##VALUE
- hmm... ##KEY is ##VALUE
- ##KEY is probably ##VALUE
- ##KEY is, like, ##VALUE
- rumour has it, ##KEY is ##VALUE
- it has been said that ##KEY is ##VALUE
- somebody said ##KEY was ##VALUE
- well, ##KEY is ##VALUE
- extra, extra, read all about it, ##KEY is ##VALUE
- [##KEY] ##VALUE
-
-# HowAreYou reply:
-howareyou
- eh, ok
- peachy
- just great
- you know how it is...
- pretty good. how about you?
- mas o menos
-
-# Question word.
-qWord
- who
- who is
- who are
- what
- what's
- what is
- what are
- where
- where's
- where is
- where are
-
-# botsnack etc praise
-# TODO add ACTION support
-praise
- :)
- thanks
- aw, gee
+++ /dev/null
-
-#
-# lart info by ejb (larne) and cerb.
-#
-
---purges WHO
-accelerates a free AOL cd to 50,000 rpm and lets WHO feel it
-acting on orders from an unspecified client drags WHO into court suing for $200 million
-beats the living hamstercrap out of WHO
-beats WHO into protomatter with the andromeda galaxy
-beats WHO over the head with a microkernel
-beats WHO senseless with a 50lb Unix manual
-beats WHO severely about the head and shoulders with a rubber chicken
-beats WHO to within 2.54cm of his life
-blames WHO for all the evil in the world
-blasts WHO to oblivion with a kamehameha wave
-blasts WHO with a huge firehose then strangles WHO with it
-brandishes Excalibur! "With this sword, I vanquish thee, WHO!" and lops off WHO's head
-breaks out the Hoover and sucks up WHO
-burns WHO to a crisp with a laser
-calls WHO on the phone ... the lights are on but nobody's home
-cats /dev/urandom into WHO's ear
-changes WHO's permissions to 0777 and tells the world
-chops WHO in half with a free AOL CD
-chops WHO in half with a free Solaris 7 CD
-crushes WHO with a full height scsi disk
-cuts off WHO's head with a halberd that could have been a little bit sharper
-cuts WHO into thin stripes
-decapitates WHO conan the destroyer style
-declares WHO a moron
-does a little 'dpkg -P WHO' action
-does a little 'renice 20 -u WHO'
-DoSes WHO
-drops a baby grand on WHO
-drops a humongous exploding nuke on WHO
-drops a truckload of VAXen on WHO
-duct-tapes WHO to the floor and drools on him
-dumps 42 tons of dirt, manure, and fish heads on WHO
-eats WHO and falls over dead
-eats WHO's liver with some fava beans and a nice chianti
-executes killall -HUP WHO
-executes killall -KILL WHO
-executes killall -TERM WHO
-explains, ever so gently, that if WHO doesn't give the channel more information, they can't help
-farts in WHO's general direction
-flings poo at WHO
-follow's WHO with a gauntlet and ... scratch ... HUMILIATION
-forces WHO to use Outlook Express
-frags WHO with his BFG9000
-gets a hotmal account and SPAMs WHO
-gives WHO a "free" copy of Windows and then charges double for "Upgrades"
-gives WHO a good seeing to
-gives WHO an extra strength ACME sleeping pill, sending WHO to sleep for 150 years, and awakening to seven strange dwarfs and a large apple
-grabs a large, mis-shapened log, with squirrels, and beats WHO until only the nuts remain ... which the squirrels run off with
-hauls WHO up by the scruff of the neck and spanks him until he waddles
-hereby declares WHO a troll
-hits WHO with an anvil and laughs with a contralto voice ... Haha Ha HA Ha
-holds WHO to the floor and spanks him with a cat-o-nine-tails
-hooks into a hydrant and hoses WHO down
-hurls dozens of incontinent, insomniac, hungry kittens with tiny little razor-sharp claws and a wide variety of contagious intestinal parasites at WHO
-installs a bad bootloader on WHO and turns WHO into a brick
-installs PocketPC on WHO's PDA
-judo chops WHO
-keeps mailing WHO free America Online CDs until he drowns
-lowers WHO's priority
-makes a balloon animal out of WHO
-moos at WHO
-nabs the moon and broadsides WHO with the sea of tranquility
-nukes WHO with a single large nuke
-offers WHO some herring
-overclocks WHO until WHO burns out
-plops WHO into a giant vat of herring
-pours gasoline all over WHO, ignites the fire, and then enjoys some toasty marshmallows with the glorious blaze
-pours hot grits down the front of WHO's pants
-pries WHO's back open with a screwdriver and flashes a new bootldr to WHO
-pulls out a ClueBat (tm) and thwaps WHO
-pulls out his louisville slugger and uses WHO's head to break the homerun record
-pushes the wall down onto WHO whilst whistling innocently
-puts on a hockey mask and jumps out at WHO
-puts on some milking gloves. "All right, now, WHO, this won't hurt a bit...."
-puts WHO into a headlock and administers a mighty noogie, rubbing half of WHO's hair of
-puts WHO through a wood chipper
-raises middle finger to WHO
-readies the nuke launcher and fires some rounds at WHO
-resizes WHO's terminal to 40x24
-rm -rf's WHO
-runs at WHO with an origami Swiss Army knife, and inflicts a nasty paper cut
-says "boot to the head" and knocks WHO over
-send killer squirrels to attack WHO
-sends a legion of lawyers after WHO's head
-shoots WHO in his sleep
-shoots WHO in the head
-shoves a crumpet down WHO's throat, happy now?! Huh? Want some JAM with that?
-slams WHO against a large cement Tux
-slaps a compatible dib on WHO's head
-slaps WHO around with a large trout
-slaps WHO upside and over the head with one freakishly huge killer whale named hugh
-slaps WHO upside the head with a wet fish
-smacks WHO up side the head with a clue-by-4
-squeezes WHO till WHO turns blue like papa smurf
-squishes WHO like a bug
-stabs WHO
-stamps WHO on the forehead with the official Troll marker
-steals WHO's mojo
-strangles WHO with a 9-pole serial cable
-strangles WHO with a doohicky mouse cord
-stuffs WHO into a shiny new tin can and vacuum seals it
-takes a big bite out of WHO's jugular vein
-takes a large goose feather pillow and swings it wildly in WHO's direction, hitting WHO and sending WHO flying into the closet
-takes a rusty axe and swings it violently, taking WHO's head off
-takes large quantities of Krispy Kream donuts and stuffs them one after another down WHO's throat until WHO puts on 150lbs
-takes out a cattle prod and gives WHO a good jolt
-takes out a seltzer bottle and sprays WHO in the face. You know, one of those old-school seltzer bottles clowns have? Yeah those. Anyway, consider yourself spritzed
-takes out WHO with the trash
-takes WHO to the vet for a "special" visit
-teaches WHO that M$ Access is a database. No, really, a database. A real live multi-user... well, ok, not multi-user, but a database. Yeah, that sounds right.
-teaches WHO the basics, including how to RTM
-throws a AN/M-8 smoke grenade at WHO
-throws WHO's poor little doggy off a cliff
-tries to shut WHO up
-turns WHO into a lifesized tux doll
-urinates on WHO
-wallops WHO with a main rotation server that needs rehubbing. It won't take long
-whacks WHO upside the head
-whacks WHO with a giant beaver's tail
-whacks WHO with the cluebat
-whips out a hot clue gun and makes sure that WHO is stuck to the floor
-whips out a shotgun, trudges over to WHO, and goes postal
-whips out a sword and chops WHO in half
-whips out his power stapler and staples WHO's foot to the floor
-whips WHO with a wet and grimy noodle just because
+++ /dev/null
-He who controls the source controls the universe!
-Want to see a listing of files installed by a package, type dpkg -L package
-Need to know the status of a package? type dpkg -s package
-Need help, but everyone is idle in the channel, try emailing to debian-user@lists.debian.org
-Need to see the list of packages matching a pattern, type dpkg -l pattern
-If you have a webserver and dww packages installed, try http://localhost/dwww for all kinds of documentation
-Need help setting up PPP? read /usr/doc/ppp/README.debian
-Want to know why Debian is best? type !why in the channel
-Want to upgrade to hamm (unstable)? type !libc6 to get the mini-HOWTO
-Want to check out Debian social contract? type !dfsg in the channel
-Warning: Dates in Calendar are closer than they appear.
-Daddy, why doesn't this magnet pick up this floppy disk?
-Give me ambiguity or give me something else.
-I.R.S.: We've got what it takes to take what you've got!
-We are born naked, wet and hungry. Then things get worse.
-Pentiums melt in your PC, not in your hand.
-Suicidal twin kills sister by mistake!
-Did anyone see my lost carrier?
-Make it idiot proof and someone will make a better idiot.
-I'm not a complete idiot, some parts are missing!
-He who laughs last thinks slowest!
-Always remember you're unique, just like everyone else.
-'More hay, Trigger?' 'No thanks, Roy, I'm stuffed!'
-A flashlight is a case for holding dead batteries.
-Lottery: A tax on people who are bad at math.
-There's too much blood in my caffeine system.
-Artificial Intelligence usually beats real stupidity.
-Hard work has a future payoff. Laziness pays off now.
-Friends help you move. Real friends help you move bodies.
-I won't rise to the occaasion, but I'll slide over to it.
-Ever notice how fast Windows runs? Neither did I.
-Double your drive space - delete Windows!
-What is a 'free' gift ? Aren't all gifts free?
-If ignorance is bliss, you must be orgasmic.
-'Very funny, Scotty. Now beam down my clothes.'
-Puritanism: The haunting fear that someone, somewhere may be happy.
-Consciousness: that annoying time between naps.
-Oops. My brain just hit a bad sector.
-I used to have a handle on life, then it broke.
-Don't take life too seriously, you won't get out alive.
-I don't suffer from insanity. I enjoy every minute of it.
-Better to understand a little than to misunderstand a lot.
-The gene pool could use a little chlorine.
-When there's a will, I want to be in it.
-Okay, who put a 'stop payment' on my reality check?
-Few women admit their age. Few men act theirs.
-I'm as confused as a baby in a topless bar.
-We have enough youth, how about a fountain of SMART?
-All generalizations are false, including this one.
-Change is inevitable, except from a vending machine.
-C program run. C program crash. C programmer quit.
-'Criminal Lawyer' is a redundancy.
-Clap on! (clap, clap) Clap off! (clap@#&$NO CARRIER
-'640K ought to be enough for anybody.' Bill Gates '81
-'90% of all statistics are made up'
-'A fanatic is one who can't change his mind and won't change the subject.'
-'A little work, a little sleep, a little love and it is all over.' - R. Frost
-'A lot of people mistake a short memory for a clear conscience.' -Doug Larson
-'Apple' (c) 6024 b.c., Adam & Eve
-'Apple' (c) Copyright 1767, Sir Isaac Newton.
-'Bad knee, gotta run' - Pat Buchanan to his draft board
-'Beam me aboard, Scotty.' 'Sure. Will a 2x10 do?'
-'Beulah, peel me a grape.'
-'Bother,' said Pooh as the brakes went out!
-'Build a watch in 179 easy steps' by C. Forsberg.
-'C++' should have been called 'D'
-'COINCIDENCE' happens.
-'Calvin, we will not have an anatomically correct snowman!'
-'Careful. We don't want to learn from this.' -- Calvin
-'Don't you hate it when your boogers freeze?' -- Calvin
-'Every time I've built character, I've regretted it.'
-'Freedom defined is freedom denied.' -The Illuminatus
-'Have you ever dated somebody because you were too lazy to commit suicide?'
-'Hi-ho, hi-ho, it's hand grenades I throw...'
-'Hmm... How *did* they finally kill Frosty?' -- Hobbes
-'Human equality is a contingent fact of history.' -Steven Jay Gould
-'I tried to think but nothing happened!' - Curly
-'I'm not an actor, but I play one on TV'
-'I'm not smart enough to lie' - Ronald Reagan
-'If I knew what I was doing...I'd be dangerous...'
-'If the shoe fits, buy it.' Imelda Marcos
-'Instant gratification takes too long.' - Carrie Fisher
-'Is' is the verb for when you don't want a verb.
-'It is not the fall that kills you. it's the sudden stop at the end.'-D. Adams
-'It's sad how whole families are torn apart by simple things, like wild dogs'
-'Keyboard? How quaint!' - Scotty
-'Luke... Luke... Use the MOUSE, Luke' - Obi Wan Gates
-'Mr. Worf, blow the Windows-powered Borg ship out of this Universe!'
-'Off the keyboard, thru the router, over the bridge, nothing but net!'
-'Quotations are for people who are not saying things worth quoting.'
-'Remember when we said there was no future? Well, this is it.' -- Blank Regk
-'Stupid' is a boundless concept.
-'Suicide Hotline...please hold.'
-'The faster you go, the shorter you are' - Einstein
-'The reports of my death have been greatly exaggerated.' - Mark Twain
-'The sun ain't yellow, its chicken.' -Bob Dylan
-'There are lies, damned lies, and statistics.' -Mark Twain
-'There's someone in my head, but its not me.' -Pink Floyd
-'This is a job for.. AACK! WAAUGHHH!! ...someone else.' -
-'To err is human, to forgive....$5.00'
-'Ummm, Trouble with grammar have I! Yes!' -Yoda-
-'Vote for Perot' - Bumper sticker attached with Velcro
-'You can't have everything. Where would you put it?' -Steven Wright
-#1 OS/2 tip: Drag the Windows folder to the shreader!!!
-#include std/disclaimer.h
-$$$ not found -- (A)bort (R)efinance (B)ankrupt
-'Tis better to be thought a fool, then to open your mouth and remove all doubt
-(((((This tagline in Stereo where available)))))
-(A)bort (R)etry (C)ut Your Throat.....
-(A)bort (R)etry (F)ail (U)nplug & (S)ell.
-(A)bort (R)etry (P)ull leg (H)ot boot (S)wipe tagline!
-(A)bort, (R)etry, (I)nfluence with large hammer
-(A)bort, (R)etry, (P)retend this never happened...
-(D)inner not ready: (A)bort (R)etry (P)izza
-(You can have your cake) XOR (You can eat your cake)
-(c) Copywight 1995 Elmer Fudd. All wights wesewved.
-* OLX 3 * Windows is to OS/2 what Etch-a-Sketch is to art.
-*Four hours* to bury a cat? Yes - it wouldn't keep still
-.. Bugs come in through open Windows.
-... 'I'll be Bach.' - Johann Sebastian Schwarzenegger
-... All the world's a stage, and I missed rehearsal.
-... Bill Clinton isn't slick. He's just a liar.
-... Clinton Economics: If 1+2=3 then 4+5=6.
-... Clinton excuse #15: Hey - I just do what the wife says
-... Clinton excuse #18: You took that seriously? Har har
-... Clinton sandwich: $5 of baloney and $20 in taxes
-... Getting the truth from Clinton is like nailing Jello
-... It's tourist season in Florida, bag limit two.
-... KARAOKE is Japanese for 'Tone Deaf'
-... Some days you're the dog, some days you're the hydrant
-.....If it ain't broke, fix it anyway just to screw it up!
-...I'm sorry, Reality is not in service at this time.
-...On the other hand, you have different fingers.
-..Windows NT Performance', on the next 'In Search Of'
-/EARTH is 98% full. Please delete anybody you can
-1 + 1 = ? Ask my calculator.
-10 out of 5 doctors feel it's OK to be schitzo!
-1200 bps used to seem so fast
-186,000 miles/sec: Not just a good idea, it's the LAW.
-1st rule of intelligent tinkering - save all the parts
-2 + 2 = 4 (for the time being).
-2 + 2 = 5 (for sufficiently large values of 2)
-3 out of 4 Americans make up 75% of the population.
-43% of all statistics are worthless.
-43rd Law of Computing: Anything that can go wr...
-5 schizophrenics agree!
-50 states, and I had to pick this one...
-668 - Neighbor of the Beast
-90% of being smart is knowing what you're dumb at.
-<<< Tagline deleted by Natl Endowment for the Arts >>>
-==/==/==/==Police tagline==/==/==Do not cross ==/==/==/==
-From my brain, an organ with a mind of it's own.
-From the Department of Redundancy Dept.
-A BBSer's telephone bill knows no bounds...
-A Bugless Program is an Abstract Theoretical Concept.
-A Metaphor is like a Simile.
-A Smith & Wesson *ALWAYS* beats 4 Aces.
-A big enough hammer fixes anything
-A bird in the hand can be messy.
-A camel is a horse planned by committee.
-A chicken is an egg's way of producing more eggs.
-A clean desk is a sign of a cluttered desk drawer.
-A closed mind gathers no intelligence
-A closed mouth gathers no feet.
-A committee has 6 or more legs and no brain.
-A conscience does not prevent sin. It only prevents you from enjoying it.
-A critic is a man who leaves no turn unstoned.
-A cynic smells flowers and looks for the casket.
-A day for firm decisions! Or is it?
-A day not wasted is a day wasted!
-A day without radiation is a day without sunshine.
-A day without sunshine is like night.
-A diplomat thinks twice before saying nothing.
-A dirty book is rarely dusty.
-A fool and his money are soon SYSOP.
-A fool and his money rarely get together to start with.
-A fool must now and then be right by chance.
-A friend in need is a pest indeed...
-A friend: someone who likes you even after they know you.
-A good way to deal with predators is to taste terrible.
-A half moon is better than no moon at all.
-A harp is a nude piano.
-A hunch is creativity trying to tell you something.
-A library is an arsenal of liberty.
-A life lived in fear is half a life lived.
-A little greed can get you lots of stuff.
-A little inaccuracy sometimes saves tons of explanation.
-A living example of Artificial Intelligence.
-A man needs a good memory after he has lied.
-A man's best friend is his dogma.
-A man, a plan, a canal. Suez!
-A mind is a terrible thing to taste.
-A mind is a terrible thing to ugg.. I forgot..
-A neat desk is a sign of a sick mind.
-A pedestrian hit me and went under my car.
-A penny saved is a Governmental oversight.
-A perversion of nature....how exciting!
-A pessimist is never disappointed.
-A phaser on stun is like a day without orange juice.
-A rolling stone gathers momentum.
-A seminar on Time Travel will be held two weeks ago.
-A single fact can spoil a good argument.
-A stitch in time would have confused Einstein.
-A truly wise man never plays leapfrog with a moose.
-A waist is a terrible thing to mind.
-A yer ago I kudnt spel progremr now I are won.
-ASCII and ye shall receive.
-ASCII stupid question... get a stupid ANSI!
-Abandon all hope ye who have entered cyberspace.
-Afraid of heights? Not me, I'm afraid of widths!
-Agnodyslexic plea: 'why ME, dog?'
-Air conditioned environment - Do not open Windows.
-Alex, I'll take 'Things Only I Know' for $1000.
-All E-mail gladly received. Offensive reply ASAP.
-All I ask for is the opportunity to prove that money can't make me happy.
-All I need to know I learned from my cat.
-All I want is a warm bed, a kind word and unlimited power
-All generalizations are bad.
-All generalizations are false, including this one.
-All hope abandon, ye who enter messages here.
-All in a day's work for...'Confuse-a-Cat'!
-All in all it's just a... 'nother brick in the wall!
-All life's answers are on TV. - Bart Simpson
-All programers are optimists.
-All that glitters has a high refractive index.
-All the easy problems have been solved.
-All things are green unless they are not.
-All wiyht. Rho sritched mg kegtops awound?
-All words are pegs on which to hang ideas.
-All work and no play, will make you a manager.
-All you need to be a fisherman is patience and bait.
-Almost went crazy. Would have been a real short trip.
-Alone: In bad company.
-Always draw your curves, then plot the data.
-Always forgive your enemies, nothing annoys them so much.
-Always glad to share my ignorance - I've got plenty.
-Always proofread carefully to see if you any words out.
-Always remember no matter where you go, there you are.
-Alzheimers advantage: New friends every day.
-Ambition is the last refuge of the failure.
-America Good Place to Put Chinese Restaurant.
-Amusement is the happiness of those who cannot think.
-An Elephant; A Mouse built to government specifications.
-An egotist thinks he's in the groove when he's really in a rut.
-An elephant is a mouse with an operating system.
-An idle mind is worth two in the bush.
-An ounce of application is worth a ton of abstraction.
-An ounce of emotion is equal to a ton of facts.
-An oyster is a fish built like a nut.
-An ulcer is what you get mountain climbing over molehills.
-An unbreakable toy is useful for breaking other toys.
-An unemployed court jester is no one's fool.
-And don't start a sentence with a conjunction.
-And he disappeared in a puff of logic.
-And if one bad cluster should accidentally fail...
-And it's only ones and zeros.
-And now for something completely different...
-And now for something completely the same...
-And tomorrow will be like today, only more so.
-And, the driver compresses EVERYTHING, not just EXE & COM
-Angels can fly because they take themselves so lightly.
-Anger blows out the lamp of the mind.
-Another case of Cherry Coke down the programming hatch!
-Answers: $1 * Correct answers: $5 * Dumb looks: Free! *
-Antidisestablishmentarianism!
-Any closet is a walk-in closet if you try hard enough.
-Any fool can criticize, condemn, & complain. And most do.
-Any philosophy that can be put in a nutshell belongs there
-Any wire cut to length will be too short.
-Anything worth doing, is worth doing for a profit.
-Are we having Fahrvergn\ 1ugen yet??
-Are ya feelin' lucky, punk?!! - Harry Callahan
-Are you really American if your ethnicity has to be hyphenated?
-Are you suggesting that coconuts migrate?
-Armageddon means never having to say you're sorry.
-Artificial Intelligence is no match for natural stupidity.
-As I said before, I never repeat myself.
-As a matter of fact, no, I don't have a life.
-As easy as 3.14159265358979323846264338327950288419716
-As long as I can remember, I've had amnesia.
-Ask not for whom the bell tolls; let the machine get it.
-Assumption is the mother of all screwups...
-Atheist = Deity Disadvantaged.
-Auntie Em: Hate you, hate Kansas, taking the dog. -Dorothy
-B.Gates : quality software :: R.McDonald : gourmet cuisine
-BREAKFAST.COM Halted... Cereal Port Not Responding.
-Back Up My Hard Drive? I Can't Find The Reverse Switch!
-Backup not found: (A)bort (R)etry (P)anic
-Bad Command:(A)bort (R)etry (T)ake RAM hostage
-Bad breath is better than no breath.
-Bald: follicularly challenged.
-Barium: what you do with dead chemists.
-Beautify Texas. Put a Yankee on a bus.
-Been there, done that, got the T-shirt.
-Best file compressor around: DEL *.* (100% compression!)
-Best way to dispose of the Borg: Give them Windows 3.1.
-Better ... stronger ... faster!
-Beware of Geeks bearing gifs.
-Beware of barking dogs that bite.
-Beware of programmers carrying screwdrivers
-Bigamy : one wife too many. Monogamy : same thing
-Bill Clinton is the Lyin' King. ( Now playing nation wide )
-Bill Clinton thinks that Cheerios are donut seeds.
-Bill Clintoon: The prince of Dorkness, a caricature of a president
-Black Holes are Out of Sight
-Black holes really suck...
-Blessed are the pessimists, for they make backups!
-Blessed is the end-user who expects nothing, for ye shall not be dissapointed.
-Bliss *IS* ignorance
-Bo Knows Taglines!
-Bo Peep did it for the insurance.
-Bombs don't kill people, explosions kill people.
-Borderline psychotic with hermit-like tendencies.
-Bore: A person who talks when you wish him to listen.
-Bored? Drive the speed limit... in your garage.
-Borg spreadsheet: Locutus 1-2-3
-Borg? Where? I don't se*(#$#..NO CARRIER
-Both of his feet are firmly planted in the air.
-Boy: A noise with dirt on it.
-Brain dysfunction detected....
-Brain over - Insert coin
-Brain: The apparatus with which we think that we think.
-Break up a relationship - buy a computer!!
-Breathing may be hazardous to your health.
-Britannia waives the rules.
-Bug off, Banana Nose; Relieve mine eyes
-Bugs are Sons of Glitches!
-Bugs, like coathangers, breed if unobserved.
-Building Contractors, not to be confused with homemakers
-Bullets speak louder than reason.
-Bumper sticker on a hearse: I'd rather be breathing
-Bungee Jumper? Catch you on the rebound.
-Bureaucrats cut red tape, lengthwise
-Bus error (Passengers dumped)
-Busier than a 1 legged man in an butt-kicking contest.
-But I forgot all about the Amnesia Conference!!
-But honey, we can afford it, I sold your car!
-But my little voice TOLD me to do it!
-But soft, what light through yonder tagline breaks?
-But then again, I like cold toilet seats.
-But what if I'm a figment of my OWN imagination?
-Buy American!
-Buy Land Now. It's Not Being Made Any More.
-Buy a supscription to Playboy and send it to your boss' wife
-By all means, let's not confuse ourselves with the facts!
-C programmer run C programmer crash C programmer quit
-C:\DOS C:\DOS\RUN RUN DOS RUN
-CAUTION: RIDER MAY BAIL AT ANY TIME
-CCITT: Can't Certify I Trust Telecom.
-CCITT: Can't Conceive Intelligent Thoughts Today
-CD-WOM, Wead Onwy Memowy.
-CEO of Dementia and Other Meaningless Entities.
-CHIP: One California hi-way patrolman.
-CODING: AN addictive Drug.
-COMMAND: A suggestion made to a computer.
-CONgress (n) - Opposite of PROgress
-CRASH: Normal termination.
-CRIME CONTROL: Fire a warning shot into his HEART!
-CURIOSITY? Nah. I got THAT cat with a lawnmower.
-CYCLIC REDUNDANCY CHECK: Stocktaking at a Bike shop
-California raisins murdered: Cereal Killer suspected
-Can I yell 'movie' in a crowded firehouse?
-Can you find the mispelled word in hear?
-Can you repeat the part after 'Listen very carefully'?
-Can you see the REAL ME, can ya?!?! CAN YA??!?!!?!?!?!?!
-Can you tell me how to get to Sesame Street?
-Can't learn to do it well? Learn to enjoy doing it badly!
-Card-carrying member of the cultural elite.
-Carlsbad Caverns: 22% more cavities.
-Cause of crash: Inadvertent contact with the ground.
-Caution: Breathing may be hazardous to your health.
-Caution: Contents under pressure
-Caution: Hungry Dieter May bite if provoked
-Caveat emptor, no deposit no return, do not remove.
-Celibacy is not hereditary.
-Cheer up, the worst is yet to come.
-Chernobyl used Windows
-Chess players mate better.
-Chicago runs best on a VCR.
-Chicago, an operating system Pair-of-Dimes shift!
-Chicago... The biggest thing since New Coke!
-Chicago: NT deja vu!
-Chicago? Been there. I'm ready to travel at WARP speed!
-Chicken heads are the chief food of captive alligators.
-Chipmunks roasting on an open fire.
-Choose heaven for climate, hell for society.
-Christmas comes, but once a year is enough.
-Circular Definition: see Definition, Circular.
-City Planners do it with their eyes shut.
-Civilization - biggest syntax error in history!
-Clark Kent is a transvestite.
-Clarvoiants meeting canceled due to unforseen events.
-Clean mind, clean body: take your pick.
-Cleanliness is next to impossible.
-Climate is what you expect. Weather is what you get.
-Clinton is one Bill, George Bush can't veto...
-Clinton/Gore is to the presidency as Beavis & Butthead are to television.
-Clones are people two.
-Close only counts in horseshoes and hand grenades!
-Close your eyes and press escape three times.
-Closed Hearing for the Caption Impaired...
-Cogito ergo spud I think therefore I yam.
-Cole's Law: Thinly sliced cabbage.
-Come in here, dear boy, have a cigar, you're gonna go far!
-Coming Soon!! Mouse Support for Edlin!
-Coming soon: Netware for the Nintendo!
-Commence strategic maneuvers at audible command signal. 5, 4, 3...
-Committees keep minutes and lose hours.
-Common sense is the collection of prejudices acquired by age eighteen.
-Common sense isn't...
-Communism is like a mouth on a lollipop
-Competence always contains the seeds of incompetence.
-Computational Physicist and all around nice guy.
-Computer Lie #1: You'll never use all that disk space.
-Computer: a million morons working at the speed of light.
-Computers All Wait at the Same Speed!
-Computers Rule 01001111 01001011
-Computers are not intelligent. They only think they are.
-Computers are useless; they can only give answers.
-Computers run on faith, not electrons.
-Condense soup, not books!
-Conformity obstructs progress.
-Confucius say too much.
-Confucius say: I didn't say that!
-Confucius say: Man with no legs bums around.
-Confucius say: Those who quote me are fools.
-Confuse People: Quote from the wrong message!
-Confused? Call Counselor Troi 1-900-NCC-1701: $1.95/minute
-Confusion not only reigns, it pours.
-Consolations, Consultations, Conflagrations.
-Constant change is here to stay.
-Contentsoftaglinemaysettleduringshipping.
-Converse with any plankton lately?
-Copyright the Intergalactic Thought Association
-Corrupt REALITY.SYS: Reboot Universe (Y/n)?
-Could crop circles be the work of a cereal killer?
-Couldn't myself have better it said.
-Courage atrophies from lack of use.
-Crime does not pay...as well as politics.
-Crime doesn't pay... does that mean my job is a crime?
-Crime wouldn't pay if the government ran it.
-Crime, Sex, Alcohol, Drugs...Boy do I love Congress
-Cynicism is intellectual dandyism.
-Cynics are people who know the price of everything and the value of nothing.
-D.A.D.D. - Daddies Against Dirty Diapers
-D.A.M. - Mothers Against Dyslexia
-D.A.M.M - Drunks Against Mad Mothers
-DAM: Mothers Against Dyslexia.
-DANGER! Computer store ahead, hide wallet!
-DCE seeks DTE for mutual exchange of data.
-DEFINE: De ting you get for breaking de law.
-DEVICE=EXXON.SYS may mess up your environment
-DILATE: To live longer.
-DIODE: What happens to people who don't die young.
-DIVORCE =system('echo y| erase \wife\*.*' );
-DO NOT ADJUST YOUR MIND - the fault is with reality
-DO NOT REMOVE THIS TAGLINE (UNDER PENALTY OF LAW)!
-DOC files? We don't need NO STINKIN' DOC FILES!
-DOS 5.0 Yesterday's operating system, today!
-DOS means never having to live hand-to-mouse.
-DOS never says 'EXCELLENT command or filename, Dude!'
-DOS-O-MANIA : Reboot is not kicking your computer again
-DOS-O-MANIA : Root is not the book Alex Haley wrote.
-DOWN WITH EXCLAMATION POINTS!!!!
-Daddy, what does 'Formatting Drive C:' mean?
-Dain Bramaged.
-Dang this hobby is expensive!
-Dangerous exercise: Jumping to conclusions.
-Darth Vader sleeps with a Teddywookie.
-Dawn: The time when men of reason go to bed.
-Dawson's First Law: You don't have enough outlets.
-Death benefits = oxymoron.
-Death is 99 per cent fatal to laboratory rats.
-Death is God's way of dropping carrier.
-Death is life's answer to the question 'Why?'
-Death is life's way of telling you you've been fired.
-Death sneaks up on you as a windshield sneaks up on a bug.
-Death: to stop sinning suddenly.
-Deflector shields just came on, Captain.
-Delivered by Electronic Sled-Dogs.....Woof!
-Democrats Call for Amnesty, Reduced Sentences Likely.
-Depart in pieces.... i.e., Split.
-Detour: The roughest distance between two points.
-Diagonally parked in a parallel universe.
-Did I just step on someone's toes again?
-Did ya hear? They took the word gullible out of the dictionary!
-Did you expect mere proof to sway my opinion?
-Die Yuppie Scum.
-Diets are for those who are thick and tired of it.
-Difference between Jane Fonda & Bill Clinton? Jane went to Vietnam
-Digression is education.
-Dime: a dollar with all the taxes taken out.
-Dinner Not Ready...(A)bort (R)etry (P)izza
-Diplomacy is saying 'nice doggy' until you find a rock.
-Diplomacy is the ability to let someone else have your way.
-Diplomacy: The patriotic art of lying for one's country.
-Dirty deeds - DONE DIRT CHEAP!
-Disclaimer: All opinions are not really opinions.
-Disclaimer: Written by a highly caffeinated mammal.
-Discoveries are made by not following instructions.
-Disks travel in packs.
-Dyslexics of the world, UNTIE!
-Do Androids Dream of Electric Sheep?
-Do I mind if you smoke? No. Do you mind if I FART?
-Do fish get thirsty?
-Do not believe in miracles -- rely on them.
-Do not disturb. Already disturbed!
-Do not put statements in the negative form.
-Do radioactive cats have 18 half-lives?
-Do steam rollers really roll steam?
-Do the joke. Get the laugh. Move on.
-Do unto others BEFORE they do unto you!
-Do vegetarians eat animal crackers?
-Do you know the way to San Jose?
-Doctor Who for president
-Doctor, my brain hurts!
-Documentation is the castor oil of programming.
-Does Bill Clinton think Elvis is alive?
-Does killing time damage eternity?
-Does the Enterprise use DOS v2356.0?
-Does the name Pavlov ring a bell?
-Doesn't expecting the unexpected make the unexpected become the expected?
-Dogs come when you call. Cats have answering machines.
-Dogs crawl under Gates, software under Windows.
-Don't Take Life Seriously, It Is Not Permanent.
-Don't ask me, I have intermittent memory loss
-Don't ask me, I only work here.
-Don't ask me, I'm making this up as I go!
-Don't be a sexist, broads hate that.
-Don't be afraid to drive a nail in the wood!
-Don't believe everything you hear or anything you say.
-Don't blame me, I voted for Mickey Mouse.
-Don't buy furs, it takes trees to make protest signs.
-Don't byte off more than you can multiplex.
-Don't confuse me with facts, my mind's already made up!
-Don't crush that dwarf, hand me the pliers.
-Don't diet, download a virus to remove the FAT.
-Don't do what I SAY, do what I mean!
-Don't get stuck in a closet -- wear yourself out.
-Don't just do something !!! Stand there !!!
-Don't let school interfere with your education.
-Don't look at me in that tone of voice!
-Don't look back, the lemmings are gaining on you.
-Don't mess with Murphy.
-Don't panic. Don't panic. Don't panic. ... ALL RIGHT, NOW PANIC
-Don't play stupid with me! I'm better at it.
-Don't press the keys so hard!
-Don't read everything you believe.
-Don't rush me. I get paid by the hour.
-Don't speak now, and forever hold your peace.
-Don't start with me. You know how I get.
-Don't steal. The government hates competition.
-Don't stop posting, a good laugh breaks up my day nicely
-Don't sweat it -- it's only ones and zeros.
-Don't talk unless you can improve the silence.
-Don't thank me for insulting you. It was my pleasure...
-Don't try to saw sawdust.
-Don't use a big word where a diminutive one will suffice.
-Don't use no double negatives.
-Don't worry, I'm fluent in weirdo.
-Down with categorical imperative!
-Down with ignurance!
-Downgrade your system for only 89 dollars! Install Windows!
-Dragons love you. You're crunchy and good with ketchup.
-Drama is life with the dull bits cut out.
-Drawing on my fine command of language, I said nothing
-Drilling for oil is boring.
-Drink wet cement, and get completely stoned.
-Drive A: format failure, formatting C: instead...
-Drive C: Error, (A)bort (R)etry (I)gnore (K)ick (S)cream
-Dropped from my peeling lips like lousy fruit.
-Drugs have taught an entire generation of American kids the metric system.
-Dumb luck beats sound planning every time. Trust me.
-Dying is no excuse. Nixon in 96.
-Dyslexics are persona au gratin.
-Dyslexics have more fnu.
-Dyslexics of the world, UNTIE!
-EMS: Enhanced Money Scam
-ERROR 103: Dead mouse in hard drive.
-EXPANSION SLOTS: The extra holes in your belt buckle.
-Eagles may soar but weasels aren't sucked into jet engines!
-Easter is canceled this year. They've found the body.
-Eat Healthy, Exercise, and Die Anyway ...
-Eat the rich, the poor are tough and stringy
-Efficiency takes time! Frugality: who can afford it?
-Eggheads unite! You have nothing to lose but your yolks.
-Ego Gratification through Violence
-Either this man is dead or my watch has stopped.
-Email me the rules, please!
-Energizer Bunny Arrested! Charged with battery.
-Enjoy me, I may never pass this way again.
-Enough research will tend to support your theory.
-Ensign Pillsbury: He's bread Jim!
-Enter that again, just a little slower.
-Error 15 - Unable to exit Windows. Try the door.
-Eschew obfuscation!
-Even in this corner of the galaxy, Captain, 2+2=4 ... Spock
-Even snakes are afraid of snakes.
-Even the greatest of whales is helpless in the middle of the desert
-Ever notice how fast Windows runs? Neither did I...
-Ever stop to think, and forget to start again?
-Ever wonder why Oprah spelled backwards is Harpo?
-Every man's work is a portrait of himself.
-Every purchase has its price.
-Every why hath a wherefore.
-Everybody is ignorant, only on different subjects.
-Everybody wants to go to heaven, but nobody wants to die.
-Everyone has photographic memory...some don't have film!
-Everyone hates me because I'm paranoid
-Everyone is entitled to my opinion.
-Everyone is gifted. Some open the package sooner.
-Everyone's expendable...and no one has a real friend
-Everything bows to success, even grammar.
-Everything in our favor was against us.
-Everything that is not mandatory is forbidden.
-Everywhere is walking distance if you have the time.
-Evil always triumphs over good, because good is STUPID!
-Exceeding the legal fun limit on a regular basis
-Excellent time to become a missing person.
-Excuse me while I dance a little jig of despair
-Excuse me while I sharpen my tongue.
-Experience is a good teacher but her fees are high...
-Experience: a name everyone gives to his mistakes.
-Exploding piglets!!! My gosh, it's raining bacon!
-Exxon Suxx.
-F.A.R.T....Fathers Against Radical Teenagers
-FATAL SYSTEM ERROR: Press F13 to continue...
-FIGHT BACK! Fill out your tax forms with Roman numerals.
-FILE COPIED. I THINK?
-FLOPPY DISK: Serious curvature of the spine.
-FOR SALE: 1 set of morals, never used, will sell cheap.
-FORD: The Heartbreak of today's Chevrolet!
-Fact is solidified opinion
-Facts Just Get In The Way And Impede Progress.
-Facts are stubborn things.
-Fad: In one era and out the other
-Familiarity breeds attempt
-Familiarity breeds children.
-Famous last words - Don't worry, I can handle it.
-Famous last words - Icarus: Aaaahhhhhhhhh.
-Famous last words - You and what army?
-Faster than a speeding ticket!
-Fat Wars: May the Sauce Be With You.
-Fat person: Nutritional Overachiever
-Fatal Error Using Mouse. Replace and Bury Operator.
-Features should be discovered, not documented.
-Feel lucky???? Update your software!
-Felines... nothing more than felines...
-Fer sell cheep: IBM spel chekker. Wurks grate.
-Fife. n. Small shrill instrument that rhymes with wife.
-Figures won't lie, but liars will figure.
-File not found. Should I fake it? (Y/N)
-Find your aim in life, before you run out of ammunition
-First thing you do is shoot all the lawyers
-Fish and visitors stink in three days.
-Flames to /dev/null/here/is/a/quarter/now/go/buy/a/clue.
-Flaming nuclear death to Smurfs
-Flirt: A woman who thinks it's every man for herself.
-Floggings will continue until morale improves.
-Flying saucers are real, the Air Force doesn't exist.
-Folks who think they know it all bug those of us who do
-Follow-ups to alt.nobody.really.cares
-Food is an important part of a balanced diet.
-Fools rush in where Fools have been before!
-Fools rush in wherever lottery tickets are sold
-For Sale: Slightly used message. Enquire within.
-For at the end of history lies the undiscovered country.
-For discussion only. Not to be relied upon.
-For every vision there is an equal and opposite revision.
-For people who like peace and quiet: A phoneless cord!
-For sale, Toilet-seat cover. Barely used.
-For the finest in brain candy.
-Forget the Joneses...I can't keep up with the SIMPSONS!
-Forget the computer! Where's my abacus??
-Forget the diet center; send yourself a candygram.
-Forgive your enemies...but REMEMBER THEIR NAMES!
-Four minus two is one and the same.
-Fraud(n): A telephone number starting with '1-900'
-Free Nelson Mandela, while stocks last!
-Free advice is worth what you pay for it
-Free your mind ... the rest will follow!
-Freedom is just chaos with better lighting.
-Friction can be a drag sometimes.
-Friendly fire - ISN'T !
-Friends are Friends, regardless of their baud rate!
-Friends come and go, enemies accumulate.
-Friends don't let friends drive naked.
-Friends encourage friends to use Windows - under Linux!
-Friendship is one soul in two bodies.
-Frost
-Funny, only sensible people agree with me.
-GURU: One who knows more jargon than you.
-Gambling: The sure way of getting nothing for something.
-Gargle twice daily - see if your neck leaks.
-Geez if you belive in honkus.
-Genealogy = A DNA square-dance in the Thighlight Zone
-General Failure reading John Dvorak
-General stupidity error reading drive C:
-Geoff, Brett and Todd...the BO-DYNASTY!!!
-George Orwell was an optimist.
-Get behind early so you have plenty of time to catch up.
-Get the facts first - you can distort them later!
-Get your filthy hands off my dessert!
-Gimme back my face! You're getting it ugly.
-Give a woman an inch and she'll park a car in it.
-Give a woman an inch and she thinks she's a ruler.
-Give your child mental blocks for Christmas.
-Go Lemmings, Go!!!
-Go shopping. Buy Stuff. Sweat in it. Return it the next day.
-God created cats so that men could learn to understand women
-God does not play dice.
-God heals and the doctor takes the fee.
-Going out of my mind, back in 5 minutes.
-Going the speed of light is bad for your age.
-Good day to let down old friends who need help.
-Good girls go to heaven...but bad girls go EVERYWHERE!!
-Goodness has NOTHING to do with it.....
-Gotta love me!
-Grab your helmet, get your bike, it's SHOWTIME!
-Graduate Of The Uncle Fester & Keith Moon School of hair styling
-Gravity brings me down
-Gravity doesn't exist. The Earth sucks.
-Great minds travel in the same sewers.
-Greed is good! Greed is right! Greed works!
-Grow your own dope... plant a man
-Growing old is mandatory; growing up is optional!!
-Grub first, then ethics.
-Gun control is being able to hit your target!
-Guns don't kill people... death does.
-Guns don't kill people..., I kill people!
-H lp! S m b d st l ll th v w ls fr m m k yb rd!
-HAL 9000: Dave. Put down those Windows disks, Dave. DAVE!
-Hackito ergo sum.
-Hailing frequencies open, Captain.
-Hand me that crowbar... I must pry out this bullet.
-Happiness is Earth in your rear view mirror.
-Happiness is a warm gun.
-Happiness is a warm modem
-Happiness is finding special characters \ 1\ 2\ 1\ 2
-Happiness is not a destination. It's the trip.
-Happiness is seeing your mother-in-law's face on the back of a milk carton.
-Happiness is...receiving YOUR posts!!!!
-Hard work has a future payoff. Laziness pays off now.
-Hard work must have killed someone!
-Has it ever rained cats and dogs?
-Hasta la vista, Baby!
-Have Tardis, will travel.
-Have an adequate day.
-Have cursor, will curse.
-Have it OUR way. Yours is IRRELEVANT. At BORGerKing.
-Have you ever talked into an acoustic modem?
-Have you seen Quasimoto? I have a hunch he's back!
-Having Windows problems? Dial 1-800-3-IBM-OS2 for fast relief!
-Having two bathrooms ruins the capacity to co-operate.
-He does the work of 3 Men...Moe, Larry & Curly
-He has Van Gogh's ear for music.
-He who Laughs, Lasts.
-He who always plows a straight furrow is in a rut.
-He who asks timidly makes denial easy.
-He who dies with the most access, wins.
-He who dies with the most toys... is *still* DEAD!
-He who eats too many prunes, sits on toilet many moons.
-He who hesitates is constipated.
-He who laughs last is S-L-O-W.
-He who laughs last probably made a backup.
-He who lives by the sword laughs last.
-He who places head in sand, will get kicked in the end!
-He who shouts the loudest has the floor.
-He who sitteth on an upturned tack shall surely rise.
-He's dead Jim. Grab his tricorder. I'll get his wallet.
-He's dim, Jed
-He's not dead, Jim, he's just metabolically challenged.
-Heads I win... DITTO tails
-Health food makes me sick.
-Heisenberg slept here, I think.
-Help endangered species - adopt a KGB operative.
-Help fight continental drift.
-Help stamp out mental illness, or I'll kill you!
-Help stamp out, eliminate and abolish redundancy!
-Help! I'm lost somewhere in the Generation Gap.
-Help! I've been stuck in here for years and years...
-Help! Police! That guy stole my .sig! STOP!!! THIEF!!!
-Help!!! I'm falling and I can't click out!!!
-Help, I'm slipping into the Twilight Zone!
-Here today, gaunt tomorrow.
-Hey! Hacker! Leave those lists alone!
-Hey! This is a morgue, not an amusement park!
-Hey! Who took the cork off my lunch??!
-Hey, CServe/Unisys! Stick it where the sun don't shine!
-Hey, Worf...I hooked Data up to a Modem...Wanna see?
-Hi! I can't remember your name either.
-Hi, I'm from Corporate. I'm here to help you.
-Hi. I'll be your tagline for this evening.
-High message: 9434567. Message last read: 9.
-Hills weed out the weak. Darwin would argue this is good.
-Hindsight is always 20:20.
-Hindsight is an exact science.
-Hm..what's this red button fo:=/07<NO CARRIER
-Hmm...Nice tagline. <SWIPE!> SUCKER!!! AH, HAHAHAHAHAHAHAHA!
-Hollow chocolate has no calories
-Hollywood is like Picasso's bathroom.
-Honey, PLEASE don't pick up the PH$@#*&$^(#@&$^%(*NO CARRIER
-Honeymoon Salad: Lettuce alone, with no dressing.
-Honeymoon: time between 'I do' and 'you'd better'
-Honk if you love cheeses.
-Honk if you love peace and quiet.
-Honk, if you have slept with Clinton.
-Hors d'oeuvres--a ham sandwich cut into forty pieces.
-Housework done properly, can kill you
-Houston! do you read.
-How come the AT&T logo looks like the Death Star?
-How come there's only one Monopolies Commission?
-How come wrong numbers are never busy?
-How do I set my laser printer for stun?
-How do you know it's summer in Seattle? Rain's warm!
-How do you make Windows faster ? Throw it harder
-How do you pronounce my name? With reverence.
-How do you write zero in Roman numerals?
-How does Michael Jackson pick his nose? From a catalog!
-How does one expect the unexpected?
-How long is a short story?
-How long will a floating point operation float?
-How many consultants will fit onto the head of a pin?
-How many of you believe in telekinesis? Raise MY hand!
-How many weeks are there in a light year?
-How much can I get away with and still go to heaven?
-How much deeper would the ocean be without sponges?
-Humpty dumpty was pushed.
-Hydrate or Die.
-Hypochondria is the only disease I haven't got.
-I *LOVE* it when a plan comes together!
-I BBS because no one can read my handwriting.
-I Cayman went.
-I Have To Stop Now, My Fingers Are Getting Hoarse!
-I M a tru beleever in hour edukashun sistum.
-I Still miss my ex-wife.....BUT, My aim is improving!
-I Think....therefore I'm OVER QUALIFIED!!!!!!!!!
-I love it when a plan comes together!
-I admit it's offbeat, but lets not get hysterical.
-I always lie. In fact, I'm lying to you right now!
-I always like to try the one I've never tried before.
-I am Clinton of Borg. Your income will be assimilated.
-I am Homer of Borg! Prepare to be...OOooooo! Donuts!!!
-I am Lancelot of Borg. Resistance is feudal.
-I am both of us & so are you.
-I am built for comfort, not speed!
-I am free of all prejudice. I hate everyone equally.
-I am functioning within established parameters.
-I am in total control, but don't tell my wife.
-I am not an animal! I am ... well, not an animal.
-I am serious. And don't call me Shirley.
-I am sweet and lovable at all times.
-I am the girl-next-door's imaginary boyfriend.
-I am what I am and that's all that I am.
-I am. Therefore, I think. I think.
-I apologize to the deaf for the loss of subtitles.
-I bet you I could stop gambling.
-I bought a cordless extension cord.
-I came, I saw, I did a little shopping.
-I came, I saw, I took LOTS of PICTURES!
-I came... I saw... I stole your tagline.
-I can do without essentials but I must have my luxuries
-I can quit anytime I want; I just don't want to!
-I can resist anything but temptation.
-I can tell you are lying. Your lips are moving.
-I can walk on water, but I stagger on alcohol.
-I can't be overdrawn, I still have checks left!
-I can't believe my computer's on fire.
-I can't hear you. There's a banana republic in my ear.
-I cna ytpe 300 wrods pre mniuet!!!
-I could be arguing in my spare time.
-I could have stuck with DOS, but NO.
-I couldn't care less about apathy.
-I didn't cheat, I just changed the Rules!
-I didn't know it was impossible when I did it.
-I distinctly remember forgetting that.
-I do not fear computers. I fear the lack of them.
-I do this kind of stuff to him all through the picture.
-I don't care if I'm apathetic.
-I don't care who you are, Fatso. Get the reindeer off my roof!
-I don't care who you are, what you are driving, or where you would rather be.
-I don't eat snails... I prefer FAST food!
-I don't hate Windows - it runs great under Linux!
-I don't have a solution but I admire the problem.
-I don't lie, cheat or steal unnecessarily.
-I don't need a disclaimer. I OWN the company.
-I don't think, therefore I am not.
-I don't want the world, I just want your half.
-I drink to make other people interesting.
-I eat Swiss cheese from the inside out.
-I feel like a fugitive from the law of averages.
-I feel so inar-inar-inar tic-u-late
-I feel the need......the need for speed!
-I finally washed the mud off of mud.
-I find myself beside a stream of empty thought
-I float like an anchor and sting like a moth.
-I get mail........ I exist.
-I give advice worth the price....free!
-I got arrested in LA and boy am I beat!
-I guess a cynic smells different.
-I had a life once... now I have a computer and a modem.
-I had amnesia once or twice.
-I had my coat hangers spayed.
-I hate quotations. Tell me what you know.
-I hate to repeat gossip, so I'll only say this once.
-I have a 9600bps modem and 1.5bps fingers
-I have a rock garden. 3 of them died last week.
-I have a speech impediment... my foot.
-I have already not made that point
-I have seen the evidence. I want DIFFERENT evidence!
-I have seen the truth and it makes no sense.
-I have the mars observer and I'm not returning it until I get an 'A' in astronomy
-I haven't lost my mind -- it's backed up on tape somewhere.
-I haven't lost my mind, I know exactly where I left it.
-I hear what you're saying but I just don't care.
-I is a college student.
-I is knot dain bramaged!
-I just bought a cured ham. Wonder what it had?
-I keep my .BAT files in D:\BELFRY
-I know Karate, Kung Fu, and 47 other dangerous words
-I know everything about everything, except that.
-I know it all. I just can't remember it all at once.
-I like candy, especially the gooey kind with nougat!
-I like kids, but I don't think I could eat a whole one.
-I like to leave messages *before* the beep.
-I like to reminisce with people I don't know.
-I like to think of myself as a divide overflow.
-I like your approach, now let's see your departure.
-I lost a button hole today.
-I lost my knickers at Niagara.
-I made it foolproof. They are making better fools!
-I may be fat but you're ugly, and I can lose weight.
-I may be getting older, but I refuse to grow up
-I may not always be perfect, but I'm always me.
-I may not be perfect, but parts of me are excellent.
-I mustanottagottalotta sleep last night.
-I need someone really bad. Are you really bad?
-I never deny, I never contradict. I sometimes forget.
-I never met a chocolate I didn't like!
-I only counted 100 dalmatians...!!!
-I owe, I owe, it's off to work I go.
-I parked my hard disk and now I can't find it!
-I planted some bird seed. A bird came up.
-I post.......... I am
-I promise results, not promises.
-I refuse a battle of wits with an unarmed person!
-I remember when Saturns were rockets, not cars.
-I saw, I came, I cleaned it up.
-I smashed a Window and saw... Linux!
-I spilled spot remover on my dog, and now he's gone.
-I think I strained a muscle I didn't know I had!
-I think, therefore I am. I think.
-I think. Therefore I am DANGEROUS.
-I thought I was wrong but I was mistaken.
-I tried being reasonable once. I didn't like it.
-I tried switching to gum but I couldn't keep it lit.
-I tried to daydream, but my mind kept wandering.
-I tried to drown my problems but they can swim!
-I try to make everyone's day a little more surreal.
-I used to be disgusted, but now I'm just amused.
-I used to be indecisive, now I'm not so sure.
-I used to be schizophrenic, but we're all right now.
-I used to have a handle on life, then it broke.
-I used to spell badlie, but now I got worser.
-I used to watch TV, then I bought a modem.
-I wake near the end of the day.
-I want .50 cal machine guns as a factory option.
-I warn you not to underestimate my powers.
-I was arrested for selling illegal sized paper.
-I was arrested for walking in someone else's sleep.
-I was going to procrastinate, but I put it off....
-I went on a 30-day diet - and lost 30 days!
-I will defend to your death my right to my opinion.
-I wish life had a scroll-back buffer.
-I wouldn't touch the Metric System with a 3.048m pole!
-I wrote a few children's books, but not on purpose.
-I xeroxed my watch. Now I have time to spare.
-I'd give my left arm to be ambidextrous
-I'd like to live like a poor person with lots of money.
-I'd like to, but last time I went I never came back..
-I'd love to, but I have to fulfill my potential.
-I'd love to, but I have to rotate my crops.
-I'd love to, but I have to stay home and see if I snore
-I'd love to, but I prefer to remain an enigma.
-I'd love to, but I think you want the OTHER Phillip.
-I'd love to, but I'm trying to be less popular.
-I'd love to, but I've dedicated my life to linguini.
-I'd love to, but my crayons all melted together.
-I'd love to, but my favorite commercial is on TV.
-I'd love to, but my patent is pending.
-I'd love to, but none of my socks match.
-I'd love to, but there's a disturbance in the Force.
-I'd love to, but you know how we psychos are.
-I'd rather be bicycling!
-I'll eat anything that's BRIGHT BLUE!!
-I'll get you my pretty, and your little dog too!
-I'll get you yet, you kwazy wabbit!
-I'll jump off that bridge when I come to it.
-I'll tell you what's the matter! This parrot is dead!
-I'm Not Schizophrenic, And Neither Am I.
-I'm Serfectly Pober.
-I'm a Bum...a BEACH Bum!
-I'm a cowboy ... on a steel horse I ride!
-I'm a lumberjack, and I'm okay!
-I'm a nobody, nobody is perfect, therefore I'm perfect.
-I'm an Debian developer...I don't NEED a life!
-I'm an absolute, off-the-wall fanatical moderate.
-I'm an incorrigible punster, so don't corrige me!
-I'm an influential person, gravitationally speaking.
-I'm as bored as a pacifist's pistol.
-I'm at the corner of Walk and Don't Walk.
-I'm dangerous when I know what I'm doing.
-I'm easy to please as long as I get my way.
-I'm fallin' down a spiral, destination unknown!
-I'm fascinated by the way memory diffuses fact.
-I'm in shape ... Rounds a shape isn't it?
-I'm leaving my body to science fiction.
-I'm moving to Mars next week, so if you have any boxes.
-I'm new and what's all this then?
-I'm no stranger, just a friend you haven't met...
-I'm not a complete idiot - several parts are missing.
-I'm not as dumb as you look.
-I'm not broke, I'm just badly bent.
-I'm not dead. I'm electroencephelographically challenged.
-I'm not even going to ignore that.
-I'm not fat just horizontally disproportionate.
-I'm not loafing. I work so fast I'm always finished
-I'm not lost, I'm 'locationally challenged.'
-I'm not nearly as think as you confused I am.
-I'm not opinionated, I'm just always right!
-I'm not paranoid! Which of my enemies told you this?
-I'm not real smart, but I can lift heavy things.
-I'm not rude, I'm 'attitudinally challenged'.
-I'm not schizophrenic. It's this guy beside me!
-I'm not tense, just terribly alert.
-I'm on the crest of a slump.
-I'm out of sick days, so I'm calling in dead!
-I'm pink, therefore I'm Spam.
-I'm schizophrenic, What are you?
-I'm so broke, I can't even pay attention.
-I'm spending a year dead for tax purposes.
-I'm sure it's clearly explained in the Zmodem DOC's
-I'm sure it's in the manual somewhere...
-I'm the person your mother warned you about.
-I'm too smart to let my intelligence go to my head.
-I'm turning you in to the SPCA!
-I've been seduced by the chocolate side of the force.
-I've got Parkinson's disease. And he's got mine.
-I've got a mind like a.. a.. what's that thing called?
-I've got to sit down and work out where I stand.
-I've had fun before. This isn't it.
-I've run out of sick leave so I'm calling in dead.
-I've seen the future. I can't afford it.
-IBM: I've Been Misled
-IBM: It may be slow, but at least it's expensive.
-IBM: you can buy better, but you can't pay more
-IF numcooks > .maxcooks THEN;SET V broth = 'spoiled';END
-INTERLACE: To tie two boots together.
-Ideas are not responsible for their followers!
-If At First You Don't Succeed Ignore The Docs...
-If Clinton's the answer, it must have been a really stupid question.
-If I can't fix it, it's probably dead.
-If I can't win, I don't wanna play!
-If I had anything witty to say, I wouldn't put it here.
-If I had been using Windoze, I'd still be writing this.
-If I save the whales, where do I keep them?
-If I save time, when do I get it back ?
-If I want your stupid opinion, I'll beat it out of you.
-If I were here more often, I wouldn't be gone so much.
-If I were two faced, would I wear this one?
-If I were you, who'd be me?
-If Murphy's Law can go wrong, it will.
-If The Shoe Fits - The Sock Fits !
-If a fly has no wings would you call him a walk?
-If a tree falls on a florist, would he make a sound?
-If all goes well, you've overlooked something!
-If all you have is a hammer, everything looks like a nail
-If at first we don't succeed, we run the risk of failure.
-If at first you don't succeed, call it v1.0!
-If at first you don't succeed, hide your astonishment.
-If at first you don't succeed, put it out for beta test.
-If at first you don't succeed, redefine success.
-If at first you don't succeed, skydiving isn't for you.
-If at first you don't succeed, work for Microsoft.
-If at first you don't succeed, you must be using Windows.
-If brains were dynamite you couldn't blow your nose!
-If cows could fly, everyone would carry an umbrella.
-If evolution is outlawed, only outlaws will evolve.
-If idiots could fly, this would be an airport.
-If in doubt, make it sound convincing.
-If it glows don't touch it!
-If it has feelings, its not cooked enough!
-If it isn't broken, don't fix it.
-If it jams, force it. If it breaks, it needed replacing
-If it walks out of your refrigerator, LET IT GO !!
-If it works, tear it apart and find out why!
-If it's not broke, let me take a crack at it.
-If it's not going to plan, maybe there never was a plan.
-If it's not on fire, it's a software problem.
-If it's not worth doing well, it's not worth doing.
-If it's stupid and works, then it ain't stupid
-If it's too loud, you're too old.
-If life gives you lemons, make lemonade.
-If little else, the brain is an educational toy.
-If marriage is outlawed, only outlaws will have inlaws.
-If money could talk, it would say goodbye.
-If nobody measures up, check your yardstick.
-If rabbits feet are so lucky, what happened to the rabbit?
-If speed scares you, try Windows...
-If the shoe fits, put it in your mouth.
-If there are epigrams, there must be meta-epigrams.
-If there's one thing I can't stand, it's intolerance.
-If this were an actual tagline, it would be funny.
-If truth is stranger than fiction, you must be truth!
-If voting changed anything, they'd make it illegal.
-If winning isn't important then why keep score?
-If you associate with the wise, you will become wise.
-If you believe in telekinesis, raise my hand.
-If you can't run with the big dogs, stay on the porch.
-If you cannot convince them, confuse them.
-If you choke a smurf, what color does it turn?
-If you didn't get caught, did you really do it?
-If you don't care where you are, then you ain't lost.
-If you don't like my opinion of you - improve yourself!
-If you don't like the news, go out and make some of your own.
-If you have nothing to do, don't do it here.
-If you have to ask what jazz is, you'll never know.
-If you hear an onion ring please answer it.
-If you mess with something long enough it'll break.
-If you must drink and drive, drive a Yugo!
-If you saw a heat wave, would you wave back?
-If you say nothing, no one will repeat it.
-If you see an onion ring, ANSWER IT!
-If you think education is expensive, try ignorance.
-If you try to fail, and succeed, which have you done?
-If you want your name spelt wrong, die.
-If you wish work poorly done, pay in advance.
-If you're not confused, you're not paying attention.
-If you're not the solution, you're the precipitate.
-If your attack is going well, then it's an ambush..
-If your ship doesn't come in, swim out to it!
-Ifyoucanreadthis,youspendtoomuchtimefiguringouttaglines!
-Ignorance is temporary; stupid is forever.
-Illiterate? Write for free help.
-Imagery is All In The Mind.
-Imagination is the only weapon in the war against reality
-Impropriety is the soul of wit.
-In God we trust, all others pay cash.
-In a fight between you and the world, back the world.
-In case of emergency, break glass. Scream. Bleed to death
-In case of fire, yell 'FIRE!'
-In politics stupidity is not a handicap.
-In the land of the witless, the halfwit is king.
-In war there is no substitute for victory.
-Include this in your CONFIG.SYS File: BUGS=OFF
-Incompetence plus incompetence equals incompetence.
-Individualists of the world, UNITE!
-Inertia makes the world go round.
-Inferiority complex: conviction by a jury of your fears.
-Innovate or Die.
-Insanity is hereditary. You get it from your kids.
-Insanity is just a state of mind.
-Insert New Disk for Drive C: Press ENTER when ready.
-Insert inevitable trivial witticism of your choice.
-Interchangeable parts won't.
-Internal combustion engines are the dinosaurs' revenge
-International Brotherhood of Tagline Thieves.
-Interstellar Matter is a Gas
-Invisible Systems, Inc. If you don't see it, we made it.
-Iron Law of Distribution: Them that has, gets.
-Is 'tired old cliche' one?
-Is it OK to yell 'MOVIE' in a crowded firehouse?
-Is it in my head...or in my heart?
-Is it ok to use my AM radio after NOON?
-Is it possible to feel gruntled?
-Is that a flying saucer or a pie in the sky?
-Is there life before coffee?
-Is this a machine? I don't talk to machines! [Click]
-Is this the right room for an argument?
-It all looks the same if you're not the lead dog.
-It can't be full...I STILL HAVE SUBDIRECTORIES!
-It compiled, first screen came up?? Ship it! --Bill Gates
-It did what? Well, it's not supposed to do that.
-It doesn't work, but it looks pretty.
-It has many other uses as well. Allow me. - Worf
-It is always better to sacrifice your opponent's men
-It is bad luck to be superstitious.
-It is better to be brief than boring.
-It is better to wear out than to rust out.
-It is broke. It will not work. It does not go.
-It is fatal to live too long.
-It is incumbent on us to avoid archaisms.
-It is morally wrong to allow suckers to keep their money.
-It is much easier to be critical than to be correct
-It is not enough to succeed. Others must fail.
-It is, after all, only a moment in the infinity of time.
-It really bothers me when people cut me o...
-It said 'Insert disk #3', but only two will fit!
-It works better if you plug it in.
-It's 10:00 PM...do YOU know where YOUR tagline is?
-It's Ensign Flintstone - he's Fred, Jim.
-It's a Tough Job! ..... So I'd Rather YOU do it.
-It's a fine line between fishing & standing still
-It's a fine night to have an evening.
-It's a good thing we don't get all the government we pay for.
-It's a tough job! ..... So I'd Rather YOU do it.
-It's an ill wind that gathers no moss.
-It's as bad as you think and they are out to get you.
-It's bad luck to be superstitious.
-It's been a business doing pleasure with you.
-It's been lovely, but I have to scream now.
-It's best to leave quickly when you make noises like that...
-It's better to burn out than to fade away.
-It's clever, but is it art?
-It's de\ 2ja\ 5 vu all over again.
-It's easier to get older than it is to get wiser.
-It's easier to obtain forgiveness than permission.
-It's easy to apply yourself, just use crazy glue!
-It's easy to be brave from a safe distance.
-It's hard to RTFM when you can't find the FM..
-It's hard to be serious when you're naked.
-It's life Jim, but not as we know it.
-It's like Deja Vu all over again...
-It's lonely at the top, but you eat better.
-It's more than a reader. It's a message base manager!
-It's never too late to have a happy childhood
-It's not easy having an overbearing parent! - Troi
-It's not hard to meet expenses, they're everywhere!
-It's not in the manual!
-It's not just a hobby, it's an obsession!
-It's not pretty being easy.
-It's not the bullet that kills you, it's the hole.
-It's not the money I want, it's the stuff.
-It's not the principle of the thing, it's the money
-It's okay to be ugly...but aren't you overdoing it?
-It's only a hobby ... only a hobby ... only a hobby ... only
-It's only ones and zeros.
-It's raining, it's pouring, the old man is...dead, Jim.
-It's smart to pick your friends, but not your nose.
-It's starting to rain, .SQZ the animals into the .ARC !
-It's true, forgiveness IS easier to get than permission
-Its a JOKE, like the funny kind but different.
-Itsdifficulttobeverycreativewithonlyfiftysevencharacters!
-JFK: I need this motorcade like a hole in my head!
-James Bond rules. 00K.
-Jealousy is all the fun you think they have.
-Jet Engine Theory -Suck, Squeeze, Bang, Blow!
-Join the Group Mind - become a Borg
-Joseph Stalin's grave was a Communist Plot.
-Jumbo shrimp = oxymoron.
-Junk: stuff we throw away. Stuff: junk we keep.
-Just because you're STUPID ain't no excuse.
-Just because I'm paranoid doesn't mean they aren't out to get me!
-Just do it.
-Just don't tell the asylum you saw me here
-Just how much leg have I got
-Just my 78,000 lira worth.
-Just what part of 'NO' didn't you understand...?
-Just when you think you've won the rat race along come faster rats.
-Justice is incidental to law and order.
-Justice: A decision in your favor.
-Kamikaze Pilot Wanted: Experienced only need apply.
-Keep America beautiful.. properly dispose of your lawyer.
-Keep a clear head and always carry a lightbulb.
-Keep emotionally active. Cater to your favorite neurosis.
-Keyboard Not Found - Press [F1] to Continue
-Kicked wide of the goal with such precision.
-Kids-They're not sleeping, they're recharging!
-Kill them all! .... Let God sort them out.
-Killer Rabbit's Motto: 'Lettuce Prey.'
-Kilroy occupied these coordinates.
-Kleptomania: take something for it
-Know what I hate? I hate rhetorical questions!
-Knowing Murphy's Law won't help either.
-LISP: To call a spade a thpade.
-LISTEN HERE! I HAVE FIRST AMENDENT RIGH(@#$!9*&^ NO CARRIER
-LOTUS - Let Only The Users Suffer
-Laddie, ya think ya might like ta ... rephrase that?
-Land of the Single Entendre...
-Last week I forgot how to ride a bicycle.
-Laugh and the world thinks you're an idiot.
-Laughter: The shortest distance between two people.
-Lead me not into temptation, I can find it myself.
-Lesser artists borrow. Great artists steal.
-Let he who takes the plunge remember to return it!
-Let's organize this thing and take all the fun out of it.
-Let's split up, we can do more damage that way.
-Liberal - a power worshiper without power.
-Libraries: There are no answers, only cross references.
-Life - brief interlude between nothingness and eternity.
-Life can be great if you live it to the fullest!
-Life is a sandwich, and it's always lunchtime
-Life is a series of very rude awakenings.
-Life is like a Car-wash and I'm on a bicycle.
-Life is only as long as you live it.
-Life is serious, but ART is fun!
-Life is tough. It's tougher when you're stupid.
-Life is uncertain...eat dessert first!
-Life sucks, but Death swallows!
-Life would be easier if I had the source code.
-Life's too short to dance with ugly men.
-Life's too short to dance with ugly women.
-Life, loathe it or ignore it, you can't like it.
-Likelihoods, however, are 90% against you.
-Likes and dislikes are among my favorites
-Linux, the choice of a GNU generation.
-Liposuction will destroy your FAT
-Lisp programmers have to stop and collect garbage.
-Live before you die.
-Living poor is best left to those with no money.
-Locked coathanger in car. Good thing I had a key.
-Looks like I picked the wrong week to stop sniffing glue.
-Love is blind, marriage is the eye-opener.
-Luxuriantly hand-crafted from only the finest ASCII.
-M.A.D.D.: Midgets Against Desk Drawers.
-MOPAR = Move Over Plymouth Approaching Rapidly!
-MS Windows -- From the people who brought you EDLIN!
-MS-DOS: celebrating ten years of obsolescence
-Macho does not prove Mucho.
-Madness takes its toll; please have exact change.
-Make Headlines..use a corduroy pillow....
-Make it as simple as possible, but no simpler.
-Make it do ... Or do without.
-Make like a Tom and Cruise.
-Make like a baby and head out.
-Make like a banana and split.
-Make like a drum and beat it!
-Make like a tree and leave.
-Make somebody happy. Mind your own business.
-Make up a language and ask people for directions.
-Man has his will. Woman has her won't!
-Man invented language to satisfy his need to complain.
-Man who get hit by car, get that run down feeling
-Man who jumps through screen door likely to strain himself
-Man who put head on railroad track get splitting headache
-Man who run behind car get exhausted.
-Man who speaks with forked tongue should not kiss balloon
-Marching to a different kettle of fish.
-Mary had a little RAM -- only about a MEG or so.
-Math is the language God used to write the universe.
-May I please be excused? My Brain is full.
-May the Porsche be with you.
-May you live in interesting times.
-May your life be filled with experiences.
-Me know gammar. Me cood use it gud.
-Mediocrity requires aloofness to preserve it's dignity
-Meditation is not what you Think.
-Meet the new Boss--same as the old Boss...
-Megabyte: A nine course dinner.
-Member: International Brotherhood of Tagline Thieves!
-Memory is a thing we forget with.
-Mental Floss prevents Moral Decay.
-Mercifully free of the ravages of intelligence
-Microfiche: Sardines.
-Microsoft Windows... a virus with mouse support.
-Microsoft gives you Windows... Linux gives you the whole house.
-Migratory lifeform with a tropism for parties
-Minds are like parachutes, they only work when open.
-Misfortune: The kind of fortune that never misses.
-Misspelled? Impossible. My modem is error correcting!
-Mistakes are often the stepping stones to utter failure.
-Modem: What landscapers do to dem lawns.
-Money is the root of all wealth.
-Monogamy leaves a lot to be desired.
-Monopoly? No, we just don't want competition.
-Most of us have been at work for several hours now.
-Mother is the invention of necessity.
-Multitasking = 3 PCs and a chair with wheels!
-Multitasking causes schizophrenia..
-Murphy is out there... waiting...
-Murphy was an optimist.
-Murphy's law needs to be repealed.
-Must Go - My Rotweiler needs its teeth sharpened.
-My *taglines* are original. *I* am a copy.
-My RAM's not what it used to be, so don't quote me.
-My attention isn't hard to get. It IS hard to keep...
-My best friend is a social worker.
-My computer has a terminal illness
-My computer's sick, I think my modem's a carrier
-My couch potato routine honed to perfection
-My fallacies are more logical than your fallacies.
-My foolish parents taught me to read and write.
-My hat covers my head... Just like hair used to!
-My haystack had no needle!
-My head is sore, and there's a hole in the brick wall!
-My inferiority complexes aren't as good as yours.
-My karma ran over your dogma.
-My life may be strange, but at least it's not boring
-My message above. Your response here ____________.
-My other computer is a Cray Y/MP-4!
-My other computer is a HAL 9000.
-My other computer is an abacus.
-My other vehicle is a Galaxy Class Starship ...
-My reality check just bounced.
-My tagline can beat up your tagline!
-My weight is perfect for my height... which varies.
-NAVY: Never Again Volunteer Yourself
-NETWORK: What fishermen do when not fishing.
-NEWS! Drunk gets nine months in violin case
-NEWS! Enraged cow injures farmer with ax
-NEWS! Iraqi head seeks arms
-NEWS! Police begin campaign to run down jaywalkers
-NEWS! Stolen painting found by tree
-NEWS! Survivor of siamese twins joins parents
-NO! Taco Bell is NOT the Mexican Phone Company!
-NUMBER CRUNCHING: Jumping on a Computer.
-Naaah, real men don't read docs.
-Nanosecond: Mork's stunt man.
-Neil Armstrong tripped.
-Neither rain, nor snow, nor l?ne n*oi*se
-Neurotic: Self-taut person.
-Never argue with a woman when she's tired, or rested.
-Never assume. It makes an 'ass' out of 'u' and 'me'.
-Never count your chickens before they rip your lips off.
-Never draw fire, it irritates everyone around you
-Never eat anything bigger than your head.
-Never eat more than you can lift.
-Never enter a battle of wits unarmed.
-Never go with the odds
-Never hit a man with glasses. Use your fist!
-Never judge a man by his taglines.
-Never let your feet run faster than your shoes.
-Never mind the facts - I know what I know.
-Never park your hard disk in a tow-away zone.
-Never say, 'Oops!'; always say, 'Ah, interesting!'
-Never test for an error you don't know how to handle.
-Never trust a man who can count to 1,023 on his fingers
-Never trust a skinny cook.
-Never underestimate the power of human stupidity.
-Never use a preposition to end a sentence with.
-New Highway gets Railroaded.
-Newsbytes - Microsoft announce EDLIN for Windows.
-Nihilism should commence with oneself.
-Ninety per cent of everything is crap.
-Nitpicking: Not just a hobby, it's a way of life!
-Nitrate: Lower than the day rate.
-No .sig is a good .sig
-No free lunch in an ecosystem.
-No one EXPECTS the Spanish Inquisition!!!
-No one ever said 'if I'd only spent more time in the office'
-No radio. Already stolen.
-No sense being pessimistic. It wouldn't work anyway.
-No wanna work. Wanna bang on keyboard.
-No, I'm from Iowa. I only work in Outer Space.
-Nobody roots for Goliath.
-Nobody shoots at Santa Claus.
-Nodding the head does not row the boat.
-None of you exist, my Sysop types all this in.
-Nostalgia isn't what it used to be.
-Not a computer nerd; merely a techno-weenie.
-Not a real tagline, but an incredible soy substitute.
-Not many people realize just how well known I am.
-Not now, John, we gotta get on with the game show...
-Not quite human any longer.
-Nothing is 100% certain, bug free or IBM compatible.
-Nothing is as inevitable as a mistake whose time has come
-Nothing is ever so bad that it can't get worse.
-Nothing is foolproof because fools are so ingenious
-Nothing is impossible for anyone impervious to reason
-Nothing recedes like success.
-Nothing succeeds like excess.
-Now entering Iowa. Please set your clocks back 20 years.
-Now go away or I shall taunt you a second time.
-Now is not a good time to annoy me
-Now is the time for all good men to come to.
-Now that I've given up hope I feel much better...
-Nudge, nudge, wink, wink, know what I mean?
-O Oysters come and walk with us, the Walrus did beseech.
-OK Scotty, detonate and energize NOW! No, wait, I mean.......
-OK, I'm weird! But I'm saving up to become eccentric.
-OPERATOR! Trace this call and tell me where I am.
-OUT TO LUNCH - If not back at five, OUT TO DINNER!
-Obe Wan Kenobi at the dinner table: 'Use the FORKS, Luke!'
-Objection, your Honor! My client is an idiot!
-Objectivity is in the eye of the beholder
-Objects in taglines are closer than they appear.
-Of all the people I've met you're certainly one of them
-Of all the things I've lost, I miss my mind the most.
-Of course I'm running Windows[kVxB NO CARRIER
-Oh goody! Another Muranium Explosive Space Modulator!
-Oh no you don't! You're not stealing this one!
-Oh no, not another learning experience!
-Oh, Bullwinkle, that trick NEVER works!
-Ok, I pulled the pin. Now what? Where are you going?
-Okay - right after this one we're BACK to the TOPIC
-Old MacDonald had a computer with an EIE I/O
-Old age is better than the alternative.
-On a clear disk you can seek forever.
-On a scale of 1 to 10, 4 is about 7.
-On an electrician's truck: Let Us Remove Your Shorts
-One atom bomb can really ruin your day.
-One good turn gets most of the blanket.
-One is never as happy or unhappy as one imagines.
-One man's Windows are another man's walls...
-One man's upload is another man's download
-One night I came home very late. It was the next night
-One tactical thermonuclear weapon can ruin your whole day.
-One way to better your lot is to do a lot better...
-One way to stop a run away horse is to bet on him.
-Only 19,999 lines of C++ to my next ski trip...
-Only cosmetologists give make-up exams.
-Only the winners decide what were war crimes.
-Open Mouth. Insert Foot. Chew Carefully.
-Optimization hinders evolution.
-Originality is the art of concealing your sources.
-Our houseplants have a good sense of humous.
-Our necessities are few but our wants are endless...
-Out here in the fields...I fight for my meals...!
-Out of Memory!? But I fed you 6 Megs this morning!
-Out of the mouths of babes does often come cereal.
-Outlaw junk mail, and save the trees!
-Overload--core meltdown sequence initiated.
-Oxymoron - Definite possibility
-Oxymoron - Military Intelligence
-Oxymoron: Bosnian Cease-Fire
-Oxymoron: Soviet Union.
-PC! Politically Correct (or) Pure Crap!
-PCBackup: 1 of 1362 disks.
-PI seconds is a nanocentury. - Tom Duff, Bell Labs
-PKZip - it's not just for downloads anymore
-Pain is inevitable, suffering is optional.
-Palindrome isn't one.
-Pandemonium doesn't reign here... It pours!
-Paranoia is heightened awareness.
-Paranoia is simply an optimistic outlook on life.
-Pardon my driving, I'm trying to reload.
-Pascal: What's it Wirth?
-Passwords are implemented as a result of insecurity.
-Patience is a virtue that carries a lot of WAIT!
-Pay your electric bill in pennies.
-Peace through superior firepower.
-People are always available for work in the past tense.
-People say I'm apathetic, but I don't care.
-People who live in glass houses shouldn't!
-People who live in stone houses shouldn't throw glasses.
-Perot/Bush/Quayle: The Millionaire, Skipper & Gilligan.
-Pet Store: 'Buy one, get one flea.'
-Petroleum and coffee had no value a few centuries ago.
-Pi R squared. Nooo! Pie R round, cornbread R square!
-Pizza IS the four food groups!
-Plagiarism is the sincerest form of flattery.
-Plagiarism prohibited, derive carefully.
-Plankton lobbyist: 'NUKE THE WHALES!'
-Plasma is another matter.
-Please Tell Me if you Don't Get This Message
-Please call the windows police. I've caught another gpf.
-Please don't drink and post.
-Please don't take my sunshine away.
-Please recycle this tagline. Once is not enough.
-Pobody's Nerfect!
-Poets go from bad to verse
-Point not found. A)bort, R)eread, I)gnore.
-Politeness, n: The most acceptable hypocrisy.
-Political panjandrums prologize pedantic paronomasia.
-Political power grows out of the barrel of a gun.
-Politics is the entertainment branch of industry.
-Positive: Mistaken at the top of one's voice.
-Pound forehead on keyboard to continue.
-Power corrupts, but we need electricity.
-Power corrupts. Absolute power is kind of neat.
-Predestination was doomed from the start.
-Predicting the future of technology is fraud with peril!
-Prejudice is the reason of fools. - Voltaire.
-Preserve wildlife... pickle a rat.
-Press <CTRL>-<ALT>-<DEL> to continue...
-Press any key to continue or any other key to quit
-Press any key...NO, NO, NO, NOT THAT ONE!!!!!!
-Procrastination means never having to say you're sorry.
-Procrastination: The art of keeping up with yesterday.
-Program too small to fit into memory.
-Programming is an art form that fights back.
-Progress is made on alternate Fridays.
-Prosecutors will be violated
-Psychiatrists stay on your mind.
-Psychoceramics: The study of crackpots.
-Push the limit, and the limit will move away!
-Put on your seatbelt. I wanna try something.
-Put people on hold when possible.
-Quantum mechanics do it in leaps.
-Quasimodo is a dead ringer.
-Question Authority, ask me anything
-RAID Antivirus - Kills Virus's DEAD!!!
-Racial prejudice is a pigment of the imagination.
-Radioactive halibut will make fission chips.
-Random order = oxymoron
-Rap music = oxymoron
-Read the dictionary backwards and look for secret messages.
-Real Programmers aren't afraid to use GOTO's.
-Real Trekkers work out at the He's Dead Gym.
-Real men don't set for stun.
-Real men write self-modifying code.
-Reality is a crutch for people who can't handle buttons
-Reality is an obstacle to hallucination.
-Reality is for people who can't handle Star Trek.
-Reality is nothing but a collective hunch.
-Really ?? What a coincidence, I'm shallow too!!
-Recursive, adj.; see Recursive
-Red ship crashes into blue ship - sailors marooned.
-Reduce Carbon Dioxide emmissions - STOP Breathing
-Redundancy: A Politician with an airbag in his car.
-Refuse Novocain...Transcend Dental Medication!
-Remember that you are unique. Just like everyone else.
-Remember, If you're not in bed by 10:30..... go home!
-Remember, Subaru spelled backwards is U-R-A-BUS.
-Reputation: what others are not thinking about you.
-Resistance Is Useless! (If < 1 ohm)
-Return((usBirdInHand = 2 * InTheBush()));
-Reverse the polarity of the neutron flow.
-Revolution is the opiate of the intellectuals.
-Road Kill Cafe: You kill 'em, we grill 'em.
-Roses are red, Violet's are blue, And mine are white.
-Rotisserie: a ferris wheel for chickens
-Round up the usual suspects!
-Rubber bands have snappy endings!
-Russian Express Card motto: Don't leave home!
-S met ing's hap ening t my k ybo rd . .
-SCUD : Sure Could Use Directions
-STICK: A boomerang that doesn't work.
-STUPIDITY is NOT a HANDICAP! Park elsewhere!
-SYNTAX? Why not--they tax everything else!
-SYSTEM ERROR: press F13 to continue...
-Santa's elves are just a bunch of subordinate Clauses.
-Sarcasm: barbed ire.
-Save California; when you leave take someone with you.
-Save energy: be apathetic.
-Save the whales! Trade them for valuable prizes!
-Save the whales. Collect the whole set.
-Save your money for a rainy day, or a new computer!
-Say yer prayers, y' flea-bitten' varmint.
-Schizophrenia beats being alone.
-Science asks why. I ask why not.
-Science: preconception meeting verification.
-Scientists discover life causes cancer.
-Scotty! Hurry! Beam me uragg^*z~% NO CARRIER
-Scrute the inscrutable, eff the ineffable.
-See how you can be?
-Seeing is deceiving. It's eating that's believing.
-Send lawyers, guns, & money...
-Send more tourists..... the last ones were delicious!
-Sentient plasmoids are a gas.
-Serving the scum of Paris for over 300 years
-Set mode=Extremely verbose
-Shareware author dies: .GIF at eleven!
-Shareware: forget the manual...phone the author at home!
-ShelfDoze is a registered Trademark of M$.
-Shell to DOS... come in DOS... Do you copy?
-Shh! Be vewy quiet, I'm hunting wuntime errors!
-Shin - a device for finding furniture in the dark..
-Shoot your program and put it out of its memory!
-Shoplifters with the runs take Clepto Bismol
-Short people are vertically challenged.
-Should I or shouldn't I?... Too late, I did!
-Should I weed the lawn or say it's a garden?
-Show me a sane man. I'll cure him for you.
-Sign here please:_______________________Thanks
-Sign on Closed Nuclear Power Plant... 'Gone Fission'
-Sign on a clothing store - Come inside and have a fit.
-Signito ergo sum - I sign therefore I am.
-Simon says: don't be so suggestible.
-Sit down, you're rocking the boat!
-Six of one, 110 (base 2) of another.
-Skating away on the thin ice of a new day.
-Slower Traffic Keep Right - Is that so difficult?
-Slug Sautee: a hors of a different d'oeuvre.
-Small changes pick up the reins from nowhere.
-Smash forehead on keyboard to continue...
-Smile. It's the second best thing you can do with your lips.
-Smile... people will wonder what you've been up to.
-Smiley faces were meant to be annoying.
-Smokey the Bear says, 'Strip mining prevents forest fires!'
-Smoking cures weight problems...eventually.
-Smoking is a leading cause of statistics.
-Smurf exterminator.
-So many bytes, so few cps.
-So many lawyers, so few bullets.
-So many pedestrians, so little time.
-So many toys, so little time...
-So much time, and so little to do.
-Socialism is the equal distribution of poverty.
-Software Independent: Won't work with ANY software.
-Software means never having to say you're finished
-Some Do, Some Don't, Some Will and Some Won't.
-Some People....
-Some days you're a bug, other days a windshield.
-Some days, nothing goes left.
-Some little dipstick stole all my good taglines...
-Some minds should be cultivated, others plowed under...
-Some people are so nice to be nasty to.
-Some people are, through no fault of their own, sane.
-Some things have got to be believed to be seen.
-Someone is unenthusiastic about your work.
-Something is rotten in the state of confusion.
-Sometimes a cigar is just a cigar.
-Sorry about your Rectal-Cranial Inversion.
-Sorry, I don't date outside my species.
-Sorry... my mind has a few bad sectors.
-Southern DOS: Y'all reckon? (yep/Nope)
-Space is an illusion, disk space doubly so.
-Space is big. Really big.
-Spaceman Spiff, Interplanetary Explorer!
-Speaking only for myself, one of my many tricks.
-Spell chequers dew knot work write.
-Spice is the variety of life.
-Stamp out philately!
-Standing there making a sitting target of himself.
-Stay Alert. Stay Awake. Stay Alive.
-Steal my cash, car and TV - but leave the computer!
-Sterility is hereditary.
-Stop tagline theft! Copyright your tagline ©
-Strike any user when ready.
-Stupidity got us into this mess, why can't it get us out?
-Subvert the dominant paradigm!
-Suicide is the most sincere form of self criticism.
-Sumo Wrestling: survival of the fattest.
-Supercalifragilisticexpialidocius
-Supernovae are a Blast
-Support bacteria - it's the only culture some people have!
-Support the helpless victims of computers.
-Surprise your boss. Get to work on time.
-Swish, two, three, four! Swish, two, three, four!
-Sylvester Stallone: father of the RISC concept.
-THE GOLDEN RULE: He who has the gold makes the rules
-TV is chewing gum for the eyes.
-Tact: knowing how far to go too far.
-Tact: making a point without making an enemy.
-Tagline Lotto: 2222222222<- Scratch here for prize.
-Tagline theft is a compliment.
-Taglines \'tag-l\ 4inz \ The bumperstickers of the internet
-Take a bite out of crime .. Abolish the IRS!
-Take my advice, I don't use it anyway.
-Take two crows and caw me in the morning
-Talk is cheap because Supply exceeds Demand.
-Taxes are not levied for the benefit of the taxed.
-Teamwork is essential. It gives them another target.
-Ten weeks from Friday will be a pretty good day.
-Thank you very little.
-That ain't so good English!
-That must be wonderful! I don't understand it at all.
-That that is is not that that is not.
-That was ZEN -- this is TAO
-That'll be $67.50 CCCHHHHHIIIIINNNNGGGG!!!!
-That's inches away from being millimeter perfect.
-The Borg assimilated me & all I got was this stupid T-Shirt!
-The Czech's in the mail. Sending Frenchman by FAX.
-The French defense isn't...
-The Hubbell works fine; all that stuff IS blurry!
-The Lab called,..... Your brain is ready!
-The Magic of Windows: Turns a 486 back into a PC/XT.
-The Microsoft Motto: 'We're the leaders, wait for us!'
-The PARITY CHECK is in the E-MAIL...
-The Tour de France!
-The UARTs won't take this speed, Captain
-The Universe is a big place... perhaps the biggest
-The Vatican Express Card. Don't leave Rome without it.
-The backup's not over 'til the FAT table sings!
-The ballot is stronger than the bullet.
-The best cure for insomnia is to get a lot of sleep.
-The best defense against logic is stupidity.
-The best defense is to stay out of range.
-The best substitute for experience is being sixteen.
-The best way to keep friends is not to give them away.
-The best way to win an argument is to be right.
-The buck doesn't even slow down here!
-The cause of problems are solutions!
-The cost of feathers has risen... Now even DOWN is up!
-The cost of living hasn't affected its popularity.
-The cream rises to the top. So does the scum...
-The days of the digital watch are numbered
-The dentist said my wisdom teeth were retarded.
-The dreadful burden of having nothing to do.
-The evidence before the court is...INCONTROVERTIBLE!
-The eyes are the mirror of the soul.
-The first duty of a revolutionary is to get away with it
-The first myth of management is that it exists.
-The first rule of intelligent tinkering is save all parts!
-The fish that escaped is the big one.
-The further I go, the behinder I get.
-The future isn't what it used to be.
-The game's a little bit wide open again.
-The gene pool has no lifeguard.
-The hand that turneth the knob, opens the door.
-The hangman let us down.
-The hardest thing about time travel is the grammar.
-The heart is wiser than the intellect...
-The irony of life is that no one gets out alive...
-The large print giveth and the small print taketh away.
-The little engineer that could
-The longer the title, the less important the job.
-The man who begins many things finishes few.
-The margin is very marginal.
-The meek shall inherit the earth, if that's OK with you
-The mind is like a parachute - it works only when open.
-The moving cat sheds, and having shed, moves on...
-The next thing to do is hang all the consultants.
-The only thing shorter than a weekend is a vacation.
-The option to override self-destruct expir@^%i@&$#NO CARRIER
-The pen is mightier than the pencil.
-The penalty for bigamy is having two mothers-in-law.
-The pendulum has gone full circle.
-The purpose of computing is insight, not numbers.
-The rich get richer; the poor get babies.
-The road to success is always under construction.
-The score didn't really reflect the outcome.
-The secret of the universe is~~*#~** FF * NO CARRIER
-The shortest distance between two points is off the wall
-The simple explanation always follows the complex solution
-The sixth sheikh's sixth sheep's sick.
-The soul would have no heart had the eyes no tears...
-The superfluous is very necessary.
-The thrill is gone, the thrill is gone baby
-The universe is a spheroid region 705 meters in diameter...
-The unnatural, that too is natural.
-The way to a man's heart is through the left ventricle.
-The weather is here, wish you were beautiful.
-The whole world is about three drinks behind
-The world is coming to an end. Please log off.
-The worst thing about censorship is **************************.
-The young know the rules, the old know the exceptions.
-Then somebody spoke, and I went into a dream....
-There are 2 ways to handle women and I know neither.
-There are many things I could say...
-There are no atheists in the foxholes.
-There is always a way, and it usually doesn't work.
-There is an exception to every rule, except this one.
-There is much Obiwan did not tell you.
-There is no dark side of the moon. Really.
-There is no finish line.
-There is no remedy for fun but more fun!
-There is no vaccine against stupidity.
-There is something to be said about me: 'Wow!!'
-There will be no last bus tonight.
-There's a hot place with pitchforks waiting.
-There's no future in time travel
-There's no such thing as a free lunch, but you can always find someone willing to treat.
-There's one in every car... You'll see.
-There's one in every crowd and they always find me.
-There's safety in numbers/When you learn to divide.
-Thesaurus: ancient reptile with an excellent vocabulary.
-They told me I was gullible ... and I believed them!
-Things are not what they seem.
-Think 'HONK' if you're a telepath.
-Think hard now! Which one is Shinola?
-This Charlie Brown must have been a very wise man.
-This Country Needs Group Therapy.
-This ain't no party...this ain't no disco...
-This door is baroque; please call Bach later.
-This is a Tagline mirror ][ rorrim enilgaT a si sihT
-This is abuse. Arguments are down the hall.
-This is just a hobby. Perfection is not required. Fun is.
-This is not a fairing, it's a force field.
-This is only a test.
-This is our only tag line.
-This isn't right. This isn't even wrong.
-This line intentionally left unjustified.
-This login session: $13.99, but for you $11.88
-This message has been UNIXized for your protection.
-This message is SHAREWARE! To Register, send $5.
-This message was typed on recycled phosphorous.
-This mind intentionally left blank.
-This program makes me look like a genius.
-This sentence is false.
-This tagline does not require Micro$oft Windows.
-This tagline intentionally left blank.
-This tagline is umop apisdn
-This tagline only to be removed by the consumer.
-This tagline was created from many little letters.
-This tagline was reclaimed and is not yet stolen.
-This tagline was written before a live studio audience.
-Those who can't write, write manuals.
-Those who can, do. Those who can't, simulate.
-Those who can, do. Those who can't, supervise!
-Those who live by the nit, die by the nit
-Those without heads do not need hats.
-Three can keep a secret, if two are dead.
-Tilt your chair back, your breath is effecting my RAM!
-Tilting at windmills hurts you more than the windmills.
-Time flies like an arrow - Fruit flies like a banana
-Time flies when you don't know what you're doing.
-Time is an illusion, lunchtime doubly so.
-Tis better to be hunter than hunted.
-Tis better to have loved a short than to never have loved a tall.
-Tis better to have loved and lost than just to have lost.
-To be, or not to be, those are the parameters.
-To boldly go and watch Star Trek re-runs.
-To do nothing is also a good remedy.
-To eat is human, to digest, divine.
-To err is human, to eat Jello, is messy.
-To err is human, to forgive is against company policy.
-To err is human. To really screw up it takes a computer.
-To err is human. To blame someone else is politics.
-To err is human. To moo bovine
-To every rule there is an exception, and vice versa.
-To iterate is human, to recurse, divine.
-To live in the hearts we leave behind, is not to die.
-To live well, know the difference between good and evil.
-To me personally, it's nothing personal to me.
-To shoot a mime, do you use a silencer?
-Today is Monday, cleverly disguised as Tuesday.
-Today is National Existential Ennui Awareness Day.
-Today is the first day of the rest of this mess.
-Today is the tomorrow you worried about yesterday
-Todays subliminal message is ' '
-Tolkien is hobbit-forming.
-Tongue tied & twisted, just an earthbound misfit I.
-Too bad stupidity isn't painful.
-Too much is never enough.
-Too much month at the end of the money.
-Too much of a good thing is WONDERFUL.
-Toto, I don't think we're in DOS anymore...
-Touch if you must, Pay up if you bust.
-Toys are made in heaven, batteries are made in hell.
-Trees hit cars only in self-defence.
-Trespassers will be shot, survivors will be shot again!
-Tried to play my shoehorn... all I got was footnotes!
-Trig..a..name...o...tree!!!
-Truck Pulls: for people who cannot understand the WWF
-Trust me -- I'm a Lawyer.
-Truth is just another misconception.
-Truthful: Dumb and illiterate.
-Try to get back on topic, he said moderately.
-Try to look unimportant, they may be low on ammo
-Try? Try not. Do, or do not. There is no try.
-Trying to think of a good tagline...
-Tubby or not tubby, fat is the question!
-Turn right here. No! NO! The OTHER right!
-Turning floppies into hard drives.
-Two Wrongs Don't Make A Right, But Three Lefts Do.
-Two heads are more numerous than one.
-Two most common elements: hydrogen, stupidity.
-Tyre Shop sign - We Skid You Not.
-UART what UEAT!
-UNNAMED LAW: If it happens, it must be possible.
-Uh, yeah...I MEANT to do that!
-Ultimate Question Research Team
-Unable to locate Coffee -- Operator Halted!
-Unburdened by the rigors of coherent thought.
-Unix and the world Unix with you; VAX and you VAX alone.
-Unless you're the lead dog, the view never changes.
-Unqualified superlatives are the worst of all.
-Until people grow up, they have no idea what's cool
-Use your MasterCard to pay your Visa bill.
-Users, losers -- what's the difference?
-Using yesterday's technology to solve today's problems, tomorrow
-VLSI: 'Getting High On Low Voltage'
-Vampires Against Mundane Poetry.
-Variables won't; constants aren't.
-Veni Vidi Visa: I came, I saw, I did a little shopping.
-Verbosity leads to unclear, inarticulate things.
-Volcano -- a mountain with hiccups.
-Vote Democratic... It's easier than getting a job.
-Vuja De - The Feeling You've Never Been Here
-Vulcans have less fun.
-Vultures only fly with carrion luggage.
-W.A.R.P.: We Are Real Programmers.
-WAITER! there's soup in my fly!
-WARNING ... drinking tap water can kill your thirst!
-WARNING: my messages are offensive to morons!
-WINDOWS ERROR #004: Operator fell asleep while waiting.
-WWhhaatt ddooeess dduupplleexx mmeeaann??
-WYGIWYD -What you got is what you deserved.
-WYTYSYDG-What you thought you saw, you didn't get.
-Waiter, there's no fly in my soup! - Kermit
-Walk softly and carry a megawatt laser.
-Walls impede my progress
-Wanna flirt with disaster? Become a SysOp!
-Want a LAUGH run a spell check on DSZ docs.
-Want a jelly baby?
-Want a stupid answer? Ask me anything!
-Wanted: Volcano. Average size. Must be active.
-War News: Saddam's army blown away by Thai hookers.
-Warning: Whimsical when bored
-Warning: Politicians can damage your wealth.
-Warranty void if tagline removed.
-Was today really Necessary?
-Wash your face in the morning, neck at night.
-Wasting time is an important part of living.
-We all live in a yellow subroutine.
-We are not a clone.
-We are the people our parents warned us about
-We don't care. We don't have to. We're Telecom...
-We have here the latest in primitive technology.
-We seem to have juxtaposed an impasse here
-We should limit congressmen to two terms: one in Congress, one in prison
-We take drugs very seriously at my house...
-We were unanimous - in fact everyone was unanimous.
-We'll give you piece de resistance and a tour de force
-We're as similar as two dissimilar things in a pod.
-We're lost, but we're making good time.
-We're staying together for the sake of the cats.
-Weeping, I wake; waking, I weep, I weep.
-Welcome to Texas, now go home.
-Welcome to the Church of the Holy Cabbage. Lettuce pray
-Well cover me in egg & flour and bake me for 14 minutes
-What are you doing?!? The message is over,GO AWAY!
-What can you do for me?
-What color is a chameleon on a mirror?
-What could possibly go wrong.
-What do batteries run on?
-What do you mean that 2 years have passed??
-What do you think?
-What does Santa do at a house with no chimney?
-What does ignorant mean?
-What does this red button do?
-What else can you do at 3:00 am?
-What garlic is to salad, insanity is to art.
-What goes around usually gets dizzy and falls over.
-What goes up has probably been doused with petrol.
-What has four legs and an arm? A happy pitbull.
-What's Irish and stays out all night? Paddy O'Furniture.
-What's another word for 'thesaurus?'
-What's brown and sticky? A stick!
-When 911 won't work .357 will!
-When in doubt, think.
-When their numbers dwindled from 50 to 8, the dwarfs began to suspect 'Hungry'
-When your opponent is down, kick him.
-Where does weight go when you lose it?
-Where in the world is Carmen San Diego?
-Who cares how it plays in Peoria?
-Who cares who's on board?
-Who glued the cup to the table?
-Who is 'they' anyway?
-Whosoever diggeth a pit shall falleth therein.
-Why am I asking all these things?
-Why are Chinese fortune cookies written in English?
-Why are you looking down here? The joke is above!
-Why are you wasting time reading taglines?
-Why aren't there many Hannukah specials on tv?
-Why can't we just spell it orderves?
-Why did you read this?
-Why do people cry when they're sad?
-Why do they tell us to watch 'The Today Show' tomorrow?
-Why do we elect people and then become afraid of them?
-Why do we read left to right yet turn pages right to left?
-Why do you think they call it 'find'?
-Why does it matter if we all put our pants on one leg at a time?
-Why does the beginning of your sentence end up in the middle of mine?
-Why don't ease, lease, and please sound alike?
-Why don't tomb, comb, and bomb sound alike?
-Why get even, when you can get odd?
-Why is 'abbreviated' such a long word?
-Why isn't 'palindrome' spelled 'palindromeemordnilap'?
-Will Rogers never met a lawyer.
-Will the sound of one hand clapping still turn off my TV?
-Win if you can, lose if you must, but always cheat
-Windows Error #F99 - CPU too tired to continue...
-Windows N'T: as in Wouldn't, Couldn't, and Didn't.
-Windows NT: Only 16 megs needed to play Minesweeper!
-Windows NT: The world's only 80 megabyte Solitaire game!
-Windows NT: Vapourware of the desperate and scared.
-Windows error 000 : No errors found! [CLOSE]
-Windows is *NOT* a virus. Viruses *DO* something!
-Windows is for fun, Linux is for getting things done.
-Windows is the best GUI - It always sticks!
-Windows isn't CrippleWare -- it's 'Functionally Challenged'.
-Windows only crashes itself under Linux. Not the whole machine.
-Windows would look better with curtains.
-Windows: The answer to a question nobody has ever asked.
-Windows: an Unrecoverable Acquisition Error!
-WindowsNT: From the makers of Doublespace
-Wisdom is knowing what to do with what you know.
-Wit is cultured insolence.
-Without Time, everything would happen at once.
-Without music, life would be a mistake.
-Women - can't live with 'em and no resale value...
-Women do come with instructions; ask them.
-Women get minks the same way minks get minks.
-Women who seek to be equal to men lack ambition.
-Women! Can't live with 'em and no resale value.
-Work off excess energy. Steal something heavy
-World ends today at 9:30 pm! Film at 11:00...
-Worry : The interest paid on trouble before it's due
-Worst-dressed sentient being in the known universe
-Would I ask you a rhetorical question?
-Yes my son, long ago mail was read 1 packet at a time.
-You buttered your bread, now lie in it.
-You can name your salary here. I call mine Fred.
-You can tune a guitar, but you cant tuna fish.
-You can't have everything...where would you put it?
-You hit the nail right between the eyes.
-You're it.
-You've got to be trusted by the people that you lie to.
-Young gorillas are friendly, but they soon learn.
-Your E-Mail has been returned due to insufficient voltage!
-Youth is a gift of nature. Age is a work of art.
-Yuk, what kind of dumb menu system is that? Oh, so that is Windows!
-Zen T-Shirt: Enlightenment Available - Enquire Within
-[DISCLAIMER: my fingers are epileptic]
-[If you can't hear me, it's because I'm in parentheses]
-hAS ANYONE SEEN MY cAPSLOCK KEY?
-Serenity through viciousness.
-FUN is never having to say you're SUSHI!!
-Include me out.
-YOW!! I'm in a very clever and adorable INSANE ASYLUM!!
-'That boy's about as sharp as a pound of wet liver' -- Foghorn Leghorn
-Pardon me while I laugh.
-Vegeterians beware! You are what you eat.
-Marriage is the sole cause of divorce.
-'From there to here, from here to there, funny things are everywhere.' -- Dr. Seuss
-You'll be sorry...
-The world is coming to an end. Please log off.
-UH-OH!! We're out of AUTOMOBILE PARTS and RUBBER GOODS!
-I used to get high on life but lately I've built up a resistance.
-Paranoia is heightened awareness.
-The things that interest people most are usually none of their business.
+++ /dev/null
-#v1: blootbot -- infobot -- written Sat Jan 21 06:17:24 2006
-
-#botpark
- -OnJoin
- +RootWarn
- +autojoin
-
-#debian-bots
- +News
- +RootWarn
- +chanlimitcheck
- chanlimitcheckInterval 10
- chanlimitcheckPlus 10
- factoidDeleteDelay 7
- ircTextCounters heh hah :) ? hi lol
- +joinfloodCheck
- limitcheckInterval 10
- limitcheckPlus 10
- newsDefaultExpire 7
- +newsKeepRead
- +newsNotifyAll
- rootWarnMode aggressive
-
-_default
- +BZFlag
- +Debian
- +DebianExtra
- +Dict
- +Exchange
- +Factoids
- +HTTPDtype
- +Kernel
- +Math
- +OnJoin
- +Plug
- +Quote
- +Rss
- +Search
- +Topic
- +Units
- +UserInfo
- +W3Search
- +Weather
- +Zippy
- addressCharacter ~
- +allowConv
- +allowTelling
- +babelfish
- +botmail
- +case
- +cookie
- +countdown
- debianRefreshInterval 7
- +dice
- +dns
- +factoidArguments
- factoidSearch $chan _default
- floodMessages 10:30
- floodRepeat 2:10
- +freshmeat
- freshmeatRefreshInterval 24
- +insult
- +karma
- +lart
- +limitcheck
- +log
- maxListReplyCount 15
- maxListReplyLength 400
- +md5
- minVolunteerLength 50
- +nickometer
- +pager
- +piglatin
- randomFactoidInterval 60
- randomQuoteInterval 60
- +reverse
- +scramble
- +sed
- +seen
- seenFlushInterval 60
- seenMaxDays 90
- +seenStats
- +seenStoreAll
- sendNoticeLimitBytes 1000
- sendNoticeLimitLines 3
- sendPrivateLimitBytes 1000
- sendPrivateLimitLines 3
- sendPublicLimitBytes 1000
- sendPublicLimitLines 3
- +slashdot
- +spell
- +tell
- +wtf
- +zfi
- +zsi
-
+++ /dev/null
-# blootbot configuration file, modify it to your own taste. blootbot reads
-# this file from files/blootbot.config so it should be moved there.
-
-#####
-# Basic IRC info
-#####
-set ircNick blootbot
-set ircUser blootbot
-set ircName blootbot experimental bot
-# if your irc network requires a password to get on the servers
-#set ircPasswd SomePassword
-set ircUMode +iw
-
-# if not using a virtualhost set to 0.0.0.0
-# otherwise IRC::Connection might try localhost which will NOT work
-###set ircHost vh.virtualhost.org
-set ircHost 0.0.0.0
-
-set owner OWNER
-
-# nickserv/chanserv support.
-###set nickServ_pass PASSWORD
-###set chanServ_ops #chan1 #chan2
-
-# default quit message.
-set quitMsg adios amigos
-
-# path to a temporary directory which blootbot can use.
-set tempDir /tmp
-
-#####
-# Factoid database configuration
-#####
-
-# [str] Ability to remember/tell factoids
-# none -- disable.
-# mysql -- ...
-# SQLite -- SQLite (libdbd-sqlite-perl) (might be version 2 or 3)
-# SQLite2 -- SQLite (libdbd-sqlite-perl) (force version 2)
-# pgsql -- postgresql (SUPPORTED and TESTED!!!)
-### REQUIRED by factoids,freshmeat,karma,seen,...
-set DBType mysql
-
-# [str] SQLite filename prefix // MYSQL/PGSQL database.
-# eg: blootbot-factoids, blootbot-seen
-# eg: /var/db/mysql/blootbot/factoids.*
-set DBName blootbot
-
-# [str] Hostname of database server (unset for SQLite)
-set SQLHost localhost
-
-# [str] SQL user allowed to insert,update,delete stuff from tables. (unset for SQLite)
-set SQLUser blootbot
-
-# [str] SQL password. (unset for SQLite)
-set SQLPass PASSWORD
-
-# [str] SQL debug file. "-" for stdout may work on some platforms
-###set SQLDebug SQL_debug.log
-
-#####
-# Logfile configuration
-#####
-
-# [file] where to put logging info. comment out to disable.
-#set logfile log/$ircUser.log
-set logfile log/
-
-# [str] Type of logging.
-# DAILY -- Create a new log each day.
-# DEFAULT -- One continuous log file.
-set logType DAILY
-
-# [int] Maximum log size, if logfile is defined, in bytes.
-set maxLogSize 10000000
-
-#####
-# Factoid-related configuration
-#####
-
-# [bool] Factoid support.
-set factoids true
-
-# [days] if not 0, number of days until factoid is deleted for good.
-set factoidDeleteDelay 0
-
-# [int] maximum length of factoid key.
-set maxKeySize 32
-
-# [int] maximum length of factoid value.
-set maxDataSize 450
-
-# [str] when should the bot bother learning new factoids.
-# ADDRESSED -- only learn when addressed.
-# HUNGRY -- learn irrelevent of addressing. this will catch
-# _everything_, use at your own risk.
-set learn ADDRESSED
-
-# [str] different behaviour with URLs.
-# REQUIRE -- means it will need to be a url type (e.g. file:, http:)
-# OPTIONAL -- will take anything
-# REJECT -- will not accept any urls. this makes it easy to
-# run 2 with different nicks and styles.
-# ^^^ what's the point of this???
-set acceptUrl OPTIONAL
-
-# [bool] profanity checking.
-set profanityCheck false
-
-# [0/1] tell so-and-so about such-and-such of a factoid.
-set allowTelling 1
-
-# [str] other bots to ask for factoids which they may have.
-#set friendlyBots url purl script mrapi
-
-#####
-# Factoid related and unrelated features, mainly Extras.
-#####
-
-# [str] addressing is when you name the bot. FIXME:
-# REQUIRE -- the bot only does something if addressed.
-# OPTIONAL -- the bot responds (does not learn) irrelevent of
-# addressing.
-set addressing REQUIRE
-
-# [str] how the bot should send messages.
-# PRIVATE -- reply to private messages only, rejecting public msgs.
-# DEFAULT -- reply to public _and_ private queries.
-set talkMethod DEFAULT
-
-# [str] how long the output string should be before it is changed from
-# public to private.
-# "+" before bot commands overrides this option temporarily.
-###set minLengthBeforePrivate 192
-
-# [0/1] allow people outside any channels the bot is on to use the bot
-# for factoids and commands.
-set disallowOutsiders 1
-
-# [int] Amount of time for auto-ignore (flooding) to expire.
-set ignoreAutoExpire 5
-
-# [int] Amount of time for forced-online ignore to expire. minutes.
-set ignoreTempExpire 60
-
-#####
-# Internal (simple) bot commands
-#####
-
-# [0/1] Forking... disable for non-nix OS or to reduce mem usage.
-# Disabling should make the bot work on Win32 and MacOS.
-set forking 1
-
-# [int] Backlog... ideal to see what happened to the bot on console.
-# maximum number of lines to backlog.
-set backlog 24
-
-#####
-# Extra features
-#####
-
-# [str] anything which requires LWP + http proxy.
-###set httpProxy http://HOSTNAME:PORT/
-
-# [0/1] countdown to specific dates
-set countdown true
-
-# [0/1] Debian file and package search.
-# FIXME: should be a channel option
-set Debian true
-
-# [0/1] Freshmeat
-set freshmeat false
-# [int] how often to update the freshmeat table, in hours.
-set freshmeatRefreshInterval 24
-
-# [bool] if factoid does not exist, check freshmeat for it.
-set freshmeatForFactoid false
-
-# [0/1] Uptime logs
-set Uptime true
-
-#####
-# Miscellaneous configuration options
-#####
-
-# [int] Display a bit too much info about stuff.
-# 0 -- disable.
-# 1 -- standard.
-# 2 -- extra.
-set VERBOSITY 1
-
-# [0/1] Warn messages.
-set WARN 1
-
-# [0/1] Debugging messages.
-set DEBUG 0
-
-# [0/1] Work In Progress...
-set WIP 0
-
-# strict perl?
-set useStrict 1
-
-# debugging...
-###set DumpVars 1
-###set dumpvarsAtExit 1
-# log to specific file or global log file.
-###set dumpvarsLogFile dumpvars.log
-# more debugging
-###set DumpVars2 1
-###set symdumpLogFile log/dumpvars2.log
-
-# [str] Interface: [IRC/CLI]
-# IRC -- Internet Relay Chat
-# CLI -- Command Line Interface
-set Interface IRC
-
-# [0/1] Show topic author (troubled)
-# If 1, topics managed with !topic add foo will show the nick in ()'s
-# If 0, the nick of the creator will be recorded for !topic list, but not shown in the topic itself
-set topicAuthor 1
-
-####
-# Now modify blootbot.chan for per-channel specific configuration see
-# sample.chans for info.
-####
+++ /dev/null
-# countdown file.
-20001225 christmas Christmas
-20000914 olympics Opening ceremony of Olympics in Sydney, Australia
-20000704 america Independence Day
-20000501 potato Proposed release of Debian GNU/Linux Potato 2.2
-20000420 2.4 Hopeful debut of 2.4.0 kernel
-20000315 xfree4.0 XFree86 4.0 core release
-20000217 win2k Evil Empire's Release of deadly OS
-20000126 australia Australia Day
-20000119 crusoe Transmeta comes out of hiding
-20000115 freeze Debian (GNU/Linux) Potato version 2.2 stabilization begins
-20000101 y2k Year 2000
+++ /dev/null
-###
-# blootbot.servers: line separated list of servers to connect to
-###
-
-irc.freenode.net
-irc.home.org
-irc.linux.com
+++ /dev/null
-#v1: blootbot -- blootbot -- written Mon Feb 28 23:46:48 2005
-
-_default
---FLAGS amrt
---HOSTS *!*@*
-
-local
---FLAGS Aemnorst
---HOSTS local!local@local
---PASS xxfxfIfoJHdYg
-
-timriker
---FLAGS Aemnorst
---HOSTS *!~timr@TimRiker.active.supporter.pdpc
---PASS xxfxfIfoJHdYg
-
-xk
---FLAGS emnorst
---HOSTS *!xk@example.com
---HOSTS *!xk@superbox.home.org
---PASS 5K/rmJPzwxJhU
-
+++ /dev/null
-#
-# Unit defintions
-# 18 May 2001 M-J. Dominus <mjd-perl-units+@plover.com>.
-# This file is in the PUBLIC DOMAIN.
-# All rights abandoned.
-#
-# If you discover definitions of units that do not appear in this
-# file, you are invited to mail them to mjd-perl-units+@plover.com, so
-# that I can include them in a future version. Please include the
-# date of this file, 18 May 2001, with all such submissions.
-
-# If a unit is defined as `***', that means
-# it has no definition because it is a fundamental unit.
-
-# http://perl.plover.com/units/unittab
-
-# Fundamental units:
-# Seven instrinsic SI units:
-gram ***
-meter ***
-# Tim Riker <Tim@Rikers.org> adds metre alias
-metre meter
-second ***
-ampere ***
-candela ***
-Kelvin ***
-mole ***
-# Two supplementary units
-radian ***
-steradian ***
-# Some miscellany
-dollar ***
-bit ***
-sheet *** # Of paper
-turn *** # Of coiled wire
-
-# DIMENSIONLESS
-pi 3.1415926535897932386
-two 2
-half 1|2
-e 2.718281828459045 # Why did I put this in? Oh, I don't know.
-Neper 1 # Unit of logarithmic ratio
-Np Neper
-# Would it be better to make this a fundamental unit?
-bel .868588963 Np # 2/ln(10) actually
-B bel
-dB decibel
-
-# LENGTH
-m meter
-km kilometer
-cm centimeter
-mm millimeter
-micron micrometer
-inch 2.54 cm # This is the official definition and is exact
-mil milliinch
-in inch
-barleycorn 1/3 inch # Tim Riker <Tim@Rikers.org
-inches inch # plural
-foot 12 inch
-ft foot
-feet foot
-yard 3 feet
-yd yard
-mile 5280 feet
-mi mile
-#nautical 1.151 # For `nautical mile'
-nautical 1.150779447892
-statute 1
-# pilots need this :)
-nm 1 nautical mile
-sm 1 statute mile
-parsec 1.91615e13 mi
-#parsec 3.08568025e16 m # better?
-# light year will be implied by `year' and `light' below
-fathom 6 ft
-cable 120 fathoms
-league 3 mi
-bolt 25 yd # Of cloth; bolt length varies from bolt to bolt
- # 25 yd is typical
-cubit 18 in
-ell 45 in # More or less standard, although other ells
- # have also been used.
-hand 4 in
-palm 3 in
-span 9 in
-pace 2.5ft
-astronomicalunit 92.9 megamiles # Is this exact?
-au astronomicalunit
-rope 20 ft
-skein 360 feet
-
-# Surveyor's
-furlong 1|8 mi
-chain 1|10 furlong
-rod 1|4 chain
-link 1|100 chain
-
-# Typographic
-point .013837 in
-pt point
-bigpoint 1|72 in
-pica 12 pt
-didot 1238|1157 pt
-dd didot
-cicero 12dd # TeX likes to abbreviate this to cc, but cc is cubic centimeter
-scaledpoint 1|65536 pt # Internal to TeX
-sp scaledpoint
-
-
-
-# AREA
-are (10 m)2 # Implies `hectare'
-acre chain furlong # Now you know why an acre is the size it is
-rood 1|4 acre
-township 36 mi2 # Who uses these?
-barn (1.0E-12 centimeter)2 # Particle physics
-board 144 in3/ft # Implies `board feet'
-
-# VOLUME
-cc cm3
-liter (decimeter)3
-ml milliliter
-stere m3
-floz 29.573 ml # `floz' means `fluid ounce', which is different
- # from `ounce', which is a measurement of mass.
- # See `pound' below for more details.
-fldram 1|8 floz
-minim 1|60 fldram
-cup 8 floz
-cu cup
-gill 1|2 cup
-pint two cups
-quart two pints
-pottle two quarts # Yup!
-gallon two pottles
-qt quart
-gal gallon
-tablespoon 1|2 floz
-tbsp tablespoon
-teaspoon 1|3 tbsp
-tsp teaspoon
-cordfoot 16 ft2 # NOT the same as `cord foot'.
-cordfeet cordfoot
-cord 8 cordfeet
-# Barrels are complicated. `Barrel' here means `U.S. liquid barrel'.
-barrel 31.5 gal
-bbl barrel
-hogshead two barrels
-butt two hogsheads
-tun two butts
-firkin 9 gal # American firkin, not British firkin
-perch 24.75 ft3 # Masonry
-puncheon 84 gal
-# Following units contributed 20011217 Thomas R Wyant III
-fifth 1|5 gallon
-magnum 2.5 fifth
-jeroboam 4 fifth
-rehoboam 7.5 fifth
-methuselah 10 fifth
-shalmanazar 14 fifth
-balthazar 20 fifth
-nebuchadnezzar 25 fifth
-
-# Delightful British liquid volumes; they all begin with `brit'.
-britfloz 28.41225 ml
-britminim 1|480 britfloz
-britdrachm 1|8 britfloz
-drachm britdrachm # U.S. drachm is spelled `dram'.
-britgill 5 britfloz # five, NOT four.
-britnoggin britgill
-noggin britnoggin # Yeah, as though anyone else would have a `noggin.'
-britpint 4 britgill
-britpt britpint
-britquart 2 britpint
-britqt britquart
-britgallon 4 britquart
-britgal britgallon
-britpeck 2 britgal
-britfirkin 9 britgal
-britkilderkin two britfirkins
-kilderkin britkilderkin # kilderkin is British only
-britbucket 4 britgal # That's `britbucket,' not `bit bucket'.
-bucket britbucket # Buckets are brit only.
-britlast 2909.414 liters
-last britlast
-
-# Dry volume
-dry 1.164904862579 # For `dry pint,' `dry quart,' etc.
-peck 8 dry quarts
-bushel 4 pecks
-bu bushel
-seam 8bu
-bag 3bu
-
-imperial 1.201 # For `imperial pint,' etc.
-
-# MASS (also WEIGHT)
-#
-# To avoid confusing the end user, we will pretend that `pound' is
-# a unit of mass, interconvertible with `grams'. If you want
-# pounds of force, see `lbf,' below. In this section, `pound'
-# really means `mass of an object that weighs one-pound at the surface
-# of the Earth.' That is, in this program, `slug' has its usual
-# meaning, and `pound' is synonymous aith `slug'.
-g gram
-kg kilogram
-metricton kilokilogram
-tonne metricton
-mg milligram
-grain 64.79891 mg
-ounce 437.5 grains
-oz ounce
-pound 16 oz
-lb pound
-slug lb
-hundredweight 112 lb # This is the `long' hundredweight, analagous to
- # the long ton. There is also a `short' hundredwight,
- # but it's just a hectlb, so I put this one in instead.
-cwt hundredweight
-quarter 5 cwts
-longton 20 cwt
-#ton longton # use shortton my default Tim Riker <Tim@Rikers.org>
-short 100|112 # Convert long tons, cwts, and quarters to short.
-shortton short longton
-ton short longton # the american ton, see metriton and longton
-stone 14 lb
-cental 100 lb
-wey 252 lb
-# Obscure apothecaries' measures
-scruple 20 grains
-dram 3 scruples
-apothounce 480 grains
-apothoz apothounce
-apothpound 12 apothoz
-apothlb apothpound
-# Troy measures (for gold and precious stones)
-pennyweight 24 grains
-troyoz 480 grains # We can't define `troy' as a constant,
- # because there are 16 oz in a lb, but only
- # 12 troyoz in a troylb, so at least one of
- # `troy oz' or `troy lb' would be wrong.
-troylb 12 troyoz
-carat 3.08647 grain # Metric version. Is this useful?
-atomicmassunit 1.6605402e-27 kg # NIST 19990301 (+/- 0.10e-33 kg)
-amu atomicmassunit
-quintal 100kg # Metric quintal. Wasn't there another quintal?
-elvis 255lb # At the time of his death, the King weighed 255 lb.
-
-# TIME
-sec second
-s second
-minute 60 sec
-min minute
-hour 60 min
-hr hour
-day 24 hrs
-dy day # This will denote mean solar days
-siderealday 0.99726957 dys
-week 7 days
-wk week
-month 30 days
-lunarmonth 29.530588 days # Mean solar days
-meanmonth 730 hours
-mo month
-tropicalyear 365.24219 dys # Mean solar days
-siderealyear 365.25636 dys # Mean solar days
-leapyear 366 dys # Mean solar days
-calendaryear 365 dys # Mean solar days
-gregorianyear 365.2425 dys
-year tropicalyear # Correct on average for most calculations
-yr years
-fortnight two weeks
-decade 10 years
-century 100 years
-millennium 1000 years
-millennia millennium
-centuries century
-beat 1|1000 day # Swatch Internet Time (``Fuck the Sun'')
-# Velocity
-knot 1 nautical mi/hour
-mph 1 mi/hr
-
-# SCIENTIFIC
-#
-# Electromagnetic items, work, force, energy.
-#
-# Velocity
-c 299792458 m/s # NIST 19990301 EXACT
-light c # Implies `light year'
-
-
-# Absolute temperature
-kelvin Kelvin
-K Kelvin
-Rankine 5|9 K # This is a very funny unit
-Ra Rankine
-
-# Amount of substance
-mol mole
-Avogadro 6.0221367e23
-avogadro Avogadro
-molecule 1 mole per Avogadro # 1 mole is an Avogagro-number of molecules
-
-# Current
-# The Ampere is fundamental here, defined as the constant current
-# which, if maintained in two straight parallel conductors of infinite
-# length, of negligible circular cross-section, and placed 1m apart in
-# vacuum, would produce between these conductors a force equal to 2e-7
-# newtons per meter of length.
-Ampere ampere
-amp ampere
-abampere 10 amps
-abamp abampere
-statampere 3.335635e-11 abamperes
-statamp statampere
-
-# What is this called? Is it capitalized? Is there an abbreviation?
-gilbert 0.79577472 ampere turns
-
-# Electrostatic charge
-Coulomb ampere sec
-coulomb Coulomb
-coul Coulomb
-C Coulomb
-electron 1.60217733e-19 C # Charge on the electron; implies electron-volts
-e electron
-abcoulomb 10C
-statcoulomb 3.335635e-11 abcoulomb
-
-
-# Force
-Newton kg m/s2
-newton Newton
-N newton
-dyne g cm/s2
-grav 9.8 m/s2 # Acceleration due to gravity
-gee grav
-# Actually the accleration varies with altitude and latitude,
-# from 9.78039 m/s2 at the equator to 9.83217 m/s2 at the poles.
-# This mean value corresponds to a latitude of about 38 degrees.
-lbf lb grav
-
-# Pressure
-Pascal N/m2
-pascal Pascal
-Pa pascal
-atmosphere 101325 N/m2 # NIST 20010518 EXACT
-atm atmosphere
-bar megadyne/cm2 # Implies `millibars'
-mercury 1|760 atm/mm # Implies `mm mercury' and `inches mercury'
-hg mercury
-torricelli mm hg
-torr torricelli
-water .0295 atm/ft # Implies `feet water'
-barye dyne/cm2
-air 6.6083e-5 atm/foot # At 60 deg.F; Implies `feet air'
-
-# Work and energy
-Joule newton-meter
-joule Joule
-J joule
-footpound ft-lbf # foot-pound won't work, because `pound' is a mass
-calorie 4.186 J
-cal calorie
-kcal kilocalorie
-britishthermalunit 1054.8 J
-btu britishthermalunit
-erg dyne-cm
-# Kilowatt-hour (kWh) will be implied by `Watt'.
-
-
-# Power
-Watt J/sec
-watt Watt
-W Watt
-horsepower 550 ft-lbf/s
-
-# Electric potential
-Volt W/amp
-volt Volt
-V Volt
-abvolt 1|100 microvolt
-statvolt 2.997930e10 V
-
-# Frequency
-cycle 1 # For `cycles per second'
-Hertz cycles per second
-Hz Hertz
-hz Hz
-
-# Inductance
-Henry volt s/amp
-henry Henry
-H Henry
-abhenry 1.0e-9 henry
-Henries Henry # For plural
-henries Henry
-stathenry 8.987584e11 henries
-stathenries stathenry
-
-# Etc.
-Weber volt s
-weber Weber
-Wb weber
-Tesla Wb/m2
-tesla Tesla
-T tesla
-Oersted 1|4 pi kiloamp/m
-oersted Oersted
-Oe oersted
-Maxwell 1.0e-8 Wb
-maxwell Maxwell
-Mx Maxwell
-Gauss 1.0e-4 T
-gauss Gauss
-# We won't use G for Gauss because it is more important to
-# use it for the universal gravitational constant
-
-# Capacitance
-# `farad' is *not* an abbreviation for `Faraday' as far as I can tell.
-farad amp sec / volt
-F farad
-abfarad 1.0e9 farad
-statfarad 1.112646e-13 farad
-
-# Resistance
-Ohm volt/amp
-ohm Ohm
-abohm 1.0e-9 ohm
-statohm 8.987584e11 Ohms
-
-# Conductance
-mho 1/ohm
-abmho 1/abohm
-Siemens mho
-siemens Siemens
-
-# Misc
-Angstrom 1.0e-10 m
-angstrom Angstrom
-G 6.67259e-11 N m2/kg2 # Newton gravitational constant NIST19990301
-lightyear light year # Common abbreviation
-eV e V # Electron volts
-ev eV
-kev kiloeV
-Mev megaeV
-Gev gigaeV
-Tev teraeV
-energy c2 # You can ask for `1 gram energy' and get
- # the amount of energy equivalent to
- # 1 gram according to e=mc2.
- # Check: 1amu energy == 931.16 Mev?
-Franklin (10/c) C cm/sec
-Fr Franklin
-franklin Franklin
-Biot 10 amp
-Bi Biot
-biot Biot
-
-# Viscosity - Maybe someone who understands this better can check.
-poise g/(cm s) # Named after M. Poiseuille
-rhe 1/poise
-reyn (lbf s)/in2
-# Kinematic viscosity = viscosity per unit density
-stoke cm2/s
-
-# Refrigeration - Maybe someone who understands this better can check.
-refrigeration 288000 btu/ton
-ice tons refrigeration / 2009.1 lb
-
-# Light
-# The candela is fundamental here. Prior to 1979, it was defined as
-# the luminous intensity of a black body at the temperature of
-# solidification of platinum, whose radiating surface is 1/60 cm2. It
-# is now the luminous intensity, in a given direction, of a source
-# that emits monochromatic radiation of frequency 540e12 Hz and that
-# has a radiant intensity in that direction of 1|683 W/sr
-cd candela
-sr steradian
-lumen candela sr
-lm lumen
-lux lm/m2
-lx lux
-candlepower 12.566370 lumens
-candle candela # ``International standard candle''
-Hefner 0.90 candles # This was the German standard in early C20.
-hefner Hefner
-Lambert lm/cm2
-lambert Lambert
-footcandle lm/ft2 # NOT the same as foot-candle.
-phot 1.0e4 lx
-stilb candle/m2 # Same as a pi lambert
-
-# Various important physical constants
-# I got this stuff from physics.nist.gov on 19990301.
-h 6.6260755e-27 erg-sec # Planck's constant
-hbar h/(2 pi)
-plancklength 1.61605e-35 m
-planckmass 2.17671e-8 kg
-plancktime 5.39056e-44 sec
-# Let's reserve `Planck' for a while longer until I can decide if
-# they'd be useful in `planck time' etc.
-permeability 4*pi*1.0e-7 H/m # Magnetic permeability of vacuum constant
-permittivity 8.854187817e-12 F/m # Electric permittivity of vacuum constant
-protonmass 1.6726231e-27 kg
-neutronmass 1.6749286e-27 kg
-electronmass 9.1093897e-31 kg
-finestructure 7.29735308e-3 # Rl
-# Electron charge is up above under `electrostatic'.
-# There's no reason to get too obscure here because if someone wants
-# they can make up an `obscure physical constants' file that
-# physiscists could load in if they wanted to. So I've omitted stuff
-# like the magnetic moment of the muon.
-
-# ANGULAR
-rad radian
-circle 2 pi radians
-revolution circle # For revolutions / sec
-rev revolution
-rpm revolutions per minute
-quadrant 1|4 circle
-degree 1|360 circle
-arcminute 1|60 degree
-arcsecond 1|60 arcminute
-arcmin arcminute
-arcsec arcsecond
-sphere 4 pi steradians
-grade 1|100 quadrant
-grad grade
-
-# PAPER
-quire 50 sheets
-ream 10 quires
-
-# INFORMATION
-byte 8 bits
-nybble half byte
-kbyte 1024 bytes # `kilobyte' means 1000 bytes
-# Don't use `K'; that's for Kelvins.
-kb kbyte
-Kb kbyte
-KB kbyte
-mbyte 1024 kbytes # `megabyte' means 1000000 bytes
-meg mbyte
-kbit 1024 bits
-Kbit kbit
-mbit 1024 kbits
-Mbit mbit
-baud bit/sec # Not strictly correct
-
-# MONEY
-#
-# Conversions accurate only as of 25 November 1996.
-#
-$ dollar
-usdollar $
-usd $
-us$ $
-$us $
-US$ $
-$US $
-cent 1|100 $
-Australia.dollar 0.8123$
-AUS$ Australia.dollar
-Austria.schilling 0.09438$
-Belgium.franc 0.03223$
-Brazil.real 0.9709$
-British.pound 1.681$
-pound.sterling British.pound
-sterling British.pound
-Canada.dollar 0.7468$
-Can$ Canada.dollar
-Cayman.currency 1.22$
-Denmark.krone 0.173$
-krone Denmark.krone
-EuropeanCommunityUnit.ECU 1.278$
-ECU EuropeanCommunityUnit.ECU
-ecu ECU
-Finland.markka 0.2203$
-markka Finland.markka
-France.franc 0.1963$
-franc France.franc
-Germany.mark 0.6647$
-DM Germany.mark
-Deutschmark DM
-mark DM
-Greece.drachma 0.004216$
-drachma Greece.drachma
-HongKong.dollar 0.1294$
-HK$ HongKong.dollar
-India.rupee 0.02797$
-rupee India.rupee
-Ireland.punt 1.684$
-punt Ireland.punt
-Israel.shekel 0.3623$
-shekel Israel.shekel
-Italy.lira 0.0006655$
-Japan.yen 0.008976$
-yen Japan.yen
-Kenya.shilling 0.02376$
-Malaysia.dollar 0.397$
-Mexico.peso 0.1269$
-peso Mexico.peso
-Morocco.dirham 0.1248$
-dirham Morocco.dirham
-Netherlands.guilder 0.5924$
-guilder Netherlands.guilder
-NewZealand.dollar 0.7153$
-NZ$ NewZealand.dollar
-Norway.krone 0.1576$
-krone Norway.krone
-Portugal.escudo 0.006577$
-escudo Portugal.escudo
-Senegal.CFAfranc 0.002019$
-SouthAfrica.rand 0.2169$
-rand SouthAfrica.rand
-Spain.peseta 0.007896$
-peseta Spain.peseta
-Sweden.krona 0.1513$
-krona Sweden.krona
-Switzerland.franc 0.788$
-swissfranc Switzerland.franc
-Swissfranc Switzerland.franc
-Turkey.lira 1.3e-05$
-# Old-style Brit money. Did I omit anything interesting?
-sovereign sterling
-shilling 1|20 sterling
-penny 1|12 shilling
-pence penny
-farthing 1|4 penny
-hapenny half penny
-twopence two pence
-tuppence two pence
-thruppence 3 pence
-threepence 3 pence
-sixpence 6 pence
-crown 5 shillings # Implies `half crown'
-guinea 21 shillings
-florin 2 shillings
-
-
-# 18th century French coinage. References:
-# http://home.nordnet.fr/~jlmorel/mesures.html and reverse-engineered
-# from The Three Musketeers
-# 20011227 Thomas R Wyant III
-livre franc ### 3 Musketeers has francs!
- ### Now, you too can convert Louis d'Or to U.S. Dollars!
-sou 1|20 livre
-crown 3 livres # It's ecu in French, not to be confused with ECU.
-pistole 10 livres
-double 2 # 3 Musketeers refers to double pistoles, so ...
-louis 24 livres
-### Now if only I had good definitions for reals and doubloons ...
-
-
-# For `register tons'
-register 100 ft3/ton
-registerton register ton
-
-# What's missing?
-# bequerel (nucleotide radioactivity): Bq = k/s k=1??
-# gray (absorbed dose): Gy = k J/kg k=1??
-# sievert (dose equivalent): Sv = k J/kg k=1??
-# curie: Ci = 3.3e10 Bq
-# roentgen: R = 2.58e-4 C/kg
-# rad: rad = centigray
-# rem: rem = centisievert
+++ /dev/null
-##########################################################
-# Google.pm
-# by Jim Smyser
-# Copyright (C) 1996-1999 by Jim Smyser & USC/ISI
-# $Id: Google.pm,v 2.20 2000/07/09 14:29:22 jims Exp $
-##########################################################
-
-
-package WWW::Search::Google;
-
-
-=head1 NAME
-
-WWW::Search::Google - class for searching Google
-
-
-=head1 SYNOPSIS
-
-use WWW::Search;
-my $Search = new WWW::Search('Google'); # cAsE matters
-my $Query = WWW::Search::escape_query("Where is Jimbo");
-$Search->native_query($Query);
-while (my $Result = $Search->next_result()) {
-print $Result->url, "\n";
-}
-
-=head1 DESCRIPTION
-
-This class is a Google specialization of WWW::Search.
-It handles making and interpreting Google searches.
-F<http://www.google.com>.
-
-This class exports no public interface; all interaction should
-be done through L<WWW::Search> objects.
-
-=head1 LINUX SEARCH
-
-For LINUX lovers like me, you can put Googles in a LINUX only search
-mode by changing search URL from:
-
- 'search_url' => 'http://www.google.com/search',
-
-to:
-
- 'search_url' => 'http://www.google.com/linux',
-
-=head1 SEE ALSO
-
-To make new back-ends, see L<WWW::Search>.
-
-=head1 HOW DOES IT WORK?
-
-C<native_setup_search> is called (from C<WWW::Search::setup_search>)
-before we do anything. It initializes our private variables (which
-all begin with underscore) and sets up a URL to the first results
-page in C<{_next_url}>.
-
-C<native_retrieve_some> is called (from C<WWW::Search::retrieve_some>)
-whenever more hits are needed. It calls C<WWW::Search::http_request>
-to fetch the page specified by C<{_next_url}>.
-It then parses this page, appending any search hits it finds to
-C<{cache}>. If it finds a ``next'' button in the text,
-it sets C<{_next_url}> to point to the page for the next
-set of results, otherwise it sets it to undef to indicate we''re done.
-
-
-=head1 TESTING
-
-This module adheres to the C<WWW::Search> test suite mechanism.
-
-=head1 AUTHOR
-
-This backend is written and maintained/supported by Jim Smyser.
-<jsmyser@bigfoot.com>
-
-=head1 BUGS
-
-Google is not an easy search engine to parse in that it is capable
-of altering it's output ever so slightly on different search terms.
-There may be new slight results output the author has not yet seen that
-will pop at any given time for certain searches. So, if you think you see
-a bug keep the above in mind and send me the search words you used so I
-may code for any new variations.
-
-=head1 CHANGES
-
-2.21.1
-Parsing update from Tim Riker <Tim@Rikers.org>
-
-2.21
-Minor code correction for empty returned titles
-
-2.20
-Forgot to add new next url regex in 2.19!
-
-2.19
-Regex work on some search results url's that has changed. Number found
-return should be right now.
-
-2.17
-Insert url as a title when no title is found.
-
-2.13
-New regexp to parse newly found results format with certain search terms.
-
-2.10
-removed warning on absence of description; new test case
-
-2.09
-Google NOW returning url and title on one line.
-
-2.07
-Added a new parsing routine for yet another found result line.
-Added a substitute for whacky url links some queries can produce.
-Added Kingpin's new hash_to_cgi_string() 10/12/99
-
-2.06
-Fixed missing links / regexp crap.
-
-2.05
-Matching overhaul to get the code parsing right due to multiple
-tags being used by google on the hit lines. 9/25/99
-
-2.02
-Last Minute description changes 7/13/99
-
-2.01
-New test mechanism 7/13/99
-
-1.00
-First release 7/11/99
-
-=head1 LEGALESE
-
-THIS SOFTWARE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
-WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
-MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-
-
-=cut
-#'
-
-
-#####################################################################
-
-require Exporter;
-@EXPORT = qw();
-@EXPORT_OK = qw();
-@ISA = qw(WWW::Search Exporter);
-$VERSION = '2.21.1';
-
-$MAINTAINER = 'Jim Smyser <jsmyser@bigfoot.com>';
-$TEST_CASES = <<"ENDTESTCASES";
-# Google looks for partial words it can find results for so it will end up finding "Bogus" pages.
-&test('Google', '$MAINTAINER', 'zero', '4036e7757s5', \$TEST_EXACTLY);
-&test('Google', '$MAINTAINER', 'one_page', '+LS'.'AM +rep'.'lication', \$TEST_RANGE, 2,99);
-&test('Google', '$MAINTAINER', 'multi', 'dir'.'ty ha'.'rr'.'y bimbo', \$TEST_GREATER_THAN, 101);
-ENDTESTCASES
-
-use Carp ();
-use WWW::Search(qw(generic_option strip_tags));
-require WWW::SearchResult;
-
-
-sub undef_to_emptystring {
-return defined($_[0]) ? $_[0] : "";
-}
-# private
-sub native_setup_search
- {
- my($self, $native_query, $native_options_ref) = @_;
- $self->user_agent('user');
- $self->{_next_to_retrieve} = 0;
- $self->{'_num_hits'} = 100;
- if (!defined($self->{_options})) {
- $self->{_options} = {
- 'search_url' => 'http://www.google.com/search',
- 'num' => $self->{'_num_hits'},
- };
- };
- my($options_ref) = $self->{_options};
- if (defined($native_options_ref)) {
- # Copy in new options.
- foreach (keys %$native_options_ref) {
- $options_ref->{$_} = $native_options_ref->{$_};
- };
- };
- # Process the options.
- my($options) = '';
- foreach (keys %$options_ref) {
- # printf STDERR "option: $_ is " . $options_ref->{$_} . "\n";
- next if (generic_option($_));
- $options .= $_ . '=' . $options_ref->{$_} . '&';
- };
- $self->{_debug} = $options_ref->{'search_debug'};
- $self->{_debug} = 2 if ($options_ref->{'search_parse_debug'});
- $self->{_debug} = 0 if (!defined($self->{_debug}));
-
- # Finally figure out the url.
- $self->{_base_url} =
- $self->{_next_url} =
- $self->{_options}{'search_url'} .
- "?" . $options .
- "q=" . $native_query;
- }
-
-# private
-sub begin_new_hit {
- my($self) = shift;
- my($old_hit) = shift;
- my($old_raw) = shift;
- if (defined($old_hit)) {
- $old_hit->raw($old_raw) if (defined($old_raw));
- push(@{$self->{cache}}, $old_hit);
- };
- return (new WWW::SearchResult, '');
- }
-sub native_retrieve_some {
- my ($self) = @_;
- # fast exit if already done
- return undef if (!defined($self->{_next_url}));
- # get some
- print STDERR "Fetching " . $self->{_next_url} . "\n" if ($self->{_debug});
- my($response) = $self->http_request('GET', $self->{_next_url});
- $self->{response} = $response;
- if (!$response->is_success) {
- return undef;
- };
-
- # parse the output
- my($HEADER, $HITS, $TRAILER, $POST_NEXT) = (1..10);
- my($hits_found) = 0;
- my($state) = ($HEADER);
- my($hit) = undef;
- my($raw) = '';
- foreach ($self->split_lines($response->content())) {
- next if m@^$@; # short circuit for blank lines
-
- if ($state == $HEADER && m/about <b>([\d,]+)<\/b>/)
- {
- my($n) = $1;
- $self->approximate_result_count($n);
- print STDERR "Found Total: $n\n" ;
- $state = $HITS;
- }
- if ($state == $HITS &&
- m|<p><a href=([^\>]*)\>(.*?)</a\><br\>|i) {
- my ($url, $title) = ($1,$2);
- ($hit, $raw) = $self->begin_new_hit($hit, $raw);
- print STDERR "**Found HIT0 Line** $url - $title\n" if ($self->{_debug});
- $raw .= $_;
- $url =~ s/(>.*)//g;
- $hit->add_url(strip_tags($url));
- $hits_found++;
- $title = "No Title" if ($title =~ /^\s+/);
- $hit->title(strip_tags($title));
- $state = $HITS;
- }
- elsif ($state == $HITS &&
- m|<a href=(.*)\>(.*?)</a><font size=-1><br><font color=green><.*?>|i) {
- my ($url, $title) = ($1,$2);
- ($hit, $raw) = $self->begin_new_hit($hit, $raw);
- print STDERR "**Found HIT1 Line**\n" if ($self->{_debug});
- $raw .= $_;
- $url =~ s/(>.*)//g;
- $hit->add_url(strip_tags($url));
- $hits_found++;
- $title = "No Title" if ($title =~ /^\s+/);
- $hit->title(strip_tags($title));
- $state = $HITS;
- }
- elsif ($state == $HITS &&
- m@^<p><a href=/url\?sa=U&start=\d+&q=([^<]+)\&.*?>(.*)</a><font size=-1><br>(.*)@i ||
- m@^<p><a href=([^<]+)>(.*)</a>.*?<font size=-1><br>(.*)@i)
- {
- ($hit, $raw) = $self->begin_new_hit($hit, $raw);
- print STDERR "**Found HIT2 Line**\n" if ($self->{_debug});
- my ($url, $title) = ($1,$2);
- $mDesc = $3;
- $url =~ s/\/url\?sa=\w&start=\d+&q=//g;
- $url =~ s/&(.*)//g;
- $url =~ s/(>.*)//g;
- $raw .= $_;
- $hit->add_url(strip_tags($url));
- $hits_found++;
- $title = "No Title" if ($title =~ /^\s+/);
- $hit->title(strip_tags($title));
- $mDesc =~ s/<.*?>//g;
- $mDesc = $mDesc . '<br>' if not $mDesc =~ m@<br>@;
- $hit->description($mDesc) if (defined($hit));
- $state = $HITS;
- }
- elsif ($state == $HITS && m@^(\.\.(.+))@i)
- {
- print STDERR "**Parsing Description Line**\n" if ($self->{_debug});
- $raw .= $_;
- $sDesc = $1;
- $sDesc ||= '';
- $sDesc =~ s/<.*?>//g;
- $sDesc = $mDesc . $sDesc;
- $hit->description($sDesc) if $sDesc =~ m@^\.@;
- $sDesc = '';
- $state = $HITS;
- }
- elsif ($state == $HITS && m@<div class=nav>@i)
- {
- ($hit, $raw) = $self->begin_new_hit($hit, $raw);
- print STDERR "**Found Last Line**\n" if ($self->{_debug});
- # end of hits
- $state = $TRAILER;
- }
- elsif ($state == $TRAILER &&
- m|<a href=([^<]+)><IMG SRC=/nav_next.gif.*?>.*?|i)
- {
- my($relative_url) = $1;
- print STDERR "**Fetching >>Next<< Page**\n" if ($self->{_debug});
- $self->{_next_url} = 'http://www.google.com' . $relative_url;
- $state = $POST_NEXT;
- } else {
- };
- };
- if ($state != $POST_NEXT) {
- # No "Next" Tag
- $self->{_next_url} = undef;
- if ($state == $HITS) {
- $self->begin_new_hit($hit, $raw);
- };
- $self->{_next_url} = undef;
- };
- # ZZZzzzzZZZZzzzzzzZZZZZZzzz
- $self->user_agent_delay if (defined($self->{_next_url}));
- return $hits_found;
- }
-1;
-
+++ /dev/null
---- Connection.pm.orig Fri Nov 1 00:20:36 2002
-+++ Connection.pm Sat Nov 2 18:00:42 2002
-@@ -1300,14 +1300,13 @@
- # the line from the server.
- sub parse_ctcp {
- my ($self, $type, $from, $stuff, $line) = @_;
--
- my ($one, $two);
- my ($odd, @foo) = (&dequote($line));
-
- while (($one, $two) = (splice @foo, 0, 2)) {
-
- ($one, $two) = ($two, $one) if $odd;
--
-+
- my ($ctype) = $one =~ /^(\w+)\b/;
- my $prefix = undef;
- if ($type eq 'notice') {
-@@ -1326,10 +1325,10 @@
- # -- #perl was here! --
- # fimmtiu: Words cannot describe my joy. Sil, you kick ass.
- # fimmtiu: I was passing the wrong arg to Event::new()
--
-- $one =~ s/^$ctype //i; # strip the CTCP type off the args
-+
-+ # this is what it used to be in version 0.63 or so.
- $self->handler(Net::IRC::Event->new( $handler, $from, $stuff,
-- $handler, $one ));
-+ $handler, (split /\s/, $one)));
- }
-
- $self->handler(Net::IRC::Event->new($type, $from, $stuff, $type, $two))
+++ /dev/null
---- Google.pm.orig Wed May 24 16:55:47 2000
-+++ Google.pm Wed Jan 16 22:02:53 2002
-@@ -2,7 +2,7 @@
- # Google.pm
- # by Jim Smyser
- # Copyright (C) 1996-1999 by Jim Smyser & USC/ISI
--# $Id$
-+# $Id$
- ##########################################################
-
-
-@@ -30,8 +30,6 @@
- It handles making and interpreting Google searches.
- F<http://www.google.com>.
-
--Googles returns 100 Hits per page. Custom Linux Only search capable.
--
- This class exports no public interface; all interaction should
- be done through L<WWW::Search> objects.
-
-@@ -70,33 +68,41 @@
-
- This module adheres to the C<WWW::Search> test suite mechanism.
-
--=head1 BUGS
--
--2.07 now parses for most of what Google produces, but not all.
--Because Google does not produce universial formatting for all
--results it produces, there are undoublty a few line formats yet
--uncovered by the author. Different search terms creates various
--differing format out puts for each line of results. Example,
--searching for "visual basic" will create whacky url links,
--whereas searching for "Visual C++" does not. It is a parsing
--nitemare really! If you think you uncovered a BUG just remember
--the above comments!
--
--With the above said, this back-end will produce proper formated
--results for 96+% of what it is asked to produce. Your milage
--will vary.
--
- =head1 AUTHOR
-
--This backend is maintained and supported by Jim Smyser.
-+This backend is written and maintained/supported by Jim Smyser.
- <jsmyser@bigfoot.com>
-
- =head1 BUGS
-
--2.09 seems now to parse all hits with the new format change so there really shouldn't be
--any like there were with 2.08.
-+Google is not an easy search engine to parse in that it is capable
-+of altering it's output ever so slightly on different search terms.
-+There may be new slight results output the author has not yet seen that
-+will pop at any given time for certain searches. So, if you think you see
-+a bug keep the above in mind and send me the search words you used so I
-+may code for any new variations.
-+
-+=head1 CHANGES
-+
-+2.22
-+Fixed up changed format from google
-+reformatted code
-+
-+2.21
-+Minor code correction for empty returned titles
-+
-+2.20
-+Forgot to add new next url regex in 2.19!
-+
-+2.19
-+Regex work on some search results url's that has changed. Number found
-+return should be right now.
-+
-+2.17
-+Insert url as a title when no title is found.
-
--=head1 VERSION HISTORY
-+2.13
-+New regexp to parse newly found results format with certain search terms.
-
- 2.10
- removed warning on absence of description; new test case
-@@ -131,15 +137,18 @@
- WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
- MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-
-+
- =cut
- #'
--
-+
-+
- #####################################################################
-+
- require Exporter;
- @EXPORT = qw();
- @EXPORT_OK = qw();
- @ISA = qw(WWW::Search Exporter);
--$VERSION = '2.10';
-+$VERSION = '2.22';
-
- $MAINTAINER = 'Jim Smyser <jsmyser@bigfoot.com>';
- $TEST_CASES = <<"ENDTESTCASES";
-@@ -148,160 +157,187 @@
- &test('Google', '$MAINTAINER', 'one_page', '+LS'.'AM +rep'.'lication', \$TEST_RANGE, 2,99);
- &test('Google', '$MAINTAINER', 'multi', 'dir'.'ty ha'.'rr'.'y bimbo', \$TEST_GREATER_THAN, 101);
- ENDTESTCASES
--
-+
- use Carp ();
--use WWW::Search(generic_option);
-+use WWW::Search(qw(generic_option strip_tags));
- require WWW::SearchResult;
--
-+
-+
-+sub undef_to_emptystring {
-+return defined($_[0]) ? $_[0] : "";
-+}
-+# private
- sub native_setup_search {
-- my($self, $native_query, $native_options_ref) = @_;
-- $self->{_debug} = $native_options_ref->{'search_debug'};
-- $self->{_debug} = 2 if ($native_options_ref->{'search_parse_debug'});
-- $self->{_debug} = 0 if (!defined($self->{_debug}));
-- $self->{agent_e_mail} = 'jsmyser@bigfoot.com';
-- $self->user_agent('user');
-- $self->{_next_to_retrieve} = 1;
-- $self->{'_num_hits'} = 0;
-- if (!defined($self->{_options})) {
-- $self->{'search_base_url'} = 'http://www.google.com';
-- $self->{_options} = {
-- 'search_url' => 'http://www.google.com/search',
-- 'num' => '100',
-- 'q' => $native_query,
-- };
-- }
-- my $options_ref = $self->{_options};
-- if (defined($native_options_ref))
-- {
-- # Copy in new options.
-- foreach (keys %$native_options_ref)
-- {
-- $options_ref->{$_} = $native_options_ref->{$_};
-- } # foreach
-- } # if
-- # Process the options.
-- my($options) = '';
-- foreach (sort keys %$options_ref)
-- {
-- # printf STDERR "option: $_ is " . $options_ref->{$_} . "\n";
-- next if (generic_option($_));
-- $options .= $_ . '=' . $options_ref->{$_} . '&';
-- }
-- chop $options;
-- # Finally figure out the url.
-- $self->{_next_url} = $self->{_options}{'search_url'} .'?'. $self->hash_to_cgi_string($self->{_options});
-- } # native_setup_search
--
-+ my($self, $native_query, $native_options_ref) = @_;
-+ $self->user_agent('user');
-+ $self->{_next_to_retrieve} = 0;
-+ $self->{'_num_hits'} = 100;
-+
-+ if (!defined $self->{_options}) {
-+ $self->{_options} = {
-+ 'search_url' => 'http://www.google.com/search',
-+ 'num' => $self->{'_num_hits'},
-+ };
-+ }
-+
-+ my($options_ref) = $self->{_options};
-+
-+ if (defined $native_options_ref) {
-+ # Copy in new options.
-+ foreach (keys %$native_options_ref) {
-+ $options_ref->{$_} = $native_options_ref->{$_};
-+ }
-+ }
-+
-+ # Process the options.
-+ my($options) = '';
-+ foreach (keys %$options_ref) {
-+ # printf STDERR "option: $_ is " . $options_ref->{$_} . "\n";
-+ next if (generic_option($_));
-+ $options .= $_ . '=' . $options_ref->{$_} . '&';
-+ }
-+
-+ $self->{_debug} = $options_ref->{'search_debug'};
-+ $self->{_debug} = 2 if ($options_ref->{'search_parse_debug'});
-+ $self->{_debug} = 0 if (!defined $self->{_debug});
-+
-+ # Finally figure out the url.
-+ $self->{_base_url} =
-+ $self->{_next_url} =
-+ $self->{_options}{'search_url'} .
-+ "?" . $options .
-+ "q=" . $native_query;
-+}
-+
- # private
--sub native_retrieve_some
-- {
-- my ($self) = @_;
-- print STDERR "**Google::native_retrieve_some()**\n" if $self->{_debug};
-- # Fast exit if already done:
-- return undef if (!defined($self->{_next_url}));
--
-- # If this is not the first page of results, sleep so as to not
-- # overload the server:
-- $self->user_agent_delay if 1 < $self->{'_next_to_retrieve'};
--
-- # Get some if were not already scoring somewhere else:
-- print STDERR "*Sending request (",$self->{_next_url},")\n" if $self->{_debug};
-- my($response) = $self->http_request('GET', $self->{_next_url});
-- $self->{response} = $response;
-- if (!$response->is_success)
-- {
-- return undef;
-- }
-- $self->{'_next_url'} = undef;
-- print STDERR "**Response\n" if $self->{_debug};
--
-- # parse the output
-- my ($HEADER, $START, $HITS, $NEXT) = qw(HE HI ST NX);
-- my $hits_found = 0;
-- my $state = $HEADER;
-- my $hit = ();
-- foreach ($self->split_lines($response->content()))
-- {
-- next if m@^$@; # short circuit for blank lines
-- print STDERR " $state ===$_=== " if 2 <= $self->{'_debug'};
-- if (m|<b>(\d+)</b></font> matches|i) {
-- print STDERR "**Found Header Count**\n" if ($self->{_debug});
-- $self->approximate_result_count($1);
-- $state = $START;
-- # set-up attempting the tricky task of
-- # fetching the very first HIT line
-- }
-- elsif ($state eq $START && m|Search took|i)
-- {
-- print STDERR "**Found Start Line**\n" if ($self->{_debug});
-- $state = $HITS;
-- # Attempt to pull the very first hit line
-- }
-- if ($state eq $HITS) {
-- print "\n**state == HITS**\n" if 2 <= $self->{_debug};
-- }
-- if ($state eq $HITS && m@^<p><a href=([^<]+)>(.*)</a>$@i)
-- {
-- print "**Found HIT**\n" if 2 <= $self->{_debug};
-- my ($url, $title) = ($1,$2);
-- if (defined($hit))
-- {
-- push(@{$self->{cache}}, $hit);
-- };
-- $hit = new WWW::SearchResult;
-- # some queries *can* create internal junk in the url link
-- # remove them!
-- $url =~ s/\/url\?sa=U&start=\d+&q=//g;
-- $hits_found++;
-- $hit->add_url($url);
-- $hit->title($title);
-- $state = $HITS;
-- }
-- if ($state eq $HITS && m@^<font size=-1><br>(.*)@i)
-- {
-- print "**Found First Description**\n" if 2 <= $self->{_debug};
-- $mDesc = $1;
-- if (not $mDesc =~ m@ @)
-- {
-- $mDesc =~ s/<.*?>//g;
-- $mDesc = $mDesc . '<br>' if not $mDesc =~ m@<br>@;
-- $hit->description($mDesc);
-- $state = $HITS;
-- }
-- }
-- elsif ($state eq $HITS &&
-- m@^(\.(.+))@i ||
-- m@^<br><font color=green>(.*)\s@i) {
-- print "**Found Second Description**\n" if 2 <= $self->{_debug};
-- $sDesc = $1;
-- $sDesc ||= '';
-- $sDesc =~ s/<.*?>//g;
-- $sDesc = $mDesc . $sDesc;
-- $hit->description($sDesc);
-- $sDesc ='';
-- $state = $HITS;
-- }
-- elsif ($state eq $HITS &&
-- m|<a href=([^<]+)><IMG SRC=/nav_next.gif.*?><br><.*?>.*?</A>|i) {
-- my $nexturl = $self->{'_next_url'};
-- if (defined $nexturl) {
-- print STDERR "**Fetching Next URL-> ", $nexturl, "\n" if 2 <= $self->{_debug};
-- } else {
-- print STDERR "**Fetching Next URL-> UNDEF\n" if 2 <= $self->{_debug};
-- }
--
-- my $iURL = $1;
-- $self->{'_next_url'} = $self->{'search_base_url'} . $iURL;
-- }
-- else
-- {
-- print STDERR "**Nothing matched.**\n" if 2 <= $self->{_debug};
-- }
-- }
-- if (defined($hit))
-- {
-- push(@{$self->{cache}}, $hit);
-- }
-- return $hits_found;
-- } # native_retrieve_some
--1;
-+sub begin_new_hit {
-+ my($self) = shift;
-+ my($old_hit) = shift;
-+ my($old_raw) = shift;
-+
-+ if (defined $old_hit) {
-+ $old_hit->raw($old_raw) if (defined $old_raw);
-+ push(@{$self->{cache}}, $old_hit);
-+ }
-+
-+ return (new WWW::SearchResult, '');
-+}
-+
-+sub native_retrieve_some {
-+ my ($self) = @_;
-+ # fast exit if already done
-+ return undef if (!defined $self->{_next_url});
-+
-+ # get some
-+ print STDERR "Fetching " . $self->{_next_url} . "\n" if ($self->{_debug});
-+ my($response) = $self->http_request('GET', $self->{_next_url});
-+ $self->{response} = $response;
-+
-+ return undef if (!$response->is_success);
-+
-+ # parse the output
-+ my($HEADER, $HITS, $TRAILER, $POST_NEXT) = (1..10);
-+ my($hits_found) = 0;
-+ my($state) = ($HEADER);
-+ my($hit) = undef;
-+ my($raw) = '';
-+
-+ foreach ($self->split_lines($response->content())) {
-+ next if m@^$@; # short circuit for blank lines
-+
-+ if ($state == $HEADER && m/about <b>([\d,]+)<\/b>/) {
-+ my($n) = $1;
-+ $self->approximate_result_count($n);
-+ print STDERR "Found Total: $n\n" if ($self->{_debug});
-+ $state = $HITS;
-+
-+ } elsif ($state == $HITS &&
-+ m|<a href=(\S+)\>(.*?)</a><br><font size=-1><font color=\"#008000\"><.*?>|i
-+ ) {
-+
-+ my ($url, $title) = ($1,$2);
-+ ($hit, $raw) = $self->begin_new_hit($hit, $raw);
-+ print STDERR "**Found HIT1 Line**\n" if ($self->{_debug});
-+ $raw .= $_;
-+ $url =~ s/(>.*)//g;
-+ $hit->add_url(strip_tags($url));
-+ $hits_found++;
-+ $title = "No Title" if ($title =~ /^\s+/);
-+ $hit->title(strip_tags($title));
-+ $state = $HITS;
-+
-+ } elsif ($state == $HITS &&
-+ m@^<p><a href=/url\?sa=U&start=\d+&q=([^<]+)\&.*?>(.*)</a><font size=-1><br>(.*)@i ||
-+ m@^<p><a href=(\S+)>(.*)</a>.*?<font size=-1>(.*)@i
-+ ) {
-+ print STDERR "**Found HIT2 Line**\n" if ($self->{_debug});
-+
-+ ($hit, $raw) = $self->begin_new_hit($hit, $raw);
-+
-+ my ($url, $title) = ($1,$2);
-+ $mDesc = $3;
-+
-+ $url =~ s/\/url\?sa=\w&start=\d+&q=//g;
-+ $url =~ s/\?lang=(\S+)$//g;
-+ $url =~ s/&(.*)//g;
-+ $url =~ s/(>.*)//g;
-+ $url =~ s/\/$//g; # kill trailing slash.
-+
-+ $raw .= $_;
-+ $hit->add_url(strip_tags($url));
-+ $hits_found++;
-+
-+ $title = "No Title" if ($title =~ /^\s+/);
-+ $hit->title(strip_tags($title));
-+
-+ $mDesc =~ s/<.*?>//g;
-+### $mDesc = $mDesc . '<br>' if not $mDesc =~ m@<br>@;
-+ $hit->description($mDesc) if (defined $hit);
-+ $state = $HITS;
-+
-+# description parsing
-+ } elsif ($state == $HITS && m@<b>(\.\.(.+))</b> @i
-+ ) {
-+ print STDERR "**Parsing Description Line**\n" if ($self->{_debug});
-+ $raw .= $_;
-+ # uhm...
-+ $sDesc = $1 || "";
-+
-+ $sDesc =~ s/<.*?>//g;
-+ $mDesc ||= "";
-+ $sDesc = $mDesc . $sDesc;
-+# $hit->description($sDesc) if $sDesc =~ m@^\.@;
-+ $sDesc = '';
-+ $state = $HITS;
-+
-+ } elsif ($state == $HITS && m@<div>@i
-+ ) {
-+ ($hit, $raw) = $self->begin_new_hit($hit, $raw);
-+ print STDERR "**Found Last Line**\n" if ($self->{_debug});
-+ # end of hits
-+ $state = $TRAILER;
-+
-+ } elsif ($state == $TRAILER &&
-+ m|<a href=([^<]+)><img src=/nav_next.gif.*?>.*?|i
-+ ) {
-+ my($relative_url) = $1;
-+ print STDERR "**Fetching >>Next<< Page**\n" if ($self->{_debug});
-+ $self->{_next_url} = 'http://www.google.com' . $relative_url;
-+ $state = $POST_NEXT;
-+ }
-+ }
-+
-+ if ($state != $POST_NEXT) {
-+ # No "Next" Tag
-+ $self->{_next_url} = undef;
-+ $self->begin_new_hit($hit, $raw) if ($state == $HITS);
-+ $self->{_next_url} = undef;
-+ }
-+
-+ # ZZZzzzzZZZZzzzzzzZZZZZZzzz
-+ $self->user_agent_delay if (defined($self->{_next_url}));
-+ return $hits_found;
-+}
-+
-+1;
-+
+++ /dev/null
---- WWW/Search/Google.pm.orig Wed May 24 16:55:47 2000
-+++ WWW/Search/Google.pm Wed May 24 16:56:19 2000
-@@ -240,7 +240,7 @@
- if ($state eq $HITS) {
- print "\n**state == HITS**\n" if 2 <= $self->{_debug};
- }
-- if ($state eq $HITS && m@^<p><a href=([^<]+)>(.*)</a>$@i)
-+ if ($state eq $HITS && m@^<p><a href=([^<]+)>(.*)</a>@i)
- {
- print "**Found HIT**\n" if 2 <= $self->{_debug};
- my ($url, $title) = ($1,$2);
-@@ -252,6 +252,7 @@
- # some queries *can* create internal junk in the url link
- # remove them!
- $url =~ s/\/url\?sa=U&start=\d+&q=//g;
-+ $url =~ s/\&exp\=OneBoxNews\s//g; # new junk.
- $hits_found++;
- $hit->add_url($url);
- $hit->title($title);
-@@ -275,9 +276,8 @@
- print "**Found Second Description**\n" if 2 <= $self->{_debug};
- $sDesc = $1;
- $sDesc ||= '';
-- $sDesc =~ s/<.*?>//g;
-- $sDesc = $mDesc . $sDesc;
-- $hit->description($sDesc);
-+ $sDesc = $mDesc . $sDesc if (defined $mDesc);
-+ $hit->description($sDesc) if (defined $hit and $sDesc ne '');
- $sDesc ='';
- $state = $HITS;
- }
+++ /dev/null
-#!/bin/bash
-
-BACKUP_SRCDIR="/var/lib/mysql/"
-BACKUP_TDIR="blootbot/"
-BACKUP_FILE="/home/a/apt/public_html/tables.tar.bz2"
-
-pwd
-echo "Copying... $BACKUP_SRCDIR/$BACKUP_TDIR"
-cp -R $BACKUP_SRCDIR/$BACKUP_TDIR ~
-
-if [ -d $BACKUP_TDIR ]; then
- echo "Tarring... $BACKUP_FILE $BACKUP_TDIR"
- tar -Icvf $BACKUP_FILE $BACKUP_TDIR
- echo "Removing..."
- rm -rf $BACKUP_TDIR
-else
- echo "ERROR: $BACKUP_TDIR doesn't exist."
-fi
-
-exit 0;
+++ /dev/null
-#!/usr/bin/perl -w
-#
-# backup_table-slave.pl: Backup mysql tables
-# Author: dms
-# Version: v0.1b (20000223)
-# Created: 20000210
-#
-
-
-use strict;
-use LWP;
-use POSIX qw(strftime);
-
-my $backup_interval = 1; # every: 1,7,14,30.
-my $backup_count = 7;
-my $backup_url = "http://achilles.nyip.net/~apt/tables.tar.bz2";
-my $backup_file = "tables-##DATE.tar.bz2";
-my $backup_destdir = "/home/xk/public_html/";
-my $backup_indexfile = "tables-index.txt";
-
-my %index;
-
-# Usage: &getURL($url);
-sub getURL {
- my ($url) = @_;
- my ($ua,$res,$req);
-
- $ua = new LWP::UserAgent;
- $ua->proxy('http', $ENV{'http_proxy'}) if (exists $ENV{'http_proxy'});
- $ua->proxy('http', $ENV{'HTTP_PROXY'}) if (exists $ENV{'HTTP_PROXY'});
-
- $req = new HTTP::Request('GET',$url);
- $res = $ua->request($req);
-
- # return NULL upon error.
- if ($res->is_success) {
- return $res->content;
- } else {
- print "error: failure.\n";
- exit 1;
- }
-}
-
-#...
-if ( -f "$backup_destdir/$backup_indexfile") {
- if (open(INDEX, "$backup_destdir/$backup_indexfile")) {
- while (<INDEX>) {
- chop;
-
- # days since 1970, file.
- if (/^(\d+) (\S+)$/) {
- $index{$1} = $2;
- }
- }
- close INDEX;
- } else {
- print "WARNING: can't open $backup_indexfile.\n";
- }
-}
-my $now_days = (localtime)[7] + (((localtime)[5] - 70) * 365);
-my $now_date = strftime("%Y%m%d", localtime);
-
-if (scalar keys %index) {
- my $last_days = (sort {$b <=> $a} keys %index)[0];
-
- if ($now_days - $last_days < $backup_interval) {
- print "error: shouldn't run today.\n";
- goto recycle;
- }
-}
-
-$backup_file =~ s/##DATE/$now_date/;
-print "backup_file => '$backup_file'.\n";
-if ( -f $backup_file) {
- print "error: $backup_file already exists.\n";
- exit 1;
-}
-
-my $file = &getURL($backup_url);
-open(OUT,">$backup_destdir/$backup_file");
-print OUT $file;
-close OUT;
-
-$index{$now_days} = $backup_file;
-recycle:;
-my @index = sort {$b <=> $a} keys %index;
-
-open(OUT,">$backup_destdir/$backup_indexfile");
-for(my $i=0; $i<scalar(@index); $i++) {
- my $day = $index[$i];
- print "fe: day => '$day'.\n";
-
- if ($backup_count - 1 >= $i) {
- print "DEBUG: $day $index{$day}\n";
- print OUT "$day $index{$day}\n";
- } else {
- print "Deleting $backup_destdir/$index{$day}\n";
- unlink "$backup_destdir/$index{$day}";
- }
-}
-close OUT;
-
-print "Done.\n";
+++ /dev/null
-#!/bin/sh
-
-BOTDIR=/home/apt/bot
-BOTNICK=blootbot
-PIDFILE=$BOTDIR/$BOTNICK.pid
-
-if [ -f $PIDFILE ]; then # exists.
- PID=`cat $PIDFILE`
- if [ -d /proc/$PID ]; then # already running.
- exit 0
- fi
-
- # blootbot removes the pid file.
- echo "stale pid file; removing."
-# rm -f $PIDFILE
-fi
-
-cd $BOTDIR
-./blootbot
+++ /dev/null
-#!/usr/bin/perl
-# by the xk.
-###
-
-require "src/core.pl";
-require "src/logger.pl";
-require "src/modules.pl";
-
-require "src/Misc.pl";
-require "src/Files.pl";
-&loadDBModules();
-require "src/dbi.pl";
-package main;
-
-# todo: main()
-
-if (!scalar @ARGV) {
- print "Usage: dbm2mysql <whatever dbm>\n";
- print "Example: dbm2mysql.pl apt\n";
- print "NOTE: suffix '-is' and '-extra' are used.\n";
- exit 0;
-}
-
-my $dbfile = shift;
-my $key;
-my %db;
-
-# open dbm.
-if (!dbmopen(%db, $dbfile, 0666)) {
- &ERROR("Failed open to dbm file ($dbfile).");
- exit 1;
-}
-&status("::: opening dbm file: $dbfile");
-
-# open all the data...
-&loadConfig("files/blootbot.config");
-$dbname = $param{'DBName'};
-my $dbh_mysql = sqlOpenDB($param{'DBName'},
- $param{'DBType'}, $param{'SQLUser'}, $param{'SQLPass'});
-print "DEBUG: scalar db == '". scalar(keys %db) ."'.\n";
-
-my $factoid;
-my $ndef = 1;
-my $i = 1;
-foreach $factoid (keys %db) {
- &sqlReplace("factoids", {
- factoid_key => $_,
- factoid_value => $db{$_},
- } );
-
- $i++;
- print "i=$i... " if ($i % 100 == 0);
- print "ndef=$ndef... " if ($ndef % 1000 == 0);
-}
-
-print "Done.\n";
-&closeDB();
-dbmclose(%db);
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-use DB_File;
-if (!scalar @ARGV) {
- print "Usage: dbm2txt <whatever dbm>\n";
- print "Example: dbm2txt.pl factoids\n";
- exit 0;
-}
-
-my $dbfile = shift;
-my %db;
-if (0) {
- require "src/Factoids/db_dbm.pl";
- openDB();
-}
-
-dbmopen(%db, $dbfile, 0644) or die "error: cannot open db. $dbfile\n";
-my ($key, $val);
-while (($key, $val) = each %db) {
- chomp $val;
- print "$key => $val\n";
-}
-dbmclose %db;
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-
-my(%param, %conf, %both);
-
-foreach (`find -name "*.pl"`) {
- chop;
- my $file = $_;
- my $debug = 0;
-
- open(IN, $file);
- while (<IN>) {
- chop;
-
- if (/IsParam\(['"](\S+?)['"]\)/) {
- print "File: $file: IsParam: $1\n" if $debug;
- $param{$1}++;
- next;
- }
-
- if (/IsChanConfOrWarn\(['"](\S+?)['"]\)/) {
- print "File: $file: IsChanConfOrWarn: $1\n" if $debug;
- $both{$1}++;
- next;
- }
-
- if (/getChanConfDefault\(['"](\S+?)['"]/) {
- print "File: $file: gCCD: $1\n" if $debug;
- $both{$1}++;
- next;
- }
-
- if (/getChanConf\(['"](\S+?)['"]/) {
- print "File: $file: gCC: $1\n" if $debug;
- $conf{$1}++;
- next;
- }
-
- if (/IsChanConf\(['"](\S+?)['"]\)/) {
- print "File: $file: ICC: $1\n" if $debug;
- $conf{$1}++;
- next;
- }
-
- # command hooks => IsChanConfOrWarn => both.
- # note: this does not support multiple lines.
- if (/\'Identifier\'[\s\t]=>[\s\t]+\'(\S+?)\'/) {
- print "File: $file: command hook: $1\n" if $debug;
- $both{$1}++;
- next;
- }
- }
- close IN;
-}
-
-print "Conf AND/OR Params:\n";
-foreach (sort keys %both) {
- print " $_\n";
-}
-print "\n";
-
-print "Params:\n";
-foreach (sort keys %param) {
- print " $_\n";
-}
-print "\n";
-
-print "Conf:\n";
-foreach (sort keys %conf) {
- print " $_\n";
-}
+++ /dev/null
-#!/usr/bin/perl -w
-
-use DBI;
-
-my $dsn = "DBI:mysql:blootbot:localhost";
-my $dbh = DBI->connect($dsn, "USERNAME", "PASSWORD");
-
-my @factkey;
-my %factval;
-my $query;
-my $regex = '\\\\([\_\%])';
-
-$query = "SELECT factoid_key,factoid_value from factoids";
-my $sth = $dbh->prepare($query);
-$sth->execute;
-while (my @row = $sth->fetchrow_array) {
- if ($row[0] =~ /$regex/) {
- push(@factkey,$row[0]);
- } else {
- $factval{$row[0]} = $row[1] if ($row[1] =~ /$regex/);
- }
-}
-$sth->finish;
-
-print "scalar factkey => '". scalar(@factkey) ."'\n";
-foreach (@factkey) {
- print "factkey => '$_'.\n";
- my $new = $_;
- $new =~ s/$regex/$1/g;
-
- next if ($new eq $_);
-
- $query = "SELECT factoid_key FROM factoids where factoid_key=".
- $dbh->quote($new);
- my $sth = $dbh->prepare($query);
- $sth->execute;
- if (scalar $sth->fetchrow_array) { # exist.
- print "please remove $new or $_.\n";
- } else { # ! exist.
- $sth->finish;
-
- $query = "UPDATE factoids SET factoid_key=".$dbh->quote($new).
- " WHERE factoid_key=".$dbh->quote($_);
- my $sth = $dbh->prepare($query);
- $sth->execute;
- $sth->finish;
- }
-}
-
-print "scalar factval => '". scalar(keys %factval) ."\n";
-foreach (keys %factval) {
- print "factval => '$_'.\n";
- my $fact = $_;
- my $old = $factval{$_};
- my $new = $old;
- $new =~ s/$regex/$1/g;
-
- next if ($new eq $old);
-
- $query = "UPDATE factoids SET factoid_value=".$dbh->quote($new).
- " WHERE factoid_key=".$dbh->quote($fact);
- my $sth = $dbh->prepare($query);
- $sth->execute;
- $sth->finish;
-}
-
-$dbh->disconnect();
+++ /dev/null
-#!/usr/bin/perl -w
-
-$| = 1;
-
-use strict;
-
-require "src/core.pl";
-require "src/logger.pl";
-require "src/modules.pl";
-require "src/Factoids/DBCommon.pl";
-
-&loadConfig($bot_config_dir."/blootbot.config");
-&loadDBModules();
-
-unless (@_) {
- print "hrm.. usage\n";
- exit 0;
-}
-
-foreach (@_) {
- next unless ( -f $_);
-
- open(IN, $_) or die "error: cannot open $_\n";
- print "Opened $_ for input...\n";
-
- print "inserting... ";
- while (<IN>) {
- next unless (/^(.*?) => (.*)$/);
-
- ### TODO: check if it already exists. if so, don't add.
- &setFactInfo($1, "factoid_value", $2);
- print ":: $1 ";
- }
-
- close IN;
-}
+++ /dev/null
-#!/usr/bin/perl -w
-
-# irclog2html.pl Version 1.5 - 11th May 2000
-# Copyright (C) 2000, Jeffrey W. Waugh
-
-# Author:
-# Jeff Waugh <jdub@aphid.net>
-
-# Contributors:
-# Rick Welykochy <rick@praxis.com.au>
-# Alexander Else <aelse@uu.net>
-
-# Released under the terms of the GNU GPL
-# http://www.gnu.org/copyleft/gpl.html
-
-# Modified by Tim Riker <Tim@Rikers.org>
-# to work with infobot logs
-# then modified again for blootbot
-
-# Usage: irclog2html <date> < logfile
-
-# irclog2html will write out a colourised irc log, appending a .html
-# extension to the output file.
-
-
-####################################################################################
-# Perl Configuration
-
-use strict;
-$^W = 1; #RW# turn on warnings
-use POSIX qw(strftime);
-
-
-####################################################################################
-# Preferences
-
-# Comment out the "table" assignment to use the plain version
-
-#my $STYLE = "tt";
-#my $STYLE = "simplett";
-#my $STYLE = "table";
-my $STYLE = "simpletable";
-
-my $colour_left = "#000099"; # nick leaving channel
-my $colour_joined = "#009900"; # nick joining channel
-my $colour_server = "#009900"; # server message (***)
-my $colour_nickchange = "#009900"; # nick change
-my $colour_action = "#CC00CC"; # nick action (/me waves)
-
-my %prefs_colour_nick = (
- "jdub" => "#993333",
- "cantanker" => "#006600",
- "chuckd" => "#339999",
-);
-
-
-####################################################################################
-# Utility Functions
-
-sub header {
- my ($channel, $date) = @_;
- my $return = '';
-
- $return .= qq{<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
-<html>
-<head>
- <title>irclog2html for $channel on $date</title>
- <meta name="generator" content="irclog2html.pl by Jeff Waugh">
- <meta name="version" content="Version 1.5 - 11th May 2000">
- <meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
-</head>
-<body text="#000000" bgcolor="#ffffff">
-<h1>irclog2html for $channel on $date</h1>
-};
-
- if ($STYLE =~ /table/) {
- $return .= "<table cellspacing=3 cellpadding=2 border=0>\n";
- }
- return $return;
-}
-
-sub footer {
- my $return = '';
- if ($STYLE =~ /table/) {
- $return .= "</table>\n";
- }
-
- $return .= qq{
-<br>Generated by irclog2html.pl by
-<a href="mailto:jdub\@NOSPAMaphid.net">Jeff Waugh</a> - find it at
-<a href="http://freshmeat.net/appindex/2000/03/28/954251322.html">freshmeat.net</a>!
-Modified by <a href="http://www.Rikers.org">Tim Riker</a> to work with
-<a href="http://blootbot.sourceforge.net/">blootbot</a> logs, split per channel, etc.
-</body></html>
-};
- return $return;
-}
-
-my $lastdate = '';
-
-sub add_footers {
- my $filename;
-
- return if not $lastdate;
-
- my @files=`ls $lastdate.html */$lastdate.html`;
- foreach $filename (@files) {
- chomp $filename;
- if (!open(OUTPUT, ">>$filename")) {
- print "Cannot open $filename for writing!\n\n";
- return;
- }
- print OUTPUT footer();
- close OUTPUT;
- }
-}
-
-sub output_line {
- my ($date, $time, $channel, $lineout) = @_;
-
- add_footers() if $lastdate ne $date;
-
- $lastdate = $date;
- my $filename = "";
- $filename .= "$channel/" if $channel;
- $filename .= "$date.html";
-
- mkdir($channel,oct('755')) if ($channel && ! -d $channel);
- if (!open(OUTPUT, ">>$filename")) {
- #print "Cannot open $filename for writing!\n\n";
- return;
- }
- # Begin output #
- print OUTPUT header($channel, $date) if -z $filename;
-
- print OUTPUT $lineout;
-
- close OUTPUT;
-}
-
-sub output_timenicktext {
- my ($date, $time, $channel, $nick, $text, $htmlcolour) = @_;
- my $lineout = '';
-
- if ($STYLE eq "table") {
- $lineout .= "<tr>";
- $lineout .= "<td bgcolor=\"$htmlcolour\"><font color=\"#ffffff\"><tt>$time</tt></font></td>" if $time;
- $lineout .= "<td bgcolor=\"$htmlcolour\"><font color=\"#ffffff\"><tt>$nick</tt></font></td>";
- $lineout .= "<td width=\"100%\" bgcolor=\"#eeeeee\"><tt><font color=\"$htmlcolour\">$text<\/font></tt></td></tr>\n";
- }
- elsif ($STYLE eq "simpletable") {
- $lineout .= "<tr bgcolor=\"#eeeeee\">";
- $lineout .= "<td><tt>$time</tt></td>" if $time;
- $lineout .= "<td><font color=\"$htmlcolour\"><tt>$nick</tt></font></td>";
- $lineout .= "<td width=\"100%\"><tt>$text</tt></td></tr>\n";
- }
- elsif ($STYLE eq "simplett") {
- $lineout .= "$time " if $time;
- $lineout .= "<\;$nick>\; $text<br>\n";
- }
- else {
- $lineout .= "$time " if $time;
- $lineout .= "<font color=\"$htmlcolour\"><\;$nick>\; $text<\/font><br>\n";
- }
- output_line($date, $time, $channel, $lineout);
-}
-
-sub output_timeservermsg {
- my ($date, $time, $channel, $line) = @_;
- my $lineout = '';
-
- if ($STYLE =~ /table/) {
- $lineout .= "<tr>";
- $lineout .= "<td><tt>$time</tt></td>" if $time;
- $lineout .= "<td colspan=2><tt>$line</tt></td></tr>\n";
- }
- else {
- $lineout .= "$time " if $time;
- $lineout .= "$line<br>\n";
- }
- output_line($date, $time, $channel, $lineout);
-}
-
-sub html_rgb
-{
- my ($i,$ncolours) = @_;
- $ncolours = 1 if $ncolours == 0;
-
- my $rgbmax = 125; # tune these two for the outmost ranges of colour depth
- my $rgbmin = 240;
-
- my $a = 0.95; # tune these for the starting and ending concentrations of R,G,B
- my $c = 0.5;
-
- my $rgb = [ [$a,$c,$c], [$c,$a,$c], [$c,$c,$a], [$a,$a,$c], [$a,$c,$a], [$c,$a,$a] ];
- my $n = $i % @$rgb;
- my $m = $rgbmin + ($rgbmax - $rgbmin) * ($ncolours - $i) / $ncolours;
-
- my $r = $rgb->[$n][0] * $m;
- my $g = $rgb->[$n][1] * $m;
- my $b = $rgb->[$n][2] * $m;
- sprintf("#%02x%02x%02x",$r,$g,$b);
-}
-
-####################################################################################
-# Main
-
-sub main {
- my ($date) = @_;
- my $files;
-
- my $line;
- my $time;
- my $lastdate = "";
- my $nick;
- my $channel;
- my $text;
-
- my $htmlcolour;
- my $nickcount = 0;
- my $NICKMAX = 30;
-
- my %colour_nick = %prefs_colour_nick;
-
- while ($line = <STDIN>) {
-
- chomp $line;
-
- if (!$line eq "") {
- # parse out the time
- if ($line =~ s/^([0-9:\.]*) (.*)$/$2/) {
- $time = $1;
- } else {
- $time = '';
- }
- $channel = '';
-
- # Replace ampersands, pointies, control characters #
- $line =~ s/&/&\;/g;
- $line =~ s/</<\;/g;
- $line =~ s/>/>\;/g;
- $line =~ s/\e\[[0-1]*m//g;
- $line =~ s/[\x00-\x1f]+//g;
-
- # Replace possible URLs with links #
- $line =~ s/((http|https|ftp|gopher|news):\/\/\S*)/<a href="$1">$1<\/a>/g;
-
- # Colourise the comments
- if ($line =~ /^<\;[^\/]*?\/\#.*?>\; .*$/) {
- # Split $nick, $channel and $line
- $nick = $line;
- $nick =~ s/^<\;([^\/]*?)\/\#.*?>\; .*$/$1/;
- $channel = $line;
- $channel =~ s/^<\;[^\/]*?\/(\#.*?)>\; .*$/$1/;
-
- # $nick =~ tr/[A-Z]/[a-z]/;
- # <======= move this into another function when getting nick colour
-
- $text = $line;
- $text =~ s/^<\;.*?>\; (.*)$/$1/;
- $text =~ s/^ .*/<\;PROTECTED>\;/g;
- $text =~ s/ / \; \;/g;
-
- $htmlcolour = $colour_nick{$nick};
- if (!defined($htmlcolour)) {
- # new nick
- $nickcount++;
-
- # if we've exceeded our estimate of the number of nicks, double it
- $NICKMAX *= 2 if $nickcount >= $NICKMAX;
-
- $htmlcolour = $colour_nick{$nick} = html_rgb($nickcount, $NICKMAX);
- }
- output_timenicktext($date, $time, $channel, $nick, $text, $htmlcolour);
- } elsif ($line =~ /^>\;>\;>\; /) {
- $line =~ s/^>\;>\;>\; /\*\*\* /;
-
- # Process changed nick results, and remember colours accordingly #
- if ($line =~ /\*\*\* (.*?) materializes into (.*)/) {
- my $nick_old = $1;
- my $nick_new = $2;
-
- #$nick_old = $line;
- #$nick_old =~ s/\*\*\* (.*?) materializes into .*/$1/;
- #$nick_new = $line;
- #$nick_new =~ s/\*\*\* (.*?) materializes into (.*)/$2/;
-
- $colour_nick{$nick_new} = $colour_nick{$nick_old};
- $colour_nick{$nick_old} = undef;
-
- $line =~ s/(\*\*\* .*)/<font color=\"$colour_nickchange\">$1<\/font>/
- } elsif ($line =~ /\*\*\* (join|mode|topic)\/(.*?) .*/) {
- $channel = lc $2;
- $line =~ s/(\*\*\* .*)/<font color=\"$colour_joined\">$1<\/font>/;
- } elsif ($line =~ /\*\*\* (part|kick|banned)\/(.*?) .*/) {
- $channel = lc $2;
- $line =~ s/(\*\*\* .*)/<font color=\"$colour_left\">$1<\/font>/;
- } elsif ($line =~ /\*\*\* .* has signed off IRC .*/) {
- # Colourise joined/left/server messages #
- $line =~ s/(\*\*\* .*)/<font color=\"$colour_left\">$1<\/font>/;
- } elsif ($line =~ /\*\*\* /) {
- $line =~ s/(\*\*\* .*)$/<font color=\"$colour_server\">$1<\/font>/;
- } elsif ($line =~ /^\* .*$/) {
- # Colourise the /me's #
- $line =~ s/^(\*.*)$/<font color=\"$colour_action\">$1<\/font>/;
- }
-
- output_timeservermsg($date, $time, $channel, $line);
- }
- }
- }
-
- add_footers();
-
- return 0;
-}
-
-if (!scalar @ARGV) {
- print "Usage: irclog2html.pl <date> < logfile\n";
- print "Example: bzcat log/blootbot.log-20021104.bz2 | irclog2html.pl 20021104\n";
- exit 0;
-}
-my $date = shift;
-exit &main($date);
-# vim: ts=2
+++ /dev/null
-#!/usr/bin/perl
-
-$| = 1;
-
-print "plaintext> ";
-while (<>) {
- chomp;
- $result = &mkpasswd($_);
- print "\t$result\n";
- print "plaintext> ";
-}
-
-sub mkpasswd {
- my $what = $_[0];
- my $salt = chr(65+rand(27)).chr(65+rand(27));
- $salt =~ s/\W/x/g;
-
- return crypt($what, $salt);
-}
-
+++ /dev/null
-#!/usr/bin/perl
-# mysql -> txt.
-# written by the xk.
-###
-
-require "src/core.pl";
-require "src/logger.pl";
-require "src/modules.pl";
-require "src/Misc.pl";
-require "src/Files.pl";
-$bot_src_dir = "./src/";
-
-my $dbname = shift;
-if (!defined $dbname) {
- print "Usage: $0 <db name>\n";
- print "Example: $0 factoids\n";
- exit 0;
-}
-
-# open the db.
-&loadConfig("files/blootbot.config");
-&loadDBModules();
-
-&openDB($param{'DBName'}, $param{'SQLUser'}, $param{'SQLPass'});
-
-# retrieve a list of db's from the server.
-my %db;
-foreach ($dbh->func('_ListTables')) {
- $db{$_} = 1;
-}
-
-# factoid db.
-if (!exists $db{$dbname}) {
- print "error: $dbname does not exist as a table.\n";
- exit 1;
-}
-
-my $query = "SELECT factoid_key,factoid_value from $param{'DBName'}.$dbname";
-my $sth = $dbh->prepare($query);
-$sth->execute;
-while (my @row = $sth->fetchrow_array) {
- print "$row[0] => $row[1]\n";
-}
-$sth->finish;
-
-print "Done.\n";
-&closeDB();
+++ /dev/null
-package DUMPVAR;
-sub dumpvar {
- ($packageName) = @_;
- $rPackage = \%{"${packageName}::"}; # Get a reference to the appropriate symbol table hash.
- $, = " " ;
- while (($varName, $globValue) = each %$rPackage) {
- print "$varName ============================= \n";
- *var = $globValue;
- if (defined ($var)) {
- print "\t \$$varName $var \n";
- }
- if (defined (@var)) {
- print "\t \@$varName @var \n";
- }
- if (defined (%var)) {
- print "\t \%$varName ",%var," \n";
- }
- }
-}
-
-
-package Test;
-$x = 10;
-@y = (1,3,4);
-%z = (1,2,3,4, 5, 6, \@y);
-$z = 300;
-DUMPVAR::dumpvar("Test");
+++ /dev/null
-@sample = (11.233,{3 => 4, "hello" => [6,7]});
-pretty_print(@sample);
-
-$level = -1; # Level of indentation
-
-sub pretty_print {
- my $var;
- foreach $var (@_) {
- if (ref ($var)) {
- print_ref($var);
- } else {
- print_scalar($var);
- }
- }
-}
-
-sub print_scalar {
- ++$level;
- print_indented ($_[0]);
- --$level;
-}
-
-sub print_ref {
- my $r = $_[0];
- if (exists ($already_seen{$r})) {
- print_indented ("$r (Seen earlier)");
- return;
- } else {
- $already_seen{$r}=1;
- }
- my $ref_type = ref($r);
- if ($ref_type eq "ARRAY") {
- print_array($r);
- } elsif ($ref_type eq "SCALAR") {
- print "Ref -> $r";
- print_scalar($$r);
- } elsif ($ref_type eq "HASH") {
- print_hash($r);
- } elsif ($ref_type eq "REF") {
- ++$level;
- print_indented("Ref -> ($r)");
- print_ref($$r);
- --$level;
- } else {
- print_indented ("$ref_type (not supported)");
- }
-}
-
-sub print_array {
- my ($r_array) = @_;
- ++$level;
- print_indented ("[ # $r_array");
- foreach $var (@$r_array) {
- if (ref ($var)) {
- print_ref($var);
- } else {
- print_scalar($var);
- }
- }
- print_indented ("]");
- --$level;
-}
-
-sub print_hash {
- my($r_hash) = @_;
- my($key, $val);
- ++$level;
- print_indented ("{ # $r_hash");
- while (($key, $val) = each %$r_hash) {
- $val = ($val ? $val : '""');
- ++$level;
- if (ref ($val)) {
- print_indented ("$key => ");
- print_ref($val);
- } else {
- print_indented ("$key => $val");
- }
- --$level;
- }
- print_indented ("}");
- --$level;
-}
-
-sub print_indented {
- $spaces = ": " x $level;
- print "${spaces}$_[0]\n";
-}
+++ /dev/null
-#!/bin/sh
-echo -n "DEBUG: "; grep DEBUG `find blootbot src -type f`| wc -l
-echo -n "WARN: "; grep WARN `find blootbot src -type f` | wc -l
-echo -n "FIXME: "; grep FIXME `find blootbot src -type f` | wc -l
-echo -n "status: "; grep status `find blootbot src -type f` | wc -l
-echo -n "ERROR: "; grep ERROR `find blootbot src -type f` | wc -l
-echo -n "TODO: "; grep TODO `find blootbot src -type f` | wc -l
+++ /dev/null
-#!/usr/bin/perl -w
-
-# leading and trailing context lines.
-my $contextspread = 2;
-
-use strict;
-
-$| = 1;
-
-if (!scalar @ARGV) {
- print "Usage: parse_warn.pl <files>\n";
- print "Example: parse_warn.pl log/*\n";
- exit 0;
-}
-
-my %done;
-my $file;
-
-foreach $file (@ARGV) {
- if (! -f $file) {
- print "warning: $file does not exist.\n";
- next;
- }
- my $str = ' at .* line ';
-
- print "Opening $file... ";
- if ($file =~ /bz2$/) { # bz2
- open(FILE, "bzcat $file | egrep '$str' |");
- } elsif ($file =~ /gz$/) { # gz
- open(FILE, "zegrep '$str' $file |");
- } else { # raw
- open(FILE, "egrep '$str' $file |");
- }
-
- print "Parsing... ";
- while (<FILE>) {
- if (/ at (\S+) line (\d+)/) {
- my ($file,$lineno) = ($1,$2+1);
- $done{$file}{$lineno}++;
- }
- }
- close FILE;
-
- print "Done.\n";
-}
-
-foreach $file (keys %done) {
- my $count = scalar(keys %{$done{$file}});
- print "warn $file: $count unique warnings.\n";
-
- if (! -f $file) {
- print "=> error: does not exist.\n\n";
- next;
- }
-
- if (open(IN,$file)) {
- my @lines = <IN>;
- close IN;
-
- my $total = scalar @lines;
- my $spread = 0;
- my $done = 0;
- for(my $i=0; $i<=$total; $i++) {
- next unless (exists $done{$file}{$i+$contextspread} or $spread);
-
- if (exists $done{$file}{$i+$contextspread}) {
- print "@@ $i @@\n" unless ($spread);
- # max lines between offending lines should be 2*context-1.
- # coincidence that it is!
- $spread = 2*$contextspread;
- } else {
- $spread--;
- }
-
- if (exists $done{$file}{$i}) {
- print "*** ";
- } else {
- print "--- ";
- }
-
- if ($i >= $total) {
- print "EOF\n";
- } else {
- print $lines[$i];
- }
- }
- print "\n";
- } else {
- print "=> error: could not open file.\n";
- }
-}
+++ /dev/null
-@test = ("test");
-
-sub dumpvar {
- ($packageName) = @_;
- $rPackage = \%{"${packageName}::"}; # Get a reference to the appropriate symbol table hash.
- $, = " " ;
- while (($varName, $globValue) = each %$rPackage) {
- last if ($varName eq "main::");
- print "$varName ============================= \n";
- *var = $globValue;
- if (defined ($var)) {
- print "\t \$$varName = '$var' \n";
- }
- if (defined (@var)) {
- pretty_print(@var);
-### print "\t \@$varName @var \n";
- }
- if (defined (%var)) {
- pretty_print(%var);
-### print "\t \%$varName ",%var," \n";
- }
- }
-}
-
-dumpvar("main");
-
-$level = -1; # Level of indentation
-
-sub pretty_print {
- my $var;
- foreach $var (@_) {
- if (ref ($var)) {
- print_ref($var);
- } else {
- print_scalar($var);
- }
- }
-}
-
-sub print_scalar {
- ++$level;
- print_indented ($_[0]);
- --$level;
-}
-
-sub print_ref {
- my $r = $_[0];
- if (exists ($already_seen{$r})) {
- print_indented ("$r (Seen earlier)");
- return;
- } else {
- $already_seen{$r}=1;
- }
- my $ref_type = ref($r);
- if ($ref_type eq "ARRAY") {
- print_array($r);
- } elsif ($ref_type eq "SCALAR") {
- print "Ref -> $r";
- print_scalar($$r);
- } elsif ($ref_type eq "HASH") {
- print_hash($r);
- } elsif ($ref_type eq "REF") {
- ++$level;
- print_indented("Ref -> ($r)");
- print_ref($$r);
- --$level;
- } else {
- print_indented ("$ref_type (not supported)");
- }
-}
-
-sub print_array {
- my ($r_array) = @_;
- ++$level;
- print_indented ("[ # $r_array");
- foreach $var (@$r_array) {
- if (ref ($var)) {
- print_ref($var);
- } else {
- print_scalar($var);
- }
- }
- print_indented ("]");
- --$level;
-}
-
-sub print_hash {
- my($r_hash) = @_;
- my($key, $val);
- ++$level;
- print_indented ("{ # $r_hash");
- while (($key, $val) = each %$r_hash) {
- $val = ($val ? $val : '""');
- ++$level;
- if (ref ($val)) {
- print_indented ("$key => ");
- print_ref($val);
- } else {
- print_indented ("$key => $val");
- }
- --$level;
- }
- print_indented ("}");
- --$level;
-}
-
-sub print_indented {
- $spaces = ": " x $level;
- print "${spaces}$_[0]\n";
-}
+++ /dev/null
-#!/usr/bin/perl -w
-
-# hrm...
-#use strict;
-
-my @test;
-my @test1;
-my %test;
-
-$test{'hash0r'} = 2;
-$test{'hegdfgsd'} = 'GSDFSDfsd';
-
-push(@test1,"Aeh.");
-push(@test1,"Beh.");
-push(@test1,"Ceh.");
-push(@test1,"Deh.");
-
-push(@test,"heh.");
-push(@test,\%test);
-#push(@test,\%ENV);
-push(@test,\@test1);
-
-print "=============start=================\n";
-#&DumpArray(0, '@test', \@test);
-&DumpPackage(0, 'main::', \%main::);
-
-# SCALAR ARRAY HASH CODE REF GLOB LVALUE
-sub DumpArray {
- my ($pad, $symname, $arrayref) = @_;
- my $padding = " " x $pad;
- my $scalar = 0;
- my $size = 0;
-
- print "$padding$symname\n";
- foreach (@{$arrayref}) {
- my $ref = ref $_;
- if ($ref eq 'ARRAY') {
- $size += &DumpArray($pad+1, "@" . $_, $_);
- } elsif ($ref eq 'HASH') {
- $size += &DumpHash($pad+1, "%" . $_, $_);
- } else {
- print "$padding $_ $ref\n";
- $scalar++;
- $size += length($_);
- }
- }
- print $padding."scalars $scalar, size $size\n";
- return $size;
-}
-
-sub DumpHash{
- my ($pad, $symname, $hashref) = @_;
- my $padding = " " x $pad;
- my $scalar = 0;
- my $size = 0;
-
- my %sym = %{$hashref};
- my @list = sort keys %sym;
- print "$padding$symname\n";
-
- foreach (@list) {
- my $ref = ref %{$symname}; #FIXME
- $size += length($_);
- if ($ref eq 'ARRAY') {
- $size += &DumpArray($pad+1, "@" . $_, $_);
- } elsif ($ref eq 'HASH') {
- $size += &DumpHash($pad+1, "%" . $_, $_);
- } else {
- print "$padding $_=$sym{$_} $ref\n";
- $scalar++;
- $size += length($sym{$_});
- }
- }
- print $padding."scalars $scalar, size $size\n";
- return $size;
-}
-
-sub DumpPackage {
- my ($pad, $packname, $package) = @_;
- my $padding = " " x $pad;
- my $scalar = 0;
- my $size = 0;
-
- print $padding . "\%$packname\n";
- my $symname;
- foreach $symname (sort keys %$package) {
- local *sym = $$package{$symname};
- if (defined $sym) {
- print "$padding \$$symname='$sym'\n";
- $scalar++;
- $size += length($sym);
- } elsif (defined @sym) {
- $size += &DumpArray($pad+1, $symname, \@sym);
- } elsif (defined %sym) {
- $size += &DumpHash($pad+1, $symname, \%sym);
- } elsif (($symname =~ /::/) and ($symname ne 'main::')) {
- $size += &DumpPackage($pad+1, \%sym, $symname);
- } else {
- print("ERROR $symname" . ref $symname . "\n");
- }
- }
- print $padding."scalars $scalar, size $size\n";
- return $size;
-}
+++ /dev/null
-#!/usr/bin/perl
-# by the xk.
-#
-
-require "src/core.pl";
-require "src/logger.pl";
-require "src/modules.pl";
-require "src/Files.pl";
-require "src/Misc.pl";
-require "src/Factoids/DBCommon.pl";
-
-if (!scalar @ARGV) {
- print "Usage: txt2mysql.pl <input.txt>\n";
- exit 0;
-}
-
-# open the txtfile.
-my $txtfile = shift;
-open(IN,$txtfile) or die "error: cannot open txtfile '$txtfile'.\n";
-
-# read the bot config file.
-&loadConfig("files/blootbot.config");
-&loadDBModules();
-&openDB($param{'DBName'}, $param{'SQLUser'}, $param{'SQLPass'});
-
-### now pipe all the data to the mysql server...
-my $i = 1;
-print "converting factoid db to mysql...\n";
-while (<IN>) {
- chop;
- next if !length;
- if (/^(.*)\s+=>\s+(.*)$/) {
- # verify if it already exists?
- my ($key,$val) = ($1,$2);
- if ($key =~ /^\s*$/ or $val =~ /^\s*$/) {
- print "warning: broken => '$_'.\n";
- next;
- }
-
- if (&IsParam("freshmeat") and &dbGet("freshmeat", "name", $key, "name")) {
- if (&getFactoid($key)) {
- &delFactoid($key);
- }
- } else {
- &setFactInfo(lc $key, "factoid_value", $val);
- $i++;
- }
-
- print "$i... " if ($i % 100 == 0);
- } else {
- print "warning: invalid => '$_'.\n";
- }
-}
-close IN;
-
-print "Done.\n";
-&closeDB();
+++ /dev/null
-#!/usr/bin/perl -w
-# hrm...
-
-# use strict;
-
-local @test;
-local %test;
-
-$test{'hash0r'} = 2;
-$test{'hegdfgsd'} = 'GSDFSDfsd';
-
-push(@test,"heh.");
-push(@test,\%test);
-
-&vartree(\%main::, 'main::');
-
-
-sub tree {
- my ($pad, $ref, $symname) = @_;
- my $padded = " " x $pad;
- my @list;
- my $scalar = 0;
- my $size = 0;
-
- @list = keys %{$symname} if ($ref eq 'HASH');
- @list = @{$symname} if ($ref eq 'ARRAY');
-
- foreach (@list) {
- my $ref = ref $_;
-
- if ($ref eq 'HASH' or $ref eq 'ARRAY') {
- print $padded."recursing $ref($_).\n";
- &tree($pad+2, $ref, $_);
- } elsif ($ref eq '') {
- $scalar++;
- $size += length($_);
- }
- }
- print $padded."scalars $scalar, size $size\n";
-}
-
-sub vartree {
- my ($package, $packname) = @_;
- my $symname;
-
- # scalar.
- foreach $symname (sort keys %$package) {
- local *sym = $$package{$symname};
- next unless (defined $sym);
- print "scalar => $symname = '$sym'\n";
- }
-
- # array.
- foreach $symname (sort keys %$package) {
- local *sym = $$package{$symname};
- next unless (defined @sym);
- print "\@$symname\n";
- &tree(2, "ARRAY", $symname);
- }
-
- # hash.
- foreach $symname (sort keys %$package) {
- local *sym = $$package{$symname};
- next unless (defined %sym);
- print "\%$symname\n";
- &tree(2, "HASH", $symname);
- }
-
- foreach $symname (sort keys %$package) {
- local *sym = $$package{$symname};
- next unless (defined %sym);
- next unless ($symname =~ /::/);
- next if ($symname eq 'main::');
-
- print "recurse: $symname.\n";
- &vartree(\%sym, $symname);
- }
-
- print "end.\n";
-}
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-use LWP;
-use POSIX qw(strftime);
-
-my $backup_interval = 1; # every: 1,7,14,30.
-my $backup_count = 7;
-my $backup_url = "http://core.junker.org/~apt/tables.tar.bz2";
-my $backup_file = "tables-##DATE.tar.bz2";
-my $backup_destdir = "/home/xk/public_html/";
-my $backup_indexfile = "tables-index.txt";
-
-my %index;
-
-# Usage: &getURL($url);
-sub getURL {
- my ($url) = @_;
- my ($ua,$res,$req);
-
- $ua = new LWP::UserAgent;
-### $ua->proxy('http', $proxy);
-
- $req = new HTTP::Request('GET',$url);
- $res = $ua->request($req);
-
- # return NULL upon error.
- if ($res->is_success) {
- return $res->content;
- } else {
- print "error: failure.\n";
- exit 1;
- }
-}
-
-#...
-if ( -f "$backup_destdir/$backup_indexfile") {
- if (open(INDEX, "$backup_destdir/$backup_indexfile")) {
- while (<INDEX>) {
- chop;
-
- # days since 1970, file.
- if (/^(\d+) (\S+)$/) {
- $index{$1} = $2;
- }
- }
- close INDEX;
- } else {
- print "WARNING: can't open $backup_indexfile.\n";
- }
-}
-my $now_days = (localtime)[7] + (((localtime)[5] - 70) * 365);
-my $now_date = strftime("%Y%m%d", localtime);
-
-if (scalar keys %index) {
- my $last_days = (sort {$b <=> $a} keys %index)[0];
-
- if ($now_days - $last_days < $backup_interval) {
- print "error: shouldn't run today.\n";
- goto cycle;
- }
-}
-
-$backup_file =~ s/##DATE/$now_date/;
-print "backup_file => '$backup_file'.\n";
-if ( -f $backup_file) {
- print "error: $backup_file already exists.\n";
- exit 1;
-}
-
-my $file = &getURL($backup_url);
-open(OUT,">$backup_destdir/$backup_file");
-print OUT $file;
-close OUT;
-
-$index{$now_days} = $backup_file;
-cycle:;
-my @index = sort {$b <=> $a} keys %index;
-
-open(OUT,">$backup_destdir/$backup_indexfile");
-for(my $i=0; $i<scalar(@index); $i++) {
- my $day = $index[$i];
- print "fe: day => '$day'.\n";
-
- if ($backup_count - 1 >= $i) {
- print "DEBUG: $day $index{$day}\n";
- print OUT "$day $index{$day}\n";
- } else {
- print "Deleting $index{$day}\n";
- unlink $backup_destdir."/".$index{$day};
- }
-}
-close OUT;
-
-print "Done.\n";
+++ /dev/null
-Welcome,
-
-This directory has changed slightly. The new format allows for
-each type of database to have its own schema. The following
-directories are included:
-
- mysql/ -- Schema for the popular MySQL
- sqlite/ -- Schema for v2 or v3 of SQLite
- sqlite2/ -- Schema for specifically v2 of SQLite
- pgsql/ -- Schema for PostgreSQL
-
-Also, the included setup.pl has been modified to work with
-all of the above types of databases. (FIXME: actually, only
-MySQL until I actually change it)
-
-To automate the setup of your database and user, type:
-
- cd ~/blootbotdir
- ./setup/setup.pl
-
-(NOTE: The setup will ask for an account capable of administrating
-the database server!)
+++ /dev/null
-CREATE TABLE botmail (
- srcwho VARCHAR(20) NOT NULL,
- dstwho VARCHAR(20) NOT NULL,
- srcuh VARCHAR(80) NOT NULL,
- time INT UNSIGNED DEFAULT 'UNIX_TIMESTAMP()',
- msg TEXT NOT NULL,
- PRIMARY KEY (srcwho,dstwho)
-);
+++ /dev/null
-CREATE TABLE connections (
- server VARCHAR(30) NOT NULL,
- port INT NOT NULL DEFAULT '6667',
- nick VARCHAR(20) NOT NULL,
- nickservpass VARCHAR(8) NOT NULL,
- ircname VARCHAR (20) NOT NULL DEFAULT 'blootbot experimental bot',
- timeadded INT UNSIGNED DEFAULT 'UNIX_TIMESTAMP()',
- PRIMARY KEY (server,port,nick)
-);
+++ /dev/null
-CREATE TABLE factoids (
- factoid_key VARCHAR(64) NOT NULL,
- requested_by VARCHAR(64) NOT NULL DEFAULT 'nobody',
- requested_time INT NOT NULL DEFAULT '0',
- requested_count SMALLINT UNSIGNED NOT NULL DEFAULT '0',
- created_by VARCHAR(64),
- created_time INT NOT NULL DEFAULT '0',
- modified_by VARCHAR(192),
- modified_time INT NOT NULL DEFAULT '0',
- locked_by VARCHAR(64),
- locked_time INT NOT NULL DEFAULT '0',
- factoid_value TEXT NOT NULL,
- PRIMARY KEY (factoid_key)
-);
+++ /dev/null
-CREATE TABLE freshmeat (
- projectname_short VARCHAR(64) NOT NULL,
- latest_version VARCHAR(32) DEFAULT 'none' NOT NULL,
- license VARCHAR(32),
- url_homepage VARCHAR(128),
- desc_short VARCHAR(96) NOT NULL,
- PRIMARY KEY (projectname_short,latest_version)
-);
+++ /dev/null
-CREATE TABLE news (
- channel VARCHAR(16) NOT NULL,
- id INT UNSIGNED DEFAULT '0',
- key VARCHAR(16) NOT NULL,
- value TEXT NOT NULL, # limit to ~450 or so.
- PRIMARY KEY (channel,id,key)
-);
+++ /dev/null
-CREATE TABLE onjoin (
- nick VARCHAR(20) NOT NULL,
- channel VARCHAR(16) NOT NULL,
- message VARCHAR(255) NOT NULL,
- modified_by VARCHAR(20) NOT NULL DEFAULT 'nobody',
- modified_time INT NOT NULL DEFAULT '0',
- PRIMARY KEY (nick, channel)
-);
-
--- v.2 -> v.3
--- ALTER TABLE onjoin ADD COLUMN modified_by VARCHAR(20) NOT NULL DEFAULT 'nobody';
--- ALTER TABLE onjoin ADD COLUMN modified_time INT NOT NULL DEFAULT '0';
--- ** the following doesn't work for sqlite **
--- ALTER TABLE onjoin ADD PRIMARY KEY (nick, channel);
+++ /dev/null
-CREATE TABLE rootwarn (
- nick VARCHAR(20) NOT NULL,
- attempt SMALLINT UNSIGNED,
- time INT NOT NULL,
- host VARCHAR(80) NOT NULL,
- channel VARCHAR(20) NOT NULL,
- PRIMARY KEY (nick)
-);
+++ /dev/null
-CREATE TABLE seen (
- nick VARCHAR(20) NOT NULL,
- time INT NOT NULL,
- channel VARCHAR(20) NOT NULL,
- host VARCHAR(80) NOT NULL,
- message TINYTEXT NOT NULL,
- PRIMARY KEY (nick,channel)
-);
+++ /dev/null
-CREATE TABLE stats (
- nick VARCHAR(20) NOT NULL,
- type VARCHAR(8) NOT NULL,
- channel VARCHAR(16) NOT NULL DEFAULT "PRIVATE",
- time INT UNSIGNED DEFAULT 'UNIX_TIMESTAMP()',
- counter SMALLINT UNSIGNED DEFAULT '0',
- PRIMARY KEY (nick,type,channel)
-);
+++ /dev/null
-CREATE TABLE uptime (
- uptime INT UNSIGNED DEFAULT '0', # start.
- endtime INT UNSIGNED DEFAULT '0', # end.
- string VARCHAR(128) NOT NULL,
- PRIMARY KEY (uptime)
-);
+++ /dev/null
-CREATE TABLE botmail (
- srcwho character varying(20) NOT NULL,
- dstwho character varying(20) NOT NULL,
- srcuh character varying(80) NOT NULL,
- "time" numeric DEFAULT 0 NOT NULL,
- msg text NOT NULL
-) WITHOUT OIDS;
-
-REVOKE ALL ON TABLE botmail FROM PUBLIC;
-
-ALTER TABLE ONLY botmail
- ADD CONSTRAINT botmail_pkey PRIMARY KEY (srcwho, dstwho);
+++ /dev/null
-CREATE TABLE connections (
- server character varying(30) NOT NULL,
- port integer DEFAULT 6667 NOT NULL,
- nick character varying(20) NOT NULL,
- nickservpass character varying(8) NOT NULL,
- ircname character varying(20) DEFAULT 'blootbot IRC bot'::character varying NOT NULL,
- timeadded numeric DEFAULT 0
-) WITHOUT OIDS;
-
-REVOKE ALL ON TABLE connections FROM PUBLIC;
-
-ALTER TABLE ONLY connections
- ADD CONSTRAINT connections_pkey PRIMARY KEY (server, port, nick);
+++ /dev/null
-CREATE TABLE factoids (
- factoid_key VARCHAR(64) NOT NULL,
- requested_by VARCHAR(80) DEFAULT 'nobody' NOT NULL,
- requested_time numeric(11) DEFAULT 0 NOT NULL,
- requested_count numeric(5) DEFAULT 0 NOT NULL,
- created_by VARCHAR(80),
- created_time numeric(11) DEFAULT 0 NOT NULL,
- modified_by VARCHAR(80),
- modified_time numeric(11) DEFAULT 0 NOT NULL,
- locked_by VARCHAR(80),
- locked_time numeric(11) DEFAULT 0 NOT NULL,
- factoid_value text NOT NULL
-) WITHOUT OIDS;
-
-REVOKE ALL ON TABLE factoids FROM PUBLIC;
-
-CREATE INDEX factoids_idx_fvalue ON factoids USING hash (factoid_value);
-
-ALTER TABLE ONLY factoids
- ADD CONSTRAINT factoids_pkey_fkey PRIMARY KEY (factoid_key);
+++ /dev/null
-CREATE TABLE freshmeat (
- projectname_short VARCHAR(64) NOT NULL,
- latest_version VARCHAR(32) DEFAULT 'none'::VARCHAR NOT NULL,
- license VARCHAR(32),
- url_homepage VARCHAR(128),
- desc_short VARCHAR(96) NOT NULL
-) WITHOUT OIDS;
-
-REVOKE ALL ON TABLE freshmeat FROM PUBLIC;
-
-ALTER TABLE ONLY freshmeat
- ADD CONSTRAINT freshmeat_pkey PRIMARY KEY (projectname_short, latest_version);
+++ /dev/null
-CREATE TABLE news (
- channel VARCHAR(16) NOT NULL,
- id numeric DEFAULT 0 NOT NULL,
- "key" VARCHAR(16) NOT NULL,
- value text NOT NULL
-) WITHOUT OIDS;
-
-REVOKE ALL ON TABLE news FROM PUBLIC;
-
-ALTER TABLE ONLY news
- ADD CONSTRAINT news_pkey PRIMARY KEY (channel, id, "key");
+++ /dev/null
-CREATE TABLE onjoin (
- nick VARCHAR(20) NOT NULL,
- channel VARCHAR(16) NOT NULL,
- message VARCHAR(255) NOT NULL,
- modified_by VARCHAR(20) DEFAULT 'nobody' NOT NULL,
- modified_time numeric DEFAULT 0 NOT NULL
-) WITHOUT OIDS;
-
-REVOKE ALL ON TABLE onjoin FROM PUBLIC;
-
-ALTER TABLE ONLY onjoin
- ADD CONSTRAINT onjoin_pkey PRIMARY KEY (nick, channel);
+++ /dev/null
-CREATE TABLE rootwarn (
- nick VARCHAR(20) NOT NULL,
- attempt numeric,
- "time" numeric NOT NULL,
- host VARCHAR(80) NOT NULL,
- channel VARCHAR(20) NOT NULL
-) WITHOUT OIDS;
-
-REVOKE ALL ON TABLE rootwarn FROM PUBLIC;
-
-ALTER TABLE ONLY rootwarn
- ADD CONSTRAINT rootwarn_pkey PRIMARY KEY (nick);
+++ /dev/null
-CREATE TABLE seen (
- nick VARCHAR(20) NOT NULL,
- "time" numeric NOT NULL,
- channel VARCHAR(20) NOT NULL,
- host VARCHAR(80) NOT NULL,
- message text NOT NULL,
- hehcount numeric DEFAULT 0 NOT NULL,
- messagecount numeric DEFAULT 0 NOT NULL
-) WITHOUT OIDS;
-
-REVOKE ALL ON TABLE seen FROM PUBLIC;
-
-ALTER TABLE ONLY seen
- ADD CONSTRAINT seen_pkey PRIMARY KEY (nick, channel);
+++ /dev/null
-CREATE TABLE stats (
- nick VARCHAR(20) NOT NULL,
- "type" VARCHAR(8) NOT NULL,
- channel VARCHAR(16) DEFAULT 'PRIVATE' NOT NULL,
- "time" numeric DEFAULT 0 NOT NULL,
- counter numeric DEFAULT 0
-) WITHOUT OIDS;
-
-REVOKE ALL ON TABLE stats FROM PUBLIC;
-
-ALTER TABLE ONLY stats
- ADD CONSTRAINT stats_pkey PRIMARY KEY (nick, "type", channel);
+++ /dev/null
-CREATE TABLE uptime (
- uptime numeric DEFAULT 0,
- endtime numeric DEFAULT 0,
- string VARCHAR(128) NOT NULL
-) WITHOUT OIDS;
-
-REVOKE ALL ON TABLE uptime FROM PUBLIC;
-
-ALTER TABLE ONLY uptime
- ADD CONSTRAINT uptime_pkey PRIMARY KEY (uptime);
+++ /dev/null
-#!/usr/bin/perl
-# setup_tables: setup MYSQL/PGSQL side of things for blootbot.
-# written by the xk.
-###
-
-require "src/logger.pl";
-require "src/core.pl";
-require "src/modules.pl";
-require "src/Misc.pl";
-require "src/CLI/Support.pl";
-
-$bot_src_dir = "src/";
-
-# read param stuff from blootbot.config.
-&loadConfig("files/blootbot.config");
-
-&loadDBModules();
-my $dbname = $param{'DBName'};
-my $query;
-
-if ($dbname eq "") {
- print "error: appears that the config file was not loaded properly.\n";
- exit 1;
-}
-
-if ($param{'DBType'} =~ /mysql/i) {
- use DBI;
-
- print "Enter root information...\n";
- # username.
- print "Username: ";
- chop (my $adminuser = <STDIN>);
-
- # passwd.
- system "stty -echo";
- print "Password: ";
- chop(my $adminpass = <STDIN>);
- print "\n";
- system "stty echo";
-
- if ($adminuser eq "" or $adminpass eq "") {
- &ERROR("error: adminuser || adminpass is NULL.");
- exit 1;
- }
-
- &sqlOpenDB("mysql", "mysql", $adminuser, $adminpass);
-
- my $database_exists = 0;
- foreach $database (&sqlRawReturn("SHOW DATABASES")) {
- $database_exists++ if $database eq $param{DBName};
- }
- if ($database_exists) {
- &status("Database '$param{DBName}' already exists. Continuing...");
- } else {
- &status("Creating db ...");
- &sqlRaw("create(database)", "CREATE DATABASE $param{DBName}");
- }
-
- &status("--- Adding user information for user '$param{'SQLUser'}'");
-
- if (!&sqlSelect("user", "user", { 'user' => &sqlQuote($param{'SQLUser'}) })) {
- &status("--- Adding user '$param{'SQLUser'}' $dbname/user table...");
-
- $query = "INSERT INTO user VALUES ".
- "('localhost', '$param{'SQLUser'}', ".
- "password('$param{'SQLPass'}'), ";
-
- $query .= "'Y','Y','Y','Y','Y','Y','N','N','N','N','N','N','N','N')";
-
- &sqlRaw("create(user)", $query);
- } else {
- &status("... user information already present.");
- }
-
- if (!&sqlSelect("db", "db", { 'db' => &sqlQuote($param{'SQLUser'}) })) {
- &status("--- Adding database information for database '$dbname'.");
-
- $query = "INSERT INTO db VALUES ".
- "('localhost', '$dbname', ".
- "'$param{'SQLUser'}', ";
-
- $query .= "'Y','Y','Y','Y','Y','Y','Y','N','N','N')";
-
- &sqlRaw("create(db)", $query);
- } else {
- &status("... db info already present.");
- }
-
- # flush.
- &status("Flushing privileges...");
- $query = "FLUSH PRIVILEGES";
- &sqlRaw("mysql(flush)", $query);
-}
-
-&status("Done.");
-
-&sqlCloseDB();
+++ /dev/null
-CREATE TABLE botmail (
- srcwho VARCHAR(20) NOT NULL,
- dstwho VARCHAR(20) NOT NULL,
- srcuh VARCHAR(80) NOT NULL,
- time INT UNSIGNED DEFAULT 'UNIX_TIMESTAMP()',
- msg TEXT NOT NULL,
- PRIMARY KEY (srcwho,dstwho)
-);
+++ /dev/null
-CREATE TABLE connections (
- server VARCHAR(30) NOT NULL,
- port INT NOT NULL DEFAULT '6667',
- nick VARCHAR(20) NOT NULL,
- nickservpass VARCHAR(8) NOT NULL,
- ircname VARCHAR (20) NOT NULL DEFAULT 'blootbot experimental bot',
- timeadded INT UNSIGNED DEFAULT 'UNIX_TIMESTAMP()',
- PRIMARY KEY (server,port,nick)
-);
+++ /dev/null
-CREATE TABLE factoids (
- factoid_key VARCHAR(64) NOT NULL,
- requested_by VARCHAR(64) NOT NULL DEFAULT 'nobody',
- requested_time INT NOT NULL DEFAULT '0',
- requested_count SMALLINT UNSIGNED NOT NULL DEFAULT '0',
- created_by VARCHAR(64),
- created_time INT NOT NULL DEFAULT '0',
- modified_by VARCHAR(192),
- modified_time INT NOT NULL DEFAULT '0',
- locked_by VARCHAR(64),
- locked_time INT NOT NULL DEFAULT '0',
- factoid_value TEXT NOT NULL,
- PRIMARY KEY (factoid_key)
-);
+++ /dev/null
-CREATE TABLE freshmeat (
- projectname_short VARCHAR(64) NOT NULL,
- latest_version VARCHAR(32) DEFAULT 'none' NOT NULL,
- license VARCHAR(32),
- url_homepage VARCHAR(128),
- desc_short VARCHAR(96) NOT NULL,
- PRIMARY KEY (projectname_short,latest_version)
-);
+++ /dev/null
-CREATE TABLE news (
- channel VARCHAR(16) NOT NULL,
- id INT UNSIGNED DEFAULT '0',
- key VARCHAR(16) NOT NULL,
- value TEXT NOT NULL, # limit to ~450 or so.
- PRIMARY KEY (channel,id,key)
-);
+++ /dev/null
-CREATE TABLE onjoin (
- nick VARCHAR(20) NOT NULL,
- channel VARCHAR(16) NOT NULL,
- message VARCHAR(255) NOT NULL,
- modified_by VARCHAR(20) NOT NULL DEFAULT 'nobody',
- modified_time INT NOT NULL DEFAULT '0',
- PRIMARY KEY (nick, channel)
-);
-
--- v.2 -> v.3
--- ALTER TABLE onjoin ADD COLUMN modified_by VARCHAR(20) NOT NULL DEFAULT 'nobody';
--- ALTER TABLE onjoin ADD COLUMN modified_time INT NOT NULL DEFAULT '0';
--- ** the following doesn't work for sqlite **
--- ALTER TABLE onjoin ADD PRIMARY KEY (nick, channel);
+++ /dev/null
-CREATE TABLE rootwarn (
- nick VARCHAR(20) NOT NULL,
- attempt SMALLINT UNSIGNED,
- time INT NOT NULL,
- host VARCHAR(80) NOT NULL,
- channel VARCHAR(20) NOT NULL,
- PRIMARY KEY (nick)
-);
+++ /dev/null
-CREATE TABLE seen (
- nick VARCHAR(20) NOT NULL,
- time INT NOT NULL,
- channel VARCHAR(20) NOT NULL,
- host VARCHAR(80) NOT NULL,
- message TINYTEXT NOT NULL,
- PRIMARY KEY (nick,channel)
-);
+++ /dev/null
-CREATE TABLE stats (
- nick VARCHAR(20) NOT NULL,
- type VARCHAR(8) NOT NULL,
- channel VARCHAR(16) NOT NULL DEFAULT "PRIVATE",
- time INT UNSIGNED DEFAULT 'UNIX_TIMESTAMP()',
- counter SMALLINT UNSIGNED DEFAULT '0',
- PRIMARY KEY (nick,type,channel)
-);
+++ /dev/null
-CREATE TABLE uptime (
- uptime INT UNSIGNED DEFAULT '0', # start.
- endtime INT UNSIGNED DEFAULT '0', # end.
- string VARCHAR(128) NOT NULL,
- PRIMARY KEY (uptime)
-);
+++ /dev/null
-CREATE TABLE botmail (
- srcwho VARCHAR(20) NOT NULL,
- dstwho VARCHAR(20) NOT NULL,
- srcuh VARCHAR(80) NOT NULL,
- time INT UNSIGNED DEFAULT 'UNIX_TIMESTAMP()',
- msg TEXT NOT NULL,
- PRIMARY KEY (srcwho,dstwho)
-);
+++ /dev/null
-CREATE TABLE connections (
- server VARCHAR(30) NOT NULL,
- port INT NOT NULL DEFAULT '6667',
- nick VARCHAR(20) NOT NULL,
- nickservpass VARCHAR(8) NOT NULL,
- ircname VARCHAR (20) NOT NULL DEFAULT 'blootbot experimental bot',
- timeadded INT UNSIGNED DEFAULT 'UNIX_TIMESTAMP()',
- PRIMARY KEY (server,port,nick)
-);
+++ /dev/null
-CREATE TABLE factoids (
- factoid_key VARCHAR(64) NOT NULL,
- requested_by VARCHAR(64) NOT NULL DEFAULT 'nobody',
- requested_time INT NOT NULL DEFAULT '0',
- requested_count SMALLINT UNSIGNED NOT NULL DEFAULT '0',
- created_by VARCHAR(64),
- created_time INT NOT NULL DEFAULT '0',
- modified_by VARCHAR(192),
- modified_time INT NOT NULL DEFAULT '0',
- locked_by VARCHAR(64),
- locked_time INT NOT NULL DEFAULT '0',
- factoid_value TEXT NOT NULL,
- PRIMARY KEY (factoid_key)
-);
+++ /dev/null
-CREATE TABLE freshmeat (
- projectname_short VARCHAR(64) NOT NULL,
- latest_version VARCHAR(32) DEFAULT 'none' NOT NULL,
- license VARCHAR(32),
- url_homepage VARCHAR(128),
- desc_short VARCHAR(96) NOT NULL,
- PRIMARY KEY (projectname_short,latest_version)
-);
+++ /dev/null
-CREATE TABLE news (
- channel VARCHAR(16) NOT NULL,
- id INT UNSIGNED DEFAULT '0',
- key VARCHAR(16) NOT NULL,
- value TEXT NOT NULL, # limit to ~450 or so.
- PRIMARY KEY (channel,id,key)
-);
+++ /dev/null
-CREATE TABLE onjoin (
- nick VARCHAR(20) NOT NULL,
- channel VARCHAR(16) NOT NULL,
- message VARCHAR(255) NOT NULL,
- modified_by VARCHAR(20) NOT NULL DEFAULT 'nobody',
- modified_time INT NOT NULL DEFAULT '0',
- PRIMARY KEY (nick, channel)
-);
-
--- v.2 -> v.3
--- ALTER TABLE onjoin ADD COLUMN modified_by VARCHAR(20) NOT NULL DEFAULT 'nobody';
--- ALTER TABLE onjoin ADD COLUMN modified_time INT NOT NULL DEFAULT '0';
--- ** the following doesn't work for sqlite **
--- ALTER TABLE onjoin ADD PRIMARY KEY (nick, channel);
+++ /dev/null
-CREATE TABLE rootwarn (
- nick VARCHAR(20) NOT NULL,
- attempt SMALLINT UNSIGNED,
- time INT NOT NULL,
- host VARCHAR(80) NOT NULL,
- channel VARCHAR(20) NOT NULL,
- PRIMARY KEY (nick)
-);
+++ /dev/null
-CREATE TABLE seen (
- nick VARCHAR(20) NOT NULL,
- time INT NOT NULL,
- channel VARCHAR(20) NOT NULL,
- host VARCHAR(80) NOT NULL,
- message TINYTEXT NOT NULL,
- PRIMARY KEY (nick,channel)
-);
+++ /dev/null
-CREATE TABLE stats (
- nick VARCHAR(20) NOT NULL,
- type VARCHAR(8) NOT NULL,
- channel VARCHAR(16) NOT NULL DEFAULT "PRIVATE",
- time INT UNSIGNED DEFAULT 'UNIX_TIMESTAMP()',
- counter SMALLINT UNSIGNED DEFAULT '0',
- PRIMARY KEY (nick,type,channel)
-);
+++ /dev/null
-CREATE TABLE uptime (
- uptime INT UNSIGNED DEFAULT '0', # start.
- endtime INT UNSIGNED DEFAULT '0', # end.
- string VARCHAR(128) NOT NULL,
- PRIMARY KEY (uptime)
-);
+++ /dev/null
-#
-# CLI/Support.pl: Stubs for functions that are from IRC/*
-# Author: Tim Riker <Tim@Rikers.org>
-# Version: v0.1 (20021028)
-# Created: 20021028
-#
-use strict;
-
-my $postprocess;
-
-use vars qw($uh $message);
-
-sub cliloop {
- &status("Using CLI...");
- &status("Now type what you want.");
-
- $nuh = "local!local\@local";
- $uh = "local\@local";
- $who = 'local';
- $orig{who} = 'local';
- $ident = $param{'ircUser'};
- $chan = $talkchannel = "_local";
- $addressed = 1;
- $msgType = 'private';
- $host = 'local';
-
- # install libterm-readline-gnu-perl to get history support
- use Term::ReadLine;
- my $term = new Term::ReadLine 'blootbot';
- my $prompt = "$who> ";
- #$OUT = $term->OUT || STDOUT;
- while ( defined ($_ = $term->readline($prompt)) ) {
- $orig{message} = $_;
- $message = $_;
- chomp $message;
- last if ($message =~ m/^quit$/);
- $_ = &process() if $message;
- }
- &doExit();
-}
-
-sub msg {
- my ($nick, $msg) = @_;
- if (!defined $nick) {
- &ERROR("msg: nick == NULL.");
- return;
- }
-
- if (!defined $msg) {
- $msg ||= 'NULL';
- &WARN("msg: msg == $msg.");
- return;
- }
-
- if ( $postprocess ) {
- undef $postprocess;
- } elsif ($postprocess = &getChanConf('postprocess', $talkchannel)) {
- &DEBUG("say: $postprocess $msg");
- &parseCmdHook($postprocess . ' ' . $msg);
- undef $postprocess;
- return;
- }
-
- &status(">$nick< $msg");
-
- print("$nick: $msg\n");
-}
-
-# Usage: &action(nick || chan, txt);
-sub action {
- my ($target, $txt) = @_;
- if (!defined $txt) {
- &WARN("action: txt == NULL.");
- return;
- }
-
- if (length $txt > 480) {
- &status("action: txt too long; truncating.");
- chop($txt) while (length $txt > 480);
- }
-
- &status("* $ident/$target $txt");
-}
-
-sub IsNickInChan {
- my ($nick,$chan) = @_;
- return 1;
-}
-
-sub performStrictReply {
- &msg($who, @_);
-}
-
-sub performReply {
- &msg($who, @_);
-}
-
-sub performAddressedReply {
- return unless ($addressed);
- &msg($who, @_);
-}
-
-1;
+++ /dev/null
-#
-# User Command Extension Stubs
-# WARN: this file does not reload on HUP.
-#
-
-#use strict; # TODO: sub { \&{ $hash{'CODEREF'} }($flatarg) };
-
-use vars qw($who $msgType $conn $chan $message $ident $talkchannel
- $bot_version $bot_data_dir);
-use vars qw(@vernick @vernicktodo);
-use vars qw(%channels %cache %mask %userstats %myModules %cmdstats
- %cmdhooks %lang %ver);
-# TODO: FIX THE FOLLOWING:
-use vars qw($total $x $type $i $good %wingateToDo);
-
-### COMMAND HOOK IMPLEMENTATION.
-# addCmdHook('TEXT_HOOK',
-# (CODEREF => 'Blah',
-# Forker => 1,
-# Module => 'blah.pl' # preload module.
-# Identifier => 'config_label', # change to Config?
-# Help => 'help_label',
-# Cmdstats => 'text_label',)
-#}
-###
-
-sub addCmdHook {
- my ($ident, %hash) = @_;
-
- if (exists $cmdhooks{$ident}) {
- &WARN("aCH: \$cmdhooks{$ident} already exists.");
- return;
- }
-
- &VERB("aCH: added $ident",2); # use $hash{'Identifier'}?
- ### hrm... prevent warnings?
- $cmdhooks{$ident} = \%hash;
-}
-
-# RUN IF ADDRESSED.
-sub parseCmdHook {
- my ($line) = @_;
- $line =~ s/^\s+|\s+$//g; # again.
- $line =~ /^(\S+)(\s+(.*))?$/;
- my $cmd = $1; # command name is whitespaceless.
- my $flatarg = $3;
- my @args = split(/\s+/, $flatarg || '');
- my $done = 0;
-
- &shmFlush();
-
- if (!defined %cmdhooks) {
- &WARN('%cmdhooks does not exist.');
- return 0;
- }
-
- if (!defined $cmd) {
- &WARN('cstubs: cmd == NULL.');
- return 0;
- }
-
- foreach (keys %cmdhooks) {
- # rename to something else! like $id or $label?
- my $ident = $_;
-
- next unless ($cmd =~ /^$ident$/i);
-
- if ($done) {
- &WARN("pCH: Multiple hook match: $ident");
- next;
- }
-
- &status("cmdhooks: $cmd matched '$ident' '$flatarg'");
- my %hash = %{ $cmdhooks{$ident} };
-
- if (!scalar keys %hash) {
- &WARN('CmdHook: hash is NULL?');
- return 1;
- }
-
- if ($hash{NoArgs} and $flatarg) {
- &DEBUG("cmd $ident does not take args ('$flatarg'); skipping.");
- next;
- }
-
- if (!exists $hash{CODEREF}) {
- &ERROR("CODEREF undefined for $cmd or $ident.");
- return 1;
- }
-
- ### DEBUG.
- foreach (keys %hash) {
- &VERB(" $cmd->$_ => '$hash{$_}'.",2);
- }
-
- ### HELP.
- if (exists $hash{'Help'} and !scalar(@args)) {
- &help( $hash{'Help'} );
- return 1;
- }
-
- ### IDENTIFIER.
- if (exists $hash{'Identifier'}) {
- return 1 unless (&IsChanConfOrWarn($hash{'Identifier'}));
- }
-
- ### USER FLAGS.
- if (exists $hash{'UserFlag'}) {
- return 1 unless (&hasFlag($hash{'UserFlag'}));
- }
-
- ### FORKER,IDENTIFIER,CODEREF.
- if (($$ == $bot_pid) && exists $hash{'Forker'}) {
- if (exists $hash{'ArrayArgs'}) {
- &Forker($hash{'Identifier'}, sub { \&{ $hash{'CODEREF'} }(@args) } );
- } else {
- &Forker($hash{'Identifier'}, sub { \&{ $hash{'CODEREF'} }($flatarg) } );
- }
-
- } else {
- if (exists $hash{'Module'}) {
- &loadMyModule($hash{'Module'});
- }
-
- # check if CODEREF exists.
- if (!defined &{ $hash{'CODEREF'} }) {
- &WARN("coderef $hash{'CODEREF'} does not exist.");
- if (defined $who) {
- &msg($who, "coderef does not exist for $ident.");
- }
-
- return 1;
- }
-
- if (exists $hash{'ArrayArgs'}) {
- &{ $hash{'CODEREF'} }(@args);
- } else {
- &{ $hash{'CODEREF'} }($flatarg);
- }
- }
-
- ### CMDSTATS.
- if (exists $hash{'Cmdstats'}) {
- $cmdstats{ $hash{'Cmdstats'} }++;
- }
-
- &VERB('hooks: End of command.',2);
-
- $done = 1;
- }
-
- return 1 if ($done);
- return 0;
-}
-
-sub Modules {
- if (!defined $message) {
- &WARN('Modules: message is undefined. should never happen.');
- return;
- }
-
- my $debiancmd = 'conflicts?|depends?|desc|file|(?:d)?info|provides?';
- $debiancmd .= '|recommends?|suggests?|maint|maintainer';
-
- if ($message =~ /^($debiancmd)(\s+(.*))?$/i) {
- return unless (&IsChanConfOrWarn('Debian'));
- my $package = lc $3;
-
- if (defined $package) {
- &Forker('Debian', sub { &Debian::infoPackages($1, $package); } );
- } else {
- &help($1);
- }
-
- return;
- }
-
- # google searching. Simon++
- my $w3search_regex = 'google';
- if ($message =~ /^(?:search\s+)?($w3search_regex)\s+(?:for\s+)?['"]?(.*?)["']?\s*\?*$/i) {
- return unless (&IsChanConfOrWarn('W3Search'));
-
- &Forker('W3Search', sub { &W3Search::W3Search($1,$2); } );
-
- $cmdstats{'W3Search'}++;
- return;
- }
-
- # text counters. (eg: hehstats)
- my $itc;
- $itc = &getChanConf('ircTextCounters');
- $itc = &findChanConf('ircTextCounters') unless ($itc);
- return if ($itc && &do_text_counters($itc) == 1);
- # end of text counters.
-
- # list{keys|values}. xk++. Idea taken from #linuxwarez@EFNET
- if ($message =~ /^list(\S+)(\s+(.*))?$/i) {
- return unless (&IsChanConfOrWarn('Search'));
-
- my $thiscmd = lc $1;
- my $args = $3 || '';
-
- $thiscmd =~ s/^vals$/values/;
- return if ($thiscmd ne 'keys' && $thiscmd ne 'values');
-
- # Usage:
- if (!defined $args or $args =~ /^\s*$/) {
- &help('list'. $thiscmd);
- return;
- }
-
- # suggested by asuffield and \broken.
- if ($args =~ /^["']/ and $args =~ /["']$/) {
- &DEBUG('list*: removed quotes.');
- $args =~ s/^["']|["']$//g;
- }
-
- if (length $args < 2 && &IsFlag('o') ne 'o') {
- &msg($who, 'search string is too short.');
- return;
- }
-
- &Forker('Search', sub { &Search::Search($thiscmd, $args); } );
-
- $cmdstats{'Factoid Search'}++;
- return;
- }
-
- # Topic management. xk++
- # may want to add a userflags for topic. -xk
- if ($message =~ /^topic(\s+(.*))?$/i) {
- return unless (&IsChanConfOrWarn('Topic'));
-
- my $chan = $talkchannel;
- my @args = split / /, $2 || '';
-
- if (!scalar @args) {
- &msg($who,"Try 'help topic'");
- return;
- }
-
- $chan = lc(shift @args) if ($msgType eq 'private');
- my $thiscmd = shift @args;
-
- # topic over public:
- if ($msgType eq 'public' && $thiscmd =~ /^#/) {
- &msg($who, 'error: channel argument is not required.');
- &msg($who, "\002Usage\002: topic <CMD>");
- return;
- }
-
- # topic over private:
- if ($msgType eq 'private' && $chan !~ /^#/) {
- &msg($who, 'error: channel argument is required.');
- &msg($who, "\002Usage\002: topic #channel <CMD>");
- return;
- }
-
- if (&validChan($chan) == 0) {
- &msg($who,"error: invalid channel \002$chan\002");
- return;
- }
-
- # for semi-outsiders.
- if (!&IsNickInChan($who,$chan)) {
- &msg($who, "Failed. You ($who) are not in $chan, hey?");
- return;
- }
-
- # now lets do it.
- &loadMyModule('Topic');
- &Topic($chan, $thiscmd, join(' ', @args));
- $cmdstats{'Topic'}++;
- return;
- }
-
- # wingate.
- if ($message =~ /^wingate$/i) {
- return unless (&IsChanConfOrWarn('Wingate'));
-
- my $reply = "Wingate statistics: scanned \002"
- .scalar(keys %wingateToDo)."\002 hosts";
- my $queue = scalar(keys %wingateToDo);
- if ($queue) {
- $reply .= ". I have \002$queue\002 hosts in the queue";
- $reply .= '. Started the scan '.&Time2String(time() - $wingaterun).' ago';
- }
-
- &performStrictReply("$reply.");
-
- return;
- }
-
- # do nothing and let the other routines have a go
- return 'CONTINUE';
-}
-
-# Uptime. xk++
-sub uptime {
- my $count = 1;
- &msg($who, "- Uptime for $ident -");
- &msg($who, "Now: ". &Time2String(&uptimeNow()) ." running $bot_version");
-
- foreach (&uptimeGetInfo()) {
- /^(\d+)\.\d+ (.*)/;
- my $time = &Time2String($1);
- my $info = $2;
-
- &msg($who, "$count: $time $2");
- $count++;
- }
-}
-
-# seen.
-sub seen {
- my($person) = lc shift;
- $person =~ s/\?*$//;
-
- if (!defined $person or $person =~ /^$/) {
- &help('seen');
-
- my $i = &countKeys('seen');
- &msg($who,'there '. &fixPlural('is',$i) ." \002$i\002 ".
- 'seen '. &fixPlural('entry',$i) .' that I know of.');
-
- return;
- }
-
- my @seen;
-
- &seenFlush(); # very evil hack. oh well, better safe than sorry.
-
- # TODO: convert to &sqlSelectRowHash();
- my $select = 'nick,time,channel,host,message';
- if ($person eq 'random') {
- @seen = &randKey('seen', $select);
- } else {
- @seen = &sqlSelect('seen', $select, { nick => $person } );
- }
-
- if (scalar @seen < 2) {
- foreach (@seen) {
- &DEBUG("seen: _ => '$_'.");
- }
- &performReply("i haven't seen '$person'");
- return;
- }
-
- # valid seen.
- my $reply;
- ### TODO: multi channel support. may require &IsNick() to return
- ### all channels or something.
-
- my @chans = &getNickInChans($seen[0]);
- if (scalar @chans) {
- $reply = "$seen[0] is currently on";
-
- foreach (@chans) {
- $reply .= ' '.$_;
- next unless (exists $userstats{lc $seen[0]}{'Join'});
- $reply .= ' ('.&Time2String(time() - $userstats{lc $seen[0]}{'Join'}).')';
- }
-
- if (&IsChanConf('seenStats') > 0) {
- my $i;
- $i = $userstats{lc $seen[0]}{'Count'};
- $reply .= ". Has said a total of \002$i\002 messages" if (defined $i);
- $i = $userstats{lc $seen[0]}{'Time'};
- $reply .= '. Is idling for '.&Time2String(time() - $i) if (defined $i);
- }
- $reply .= ", last said\002:\002 '$seen[4]'.";
- } else {
- my $howlong = &Time2String(time() - $seen[1]);
- $reply = "$seen[0] <$seen[3]> was last seen on IRC ".
- "in channel $seen[2], $howlong ago, ".
- "saying\002:\002 '$seen[4]'.";
- }
-
- &performStrictReply($reply);
- return;
-}
-
-# User Information Services. requested by Flugh.
-sub userinfo {
- my ($arg) = join(' ',@_);
-
- if ($arg =~ /^set(\s+(.*))?$/i) {
- $arg = $2;
- if (!defined $arg) {
- &help('userinfo set');
- return;
- }
-
- &UserInfoSet(split /\s+/, $arg, 2);
- } elsif ($arg =~ /^unset(\s+(.*))?$/i) {
- $arg = $2;
- if (!defined $arg) {
- &help('userinfo unset');
- return;
- }
-
- &UserInfoSet($arg, '');
- } else {
- &UserInfoGet($arg);
- }
-}
-
-# cookie (random). xk++
-sub cookie {
- my ($arg) = @_;
-
- # lets find that secret cookie.
- my $target = ($msgType ne 'public') ? $who : $talkchannel;
- my $cookiemsg = &getRandom(keys %{ $lang{'cookie'} });
- my ($key,$value);
-
- ### WILL CHEW TONS OF MEM.
- ### TODO: convert this to a Forker function!
- if ($arg) {
- my @list = &searchTable('factoids', 'factoid_key', 'factoid_value', $arg);
- $key = &getRandom(@list);
- $value = &getFactInfo($key, 'factoid_value');
- } else {
- ($key,$value) = &randKey('factoids','factoid_key,factoid_value');
- }
-
- for ($cookiemsg) {
- s/##KEY/\002$key\002/;
- s/##VALUE/$value/;
- s/##WHO/$who/;
- s/\$who/$who/; # cheap fix.
- s/(\S+)?\s*<\S+>/$1 /;
- s/\s+/ /g;
- }
-
- if ($cookiemsg =~ s/^ACTION //i) {
- &action($target, $cookiemsg);
- } else {
- &msg($target, $cookiemsg);
- }
-}
-
-sub convert {
- my $arg = join(' ',@_);
- my ($from,$to) = ('','');
-
- ($from,$to) = ($1,$2) if ($arg =~ /^(.*?) to (.*)$/i);
- ($from,$to) = ($2,$1) if ($arg =~ /^(.*?) from (.*)$/i);
-
- if (!$to or !$from) {
- &msg($who, 'Invalid format!');
- &help('convert');
- return;
- }
-
- &Units::convertUnits($from, $to);
-
- return;
-}
-
-sub lart {
- my ($target) = &fixString($_[0]);
- my $extra = 0;
- my $chan = $talkchannel;
- my ($for);
- my $mynick = $conn->nick();
-
- if ($msgType eq 'private') {
- if ($target =~ /^($mask{chan})\s+(.*)$/) {
- $chan = $1;
- $target = $2;
- $extra = 1;
- } else {
- &msg($who, 'error: invalid format or missing arguments.');
- &help('lart');
- return;
- }
- }
- if ($target =~ /^(.*)(\s+for\s+.*)$/) {
- $target = $1;
- $for = $2;
- }
-
- my $line = &getRandomLineFromFile($bot_data_dir. '/blootbot.lart');
- if (defined $line) {
- if ($target =~ /^(me|you|itself|\Q$mynick\E)$/i) {
- $line =~ s/WHO/$who/g;
- } else {
- $line =~ s/WHO/$target/g;
- }
- $line .= $for if ($for);
- $line .= ", courtesy of $who" if ($extra);
-
- &action($chan, $line);
- } else {
- &status('lart: error reading file?');
- }
-}
-
-sub DebianNew {
- my $idx = 'debian/Packages-sid.idx';
- my $error = 0;
- my %pkg;
- my @new;
-
- $error++ unless ( -e $idx);
- $error++ unless ( -e "$idx-old");
-
- if ($error) {
- $error = 'no sid/sid-old index file found.';
- &ERROR("Debian: $error");
- &msg($who, $error);
- return;
- }
-
- open(IDX1, $idx);
- open(IDX2, "$idx-old");
-
- while (<IDX2>) {
- chop;
- next if (/^\*/);
-
- $pkg{$_} = 1;
- }
- close IDX2;
-
- open(IDX1,$idx);
- while (<IDX1>) {
- chop;
- next if (/^\*/);
- next if (exists $pkg{$_});
-
- push(@new, $_);
- }
- close IDX1;
-
- &::performStrictReply( &::formListReply(0, 'New debian packages:', @new) );
-}
-
-sub do_verstats {
- my ($chan) = @_;
-
- if (!defined $chan) {
- &help('verstats');
- return;
- }
-
- if (!&validChan($chan)) {
- &msg($who, "chan $chan is invalid.");
- return;
- }
-
- if (scalar @vernick > scalar(keys %{ $channels{lc $chan}{''} })/4) {
- &msg($who, 'verstats already in progress for someone else.');
- return;
- }
-
- &msg($who, "Sending CTCP VERSION to $chan; results in 60s.");
- $conn->ctcp('VERSION', $chan);
- $cache{verstats}{chan} = $chan;
- $cache{verstats}{who} = $who;
- $cache{verstats}{msgType} = $msgType;
-
- $conn->schedule(30, sub {
- my $c = lc $cache{verstats}{chan};
- @vernicktodo = ();
-
- foreach (keys %{ $channels{$c}{''} } ) {
- next if (grep /^\Q$_\E$/i, @vernick);
- push(@vernicktodo, $_);
- }
-
- &verstats_flush();
- } );
-
- $conn->schedule(60, sub {
- my $vtotal = 0;
- my $c = lc $cache{verstats}{chan};
- my $total = keys %{ $channels{$c}{''} };
- $chan = $c;
- $who = $cache{verstats}{who};
- $msgType = $cache{verstats}{msgType};
- delete $cache{verstats}; # sufficient?
-
- foreach (keys %ver) {
- $vtotal += scalar keys %{ $ver{$_} };
- }
-
- my %sorted;
- my $unknown = $total - $vtotal;
- my $perc = sprintf("%.1f", $unknown * 100 / $total);
- $perc =~ s/.0$//;
- $sorted{$perc}{'unknown/cloak'} = "$unknown ($perc%)" if ($unknown);
-
- foreach (keys %ver) {
- my $count = scalar keys %{ $ver{$_} };
- $perc = sprintf("%.01f", $count * 100 / $total);
- $perc =~ s/.0$//; # lame compression.
-
- $sorted{$perc}{$_} = "$count ($perc%)";
- }
-
- ### can be compressed to a map?
- my @list;
- foreach ( sort { $b <=> $a } keys %sorted ) {
- my $perc = $_;
- foreach (sort keys %{ $sorted{$perc} }) {
- push(@list, "$_ - $sorted{$perc}{$_}");
- }
- }
-
- # hack. this is one major downside to scheduling.
- $chan = $c;
- &performStrictReply( &formListReply(0, "IRC Client versions for $c ", @list) );
-
- # clean up not-needed data structures.
- undef %ver;
- undef @vernick;
- } );
-
- return;
-}
-
-sub verstats_flush {
- for (1..5) {
- last unless (scalar @vernicktodo);
-
- my $n = shift(@vernicktodo);
- $conn->ctcp('VERSION', $n);
- }
-
- return unless (scalar @vernicktodo);
-
- $conn->schedule(3, \&verstats_flush() );
-}
-
-sub do_text_counters {
- my ($itc) = @_;
- $itc =~ s/([^\w\s])/\\$1/g;
- my $z = join '|', split ' ', $itc;
-
- if ($msgType eq 'privmsg' and $message =~ / ($mask{chan})$/) {
- &DEBUG("ircTC: privmsg detected; chan = $1");
- $chan = $1;
- }
-
- if ($message =~ /^_stats(\s+(\S+))$/i) {
- &textstats_main($2);
- return 1;
- }
-
- my ($type,$arg);
- if ($message =~ /^($z)stats(\s+(\S+))?$/i) {
- $type = $1;
- $arg = $3;
- } else {
- return 0;
- }
-
- # even more uglier with channel/time arguments.
- my $c = $chan;
-# my $c = $chan || 'PRIVATE';
- my $where = 'type='.&sqlQuote($type);
- if (defined $c) {
- &DEBUG("c => $c");
- $where .= ' AND channel='.&sqlQuote($c) if (defined $c);
- } else {
- &DEBUG('not using chan arg');
- }
-
- my $sum = (&sqlRawReturn('SELECT SUM(counter) FROM stats'
- .' WHERE '.$where ))[0];
-
- if (!defined $arg or $arg =~ /^\s*$/) {
- # this is way ugly.
-
- # TODO: convert $where to hash
- my %hash = &sqlSelectColHash('stats', 'nick,counter',
- { },
- $where.' ORDER BY counter DESC LIMIT 3', 1
- );
- my $i;
- my @top;
-
- # unfortunately we have to sort it again!
- 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 = '';
- if (scalar @top) {
- $topstr = '. Top '.scalar(@top).': '.join(', ', @top);
- }
-
- if (defined $sum) {
- &performStrictReply("total count of \037$type\037 on \002$c\002: $sum$topstr");
- } else {
- &performStrictReply("zero counter for \037$type\037.");
- }
- } else {
- # TODO: convert $where to hash and use a sqlSelect
- my $x = (&sqlRawReturn('SELECT SUM(counter) FROM stats'.
- " WHERE $where AND nick=".&sqlQuote($arg) ))[0];
-
- if (!defined $x) { # !defined.
- &performStrictReply("$arg has not said $type yet.");
- return 1;
- }
-
- # defined.
- # TODO: convert $where to hash
- my @array = &sqlSelect('stats', 'nick', undef,
- $where.' ORDER BY counter', 1
- );
- my $good = 0;
- my $i = 0;
- for ($i=0; $i<scalar @array; $i++) {
- next unless ($array[0] =~ /^\Q$who\E$/);
- $good++;
- last;
- }
- $i++;
-
- my $total = scalar(@array);
- 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);
- &performStrictReply("\002$arg\002 has said \037$type\037 \002$x\002 times (\002$pct1\002 %)$xtra");
- }
-
- return 1;
-}
-
-sub textstats_main {
- my($arg) = @_;
-
- # even more uglier with channel/time arguments.
- my $c = $chan;
-# my $c = $chan || 'PRIVATE';
- &DEBUG('not using chan arg') if (!defined $c);
-
- # example of converting from RawReturn to sqlSelect.
- my $where_href = (defined $c) ? { channel => $c } : '';
- my $sum = &sqlSelect('stats', 'SUM(counter)', $where_href);
-
- if (!defined $arg or $arg =~ /^\s*$/) {
- # this is way ugly.
- &DEBUG('_stats: !arg');
-
- my %hash = &sqlSelectColHash('stats', 'nick,counter',
- $where_href,
- ' ORDER BY counter DESC LIMIT 3', 1
- );
- my $i;
- my @top;
-
- # unfortunately we have to sort it again!
- 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 = '';
- if (scalar @top) {
- $topstr = '. Top '.scalar(@top).': '.join(', ', @top);
- }
-
- if (defined $sum) {
- &performStrictReply("total count of \037$type\037 on \002$c\002: $sum$topstr");
- } else {
- &performStrictReply("zero counter for \037$type\037.");
- }
-
- return;
- }
-
- # TODO: add nick to where_href
- my %hash = &sqlSelectColHash('stats', 'type,counter',
- $where_href, ' AND nick='.&sqlQuote($arg)
- );
-
- # this is totally messed up... needs to be fixed... and cleaned up.
- my $total;
- my $good;
- my $ii;
- my $x;
-
- foreach (keys %hash) {
- &DEBUG("_stats: hash{$_} => $hash{$_}");
- # ranking.
- # TODO: convert $where to hash
- my $where = '';
- my @array = &sqlSelect('stats', 'nick', undef, $where.' ORDER BY counter', 1);
- $good = 0;
- $ii = 0;
- for(my $i=0; $i<scalar @array; $i++) {
- next unless ($array[0] =~ /^\Q$who\E$/);
- $good++;
- last;
- }
- $ii++;
-
- $total = scalar(@array);
- &DEBUG(" i => $i, good => $good, total => $total");
- $x .= ' '.$total.'blah blah';
- }
-
-# return;
-
- if (!defined $x) { # !defined.
- &performStrictReply("$arg has not said $type yet.");
- return;
- }
-
- my $xtra = '';
- if ($total and $good) {
- my $pct = sprintf("%.01f", 100*(1+$total-$ii)/$total);
- $xtra = ", ranked $ii\002/\002$total (percentile: \002$pct\002 %)";
- }
-
- my $pct1 = sprintf("%.01f", 100*$x/$sum);
- &performStrictReply("\002$arg\002 has said \037$type\037 \002$x\002 times (\002$pct1\002 %)$xtra");
-}
-
-sub nullski {
- my ($arg) = @_;
- return unless (defined $arg);
- # big security hole
- #foreach (`$arg`) { &msg($who,$_); }
-}
-
-%cmdhooks=();
-###
-### START ADDING HOOKS.
-###
-&addCmdHook('(babel(fish)?|x|xlate|translate)', ('CODEREF' => 'babelfish::babelfish', 'Identifier' => 'babelfish', 'Cmdstats' => 'babelfish', 'Forker' => 1, 'Help' => 'babelfish', 'Module' => 'babelfish') );
-&addCmdHook('(botmail|message)', ('CODEREF' => 'botmail::parse', 'Identifier' => 'botmail', 'Cmdstats' => 'botmail') );
-&addCmdHook('bzflist17', ('CODEREF' => 'BZFlag::list17', 'Identifier' => 'BZFlag', 'Cmdstats' => 'BZFlag', 'Forker' => 1, 'Module' => 'BZFlag') );
-&addCmdHook('bzflist', ('CODEREF' => 'BZFlag::list', 'Identifier' => 'BZFlag', 'Cmdstats' => 'BZFlag', 'Forker' => 1, 'Module' => 'BZFlag') );
-&addCmdHook('bzfquery', ('CODEREF' => 'BZFlag::query', 'Identifier' => 'BZFlag', 'Cmdstats' => 'BZFlag', 'Forker' => 1, 'Module' => 'BZFlag') );
-&addCmdHook('chan(stats|info)', ('CODEREF' => 'chaninfo', ) );
-&addCmdHook('cmd(stats|info)', ('CODEREF' => 'cmdstats', ) );
-&addCmdHook('convert', ('CODEREF' => 'convert', 'Forker' => 1, 'Identifier' => 'Units', 'Help' => 'convert') );
-&addCmdHook('(cookie|random)', ('CODEREF' => 'cookie', 'Forker' => 1, 'Identifier' => 'Factoids') );
-&addCmdHook('countdown', ('CODEREF' => 'countdown', 'Module' => 'countdown', 'Identifier' => 'countdown', 'Cmdstats' => 'countdown') );
-&addCmdHook('countrystats', ('CODEREF' => 'countryStats') );
-&addCmdHook('dauthor', ('CODEREF' => 'Debian::searchAuthor', 'Forker' => 1, 'Identifier' => 'Debian', 'Cmdstats' => 'Debian Author Search', 'Help' => 'dauthor' ) );
-&addCmdHook('d?bugs', ('CODEREF' => 'DebianExtra::Parse', 'Forker' => 1, 'Identifier' => 'DebianExtra', 'Cmdstats' => 'Debian Bugs') );
-&addCmdHook('d?contents', ('CODEREF' => 'Debian::searchContents', 'Forker' => 1, 'Identifier' => 'Debian', 'Cmdstats' => 'Debian Contents Search', 'Help' => 'contents' ) );
-&addCmdHook('d?find', ('CODEREF' => 'Debian::DebianFind', 'Forker' => 1, 'Identifier' => 'Debian', 'Cmdstats' => 'Debian Search', 'Help' => 'find' ) );
-&addCmdHook('dice', ('CODEREF' => 'dice::dice', 'Identifier' => 'dice', 'Cmdstats' => 'dice', 'Forker' => 1, 'Module' => 'dice') );
-&addCmdHook('Dict', ('CODEREF' => 'Dict::Dict', 'Identifier' => 'Dict', 'Help' => 'dict', 'Forker' => 1, 'Cmdstats' => 'Dict') );
-&addCmdHook('dincoming', ('CODEREF' => 'Debian::generateIncoming', 'Forker' => 1, 'Identifier' => 'Debian' ) );
-&addCmdHook('dnew', ('CODEREF' => 'DebianNew', 'Identifier' => 'Debian' ) );
-&addCmdHook('dns|d?nslookup', ('CODEREF' => 'dns::query', 'Identifier' => 'dns', 'Cmdstats' => 'dns', 'Forker' => 1, 'Help' => 'dns') );
-&addCmdHook('(d|search)desc', ('CODEREF' => 'Debian::searchDescFE', 'Forker' => 1, 'Identifier' => 'Debian', 'Cmdstats' => 'Debian Desc Search', 'Help' => 'ddesc' ) );
-&addCmdHook('dstats', ('CODEREF' => 'Debian::infoStats', 'Forker' => 1, 'Identifier' => 'Debian', 'Cmdstats' => 'Debian Statistics' ) );
-&addCmdHook('(ex)?change', ('CODEREF' => 'Exchange::query', 'Identifier' => 'Exchange', 'Cmdstats' => 'Exchange', 'Forker' => 1) );
-&addCmdHook('factinfo', ('CODEREF' => 'factinfo', 'Cmdstats' => 'Factoid Info', Module => 'Factoids', ) );
-&addCmdHook('factstats?', ('CODEREF' => 'factstats', 'Cmdstats' => 'Factoid Stats', Help => 'factstats', Forker => 1, 'Identifier' => 'Factoids', ) );
-&addCmdHook('help', ('CODEREF' => 'help', 'Cmdstats' => 'Help', ) );
-&addCmdHook('HTTPDtype', ('CODEREF' => 'HTTPDtype::HTTPDtype', 'Identifier' => 'HTTPDtype', 'Cmdstats' => 'HTTPDtype', 'Forker' => 1) );
-&addCmdHook('[ia]?spell', ('CODEREF' => 'spell::query', 'Identifier' => 'spell', 'Cmdstats' => 'spell', 'Forker' => 1, 'Help' => 'spell') );
-&addCmdHook('insult', ('CODEREF' => 'Insult::Insult', 'Forker' => 1, 'Identifier' => 'insult', 'Help' => 'insult' ) );
-&addCmdHook('karma', ('CODEREF' => 'karma', ) );
-&addCmdHook('kernel', ('CODEREF' => 'Kernel::Kernel', 'Forker' => 1, 'Identifier' => 'Kernel', 'Cmdstats' => 'Kernel', 'NoArgs' => 1) );
-&addCmdHook('lart', ('CODEREF' => 'lart', 'Identifier' => 'lart', 'Help' => 'lart') );
-&addCmdHook('lc', ('CODEREF' => 'case::lower', 'Identifier' => 'case', 'Cmdstats' => 'case', 'Forker' => 1, 'Module' => 'case') );
-&addCmdHook('listauth', ('CODEREF' => 'CmdListAuth', 'Identifier' => 'Search', Module => 'Factoids', 'Help' => 'listauth') );
-&addCmdHook('md5(sum)?', ('CODEREF' => 'md5::md5', 'Identifier' => 'md5', 'Cmdstats' => 'md5', 'Forker' => 1, 'Module' => 'md5') );
-&addCmdHook('metar', ('CODEREF' => 'Weather::Metar', 'Identifier' => 'Weather', 'Help' => 'weather', 'Cmdstats' => 'Weather', 'Forker' => 1) );
-&addCmdHook('News', ('CODEREF' => 'News::Parse', Module => 'News', 'Cmdstats' => 'News' ) );
-&addCmdHook('(?:nick|lame)ometer(?: for)?', ('CODEREF' => 'nickometer::query', 'Identifier' => 'nickometer', 'Cmdstats' => 'nickometer', 'Forker' => 1) );
-&addCmdHook('nullski', ('CODEREF' => 'nullski', ) );
-&addCmdHook('page', ('CODEREF' => 'pager::page', 'Identifier' => 'pager', 'Cmdstats' => 'pager', 'Forker' => 1, 'Help' => 'page') );
-&addCmdHook('piglatin', ('CODEREF' => 'piglatin::piglatin', 'Identifier' => 'piglatin', 'Cmdstats' => 'piglatin', 'Forker' => 1) );
-&addCmdHook('Plug', ('CODEREF' => 'Plug::Plug', 'Identifier' => 'Plug', 'Forker' => 1, 'Cmdstats' => 'Plug') );
-&addCmdHook('quote', ('CODEREF' => 'Quote::Quote', 'Forker' => 1, 'Identifier' => 'Quote', 'Help' => 'quote', 'Cmdstats' => 'Quote') );
-&addCmdHook('reverse', ('CODEREF' => 'reverse::reverse', 'Identifier' => 'reverse', 'Cmdstats' => 'reverse', 'Forker' => 1, 'Module' => 'reverse') );
-&addCmdHook('RootWarn', ('CODEREF' => 'CmdrootWarn', 'Identifier' => 'RootWarn', 'Module' => 'RootWarn') );
-&addCmdHook('OnJoin', ('CODEREF' => 'Cmdonjoin', 'Identifier' => 'OnJoin', 'Module' => 'OnJoin') );
-&addCmdHook('Rss', ('CODEREF' => 'Rss::Rss', 'Identifier' => 'Rss', 'Cmdstats' => 'Rss', 'Forker' => 1, 'Help' => 'rss') );
-&addCmdHook('sched(stats|info)', ('CODEREF' => 'scheduleList', ) );
-&addCmdHook('scramble', ('CODEREF' => 'scramble::scramble', 'Identifier' => 'scramble', 'Cmdstats' => 'scramble', 'Forker' => 1, 'Module' => 'scramble') );
-&addCmdHook('seen', ('CODEREF' => 'seen', 'Identifier' => 'seen') );
-&addCmdHook('slashdot', ('CODEREF' => 'Slashdot::Slashdot', 'Identifier' => 'slashdot', 'Forker' => 1, 'Cmdstats' => 'slashdot') );
-&addCmdHook('tell|explain', ('CODEREF' => 'tell', Help => 'tell', Identifier => 'allowTelling', Cmdstats => 'Tell') );
-&addCmdHook('uc', ('CODEREF' => 'case::upper', 'Identifier' => 'case', 'Cmdstats' => 'case', 'Forker' => 1, 'Module' => 'case') );
-&addCmdHook('Uptime', ('CODEREF' => 'uptime', 'Identifier' => 'Uptime', 'Cmdstats' => 'Uptime') );
-&addCmdHook('u(ser)?info', ('CODEREF' => 'userinfo', 'Identifier' => 'UserInfo', 'Help' => 'userinfo', 'Module' => 'UserInfo') );
-&addCmdHook('verstats', ('CODEREF' => 'do_verstats' ) );
-&addCmdHook('Weather', ('CODEREF' => 'Weather::Weather', 'Identifier' => 'Weather', 'Help' => 'weather', 'Cmdstats' => 'Weather', 'Forker' => 1, 'Module' => 'Weather') );
-&addCmdHook('wiki(pedia)?', ('CODEREF' => 'wikipedia::wikipedia', 'Identifier' => 'wikipedia', 'Cmdstats' => 'wikipedia', 'Forker' => 1, 'Help' => 'wikipedia', 'Module' => 'wikipedia') );
-&addCmdHook('wtf', ('CODEREF' => 'wtf::query', 'Identifier' => 'wtf', 'Cmdstats' => 'wtf', 'Forker' => 1, 'Help' => 'wtf', 'Module' => 'wtf') );
-&addCmdHook('zfi', ('CODEREF' => 'zfi::query', 'Identifier' => 'zfi', 'Cmdstats' => 'zfi', 'Forker' => 1, 'Module' => 'zfi') );
-&addCmdHook('(zippy|yow)', ('CODEREF' => 'zippy::get', 'Identifier' => 'Zippy', 'Cmdstats' => 'Zippy', 'Forker' => 1, 'Module' => 'Zippy') );
-&addCmdHook('zsi', ('CODEREF' => 'zsi::query', 'Identifier' => 'zsi', 'Cmdstats' => 'zsi', 'Forker' => 1, 'Module' => 'zsi') );
-###
-### END OF ADDING HOOKS.
-###
-
-&status('loaded '.scalar(keys %cmdhooks).' command hooks.');
-
-1;
+++ /dev/null
-#
-# DynaConfig.pl: Read/Write configuration files dynamically.
-# Author: dms
-# Version: v0.1 (20010120)
-# Created: 20010119
-# NOTE: Merged from User.pl
-#
-
-use strict;
-
-use vars qw(%chanconf %cache %bans %channels %nuh %users %ignore
- %talkWho %dcc %mask);
-use vars qw($utime_userfile $ucount_userfile $utime_chanfile $who
- $ucount_chanfile $userHandle $chan $msgType $talkchannel
- $ident $bot_state_dir $talkWho $flag_quit $wtime_userfile
- $wcount_userfile $wtime_chanfile $nuh $message);
-
-#####
-##### USERFILE CONFIGURATION READER/WRITER
-#####
-
-sub readUserFile {
- my $f = "$bot_state_dir/blootbot.users";
-
- if (! -f $f) {
- &DEBUG("userfile not found; new fresh run detected.");
- return;
- }
-
- if ( -f $f and -f "$f~") {
- my $s1 = -s $f;
- my $s2 = -s "$f~";
-
- if ($s2 > $s1*3) {
- &FIXME("rUF: backup file bigger than current file.");
- }
- }
-
- if (!open IN, $f) {
- &ERROR("Cannot read userfile ($f): $!");
- &closeLog();
- exit 1;
- }
-
- undef %users; # clear on reload.
- undef %bans; # reset.
- undef %ignore; # reset.
-
- my $ver = <IN>;
- if ($ver !~ /^#v1/) {
- &ERROR("old or invalid user file found.");
- &closeLog();
- exit 1; # correct?
- }
-
- my $nick;
- my $type;
- while (<IN>) {
- chop;
-
- next if /^$/;
- next if /^#/;
-
- if (/^--(\S+)[\s\t]+(.*)$/) { # user: middle entry.
- my ($what,$val) = ($1,$2);
-
- if (!defined $val or $val eq '') {
- &WARN("$what: val == NULL.");
- next;
- }
-
- if (!defined $nick) {
- &WARN("DynaConfig: invalid line: $_");
- next;
- }
-
- # nice little hack.
- if ($what eq 'HOSTS') {
- $users{$nick}{$what}{$val} = 1;
- } else {
- $users{$nick}{$what} = $val;
- }
-
- } elsif (/^(\S+)$/) { # user: start entry.
- $nick = $1;
-
- } elsif (/^::(\S+) ignore$/) { # ignore: start entry.
- $chan = $1;
- $type = 'ignore';
-
- } elsif (/^- (\S+):\+(\d+):\+(\d+):(\S+):(.*)$/ and $type eq 'ignore') {
- ### ignore: middle entry.
- my $mask = $1;
- my(@array) = ($2,$3,$4,$5);
- ### DEBUG purposes only!
- if ($mask !~ /^$mask{nuh}$/) {
- &WARN("ignore: mask $mask is invalid.");
- next;
- }
- $ignore{$chan}{$mask} = \@array;
-
- } elsif (/^::(\S+) bans$/) { # bans: start entry.
- $chan = $1;
- $type = 'bans';
-
- } elsif (/^- (\S+):\+(\d+):\+(\d+):(\d+):(\S+):(.*)$/ and $type eq 'bans') {
- ### bans: middle entry.
- # $btime, $atime, $count, $whoby, $reason.
- my(@array) = ($2,$3,$4,$5,$6);
- $bans{$chan}{$1} = \@array;
-
- } else { # unknown.
- &WARN("unknown line: $_");
- }
- }
- close IN;
-
- &status( sprintf("USERFILE: Loaded: %d users, %d bans, %d ignore",
- scalar(keys %users)-1,
- scalar(keys %bans), # ??
- scalar(keys %ignore), # ??
- )
- );
-}
-
-sub writeUserFile {
- if (!scalar keys %users) {
- &DEBUG("wUF: nothing to write.");
- return;
- }
-
- if (!open OUT,">$bot_state_dir/blootbot.users") {
- &ERROR("Cannot write userfile ($bot_state_dir/blootbot.users): $!");
- return;
- }
-
- my $time = scalar(gmtime);
-
- print OUT "#v1: blootbot -- $ident -- written $time\n\n";
-
- ### USER LIST.
- my $cusers = 0;
- foreach (sort keys %users) {
- my $user = $_;
- $cusers++;
- my $count = scalar keys %{ $users{$user} };
- if (!$count) {
- &WARN("user $user has no other attributes; skipping.");
- next;
- }
-
- print OUT "$user\n";
-
- foreach (sort keys %{ $users{$user} }) {
- my $what = $_;
- my $val = $users{$user}{$_};
-
- if (ref($val) eq 'HASH') {
- foreach (sort keys %{ $users{$user}{$_} }) {
- print OUT "--$what\t\t$_\n";
- }
-
- } elsif ($_ eq 'FLAGS') {
- print OUT "--$_\t\t" . join('', sort split('', $val)) . "\n";
- } else {
- print OUT "--$_\t\t$val\n";
- }
- }
- print OUT "\n";
- }
-
- ### BAN LIST.
- my $cbans = 0;
- foreach (keys %bans) {
- my $chan = $_;
- $cbans++;
-
- my $count = scalar keys %{ $bans{$chan} };
- if (!$count) {
- &WARN("bans: chan $chan has no other attributes; skipping.");
- next;
- }
-
- print OUT "::$chan bans\n";
- foreach (keys %{ $bans{$chan} }) {
-# format: bans: mask expire time-added count who-added reason
- my @array = @{ $bans{$chan}{$_} };
- if (scalar @array != 5) {
- &WARN("bans: $chan/$_ is corrupted.");
- next;
- }
-
- printf OUT "- %s:+%d:+%d:%d:%s:%s\n", $_, @array;
- }
- }
- print OUT "\n" if ($cbans);
-
- ### IGNORE LIST.
- my $cignore = 0;
- foreach (keys %ignore) {
- my $chan = $_;
- $cignore++;
-
- my $count = scalar keys %{ $ignore{$chan} };
- if (!$count) {
- &WARN("ignore: chan $chan has no other attributes; skipping.");
- next;
- }
-
- ### TODO: use hash instead of array for flexibility?
- print OUT "::$chan ignore\n";
- foreach (keys %{ $ignore{$chan} }) {
-# format: ignore: mask expire time-added who-added reason
- my @array = @{ $ignore{$chan}{$_} };
- if (scalar @array != 4) {
- &WARN("ignore: $chan/$_ is corrupted.");
- next;
- }
-
- printf OUT "- %s:+%d:+%d:%s:%s\n", $_, @array;
- }
- }
-
- close OUT;
-
- $wtime_userfile = time();
- &status("--- Saved USERFILE ($cusers users; $cbans bans; $cignore ignore) at $time");
- if (defined $msgType and $msgType =~ /^chat$/) {
- &performStrictReply("--- Writing user file...");
- }
-}
-
-#####
-##### CHANNEL CONFIGURATION READER/WRITER
-#####
-
-sub readChanFile {
- my $f = "$bot_state_dir/blootbot.chan";
- if ( -f $f and -f "$f~") {
- my $s1 = -s $f;
- my $s2 = -s "$f~";
-
- if ($s2 > $s1*3) {
- &FIXME("rCF: backup file bigger than current file.");
- }
- }
-
- if (!open IN, $f) {
- &ERROR("Cannot read chanfile ($f): $!");
- return;
- }
-
- undef %chanconf; # reset.
-
- $_ = <IN>; # version string.
-
- my $chan;
- while (<IN>) {
- chop;
-
- next if /^\s*$/;
- next if /^\// or /^\;/; # / or ; are comment lines.
-
- if (/^(\S+)\s*$/) {
- $chan = $1;
- next;
- }
- next unless (defined $chan);
-
- if (/^[\s\t]+\+(\S+)$/) { # bool, true.
- $chanconf{$chan}{$1} = 1;
-
- } elsif (/^[\s\t]+\-(\S+)$/) { # bool, false.
- # although this is supported in run-time configuration.
- $chanconf{$chan}{$1} = 0;
-
- } elsif (/^[\s\t]+(\S+)[\s\t]+(.*)$/) {# what = val.
- $chanconf{$chan}{$1} = $2;
-
- } else {
- &WARN("unknown line: $_") unless (/^#/);
- }
- }
- close IN;
-
- # verify configuration
- ### TODO: check against valid params.
- foreach $chan (keys %chanconf) {
- foreach (keys %{ $chanconf{$chan} }) {
- next unless /^[+-]/;
-
- &WARN("invalid param: chanconf{$chan}{$_}; removing.");
- delete $chanconf{$chan}{$_};
- undef $chanconf{$chan}{$_};
- }
- }
-
- &status("CHANFILE: Loaded: ".(scalar(keys %chanconf)-1)." chans");
-}
-
-sub writeChanFile {
- if (!scalar keys %chanconf) {
- &DEBUG("wCF: nothing to write.");
- return;
- }
-
- if (!open OUT,">$bot_state_dir/blootbot.chan") {
- &ERROR("Cannot write chanfile ($bot_state_dir/blootbot.chan): $!");
- return;
- }
-
- my $time = scalar(gmtime);
- print OUT "#v1: blootbot -- $ident -- written $time\n\n";
-
- if ($flag_quit) {
-
- ### Process 1: if defined in _default, remove same definition
- ### from non-default channels.
- foreach (keys %{ $chanconf{_default} }) {
- my $opt = $_;
- my $val = $chanconf{_default}{$opt};
- my @chans;
-
- foreach (keys %chanconf) {
- $chan = $_;
-
- next if ($chan eq "_default");
- next unless (exists $chanconf{$chan}{$opt});
- next unless ($val eq $chanconf{$chan}{$opt});
-
- push(@chans,$chan);
- delete $chanconf{$chan}{$opt};
- }
-
- if (scalar @chans) {
- &DEBUG("Removed config $opt to @chans since it's defiend in '_default'");
- }
- }
-
- ### Process 2: if defined in all chans but _default, set in
- ### _default and remove all others.
- my (%optsval, %opts);
- foreach (keys %chanconf) {
- $chan = $_;
- next if ($chan eq "_default");
- my $opt;
-
- foreach (keys %{ $chanconf{$chan} }) {
- $opt = $_;
- if (exists $optsval{$opt} and $optsval{$opt} eq $chanconf{$chan}{$opt}) {
- $opts{$opt}++;
- next;
- }
- $optsval{$opt} = $chanconf{$chan}{$opt};
- $opts{$opt} = 1;
- }
- }
-
- foreach (keys %opts) {
- next unless ($opts{$_} > 2);
- &DEBUG(" opts{$_} => $opts{$_}");
- }
-
- ### other optimizations are in UserDCC.pl
- }
-
- ### lets do it...
- foreach (sort keys %chanconf) {
- $chan = $_;
-
- print OUT "$chan\n";
-
- foreach (sort keys %{ $chanconf{$chan} }) {
- my $val = $chanconf{$chan}{$_};
-
- if ($val =~ /^0$/) { # bool, false.
- print OUT " -$_\n";
-
- } elsif ($val =~ /^1$/) { # bool, true.
- print OUT " +$_\n";
-
- } else { # what = val.
- print OUT " $_ $val\n";
-
- }
-
- }
- print OUT "\n";
- }
-
- close OUT;
-
- $wtime_chanfile = time();
- &status("--- Saved CHANFILE (".scalar(keys %chanconf).
- " chans) at $time");
-
- if (defined $msgType and $msgType =~ /^chat$/) {
- &performStrictReply("--- Writing chan file...");
- }
-}
-
-#####
-##### USER COMMANDS.
-#####
-
-# TODO: support multiple flags.
-# TODO: return all flags for opers
-sub IsFlag {
- my $flags = shift;
- my ($ret, $f, $o) = '';
-
- &verifyUser($who, $nuh);
-
- foreach $f (split //, $users{$userHandle}{FLAGS}) {
- foreach $o ( split //, $flags ) {
- next unless ($f eq $o);
-
- $ret = $f;
- last;
- }
- }
-
- $ret;
-}
-
-sub verifyUser {
- my ($nick, $lnuh) = @_;
- my ($user, $m);
-
- if ($userHandle = $dcc{'CHATvrfy'}{$who}) {
- &VERB("vUser: cached auth for $who.",2);
- return $userHandle;
- }
-
- $userHandle = '';
-
- foreach $user (keys %users) {
- next if ($user eq "_default");
-
- foreach $m (keys %{ $users{$user}{HOSTS} }) {
- $m =~ s/\?/./g;
- $m =~ s/\*/.*?/g;
- $m =~ s/([\@\(\)\[\]])/\\$1/g;
-
- next unless ($lnuh =~ /^$m$/i);
-
- if ($user !~ /^\Q$nick\E$/i and !exists $cache{VUSERWARN}{$user}) {
- &status("vU: host matched but diff nick ($nick != $user).");
- $cache{VUSERWARN}{$user} = 1;
- }
-
- $userHandle = $user;
- last;
- }
-
- last if ($userHandle ne '');
-
- if ($user =~ /^\Q$nick\E$/i and !exists $cache{VUSERWARN}{$user}) {
- &status("vU: nick matched but host is not in list ($lnuh).");
- $cache{VUSERWARN}{$user} = 1;
- }
- }
-
- $userHandle ||= "_default";
- # what's talkchannel for?
- $talkWho{$talkchannel} = $who if (defined $talkchannel);
- $talkWho = $who;
-
- return $userHandle;
-}
-
-sub ckpasswd {
- # returns true if arg1 encrypts to arg2
- my ($plain, $encrypted) = @_;
- if ($encrypted eq '') {
- ($plain, $encrypted) = split(/\s+/, $plain, 2);
- }
- return 0 unless ($plain ne '' and $encrypted ne '');
-
- # MD5 // DES. Bobby Billingsley++.
- my $salt;
- if ($encrypted =~ /^(\S{2})/ and length $encrypted == 13) {
- $salt = $1;
- } elsif ($encrypted =~ /^\$\d\$(\w\w)\$/) {
- $salt = $1;
- } else {
- &DEBUG("unknown salt from $encrypted.");
- return 0;
- }
-
- return ($encrypted eq crypt($plain, $salt));
-}
-
-# mainly for dcc chat... hrm.
-sub hasFlag {
- my ($flag) = @_;
-
- if (&IsFlag($flag) eq $flag) {
- return 1;
- } else {
- &status("DCC CHAT: <$who> $message -- not enough flags.");
- &performStrictReply("error: you do not have enough flags for that. ($flag required)");
- return 0;
- }
-}
-
-# expire is time in minutes
-sub ignoreAdd {
- my($mask,$chan,$expire,$comment) = @_;
-
- $chan ||= '*'; # global if undefined.
- $comment ||= ''; # optional.
- $expire ||= 0; # permament.
- my $count ||= 0;
-
- if ($expire > 0) {
- $expire = ($expire*60) + time();
- } else {
- $expire = 0;
- }
-
- my $exist = 0;
- $exist++ if (exists $ignore{$chan}{$mask});
-
- $ignore{$chan}{$mask} = [$expire, time(), $who, $comment];
-
- # TODO: improve this.
- if ($expire == 0) {
- &status("ignore: Added $mask for $chan to NEVER expire, by $who, for $comment");
- } else {
- &status("ignore: Added $mask for $chan to expire $expire mins, by $who, for $comment");
- }
-
- if ($exist) {
- $utime_userfile = time();
- $ucount_userfile++;
-
- return 2;
- } else {
- return 1;
- }
-}
-
-sub ignoreDel {
- my($mask) = @_;
- my @match;
-
- ### TODO: support wildcards.
- foreach (keys %ignore) {
- my $chan = $_;
-
- foreach (grep /^\Q$mask\E$/i, keys %{ $ignore{$chan} }) {
- delete $ignore{$chan}{$mask};
- push(@match,$chan);
- }
-
- &DEBUG("iD: scalar => ".scalar(keys %{ $ignore{$chan} }) );
- }
-
- if (scalar @match) {
- $utime_userfile = time();
- $ucount_userfile++;
- }
-
- return @match;
-}
-
-sub userAdd {
- my($nick,$mask) = @_;
-
- if (exists $users{$nick}) {
- return 0;
- }
-
- $utime_userfile = time();
- $ucount_userfile++;
-
- if (defined $mask and $mask !~ /^\s*$/) {
- &DEBUG("userAdd: mask => $mask");
- $users{$nick}{HOSTS}{$mask} = 1;
- }
-
- $users{$nick}{FLAGS} ||= $users{_default}{FLAGS};
-
- return 1;
-}
-
-sub userDel {
- my($nick) = @_;
-
- if (!exists $users{$nick}) {
- return 0;
- }
-
- $utime_userfile = time();
- $ucount_userfile++;
-
- delete $users{$nick};
-
- return 1;
-}
-
-sub banAdd {
- my($mask,$chan,$expire,$reason) = @_;
-
- $chan ||= '*';
- $expire ||= 0;
-
- if ($expire > 0) {
- $expire = $expire*60 + time();
- }
-
- my $exist = 1;
- $exist++ if (exists $bans{$chan}{$mask} or
- exists $bans{'*'}{$mask});
- $bans{$chan}{$mask} = [$expire, time(), 0, $who, $reason];
-
- my @chans = ($chan eq '*') ? keys %channels : $chan;
- my $m = $mask;
- $m =~ s/\?/\\./g;
- $m =~ s/\*/\\S*/g;
- foreach (@chans) {
- my $chan = $_;
- foreach (keys %{ $channels{$chan}{''} }) {
- next unless (exists $nuh{lc $_});
- next unless ($nuh{lc $_} =~ /^$m$/i);
- &FIXME("nuh{$_} =~ /$m/");
- }
- }
-
- if ($exist == 1) {
- $utime_userfile = time();
- $ucount_userfile++;
- }
-
- return $exist;
-}
-
-sub banDel {
- my($mask) = @_;
- my @match;
-
- foreach (keys %bans) {
- my $chan = $_;
-
- foreach (grep /^\Q$mask\E$/i, keys %{ $bans{$chan} }) {
- delete $bans{$chan}{$_};
- push(@match, $chan);
- }
-
- &DEBUG("bans: scalar => ".scalar(keys %{ $bans{$chan} }) );
- }
-
- if (scalar @match) {
- $utime_userfile = time();
- $ucount_userfile++;
- }
-
- return @match;
-}
-
-sub IsUser {
- my($user) = @_;
-
- if ( &getUser($user) ) {
- return 1;
- } else {
- return 0;
- }
-}
-
-sub getUser {
- my($user) = @_;
-
- if (!defined $user) {
- &WARN("getUser: user == NULL.");
- return;
- }
-
- if (my @retval = grep /^\Q$user\E$/i, keys %users) {
- if ($retval[0] ne $user) {
- &WARN("getUser: retval[0] ne user ($retval[0] ne $user)");
- }
- my $count = scalar keys %{ $users{$retval[0]} };
- &DEBUG("count => $count.");
-
- return $retval[0];
- } else {
- return;
- }
-}
-
-sub chanSet {
- my($cmd, $chan, $what, $val) = @_;
-
- if ($cmd eq "+chan") {
- if (exists $chanconf{$chan}) {
- &performStrictReply("chan $chan already exists.");
- return;
- }
- $chanconf{$chan}{_time_added} = time();
- $chanconf{$chan}{autojoin} = $conn->nick();
-
- &performStrictReply("Joining $chan...");
- &joinchan($chan);
-
- return;
- }
-
- if (!exists $chanconf{$chan}) {
- &performStrictReply("no such channel $chan");
- return;
- }
-
- my $update = 0;
-
- if (defined $what and $what =~ s/^([+-])(\S+)/$2/) {
- ### ".chanset +blah"
- ### ".chanset +blah 10" -- error.
-
- my $set = ($1 eq "+") ? 1 : 0;
- my $was = $chanconf{$chan}{$what};
-
- if ($set) { # add/set.
- if (defined $was and $was eq '1') {
- &performStrictReply("setting $what for $chan already 1.");
- return;
- }
-
- $val = 1;
-
- } else { # delete/unset.
- if (!defined $was) {
- &performStrictReply("setting $what for $chan is not set.");
- return;
- }
-
- $val = 0;
- }
-
- # alter for cosmetic (print out) reasons only.
- $was = (defined $was) ? "; was '$was'" : '';
-
- if ($val eq '0') {
- &performStrictReply("Unsetting $what for $chan$was.");
- delete $chanconf{$chan}{$what};
- } else {
- &performStrictReply("Setting $what for $chan to '$val'$was.");
- $chanconf{$chan}{$what} = $val;
- }
-
- $update++;
-
- } elsif (defined $val) {
- ### ".chanset blah testing"
-
- my $was = $chanconf{$chan}{$what};
- if (defined $was and $was eq $val) {
- &performStrictReply("setting $what for $chan already '$val'.");
- return;
- }
- $was = ($was) ? "; was '$was'" : '';
- &performStrictReply("Setting $what for $chan to '$val'$was.");
-
- $chanconf{$chan}{$what} = $val;
-
- $update++;
-
- } else { # read only.
- ### ".chanset"
- ### ".chanset blah"
-
- if (!defined $what) {
- &WARN("chanset/DC: what == undefine.");
- return;
- }
-
- if (exists $chanconf{$chan}{$what}) {
- &performStrictReply("$what for $chan is '$chanconf{$chan}{$what}'");
- } else {
- &performStrictReply("$what for $chan is not set.");
- }
- }
-
- if ($update) {
- $utime_chanfile = time();
- $ucount_chanfile++;
- }
-
- return;
-}
-
-sub rehashConfVars {
- # this is an attempt to fix where an option is enabled but the module
- # has been not loaded. it also can be used for other things.
-
- foreach (keys %{ $cache{confvars} }) {
- my $i = $cache{confvars}{$_};
- &DEBUG("rehashConfVars: _ => $_");
-
- if (/^news$/ and $i) {
- &loadMyModule('News');
- delete $cache{confvars}{$_};
- }
-
- if (/^uptime$/ and $i) {
- &loadMyModule('Uptime');
- delete $cache{confvars}{$_};
- }
-
- if (/^rootwarn$/i and $i) {
- &loadMyModule('RootWarn');
- delete $cache{confvars}{$_};
- }
-
- if (/^onjoin$/i and $i) {
- &loadMyModule('OnJoin');
- delete $cache{confvars}{$_};
- }
- }
-
- &DEBUG("end of rehashConfVars");
-
- delete $cache{confvars};
-}
-
-my @regFlagsUser = (
- # possible chars to include in FLAG
- 'A', # bot administration over /msg
- # default is only via DCC CHAT
- 'O', # dynamic ops (as on channel). (automatic +o)
- 'T', # add topics.
- 'a', # ask/request factoid.
- 'm', # modify factoid. (includes renaming)
- 'n', # bot owner, can 'reload'
- 'o', # master of bot (automatic +amrt)
- # can search on factoid strings shorter than 2 chars
- # can tell bot to join new channels
- # can [un]lock factoids
- 'r', # remove factoid.
- 't', # teach/add factoid.
-);
-
-1;
+++ /dev/null
-#
-# Misc.pl: Miscellaneous stuff.
-# Author: dms
-# Version: v0.1 (20010906)
-# Created: 20010906
-#
-
-# use strict; # TODO
-
-use vars qw(%param %cache %lang %cmdstats %bots);
-use vars qw($message $who $addressed $chan $h $nuh $ident $msgType
- $correction_plausable);
-
-# 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 !~ /^</) {
- / \Q$ident$/i and last; # someone said i'm something.
- /^i('m)? / and last;
- /^(it|that|there|what)('s)?(\s+|$)/ and last;
- /^you('re)?(\s+|$)/ and last;
-
- /^(where|who|why|when|how)(\s+|$)/ and last;
- /^(this|that|these|those|they)(\s+|$)/ and last;
- /^(every(one|body)|we) / and last;
-
- /^say / and last;
- }
-
- # uncaught commands.
- /^add topic / and last; # topic management.
- /( add$| add |^add )/ and last; # borked teach statement.
- /^learn / and last; # teach. damn morons.
- /^tell (\S+) about / and last; # tell.
- /\=\~/ and last; # substituition.
-
- /^\=/ and last; # botnick = heh is.
- /wants you to know/ and last;
-
- # symbols.
- /(\"\*)/ and last;
- /, / and last;
- (/^'/ and /'$/) and last;
- (/^"/ and /"$/) and last;
-
- # delimiters.
- /\=\>/ 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 = "<REPLY> 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 it doesn't exist, well... it doesn't!
- if (!defined $result) {
- &performReply("i didn't have anything called '$faqtoid' to forget");
- return;
- }
-
- # TODO: squeeze 3 getFactInfo calls into one?
- my $author = &getFactInfo($faqtoid, 'created_by');
- my $count = &getFactInfo($faqtoid, 'requested_count') || 0;
- # don't delete if requested $limit times
- my $limit = &getChanConfDefault('factoidPreventForgetLimit', 100, $chan);
- # don't delete if older than $limitage seconds (modified by requests below)
- my $limitage = &getChanConfDefault('factoidPreventForgetLimitTime', 7 * 24 * 60 * 60, $chan);
- my $t = &getFactInfo($faqtoid, 'created_time') || 0;
- my $age = time() - $t;
-
- # lets scale limitage from 1 (nearly 0) to $limit (full time).
- $limitage = $limitage*($count+1)/$limit if ($count < $limit);
- # isauthor and isop.
- my $isau = (defined $author and &IsHostMatch($author) == 2) ? 1 : 0;
- my $isop = (&IsFlag('o') eq 'o') ? 1 : 0;
-
- if (IsFlag('r') ne 'r' && !$isop) {
- &msg($who, "you don't have access to remove factoids");
- return;
- }
-
- return 'locked factoid' if (&IsLocked($faqtoid) == 1);
-
- ###
- ### lets go do some checking.
- ###
-
- # factoidPreventForgetLimitTime:
- if (!($isop or $isau) and $age/(60*60*24) > $limitage) {
- &msg($who, "cannot remove factoid '$faqtoid', too old. (" .
- $age/(60*60*24) . ">$limitage) use 'no,' instead");
- return;
- }
-
- # factoidPreventForgetLimit:
- if (!($isop or $isau) and $limit and $count > $limit) {
- &msg($who, "will not delete '$faqtoid', count > limit ($count > $limit) use 'no, ' instead.");
- return;
- }
-
- # this may eat some memory.
- # prevent deletion if other factoids redirect to it.
- # TODO: use hash instead of array.
- my @list;
- if (&getChanConf('factoidPreventForgetRedirect')) {
- &status("Factoids/Core: forget: checking for redirect factoids");
- @list = &searchTable('factoids', 'factoid_key',
- 'factoid_value', "^<REPLY> see ");
- }
-
- my $match = 0;
- for (@list) {
- my $f = $_;
- my $v = &getFactInfo($f, 'factoid_value');
- my $fsafe = quotemeta($faqtoid);
- next unless ($v =~ /^<REPLY> ?see( also)? $fsafe\.?$/i);
-
- &DEBUG("Factoids/Core: match! ($f || $faqtoid)");
-
- $match++;
- }
- # TODO: warn for op aswell, but allow force delete.
- if (!$isop and $match) {
- &msg($who, "uhm, other (redirection) factoids depend on this one.");
- return;
- }
-
- # minimize abuse.
- if (!$isop and &IsHostMatch($author) != 2) {
- $cache{forget}{$h}++;
-
- # warn.
- if ($cache{forget}{$h} > 3) {
- &msg($who, "Stop abusing forget!");
- }
-
- # ignore.
- # TODO: make forget limit configurable.
- # TODO: make forget ignore time configurable.
- if ($cache{forget}{$h} > 5) {
- &ignoreAdd(&makeHostMask($nuh), '*', 3*24*60, "abuse of forget");
- &msg($who, "forget: Ignoring you for abuse!");
- }
- }
-
- # lets do it!
-
- if (&IsParam('factoidDeleteDelay') or &IsChanConf('factoidDeleteDelay') > 0) {
- if (!($isop or $isau) and $faqtoid =~ / #DEL#$/) {
- &msg($who, "cannot delete it ($faqtoid).");
- return;
- }
-
- &status("forgot (safe delete): '$faqtoid' - ". scalar(gmtime));
- ### 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($new);
- 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!");
- }
- }
-
- &status("forget: <$who> '$faqtoid' =is=> '$result'");
- &delFactoid($faqtoid);
-
- &performReply("i forgot $faqtoid");
-
- $count{'Update'}++;
-
- 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') > 0);
- if (!$i) {
- &performReply("safe delete has been disable so what is there to undelete?");
- return;
- }
-
- my $faqtoid = $message;
- if ($faqtoid eq '') {
- &help('unforget');
- return;
- }
-
- $faqtoid =~ tr/A-Z/a-z/;
- my $result = &getFactoid($faqtoid." #DEL#");
- my $check = &getFactoid($faqtoid);
-
- if (defined $check) {
- &performReply("cannot undeleted '$faqtoid' because it already exists!");
- return;
- }
-
- if (!defined $result) {
- &performReply("that factoid was not backedup :/");
- return;
- }
-
- &setFactInfo($faqtoid." #DEL#", 'factoid_key', $faqtoid);
-# &setFactInfo($faqtoid, 'modified_by', '');
-# &setFactInfo($faqtoid, 'modified_time', 0);
-
- $check = &getFactoid($faqtoid);
- # TODO: check if $faqtoid." #DEL#" exists?
- if (defined $check) {
- &performReply("Successfully recovered '$faqtoid'. Have fun now.");
- $count{'Undelete'}++;
- } else {
- &performReply("did not recover '$faqtoid'. What happened?");
- }
-
- 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) {
- &performReply("i didn't have anything called '$from' to rename");
- return;
- }
-
- # who == nick!user@host.
- if (&IsFlag('m') ne 'm' and $author !~ /^\Q$who\E\!/i) {
- &msg($who, "factoid '$from' is 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 {
- &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) {
- # excessive length.
- if (length $result > $param{'maxDataSize'}) {
- &performReply("that's too long");
- return;
- }
- # empty
- if (length $result == 0) {
- &performReply("factoid would be empty. use forget?");
- return;
- }
- # min length.
- my $faqauth = &getFactInfo($faqtoid, 'created_by');
- if ((length $result)*2 < length $was and
- &IsFlag('o') ne 'o' and
- &IsHostMatch($faqauth) != 2
- ) {
- &performReply("too drastic change of factoid.");
- }
-
- &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' to modify");
- }
-
- 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 /i; # Must match ^, else factoids with "whois" anywhere break
- 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('Math') > 0 and $addressed) { # perl math.
- &loadMyModule('Math');
- 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 and !$addrchar);
-
- 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;
+++ /dev/null
-#
-# DBStubs.pl: DB independent (I hope, heh) factoid support
-# Author: dms
-# Version: v0.6d (20000223)
-# Created: 19991020
-#
-
-# use strict; # TODO
-
-#####
-# Usage: &setFactInfo($faqtoid, $key, $val);
-sub setFactInfo {
- &sqlSet('factoids',
- { factoid_key => $_[0] },
- { $_[1] => $_[2] }
- );
-}
-
-#####
-# Usage: &getFactInfo($faqtoid, [$what]);
-sub getFactInfo {
- return &sqlSelect('factoids', $_[1], { factoid_key => $_[0] } );
-}
-
-#####
-# Usage: &getFactoid($faqtoid);
-sub getFactoid {
- return &getFactInfo($_[0], 'factoid_value');
-}
-
-#####
-# Usage: &delFactoid($faqtoid);
-sub delFactoid {
- my ($faqtoid) = @_;
-
- &sqlDelete('factoids', { factoid_key => $faqtoid } );
- &status("DELETED $faqtoid");
-
- return 1;
-}
-
-#####
-# Usage: &IsLocked($faqtoid);
-sub IsLocked {
- my ($faqtoid) = @_;
- my $thisnuh = &getFactInfo($faqtoid, 'locked_by');
-
- if (defined $thisnuh and $thisnuh ne '') {
- if (!&IsHostMatch($thisnuh) and &IsFlag('o') ne 'o') {
- &performReply("cannot alter locked factoids");
- return 1;
- }
- }
-
- return 0;
-}
-
-#####
-# Usage: &AddModified($faqtoid,$nuh);
-sub AddModified {
- my ($faqtoid,$nuh) = @_;
- my $modified_by = &getFactInfo($faqtoid, 'modified_by');
- my (@modifiedlist, @modified, %modified);
-
- if (defined $modified_by) {
- push(@modifiedlist, split(/\,/, $modified_by));
- }
- push(@modifiedlist,$nuh);
-
- foreach (reverse @modifiedlist) {
- /^(\S+)!(\S+)@(\S+)$/;
- my $nick = lc $1;
- next if (exists $modified{$nick});
-
- $modified{$nick} = $_;
- push(@modified,$nick);
- }
-
- undef @modifiedlist;
-
- foreach (reverse @modified) {
- push(@modifiedlist, $modified{$_});
- }
- shift(@modifiedlist) while (scalar @modifiedlist > 3);
-
- &setFactInfo($faqtoid, 'modified_by', join(",",@modifiedlist));
- &setFactInfo($faqtoid, 'modified_time', time());
-
- return 1;
-}
-
-#####
-### Commands which use the fundamental functions... Helpers?
-#####
-
-#####
-# Usage: &CmdLock($function,$faqtoid);
-sub CmdLock {
- my ($faqtoid) = @_;
-
- my $thisnuh = &getFactInfo($faqtoid,'locked_by');
-
- if (defined $thisnuh and $thisnuh ne '') {
- my $locked_by = (split(/\!/,$thisnuh))[0];
- &msg($who,"factoid \002$faqtoid\002 has already been locked by $locked_by.");
- return 0;
- }
-
- $thisnuh ||= &getFactInfo($faqtoid,'created_by');
-
- # fixes bug found on 19991103.
- # code needs to be reorganised though.
- if ($thisnuh ne '') {
- if (!&IsHostMatch($thisnuh) && IsFlag('o') ne 'o') {
- &msg($who, "sorry, you are not allowed to lock '$faqtoid'.");
- return 0;
- }
- }
-
- &performReply("locking factoid \002$faqtoid\002");
- &setFactInfo($faqtoid,'locked_by',$nuh);
- &setFactInfo($faqtoid,'locked_time', time());
-
- return 1;
-}
-
-#####
-# Usage: &CmdUnLock($faqtoid);
-sub CmdUnLock {
- my ($faqtoid) = @_;
-
- my $thisnuh = &getFactInfo($faqtoid,'locked_by');
-
- if (!defined $thisnuh) {
- &msg($who, "factoid \002$faqtoid\002 is not locked.");
- return 0;
- }
-
- if ($thisnuh ne '' and !&IsHostMatch($thisnuh) and &IsFlag('o') ne 'o') {
- &msg($who, "sorry, you are not allowed to unlock factoid '$faqtoid'.");
- return 0;
- }
-
- &performReply("unlocking factoid \002$faqtoid\002");
- &setFactInfo($faqtoid,'locked_by', '');
- &setFactInfo($faqtoid,'locked_time', '0'); # pgsql complains if NOT NULL set. So set 0 which is the default
-
- return 1;
-}
-
-1;
+++ /dev/null
-#
-# Norm.pl: Norm.
-# Author: Kevin Lenzo
-# Version: 1997
-#
-
-# TODO:
-# use strict;
-
-sub normquery {
- my ($in) = @_;
-
- $in = " $in ";
-
- for ($in) {
- # where blah is -> where is blah
- s/ (where|what|who)\s+(\S+)\s+(is|are) / $1 $3 $2 /i;
-
- # where blah is -> where is blah
- s/ (where|what|who)\s+(.*)\s+(is|are) / $1 $3 $2 /i;
-
- s/^\s*(.*?)\s*/$1/;
-
- s/be tellin\'?g?/tell/i;
- s/ \'?bout/ about/i;
-
- s/,? any(hoo?w?|ways?)/ /ig;
- s/,?\s*(pretty )*please\??\s*$/\?/i;
-
- # what country is ...
- if ($in =~
- s/wh(at|ich)\s+(add?res?s|country|place|net (suffix|domain))/wh$1 /ig) {
- if ((length($in) == 2) && ($in !~ /^\./)) {
- $in = '.'.$in;
- }
- $in .= '?';
- }
-
- # profanity filters. just delete it
- s/th(e|at|is) (((m(o|u)th(a|er) ?)?fuck(in\'?g?)?|hell|heck|(god-?)?damn?(ed)?) ?)+//ig;
- s/wtf/where/gi;
- s/this (.*) thingy?/ $1/gi;
- s/this thingy? (called )?//gi;
- s/ha(s|ve) (an?y?|some|ne) (idea|clue|guess|seen) /know /ig;
- s/does (any|ne|some) ?(1|one|body) know //ig;
- s/do you know //ig;
- s/can (you|u|((any|ne|some) ?(1|one|body)))( please)? tell (me|us|him|her)//ig;
- s/where (\S+) can \S+ (a|an|the)?//ig;
- s/(can|do) (i|you|one|we|he|she) (find|get)( this)?/is/i; # where can i find
- s/(i|one|we|he|she) can (find|get)/is/gi; # where i can find
- s/(the )?(address|url) (for|to) //i; # this should be more specific
- s/(where is )+/where is /ig;
- s/\s+/ /g;
- s/^\s+//;
- if ($in =~ s/\s*[\/?!]*\?+\s*$//) {
- $finalQMark = 1;
- }
-
- s/\s+/ /g;
- s/^\s*(.*?)\s*$/$1/;
- s/^\s+|\s+$//g; # why twice, see Question.pl
- }
-
- return $in;
-}
-
-# for be-verbs
-sub switchPerson {
- my ($in) = @_;
-
- for ($in) {
- # # fix genitives
- s/(^|\W)\Q$who\Es\s+/$1${who}\'s /ig;
- s/(^|\W)\Q$who\Es$/$1${who}\'s/ig;
- s/(^|\W)\Q$who\E\'(\s|$)/$1${who}\'s$2/ig;
-
- s/(^|\s)i\'m(\W|$)/$1$who is$2/ig;
- s/(^|\s)i\'ve(\W|$)/$1$who has$2/ig;
- s/(^|\s)i have(\W|$)/$1$who has$2/ig;
- s/(^|\s)i haven\'?t(\W|$)/$1$who has not$2/ig;
- s/(^|\s)i(\W|$)/$1$who$2/ig;
- s/ am\b/ is/i;
- s/\bam /is/i;
- s/(^|\s)(me|myself)(\W|$)/$1$who$3/ig;
- s/(^|\s)my(\W|$)/$1${who}\'s$2/ig; # turn 'my' into name's
- s/(^|\W)you\'?re(\W|$)/$1you are$2/ig;
-
- if ($addressed) {
- my $mynick = 'UNDEF';
- $mynick = $conn->nick() if ($conn);
- # is it safe to remove $in from here, too?
- $in =~ s/yourself/$mynick/i;
- $in =~ s/(^|\W)are you(\W|$)/$1is $mynick$2/ig;
- $in =~ s/(^|\W)you are(\W|$)/$1$mynick is$2/ig;
- $in =~ s/(^|\W)you(\W|$)/$1$mynick$2/ig;
- $in =~ s/(^|\W)your(\W|$)/$1$mynick\'s$2/ig;
- }
- }
-
- return $in;
-}
-
-1;
+++ /dev/null
-###
-### Question.pl: Kevin Lenzo (c) 1997
-###
-
-## doQuestion --
-## if ($query == query) {
-## return $value;
-## } else {
-## return NULL;
-## }
-##
-##
-
-# use strict; # TODO
-
-use vars qw($query $reply $finalQMark $nuh $result $talkok $who $nuh);
-use vars qw(%bots %forked);
-
-sub doQuestion {
- # my doesn't allow variables to be inherinted, local does.
- # following is used in math()...
- local($query) = @_;
- local($reply) = '';
- local $finalQMark = $query =~ s/\?+\s*$//;
- $finalQMark += $query =~ s/\?\s*$//;
- $query =~ s/^\s+|\s+$//g;
-
- if (!defined $query or $query =~ /^\s*$/) {
- return '';
- }
-
- my $questionWord = '';
-
- if (!$addressed) {
- return '' unless ($finalQMark);
- return '' unless &IsChanConf('minVolunteerLength') > 0;
- return '' if (length $query < &::getChanConf('minVolunteerLength'));
- } else {
- ### TODO: this should be caught in Process.pl?
- return '' unless ($talkok);
-
- # there is no flag to disable/enable asking factoids...
- # so it was added... thanks zyxep! :)
- if (&IsFlag('a') ne 'a' && &IsFlag('o') ne 'o') {
- &status("$who tried to ask us when not allowed.");
- return;
- }
- }
-
- # dangerous; common preambles should be stripped before here
- if ($query =~ /^forget /i or $query =~ /^no, /) {
- return if (exists $bots{$nuh});
- }
-
- if ($query =~ s/^literal\s+//i) {
- &status("literal ask of '$query'.");
- $literal = 1;
- }
-
- # convert to canonical reference form
- my $x;
- my @query;
-
- push(@query, $query); # 1: push original.
-
- # valid factoid.
- if ($query =~ s/[!.]$//) {
- push(@query, $query);
- }
-
- $x = &normquery($query);
- push(@query, $x) if ($x ne $query);
- $query = $x;
-
- $x = &switchPerson($query);
- push(@query, $x) if ($x ne $query);
- $query = $x;
-
- $query =~ s/\s+at\s*(\?*)$/$1/; # where is x at?
- $query =~ s/^explain\s*(\?*)/$1/i; # explain x
- $query = " $query "; # side whitespaces.
-
- my $qregex = join '|', keys %{ $lang{'qWord'} };
-
- # purge prefix question string.
- if ($query =~ s/^ ($qregex)//i) {
- $questionWord = lc($1);
- }
-
- if ($questionWord eq '' and $finalQMark and $addressed) {
- $questionWord = 'where';
- }
- $query =~ s/^\s+|\s+$//g; # bleh. hacked.
- push(@query, $query) if ($query ne $x);
-
- if (&IsChanConf('factoidArguments') > 0) {
- $result = &factoidArgs($query[0]);
-
- return $result if (defined $result);
- }
-
- my @link;
- for (my$i=0; $i<scalar @query; $i++) {
- $query = $query[$i];
- $result = &getReply($query);
- next if (!defined $result or $result eq '');
-
- # 'see also' factoid redirection support.
-
- while ($result =~ /^see( also)? (.*?)\.?$/) {
- my $link = $2;
-
- # #debian@OPN was having problems with libstdc++ factoid
- # redirection :) 20021116. -xk.
- # hrm... allow recursive loops... next if statement handles
- # that.
- if (grep /^\Q$link\E$/i, @link) {
- &status("recursive link found; bailing out.");
- last;
- }
-
- if (scalar @link >= 5) {
- &status("recursive link limit (5) reached.");
- last;
- }
-
- push(@link, $link);
- my $newr = &getReply($link);
-
- # no such factoid. try commands
- if (!defined $newr || $newr =~ /^0?$/) {
- # support command redirection.
- # recursive cmdHooks aswell :)
- my $done = 0;
- $done++ if &parseCmdHook($link);
- $message = $link;
- $done++ unless (&Modules());
-
- return;
- }
- last if (!defined $newr or $newr eq '');
- $result = $newr;
- }
-
- if (@link) {
- &status("'$query' linked to: ".join(" => ", @link) );
- }
-
- if ($i != 0) {
- &VERB("Question.pl: '$query[0]' did not exist; '$query[$i]' ($i) did",2);
- }
-
- return $result;
- }
-
- ### TODO: Use &Forker(); move function to Debian.pl
- if (&IsChanConf('debianForFactoid') > 0) {
- &loadMyModule('Debian');
- $result = &Debian::DebianFind($query); # ???
- ### TODO: debian module should tell, through shm, that it went
- ### ok or not.
-### return $result if (defined $result);
- }
-
- if ($questionWord ne '' or $finalQMark) {
- # if it has not been explicitly marked as a question
- if ($addressed and $reply eq '') {
- &status("notfound: <$who> ".join(' :: ', @query))
- if ($finalQMark);
-
- return '' unless (&IsParam('friendlyBots'));
-
- foreach (split /\s+/, $param{'friendlyBots'}) {
- &msg($_, ":INFOBOT:QUERY <$who> $query");
- }
- }
- }
-
- return $reply;
-}
-
-sub factoidArgs {
- my($str) = @_;
- my $result;
-
- # to make it eleeter, split each arg and use "blah OR blah or BLAH"
- # which will make it less than linear => quicker!
- # TODO: cache this, update cache when altered. !!! !!! !!!
-# my $t = &timeget();
- my ($first) = split(/\s+/, $str);
-
- # ignore split to commands [dumb commands vs. factoids] (editing commands?)
- return undef if $str =~ /\s+\=\~\s+s[\#\/\:]/;
- my @list = &searchTable('factoids', 'factoid_key', 'factoid_key', "^cmd: $first ");
-# my $delta_time = &timedelta($t);
-# &DEBUG("factArgs: delta_time = $delta_time s");
-# &DEBUG("factArgs: list => ".scalar(@list) );
-
- # from a design perspective, it's better to have the regex in
- # the factoid key to reduce repetitive processing.
-
- # it does not matter if it's not alphabetically sorted.
- foreach (sort { length($b) <=> length($a) } @list) {
- next if (/#DEL#/); # deleted.
-
- s/^cmd: //i;
-# &DEBUG("factarg: '$str' =~ /^$_\$/");
- my $arg = $_;
-
- # eval (evil!) code. cleaned up courtesy of lear.
- my @vals;
- eval {
- @vals = ($str =~ /^$arg$/i);
- };
-
- if ($@) {
- &WARN("factargs: regex failed! '$str' =~ /^$_\$/");
- next;
- }
-
- next unless (@vals);
-
- if (defined $result) {
- &WARN("factargs: '$_' matches aswell.");
- next;
- }
-
-# &DEBUG("vals => @vals");
-
- &status("Question: factoid Arguments for '$str'");
- # TODO: use getReply() - need to modify it :(
- my $i = 0;
- my $q = "cmd: $_";
- my $r = &getFactoid($q);
- if (!defined $r) {
- &DEBUG("question: !result... should this happen?");
- return;
- }
-
- # update stats. old mysql/sqlite don't do +1
- my ($count) = &sqlSelect('factoids', 'requested_count', { factoid_key => $q });
- $count++;
- &sqlSet('factoids', {'factoid_key' => $q}, {
- requested_by => $nuh,
- requested_time => time(),
- requested_count => $count
- } );
-
- # end of update stats.
-
- $result = $r;
-
- $result =~ s/^\((.*?)\): //;
- my $vars = $1;
-
- # start nasty hack to get partial &getReply() functionality.
- $result = &SARit($result);
-
- foreach ( split(',', $vars) ) {
- my $val = $vals[$i];
-# &DEBUG("val => $val");
-
- if (!defined $val) {
- &status("factArgs: vals[$i] == undef; not SARing '$_' for '$str'");
- next;
- }
-
- my $done = 0;
- my $old = $result;
- while (1) {
-# &DEBUG("Q: result => $result (1before)");
- $result = &substVars($result,1);
-# &DEBUG("Q: result => $result (1after)");
-
- last if ($old eq $result);
- $old = $result;
- $done++;
- }
-
- # hack.
- $vals[$i] =~ s/^me$/$who/gi;
-
-# if (!$done) {
- &status("factArgs: SARing '$_' to '$vals[$i]'.");
- $result =~ s/\Q$_\E/$vals[$i]/g;
-# }
- $i++;
- }
-
- # rest of nasty hack to get partial &getReply() functionality.
- $result =~ s/^\s*<action>\s*(.*)/\cAACTION $1\cA/i;
- $result =~ s/^\s*<reply>\s*//i;
-
-# well... lets go through all of them. not advisable if we have like
-# 1000 commands, heh.
-# return $result;
- $cmdstats{'Factoid Commands'}++;
- }
-
- return $result;
-}
-
-1;
+++ /dev/null
-###
-### Reply.pl: Kevin Lenzo (c) 1997
-###
-
-##
-# x is y === $lhs $mhs $rhs
-#
-# lhs - factoid.
-# mhs - verb.
-# rhs - factoid message.
-##
-
-# use strict; # TODO
-use POSIX qw(strftime);
-
-use vars qw($msgType $uh $lastWho $ident);
-use vars qw(%lang %lastWho);
-
-sub getReply {
- my($message) = @_;
- my($lhs,$mhs,$rhs);
- my($reply, $count, $fauthor, $result, $factoid, $search, @searches);
- $orig{message} = $message;
-
- if (!defined $message or $message =~ /^\s*$/) {
- &WARN("getR: message == NULL.");
- return '';
- }
-
- $message =~ tr/A-Z/a-z/;
-
- @searches = split(/\s+/, &getChanConfDefault('factoidSearch', '_default', $chan));
- &::DEBUG("factoidSearch: $chan is: " . join(':', @searches));
- # requesting the _default one, ignore factoidSearch
- if ($message =~ /^_default\s+/) {
- @searches = ('_default');
- $message =~ s/^_default\s+//;
- }
-
- # check for factoids with each prefix
- foreach $search (@searches) {
- if ($search eq '$chan') {
- $factoid = "$chan $message";
- } elsif ($search eq '_default') {
- $factoid = $message;
- } else {
- $factoid = "$search $message";
- }
- ($count, $fauthor, $result) = &sqlSelect('factoids',
- "requested_count,created_by,factoid_value",
- { factoid_key => $factoid }
- );
- last if ($result);
- }
-
- if ($result) {
- $lhs = $message;
- $mhs = 'is';
- $rhs = $result;
-
- return "\"$factoid\" $mhs \"$rhs\"" if ($literal);
- } else {
- return '';
- }
-
- # if there was a head...
- my(@poss) = split '\|\|', $result;
- $poss[0] =~ s/^\s//;
- $poss[$#poss] =~ s/\s$//;
-
- if (@poss > 1) {
- $result = &getRandom(@poss);
- $result =~ s/^\s*//;
- }
-
- $result = &SARit($result);
-
- $reply = $result;
- if ($result ne '') {
- ### AT LAST, REPEAT PREVENTION CODE REMOVED IN FAVOUR OF GLOBAL
- ### FLOOD REPETION AND PROTECTION. -20000124
-
- # stats code.
- ### FIXME: old mysql/sqlite doesn't support
- ### "requested_count=requested_count+1".
- $count++;
- &sqlSet('factoids', {'factoid_key' => $factoid}, {
- requested_by => $nuh,
- requested_time => time(),
- requested_count => $count
- } );
-
- # TODO: rename $real to something else!
- my $real = 0;
-# my $author = &getFactInfo($lhs,'created_by') || '';
-# $real++ if ($author =~ /^\Q$who\E\!/);
-# $real++ if (&IsFlag('n'));
- $real = 0 if ($msgType =~ /public/);
-
- ### fix up the reply.
- # only remove '<reply>'
- if (!$real and $reply =~ s/^\s*<reply>\s*//i) {
- # 'are' fix.
- if ($reply =~ s/^are /$lhs are /i) {
- &VERB("Reply.pl: el-cheapo 'are' fix executed.",2);
- }
-
- } elsif (!$real and $reply =~ s/^\s*<action>\s*(.*)/\cAACTION $1\cA/i) {
- # only remove '<action>' and make it an action.
- } else { # not a short reply
-
- ### bot->bot reply.
- if (exists $bots{$nuh} and $rhs !~ /^\s*$/) {
- return "$lhs $mhs $rhs";
- }
-
- ### bot->person reply.
- # result is random if separated by '||'.
- # rhs is full factoid with '||'.
- if ($mhs eq 'is') {
- $reply = &getRandom(keys %{ $lang{'factoid'} });
- $reply =~ s/##KEY/$lhs/;
- $reply =~ s/##VALUE/$result/;
- } else {
- $reply = "$lhs $mhs $result";
- }
-
- if ($reply =~ s/^\Q$who\E is/you are/i) {
- # fix the person.
- } else {
- if ($reply =~ /^you are / or $reply =~ / you are /) {
- return if ($addressed);
- }
- }
- }
- }
-
- # remove excessive beginning and end whitespaces.
- $reply =~ s/^\s+|\s+$//g;
-
- if ($reply =~ /^\s+$/) {
- &DEBUG("Reply: Null factoid ($message)");
- return '';
- }
-
- return $reply unless ($reply =~ /\$/);
-
- ###
- ### $ SUBSTITUTION.
- ###
-
- # don't evaluate if it has factoid arguments.
-# if ($message =~ /^cmd:/i) {
-# &status("Reply: not doing substVars (eval dollar vars)");
-# } else {
- $reply = &substVars($reply,1);
-# }
-
- $reply;
-}
-
-sub smart_replace {
- my ($string) = @_;
- my ($l,$r) = (0,0); # l = left, r = right.
- my ($s,$t) = (0,0); # s = start, t = marker.
- my $i = 0;
- my $old = $string;
- my @rand;
-
- foreach (split //, $string) {
-
- if ($_ eq "(") {
- if (!$l and !$r) {
- $s = $i;
- $t = $i;
- }
-
- $l++;
- $r--;
- }
-
- if ($_ eq ")") {
- $r++;
- $l--;
-
- if (!$l and !$r) {
- my $substr = substr($old,$s,$i-$s+1);
- push(@rand, substr($old,$t+1,$i-$t-1) );
-
- my $rand = $rand[rand @rand];
-# &status("SARing '$substr' to '$rand'.");
- $string =~ s/\Q$substr\E/$rand/;
- undef @rand;
- }
- }
-
- if ($_ eq "|" and $l+$r== 0 and $l==1) {
- push(@rand, substr($old,$t+1,$i-$t-1) );
- $t = $i;
- }
-
- $i++;
- }
-
- if ($old eq $string) {
- &WARN("smart_replace: no subst made. (string => $string)");
- }
-
- return $string;
-}
-
-sub SARit {
- my($txt) = @_;
- my $done = 0;
-
- # (blah1|blah2)?
- while ($txt =~ /\((.*?)\)\?/) {
- my $str = $1;
- if (rand() > 0.5) { # fix.
- &status("Factoid transform: keeping '$str'.");
- $txt =~ s/\(\Q$str\E\)\?/$str/;
- } else { # remove
- &status("Factoid transform: removing '$str'.");
- $txt =~ s/\(\Q$str\E\)\?\s?//;
- }
- $done++;
- last if ($done >= 10); # just in case.
- }
- $done = 0;
-
- # EG: (0-32768) => 6325
- ### TODO: (1-10,20-30,40) => 24
- while ($txt =~ /\((\d+)-(\d+)\)/) {
- my ($lower,$upper) = ($1,$2);
- my $new = int(rand $upper-$lower) + $lower;
-
- &status("SARing '$&' to '$new' (2).");
- $txt =~ s/$&/$new/;
- $done++;
- last if ($done >= 10); # just in case.
- }
- $done = 0;
-
- # EG: (blah1|blah2|blah3|) => blah1
- while ($txt =~ /.*\((.*\|.*?)\).*/) {
- $txt = &smart_replace($txt);
-
- $done++;
- last if ($done >= 10); # just in case.
- }
- &status("Reply.pl: $done SARs done.") if ($done);
-
- # <URL></URL> type
- #
- while ($txt =~ /<URL>(.*)<\/URL>/){
- &status("we have to norm this <URL></URL> stuff, SARing");
- my $foobar = $1;
- if ($foobar =~ m/(http:\/\/[^?]+)\?(.*)/){
- my ($pig1,$pig2) = ($1,$2);
- &status("SARing using URLencode");
- $pig2=~s/([^\w])/sprintf("%%%02x",ord($1))/gie;
- $foobar=$pig1."?".$pig2;
- }
- $txt =~ s/<URL>(.*)<\/URL>/$foobar/;
- }
- return $txt;
-}
-
-sub substVars {
- my($reply,$flag) = @_;
-
- # $date, $time, $day.
- # TODO: support localtime.
- my $date = strftime("%Y.%m.%d", gmtime());
- $reply =~ s/\$date/$date/gi;
- my $time = strftime("%k:%M:%S", gmtime());
- $reply =~ s/\$time/$time/gi;
- my $day = strftime("%A", gmtime());
- $reply =~ s/\$day/$day/gi;
-
- # support $ident when I have multiple nicks
- my $mynick = $conn->nick() if $conn;
-
- # dollar variables.
- if ($flag) {
- $reply =~ s/\$nick/$who/g;
- $reply =~ s/\$who/$who/g; # backward compat.
- }
-
- if ($reply =~ /\$(user(name)?|host)/) {
- my ($username, $hostname) = split /\@/, $uh;
- $reply =~ s/\$user(name)?/$username/g;
- $reply =~ s/\$host(name)?/$hostname/g;
- }
- $reply =~ s/\$chan(nel)?/$talkchannel/g;
- if ($msgType =~ /public/) {
- $reply =~ s/\$lastspeaker/$lastWho{$talkchannel}/g;
- } else {
- $reply =~ s/\$lastspeaker/$lastWho/g;
- }
-
- if ($reply =~ /\$rand/) {
- my $rand = rand();
-
- # $randnick.
- if ($reply =~ /\$randnick/) {
- my @nicks = keys %{ $channels{$chan}{''} };
- my $randnick = $nicks[ int($rand*$#nicks) ];
- $reply =~ s/\$randnick/$randnick/g;
- }
-
- # eg: $rand100.3
- if ($reply =~ /\$rand(\d+)(\.(\d+))?/) {
- my $max = $1;
- my $dot = $3 || 0;
- my $orig = $&;
- #&DEBUG("dot => $dot, max => $max, rand=>$rand");
- $rand = sprintf("%.*f", $dot, $rand*$max);
-
- &DEBUG("swapping $orig to $rand");
- $reply =~ s/\Q$orig\E/$rand/eg;
- } else {
- $reply =~ s/\$rand/$rand/g;
- }
- }
-
- $reply =~ s/\$ident/$mynick/g;
-
- if ($reply =~ /\$startTime/) {
- my $time = scalar(gmtime $^T);
- $reply =~ s/\$startTime/$time/;
- }
-
- if ($reply =~ /\$uptime/) {
- my $uptime = &Time2String(time() - $^T);
- $reply =~ s/\$uptime/$uptime/;
- }
-
- if ($reply =~ /\$factoids/) {
- my $factoids = &countKeys('factoids');
- $reply =~ s/\$factoids/$factoids/;
- }
-
- if ($reply =~ /\$Fupdate/) {
- my $x = "\002$count{'Update'}\002 ".
- &fixPlural('modification', $count{'Update'});
- $reply =~ s/\$Fupdate/$x/;
- }
-
- if ($reply =~ /\$Fquestion/) {
- my $x = "\002$count{'Question'}\002 ".
- &fixPlural('question', $count{'Question'});
- $reply =~ s/\$Fquestion/$x/;
- }
-
- if ($reply =~ /\$Fdunno/) {
- my $x = "\002$count{'Dunno'}\002 ".
- &fixPlural('dunno', $count{'Dunno'});
- $reply =~ s/\$Fdunno/$x/;
- }
-
- $reply =~ s/\$memusage/$memusage/;
-
- return $reply;
-}
-
-1;
+++ /dev/null
-###
-### Statement.pl: Kevin Lenzo (c) 1997
-###
-
-##
-## doStatement --
-##
-## decide if $in is a statement, and if so,
-## - update the db
-## - return feedback statement
-##
-## otherwise return
-## - null for confused.
-##
-
-# use strict; # TODO
-
-sub doStatement {
- my($in) = @_;
-
- $in =~ s/\\(\S+)/\#$1\#/g; # fix the backslash.
- $in =~ s/^no([, ]+)//i; # 'no, '.
-
- # check if we need to be addressed and if we are
- return unless ($learnok);
-
- my($urlType) = '';
-
- # prefix www with http:// and ftp with ftp://
- $in =~ s/ www\./ http:\/\/www\./ig;
- $in =~ s/ ftp\./ ftp:\/\/ftp\./ig;
-
- $urlType = 'about' if ($in =~ /\babout:/i);
- $urlType = 'afp' if ($in =~ /\bafp:/);
- $urlType = 'file' if ($in =~ /\bfile:/);
- $urlType = 'palace' if ($in =~ /\bpalace:/);
- $urlType = 'phoneto' if ($in =~ /\bphone(to)?:/);
- if ($in =~ /\b(news|http|ftp|gopher|telnet):\s*\/\/[\-\w]+(\.[\-\w]+)+/) {
- $urlType = $1;
- }
-
- # acceptUrl.
- if (&IsParam('acceptUrl')) {
- if ($param{'acceptUrl'} eq 'REQUIRE') { # require url type.
- return if ($urlType eq '');
- } elsif ($param{'acceptUrl'} eq 'REJECT') {
- &status("REJECTED URL entry") if (&IsParam('VERBOSITY'));
- return unless ($urlType eq '');
- } else {
- # OPTIONAL
- }
- }
-
- # learn statement. '$lhs is|are $rhs'
- if ($in =~ /(^|\s)(is|are)(\s|$)/i) {
- my($lhs, $mhs, $rhs) = ($`, $&, $');
-
- # allows factoid arguments to be updated. -lear.
- $lhs =~ s/^(cmd: )?(.*)/$1||'' . lc $2/e;
-
- # discard article.
- $lhs =~ s/^(the|da|an?)\s+//i;
-
- # remove excessive initial and final whitespaces.
- $lhs =~ s/^\s+|\s+$//g;
- $mhs =~ s/^\s+|\s+$//g;
- $rhs =~ s/^\s+|\s+$//g;
-
- # break if either lhs or rhs is NULL.
- if ($lhs eq '' or $rhs eq '') {
- return "NOT-A-STATEMENT";
- }
-
- # lets check if it failed.
- if (&validFactoid($lhs,$rhs) == 0) {
- if ($addressed) {
- &status("IGNORE statement: <$who> $message");
- &performReply( &getRandom(keys %{ $lang{'confused'} }) );
- }
- return;
- }
-
- # uncomment to prevent HUNGRY learning of rhs with whitespace
- #return if (!$addressed and $lhs =~ /\s+/);
- &::DEBUG("doStatement: $in:$lhs:$mhs:$rhs");
-
- &status("statement: <$who> $message");
-
- # change "#*#" back to '*' because of '\' sar to '#blah#'.
- $lhs =~ s/\#(\S+)\#/$1/g;
- $rhs =~ s/\#(\S+)\#/$1/g;
-
- $lhs =~ s/\?+\s*$//; # strip off '?'.
-
- # verify the update statement whether there are any weird
- # characters.
- ### this can be simplified.
- foreach (split //, $lhs.$rhs) {
- my $ord = ord $_;
- if ($ord > 170 and $ord < 220) {
- &status("statement: illegal character '$_' $ord.");
- &performAddressedReply("i'm not going to learn illegal characters");
- return;
- }
- }
-
- # success.
- return if (&update($lhs, $mhs, $rhs));
- }
-
- return 'CONTINUE';
-}
-
-1;
+++ /dev/null
-#
-# Update.pl: Add or modify factoids in the db.
-# Author: Kevin Lenzo
-# dms
-# Version: 19991209
-# Created: 1997
-#
-
-# use strict; # TODO
-
-sub update {
- my($lhs, $mhs, $rhs) = @_;
-
- for ($lhs) {
- s/^i (heard|think) //i;
- s/^some(one|1|body) said //i;
- s/\s+/ /g;
- }
-
- # locked.
- return if (&IsLocked($lhs) == 1);
-
- # profanity.
- if (&IsParam('profanityCheck') and &hasProfanity($rhs)) {
- &performReply("please, watch your language.");
- return 1;
- }
-
- # teaching.
- if (&IsFlag('t') ne 't' && &IsFlag('o') ne 'o') {
- &msg($who, "permission denied.");
- &status("alert: $who wanted to teach me.");
- return 1;
- }
-
- # invalid verb.
- if ($mhs !~ /^(is|are)$/i) {
- &ERROR("UNKNOWN verb: $mhs.");
- return;
- }
-
- # check if the arguments are too long to be stored in our table.
- my $toolong = 0;
- $toolong++ if (length $lhs > $param{'maxKeySize'});
- $toolong++ if (length $rhs > $param{'maxDataSize'});
- if ($toolong) {
- &performAddressedReply("that's too long");
- return 1;
- }
-
- # also checking.
- my $also = ($rhs =~ s/^-?also //i);
- my $also_or = ($also and $rhs =~ s/\s+(or|\|\|)\s+//);
-
- # factoid arguments handler.
- # must start with a non-variable
- if (&IsChanConf('factoidArguments') > 0 and $lhs =~ /^[^\$]+.*\$/) {
- &status("Update: Factoid Arguments found.");
- &status("Update: orig lhs => '$lhs'.");
- &status("Update: orig rhs => '$rhs'.");
-
- my @list;
- my $count = 0;
- $lhs =~ s/^/cmd: /;
- while ($lhs =~ s/\$(\S+)/(.*?)/) {
- push(@list, "\$$1");
- $count++;
- last if ($count >= 10);
- }
-
- if ($count >= 10) {
- &msg($who, "error: could not SAR properly.");
- &DEBUG("error: lhs => '$lhs' rhs => '$rhs'.");
- return;
- }
-
- my $z = join(',',@list);
- $rhs =~ s/^/($z): /;
-
- &status("Update: new lhs => '$lhs' rhs => '$rhs'.");
- }
-
- # the fun begins.
- my $exists = &getFactoid($lhs);
-
- if (!$exists) {
- # nice 'are' hack (or work-around).
- if ($mhs =~ /^are$/i and $rhs !~ /<\S+>/) {
- &status("Update: 'are' hack detected.");
- $mhs = 'is';
- $rhs = "<REPLY> are ". $rhs;
- }
-
- &status("enter: <$who> \'$lhs\' =$mhs=> \'$rhs\'");
- $count{'Update'}++;
-
- &performAddressedReply('okay');
-
- &sqlInsert('factoids', {
- created_by => $nuh,
- created_time => time(), # modified time.
- factoid_key => $lhs,
- factoid_value => $rhs,
- } );
-
- if (!defined $rhs or $rhs eq '') {
- &ERROR("Update: rhs1 == NULL.");
- }
-
- return 1;
- }
-
- # factoid exists.
- if ($exists eq $rhs) {
- # this catches the following situation: (right or wrong?)
- # "test is test"
- # "test is also test"
- &performAddressedReply("i already had it that way");
- return 1;
- }
-
- if ($also) { # 'is also'.
- if ($exists =~ /^<REPLY> see /i) {
- &TODO("Update.pl: append to linked factoid.");
- }
-
- if ($also_or) { # 'is also ||'.
- $rhs = $exists.' || '.$rhs;
- } else {
-# if ($exists =~ s/\,\s*$/, /) {
- if ($exists =~ /\,\s*$/) {
- &DEBUG("current has trailing comma, just append as is");
- &DEBUG("Up: exists => $exists");
- &DEBUG("Up: rhs => $rhs");
- # $rhs =~ s/^\s+//;
- # $rhs = $exists." ".$rhs; # keep comma.
- }
-
- if ($exists =~ /\.\s*$/) {
- &DEBUG("current has trailing period, just append as is with 2 WS");
- &DEBUG("Up: exists => $exists");
- &DEBUG("Up: rhs => $rhs");
- # $rhs =~ s/^\s+//;
- # use ucfirst();?
- # $rhs = $exists." ".$rhs; # keep comma.
- }
-
- if ($rhs =~ /^[A-Z]/) {
- if ($rhs =~ /\w+\s*$/) {
- &status("auto insert period to factoid.");
- $rhs = $exists.". ".$rhs;
- } else { # '?' or '.' assumed at end.
- &status("orig factoid already had trailing symbol; not adding period.");
- $rhs = $exists." ".$rhs;
- }
- } elsif ($exists =~ /[\,\.\-]\s*$/) {
- &VERB("U: current has trailing symbols; inserting whitespace + new.",2);
- $rhs = $exists." ".$rhs;
- } elsif ($rhs =~ /^\./) {
- &VERB("U: new text has ^.; appending directly",2);
- $rhs = $exists.$rhs;
- } else {
- $rhs = $exists.', or '.$rhs;
- }
- }
-
- # max length check again.
- if (length $rhs > $param{'maxDataSize'}) {
- if (length $rhs > length $exists) {
- &performAddressedReply("that's too long");
- return 1;
- } else {
- &status("Update: new length is still longer than maxDataSize but less than before, we'll let it go.");
- }
- }
-
- &performAddressedReply('okay');
-
- $count{'Update'}++;
- &status("update: <$who> \'$lhs\' =$mhs=> \'$rhs\'; was \'$exists\'");
- &sqlSet('factoids', {'factoid_key' => $lhs}, {
- modified_by => $nuh,
- modified_time => time(),
- factoid_value => $rhs,
- } );
-
- if (!defined $rhs or $rhs eq '') {
- &ERROR("Update: rhs1 == NULL.");
- }
- } else { # not 'also'
-
- if (!$correction_plausible) { # "no, blah is ..."
- if ($addressed) {
- &performStrictReply("...but \002$lhs\002 is already something else...");
- &status("FAILED update: <$who> \'$lhs\' =$mhs=> \'$rhs\'");
- }
- return 1;
- }
-
- my $author = &getFactInfo($lhs, 'created_by') || '';
-
- if (IsFlag('m') ne 'm' && IsFlag('o') ne 'o' &&
- $author !~ /^\Q$who\E\!/i
- ) {
- &msg($who, "you can't change that factoid.");
- return 1;
- }
-
- &performAddressedReply('okay');
-
- $count{'Update'}++;
- &status("update: <$who> \'$lhs\' =$mhs=> \'$rhs\'; was \'$exists\'");
-
- &sqlSet('factoids', {'factoid_key' => $lhs}, {
- modified_by => $nuh,
- modified_time => time(),
- factoid_value => $rhs,
- } );
-
- if (!defined $rhs or $rhs eq '') {
- &ERROR("Update: rhs1 == NULL.");
- }
- }
-
- return 1;
-}
-
-1;
+++ /dev/null
-#
-# Files.pl: Open and close, read and probably write files.
-# Author: dms
-# Version: v0.3 (20010120)
-# Created: 19991221
-#
-
-use strict;
-
-use vars qw(%lang %ircPort);
-use vars qw(@ircServers);
-use vars qw($bot_config_dir);
-
-# File: Language support.
-sub loadLang {
- my ($file) = @_;
- my $langCount = 0;
- my $replyName;
-
- if (!open(FILE, $file)) {
- &ERROR("Failed reading lang file ($file): $!");
- exit 0;
- }
-
- undef %lang; # for rehash.
-
- while (<FILE>) {
- chop;
- if ($_ eq '' || /^#/) {
- undef $replyName;
- next;
- }
-
- if (!/^\s/) {
- $replyName = $_;
- next;
- }
-
- s/^[\s\t]+//g;
- if (!$replyName) {
- &status("loadLang: bad line ('$_')");
- next;
- }
-
- $lang{$replyName}{$_} = 1;
- $langCount++;
- }
- close FILE;
-
- $file =~ s/^.*\///;
- &status("Loaded $file ($langCount items)");
-}
-
-# File: Irc Servers list.
-sub loadIRCServers {
- my ($file) = $bot_config_dir."/blootbot.servers";
- @ircServers = ();
- %ircPort = ();
-
- if (!open(FILE, $file)) {
- &ERROR("Failed reading server list ($file): $!");
- exit 0;
- }
-
- while (<FILE>) {
- chop;
- next if /^\s*$/;
- next if /^[\#\[ ]/;
-
- if (/^(\S+)(:(\d+))?$/) {
- push(@ircServers,$1);
- $ircPort{$1} = ($3 || 6667);
- } else {
- &status("loadIRCServers: invalid line => '$_'.");
- }
- }
- close FILE;
-
- $file =~ s/^.*\///;
- &status("Loaded $file (". scalar(@ircServers) ." servers)");
-}
-
-1;
+++ /dev/null
-#
-# Irc.pl: IRC core stuff.
-# Author: dms
-# Version: 20000126
-# NOTE: Based on code by Kevin Lenzo & Patrick Cole (c) 1997
-#
-
-use strict;
-
-no strict 'refs';
-no strict 'subs'; # IN/STDIN
-
-use vars qw(%floodjoin %nuh %dcc %cache %conns %channels %param %mask
- %chanconf %orig %ircPort %ircstats %last %netsplit);
-use vars qw($irc $nickserv $conn $msgType $who $talkchannel
- $addressed $postprocess);
-use vars qw($notcount $nottime $notsize $msgcount $msgtime $msgsize
- $pubcount $pubtime $pubsize);
-use vars qw($b_blue $ob);
-use vars qw(@ircServers);
-
-#use open ':utf8';
-#use open ':std';
-
-$nickserv = 0;
-my $maxlinelen = 400;
-
-sub ircloop {
- my $error = 0;
- my $lastrun = 0;
-
-loop:;
- while (my $host = shift @ircServers) {
- # JUST IN CASE. irq was complaining about this.
- if ($lastrun == time()) {
- &DEBUG("ircloop: hrm... lastrun == time()");
- $error++;
- sleep 10;
- next;
- }
-
- if (!defined $host) {
- &DEBUG("ircloop: ircServers[x] = NULL.");
- $lastrun = time();
- next;
- }
- next unless (exists $ircPort{$host});
-
- my $retval = &irc($host, $ircPort{$host});
- next unless (defined $retval and $retval == 0);
- $error++;
-
- if ($error % 3 == 0 and $error != 0) {
- &status("IRC: Could not connect.");
- &status("IRC: ");
- next;
- }
-
- if ($error >= 3*2) {
- &status("IRC: cannot connect to any IRC servers; stopping.");
- &shutdown();
- exit 1;
- }
- }
-
- &status("IRC: ok, done one cycle of IRC servers; trying again.");
-
- &loadIRCServers();
- goto loop;
-}
-
-sub irc {
- my ($server,$port) = @_;
-
- $irc = new Net::IRC;
-
- # TODO: move all this to an sql table
- my $iaddr = inet_aton($server);
- my $paddr = sockaddr_in($port, $iaddr);
- my $proto = getprotobyname('tcp');
-
- # why was this here?
- #select STDOUT;
-
- # host->ip.
- my $resolve;
- if ($server =~ /\D$/) {
- my $packed = scalar(gethostbyname($server));
-
- if (!defined $packed) {
- &status(" cannot resolve $server.");
- return 0;
- }
-
- $resolve = inet_ntoa($packed);
- ### warning in Sys/Hostname line 78???
- ### caused inside Net::IRC?
- }
-
- my %args = (
- Nick => $param{'ircNick'},
- Server => $server,
- Port => $port,
- Ircname => $param{'ircName'},
- );
- $args{'LocalAddr'} = $param{'ircHost'} if ($param{'ircHost'});
- $args{'Password'} = $param{'ircPasswd'} if ($param{'ircPasswd'});
-
- foreach my $mynick (split ',', $param{'ircNick'}) {
- &status("Connecting to port $port of server $server ($resolve) as $mynick ...");
- $args{'Nick'} = $mynick;
- $conns{$mynick} = $irc->newconn(%args);
- if (!defined $conns{$mynick}) {
- &ERROR("IRC: connection failed.");
- &ERROR("add \"set ircHost 0.0.0.0\" to your config. If that does not work");
- &ERROR("Please check /etc/hosts to see if you have a localhost line like:");
- &ERROR("127.0.0.1 localhost localhost");
- &ERROR("If this is still a problem, please contact the maintainer.");
- }
- $conns{$mynick}->maxlinelen($maxlinelen);
- # handler stuff.
- $conns{$mynick}->add_global_handler('caction', \&on_action);
- $conns{$mynick}->add_global_handler('cdcc', \&on_dcc);
- $conns{$mynick}->add_global_handler('cping', \&on_ping);
- $conns{$mynick}->add_global_handler('crping', \&on_ping_reply);
- $conns{$mynick}->add_global_handler('cversion', \&on_version);
- $conns{$mynick}->add_global_handler('crversion', \&on_crversion);
- $conns{$mynick}->add_global_handler('dcc_open', \&on_dcc_open);
- $conns{$mynick}->add_global_handler('dcc_close', \&on_dcc_close);
- $conns{$mynick}->add_global_handler('chat', \&on_chat);
- $conns{$mynick}->add_global_handler('msg', \&on_msg);
- $conns{$mynick}->add_global_handler('public', \&on_public);
- $conns{$mynick}->add_global_handler('join', \&on_join);
- $conns{$mynick}->add_global_handler('part', \&on_part);
- $conns{$mynick}->add_global_handler('topic', \&on_topic);
- $conns{$mynick}->add_global_handler('invite', \&on_invite);
- $conns{$mynick}->add_global_handler('kick', \&on_kick);
- $conns{$mynick}->add_global_handler('mode', \&on_mode);
- $conns{$mynick}->add_global_handler('nick', \&on_nick);
- $conns{$mynick}->add_global_handler('quit', \&on_quit);
- $conns{$mynick}->add_global_handler('notice', \&on_notice);
- $conns{$mynick}->add_global_handler('whoischannels', \&on_whoischannels);
- $conns{$mynick}->add_global_handler('useronchannel', \&on_useronchannel);
- $conns{$mynick}->add_global_handler('whois', \&on_whois);
- $conns{$mynick}->add_global_handler('other', \&on_other);
- $conns{$mynick}->add_global_handler('disconnect', \&on_disconnect);
- $conns{$mynick}->add_global_handler([251,252,253,254,255], \&on_init);
-# $conns{$mynick}->add_global_handler(302, \&on_init); # userhost
- $conns{$mynick}->add_global_handler(303, \&on_ison); # notify.
- $conns{$mynick}->add_global_handler(315, \&on_endofwho);
- $conns{$mynick}->add_global_handler(422, \&on_endofwho); # nomotd.
- $conns{$mynick}->add_global_handler(324, \&on_modeis);
- $conns{$mynick}->add_global_handler(333, \&on_topicinfo);
- $conns{$mynick}->add_global_handler(352, \&on_who);
- $conns{$mynick}->add_global_handler(353, \&on_names);
- $conns{$mynick}->add_global_handler(366, \&on_endofnames);
- $conns{$mynick}->add_global_handler(376, \&on_endofmotd); # on_connect.
- $conns{$mynick}->add_global_handler(433, \&on_nick_taken);
- $conns{$mynick}->add_global_handler(439, \&on_targettoofast);
- # for proper joinnextChan behaviour
- $conns{$mynick}->add_global_handler(471, \&on_chanfull);
- $conns{$mynick}->add_global_handler(473, \&on_inviteonly);
- $conns{$mynick}->add_global_handler(474, \&on_banned);
- $conns{$mynick}->add_global_handler(475, \&on_badchankey);
- $conns{$mynick}->add_global_handler(443, \&on_useronchan);
- # end of handler stuff.
- }
-
- &clearIRCVars();
-
- # change internal timeout value for scheduler.
- $irc->{_timeout} = 10; # how about 60?
- # Net::IRC debugging.
- $irc->{_debug} = 1;
-
- $ircstats{'Server'} = "$server:$port";
-
- # works? needs to actually do something
- # should likely listen on a tcp port instead
- #$irc->addfh(STDIN, \&on_stdin, 'r');
-
- &status("starting main loop");
-
- $irc->start;
-}
-
-######################################################################
-######## IRC ALIASES IRC ALIASES IRC ALIASES IRC ALIASES #######
-######################################################################
-
-sub rawout {
- my ($buf) = @_;
- $buf =~ s/\n//gi;
-
- # slow down a bit if traffic is 'high'.
- # need to take into account time of last message sent.
- if ($last{buflen} > 256 and length($buf) > 256) {
- sleep 1;
- }
-
- $conn->sl($buf) if (&whatInterface() =~ /IRC/);
-
- $last{buflen} = length($buf);
-}
-
-sub say {
- my ($msg) = @_;
- my $mynick = $conn->nick();
- if (!defined $msg) {
- $msg ||= 'NULL';
- &WARN("say: msg == $msg.");
- return;
- }
-
- if (&getChanConf('silent', $talkchannel)) {
- &DEBUG("say: silent in $talkchannel, not saying $msg");
- return;
- }
-
- if ( $postprocess ) {
- undef $postprocess;
- } elsif ($postprocess = &getChanConf('postprocess', $talkchannel)) {
- &DEBUG("say: $postprocess $msg");
- &parseCmdHook($postprocess . ' ' . $msg);
- undef $postprocess;
- return;
- }
-
- &status("<$mynick/$talkchannel> $msg");
-
- return unless (&whatInterface() =~ /IRC/);
-
- $msg = 'zero' if ($msg =~ /^0+$/);
-
- my $t = time();
-
- if ($t == $pubtime) {
- $pubcount++;
- $pubsize += length $msg;
-
- my $i = &getChanConfDefault('sendPublicLimitLines', 3, $chan);
- my $j = &getChanConfDefault('sendPublicLimitBytes', 1000, $chan);
-
- if ( ($pubcount % $i) == 0 and $pubcount) {
- sleep 1;
- } elsif ($pubsize > $j) {
- sleep 1;
- $pubsize -= $j;
- }
-
- } else {
- $pubcount = 0;
- $pubtime = $t;
- $pubsize = length $msg;
- }
-
- $conn->privmsg($talkchannel, $msg);
-}
-
-sub msg {
- my ($nick, $msg) = @_;
- if (!defined $nick) {
- &ERROR("msg: nick == NULL.");
- return;
- }
-
- if (!defined $msg) {
- $msg ||= 'NULL';
- &WARN("msg: msg == $msg.");
- return;
- }
-
- # some say() end up here (eg +help)
- if (&getChanConf('silent', $nick)) {
- &DEBUG("msg: silent in $nick, not saying $msg");
- return;
- }
-
- &status(">$nick< $msg");
-
- return unless (&whatInterface() =~ /IRC/);
- my $t = time();
-
- if ($t == $msgtime) {
- $msgcount++;
- $msgsize += length $msg;
-
- my $i = &getChanConfDefault('sendPrivateLimitLines', 3, $chan);
- my $j = &getChanConfDefault('sendPrivateLimitBytes', 1000, $chan);
- if ( ($msgcount % $i) == 0 and $msgcount) {
- sleep 1;
- } elsif ($msgsize > $j) {
- sleep 1;
- $msgsize -= $j;
- }
-
- } else {
- $msgcount = 0;
- $msgtime = $t;
- $msgsize = length $msg;
- }
-
- $conn->privmsg($nick, $msg);
-}
-
-# Usage: &action(nick || chan, txt);
-sub action {
- my $mynick = $conn->nick();
- my ($target, $txt) = @_;
- if (!defined $txt) {
- &WARN("action: txt == NULL.");
- return;
- }
-
- if (&getChanConf('silent', $target)) {
- &DEBUG("action: silent in $target, not doing $txt");
- return;
- }
-
- if (length $txt > 480) {
- &status("action: txt too long; truncating.");
- chop($txt) while (length $txt > 480);
- }
-
- &status("* $mynick/$target $txt");
- $conn->me($target, $txt);
-}
-
-# Usage: ¬ice(nick || chan, txt);
-sub notice {
- my ($target, $txt) = @_;
- if (!defined $txt) {
- &WARN("notice: txt == NULL.");
- return;
- }
-
- &status("-$target- $txt");
-
- my $t = time();
-
- if ($t == $nottime) {
- $notcount++;
- $notsize += length $txt;
-
- my $i = &getChanConfDefault('sendNoticeLimitLines', 3, $chan);
- my $j = &getChanConfDefault('sendNoticeLimitBytes', 1000, $chan);
-
- if ( ($notcount % $i) == 0 and $notcount) {
- sleep 1;
- } elsif ($notsize > $j) {
- sleep 1;
- $notsize -= $j;
- }
-
- } else {
- $notcount = 0;
- $nottime = $t;
- $notsize = length $txt;
- }
-
- $conn->notice($target, $txt);
-}
-
-sub DCCBroadcast {
- my ($txt,$flag) = @_;
-
- ### FIXME: flag not supported yet.
-
- foreach (keys %{ $dcc{'CHAT'} }) {
- $conn->privmsg($dcc{'CHAT'}{$_}, $txt);
- }
-}
-
-##########
-### perform commands.
-###
-
-# Usage: &performReply($reply);
-sub performReply {
- my ($reply) = @_;
-
- if (!defined $reply or $reply =~ /^\s*$/) {
- &DEBUG("performReply: reply == NULL.");
- return;
- }
-
- $reply =~ /([\.\?\s]+)$/;
-
- # FIXME need real throttling....
- if (length($reply) > $maxlinelen - 30) {
- $reply = substr($reply, 0, $maxlinelen - 33);
- $reply =~ s/ [^ ]*?$/ .../;
- }
- &checkMsgType($reply);
-
- if ($msgType eq 'public') {
- if (rand() < 0.5 or $reply =~ /[\.\?]$/) {
- $reply = "$orig{who}: ".$reply;
- } else {
- $reply = "$reply, ".$orig{who};
- }
- &say($reply);
-
- } elsif ($msgType eq 'private') {
- if (rand() > 0.5) {
- $reply = "$reply, ".$orig{who};
- }
- &msg($who, $reply);
-
- } elsif ($msgType eq 'chat') {
- if (!exists $dcc{'CHAT'}{$who}) {
- &VERB("pSR: dcc{'CHAT'}{$who} does not exist.",2);
- return;
- }
- $conn->privmsg($dcc{'CHAT'}{$who}, $reply);
-
- } else {
- &ERROR("PR: msgType invalid? ($msgType).");
- }
-}
-
-# ...
-sub performAddressedReply {
- return unless ($addressed);
- &performReply(@_);
-}
-
-# Usage: &performStrictReply($reply);
-sub performStrictReply {
- my ($reply) = @_;
-
- # FIXME need real throttling....
- if (length($reply) > $maxlinelen - 30) {
- $reply = substr($reply, 0, $maxlinelen - 33);
- $reply =~ s/ [^ ]*?$/ .../;
- }
- &checkMsgType($reply);
-
- if ($msgType eq 'private') {
- &msg($who, $reply);
- } elsif ($msgType eq 'public') {
- &say($reply);
- } elsif ($msgType eq 'chat') {
- &dccsay(lc $who, $reply);
- } else {
- &ERROR("pSR: msgType invalid? ($msgType).");
- }
-}
-
-sub dccsay {
- my($who, $reply) = @_;
-
- if (!defined $reply or $reply =~ /^\s*$/) {
- &WARN("dccsay: reply == NULL.");
- return;
- }
-
- if (!exists $dcc{'CHAT'}{$who}) {
- &VERB("pSR: dcc{'CHAT'}{$who} does not exist. (2)",2);
- return;
- }
-
- &status("=>$who<= $reply"); # dcc chat.
- $conn->privmsg($dcc{'CHAT'}{$who}, $reply);
-}
-
-sub dcc_close {
- my($who) = @_;
- my $type;
-
- foreach $type (keys %dcc) {
- &FIXME("dcc_close: $who");
- my @who = grep /^\Q$who\E$/i, keys %{ $dcc{$type} };
- next unless (scalar @who);
- $who = $who[0];
- &DEBUG("dcc_close... close $who!");
- }
-}
-
-sub joinchan {
- my ($chan, $key) = @_;
- $key ||= &getChanConf('chankey', $chan);
- $key ||= '';
-
- # forgot for about 2 years to implement channel keys when moving
- # over to Net::IRC...
-
- # hopefully validChan is right.
- if (&validChan($chan)) {
- &status("join: already on $chan?");
- }
- #} else {
- &status("joining $b_blue$chan $key$ob");
-
- return if ($conn->join($chan, $key));
- return if (&validChan($chan));
-
- &DEBUG("joinchan: join failed. trying connect!");
- &clearIRCVars();
- $conn->connect();
- #}
-}
-
-sub part {
- my $chan;
-
- foreach $chan (@_) {
- next if ($chan eq '');
- $chan =~ tr/A-Z/a-z/; # lowercase.
-
- if ($chan !~ /^$mask{chan}$/) {
- &WARN("part: chan is invalid ($chan)");
- next;
- }
-
- &status("parting $chan");
- if (!&validChan($chan)) {
- &WARN("part: not on $chan; doing anyway");
-# next;
- }
-
- $conn->part($chan);
- # deletion of $channels{chan} is done in &entryEvt().
- }
-}
-
-sub mode {
- my ($chan, @modes) = @_;
- my $modes = join(" ", @modes);
-
- if (&validChan($chan) == 0) {
- &ERROR("mode: invalid chan => '$chan'.");
- return;
- }
-
- &DEBUG("mode: MODE $chan $modes");
-
- # should move to use Net::IRC's $conn->mode()... but too lazy.
- rawout("MODE $chan $modes");
-}
-
-sub op {
- my ($chan, @who) = @_;
- my $os = 'o' x scalar(@who);
-
- &mode($chan, "+$os @who");
-}
-
-sub deop {
- my ($chan, @who) = @_;
- my $os = 'o' x scalar(@who);
-
- &mode($chan, "-$os ".@who);
-}
-
-sub kick {
- my ($nick,$chan,$msg) = @_;
- my (@chans) = ($chan eq '') ? (keys %channels) : lc($chan);
- my $mynick = $conn->nick();
-
- if ($chan ne '' and &validChan($chan) == 0) {
- &ERROR("kick: invalid channel $chan.");
- return;
- }
-
- $nick =~ tr/A-Z/a-z/;
-
- foreach $chan (@chans) {
- if (!&IsNickInChan($nick,$chan)) {
- &status("kick: $nick is not on $chan.") if (scalar @chans == 1);
- next;
- }
-
- if (!exists $channels{$chan}{o}{$mynick}) {
- &status("kick: do not have ops on $chan :(");
- next;
- }
-
- &status("Kicking $nick from $chan.");
- $conn->kick($chan, $nick, $msg);
- }
-}
-
-sub ban {
- my ($mask,$chan) = @_;
- my (@chans) = ($chan =~ /^\*?$/) ? (keys %channels) : lc($chan);
- my $mynick = $conn->nick();
- my $ban = 0;
-
- if ($chan !~ /^\*?$/ and &validChan($chan) == 0) {
- &ERROR("ban: invalid channel $chan.");
- return;
- }
-
- foreach $chan (@chans) {
- if (!exists $channels{$chan}{o}{$mynick}) {
- &status("ban: do not have ops on $chan :(");
- next;
- }
-
- &status("Banning $mask from $chan.");
- &rawout("MODE $chan +b $mask");
- $ban++;
- }
-
- return $ban;
-}
-
-sub unban {
- my ($mask,$chan) = @_;
- my (@chans) = ($chan =~ /^\*?$/) ? (keys %channels) : lc($chan);
- my $mynick = $conn->nick();
- my $ban = 0;
-
- &DEBUG("unban: mask = $mask, chan = @chans");
-
- foreach $chan (@chans) {
- if (!exists $channels{$chan}{o}{$mynick}) {
- &status("unBan: do not have ops on $chan :(");
- next;
- }
-
- &status("Removed ban $mask from $chan.");
- &rawout("MODE $chan -b $mask");
- $ban++;
- }
-
- return $ban;
-}
-
-sub quit {
- my ($quitmsg) = @_;
- if (defined $conn) {
- &status("QUIT " . $conn->nick() . " has quit IRC ($quitmsg)");
- $conn->quit($quitmsg);
- } else {
- &WARN("quit: could not quit!");
- }
-}
-
-sub nick {
- my ($newnick) = @_;
- my $mynick = $conn->nick();
-
- if (!defined $newnick) {
- &ERROR("nick: nick == NULL.");
- return;
- }
-
- if (!defined $mynick) {
- &WARN("nick: mynick == NULL.");
- return;
- }
-
- my $bad = 0;
- $bad++ if (exists $nuh{$newnick});
- $bad++ if (&IsNickInAnyChan($newnick));
-
- if ($bad) {
- &WARN("Nick: not going to try to change from $mynick to $newnick. [". scalar(gmtime). "]");
- # hrm... over time we lose track of our own nick.
- #return;
- }
-
- if ($newnick =~ /^$mask{nick}$/) {
- &status("nick: Changing nick from $mynick to $newnick");
- # ->nick() will NOT change cause we are using rawout?
- &rawout("NICK $newnick");
- return 1;
- }
- &DEBUG("nick: failed... why oh why (mynick=$mynick, newnick=$newnick)");
- return 0;
-}
-
-sub invite {
- my($who, $chan) = @_;
- # TODO: check if $who or $chan are invalid.
-
- $conn->invite($who, $chan);
-}
-
-##########
-# Channel related functions...
-#
-
-# Usage: &joinNextChan();
-sub joinNextChan {
- my $joined = 0;
- foreach (sort keys %conns) {
- $conn = $conns{$_};
- my $mynick = $conn->nick();
- my @join = getJoinChans(1);
-
- if (scalar @join) {
- my $chan = shift @join;
- &joinchan($chan);
-
- if (my $i = scalar @join) {
- &status("joinNextChan: $mynick $i chans to join.");
- }
- $joined = 1;
- }
- }
- return if $joined;
-
- if (exists $cache{joinTime}) {
- my $delta = time() - $cache{joinTime} - 5;
- my $timestr = &Time2String($delta);
- # FIXME: @join should be @in instead (hacked to 10)
- #my $rate = sprintf("%.1f", $delta / @in);
- my $rate = sprintf("%.1f", $delta / 10);
- delete $cache{joinTime};
-
- &status("time taken to join all chans: $timestr; rate: $rate sec/join");
- }
-
- # chanserv check: global channels, in case we missed one.
- foreach ( &ChanConfList('chanServ_ops') ) {
- &chanServCheck($_);
- }
-}
-
-# Usage: &getNickInChans($nick);
-sub getNickInChans {
- my ($nick) = @_;
- my @array;
-
- foreach (keys %channels) {
- next unless (grep /^\Q$nick\E$/i, keys %{ $channels{$_}{''} });
- push(@array, $_);
- }
-
- return @array;
-}
-
-# Usage: &getNicksInChan($chan);
-sub getNicksInChan {
- my ($chan) = @_;
- my @array;
-
- return keys %{ $channels{$chan}{''} };
-}
-
-sub IsNickInChan {
- my ($nick,$chan) = @_;
-
- $chan =~ tr/A-Z/a-z/; # not lowercase unfortunately.
-
- if ($chan =~ /^$/) {
- &DEBUG("INIC: chan == NULL.");
- return 0;
- }
-
- if (&validChan($chan) == 0) {
- &ERROR("INIC: invalid channel $chan.");
- return 0;
- }
-
- if (grep /^\Q$nick\E$/i, keys %{ $channels{$chan}{''} }) {
- return 1;
- } else {
- foreach (keys %channels) {
- next unless (/[A-Z]/);
- &DEBUG("iNIC: hash channels contains mixed cased chan!!!");
- }
- return 0;
- }
-}
-
-sub IsNickInAnyChan {
- my ($nick) = @_;
- my $chan;
-
- foreach $chan (keys %channels) {
- next unless (grep /^\Q$nick\E$/i, keys %{ $channels{$chan}{''} });
- return 1;
- }
- return 0;
-}
-
-# Usage: &validChan($chan);
-sub validChan {
- # TODO: use $c instead?
- my ($chan) = @_;
-
- if (!defined $chan or $chan =~ /^\s*$/) {
- return 0;
- }
-
- if (lc $chan ne $chan) {
- &WARN("validChan: lc chan != chan. ($chan); fixing.");
- $chan =~ tr/A-Z/a-z/;
- }
-
- # it's possible that this check creates the hash if empty.
- if (defined $channels{$chan} or exists $channels{$chan}) {
- if ($chan =~ /^_?default$/) {
-# &WARN("validC: chan cannot be _default! returning 0!");
- return 0;
- }
-
- return 1;
- } else {
- return 0;
- }
-}
-
-###
-# Usage: &delUserInfo($nick,@chans);
-sub delUserInfo {
- my ($nick,@chans) = @_;
- my ($mode,$chan);
-
- foreach $chan (@chans) {
- foreach $mode (keys %{ $channels{$chan} }) {
- # use grep here?
- next unless (exists $channels{$chan}{$mode}{$nick});
-
- delete $channels{$chan}{$mode}{$nick};
- }
- }
-}
-
-sub clearChanVars {
- my ($chan) = @_;
-
- delete $channels{$chan};
-}
-
-sub clearIRCVars {
- undef %channels;
- undef %floodjoin;
-
- $cache{joinTime} = time();
-}
-
-sub getJoinChans {
- my($show) = @_;
-
- my @in;
- my @skip;
- my @join;
-
- # can't join any if not connected
- return @join if (!$conn);
-
- my $nick = $conn->nick();
-
- foreach (keys %chanconf) {
- next if ($_ eq '_default');
-
- my $skip = 0;
- my $val = $chanconf{$_}{autojoin};
-
- if (defined $val) {
- $skip++ if ($val eq '0');
- if ($val eq '1') {
- # convert old +autojoin to autojoin <nick>
- $val = lc $nick;
- $chanconf{$_}{autojoin} = $val;
- }
- $skip++ if (lc $val ne lc $nick);
- } else {
- $skip++;
- }
-
- if ($skip) {
- push(@skip, $_);
- } else {
- if (defined $channels{$_} or exists $channels{$_}) {
- push(@in, $_);
- } else {
- push(@join, $_);
- }
- }
- }
-
- my $str;
- #$str .= ' in:' . join(',', sort @in) if scalar @in;
- #$str .= ' skip:' . join(',', sort @skip) if scalar @skip;
- $str .= ' join:' . join(',', sort @join) if scalar @join;
-
- &status("Chans: ($nick)$str") if ($show);
-
- return sort @join;
-}
-
-sub closeDCC {
-# &DEBUG("closeDCC called.");
- my $type;
-
- foreach $type (keys %dcc) {
- next if ($type ne uc($type));
-
- my $nick;
- foreach $nick (keys %{ $dcc{$type} }) {
- next unless (defined $nick);
- &status("DCC CHAT: closing DCC $type to $nick.");
- next unless (defined $dcc{$type}{$nick});
-
- my $ref = $dcc{$type}{$nick};
- &dccsay($nick, "bye bye, $nick") if ($type =~ /^chat$/i);
- $dcc{$type}{$nick}->close();
- delete $dcc{$type}{$nick};
- &DEBUG("after close for $nick");
- }
- delete $dcc{$type};
- }
-}
-
-sub joinfloodCheck {
- my($who,$chan,$userhost) = @_;
-
- return unless (&IsChanConf('joinfloodCheck') > 0);
-
- if (exists $netsplit{lc $who}) { # netsplit join.
- &DEBUG("joinfloodCheck: $who was in netsplit; not checking.");
- }
-
- if (exists $floodjoin{$chan}{$who}{Time}) {
- &WARN("floodjoin{$chan}{$who} already exists?");
- }
-
- $floodjoin{$chan}{$who}{Time} = time();
- $floodjoin{$chan}{$who}{Host} = $userhost;
-
- ### Check...
- foreach (keys %floodjoin) {
- my $c = $_;
- my $count = scalar keys %{ $floodjoin{$c} };
- next unless ($count > 5);
- &DEBUG("joinflood: count => $count");
-
- my $time;
- foreach (keys %{ $floodjoin{$c} }) {
- my $t = $floodjoin{$c}{$_}{Time};
- next unless (defined $t);
-
- $time += $t;
- }
- &DEBUG("joinflood: time => $time");
- $time /= $count;
-
- &DEBUG("joinflood: new time => $time");
- }
-
- ### Clean it up.
- my $delete = 0;
- my $time = time();
- foreach $chan (keys %floodjoin) {
- foreach $who (keys %{ $floodjoin{$chan} }) {
- my $t = $floodjoin{$chan}{$who}{Time};
- next unless (defined $t);
-
- my $delta = $time - $t;
- next unless ($delta > 10);
-
- delete $floodjoin{$chan}{$who};
- $delete++;
- }
- }
-
- &DEBUG("joinfloodCheck: $delete deleted.") if ($delete);
-}
-
-sub getHostMask {
- my($n) = @_;
-
- if (exists $nuh{$n}) {
- return &makeHostMask($nuh{$n});
- } else {
- $cache{on_who_Hack} = 1;
- $conn->who($n);
- }
-}
-
-1;
+++ /dev/null
-#
-# IrcHooks.pl: IRC Hooks stuff.
-# Author: dms
-# Version: 20010413
-# Created: 20010413
-# NOTE: Based on code by Kevin Lenzo & Patrick Cole (c) 1997
-#
-
-#######################################################################
-####### IRC HOOK HELPERS IRC HOOK HELPERS IRC HOOK HELPERS ########
-#######################################################################
-
-#####
-# Usage: &hookMode($nick, $modes, @targets);
-sub hookMode {
- my ($nick, $modes, @targets) = @_;
- my $parity = 0;
-
- if ($chan =~ tr/A-Z/a-z/) {
- &VERB("hookMode: cased $chan.",2);
- }
-
- my $mode;
- foreach $mode (split(//, $modes)) {
- # sign.
- if ($mode =~ /[-+]/) {
- $parity = 1 if ($mode eq "+");
- $parity = 0 if ($mode eq "-");
- next;
- }
-
- # mode with target.
- if ($mode =~ /[bklov]/) {
- my $target = shift @targets;
-
- if ($parity) {
- $chanstats{$chan}{'Op'}++ if ($mode eq 'o');
- $chanstats{$chan}{'Ban'}++ if ($mode eq 'b');
- } else {
- $chanstats{$chan}{'Deop'}++ if ($mode eq 'o');
- $chanstats{$chan}{'Unban'}++ if ($mode eq 'b');
- }
-
- # modes w/ target affecting nick => cache it.
- if ($mode =~ /[bov]/) {
- $channels{$chan}{$mode}{$target}++ if $parity;
- delete $channels{$chan}{$mode}{$target} if !$parity;
-
- # lets do some custom stuff.
- if ($mode eq 'o' and $parity) {
- if ($nick eq 'ChanServ' and $target =~ /^\Q$ident\E$/i) {
- &VERB("hookmode: chanserv deopped us! asking",2);
- &chanServCheck($chan);
- }
-
- &chanLimitVerify($chan);
- }
- }
-
- if ($mode =~ /[l]/) {
- $channels{$chan}{$mode} = $target if $parity;
- delete $channels{$chan}{$mode} if !$parity;
- }
- }
-
- # important channel modes, targetless.
- if ($mode =~ /[mt]/) {
- $channels{$chan}{$mode}++ if $parity;
- delete $channels{$chan}{$mode} if !$parity;
- }
- }
-}
-
-sub hookMsg {
- ($msgType, $chan, $who, $message) = @_;
- my $skipmessage = 0;
- $addressed = 0;
- $addressedother = 0;
- $orig{message} = $message;
- $orig{who} = $who;
- $addrchar = 0;
-
- $message =~ s/[\cA-\c_]//ig; # strip control characters
- $message =~ s/^\s+//; # initial whitespaces.
- $who =~ tr/A-Z/a-z/; # lowercase.
- my $mynick = $conn->nick();
-
- &showProc();
-
- # addressing.
- if ($msgType =~ /private/) {
- # private messages.
- $addressed = 1;
- if (&IsChanConf('addressCharacter') > 0) {
- $addressCharacter = getChanConf('addressCharacter');
- if ($message =~ s/^\Q$addressCharacter\E//) {
- &msg($who, "The addressCharacter \"$addressCharacter\" is to get my attention in a normal channel. Please leave it off when messaging me directly.");
- }
- }
- } else {
- # public messages.
- # addressing revamped by the xk.
- ### below needs to be fixed...
- if (&IsChanConf('addressCharacter') > 0) {
- $addressCharacter = getChanConf('addressCharacter');
- if ($message =~ s/^\Q$addressCharacter\E//) {
- $addrchar = 1;
- $addressed = 1;
- }
- }
-
- if ($message =~ /^($mask{nick})([\;\:\>\, ]+) */) {
- my $newmessage = $';
- if ($1 =~ /^\Q$mynick\E$/i) {
- $message = $newmessage;
- $addressed = 1;
- } else {
- # ignore messages addressed to other people or unaddressed.
- $skipmessage++ if ($2 ne '' and $2 !~ /^ /);
- }
- }
- }
-
- # Determine floodwho.
- my $c = '_default';
- if ($msgType =~ /public/i) {
- # public.
- $floodwho = $c = lc $chan;
- } elsif ($msgType =~ /private/i) {
- # private.
- $floodwho = lc $who;
- } else {
- # dcc?
- &FIXME("floodwho = ???");
- }
-
- my $val = &getChanConfDefault('floodRepeat', "2:5", $c);
- my ($count, $interval) = split /:/, $val;
-
- # flood repeat protection.
- if ($addressed) {
- my $time = $flood{$floodwho}{$message} || 0;
-
- if (!&IsFlag('o') and $msgType eq 'public' and (time() - $time < $interval)) {
- ### public != personal who so the below is kind of pointless.
- my @who;
- foreach (keys %flood) {
- next if (/^\Q$floodwho\E$/);
- next if (defined $chan and /^\Q$chan\E$/);
-
- push(@who, grep /^\Q$message\E$/i, keys %{ $flood{$_} });
- }
-
- return if ($lobotomized);
-
- if (!scalar @who) {
- push(@who,'Someone');
- }
- &msg($who,join(' ', @who)." already said that ". (time - $time) ." seconds ago" );
-
- ### TODO: delete old floodwarn{} keys.
- my $floodwarn = 0;
- if (!exists $floodwarn{$floodwho}) {
- $floodwarn++;
- } else {
- $floodwarn++ if (time() - $floodwarn{$floodwho} > $interval);
- }
-
- if ($floodwarn) {
- &status("FLOOD repetition detected from $floodwho.");
- $floodwarn{$floodwho} = time();
- }
-
- return;
- }
-
- if ($addrchar) {
- &status("$b_cyan$who$ob is short-addressing $mynick");
- } elsif ($msgType eq 'private') { # private.
- &status("$b_cyan$who$ob is /msg'ing $mynick");
- } else { # public?
- &status("$b_cyan$who$ob is addressing $mynick");
- }
-
- $flood{$floodwho}{$message} = time();
- } elsif ($msgType eq 'public' and &IsChanConf('kickOnRepeat') > 0) {
- # unaddressed, public only.
-
- ### TODO: use a separate "short-time" hash.
- my @data;
- @data = keys %{ $flood{$floodwho} } if (exists $flood{$floodwho});
- }
-
- $val = &getChanConfDefault('floodMessages', "5:30", $c);
- ($count, $interval) = split /:/, $val;
-
- # flood overflow protection.
- if ($addressed) {
- foreach (keys %{ $flood{$floodwho} }) {
- next unless (time() - $flood{$floodwho}{$_} > $interval);
- delete $flood{$floodwho}{$_};
- }
-
- my $i = scalar keys %{ $flood{$floodwho} };
- if ($i > $count) {
- my $expire = $param{'ignoreAutoExpire'} || 5;
-
-# &msg($who,"overflow of messages ($i > $count)");
- &msg($who,"Too many queries from you, ignoring for $expire minutes.");
- &status("FLOOD overflow detected from $floodwho; ignoring");
-
- &ignoreAdd("*!$uh", $chan, $expire, "flood overflow auto-detected.");
- return;
- }
-
- $flood{$floodwho}{$message} = time();
- }
-
- my @ignore;
- if ($msgType =~ /public/i) { # public.
- $talkchannel = $chan;
- &status("<$orig{who}/$chan> $orig{message}");
- push(@ignore, keys %{ $ignore{$chan} }) if (exists $ignore{$chan});
- } elsif ($msgType =~ /private/i) { # private.
- &status("[$orig{who}] $orig{message}");
- $talkchannel = undef;
- $chan = '_default';
- } else {
- &DEBUG("unknown msgType => $msgType.");
- }
- push(@ignore, keys %{ $ignore{'*'} }) if (exists $ignore{'*'});
-
- if ((!$skipmessage or &IsChanConf('seenStoreAll') > 0) and
- &IsChanConf('sed') > 0 and &IsChanConf('seen') > 0 and
- $msgType =~ /public/ and
- $orig{message} =~ /^s\/([^;\/]*)\/([^;\/]*)\/([g]*)$/) {
- my $sedmsg = $seencache{$who}{'msg'};
- eval "\$sedmsg =~ s/\Q$1\E/\Q$2\E/$3;";
- $sedmsg =~ s/^(.{255}).*$/$1.../; # 255 char max to prevent flood
-
- if ($sedmsg ne $seencache{$who}{'msg'}) {
- &DEBUG("sed \"" . $orig{message} . "\" \"" .
- $seencache{$who}{'msg'} . "\" \"" . $sedmsg. "\"");
- &msg($talkchannel, "$orig{who} meant: $sedmsg");
- }
- } elsif ((!$skipmessage or &IsChanConf('seenStoreAll') > 0) and
- &IsChanConf('seen') > 0 and $msgType =~ /public/) {
- $seencache{$who}{'time'} = time();
- $seencache{$who}{'nick'} = $orig{who};
- $seencache{$who}{'host'} = $uh;
- $seencache{$who}{'chan'} = $talkchannel;
- $seencache{$who}{'msg'} = $orig{message};
- $seencache{$who}{'msgcount'}++;
- }
- if (&IsChanConf('minVolunteerLength') > 0) {
- # FIXME hack to treat unaddressed as if using addrchar
- $addrchar = 1;
- }
- return if ($skipmessage);
- return unless ($addrchar or $addressed);
-
- foreach (@ignore) {
- s/\*/\\S*/g;
-
- next unless (eval { $nuh =~ /^$_$/i } );
-
- # better to ignore an extra message than to allow one to get
- # through, although it would be better to go through ignore
- # checking again.
- if (time() - ($cache{ignoreCheckTime} || 0) > 60) {
- &ignoreCheck();
- }
-
- &status("IGNORE <$who> $message");
- return;
- }
-
- if (defined $nuh) {
- if (!defined $userHandle) {
- &DEBUG("line 1074: need verifyUser?");
- &verifyUser($who, $nuh);
- }
- } else {
- &DEBUG("hookMsg: 'nuh' not defined?");
- }
-
-### For extra debugging purposes...
- if ($_ = &process()) {
-# &DEBUG("IrcHooks: process returned '$_'.");
- }
-
- # hack to remove +o from ppl with +O flag.
- if (exists $users{$userHandle} && exists $users{$userHandle}{FLAGS} &&
- $users{$userHandle}{FLAGS} =~ /O/
- ) {
- $users{$userHandle}{FLAGS} =~ s/o//g;
- }
-
- return;
-}
-
-# this is basically run on on_join or on_quit
-sub chanLimitVerify {
- my($c) = @_;
- $chan = $c;
- my $l = $channels{$chan}{'l'};
-
- return unless (&IsChanConf('chanlimitcheck') > 0);
-
- if (scalar keys %netsplit) {
- &WARN("clV: netsplit active (1, chan = $chan); skipping.");
- return;
- }
-
- if (!defined $l) {
- &DEBUG("$chan: running chanlimitCheck from chanLimitVerify.");
- &chanlimitCheck();
- return;
- }
-
- # only change it if it's not set.
- my $plus = &getChanConfDefault('chanlimitcheckPlus', 5, $chan);
- my $count = scalar(keys %{ $channels{$chan}{''} });
- my $int = &getChanConfDefault('chanlimitcheckInterval', 10, $chan);
-
- my $delta = $count + $plus - $l;
-# $delta =~ s/^\-//;
-
- if ($plus <= 3) {
- &WARN("clc: stupid to have plus at $plus, fix it!");
- }
-
- if (exists $cache{chanlimitChange}{$chan}) {
- if (time() - $cache{chanlimitChange}{$chan} < $int*60) {
- return;
- }
- }
-
- &chanServCheck($chan);
-
- ### TODO: unify code with chanlimitcheck()
- return if ($delta > 5);
-
- &status("clc: big change in limit for $chan ($delta);".
- "going for it. (was: $l; now: ".($count+$plus).")");
-
- $conn->mode($chan, "+l", $count+$plus);
- $cache{chanlimitChange}{$chan} = time();
-}
-
-sub chanServCheck {
- ($chan) = @_;
-
- if (!defined $chan or $chan =~ /^\s*$/) {
- &WARN("chanServCheck: chan == NULL.");
- return 0;
- }
-
- if ($chan =~ tr/A-Z/a-z/) {
- &DEBUG("chanServCheck: lowercased chan ($chan)");
- }
-
- if (! &IsChanConf('chanServ_ops') > 0) {
- return 0;
- }
-
- &VERB("chanServCheck($chan) called.",2);
-
- if ( &IsParam('nickServ_pass') and !$nickserv) {
- $conn->who('NickServ');
- return 0;
- }
-
- # check for first hash then for next hash.
- # TODO: a function for &ischanop()? &isvoice()?
- if (exists $channels{$chan} and exists $channels{$chan}{'o'}{$ident}) {
- return 0;
- }
-
- &status("ChanServ ==> Requesting ops for $chan. (chanServCheck)");
- &rawout("PRIVMSG ChanServ :OP $chan $ident");
- return 1;
-}
-
-1;
+++ /dev/null
-#
-# IrcHooks.pl: IRC Hooks stuff.
-# Author: dms
-# Version: 20000126
-# NOTE: Based on code by Kevin Lenzo & Patrick Cole (c) 1997
-#
-use vars qw(%chanconf);
-
-# GENERIC. TO COPY.
-sub on_generic {
- $conn = shift(@_);
- my ($event) = @_;
- my $nick = $event->nick();
- my $chan = ($event->to)[0];
-
- &DEBUG("on_generic: nick => '$nick'.");
- &DEBUG("on_generic: chan => '$chan'.");
-
- foreach ($event->args) {
- &DEBUG("on_generic: args => '$_'.");
- }
-}
-
-sub on_action {
- $conn = shift(@_);
- my ($event) = @_;
- my ($nick, @args) = ($event->nick, $event->args);
- my $chan = ($event->to)[0];
-
- shift @args;
-
- if ($chan eq $ident) {
- &status("* [$nick] @args");
- } else {
- &status("* $nick/$chan @args");
- }
-}
-
-sub on_chat {
- $conn = shift(@_);
- my ($event) = @_;
- my $msg = ($event->args)[0];
- my $sock = ($event->to)[0];
- my $nick = lc $event->nick();
-
- if (!exists $nuh{$nick}) {
- &DEBUG("chat: nuh{$nick} doesn't exist; trying WHOIS .");
- $conn->whois($nick);
- return;
- }
-
- ### set vars that would have been set in hookMsg.
- $userHandle = ''; # reset.
- $who = lc $nick;
- $message = $msg;
- $orig{who} = $nick;
- $orig{message} = $msg;
- $nuh = $nuh{$who};
- $uh = (split /\!/, $nuh)[1];
- $h = (split /\@/, $uh)[1];
- $addressed = 1;
- $msgType = 'chat';
-
- if (!exists $dcc{'CHATvrfy'}{$nick}) {
- $userHandle = &verifyUser($who, $nuh);
- my $crypto = $users{$userHandle}{PASS};
- my $success = 0;
-
- if ($userHandle eq '_default') {
- &WARN("DCC CHAT: _default/guest not allowed.");
- return;
- }
-
- ### TODO: prevent users without CRYPT chatting.
- if (!defined $crypto) {
- &TODO("dcc close chat");
- &msg($who, "nope, no guest logins allowed...");
- return;
- }
-
- if (&ckpasswd($msg, $crypto)) {
- # stolen from eggdrop.
- $conn->privmsg($sock, "Connected to $ident");
- $conn->privmsg($sock, "Commands start with '.' (like '.quit' or '.help')");
- $conn->privmsg($sock, "Everything else goes out to the party line.");
-
- &dccStatus(2) unless (exists $sched{'dccStatus'}{RUNNING});
-
- $success++;
-
- } else {
- &status("DCC CHAT: incorrect pass; closing connection.");
- &DEBUG("chat: sock => '$sock'.");
-### $sock->close();
- delete $dcc{'CHAT'}{$nick};
- &FIXME("chat: after closing sock.");
- ### BUG: close seizes bot. why?
- }
-
- if ($success) {
- &status("DCC CHAT: user $nick is here!");
- &DCCBroadcast("*** $nick ($uh) joined the party line.");
-
- $dcc{'CHATvrfy'}{$nick} = $userHandle;
-
- return if ($userHandle eq '_default');
-
- &dccsay($nick,"Flags: $users{$userHandle}{FLAGS}");
- }
-
- return;
- }
-
- &status("$b_red=$b_cyan$who$b_red=$ob $message");
-
- if ($message =~ s/^\.//) { # dcc chat commands.
- ### TODO: make use of &Forker(); here?
- &loadMyModule('UserDCC');
-
- &DCCBroadcast("#$who# $message",'m');
-
- my $retval = &userDCC();
- return unless (defined $retval);
- return if ($retval eq $noreply);
-
- $conn->privmsg($dcc{'CHAT'}{$who}, "Invalid command.");
-
- } else { # dcc chat arena.
-
- foreach (keys %{ $dcc{'CHAT'} }) {
- $conn->privmsg($dcc{'CHAT'}{$_}, "<$who> $orig{message}");
- }
- }
-
- return 'DCC CHAT MESSAGE';
-}
-
-# is there isoff? how do we know if someone signs off?
-sub on_ison {
- $conn = shift(@_);
- my ($event) = @_;
- my $x1 = ($event->args)[0];
- my $x2 = ($event->args)[1];
- $x2 =~ s/\s$//;
-
- &DEBUG("on_ison: x1 = '$x1', x2 => '$x2'");
-}
-
-sub on_endofmotd {
- $conn = shift(@_);
-
- # update IRCStats.
- $ident = $conn->nick();
- $ircstats{'ConnectTime'} = time();
- $ircstats{'ConnectCount'}++;
- if (defined $ircstats{'DisconnectTime'}) {
- $ircstats{'OffTime'} += time() - $ircstats{'DisconnectTime'};
- }
-
- # first time run.
- if (!exists $users{_default}) {
- &status("!!! First time run... adding _default user.");
- $users{_default}{FLAGS} = 'amrt';
- $users{_default}{HOSTS}{"*!*@*"} = 1;
- }
-
- if (scalar keys %users < 2) {
- &status("!"x40);
- &status("!!! Ok. Now type '/msg $ident PASS <pass>' to get master access through DCC CHAT.");
- &status("!"x40);
- }
- # end of first time run.
-
- if (&IsChanConf('Wingate') > 0) {
- my $file = "$bot_base_dir/$param{'ircUser'}.wingate";
- open(IN, $file);
- while (<IN>) {
- chop;
- next unless (/^(\S+)\*$/);
- push(@wingateBad, $_);
- }
- close IN;
- }
-
- if ($firsttime) {
- &ScheduleThis(1, 'setupSchedulers');
- $firsttime = 0;
- }
-
- if (&IsParam('ircUMode')) {
- &VERB("Attempting change of user modes to $param{'ircUMode'}.", 2);
- if ($param{'ircUMode'} !~ /^[-+]/) {
- &WARN("ircUMode had no +- prefix; adding +");
- $param{'ircUMode'} = "+".$param{'ircUMode'};
- }
-
- &rawout("MODE $ident $param{'ircUMode'}");
- }
-
- # ok, we're free to do whatever we want now. go for it!
- $running = 1;
-
- # add ourself to notify.
- $conn->ison($conn->nick());
-
- # Q, as on quakenet.org.
- if (&IsParam('Q_pass')) {
- &status("Authing to Q...");
- &rawout("PRIVMSG Q\@CServe.quakenet.org :AUTH $param{'Q_user'} $param{'Q_pass'}");
- }
-
- &status("End of motd. Now lets join some channels...");
- #&joinNextChan();
-}
-
-sub on_endofwho {
- $conn = shift(@_);
- my ($event) = @_;
-# &DEBUG("endofwho: chan => $chan");
- $chan ||= ($event->args)[1];
-# &DEBUG("endofwho: chan => $chan");
-
- if (exists $cache{countryStats}) {
- &do_countrystats();
- }
-}
-
-sub on_dcc {
- $conn = shift(@_);
- my ($event) = @_;
- my $type = uc( ($event->args)[1] );
- my $nick = lc $event->nick();
-
- &status("on_dcc type=$type nick=$nick sock=$sock");
-
- # pity Net::IRC doesn't store nuh. Here's a hack :)
- if (!exists $nuh{lc $nick}) {
- $conn->whois($nick);
- $nuh{$nick} = "GETTING-NOW"; # trying.
- }
- $type ||= "???";
-
- if ($type eq 'SEND') { # GET for us.
- # incoming DCC SEND. we're receiving a file.
- my $get = ($event->args)[2];
- &status("DCC: not Initializing GET from $nick to '$param{tempDir}/$get'");
- # FIXME: do we want to get anything?
- return;
- #open(DCCGET,">$param{tempDir}/$get");
- #$conn->new_get($event, \*DCCGET);
-
- } elsif ($type eq 'GET') { # SEND for us?
- &status("DCC: not Initializing SEND for $nick.");
- # FIXME: do we want to do anything?
- return;
- $conn->new_send($event->args);
-
- } elsif ($type eq 'CHAT') {
- &status("DCC: Initializing CHAT for $nick.");
- $conn->new_chat($event);
-# $conn->new_chat(1, $nick, $event->host);
-
- } else {
- &WARN("${b_green}DCC $type$ob (1)");
- }
-}
-
-sub on_dcc_close {
- $conn = shift(@_);
- my ($event) = @_;
- my $nick = $event->nick();
- my $sock = ($event->to)[0];
-
- # DCC CHAT close on fork exit workaround.
- if ($bot_pid != $$) {
- &WARN("run-away fork; exiting.");
- &delForked($forker);
- }
-
- if (exists $dcc{'SEND'}{$nick} and -f "$param{tempDir}/$nick.txt") {
- &status("${b_green}DCC SEND$ob close from $b_cyan$nick$ob");
-
- &status("dcc_close: purging DCC send $nick.txt");
- unlink "$param{tempDir}/$nick.txt";
-
- delete $dcc{'SEND'}{$nick};
- } elsif (exists $dcc{'CHAT'}{$nick} and $dcc{'CHAT'}{$nick} eq $sock) {
- &status("${b_green}DCC CHAT$ob close from $b_cyan$nick$ob");
- delete $dcc{'CHAT'}{$nick};
- delete $dcc{'CHATvrfy'}{$nick};
- } else {
- &status("${b_green}DCC$ob UNKNOWN close from $b_cyan$nick$ob (2)");
- }
-}
-
-sub on_dcc_open {
- $conn = shift(@_);
- my ($event) = @_;
- my $type = uc( ($event->args)[0] );
- my $nick = lc $event->nick();
- my $sock = ($event->to)[0];
-
- &status("on_dcc_open type=$type nick=$nick sock=$sock");
-
- $msgType = 'chat';
- $type ||= "???";
- ### BUG: who is set to bot's nick?
-
- # lets do it.
- if ($type eq 'SEND') {
- &status("${b_green}DCC lGET$ob established with $b_cyan$nick$ob");
-
- } elsif ($type eq 'CHAT') {
- # very cheap hack.
- ### TODO: run ScheduleThis inside on_dcc_open_chat recursively
- ### 1,3,5,10 seconds then fail.
- if ($nuh{$nick} eq "GETTING-NOW") {
- &ScheduleThis(3/60, 'on_dcc_open_chat', $nick, $sock);
- } else {
- on_dcc_open_chat(undef, $nick, $sock);
- }
-
- } elsif ($type eq 'SEND') {
- &status("Starting DCC receive.");
- foreach ($event->args) {
- &status(" => '$_'.");
- }
-
- } else {
- &WARN("${b_green}DCC $type$ob (3)");
- }
-}
-
-# really custom sub to get NUH since Net::IRC doesn't appear to support
-# it.
-sub on_dcc_open_chat {
- my(undef, $nick, $sock) = @_;
-
- if ($nuh{$nick} eq "GETTING-NOW") {
- &FIXME("getting nuh for $nick failed.");
- return;
- }
-
- &status("${b_green}DCC CHAT$ob established with $b_cyan$nick$ob $b_yellow($ob$nuh{$nick}$b_yellow)$ob");
-
- &verifyUser($nick, $nuh{lc $nick});
-
- if (!exists $users{$userHandle}{HOSTS}) {
- &performStrictReply("you have no hosts defined in my user file; rejecting.");
- $sock->close();
- return;
- }
-
- my $crypto = $users{$userHandle}{PASS};
- $dcc{'CHAT'}{$nick} = $sock;
-
- # TODO: don't make DCC CHAT established in the first place.
- if ($userHandle eq '_default') {
- &dccsay($nick, "_default/guest not allowed");
- $sock->close();
- return;
- }
-
- if (defined $crypto) {
- &status("DCC CHAT: going to use ".$nick."'s crypt.");
- &dccsay($nick,"Enter your password.");
- } else {
-# &dccsay($nick,"Welcome to blootbot DCC CHAT interface, $userHandle.");
- }
-}
-
-sub on_disconnect {
- $conn = shift(@_);
- my ($event) = @_;
- my $from = $event->from();
- my $what = ($event->args)[0];
- my $mynick=$conn->nick();
-
- &status("$mynick disconnect from $from ($what).");
- $ircstats{'DisconnectTime'} = time();
- $ircstats{'DisconnectReason'} = $what;
- $ircstats{'DisconnectCount'}++;
- $ircstats{'TotalTime'} += time() - $ircstats{'ConnectTime'}
- if ($ircstats{'ConnectTime'});
-
- # clear any variables on reconnection.
- $nickserv = 0;
-
- &clearIRCVars();
-
- if (!defined $conn) {
- &WARN("on_disconnect: self is undefined! WTF");
- &DEBUG("running function irc... lets hope this works.");
- &irc();
- return;
- }
-
- &WARN("scheduling call ircCheck() in 60s");
- &clearIRCVars();
- &ScheduleThis(1, 'ircCheck');
-}
-
-sub on_endofnames {
- $conn = shift(@_);
- my ($event) = @_;
- my $chan = ($event->args)[1];
-
- # sync time should be done in on_endofwho like in BitchX
- if (exists $cache{jointime}{$chan}) {
- my $delta_time = sprintf("%.03f", &timedelta($cache{jointime}{$chan}) );
- $delta_time = 0 if ($delta_time <= 0);
- if ($delta_time > 100) {
- &WARN("endofnames: delta_time > 100 ($delta_time)");
- }
-
- &status("$b_blue$chan$ob: sync in ${delta_time}s.");
- }
-
- $conn->mode($chan);
-
- my $txt;
- my @array;
- foreach ('o','v','') {
- my $count = scalar(keys %{ $channels{$chan}{$_} });
- next unless ($count);
-
- $txt = 'total' if ($_ eq '');
- $txt = 'voice' if ($_ eq 'v');
- $txt = 'ops' if ($_ eq 'o');
-
- push(@array, "$count $txt");
- }
- my $chanstats = join(' || ', @array);
- &status("$b_blue$chan$ob: [$chanstats]");
-
- &chanServCheck($chan);
- # schedule used to solve ircu (OPN) "target too fast" problems.
- $conn->schedule(5, sub { &joinNextChan(); } );
-}
-
-sub on_init {
- $conn = shift(@_);
- my ($event) = @_;
- my (@args) = ($event->args);
- shift @args;
-
- &status("@args");
-}
-
-sub on_invite {
- $conn = shift(@_);
- my ($event) = @_;
- my $chan = lc( ($event->args)[0] );
- my $nick = $event->nick;
-
- if ($nick =~ /^\Q$ident\E$/) {
- &DEBUG("on_invite: self invite.");
- return;
- }
-
- ### TODO: join key.
- if (exists $chanconf{$chan}) {
- # it's still buggy :/
- if (&validChan($chan)) {
- &msg($who, "i'm already in \002$chan\002.");
-# return;
- }
-
- &status("invited to $b_blue$chan$ob by $b_cyan$nick$ob");
- &joinchan($chan);
- }
-}
-
-sub on_join {
- $conn = shift(@_);
- my ($event) = @_;
- my ($user,$host) = split(/\@/, $event->userhost);
- $chan = lc( ($event->to)[0] ); # CASING!!!!
- $who = $event->nick();
- $msgType = 'public';
- my $i = scalar(keys %{ $channels{$chan} });
- my $j = $cache{maxpeeps}{$chan} || 0;
-
- if (!&IsParam('noSHM') && time() > ($sched{shmFlush}{TIME} || time()) + 3600) {
- &DEBUG("looks like schedulers died somewhere... restarting...");
- &setupSchedulers();
- }
-
- $chanstats{$chan}{'Join'}++;
- $userstats{lc $who}{'Join'} = time() if (&IsChanConf('seenStats') > 0);
- $cache{maxpeeps}{$chan} = $i if ($i > $j);
-
- &joinfloodCheck($who, $chan, $event->userhost);
-
- # netjoin detection.
- my $netsplit = 0;
- if (exists $netsplit{lc $who}) {
- delete $netsplit{lc $who};
- $netsplit = 1;
-
- if (!scalar keys %netsplit) {
- &DEBUG("on_join: netsplit hash is now empty!");
- undef %netsplitservers;
- &netsplitCheck(); # any point in running this?
- &chanlimitCheck();
- }
- }
-
- if ($netsplit and !exists $cache{netsplit}) {
- &VERB("on_join: ok.... re-running chanlimitCheck in 60.",2);
- $conn->schedule(60, sub {
- &chanlimitCheck();
- delete $cache{netsplit};
- } );
-
- $cache{netsplit} = time();
- }
-
- # how to tell if there's a netjoin???
-
- my $netsplitstr = '';
- $netsplitstr = " $b_yellow\[${ob}NETSPLIT VICTIM$b_yellow]$ob" if ($netsplit);
- &status(">>> join/$b_blue$chan$ob $b_cyan$who$ob $b_yellow($ob$user\@$host$b_yellow)$ob$netsplitstr");
-
- $channels{$chan}{''}{$who}++;
- $nuh = $who."!".$user."\@".$host;
- $nuh{lc $who} = $nuh unless (exists $nuh{lc $who});
-
- ### on-join bans.
- my @bans;
- push(@bans, keys %{ $bans{$chan} }) if (exists $bans{$chan});
- push(@bans, keys %{ $bans{'*'} }) if (exists $bans{'*'});
-
- foreach (@bans) {
- my $ban = $_;
- s/\?/./g;
- s/\*/\\S*/g;
- my $mask = $_;
- next unless ($nuh =~ /^$mask$/i);
-
- ### TODO: check $channels{$chan}{'b'} if ban already exists.
- foreach (keys %{ $channels{$chan}{'b'} }) {
- &DEBUG(" bans_on_chan($chan) => $_");
- }
-
- my $reason = "no reason";
- foreach ($chan, '*') {
- next unless (exists $bans{$_});
- next unless (exists $bans{$_}{$ban});
-
- my @array = @{ $bans{$_}{$ban} };
-
- $reason = $array[4] if ($array[4]);
- last;
- }
-
- &ban($ban, $chan);
- &kick($who, $chan, $reason);
-
- last;
- }
-
- # no need to go further.
- return if ($netsplit);
-
- # who == bot.
- if ($who =~ /^\Q$ident\E$/i) {
- if (defined( my $whojoin = $cache{join}{$chan} )) {
- &msg($chan, "Okay, I'm here. (courtesy of $whojoin)");
- delete $cache{join}{$chan};
- &joinNextChan(); # hack.
- }
-
- ### TODO: move this to &joinchan()?
- $cache{jointime}{$chan} = &timeget();
- $conn->who($chan);
-
- return;
- }
-
- ### ROOTWARN:
- &rootWarn($who,$user,$host,$chan) if (
- &IsChanConf('RootWarn') > 0 &&
- $user =~ /^~?r(oo|ew|00)t$/i
- );
-
- ### emit a message based on who just joined
- &onjoin($who,$user,$host,$chan) if (&IsChanConf('OnJoin') > 0);
-
- ### NEWS:
- if (&IsChanConf('News') > 0 && &IsChanConf('newsKeepRead') > 0) {
- if (!&loadMyModule('News')) { # just in case.
- &DEBUG('could not load news.');
- } else {
- &News::latest($chan);
- }
- }
-
- ### botmail:
- if (&IsChanConf('botmail') > 0) {
- &botmail::check(lc $who);
- }
-
- ### wingate:
- &wingateCheck();
-}
-
-sub on_kick {
- $conn = shift(@_);
- my ($event) = @_;
- my ($chan,$reason) = $event->args;
- my $kicker = $event->nick;
- my $kickee = ($event->to)[0];
- my $uh = $event->userhost();
-
- &status(">>> kick/$b_blue$chan$ob [$b$kickee!$uh$ob] by $b_cyan$kicker$ob $b_yellow($ob$reason$b_yellow)$ob");
-
- $chan = lc $chan; # forgot about this, found by xsdg, 20001229.
- $chanstats{$chan}{'Kick'}++;
-
- if ($kickee eq $ident) {
- &clearChanVars($chan);
-
- &status("SELF attempting to rejoin lost channel $chan");
- &joinchan($chan);
- } else {
- &delUserInfo($kickee,$chan);
- }
-}
-
-sub on_mode {
- $conn = shift(@_);
- my ($event) = @_;
- my ($user, $host) = split(/\@/, $event->userhost);
- my @args = $event->args();
- my $nick = $event->nick();
- $chan = ($event->to)[0];
-
- # last element is empty... so nuke it.
- pop @args while ($args[$#args] eq '');
-
- if ($nick eq $chan) { # UMODE
- &status(">>> mode $b_yellow\[$ob$b@args$b_yellow\]$ob by $b_cyan$nick$ob");
- } else { # MODE
- &status(">>> mode/$b_blue$chan$ob $b_yellow\[$ob$b@args$b_yellow\]$ob by $b_cyan$nick$ob");
- &hookMode($nick, @args);
- }
-}
-
-sub on_modeis {
- $conn = shift(@_);
- my ($event) = @_;
- my ($myself, undef,@args) = $event->args();
- my $nick = $event->nick();
- $chan = ($event->args())[1];
-
- &hookMode($nick, @args);
-}
-
-sub on_msg {
- $conn = shift(@_);
- my ($event) = @_;
- my $nick = $event->nick;
- my $msg = ($event->args)[0];
-
- ($user,$host) = split(/\@/, $event->userhost);
- $uh = $event->userhost();
- $nuh = $nick."!".$uh;
- $msgtime = time();
- $h = $host;
-
- if ($nick eq $ident) { # hopefully ourselves.
- if ($msg eq 'TEST') {
- &status("IRCTEST: Yes, we're alive.");
- delete $cache{connect};
- return;
- }
- }
-
- &hookMsg('private', undef, $nick, $msg);
- $who = '';
- $chan = '';
- $msgType = '';
-}
-
-sub on_names {
- $conn = shift(@_);
- my ($event) = @_;
- my @args = $event->args;
- my $chan = lc $args[2]; # CASING, the last of them!
-
- foreach (split / /, @args[3..$#args]) {
- $channels{$chan}{'o'}{$_}++ if s/\@//;
- $channels{$chan}{'v'}{$_}++ if s/\+//;
- $channels{$chan}{''}{$_}++;
- }
-}
-
-sub on_nick {
- $conn = shift(@_);
- my ($event) = @_;
- my $nick = $event->nick();
- my $newnick = ($event->args)[0];
-
- if (exists $netsplit{lc $newnick}) {
- &status("Netsplit: $newnick/$nick came back from netsplit and changed to original nick! removing from hash.");
- delete $netsplit{lc $newnick};
- &netsplitCheck() if (time() != $sched{netsplitCheck}{TIME});
- }
-
- my ($chan,$mode);
- foreach $chan (keys %channels) {
- foreach $mode (keys %{ $channels{$chan} }) {
- next unless (exists $channels{$chan}{$mode}{$nick});
-
- $channels{$chan}{$mode}{$newnick} = $channels{$chan}{$mode}{$nick};
- }
- }
- # TODO: do %flood* aswell.
-
- &delUserInfo($nick, keys %channels);
- $nuh{lc $newnick} = $nuh{lc $nick};
- delete $nuh{lc $nick};
-
- if ($nick eq $conn->nick()) {
- &status(">>> I materialized into $b_green$newnick$ob from $nick");
- $ident = $newnick;
- $conn->nick($newnick);
- } else {
- &status(">>> $b_cyan$nick$ob materializes into $b_green$newnick$ob");
- my $mynick=$conn->nick();
- if ($nick =~ /^\Q$mynick\E$/i) {
- &getNickInUse();
- }
- }
-}
-
-sub on_nick_taken {
- $conn = shift(@_);
- my $nick = $conn->nick();
- #my $newnick = $nick . int(rand 10);
- my $newnick = $nick . '_';
-
- &DEBUG("on_nick_taken: nick => $nick");
-
- &status("nick taken ($nick); preparing nick change.");
-
- $conn->whois($nick);
- #$conn->schedule(5, sub {
- &status("nick taken; changing to temporary nick ($nick -> $newnick).");
- &nick($newnick);
- #} );
-}
-
-sub on_notice {
- $conn = shift(@_);
- my ($event) = @_;
- my $nick = $event->nick();
- my $chan = ($event->to)[0];
- my $args = ($event->args)[0];
-
- if ($nick =~ /^NickServ$/i) { # nickserv.
- &status("NickServ: <== '$args'");
-
- my $check = 0;
- $check++ if ($args =~ /^This nickname is registered/i);
- $check++ if ($args =~ /nickname.*owned/i);
-
- if ($check) {
- &status("nickserv told us to register; doing it.");
-
- if (&IsParam('nickServ_pass')) {
- &status("NickServ: ==> Identifying.");
- &rawout("PRIVMSG NickServ :IDENTIFY $param{'nickServ_pass'}");
- return;
- } else {
- &status("We can't tell nickserv a passwd ;(");
- }
- }
-
- # password accepted.
- if ($args =~ /^Password a/i) {
- my $done = 0;
-
- foreach ( &ChanConfList('chanServ_ops') ) {
- next unless &chanServCheck($_);
- next if ($done);
- &DEBUG("nickserv activated or restarted; doing chanserv check.");
- $done++;
- }
-
- $nickserv++;
- }
-
- } elsif ($nick =~ /^ChanServ$/i) { # chanserv.
- &status("ChanServ: <== '$args'.");
-
- } else {
- if ($chan =~ /^$mask{chan}$/) { # channel notice.
- &status("-$nick/$chan- $args");
- } else {
- $server = $nick unless (defined $server);
- &status("-$nick- $args"); # private or server notice.
- }
- }
-}
-
-sub on_other {
- $conn = shift(@_);
- my ($event) = @_;
- my $chan = ($event->to)[0];
- my $nick = $event->nick;
-
- &status("!!! other called.");
- &status("!!! $event->args");
-}
-
-sub on_part {
- $conn = shift(@_);
- my ($event) = @_;
- $chan = lc( ($event->to)[0] ); # CASING!!!
- my $mynick = $conn->nick();
- my $nick = $event->nick;
- my $userhost = $event->userhost;
- $who = $nick;
- $msgType = 'public';
-
- if (!exists $channels{$chan}) {
- &DEBUG("on_part: found out $mynick is on $chan!");
- $channels{$chan} = 1;
- }
-
- if (exists $floodjoin{$chan}{$nick}{Time}) {
- delete $floodjoin{$chan}{$nick};
- }
-
- $chanstats{$chan}{'Part'}++;
- &delUserInfo($nick,$chan);
- if ($nick eq $ident) {
- &clearChanVars($chan);
- }
-
- if (!&IsNickInAnyChan($nick) and &IsChanConf('seenStats') > 0) {
- delete $userstats{lc $nick};
- }
-
- &status(">>> part/$b_blue$chan$ob $b_cyan$nick$ob $b_yellow($ob$userhost$b_yellow)$ob");
-}
-
-sub on_ping {
- $conn = shift(@_);
- my ($event) = @_;
- my $nick = $event->nick;
-
- $conn->ctcp_reply($nick, join(' ', ($event->args)));
- &status(">>> ${b_green}CTCP PING$ob request from $b_cyan$nick$ob received.");
-}
-
-sub on_ping_reply {
- $conn = shift(@_);
- my ($event) = @_;
- my $nick = $event->nick;
- my $t = ($event->args)[1];
- if (!defined $t) {
- &WARN("on_ping_reply: t == undefined.");
- return;
- }
-
- my $lag = time() - $t;
-
- &status(">>> ${b_green}CTCP PING$ob reply from $b_cyan$nick$ob: $lag sec.");
-}
-
-sub on_public {
- $conn = shift(@_);
- my ($event) = @_;
- my $msg = ($event->args)[0];
- $chan = lc( ($event->to)[0] ); # CASING.
- my $nick = $event->nick;
- $who = $nick;
- $uh = $event->userhost();
- $nuh = $nick."!".$uh;
- $msgType = 'public';
- # TODO: move this out of hookMsg to here?
- ($user,$host) = split(/\@/, $uh);
- $h = $host;
-
- # rare case should this happen - catch it just in case.
- if ($bot_pid != $$) {
- &ERROR("run-away fork; exiting.");
- &delForked($forker);
- }
-
- $msgtime = time();
- $lastWho{$chan} = $nick;
- ### TODO: use $nick or lc $nick?
- if (&IsChanConf('seenStats') > 0) {
- $userstats{lc $nick}{'Count'}++;
- $userstats{lc $nick}{'Time'} = time();
- }
-
- # cache it.
- my $time = time();
- if (!$cache{ircTextCounters}) {
- &DEBUG("caching ircTextCounters for first time.");
- my @str = split(/\s+/, &getChanConf('ircTextCounters'));
- for (@str) { $_ = quotemeta($_); }
- $cache{ircTextCounters} = join('|', @str);
- }
-
- my $str = $cache{ircTextCounters};
- if ($str && $msg =~ /^($str)[\s!\.]?$/i) {
- my $x = $1;
-
- &VERB("textcounters: $x matched for $who",2);
- my $c = $chan || 'PRIVATE';
-
- # better to do "counter=counter+1".
- # but that will avoid time check.
- my ($v,$t) = &sqlSelect('stats', "counter,time", {
- nick => $who,
- type => $x,
- channel => $c,
- } );
- $v++;
-
- # don't allow ppl to cheat the stats :-)
- if (defined $t && $time - $t > 60) {
- &sqlSet('stats', {'nick' => $who}, {
- type => $x,
- channel => $c,
- time => $time,
- counter => $v,
- } );
- }
- }
-
- &hookMsg('public', $chan, $nick, $msg);
- $chanstats{$chan}{'PublicMsg'}++;
- $who = '';
- $chan = '';
- $msgType = '';
-}
-
-sub on_quit {
- $conn = shift(@_);
- my ($event) = @_;
- my $nick = $event->nick();
- my $reason = ($event->args)[0];
-
- # hack for ICC.
- $msgType = 'public';
- $who = $nick;
-### $chan = $reason; # no.
-
- my $count = 0;
- foreach (grep !/^_default$/, keys %channels) {
- # fixes inconsistent chanstats bug #1.
- if (!&IsNickInChan($nick,$_)) {
- $count++;
- next;
- }
- $chanstats{$_}{'SignOff'}++;
- }
-
- if ($count == scalar keys %channels) {
- &DEBUG("on_quit: nick $nick was not found in any chan.");
- }
-
- # should fix chanstats inconsistencies bug #2.
- if ($reason =~ /^($mask{host})\s($mask{host})$/) { # netsplit.
- $reason = "NETSPLIT: $1 <=> $2";
-
- # chanlimit code.
- foreach $chan ( &getNickInChans($nick) ) {
- next unless ( &IsChanConf('chanlimitcheck') > 0);
- next unless ( exists $channels{$_}{'l'} );
-
- &DEBUG("on_quit: netsplit detected on $_; disabling chan limit.");
- $conn->mode($_, "-l");
- }
-
- $netsplit{lc $nick} = time();
- if (!exists $netsplitservers{$1}{$2}) {
- &status("netsplit detected between $1 and $2 at [".scalar(gmtime)."]");
- $netsplitservers{$1}{$2} = time();
- }
- }
-
- my $chans = join(' ', &getNickInChans($nick) );
- &status(">>> $b_cyan$nick$ob has signed off IRC $b_red($ob$reason$b_red)$ob [$chans]");
-
- ###
- ### ok... lets clear out the cache
- ###
- &delUserInfo($nick, keys %channels);
- if (exists $nuh{lc $nick}) {
- delete $nuh{lc $nick};
- } else {
- # well.. it's good but weird that this has happened - lets just
- # be quiet about it.
- }
- delete $userstats{lc $nick} if (&IsChanConf('seenStats') > 0);
- delete $chanstats{lc $nick};
- ###
-
- # if we have a temp nick, and whoever is camping on our main nick leaves
- # revert to main nick. Note that Net::IRC only knows our main nick
- if ($nick eq $conn->nick()) {
- &status("nickchange: own nick \"$nick\" became free; changing.");
- &nick($mynick);
- }
-}
-
-sub on_targettoofast {
- $conn = shift(@_);
- my ($event) = @_;
- my $nick = $event->nick();
- my($me,$chan,$why) = $event->args();
-
- ### TODO: incomplete.
- if ($why =~ /.* wait (\d+) second/) {
- my $sleep = $1;
- my $max = 10;
-
- if ($sleep > $max) {
- &status("targettoofast: going to sleep for $max ($sleep)...");
- $sleep = $max;
- } else {
- &status("targettoofast: going to sleep for $sleep");
- }
-
- my $delta = time() - ($cache{sleepTime} || 0);
- if ($delta > $max+2) {
- sleep $sleep;
- $cache{sleepTime} = time();
- }
-
- return;
- }
-
- if (!exists $cache{TargetTooFast}) {
- &DEBUG("on_ttf: failed: $why");
- $cache{TargetTooFast}++;
- }
-}
-
-sub on_topic {
- $conn = shift(@_);
- my ($event) = @_;
-
- if (scalar($event->args) == 1) { # change.
- my $topic = ($event->args)[0];
- my $chan = ($event->to)[0];
- my $nick = $event->nick();
-
- ###
- # WARNING:
- # race condition here. To fix, change '1' to '0'.
- # This will keep track of topics set by bot only.
- ###
- # UPDATE:
- # this may be fixed at a later date with topic queueing.
- ###
-
- $topic{$chan}{'Current'} = $topic if (1);
- $chanstats{$chan}{'Topic'}++;
-
- &status(">>> topic/$b_blue$chan$ob by $b_cyan$nick$ob -> $topic");
- } else { # join.
- my ($nick, $chan, $topic) = $event->args;
- if (&IsChanConf('Topic') > 0) {
- $topic{$chan}{'Current'} = $topic;
- &topicAddHistory($chan,$topic);
- }
-
- $topic = &fixString($topic, 1);
- &status(">>> topic/$b_blue$chan$ob is $topic");
- }
-}
-
-sub on_topicinfo {
- $conn = shift(@_);
- my ($event) = @_;
- my ($myself,$chan,$setby,$time) = $event->args();
-
- my $timestr;
- if (time() - $time > 60*60*24) {
- $timestr = "at ". gmtime $time;
- } else {
- $timestr = &Time2String(time() - $time) ." ago";
- }
-
- &status(">>> set by $b_cyan$setby$ob $timestr");
-}
-
-sub on_crversion {
- $conn = shift(@_);
- my ($event) = @_;
- my $nick = $event->nick();
- my $ver;
-
- if (scalar $event->args() != 1) { # old.
- $ver = join ' ', $event->args();
- $ver =~ s/^VERSION //;
- } else { # new.
- $ver = ($event->args())[0];
- }
-
- if (grep /^\Q$nick\E$/i, @vernick) {
- &WARN("nick $nick found in vernick ($ver); skipping.");
- return;
- }
- push(@vernick, $nick);
-
- if ($ver =~ /bitchx/i) {
- $ver{bitchx}{$nick} = $ver;
-
- } elsif ($ver =~ /xc\!|xchat/i) {
- $ver{xchat}{$nick} = $ver;
-
- } elsif ($ver =~ /irssi/i) {
- $ver{irssi}{$nick} = $ver;
-
- } elsif ($ver =~ /epic|(Third Eye)/i) {
- $ver{epic}{$nick} = $ver;
-
- } elsif ($ver =~ /ircII|PhoEniX/i) {
- $ver{ircII}{$nick} = $ver;
-
- } elsif ($ver =~ /mirc/i) {
-# &DEBUG("verstats: mirc: $nick => '$ver'.");
- $ver{mirc}{$nick} = $ver;
-
-# ok... then we get to the lesser known/used clients.
- } elsif ($ver =~ /ircle/i) {
- $ver{ircle}{$nick} = $ver;
-
- } elsif ($ver =~ /chatzilla/i) {
- $ver{chatzilla}{$nick} = $ver;
-
- } elsif ($ver =~ /pirch/i) {
- $ver{pirch}{$nick} = $ver;
-
- } elsif ($ver =~ /sirc /i) {
- $ver{sirc}{$nick} = $ver;
-
- } elsif ($ver =~ /kvirc/i) {
- $ver{kvirc}{$nick} = $ver;
-
- } elsif ($ver =~ /eggdrop/i) {
- $ver{eggdrop}{$nick} = $ver;
-
- } elsif ($ver =~ /xircon/i) {
- $ver{xircon}{$nick} = $ver;
-
- } else {
- &DEBUG("verstats: other: $nick => '$ver'.");
- $ver{other}{$nick} = $ver;
- }
-}
-
-sub on_version {
- $conn = shift(@_);
- my ($event) = @_;
- my $nick = $event->nick;
-
- &status(">>> ${b_green}CTCP VERSION$ob request from $b_cyan$nick$ob");
- $conn->ctcp_reply($nick, "VERSION $bot_version");
-}
-
-sub on_who {
- $conn = shift(@_);
- my ($event) = @_;
- my @args = $event->args;
- my $str = $args[5]."!".$args[2]."\@".$args[3];
-
- if ($cache{on_who_Hack}) {
- $cache{nuhInfo}{lc $args[5]}{Nick} = $args[5];
- $cache{nuhInfo}{lc $args[5]}{User} = $args[2];
- $cache{nuhInfo}{lc $args[5]}{Host} = $args[3];
- $cache{nuhInfo}{lc $args[5]}{NUH} = "$args[5]!$args[2]\@$args[3]";
- return;
- }
-
- if ($args[5] =~ /^nickserv$/i and !$nickserv) {
- &DEBUG("ok... we did a who for nickserv.");
- &rawout("PRIVMSG NickServ :IDENTIFY $param{'nickServ_pass'}");
- }
-
- $nuh{lc $args[5]} = $args[5]."!".$args[2]."\@".$args[3];
-}
-
-sub on_whois {
- $conn = shift(@_);
- my ($event) = @_;
- my @args = $event->args;
-
- $nuh{lc $args[1]} = $args[1]."!".$args[2]."\@".$args[3];
-}
-
-sub on_whoischannels {
- $conn = shift(@_);
- my ($event) = @_;
- my @args = $event->args;
-
- &DEBUG("on_whoischannels: @args");
-}
-
-sub on_useronchannel {
- $conn = shift(@_);
- my ($event) = @_;
- my @args = $event->args;
-
- &DEBUG("on_useronchannel: @args");
- &joinNextChan();
-}
-
-###
-### since joinnextchan is hooked onto on_endofnames, these are needed.
-###
-
-sub on_chanfull {
- $conn = shift(@_);
- my ($event) = @_;
- my @args = $event->args;
-
- &status(">>> chanfull/$b_blue$args[1]$ob");
-
- &joinNextChan();
-}
-
-sub on_inviteonly {
- $conn = shift(@_);
- my ($event) = @_;
- my @args = $event->args;
-
- &status(">>> inviteonly/$b_cyan$args[1]$ob");
-
- &joinNextChan();
-}
-
-sub on_banned {
- $conn = shift(@_);
- my ($event) = @_;
- my @args = $event->args;
- my $chan = $args[1];
-
- &status(">>> banned/$b_blue$chan$ob $b_cyan$args[0]$ob, removing autojoin for $chan");
- delete $chanconf{$chan}{autojoin};
- &joinNextChan();
-}
-
-sub on_badchankey {
- $conn = shift(@_);
- my ($event) = @_;
- my @args = $event->args;
- my $chan = $args[1];
-
- &DEBUG("on_badchankey: args => @args, removing autojoin for $chan");
- delete $chanconf{$chan}{autojoin};
- &joinNextChan();
-}
-
-sub on_useronchan {
- $conn = shift(@_);
- my ($event) = @_;
- my @args = $event->args;
-
- &DEBUG("on_useronchan: args => @args");
- &joinNextChan();
-}
-
-# TODO not used yet
-sub on_stdin {
- my $line = <STDIN>;
- chomp($line);
- &FIXME("on_stdin: line => \"$line\"");
-}
-
-1;
+++ /dev/null
-#
-# ProcessExtra.pl: Extensions to Process.pl
-# Author: dms
-# Version: v0.5 (20010124)
-# Created: 20000117
-#
-
-# use strict; # TODO
-
-use POSIX qw(strftime);
-use vars qw(%sched %schedule);
-
-# format: function name = (
-# str chanconfdefault,
-# int internaldefault,
-# bool deferred,
-# int next run, (optional)
-# )
-
-#%schedule = {
-# uptimeLoop => ('', 60, 1),
-#};
-
-sub setupSchedulersII {
- foreach (keys %schedule) {
- &queueTask($_, @{ $schedule{$_} });
- }
-}
-
-sub queueTask {
- my($codename, $chanconfdef, $intervaldef, $defer) = @_;
- my $t = &getChanConfDefault($chanconfdef, $intervaldef, $chan);
- my $waittime = &getRandomInt($t);
-
- if (!defined $waittime) {
- &WARN("interval == waittime == UNDEF for $codename.");
- return;
- }
-
- my $time = $schedule{$codename}[3];
- if (defined $time and $time > time()) {
- &WARN("Sched for $codename already exists in " . &Time2String(time() - $time) . ".");
- return;
- }
-
- #&VERB("Scheduling \&$codename() for " . &Time2String($waittime),3);
-
- my $retval = $conn->schedule($waittime, sub {
- \&$codename;
- }, @args );
-}
-
-sub setupSchedulers {
- &VERB("Starting schedulers...",2);
-
- # ONCE OFF.
-
- # REPETITIVE.
- # 2 for on next-run.
- &randomQuote(2);
- &randomFactoid(2);
- &seenFlush(2);
- &leakCheck(2); # mandatory
- &seenFlushOld(2);
- &miscCheck2(2); # mandatory
- &slashdotLoop(2);
- &plugLoop(2);
- &kernelLoop(2);
- &wingateWriteFile(2);
- &factoidCheck(2); # takes a couple of seconds on a 486. defer it
-# TODO: convert to new format... or nuke altogether.
- &newsFlush(2);
-
- # 1 for run straight away
- &uptimeLoop(1);
- &logLoop(1);
- &chanlimitCheck(1);
- &netsplitCheck(1); # mandatory
- &floodLoop(1); # mandatory
- &ignoreCheck(1); # mandatory
- &miscCheck(1); # mandatory
- &shmFlush(1); # mandatory
- sleep 1;
- &ircCheck(1); # mandatory
-
- # TODO: squeeze this into a one-liner.
-# my $count = map { exists $sched{$_}{TIME} } keys %sched;
- my $count = 0;
- foreach (keys %sched) {
- my $time = $sched{$_}{TIME};
- next unless (defined $time and $time > time());
-
- $count++;
- }
-
- &status("Schedulers: $count will be running.");
- &scheduleList();
-}
-
-sub ScheduleThis {
- my ($interval, $codename, @args) = @_;
- my $waittime = &getRandomInt($interval);
-
- if (!defined $waittime) {
- &WARN("interval == waittime == UNDEF for $codename.");
- return;
- }
-
- my $time = $sched{$codename}{TIME};
- if (defined $time and $time > time()) {
- &WARN("Sched for $codename already exists in " . &Time2String(time() - $time) . ".");
- return;
- }
-
- &DEBUG("Scheduling \&$codename() " . \&$codename . " for " . &Time2String($waittime),3);
-
- my $retval = $conn->schedule($waittime, \&$codename, @args);
- $sched{$codename}{LABEL} = $retval;
- $sched{$codename}{TIME} = time()+$waittime;
- $sched{$codename}{LOOP} = 1;
-}
-
-####
-#### LET THE FUN BEGIN.
-####
-
-sub randomQuote {
- my $interval = &getChanConfDefault('randomQuoteInterval', 60, $chan);
- if (@_) {
- &ScheduleThis($interval, 'randomQuote');
- return if ($_[0] eq '2'); # defer.
- }
-
- foreach ( &ChanConfList('randomQuote') ) {
- next unless (&validChan($_));
-
- my $line = &getRandomLineFromFile($bot_data_dir. "/blootbot.randtext");
- if (!defined $line) {
- &ERROR("random Quote: weird error?");
- return;
- }
-
- &status("sending random Quote to $_.");
- &action($_, "Ponders: ".$line);
- }
- ### TODO: if there were no channels, don't reschedule until channel
- ### configuration is modified.
-}
-
-sub randomFactoid {
- my ($key,$val);
- my $error = 0;
-
- my $interval = &getChanConfDefault('randomFactoidInterval', 60, $chan);
- if (@_) {
- &ScheduleThis($interval, 'randomFactoid');
- return if ($_[0] eq '2'); # defer.
- }
-
- foreach ( &ChanConfList('randomFactoid') ) {
- next unless (&validChan($_));
-
- &status("sending random Factoid to $_.");
- while (1) {
- ($key,$val) = &randKey('factoids',"factoid_key,factoid_value");
- &DEBUG("rF: $key, $val");
-### $val =~ tr/^[A-Z]/[a-z]/; # blah is Good => blah is good.
- last if ((defined $val) and ($val !~ /^</) and ($key !~ /\#DEL\#/) and ($key !~ /^cmd:/));
-
- $error++;
- if ($error == 5) {
- &ERROR("rF: tried 5 times but failed.");
- return;
- }
- }
- &action($_, "Thinks: \037$key\037 is $val");
- ### FIXME: Use &getReply() on above to format factoid properly?
- $good++;
- }
-}
-
-sub logLoop {
- if (@_) {
- &ScheduleThis(60, 'logLoop');
- return if ($_[0] eq '2'); # defer.
- }
-
- return unless (defined fileno LOG);
- return unless (&IsParam('logfile'));
- return unless (&IsParam('maxLogSize'));
-
- ### check if current size is too large.
- if ( -s $file{log} > $param{'maxLogSize'}) {
- my $date = sprintf("%04d%02d%02d", (gmtime)[5,4,3]);
- $file{log} = $param{'logfile'} ."-". $date;
- &status("cycling log file.");
-
- if ( -e $file{log}) {
- my $i = 1;
- my $newlog;
- while () {
- $newlog = $file{log}."-".$i;
- last if (! -e $newlog);
- $i++;
- }
- $file{log} = $newlog;
- }
-
- &closeLog();
- CORE::system("/bin/mv '$param{'logfile'}' '$file{log}'");
- &compress($file{log});
- &openLog();
- &status("cycling log file.");
- }
-
- ### check if all the logs exceed size.
- if (!opendir(LOGS, $bot_log_dir)) {
- &WARN("logLoop: could not open dir '$bot_log_dir'");
- return;
- }
-
- my $tsize = 0;
- my (%age, %size);
- while (defined($_ = readdir LOGS)) {
- my $logfile = "$bot_log_dir/$_";
-
- next unless ( -f $logfile);
-
- my $size = -s $logfile;
- my $age = (stat $logfile)[9];
- $age{$age} = $logfile;
- $size{$logfile} = $size;
- $tsize += $size;
- }
- closedir LOGS;
-
- my $delete = 0;
- while ($tsize > $param{'maxLogSize'}) {
- &status("LOG: current size > max ($tsize > $param{'maxLogSize'})");
- my $oldest = (sort {$a <=> $b} keys %age)[0];
- &status("LOG: unlinking $age{$oldest}.");
- unlink $age{$oldest};
- $tsize -= $oldest;
- $delete++;
- }
-
- ### TODO: add how many b,kb,mb removed?
- &status("LOG: removed $delete logs.") if ($delete);
-}
-
-sub seenFlushOld {
- if (@_) {
- &ScheduleThis(1440, 'seenFlushOld');
- return if ($_[0] eq '2'); # defer.
- }
-
- # is this global-only?
- return unless (&IsChanConf('seen') > 0);
- return unless (&IsChanConf('seenFlushInterval') > 0);
-
- # global setting. does not make sense for per-channel.
- my $max_time = &getChanConfDefault('seenMaxDays', 30, $chan) *60*60*24;
- my $delete = 0;
-
- if ($param{'DBType'} =~ /^(pgsql|mysql|sqlite(2)?)$/i) {
- my $query;
-
- if ($param{'DBType'} =~ /^(mysql|sqlite(2)?)$/i) {
- $query = "SELECT nick,time FROM seen GROUP BY nick HAVING ".
- "UNIX_TIMESTAMP() - time > $max_time";
- } else { # pgsql.
- $query = "SELECT nick,time FROM seen WHERE ".
- "extract(epoch from timestamp 'now') - time > $max_time";
- }
-
- my $sth = $dbh->prepare($query);
- if ($sth->execute) {
- while (my @row = $sth->fetchrow_array) {
- my ($nick,$time) = @row;
-
- &sqlDelete('seen', { nick => $nick } );
- $delete++;
- }
- $sth->finish;
- }
- } else {
- &FIXME("seenFlushOld: for bad DBType:" . $param{'DBType'} . ".");
- }
- &VERB("SEEN deleted $delete seen entries.",2);
-
-}
-
-sub newsFlush {
- if (@_) {
- &ScheduleThis(60, 'newsFlush');
- return if ($_[0] eq '2'); # defer.
- }
-
- if (!&ChanConfList('News')) {
- &DEBUG("newsFlush: news disabled? (chan => $chan)");
- return;
- }
-
- my $delete = 0;
- my $oldest = time();
- my %none;
- foreach $chan (keys %::news) {
- my $i = 0;
- my $total = scalar(keys %{ $::news{$chan} });
-
- if (!$total) {
- delete $::news{$chan};
- next;
- }
-
- foreach $item (keys %{ $::news{$chan} }) {
- my $t = $::news{$chan}{$item}{Expire};
-
- my $tadd = $::news{$chan}{$item}{Time};
- $oldest = $tadd if ($oldest > $tadd);
-
- next if ($t == 0 or $t == -1);
- if ($t < 1000) {
- &status("newsFlush: Fixed Expire time for $chan/$item, should not happen anyway.");
- $::news{$chan}{$item}{Expire} = time() + $t*60*60*24;
- next;
- }
-
- my $delta = $t - time();
-
- next unless (time() > $t);
-
- # TODO: show how old it was.
- delete $::news{$chan}{$item};
- &status("NEWS: (newsflush) deleted '$item'");
- $delete++;
- $i++;
- }
-
- &status("NEWS (newsflush) {$chan}: deleted [$i/$total] news entries.") if ($i);
- $none{$chan} = 1 if ($total == $i);
- }
-
- # TODO: flush users aswell.
- my $duser = 0;
- foreach $chan (keys %::newsuser) {
- next if (exists $none{$chan});
-
- foreach (keys %{ $::newsuser{$chan} }) {
- my $t = $::newsuser{$chan}{$_};
- if (!defined $t or ($t > 2 and $t < 1000)) {
- &DEBUG("something wrong with newsuser{$chan}{$_} => $t");
- next;
- }
-
- next unless ($oldest > $t);
-
- delete $::newsuser{$chan}{$_};
- $duser++;
- }
-
- my $i = scalar(keys %{ $::newsuser{$chan} });
- delete $::newsuser{$chan} unless ($i);
- }
-
- if ($delete or $duser) {
- &status("NewsFlush: deleted: $delete news entries; $duser user cache.");
- }
-}
-
-sub chanlimitCheck {
- my $interval = &getChanConfDefault('chanlimitcheckInterval', 10, $chan);
- my $mynick=$conn->nick();
-
- if (@_) {
- &ScheduleThis($interval, 'chanlimitCheck');
- return if ($_[0] eq '2');
- }
-
- my $str = join(' ', &ChanConfList('chanlimitcheck') );
-
- 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'};
-
- if (scalar keys %netsplitservers) {
- if (defined $limit) {
- &status("chanlimit: netsplit; removing it for $chan.");
- $conn->mode($chan, "-l");
- $cache{chanlimitChange}{$chan} = time();
- &status("chanlimit: netsplit; removed.");
- }
-
- next;
- }
-
- if (defined $limit and scalar keys %{ $channels{$chan}{''} } > $limit) {
- &FIXME("LIMIT: set too low!!!");
- ### run NAMES again and flush it.
- }
-
- if (defined $limit and $limit == $newlimit) {
- $cache{chanlimitChange}{$chan} = time();
- next;
- }
-
- if (!exists $channels{$chan}{'o'}{$mynick}) {
- &status("chanlimit: dont have ops on $chan.") unless (exists $cache{warn}{chanlimit}{$chan});
- $cache{warn}{chanlimit}{$chan} = 1;
- &chanServCheck($chan);
- next;
- }
- delete $cache{warn}{chanlimit}{$chan};
-
- if (!defined $limit) {
- &status("chanlimit: $chan: setting for first time or from netsplit.");
- }
-
- if (exists $cache{chanlimitChange}{$chan}) {
- my $delta = time() - $cache{chanlimitChange}{$chan};
- if ($delta < $interval*60) {
- &DEBUG("chanlimit: not going to change chanlimit! ($delta<$interval*60)");
- return;
- }
- }
-
- $conn->mode($chan, "+l", $newlimit);
- $cache{chanlimitChange}{$chan} = time();
- }
-}
-
-sub netsplitCheck {
- my ($s1,$s2);
-
- if (@_) {
- &ScheduleThis(15, 'netsplitCheck');
- return if ($_[0] eq '2');
- }
-
- $cache{'netsplitCache'}++;
-# &DEBUG("running netsplitCheck... $cache{netsplitCache}");
-
- if (!scalar %netsplit and scalar %netsplitservers) {
- &DEBUG("nsC: !hash netsplit but hash netsplitservers <- removing!");
- undef %netsplitservers;
- return;
- }
-
- # well... this shouldn't happen since %netsplit code does it anyway.
- foreach $s1 (keys %netsplitservers) {
-
- foreach $s2 (keys %{ $netsplitservers{$s1} }) {
- my $delta = time() - $netsplitservers{$s1}{$s2};
-
- if ($delta > 60*30) {
- &status("netsplit between $s1 and $s2 appears to be stale.");
- delete $netsplitservers{$s1}{$s2};
- &chanlimitCheck();
- }
- }
-
- my $i = scalar(keys %{ $netsplitservers{$s1} });
- delete $netsplitservers{$s1} unless ($i);
- }
-
- # %netsplit hash checker.
- my $count = scalar keys %netsplit;
- my $delete = 0;
- foreach (keys %netsplit) {
- if (&IsNickInAnyChan($_)) { # why would this happen?
-# &DEBUG("nsC: $_ is in some chan; removing from netsplit list.");
- delete $netsplit{$_};
- $delete++;
- next;
- }
-
- next unless (time() - $netsplit{$_} > 60*15);
-
- $delete++;
- 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);
- &status("nsC: removed from netsplit list: (before: $count; after: $j)");
- }
-
- if (!scalar %netsplit and scalar %netsplitservers) {
- &DEBUG("nsC: ok hash netsplit is NULL; purging hash netsplitservers");
- undef %netsplitservers;
- }
-
- if ($count and !scalar keys %netsplit) {
- &DEBUG("nsC: netsplit is hopefully gone. reinstating chanlimit check.");
- &chanlimitCheck();
- }
-}
-
-sub floodLoop {
- my $delete = 0;
- my $who;
-
- if (@_) {
- &ScheduleThis(60, 'floodLoop'); # minutes.
- return if ($_[0] eq '2');
- }
-
- my $time = time();
- my $interval = &getChanConfDefault('floodCycle',60, $chan);
-
- foreach $who (keys %flood) {
- foreach (keys %{ $flood{$who} }) {
- if (!exists $flood{$who}{$_}) {
- &WARN("flood{$who}{$_} undefined?");
- next;
- }
-
- if ($time - $flood{$who}{$_} > $interval) {
- delete $flood{$who}{$_};
- $delete++;
- }
- }
- }
- &VERB("floodLoop: deleted $delete items.",2);
-}
-
-sub seenFlush {
- if (@_) {
- my $interval = &getChanConfDefault('seenFlushInterval', 60, $chan);
- &ScheduleThis($interval, 'seenFlush');
- return if ($_[0] eq '2');
- }
-
- my %stats;
- my $nick;
- my $flushed = 0;
- $stats{'count_old'} = &countKeys('seen') || 0;
- $stats{'new'} = 0;
- $stats{'old'} = 0;
-
- if ($param{'DBType'} =~ /^(mysql|pgsql|sqlite(2)?)$/i) {
- foreach $nick (keys %seencache) {
- my $retval = &sqlSet('seen', {'nick' => lc $seencache{$nick}{'nick'}}, {
- time => $seencache{$nick}{'time'},
- host => $seencache{$nick}{'host'},
- channel => $seencache{$nick}{'chan'},
- message => $seencache{$nick}{'msg'},
- } );
-
- delete $seencache{$nick};
- $flushed++;
- }
- } else {
- &DEBUG("seenFlush: NO VALID FACTOID SUPPORT?");
- }
-
- &status("Seen: Flushed $flushed entries.") if ($flushed);
- &VERB(sprintf(" new seen: %03.01f%% (%d/%d)",
- $stats{'new'}*100/($stats{'count_old'} || 1),
- $stats{'new'}, ( $stats{'count_old'} || 1) ), 2) if ($stats{'new'});
- &VERB(sprintf(" now seen: %3.1f%% (%d/%d)",
- $stats{'old'}*100 / ( &countKeys('seen') || 1),
- $stats{'old'}, &countKeys('seen') ), 2) if ($stats{'old'});
-
- &WARN("scalar keys seenflush != 0!") if (scalar keys %seenflush);
-}
-
-sub leakCheck {
- my ($blah1,$blah2);
- my $count = 0;
-
- if (@_) {
- &ScheduleThis(240, 'leakCheck');
- return if ($_[0] eq '2');
- }
-
- # flood. this is dealt with in floodLoop()
- foreach $blah1 (keys %flood) {
- foreach $blah2 (keys %{ $flood{$blah1} }) {
- $count += scalar(keys %{ $flood{$blah1}{$blah2} });
- }
- }
- &VERB("leak: hash flood has $count total keys.",2);
-
- # floodjoin.
- $count = 0;
- foreach $blah1 (keys %floodjoin) {
- foreach $blah2 (keys %{ $floodjoin{$blah1} }) {
- $count += scalar(keys %{ $floodjoin{$blah1}{$blah2} });
- }
- }
- &VERB("leak: hash floodjoin has $count total keys.",2);
-
- # floodwarn.
- $count = scalar(keys %floodwarn);
- &VERB("leak: hash floodwarn has $count total keys.",2);
-
- my $chan;
- foreach $chan (grep /[A-Z]/, keys %channels) {
- &DEBUG("leak: chan => '$chan'.");
- my ($i,$j);
- foreach $i (keys %{ $channels{$chan} }) {
- foreach (keys %{ $channels{$chan}{$i} }) {
- &DEBUG("leak: \$channels{$chan}{$i}{$_} ...");
- }
- }
- }
-
- # chanstats
- $count = scalar(keys %chanstats);
- &VERB("leak: hash chanstats has $count total keys.",2);
-
- # nuh.
- my $delete = 0;
- foreach (keys %nuh) {
- next if (&IsNickInAnyChan($_));
- next if (exists $dcc{CHAT}{$_});
-
- delete $nuh{$_};
- $delete++;
- }
-
- &status("leak: $delete nuh{} items deleted; now have ".
- scalar(keys %nuh) ) if ($delete);
-}
-
-sub ignoreCheck {
- if (@_) {
- &ScheduleThis(60, 'ignoreCheck');
- return if ($_[0] eq '2'); # defer.
- }
-
- my $time = time();
- my $count = 0;
-
- foreach (keys %ignore) {
- my $chan = $_;
-
- foreach (keys %{ $ignore{$chan} }) {
- my @array = @{ $ignore{$chan}{$_} };
-
- next unless ($array[0] and $time > $array[0]);
-
- delete $ignore{$chan}{$_};
- &status("ignore: $_/$chan has expired.");
- $count++;
- }
- }
-
- $cache{ignoreCheckTime} = time();
-
- &VERB("ignore: $count items deleted.",2);
-}
-
-sub ircCheck {
- if (@_) {
- &ScheduleThis(15, 'ircCheck');
- return if ($_[0] eq '2'); # defer.
- }
-
- $cache{statusSafe} = 1;
- foreach (sort keys %conns) {
- $conn=$conns{$_};
- my $mynick=$conn->nick();
- &DEBUG("ircCheck for $_");
- my @join = &getJoinChans(1);
- if (scalar @join) {
- &FIXME('ircCheck: found channels to join! ' . join(',',@join));
- &joinNextChan();
- }
-
- # TODO: fix on_disconnect()
-
- if (time() - $msgtime > 3600) {
- # TODO: shouldn't we use cache{connect} somewhere?
- if (exists $cache{connect}) {
- &WARN("ircCheck: no msg for 3600 and disco'd! reconnecting!");
- $msgtime = time(); # just in case.
- &ircloop();
- delete $cache{connect};
- } else {
- &status('ircCheck: possible lost in space; checking.'.
- scalar(gmtime) );
- &msg($mynick, 'TEST');
- $cache{connect} = time();
- }
- }
-
- if (grep /^\s*$/, keys %channels) {
- &WARN('ircCheck: we have a NULL chan in hash channels? removing!');
- if (!exists $channels{''}) {
- &DEBUG('ircCheck: this should never happen!');
- }
-
- delete $channels{''};
- }
- }
-
- $cache{statusSafe} = 0;
-
- ### USER FILE.
- if ($utime_userfile > $wtime_userfile and time() - $wtime_userfile > 3600) {
- &writeUserFile();
- $wtime_userfile = time();
- }
- ### CHAN FILE.
- if ($utime_chanfile > $wtime_chanfile and time() - $wtime_chanfile > 3600) {
- &writeChanFile();
- $wtime_chanfile = time();
- }
-}
-
-sub miscCheck {
- if (@_) {
- &ScheduleThis(120, 'miscCheck');
- return if ($_[0] eq '2'); # defer.
- }
-
- # SHM check.
- my @ipcs;
- if ( -x "/usr/bin/ipcs") {
- @ipcs = `/usr/bin/ipcs`;
- } else {
- &WARN("ircCheck: no 'ipcs' binary.");
- return;
- }
-
- # make backup of important files.
- &mkBackup( $bot_state_dir."/blootbot.chan", 60*60*24*3);
- &mkBackup( $bot_state_dir."/blootbot.users", 60*60*24*3);
- &mkBackup( $bot_base_dir."/blootbot-news.txt", 60*60*24*1);
-
- # flush cache{lobotomy}
- foreach (keys %{ $cache{lobotomy} }) {
- next unless (time() - $cache{lobotomy}{$_} > 60*60);
- delete $cache{lobotomy}{$_};
- }
-
- ### check modules if they've been modified. might be evil.
- &reloadAllModules();
-
- # shmid stale remove.
- foreach (@ipcs) {
- chop;
-
- # key, shmid, owner, perms, bytes, nattch
- next unless (/^(0x\d+) (\d+)\s+(\S+)\s+(\d+)\s+(\d+)\s+/);
-
- my ($shmid, $size) = ($2,$5);
- next unless ($shmid != $shm and $size == 2000);
- my $z = &shmRead($shmid);
- if ($z =~ /^(\S+):(\d+):(\d+): /) {
- my $n = $1;
- my $pid = $2;
- my $time = $3;
- next if (time() - $time < 60*60);
- # FIXME remove not-pid shm if parent process dead
- next if ($pid == $bot_pid);
- # don't touch other bots, if they're running.
- next unless ($param{ircUser} =~ /^\Q$n\E$/);
- } else {
- &DEBUG("shm: $shmid is not ours or old blootbot => ($z)");
- next;
- }
-
- &status("SHM: nuking shmid $shmid");
- CORE::system("/usr/bin/ipcrm shm $shmid >/dev/null");
- }
-}
-
-sub miscCheck2 {
- if (@_) {
- &ScheduleThis(240, 'miscCheck2');
- return if ($_[0] eq '2'); # defer.
- }
-
- # debian check.
- opendir(DEBIAN, "$bot_state_dir/debian");
- foreach ( grep /gz$/, readdir(DEBIAN) ) {
- my $exit = CORE::system("gzip -t $bot_state_dir/debian/$_");
- next unless ($exit);
-
- &status("debian: unlinking file => $_");
- unlink "$bot_state_dir/debian/$_";
- }
- closedir DEBIAN;
-
- # compress logs that should have been compressed.
- # TODO: use strftime?
- my ($day,$month,$year) = (gmtime(time()))[3,4,5];
- my $date = sprintf("%04d%02d%02d",$year+1900,$month+1,$day);
-
- if (!opendir(DIR,"$bot_log_dir")) {
- &ERROR("misccheck2: log dir $bot_log_dir does not exist.");
- closedir DIR;
- return -1;
- }
-
- while (my $f = readdir(DIR)) {
- next unless ( -f "$bot_log_dir/$f");
- next if ($f =~ /gz|bz2/);
- next unless ($f =~ /(\d{8})/);
- next if ($date eq $1);
-
- &compress("$bot_log_dir/$f");
- }
- closedir DIR;
-}
-
-### this is semi-scheduled
-sub getNickInUse {
-# FIXME: broken for multiple connects
-# if ($ident eq $param{'ircNick'}) {
-# &status("okay, got my nick back.");
-# return;
-# }
-#
-# if (@_) {
-# &ScheduleThis(30, 'getNickInUse');
-# return if ($_[0] eq '2'); # defer.
-# }
-#
-# &nick( $param{'ircNick'} );
-}
-
-sub uptimeLoop {
- return if (!defined &uptimeWriteFile);
-# return unless &IsParam('Uptime');
-
- if (@_) {
- &ScheduleThis(60, 'uptimeLoop');
- return if ($_[0] eq '2'); # defer.
- }
-
- &uptimeWriteFile();
-}
-
-sub slashdotLoop {
-
- if (@_) {
- &ScheduleThis(60, 'slashdotLoop');
- return if ($_[0] eq '2');
- }
-
- my @chans = &ChanConfList('slashdotAnnounce');
- return unless (scalar @chans);
-
- &Forker('slashdot', sub {
- my $line = &Slashdot::slashdotAnnounce();
- return unless (defined $line);
-
- foreach (@chans) {
- next unless (&::validChan($_));
-
- &::status("sending slashdot update to $_.");
- ¬ice($_, "Slashdot: $line");
- }
- } );
-}
-
-sub plugLoop {
-
- if (@_) {
- &ScheduleThis(60, 'plugLoop');
- return if ($_[0] eq '2');
- }
-
- my @chans = &ChanConfList('plugAnnounce');
- return unless (scalar @chans);
-
- &Forker('Plug', sub {
- my $line = &Plug::plugAnnounce();
- return unless (defined $line);
-
- foreach (@chans) {
- next unless (&::validChan($_));
-
- &::status("sending plug update to $_.");
- ¬ice($_, "Plug: $line");
- }
- } );
-}
-
-sub kernelLoop {
- if (@_) {
- &ScheduleThis(240, 'kernelLoop');
- return if ($_[0] eq '2');
- }
-
- my @chans = &ChanConfList('kernelAnnounce');
- return unless (scalar @chans);
-
- &Forker('Kernel', sub {
- my @data = &Kernel::kernelAnnounce();
-
- foreach (@chans) {
- next unless (&::validChan($_));
-
- &::status("sending kernel update to $_.");
- my $c = $_;
- foreach (@data) {
- ¬ice($c, "Kernel: $_");
- }
- }
- } );
-}
-
-sub wingateCheck {
- return unless &IsChanConf('Wingate') > 0;
-
- ### FILE CACHE OF OFFENDING WINGATES.
- foreach (grep /^$host$/, @wingateBad) {
- &status("Wingate: RUNNING ON $host BY $who");
- &ban("*!*\@$host", '') if &IsChanConf('wingateBan') > 0;
-
- my $reason = &getChanConf('wingateKick');
-
- next unless ($reason);
- &kick($who, '', $reason)
- }
-
- ### RUN CACHE OF TRIED WINGATES.
- if (grep /^$host$/, @wingateCache) {
- push(@wingateNow, $host); # per run.
- push(@wingateCache, $host); # cache per run.
- } else {
- &DEBUG("Already scanned $host. good.");
- }
-
- my $interval = &getChanConfDefault('wingateInterval', 60, $chan); # seconds.
- return if (defined $forked{'Wingate'});
- return if (time() - $wingaterun <= $interval);
- return unless (scalar(keys %wingateToDo));
-
- $wingaterun = time();
-
- &Forker('Wingate', sub { &Wingate::Wingates(keys %wingateToDo); } );
- undef @wingateNow;
-}
-
-### TODO: ??
-sub wingateWriteFile {
- if (@_) {
- &ScheduleThis(60, 'wingateWriteFile');
- return if ($_[0] eq '2'); # defer.
- }
-
- return unless (scalar @wingateCache);
-
- my $file = "$bot_base_dir/$param{'ircUser'}.wingate";
- if ($bot_pid != $$) {
- &DEBUG('wingateWriteFile: Reorganising!');
-
- open(IN, $file);
- while (<IN>) {
- chop;
- push(@wingateNow, $_);
- }
- close IN;
-
- # very lame hack.
- my %hash = map { $_ => 1 } @wingateNow;
- @wingateNow = sort keys %hash;
- }
-
- &DEBUG('wingateWF: writing...');
- open(OUT, ">$file");
- foreach (@wingateNow) {
- print OUT "$_\n";
- }
- close OUT;
-}
-
-sub factoidCheck {
- if (@_) {
- &ScheduleThis(720, 'factoidCheck');
- return if ($_[0] eq '2'); # defer.
- }
-
- my @list = &searchTable('factoids', 'factoid_key', 'factoid_key', " #DEL#");
- my $stale = &getChanConfDefault('factoidDeleteDelay', 14, $chan) *60*60*24;
- if ($stale < 1) {
- # disable it since it's 'illegal'.
- return;
- }
-
- my $time = time();
-
- foreach (@list) {
- my $age = &getFactInfo($_, 'modified_time');
-
- if (!defined $age or $age !~ /^\d+$/) {
- if (scalar @list > 50) {
- if (!$cache{warnDel}) {
- &WARN("list is over 50 (".scalar(@list)."... giving it a miss.");
- $cache{warnDel} = 1;
- last;
- }
- }
-
- &WARN("del factoid: old cruft (no time): $_");
- &delFactoid($_);
- next;
- }
-
- next unless ($time - $age > $stale);
-
- my $fix = $_;
- $fix =~ s/ #DEL#$//g;
- my $agestr = &Time2String($time - $age);
- &status("safedel: Removing '$_' for good. [$agestr old]");
-
- &delFactoid($_);
- }
-}
-
-sub dccStatus {
- return unless (scalar keys %{ $dcc{CHAT} });
-
- if (@_) {
- &ScheduleThis(10, 'dccStatus');
- return if ($_[0] eq '2'); # defer.
- }
-
- my $time = strftime("%H:%M", gmtime(time()) );
-
- my $c;
- foreach (keys %channels) {
- my $c = $_;
- my $users = keys %{ $channels{$c}{''} };
- my $chops = keys %{ $channels{$c}{o} };
- my $bans = keys %{ $channels{$c}{b} };
-
- my $txt = "[$time] $c: $users members ($chops chops), $bans bans";
- foreach (keys %{ $dcc{'CHAT'} }) {
- next unless (exists $channels{$c}{''}{lc $_});
- $conn->privmsg($dcc{'CHAT'}{$_}, $txt);
- }
- }
-}
-
-sub scheduleList {
- ###
- # custom:
- # a - time == now.
- # b - weird time.
- ###
-
- my $reply = "sched:";
- foreach (keys %{ $irc->{_queue}}) {
- my $q = $_;
- my $coderef = $irc->{_queue}->{$q}->[1];
- my $sched;
- foreach (keys %sched) {
- my $schedname = $_;
- next unless defined(\&$schedname);
- next unless ($coderef eq \&$schedname);
- $sched = $schedname;
- last;
- }
-
- my $time = $irc->{_queue}->{$q}->[0] - time();
-
- if (defined $sched) {
- $reply = "$reply, $sched($q):" . &Time2String($time);
- } else {
- $reply = "$reply, NULL($q):" . &Time2String($time);
- }
- }
-
- &DEBUG("$reply");
-}
-
-sub mkBackup {
- my($file, $time) = @_;
- my $backup = 0;
-
- if (! -f $file) {
- &VERB("mkB: file '$file' does not exist.",2);
- return;
- }
-
- my $age = 'New';
- if ( -e "$file~" ) {
- $backup++ if ((stat $file)[9] - (stat "$file~")[9] > $time);
- my $delta = time() - (stat "$file~")[9];
- $age = &Time2String($delta);
- } else {
- $backup++;
- }
-
- return unless ($backup);
-
- ### TODO: do internal copying.
- &status("Backup: $file ($age)");
- CORE::system("/bin/cp $file $file~");
-}
-
-1;
+++ /dev/null
-#
-# Misc.pl: Miscellaneous stuff.
-# Author: dms
-# Version: 20000124
-# NOTE: Based on code by Kevin Lenzo & Patrick Cole (c) 1997
-#
-
-use strict;
-
-use vars qw(%file %mask %param %cmdstats %myModules);
-use vars qw($msgType $who $bot_pid $nuh $shm $force_public_reply
- $no_timehires $bot_data_dir $addrchar);
-
-sub help {
- my $topic = shift;
- my $file = $bot_data_dir."/blootbot.help";
- my %help = ();
-
- # crude hack for performStrictReply() to work as expected.
- $msgType = 'private' if ($msgType eq 'public');
-
- if (!open(FILE, $file)) {
- &ERROR("Failed reading help file ($file): $!");
- return;
- }
-
- while (defined(my $help = <FILE>)) {
- $help =~ s/^[\# ].*//;
- chomp $help;
- next unless $help;
- my ($key, $val) = split(/:/, $help, 2);
-
- $val =~ s/^\s+//;
- $val =~ s/^D:/\002 Desc\002:/;
- $val =~ s/^E:/\002Example\002:/;
- $val =~ s/^N:/\002 NOTE\002:/;
- $val =~ s/^U:/\002 Usage\002:/;
- $val =~ s/##/$key/;
- $val =~ s/__/\037/g;
- $val =~ s/==/ /;
-
- $help{$key} = '' if (!exists $help{$key});
- $help{$key} .= $val."\n";
- }
- close FILE;
-
- if (!defined $topic or $topic eq '') {
- &msg($who, $help{'main'});
-
- my $i = 0;
- my @array;
- my $count = scalar(keys %help);
- my $reply;
- foreach (sort keys %help) {
- push(@array,$_);
- $reply = scalar(@array) ." topics: ".
- join("\002,\002 ", @array);
- $i++;
-
- if (length $reply > 400 or $count == $i) {
- &msg($who,$reply);
- undef @array;
- }
- }
-
- return '';
- }
-
- $topic = &fixString(lc $topic);
-
- if (exists $help{$topic}) {
- foreach (split /\n/, $help{$topic}) {
- &performStrictReply($_);
- }
- } else {
- &performStrictReply("no help on $topic. Use 'help' without arguments.");
- }
-
- return '';
-}
-
-sub getPath {
- my ($pathnfile) = @_;
-
- ### TODO: gotta hate an if statement.
- if ($pathnfile =~ /(.*)\/(.*?)$/) {
- return $1;
- } else {
- return ".";
- }
-}
-
-sub timeget {
- if ($no_timehires) { # fallback.
- return time();
- } else { # the real thing.
- return [gettimeofday()];
- }
-}
-
-sub timedelta {
- my($start_time) = shift;
-
- if ($no_timehires) { # fallback.
- return time() - $start_time;
- } else { # the real thing.
- return tv_interval ($start_time);
- }
-}
-
-###
-### FORM Functions.
-###
-
-###
-# Usage; &formListReply($rand, $prefix, @list);
-sub formListReply {
- my($rand, $prefix, @list) = @_;
- my $total = scalar @list;
- my $maxshow = &getChanConfDefault('maxListReplyCount', 15, $chan);
- my $maxlen = &getChanConfDefault('maxListReplyLength', 400, $chan);
- my $reply;
-
- # remove irc overhead
- $maxlen -= 30;
-
- # no results.
- return $prefix ."returned no results." unless ($total);
-
- # random.
- if ($rand) {
- my @rand;
- foreach (&makeRandom($total)) {
- push(@rand, $list[$_]);
- last if (scalar @rand == $maxshow);
- }
- if ($total > $maxshow) {
- @list = sort @rand;
- } else {
- @list = @rand;
- }
- } elsif ($total > $maxshow) {
- &status("formListReply: truncating list.");
-
- @list = @list[0..$maxshow-1];
- }
-
- # form the reply.
- # FIXME: should grow and exit when full, not discard any that are oversize
- while () {
- $reply = $prefix ."(\002". scalar(@list). "\002";
- $reply .= " of \002$total\002" if ($total != scalar @list);
- $reply .= "): " . join(" \002;;\002 ", @list) .".";
-
- last if (length($reply) < $maxlen and scalar(@list) <= $maxshow);
- last if (scalar(@list) == 1);
-
- pop @list;
- }
-
- return $reply;
-}
-
-### Intelligence joining of arrays.
-# Usage: &IJoin(@array);
-sub IJoin {
- if (!scalar @_) {
- return 'NULL';
- } elsif (scalar @_ == 1) {
- return $_[0];
- } else {
- return join(', ',@{_}[0..$#_-1]) . " and $_[$#_]";
- }
-}
-
-#####
-# Usage: &Time2String(seconds);
-sub Time2String {
- my ($time) = @_;
- my $prefix = '';
- my (@s, @t);
-
- return 'NULL' if (!defined $time);
- return $time if ($time !~ /\d+/);
-
- if ($time < 0) {
- $time = - $time;
- $prefix = "- ";
- }
-
- $t[0] = int($time) % 60;
- $t[1] = int($time / 60) % 60;
- $t[2] = int($time / 3600) % 24;
- $t[3] = int($time / 86400);
-
- push(@s, "$t[3]d") if ($t[3] != 0);
- push(@s, "$t[2]h") if ($t[2] != 0);
- push(@s, "$t[1]m") if ($t[1] != 0);
- push(@s, "$t[0]s") if ($t[0] != 0 or !@s);
-
- my $retval = $prefix.join(' ', @s);
- $retval =~ s/(\d+)/\002$1\002/g;
- return $retval;
-}
-
-###
-### FIX Functions.
-###
-
-# Usage: &fixFileList(@files);
-sub fixFileList {
- my @files = @_;
- my %files;
-
- # generate a hash list.
- foreach (@files) {
- next unless /^(.*\/)(.*?)$/;
-
- $files{$1}{$2} = 1;
- }
- @files = (); # reuse the array.
-
- # sort the hash list appropriately.
- foreach (sort keys %files) {
- my $file = $_;
- my @keys = sort keys %{ $files{$file} };
- my $i = scalar(@keys);
-
- if (scalar @keys > 3) {
- pop @keys while (scalar @keys > 3);
- push(@keys, "...");
- }
-
- if ($i > 1) {
- $file .= "\002{\002". join("\002|\002", @keys) ."\002}\002";
- } else {
- $file .= $keys[0];
- }
-
- push(@files,$file);
- }
-
- return @files;
-}
-
-# Usage: &fixString($str);
-sub fixString {
- my ($str, $level) = @_;
- if (!defined $str) {
- &WARN("fixString: str == NULL.");
- return '';
- }
-
- for ($str) {
- s/^\s+//; # remove start whitespaces.
- s/\s+$//; # remove end whitespaces.
- s/\s+/ /g; # remove excessive whitespaces.
-
- next unless (defined $level);
- if (s/[\cA-\c_]//ig) { # remove control characters.
- &DEBUG("stripped control chars");
- }
- }
-
- return $str;
-}
-
-# Usage: &fixPlural($str,$int);
-sub fixPlural {
- my ($str,$int) = @_;
-
- if (!defined $str) {
- &WARN("fixPlural: str == NULL.");
- return;
- }
-
- if (!defined $int or $int =~ /^\D+$/) {
- &WARN("fixPlural: int != defined or int");
- return $str;
- }
-
- if ($str eq 'has') {
- $str = 'have' if ($int > 1);
- } elsif ($str eq 'is') {
- $str = 'are' if ($int > 1);
- } elsif ($str eq 'was') {
- $str = 'were' if ($int > 1);
- } elsif ($str eq 'this') {
- $str = 'these' if ($int > 1);
- } elsif ($str =~ /y$/) {
- if ($int > 1) {
- if ($str =~ /ey$/) {
- $str .= 's'; # eg: 'money' => 'moneys'.
- } else {
- $str =~ s/y$/ies/;
- }
- }
- } else {
- $str .= 's' if ($int != 1);
- }
-
- return $str;
-}
-
-##########
-### get commands.
-###
-
-sub getRandomLineFromFile {
- my($file) = @_;
-
- if (!open(IN, $file)) {
- &WARN("gRLfF: could not open ($file): $!");
- return;
- }
-
- my @lines = <IN>;
- close IN;
-
- if (!scalar @lines) {
- &ERROR("GRLF: nothing loaded?");
- return;
- }
-
- # could we use the filehandler instead and put it through getRandom?
- while (my $line = &getRandom(@lines)) {
- chop $line;
-
- next if ($line =~ /^\#/);
- next if ($line =~ /^\s*$/);
-
- return $line;
- }
-}
-
-sub getLineFromFile {
- my($file,$lineno) = @_;
-
- if (! -f $file) {
- &ERROR("getLineFromFile: file '$file' does not exist.");
- return 0;
- }
-
- if (open(IN,$file)) {
- my @lines = <IN>;
- close IN;
-
- if ($lineno > scalar @lines) {
- &ERROR("getLineFromFile: lineno exceeds line count from file.");
- return 0;
- }
-
- my $line = $lines[$lineno-1];
- chop $line;
- return $line;
- } else {
- &ERROR("gLFF: Could not open file ($file): $!");
- return 0;
- }
-}
-
-# Usage: &getRandom(@array);
-sub getRandom {
- my @array = @_;
-
- srand();
- return $array[int(rand(scalar @array))];
-}
-
-# Usage: &getRandomInt("30-60");
-sub getRandomInt {
- my $str = $_[0];
-
- if (!defined $str) {
- &WARN("gRI: str == NULL.");
- return;
- }
-
- srand();
-
- if ($str =~ /^(\d+(\.\d+)?)$/) {
- my $i = $1;
- my $fuzzy = int(rand 5);
- if ($i < 10) {
- return $i;
- }
- if (rand > 0.5) {
- return ($i - $fuzzy)*60;
- } else {
- return ($i + $fuzzy)*60;
- }
- } elsif ($str =~ /^(\d+)-(\d+)$/) {
- return ($2 - $1)*int(rand $1)*60;
- } else {
- return $str; # hope we're safe.
- }
-
- &ERROR("getRandomInt: invalid arg '$str'.");
- return 1800;
-}
-
-##########
-### Is commands.
-###
-
-sub iseq {
- my ($left,$right) = @_;
- return 0 unless defined $right;
- return 0 unless defined $left;
- return 1 if ($left =~ /^\Q$right$/i);
-}
-
-sub isne {
- my $retval = &iseq(@_);
- return 1 unless ($retval);
- return 0;
-}
-
-# Usage: &IsHostMatch($nuh);
-sub IsHostMatch {
- my ($thisnuh) = @_;
- my (%this,%local);
-
- if ($nuh =~ /^(\S+)!(\S+)@(\S+)/) {
- $local{'nick'} = lc $1;
- $local{'user'} = lc $2;
- $local{'host'} = &makeHostMask(lc $3);
- }
-
- if (!defined $thisnuh) {
- &WARN("IHM: thisnuh == NULL.");
- return 0;
- } elsif ($thisnuh =~ /^(\S+)!(\S+)@(\S+)/) {
- $this{'nick'} = lc $1;
- $this{'user'} = lc $2;
- $this{'host'} = &makeHostMask(lc $3);
- } else {
- &WARN("IHM: thisnuh is invalid '$thisnuh'.");
- return 1 if ($thisnuh eq '');
- return 0;
- }
-
- # auth if 1) user and host match 2) user and nick match.
- # this may change in the future.
-
- if ($this{'user'} =~ /^\Q$local{'user'}\E$/i) {
- return 2 if ($this{'host'} eq $local{'host'});
- return 1 if ($this{'nick'} eq $local{'nick'});
- }
- return 0;
-}
-
-####
-# Usage: &isStale($file, $age);
-sub isStale {
- my ($file, $age) = @_;
-
- if (!defined $age) {
- &WARN("isStale: age == NULL.");
- return 1;
- }
-
- if (!defined $file) {
- &WARN("isStale: file == NULL.");
- return 1;
- }
-
- &DEBUG("!exist $file") if (! -f $file);
-
- return 1 unless ( -f $file);
- if ($file =~ /idx/) {
- my $age2 = time() - (stat($file))[9];
- &VERB("stale: $age2. (". &Time2String($age2) .")",2);
- }
- $age *= 60*60*24 if ($age >= 0 and $age < 30);
-
- return 1 if (time() - (stat($file))[9] > $age);
- return 0;
-}
-
-sub isFileUpdated {
- my ($file, $time) = @_;
-
- if (! -f $file) {
- return 1;
- }
-
- my $time_file = (stat $file)[9];
-
- if ($time <= $time_file) {
- return 0;
- } else {
- return 1;
- }
-}
-
-##########
-### make commands.
-###
-
-# Usage: &makeHostMask($host);
-sub makeHostMask {
- my ($host) = @_;
- my $nu = '';
-
- if ($host =~ s/^(\S+!\S+\@)//) {
- &DEBUG("mHM: detected nick!user\@ for host arg; fixing");
- &DEBUG("nu => $nu");
- $nu = $1;
- }
-
- if ($host =~ /^$mask{ip}$/) {
- return $nu."$1.$2.$3.*";
- }
-
- my @array = split(/\./, $host);
- return $nu.$host if (scalar @array <= 3);
- return $nu."*.".join('.',@{array}[1..$#array]);
-}
-
-# Usage: &makeRandom(int);
-sub makeRandom {
- my ($max) = @_;
- my @retval;
- my %done;
-
- if ($max =~ /^\D+$/) {
- &ERROR("makeRandom: arg ($max) is not integer.");
- return 0;
- }
-
- if ($max < 1) {
- &ERROR("makeRandom: arg ($max) is not positive.");
- return 0;
- }
-
- srand();
- while (scalar keys %done < $max) {
- my $rand = int(rand $max);
- next if (exists $done{$rand});
-
- push(@retval,$rand);
- $done{$rand} = 1;
- }
-
- return @retval;
-}
-
-sub checkMsgType {
- my ($reply) = @_;
- return unless (&IsParam('minLengthBeforePrivate'));
- return if ($force_public_reply);
-
- if (length $reply > $param{'minLengthBeforePrivate'}) {
- &status("Reply: len reply > minLBP ($param{'minLengthBeforePrivate'}); msgType now private.");
- $msgType = 'private';
- }
-}
-
-###
-### Valid.
-###
-
-# Usage: &validExec($string);
-sub validExec {
- my ($str) = @_;
-
- if ($str =~ /[\`\'\"\|]/) { # invalid.
- return 0;
- } else { # valid.
- return 1;
- }
-}
-
-# Usage: &hasProfanity($string);
-sub hasProfanity {
- my ($string) = @_;
- my $profanity = 1;
-
- for (lc $string) {
- /fuck/ and last;
- /dick|dildo/ and last;
- /shit/ and last;
- /pussy|[ck]unt/ and last;
- /wh[0o]re|bitch|slut/ and last;
-
- $profanity = 0;
- }
-
- return $profanity;
-}
-
-sub IsChanConfOrWarn {
- my ($param) = @_;
-
- if (&IsChanConf($param) > 0) {
- return 1;
- } else {
- ### TODO: specific reason why it failed.
- &msg($who, "unfortunately, \002$param\002 is disabled in my configuration") unless ($addrchar);
- return 0;
- }
-}
-
-sub Forker {
- my ($label, $code) = @_;
- my $pid;
-
- &shmFlush();
- &VERB("double fork detected; not forking.",2) if ($$ != $bot_pid);
-
- if (&IsParam('forking') and $$ == $bot_pid) {
- return unless &addForked($label);
-
- $SIG{CHLD} = 'IGNORE';
- $pid = eval { fork() };
- return if $pid; # parent does nothing
-
- select(undef, undef, undef, 0.2);
-# &status("fork starting for '$label', PID == $$.");
- &status("--- fork starting for '$label', PID == $$, bot_pid == $bot_pid ---");
- &shmWrite($shm,"SET FORKPID $label $$");
-
- sleep 1;
- }
-
- ### TODO: use AUTOLOAD
- ### very lame hack.
- if ($label !~ /-/ and !&loadMyModule($label)) {
- &DEBUG("Forker: failed?");
- &delForked($label);
- }
-
- if (defined $code) {
- $code->(); # weird, hey?
- } else {
- &WARN("Forker: code not defined!");
- }
-
- &delForked($label);
-}
-
-sub closePID {
- return 1 unless (exists $file{PID});
- return 1 unless ( -f $file{PID});
- return 1 if (unlink $file{PID});
- return 0 if ( -f $file{PID});
-}
-
-sub mkcrypt {
- my($str) = @_;
- my $salt = join '',('.','/',0..9,'A'..'Z','a'..'z')[rand 64, rand 64];
-
- return crypt($str, $salt);
-}
-
-sub closeStats {
- return unless (&getChanConfList('ircTextCounters'));
-
- foreach (keys %cmdstats) {
- my $type = $_;
- my $i = &sqlSelect('stats', 'counter', {
- nick => $type,
- type => 'cmdstats',
- } );
- my $z = 0;
- $z++ unless ($i);
-
- $i += $cmdstats{$type};
-
-
- &sqlSet('stats', {'nick' => $type}, {
- type => 'cmdstats',
- 'time' => time(),
- counter => $i,
- } );
- }
-}
-
-1;
+++ /dev/null
-#!/usr/bin/perl
-#
-# BZFlag
-# Copyright (c) 1993 - 2002 Tim Riker
-#
-# This package is free software; you can redistribute it and/or
-# modify it under the terms of the license found in the file
-# named LICENSE that should have accompanied this file.
-#
-# THIS PACKAGE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-# WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-
-package BZFlag;
-use strict;
-use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);
-
-my $no_BZFlag;
-
-BEGIN {
- $no_BZFlag = 0;
- eval "use Socket";
- eval "use LWP::UserAgent";
- $no_BZFlag++ if ($@);
-}
-
-sub BZFlag {
- my ($message) = @_;
- my ($retval);
- if ($no_BZFlag) {
- &::status("BZFlag module requires Socket.");
- return 'BZFlag module not active';
- }
- if ($message =~ /^bzfquery\s+([^:]*)(?::([0-9]*))?$/xi) {
- $retval = &query($1,$2);
- } elsif ($message =~ /^bzflist$/xi) {
- $retval = &list();
- } else {
- $retval = "BZFlag: unhandled command \"$message\"";
- }
- &::performStrictReply($retval);
-}
-
-sub list {
- my ($response);
- my $ua = new LWP::UserAgent;
- $ua->proxy('http', $::param{'httpProxy'}) if (&::IsParam('httpProxy'));
-
- $ua->timeout(5);
-
- my $req = HTTP::Request->new('GET', 'http://db.bzflag.org/db/?action=LIST');
- my $res = $ua->request($req);
- my %servers;
- my $totalServers = 0;
- for my $line (split("\n",$res->content)) {
- my ($serverport, $version, $flags, $ip, $comments) = split(" ",$line,5);
- # not "(A4)18" to handle old dumb perl
- my ($style, $maxShots, $shakeWins, $shakeTimeout, $maxPlayerScore, $maxTeamScore, $maxTime,
- $maxPlayers, $rogueSize, $rogueMax, $redSize, $redMax, $greenSize, $greenMax,
- $blueSize, $blueMax, $purpleSize, $purpleMax, $observerSize, $observerMax) =
- unpack('A4A4A4A4A4A4A4A2A2A2A2A2A2A2A2A2A2A2A2A2', $flags);
- my $playerSize = hex($rogueSize) + hex($redSize) + hex($greenSize)
- + hex($blueSize) + hex($purpleSize) + hex($observerSize);
- $servers{$serverport} = $playerSize;
- $servers{$version} += $playerSize;
- $servers{'PLAYERS'} += $playerSize;
- $totalServers += 1;
- }
- $response .= "s=$totalServers";
- foreach my $key (sort {$servers{$b} <=> $servers{$a}} (keys(%servers))) {
- if ($servers{$key} > 0) {
- $response .= " $key($servers{$key})";
- }
- }
- &::performStrictReply($response);
- return;
-}
-
-sub list17 {
- my ($response);
- my $ua = new LWP::UserAgent;
- $ua->proxy('http', $::param{'httpProxy'}) if (&::IsParam('httpProxy'));
-
- $ua->timeout(5);
-
- my $req = HTTP::Request->new('GET', 'http://list.bzflag.org:5156/');
- my $res = $ua->request($req);
- my %servers;
- my $totalServers = 0;
- my $totalPlayers = 0;
- for my $line (split("\n",$res->content)) {
- my ($serverport, $version, $flags, $ip, $comments) = split(" ",$line,5);
- # not "(A4)18" to handle old dumb perl
- my ($style,$maxPlayers,$maxShots,
- $rogueSize,$redSize,$greenSize,$blueSize,$purpleSize,
- $rogueMax,$redMax,$greenMax,$blueMax,$purpleMax,
- $shakeWins,$shakeTimeout,
- $maxPlayerScore,$maxTeamScore,$maxTime) =
- unpack('A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4', $flags);
- my $playerSize = hex($rogueSize) + hex($redSize) + hex($greenSize)
- + hex($blueSize) + hex($purpleSize);
- $servers{$serverport} = $playerSize;
- $totalServers += 1;
- $totalPlayers += $playerSize;
- }
- $response .= "s=$totalServers p=$totalPlayers";
- foreach my $key (sort {$servers{$b} <=> $servers{$a}} (keys(%servers))) {
- if ($servers{$key} > 0) {
- $response .= " $key($servers{$key})";
- }
- }
- &::performStrictReply($response);
- return;
-}
-
-sub querytext {
- my ($servernameport) = @_;
- my ($servername,$port) = split(":",$servernameport);
- if ($no_BZFlag) {
- &::status("BZFlag module requires Socket.");
- return 'BZFlag module not active';
- }
- #my @teamName = ('Rogue', 'Red', 'Green', 'Blue', 'Purple', 'Observer', 'Rabbit');
- my @teamName = ('X', 'R', 'G', 'B', 'P', 'O', 'K');
- my ($message, $server, $response);
- $port = 5154 unless $port;
-
- # socket define
- my $sockaddr = 'S n a4 x8';
-
- # port to port number
- my ($name,$aliases,$proto) = getprotobyname('tcp');
- ($name,$aliases,$port) = getservbyname($port,'tcp') unless $port =~ /^\d+$/;
-
- # get server address
- my ($type,$len,$serveraddr);
- ($name,$aliases,$type,$len,$serveraddr) = gethostbyname($servername);
- $server = pack($sockaddr, AF_INET, $port, $serveraddr);
-
- # connect
- # TODO wrap this with a 5 second alarm()
- return 'socket() error' unless socket(S1, AF_INET, SOCK_STREAM, $proto);
- return "could not connect to $servername:$port" unless connect(S1, $server);
-
- # don't buffer
- select(S1); $| = 1; select(STDOUT);
-
- # get hello
- my $buffer;
- return 'read error' unless read(S1, $buffer, 8) == 8;
-
- # parse reply
- my ($magic,$major,$minor,$something,$revision) = unpack("a4 a1 a1 a1 a1", $buffer);
- my ($version) = $magic . $major . $minor . $something . $revision;
-
- # quit if version isn't valid
- return 'not a bzflag server' if ($magic ne 'BZFS');
- $response .= "$major$minor$something$revision ";
- # check version
- if ($version eq 'BZFS0026') {
- # 1.11.x handled here
- return 'read error' unless read(S1, $buffer, 1) == 1;
- my ($id) = unpack('C', $buffer);
- return "rejected by server" if ($id == 255);
-
- # send game request
- print S1 pack('n2', 0, 0x7167);
-
- # get reply
- my $nbytes = read(S1, $buffer, 4);
- my ($infolen, $infocode) = unpack('n2', $buffer);
- if ($infocode == 0x6774) {
- # read and ignore MsgGameTime from new servers
- $nbytes = read(S1, $buffer, 8);
- $nbytes = read(S1, $buffer, 4);
- ($infolen, $infocode) = unpack('n2', $buffer);
- }
- $nbytes = read(S1, $buffer, 42);
- if ($nbytes != 42) {
- return "Error: read $nbytes bytes, expecting 46: $^E\n";
- }
-
- my ($style,$maxPlayers,$maxShots,
- $rogueSize,$redSize,$greenSize,$blueSize,$purpleSize,$observerSize,
- $rogueMax,$redMax,$greenMax,$blueMax,$purpleMax,$observerMax,
- $shakeWins,$shakeTimeout,
- $maxPlayerScore,$maxTeamScore,$maxTime,$timeElapsed) = unpack('n23', $buffer);
- return "bad server data $infocode" unless $infocode == 0x7167;
-
- # send players request
- print S1 pack('n2', 0, 0x7170);
-
- # get number of teams and players we'll be receiving
- return 'count read error' unless read(S1, $buffer, 8) == 8;
- my ($countlen,$countcode,$numTeams,$numPlayers) = unpack('n4', $buffer);
-
- # get the teams
- return 'bad count data' unless $countcode == 0x7170;
- return 'count read error' unless read(S1, $buffer, 5) == 5;
- ($countlen,$countcode,$numTeams) = unpack("n n C", $buffer);
- for (1..$numTeams) {
- return 'team read error' unless read(S1, $buffer, 8) == 8;
- my ($team,$size,$won,$lost) = unpack('n4', $buffer);
- if ($size > 0) {
- my $score = $won - $lost;
- $response .= "$teamName[$team]:$score($won-$lost) ";
- }
- }
-
- # get the players
- for (1..$numPlayers) {
- last unless read(S1, $buffer, 175) == 175;
- my ($playerlen,$playercode,$pID,$type,$team,$won,$lost,$tks,$sign,$email) =
- unpack('n2Cn5A32A128', $buffer);
- #my ($playerlen,$playercode,$pAddr,$pPort,$pNum,$type,$team,$won,$lost,$sign,$email) =
- # unpack("n2Nn2 n4A32A128", $buffer);
- return 'bad player data' unless $playercode == 0x6170;
- my $score = $won - $lost;
- $response .= " $sign($teamName[$team]";
- $response .= ":$email" if ($email);
- $response .= ")$score($won-$lost)";
- }
- $response .= "No Players" if ($numPlayers < 1);
-
- # close socket
- } elsif ($major == 1 && $minor == 9) {
- # 1.10.x handled here
- $revision = $something * 10 + $revision;
- return 'read error' unless read(S1, $buffer, 1) == 1;
- my ($id) = unpack('C', $buffer);
-
- # send game request
- print S1 pack('n2', 0, 0x7167);
-
- # FIXME the packets are wrong from here down
- # get reply
- return 'server read error' unless read(S1, $buffer, 40) == 40;
- my ($infolen,$infocode,$style,$maxPlayers,$maxShots,
- $rogueSize,$redSize,$greenSize,$blueSize,$purpleSize,
- $rogueMax,$redMax,$greenMax,$blueMax,$purpleMax,
- $shakeWins,$shakeTimeout,
- $maxPlayerScore,$maxTeamScore,$maxTime) = unpack('n20', $buffer);
- return 'bad server data' unless $infocode == 0x7167;
-
- # send players request
- print S1 pack('n2', 0, 0x7170);
-
- # get number of teams and players we'll be receiving
- return 'count read error' unless read(S1, $buffer, 8) == 8;
- my ($countlen,$countcode,$numTeams,$numPlayers) = unpack('n4', $buffer);
-
- # get the teams
- return 'bad count data' unless $countcode == 0x7170;
- return 'count read error' unless read(S1, $buffer, 5) == 5;
- ($countlen,$countcode,$numTeams) = unpack("n n C", $buffer);
- for (1..$numTeams) {
- return 'team read error' unless read(S1, $buffer, 8) == 8;
- my ($team,$size,$won,$lost) = unpack('n4', $buffer);
- if ($size > 0) {
- my $score = $won - $lost;
- $response .= "$teamName[$team]:$score($won-$lost) ";
- }
- }
-
- # get the players
- for (1..$numPlayers) {
- last unless read(S1, $buffer, 175) == 175;
- my ($playerlen,$playercode,$pID,$type,$team,$won,$lost,$tks,$sign,$email) =
- unpack('n2Cn5A32A128', $buffer);
- #my ($playerlen,$playercode,$pAddr,$pPort,$pNum,$type,$team,$won,$lost,$sign,$email) =
- # unpack("n2Nn2 n4A32A128", $buffer);
- return 'bad player data' unless $playercode == 0x6170;
- my $score = $won - $lost;
- $response .= " $sign($teamName[$team]";
- $response .= ":$email" if ($email);
- $response .= ")$score($won-$lost)";
- }
- $response .= "No Players" if ($numPlayers < 1);
-
- # close socket
- close(S1);
- } elsif ($major == 1 && $minor == 0 && $something == 7) {
- # 1.7* versions handled here
- # old servers send a reconnect port number
- return 'read error' unless read(S1, $buffer, 2) == 2;
- my ($reconnect) = unpack('n', $buffer);
- $minor = $minor * 10 + $something;
- # quit if rejected
- return 'rejected by server' if ($reconnect == 0);
-
- # reconnect on new port
- $server = pack($sockaddr, AF_INET, $reconnect, $serveraddr);
- return 'socket() error on reconnect' unless socket(S, AF_INET, SOCK_STREAM, $proto);
- return "could not reconnect to $servername:$reconnect" unless connect(S, $server);
- select(S); $| = 1; select(STDOUT);
-
- # close first socket
- close(S1);
-
- # send game request
- print S pack('n2', 0, 0x7167);
-
- # get reply
- return 'server read error' unless read(S, $buffer, 40) == 40;
- my ($infolen,$infocode,$style,$maxPlayers,$maxShots,
- $rogueSize,$redSize,$greenSize,$blueSize,$purpleSize,
- $rogueMax,$redMax,$greenMax,$blueMax,$purpleMax,
- $shakeWins,$shakeTimeout,
- $maxPlayerScore,$maxTeamScore,$maxTime) = unpack('n20', $buffer);
- return 'bad server data' unless $infocode == 0x7167;
-
- # send players request
- print S pack('n2', 0, 0x7170);
-
- # get number of teams and players we'll be receiving
- return 'count read error' unless read(S, $buffer, 8) == 8;
- my ($countlen,$countcode,$numTeams,$numPlayers) = unpack('n4', $buffer);
- return 'bad count data' unless $countcode == 0x7170;
-
- # get the teams
- for (1..$numTeams) {
- return 'team read error' unless read(S, $buffer, 14) == 14;
- my ($teamlen,$teamcode,$team,$size,$aSize,$won,$lost) = unpack('n7', $buffer);
- return 'bad team data' unless $teamcode == 0x7475;
- if ($size > 0) {
- my $score = $won - $lost;
- $response .= "$teamName[$team]:$score($won-$lost) ";
- }
- }
-
- # get the players
- for (1..$numPlayers) {
- last unless read(S, $buffer, 180) == 180;
- my ($playerlen,$playercode,$pAddr,$pPort,$pNum,$type,$team,$won,$lost,$sign,$email) =
- unpack("n2Nn2 n4A32A128", $buffer);
- return 'bad player data' unless $playercode == 0x6170;
- my $score = $won - $lost;
- $response .= " $sign($teamName[$team]";
- $response .= ":$email" if ($email);
- $response .= ")$score($won-$lost)";
- }
- $response .= "No Players" if ($numPlayers <= 1);
-
- # close socket
- close(S);
- } else {
- $response = "incompatible version: $version";
- }
-
- return $response;
-}
-
-sub query {
- my ($servernameport) = @_;
- &::performStrictReply(&querytext($servernameport));
- return;
-}
-
-1;
-# vim: ts=2 sw=2
+++ /dev/null
-#
-# Debian.pl: Frontend to debian contents and packages files
-# Author: dms
-# Version: v0.8 (20000918)
-# Created: 20000106
-#
-
-package Debian;
-
-use strict;
-no strict 'refs'; # FIXME: dstats aborts if set
-
-my $announce = 0;
-my $defaultdist = 'sid';
-my $refresh = &::getChanConfDefault('debianRefreshInterval', 7, $::chan) * 60 * 60 * 24;
-my $debug = 0;
-my $debian_dir = $::bot_state_dir . '/debian';
-my $country = 'nl'; # well .config it yourself then. ;-)
-my $protocol = 'http';
-# EDIT THIS (i386, amd64, powerpc, [etc.]):
-my $arch = "$arch";
-
-# format: "alias=real".
-my %dists = (
- 'unstable' => 'sid',
- 'testing' => 'lenny',
- 'stable' => 'etch',
- 'oldstable' => 'sarge',
- 'incoming' => 'incoming',
-);
-
-my %urlcontents = (
- "Contents-##DIST-$arch.gz" =>
- "$protocol://ftp.$country.debian.org".
- "/debian/dists/##DIST/Contents-$arch.gz",
- "Contents-##DIST-$arch-non-US.gz" =>
- "$protocol://non-us.debian.org".
- "/debian-non-US/dists/##DIST/non-US/Contents-$arch.gz",
-);
-
-my %urlpackages = (
- "Packages-##DIST-main-$arch.gz" =>
- "$protocol://ftp.$country.debian.org".
- "/debian/dists/##DIST/main/binary-$arch/Packages.gz",
- "Packages-##DIST-contrib-$arch.gz" =>
- "$protocol://ftp.$country.debian.org".
- "/debian/dists/##DIST/contrib/binary-$arch/Packages.gz",
- "Packages-##DIST-non-free-$arch.gz" =>
- "$protocol://ftp.$country.debian.org".
- "/debian/dists/##DIST/non-free/binary-$arch/Packages.gz",
-);
-
-#####################
-### COMMON FUNCTION....
-#######################
-
-####
-# Usage: &DebianDownload($dist, %hash);
-sub DebianDownload {
- my ($dist, %urls) = @_;
- my $bad = 0;
- my $good = 0;
-
- if (! -d $debian_dir) {
- &::status("Debian: creating debian dir.");
- mkdir($debian_dir, 0755);
- }
-
- # fe dists.
- # Download the files.
- my $file;
- foreach $file (keys %urls) {
- my $url = $urls{$file};
- $url =~ s/##DIST/$dist/g;
- $file =~ s/##DIST/$dist/g;
- my $update = 0;
-
- if ( -f $file ) {
- my $last_refresh = (stat $file)[9];
- $update++ if (time() - $last_refresh > $refresh);
- } else {
- $update++;
- }
-
- next unless ($update);
-
- &::DEBUG("announce == $announce.") if ($debug);
- if ($good + $bad == 0 and !$announce) {
- &::status("Debian: Downloading files for '$dist'.");
- &::msg($::who, "Updating debian files... please wait.");
- $announce++;
- }
-
- if (exists $::debian{$url}) {
- &::DEBUG("2: ".(time - $::debian{$url})." <= $refresh") if ($debug);
- next if (time() - $::debian{$url} <= $refresh);
- &::DEBUG("stale for url $url; updating!") if ($debug);
- }
-
- if ($url =~ /^ftp:\/\/(.*?)\/(\S+)\/(\S+)$/) {
- my ($host,$path,$thisfile) = ($1,$2,$3);
-
- if (!&::ftpGet($host,$path,$thisfile,$file)) {
- &::WARN("deb: down: $file == BAD.");
- $bad++;
- next;
- }
-
- } elsif ($url =~ /^http:\/\/\S+\/\S+$/) {
-
- if (!&::getURLAsFile($url,$file)) {
- &::WARN("deb: down: http: $file == BAD.");
- $bad++;
- next;
- }
-
- } else {
- &::ERROR("Debian: invalid format of url => ($url).");
- $bad++;
- next;
- }
-
- if (! -f $file) {
- &::WARN("deb: down: http: !file");
- $bad++;
- next;
- }
-
-# my $exit = system("/bin/gzip -t $file");
-# if ($exit) {
-# &::WARN("deb: $file is corrupted ($exit) :/");
-# unlink $file;
-# next;
-# }
-
- &::DEBUG("deb: download: good.") if ($debug);
- $good++;
- }
-
- # ok... lets just run this.
- &::miscCheck() if (&::whatInterface() =~ /IRC/);
-
- if ($good) {
- &generateIndex($dist);
- return 1;
- } else {
- return -1 unless ($bad); # no download.
- &::DEBUG("DD: !good and bad($bad). :(");
- return 0;
- }
-}
-
-###########################
-# DEBIAN CONTENTS SEARCH FUNCTIONS.
-########
-
-####
-# Usage: &searchContents($query);
-sub searchContents {
- my ($dist, $query) = &getDistroFromStr($_[0]);
- &::status("Debian: Contents search for '$query' in '$dist'.");
- my $dccsend = 0;
-
- $dccsend++ if ($query =~ s/^dcc\s+//i);
-
- $query =~ s/\\([\^\$])/$1/g; # hrm?
- $query =~ s/^\s+|\s+$//g;
-
- if (!&::validExec($query)) {
- &::msg($::who, 'search string looks fuzzy.');
- return;
- }
-
- if ($dist eq 'incoming') { # nothing yet.
- &::DEBUG('sC: dist = "incoming". no contents yet.');
- return;
- } else {
- my %urls = &fixDist($dist, %urlcontents);
- # download contents file.
- &::DEBUG('deb: download 1.') if ($debug);
- if (!&DebianDownload($dist, %urls)) {
- &::WARN('Debian: could not download files.');
- }
- }
-
- # start of search.
- my $start_time = &::timeget();
-
- my $found = 0;
- my $front = 0;
- my %contents;
- my $grepRE;
- ### TODO: search properly if /usr/bin/blah is done.
- if ($query =~ s/\$$//) {
- &::DEBUG("deb: search-regex found.") if ($debug);
- $grepRE = "$query\[ \t]";
- } elsif ($query =~ s/^\^//) {
- &::DEBUG("deb: front marker regex found.") if ($debug);
- $front = 1;
- $grepRE = $query;
- } else {
- $grepRE = "$query*\[ \t]";
- }
-
- # fix up grepRE for "*".
- $grepRE =~ s/\*/.*/g;
-
- my @files;
- foreach (keys %urlcontents) {
- s/##DIST/$dist/g;
-
- next unless ( -f "$debian_dir/$_" );
- push(@files, "$debian_dir/$_");
- }
-
- if (!scalar @files) {
- &::ERROR("sC: no files?");
- &::msg($::who, "failed.");
- return;
- }
-
- my $files = join(' ', @files);
-
- my $regex = $query;
- $regex =~ s/\./\\./g;
- $regex =~ s/\*/\\S*/g;
- $regex =~ s/\?/./g;
-
- open(IN,"zegrep -h '$grepRE' $files |");
- # wonderful abuse of if, last, next, return, and, unless ;)
- while (<IN>) {
- last if ($found > 100);
-
- next unless (/^\.?\/?(.*?)[\t\s]+(\S+)\n$/);
- my ($file,$package) = ("/".$1,$2);
-
- if ($query =~ /[\/\*\\]/) {
- next unless (eval { $file =~ /$regex/ });
- return unless &checkEval($@);
- } else {
- my ($basename) = $file =~ /^.*\/(.*)$/;
- next unless (eval { $basename =~ /$regex/ });
- return unless &checkEval($@);
- }
- next if ($query !~ /\.\d\.gz/ and $file =~ /\/man\//);
- next if ($front and eval { $file !~ /^\/$query/ });
- return unless &checkEval($@);
-
- $contents{$package}{$file} = 1;
- $found++;
- }
- close IN;
-
- my $pkg;
-
- ### send results with dcc.
- if ($dccsend) {
- if (exists $::dcc{'SEND'}{$::who}) {
- &::msg($::who, "DCC already active!");
- return;
- }
-
- if (!scalar %contents) {
- &::msg($::who,"search returned no results.");
- return;
- }
-
- my $file = "$::param{tempDir}/$::who.txt";
- if (!open OUT, ">$file") {
- &::ERROR("Debian: cannot write file for dcc send.");
- return;
- }
-
- foreach $pkg (keys %contents) {
- foreach (keys %{ $contents{$pkg} }) {
- # TODO: correct padding.
- print OUT "$_\t\t\t$pkg\n";
- }
- }
- close OUT;
-
- &::shmWrite($::shm, "DCC SEND $::who $file");
-
- return;
- }
-
- &::status("Debian: $found contents results found.");
-
- my @list;
- foreach $pkg (keys %contents) {
- my @tmplist = &::fixFileList(keys %{ $contents{$pkg} });
- my @sublist = sort { length $a <=> length $b } @tmplist;
-
- pop @sublist while (scalar @sublist > 3);
-
- $pkg =~ s/\,/\037\,\037/g; # underline ','.
- push(@list, "(". join(', ',@sublist) .") in $pkg");
- }
- # sort the total list from shortest to longest...
- @list = sort { length $a <=> length $b } @list;
-
- # show how long it took.
- my $delta_time = &::timedelta($start_time);
- &::status(sprintf("Debian: %.02f sec to complete query.", $delta_time)) if ($delta_time > 0);
-
- my $prefix = "Debian Search of '$query' ";
- if (scalar @list) { # @list.
- &::performStrictReply( &::formListReply(0, $prefix, @list) );
- return;
- }
-
- # !@list.
- &::DEBUG("deb: ok, !\@list, searching desc for '$query'.") if ($debug);
- @list = &searchDesc($query);
-
- if (!scalar @list) {
- my $prefix = "Debian Package/File/Desc Search of '$query' ";
- &::performStrictReply( &::formListReply(0, $prefix, ) );
-
- } elsif (scalar @list == 1) { # list = 1.
- &::DEBUG("deb: list == 1; showing package info of '$list[0]'.");
- &infoPackages("info", $list[0]);
-
- } else { # list > 1.
- my $prefix = "Debian Desc Search of '$query' ";
- &::performStrictReply( &::formListReply(0, $prefix, @list) );
- }
-}
-
-####
-# Usage: &searchAuthor($query);
-sub searchAuthor {
- my ($dist, $query) = &getDistroFromStr($_[0]);
- &::DEBUG("deb: searchAuthor: dist => '$dist', query => '$query'.") if ($debug);
- $query =~ s/^\s+|\s+$//g;
-
- # start of search.
- my $start_time = &::timeget();
- &::status("Debian: starting author search.");
-
- my $files;
- my ($bad,$good) = (0,0);
- my %urls = %urlpackages;
-
- foreach (keys %urlpackages) {
- s/##DIST/$dist/g;
-
- if (! -f "$debian_dir/$_" ) {
- $bad++;
- next;
- }
-
- $good++;
- $files .= " ".$_;
- }
-
- &::DEBUG("deb: good = $good, bad = $bad...") if ($debug);
-
- if ($good == 0 and $bad != 0) {
- my %urls = &fixDist($dist, %urlpackages);
- &::DEBUG("deb: download 2.");
-
- if (!&DebianDownload($dist, %urls)) {
- &::ERROR("Debian(sA): could not download files.");
- return;
- }
- }
-
- my (%maint, %pkg, $package);
- open(IN,"zegrep -h '^Package|^Maintainer' $files |");
- while (<IN>) {
- if (/^Package: (\S+)$/) {
- $package = $1;
-
- } elsif (/^Maintainer: (.*) \<(\S+)\>$/) {
- my($name,$email) = ($1,$2);
- if ($package eq "") {
- &::DEBUG("deb: sA: package == NULL.");
- next;
- }
- $maint{$name}{$email} = 1;
- $pkg{$name}{$package} = 1;
- $package = "";
-
- } else {
- chop;
- &::WARN("debian: invalid line: '$_' (1).");
- }
- }
- close IN;
-
- my %hash;
- # TODO: can we use 'map' here?
- foreach (grep /\Q$query\E/i, keys %maint) {
- $hash{$_} = 1;
- }
-
- # TODO: should we only search email if '@' is used?
- if (scalar keys %hash < 15) {
- my $name;
-
- foreach $name (keys %maint) {
- my $email;
-
- foreach $email (keys %{ $maint{$name} }) {
- next unless ($email =~ /\Q$query\E/i);
- next if (exists $hash{$name});
- $hash{$name} = 1;
- }
- }
- }
-
- my @list = keys %hash;
- if (scalar @list != 1) {
- my $prefix = "Debian Author Search of '$query' ";
- &::performStrictReply( &::formListReply(0, $prefix, @list) );
- return 1;
- }
-
- &::DEBUG("deb: showing all packages by '$list[0]'...") if ($debug);
-
- my @pkg = sort keys %{ $pkg{$list[0]} };
-
- # show how long it took.
- my $delta_time = &::timedelta($start_time);
- &::status(sprintf("Debian: %.02f sec to complete query.", $delta_time)) if ($delta_time > 0);
-
- my $email = join(', ', keys %{ $maint{$list[0]} });
- my $prefix = "Debian Packages by $list[0] \002<\002$email\002>\002 ";
- &::performStrictReply( &::formListReply(0, $prefix, @pkg) );
-}
-
-####
-# Usage: &searchDesc($query);
-sub searchDesc {
- my ($dist, $query) = &getDistroFromStr($_[0]);
- &::DEBUG("deb: searchDesc: dist => '$dist', query => '$query'.") if ($debug);
- $query =~ s/^\s+|\s+$//g;
-
- # start of search.
- my $start_time = &::timeget();
- &::status("Debian: starting desc search.");
-
- my $files;
- my ($bad,$good) = (0,0);
- my %urls = %urlpackages;
-
- foreach (keys %urlpackages) {
- s/##DIST/$dist/g;
-
- if (! -f "$debian_dir/$_" ) {
- $bad++;
- next;
- }
-
- $good++;
- $files .= " $debian_dir/$_";
- }
-
- &::DEBUG("deb(2): good = $good, bad = $bad...") if ($debug);
-
- if ($good == 0 and $bad != 0) {
- my %urls = &fixDist($dist, %urlpackages);
- &::DEBUG("deb: download 2c.") if ($debug);
-
- if (!&DebianDownload($dist, %urls)) {
- &::ERROR("deb: sD: could not download files.");
- return;
- }
- }
-
- my $regex = $query;
- $regex =~ s/\./\\./g;
- $regex =~ s/\*/\\S*/g;
- $regex =~ s/\?/./g;
-
- my (%desc, $package);
- open(IN,"zegrep -h '^Package|^Description' $files |");
- while (<IN>) {
- if (/^Package: (\S+)$/) {
- $package = $1;
- } elsif (/^Description: (.*)$/) {
- my $desc = $1;
- next unless (eval { $desc =~ /$regex/i });
- return unless &checkEval($@);
-
- if ($package eq "") {
- &::WARN("sD: package == NULL?");
- next;
- }
-
- $desc{$package} = $desc;
- $package = "";
-
- } else {
- chop;
- &::WARN("debian: invalid line: '$_'. (2)");
- }
- }
- close IN;
-
- # show how long it took.
- my $delta_time = &::timedelta($start_time);
- &::status(sprintf("Debian: %.02f sec to complete query.", $delta_time)) if ($delta_time > 0);
-
- return keys %desc;
-}
-
-####
-# Usage: &generateIncoming();
-sub generateIncoming {
- my $pkgfile = $debian_dir."/Packages-incoming";
- my $idxfile = $pkgfile.".idx";
- my $stale = 0;
- $stale++ if (&::isStale($pkgfile.".gz", $refresh));
- $stale++ if (&::isStale($idxfile, $refresh));
- &::DEBUG("deb: gI: stale => '$stale'.") if ($debug);
- return 0 unless ($stale);
-
- ### STATIC URL.
- my %ftp = &::ftpList("llug.sep.bnl.gov", "/pub/debian/Incoming/");
-
- if (!open PKG, ">$pkgfile") {
- &::ERROR("cannot write to pkg $pkgfile.");
- return 0;
- }
- if (!open IDX, ">$idxfile") {
- &::ERROR("cannot write to idx $idxfile.");
- return 0;
- }
-
- print IDX "*$pkgfile.gz\n";
- my $file;
- foreach $file (sort keys %ftp) {
- next unless ($file =~ /deb$/);
-
- if ($file =~ /^(\S+)\_(\S+)\_(\S+)\.deb$/) {
- print IDX "$1\n";
- print PKG "Package: $1\n";
- print PKG "Version: $2\n";
- print PKG "Architecture: ", (defined $4) ? $4 : "all", "\n";
- }
- print PKG "Filename: $file\n";
- print PKG "Size: $ftp{$file}\n";
- print PKG "\n";
- }
- close IDX;
- close PKG;
-
- system("gzip -9fv $pkgfile"); # lame fix.
-
- &::status("Debian: generateIncoming() complete.");
-}
-
-
-##############################
-# DEBIAN PACKAGE INFO FUNCTIONS.
-#########
-
-# Usage: &getPackageInfo($query,$file);
-sub getPackageInfo {
- my ($package, $file) = @_;
-
- if (! -f $file) {
- &::status("gPI: file $file does not exist?");
- return 'NULL';
- }
-
- my $found = 0;
- my (%pkg, $pkg);
-
- open(IN, "/bin/zcat $file 2>&1 |");
-
- my $done = 0;
- while (!eof IN) {
- $_ = <IN>;
-
- next if (/^ \S+/); # package long description.
-
- # package line.
- if (/^Package: (.*)\n$/) {
- $pkg = $1;
- if ($pkg =~ /^\Q$package\E$/i) {
- $found++; # we can use pkg{'package'} instead.
- $pkg{'package'} = $pkg;
- }
-
- next;
- }
-
- if ($found) {
- chop;
-
- if (/^Version: (.*)$/) {
- $pkg{'version'} = $1;
- } elsif (/^Priority: (.*)$/) {
- $pkg{'priority'} = $1;
- } elsif (/^Section: (.*)$/) {
- $pkg{'section'} = $1;
- } elsif (/^Size: (.*)$/) {
- $pkg{'size'} = $1;
- } elsif (/^Installed-Size: (.*)$/i) {
- $pkg{'installed'} = $1;
- } elsif (/^Description: (.*)$/) {
- $pkg{'desc'} = $1;
- } elsif (/^Filename: (.*)$/) {
- $pkg{'find'} = $1;
- } elsif (/^Pre-Depends: (.*)$/) {
- $pkg{'depends'} = "pre-depends on $1";
- } elsif (/^Depends: (.*)$/) {
- if (exists $pkg{'depends'}) {
- $pkg{'depends'} .= "; depends on $1";
- } else {
- $pkg{'depends'} = "depends on $1";
- }
- } elsif (/^Maintainer: (.*)$/) {
- $pkg{'maint'} = $1;
- } elsif (/^Provides: (.*)$/) {
- $pkg{'provides'} = $1;
- } elsif (/^Suggests: (.*)$/) {
- $pkg{'suggests'} = $1;
- } elsif (/^Conflicts: (.*)$/) {
- $pkg{'conflicts'} = $1;
- }
-
-### &::DEBUG("=> '$_'.");
- }
-
- # blank line.
- if (/^$/) {
- undef $pkg;
- last if ($found);
- next;
- }
-
- next if (defined $pkg);
- }
-
- close IN;
-
- %pkg;
-}
-
-# Usage: &infoPackages($query,$package);
-sub infoPackages {
- my ($query,$dist,$package) = ($_[0], &getDistroFromStr($_[1]));
-
- &::status("Debian: Searching for package '$package' in '$dist'.");
-
- # download packages file.
- # hrm...
- my %urls = &fixDist($dist, %urlpackages);
- if ($dist ne "incoming") {
- &::DEBUG("deb: download 3.") if ($debug);
-
- if (!&DebianDownload($dist, %urls)) { # no good download.
- &::WARN("Debian(iP): could not download ANY files.");
- }
- }
-
- # check if the package is valid.
- my $incoming = 0;
- my @files = &validPackage($package, $dist);
- if (!scalar @files) {
- &::status("Debian: no valid package found; checking incoming.");
- @files = &validPackage($package, "incoming");
-
- if (scalar @files) {
- &::status("Debian: cool, it exists in incoming.");
- $incoming++;
- } else {
- &::msg($::who, "Package '$package' does not exist.");
- return 0;
- }
- }
-
- if (scalar @files > 1) {
- &::WARN("same package in more than one file; random.");
- &::DEBUG("THIS SHOULD BE FIXED SOMEHOW!!!");
- $files[0] = &::getRandom(@files);
- }
-
- if (! -f $files[0]) {
- &::WARN("files[0] ($files[0]) doesn't exist.");
- &::msg($::who, "FIXME: $files[0] does not exist?");
- return 'NULL';
- }
-
- ### TODO: if specific package is requested, note down that a version
- ### exists in incoming.
-
- my $found = 0;
- my $file = $files[0];
- my ($pkg);
-
- ### TODO: use fe, dump to a hash. if only one version of the package
- ### exists. do as normal otherwise list all versions.
- if (! -f $file) {
- &::ERROR("D:iP: file '$file' DOES NOT EXIST!!! should never happen.");
- return 0;
- }
- my %pkg = &getPackageInfo($package, $file);
-
- $query = "info" if ($query eq "dinfo");
-
- # 'fm'-like output.
- if ($query eq "info") {
- if (scalar keys %pkg <= 5) {
- &::DEBUG("deb: running debianCheck() due to problems (".scalar(keys %pkg).").");
- &debianCheck();
- &::DEBUG("deb: end of debianCheck()");
-
- &::msg($::who,"Debian: Package appears to exist but I could not retrieve info about it...");
- return;
- }
-
- $pkg{'info'} = "\002(\002". $pkg{'desc'} ."\002)\002";
- $pkg{'info'} .= ", section ".$pkg{'section'};
- $pkg{'info'} .= ", is ".$pkg{'priority'};
-# $pkg{'info'} .= ". Version: \002$pkg{'version'}\002";
- $pkg{'info'} .= ". Version: \002$pkg{'version'}\002 ($dist)";
- $pkg{'info'} .= ", Packaged size: \002". int($pkg{'size'}/1024) ."\002 kB";
- $pkg{'info'} .= ", Installed size: \002$pkg{'installed'}\002 kB";
-
- if ($incoming) {
- &::status("iP: info requested and pkg is in incoming, too.");
- my %incpkg = &getPackageInfo($query, $debian_dir ."/Packages-incoming");
-
- if (scalar keys %incpkg) {
- $pkg{'info'} .= ". Is in incoming ($incpkg{'file'}).";
- } else {
- &::ERROR("iP: pkg $query is in incoming but we couldn't get any info?");
- }
- }
- }
-
- if ($dist eq "incoming") {
- $pkg{'info'} .= "Version: \002$pkg{'version'}\002";
- $pkg{'info'} .= ", Packaged size: \002". int($pkg{'size'}/1024) ."\002 kB";
- $pkg{'info'} .= ", is in incoming!!!";
- }
-
- if (!exists $pkg{$query}) {
- if ($query eq "suggests") {
- $pkg{$query} = "has no suggestions";
- } elsif ($query eq "conflicts") {
- $pkg{$query} = "does not conflict with any other package";
- } elsif ($query eq "depends") {
- $pkg{$query} = "does not depend on anything";
- } elsif ($query eq "maint") {
- $pkg{$query} = "has no maintainer";
- } else {
- $pkg{$query} = "has nothing about $query";
- }
- }
-
- &::performStrictReply("$package: $pkg{$query}");
-}
-
-# Usage: &infoStats($dist);
-sub infoStats {
- my ($dist) = @_;
- $dist = &getDistro($dist);
- return unless (defined $dist);
-
- &::DEBUG("deb: infoS: dist => '$dist'.");
-
- # download packages file if needed.
- my %urls = &fixDist($dist, %urlpackages);
- &::DEBUG("deb: download 4.");
- if (!&DebianDownload($dist, %urls)) {
- &::WARN("Debian(iS): could not download ANY files.");
- &::msg($::who, "Debian(iS): internal error.");
- return;
- }
-
- my %stats;
- my %total = (count => 0, maint => 0, isize => 0, csize => 0);
- my $file;
- foreach $file (keys %urlpackages) {
- $file =~ s/##DIST/$dist/g; # won't work for incoming.
- &::DEBUG("deb: file => '$file'.");
- if (exists $stats{$file}{'count'}) {
- &::DEBUG("deb: hrm... duplicate open with $file???");
- next;
- }
-
- open(IN, "zcat $debian_dir/$file 2>&1 |");
-
- if (! -e "$debian_dir/$file") {
- &::DEBUG("deb: iS: $debian_dir/$file does not exist.");
- next;
- }
-
- while (!eof IN) {
- $_ = <IN>;
-
- next if (/^ \S+/); # package long description.
-
- if (/^Package: (.*)\n$/) { # counter.
- $stats{$file}{'count'}++;
- $total{'count'}++;
- } elsif (/^Maintainer: .* <(\S+)>$/) {
- $stats{$file}{'maint'}{$1}++;
- $total{'maint'}{$1}++;
- } elsif (/^Size: (.*)$/) { # compressed size.
- $stats{$file}{'csize'} += $1;
- $total{'csize'} += $1;
- } elsif (/^i.*size: (.*)$/i) { # installed size.
- $stats{$file}{'isize'} += $1;
- $total{'isize'} += $1;
- }
-
-### &::DEBUG("=> '$_'.");
- }
- close IN;
- }
-
- ### TODO: don't count ppl with multiple email addresses.
-
- &::performStrictReply(
- "Debian Distro Stats on $dist... ".
- "\002$total{'count'}\002 packages, ".
- "\002".scalar(keys %{ $total{'maint'} })."\002 maintainers, ".
- "\002". int($total{'isize'}/1024)."\002 MB installed size, ".
- "\002". int($total{'csize'}/1024/1024)."\002 MB compressed size."
- );
-
-### TODO: do individual stats? if so, we need _another_ arg.
-# foreach $file (keys %stats) {
-# foreach (keys %{ $stats{$file} }) {
-# &::DEBUG(" '$file' '$_' '$stats{$file}{$_}'.");
-# }
-# }
-
- return;
-}
-
-###
-# HELPER FUNCTIONS FOR INFOPACKAGES...
-###
-
-# Usage: &generateIndex();
-sub generateIndex {
- my (@dists) = @_;
- &::DEBUG("D: generateIndex($dists[0]) called!");
- if (!scalar @dists or $dists[0] eq '') {
- &::ERROR("gI: no dists to generate index.");
- return 1;
- }
-
- foreach (@dists) {
- my $dist = &getDistro($_); # incase the alias is returned, possible?
- my $idx = $debian_dir."/Packages-$dist.idx";
-
- # TODO: check if any of the Packages file have been updated then
- # regenerate it, even if it's not stale.
- # TODO: also, regenerate the index if the packages file is newer
- # than the index.
- next unless (&::isStale($idx, $refresh));
-
- if (/^incoming$/i) {
- &::DEBUG("deb: gIndex: calling generateIncoming()!");
- &generateIncoming();
- next;
- }
-
- if (/^woody$/i) {
- &::DEBUG("deb: Copying old index of woody to -old");
- system("cp $idx $idx-old");
- }
-
- &::DEBUG("deb: gIndex: calling DebianDownload($dist, ...).") if ($debug);
- &DebianDownload($dist, &fixDist($dist, %urlpackages) );
-
- &::status("Debian: generating index for '$dist'.");
- if (!open OUT, ">$idx") {
- &::ERROR("cannot write to $idx.");
- return 0;
- }
-
- my $packages;
- foreach $packages (keys %urlpackages) {
- $packages =~ s/##DIST/$dist/;
- $packages = "$debian_dir/$packages";
-
- if (! -e $packages) {
- &::ERROR("gIndex: '$packages' does not exist?");
- next;
- }
-
- print OUT "*$packages\n";
- open(IN,"zcat $packages |");
-
- while (<IN>) {
- next unless (/^Package: (.*)\n$/);
- print OUT $1."\n";
- }
- close IN;
- }
- close OUT;
- }
-
- return 1;
-}
-
-# Usage: &validPackage($package, $dist);
-sub validPackage {
- my ($package,$dist) = @_;
- my @files;
- my $file;
-
- ### this majorly sucks, we need some standard in place.
- # why is this needed... need to investigate later.
- my $olddist = $dist;
- $dist = &getDistro($dist);
-
- &::DEBUG("deb: validPackage($package, $dist) called.") if ($debug);
-
- my $error = 0;
- while (!open IN, $debian_dir."/Packages-$dist.idx") {
- if ($error) {
- &::ERROR("Packages-$dist.idx does not exist (#1).");
- return;
- }
-
- &generateIndex($dist);
-
- $error++;
- }
-
- my $count = 0;
- while (<IN>) {
- if (/^\*(.*)\n$/) {
- $file = $1;
- next;
- }
-
- if (/^\Q$package\E\n$/) {
- push(@files,$file);
- }
- $count++;
- }
- close IN;
-
- &::VERB("vP: scanned $count items in index.",2);
-
- return @files;
-}
-
-sub searchPackage {
- my ($dist, $query) = &getDistroFromStr($_[0]);
- my $file = $debian_dir."/Packages-$dist.idx";
- my $warn = ($query =~ tr/A-Z/a-z/) ? 1 : 0;
- my $error = 0;
- my @files;
-
- &::status("Debian: Search package matching '$query' in '$dist'.");
- unlink $file if ( -z $file );
-
- while (!open IN, $file) {
- if ($dist eq "incoming") {
- &::DEBUG("deb: sP: dist == incoming; calling gI().");
- &generateIncoming();
- }
-
- if ($error) {
- &::ERROR("could not generate index ($file)!");
- return;
- }
-
- $error++;
- &::DEBUG("deb: should we be doing this?");
- &generateIndex(($dist));
- }
-
- while (<IN>) {
- chop;
-
- if (/^\*(.*)$/) {
- $file = $1;
-
- if (&::isStale($file, $refresh)) {
- &::DEBUG("deb: STALE $file! regen.") if ($debug);
- &generateIndex(($dist));
-### @files = searchPackage("$query $dist");
- &::DEBUG("deb: EVIL HACK HACK HACK.") if ($debug);
- last;
- }
-
- next;
- }
-
- if (/\Q$query\E/) {
- push(@files,$_);
- }
- }
- close IN;
-
- if (scalar @files and $warn) {
- &::msg($::who, "searching for package name should be fully lowercase!");
- }
-
- return @files;
-}
-
-sub getDistro {
- my $dist = $_[0];
-
- if (!defined $dist or $dist eq "") {
- &::DEBUG("deb: gD: dist == NULL; dist = defaultdist.");
- $dist = $defaultdist;
- }
-
- if ($dist =~ /^(slink|hamm|rex|bo)$/i) {
- &::DEBUG("deb: deprecated version ($dist).");
- &::msg($::who, "Debian: deprecated distribution version.");
- return;
- }
-
- if (exists $dists{$dist}) {
- &::VERB("gD: returning dists{$dist} ($dists{$dist})",2);
- return $dists{$dist};
-
- } else {
- if (!grep /^\Q$dist\E$/i, %dists) {
- &::msg($::who, "invalid dist '$dist'.");
- return;
- }
-
- &::VERB("gD: returning $dist (no change or conversion)",2);
- return $dist;
- }
-}
-
-sub getDistroFromStr {
- my ($str) = @_;
- my $dists = join '|', %dists;
- my $dist = $defaultdist;
-
- if ($str =~ s/\s+($dists)$//i) {
- $dist = &getDistro(lc $1);
- $str =~ s/\\+$//;
- }
- $str =~ s/\\([\$\^])/$1/g;
-
- return($dist,$str);
-}
-
-sub fixDist {
- my ($dist, %urls) = @_;
- my %new;
- my ($key,$val);
-
- while (($key,$val) = each %urls) {
- $key =~ s/##DIST/$dist/;
- $val =~ s/##DIST/$dist/;
- ### TODO: what should we do if the sar wasn't done.
- $new{$debian_dir."/".$key} = $val;
- }
-
- return %new;
-}
-
-sub DebianFind {
- # HACK! HACK! HACK!
- my ($str) = @_;
- my ($dist, $query) = &getDistroFromStr($str);
- my @results = sort &searchPackage($str);
-
- if (!scalar @results) {
- &::Forker("Debian", sub { &searchContents($str); } );
- } elsif (scalar @results == 1) {
- &::status("searchPackage returned one result; getting info of package instead!");
- &::Forker("Debian", sub { &infoPackages("info", "$results[0] $dist"); } );
- } else {
- my $prefix = "Debian Package Listing of '$query' ";
- &::performStrictReply( &::formListReply(0, $prefix, @results) );
- }
-}
-
-sub debianCheck {
- my $error = 0;
-
- &::status("debianCheck() called.");
-
- ### TODO: remove the following loop (check if dir exists before)
- while (1) {
- last if (opendir(DEBIAN, $debian_dir));
-
- if ($error) {
- &::ERROR("dC: cannot opendir debian.");
- return;
- }
-
- mkdir $debian_dir, 0755;
- $error++;
- }
-
- my $retval = 0;
- my $file;
- while (defined($file = readdir DEBIAN)) {
- next unless ($file =~ /(gz|bz2)$/);
-
- # TODO: add bzip2 support (debian doesn't do .bz2 anyway)
- #my $exit = system("/bin/gzip -t '$debian_dir/$file'");
- #next unless ($exit);
- &::DEBUG("deb: hmr... => ".(time() - (stat($file))[8])."'.");
- next unless (time() - (stat($file))[8] > 3600);
-
- #&::DEBUG("deb: dC: exit => '$exit'.");
- &::WARN("dC: '$debian_dir/$file' corrupted? deleting!");
- unlink $debian_dir."/".$file;
- $retval++;
- }
-
- return $retval;
-}
-
-sub checkEval {
- my($str) = @_;
-
- if ($str) {
- &::WARN("cE: $str");
- return 0;
- } else {
- return 1;
- }
-}
-
-sub searchDescFE {
-# &::DEBUG("deb: FE called for searchDesc");
- my ($query) = @_;
- my @list = &searchDesc($query);
-
- if (!scalar @list) {
- my $prefix = "Debian Desc Search of '$query' ";
- &::performStrictReply( &::formListReply(0, $prefix, ) );
- } elsif (scalar @list == 1) { # list = 1.
- &::DEBUG("deb: list == 1; showing package info of '$list[0]'.");
- &infoPackages("info", $list[0]);
- } else { # list > 1.
- my $prefix = "Debian Desc Search of '$query' ";
- &::performStrictReply( &::formListReply(0, $prefix, @list) );
- }
-}
-
-1;
+++ /dev/null
-#
-# DebianExtra.pl: Extra stuff for debian
-# Author: dms
-# Version: v0.1 (20000520)
-# Created: 20000520
-#
-
-use strict;
-
-package DebianExtra;
-
-sub Parse {
- my($args) = @_;
- my($msg) = '';
-
- #&::DEBUG("DebianExtra: $args\n");
- if (!defined $args or $args =~ /^$/) {
- $msg = &debianBugs();
- } elsif ($args =~ /^(\d+)$/) {
- # package number:
- $msg = &do_id($args);
- } elsif ($args =~ /^(\S+\@\S+)$/) {
- # package email maintainer.
- $msg = &do_email($args);
- } elsif ($args =~ /^(\S+)$/) {
- # package name.
- $msg = &do_pkg($args);
- } else {
- # invalid.
- $msg = "error: could not parse $args";
- }
- &::performStrictReply($msg);
-}
-
-sub debianBugs {
- my @results = &::getURL("http://master.debian.org/~wakkerma/bugs");
- my ($date, $rcbugs, $remove);
- my ($bugs_closed, $bugs_opened) = (0,0);
-
- if (scalar @results) {
- foreach (@results) {
- s/<.*?>//g;
- $date = $1 if (/status at (.*)\s*$/);
- $rcbugs = $1 if (/bugs: (\d+)/);
- $remove = $1 if (/REMOVE\S+ (\d+)\s*$/);
- if (/^(\d+) r\S+ b\S+ w\S+ c\S+ a\S+ (\d+)/) {
- $bugs_closed = $1;
- $bugs_opened = $2;
- }
- }
- my $xtxt = ($bugs_closed >=$bugs_opened) ?
- "It's good to see " :
- "Oh no, the bug count is rising -- ";
-
- &::performStrictReply(
- "Debian bugs statistics, last updated on $date... ".
- "There are \002$rcbugs\002 release-critical bugs; $xtxt".
- "\002$bugs_closed\002 bugs closed, opening \002$bugs_opened\002 bugs. ".
- "About \002$remove\002 packages will be removed."
- );
- } else {
- &::msg($::who, "Couldn't retrieve data for debian bug stats.");
- }
-}
-
-sub do_id($){
- my ($bug_num) = shift;
-
- if (not $bug_num =~ /^\#?\d+$/) {
- return "Bug is not a number!";
- }
- $bug_num =~ s/^\#//;
- my @results = &::getURL("http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=$bug_num");
- my $report = join("\n", @results);
-
- # strip down report to relevant header information.
- $report =~ s/\r//sig;
- $report =~ /<BODY[^>]*>(.+?)<HR>/si;
- $report = $1;
- my $bug = {};
- ($bug->{num}, $bug->{title}) = $report =~ m#\#(\d+)\<\/A\>\<BR\>(.+?)\<\/H1\>#is;
- &::DEBUG("Bugnum: $bug->{num}\n");
- $bug->{title} =~ s/</\</g;
- $bug->{title} =~ s/>/\>/g;
- $bug->{title} =~ s/"/\"/g;
- &::DEBUG("Title: $bug->{title}\n");
- $bug->{severity} = 'n'; #Default severity is normal
- my @bug_flags = split /(?<!\&.t);/s, $report;
- foreach my $bug_flag (@bug_flags) {
- $bug_flag =~ s/\n//g;
- &::DEBUG("Bug_flag: $bug_flag\n");
- if ($bug_flag =~ /Severity:/i) {
- ($bug->{severity}) = $bug_flag =~ /(wishlist|minor|normal|important|serious|grave)/i;
- # Just leave the leter instead of the whole thing.
- $bug->{severity} =~ s/^(.).+$/$1/;
- }
- elsif ($bug_flag =~ /Package:/) {
- ($bug->{package}) = $bug_flag =~ /\"\>\s*([^<>]+?)\s*\<\/a\>/;
- # take packagename out of title if it's there
- $bug->{title} =~ s/^$bug->{package}: //;
- }
- elsif ($bug_flag =~ /Reported by:/) {
- ($bug->{reporter}) = $bug_flag =~ /\"\>\s*(.+?)\s*\<\/a\>/;
- # strip < and >
- $bug->{reporter} =~ s/</\</g;
- $bug->{reporter} =~ s/>/\>/g;
- }
- elsif ($bug_flag =~ /Date:/) {
- ($bug->{date}) = $bug_flag =~ /Date:\s*(\w.+?)\s*$/;
- #ditch extra whitespace
- $bug->{date} =~ s/\s{2,}/\ /;
- }
- elsif ($bug_flag =~ /Tags:/) {
- ($bug->{tags}) = $bug_flag =~ /strong\>\s*(.+?)\s*\<\/strong\>/;
- }
- elsif ($bug_flag =~ /merged with /) {
- $bug_flag =~ s/merged with\s*//;
- $bug_flag =~ s/\<[^\>]+\>//g;
- $bug_flag =~ s/\s//sg;
- $bug->{merged_with} = $bug_flag;
-
- }
- elsif ($bug_flag =~ /\>Done:\</) {
- $bug->{done} = 1;
- }
- }
-
- # report bug
-
- $report = '';
- $report .= 'DONE:' if defined $bug->{done} and $bug->{done};
- $report .= '#'.$bug->{num}.':'.uc($bug->{severity}).'['.$bug->{package}.'] '.$bug->{title};
- $report .= ' ('.$bug->{tags}.')' if defined $bug->{tags};
- $report .= ' ' . $bug->{date};
- # Avoid reporting so many merged bugs.
- $report .= ' ['.join(',',splice(@{[split(/,/,$bug->{merged_with})]},0,3)).']' if defined $bug->{merged_with};
- if ($::DEBUG) {
- use Data::Dumper;
- &::DEBUG(Dumper($bug));
- }
- return $report;
-}
-
-sub old_do_id {
- my($num) = @_;
- my $url = "http://bugs.debian.org/$num";
-
- # FIXME
- return "do_id not supported yet.";
-
- my @results = &::getURL($url);
- foreach (@results) {
- &::DEBUG("do_id: $_");
- }
-}
-
-sub do_email {
- my($email) = @_;
- my $url = "http://bugs.debian.org/$email";
-
- # FIXME
- return "do_email not supported yet.";
-
- my @results = &::getURL($url);
- foreach (@results) {
- &::DEBUG("do_email: $_");
- }
-}
-
-sub do_pkg {
- my($pkg) = @_;
- my $url = "http://bugs.debian.org/$pkg";
-
- # FIXME
- return "do_pkg not supported yet.";
-
- my @results = &::getURL($url);
- foreach (@results) {
- &::DEBUG("do_pkg: $_");
- }
-}
-
-1;
+++ /dev/null
-#
-# Dict.pl: Frontend to dict.org.
-# Author: dms
-# Version: v0.6c (20000924).
-# Created: 19990914.
-# Updates: Copyright (c) 2005 - Tim Riker <Tim@Rikers.org>
-#
-# see http://luetzschena-stahmeln.de/dictd/
-# for a list of dict servers
-
-package Dict;
-
-use IO::Socket;
-use strict;
-
-#use vars qw(PF_INET);
-
-# need a specific host||ip.
-my $server = "dict.org";
-
-sub Dict {
- my ($query) = @_;
-# return unless &::loadPerlModule("IO::Socket");
- my $port = 2628;
- my $proto = getprotobyname('tcp');
- my @results;
- my $retval;
-
- for ($query) {
- s/^[\s\t]+//;
- s/[\s\t]+$//;
- s/[\s\t]+/ /;
- }
-
- # connect.
- # TODO: make strict-safe constants... so we can defer IO::Socket load.
- my $socket = new IO::Socket;
- socket($socket, PF_INET, SOCK_STREAM, $proto) or return "error: socket: $!";
- eval {
- local $SIG{ALRM} = sub { die 'alarm' };
- alarm 10;
- connect($socket, sockaddr_in($port, inet_aton($server))) or die "error: connect: $!";
- alarm 0;
- };
-
- if ($@) {
- # failure.
- $retval = "i could not get info from $server '$@'";
- } else { # success.
- $socket->autoflush(1); # required.
-
- my $num;
- if ($query =~ s/^(\d+)\s+//) {
- $num = $1;
- }
- my $dict = '*';
- if ($query =~ s/\/(\S+)$//) {
- $dict = $1;
- }
-
- # body.
- push(@results, &Define($socket,$query,$dict));
- #push(@results, &Define($socket,$query,'foldoc'));
- #push(@results, &Define($socket,$query,'web1913'));
- # end.
-
- print $socket "QUIT\n";
- close $socket;
-
- my $count=0;
- foreach (@results) {
- $count++;
- &::DEBUG("$count: $_");
- }
- my $total = scalar @results;
-
- if ($total == 0) {
- $num = undef;
- }
-
- if (defined $num and ($num > $total or $num < 1)) {
- &::msg($::who, "error: choice in definition is out of range.");
- return;
- }
-
- # parse the results.
- if ($total > 1) {
- if (defined $num) {
- $retval = sprintf("[%d/%d] %s", $num, $total, $results[$num-1]);
- } else {
- # suggested by larne and others.
- my $prefix = "Dictionary '$query' ";
- $retval = &::formListReply(1, $prefix, @results);
- }
- } elsif ($total == 1) {
- $retval = "Dictionary '$query' ".$results[0];
- } else {
- $retval = "could not find definition for \002$query\002";
- $retval .= " in $dict" if ($dict ne '*');
- }
- }
-
- &::performStrictReply($retval);
-}
-
-sub Define {
- my ($socket, $query, $dict) = @_;
- my @results;
-
- &::DEBUG("Dict: asking $dict.");
- print $socket "DEFINE $dict \"$query\"\n";
-
- my $def = '';
- my $term = $query;
-
- while (<$socket>) {
- chop; # remove \n
- chop; # remove \r
-
- &::DEBUG("$term/$dict '$_'");
- if (/^552 /) {
- # no match.
- return;
- } elsif (/^250 /) {
- # end w/ optional stats
- last;
- } elsif (/^151 "([^"]*)" (\S+) .*/) {
- # 151 "Good Thing" jargon "Jargon File (4.3.0, 30 APR 2001)"
- $term=$1;
- $dict=$2;
- $def = '';
- &::DEBUG("term=$term dict=$dict");
- } else {
- my $line = $_;
- # some dicts put part of the definition on the same line ie: jargon
- $line =~ s/^$term//i;
- $line =~ s/^\s+/ /;
- if ($dict eq 'wn') {
- # special processing for sub defs in wordnet
- if ($line eq '.') {
- # end of def.
- $def =~ s/\s+$//;
- $def =~ s/\[[^\]]*\]//g;
- push(@results, $def);
- } elsif ($line =~ m/^\s+(\S+ )?(\d+)?: (.*)/) {
- # start of sub def.
- my $text = $3;
- $def =~ s/\s+$//;
- #&::DEBUG("def => '$def'.");
- $def =~ s/\[[^\]]*\]//g;
- push(@results, $def) if ($def ne '');
- $def = $text;
- } elsif (/^\s+(.*)/) {
- $def .= $line;
- } else {
- &::DEBUG("ignored '$line'");
- }
- } else {
- # would be nice to divide other dicts
- # but many are not always in a parsable format
- if ($line eq '.') {
- # end of def.
- next if ($def eq '');
- push(@results, $def);
- $def = '';
- } elsif ($line =~ m/^\s+(\S.*\S)\s*$/) {
- #&::DEBUG("got '$1'");
- $def .= ' ' if ($def ne '');
- $def .= $1;
- } else {
- &::DEBUG("ignored '$line'");
- }
- }
- }
- }
-
- &::DEBUG("Dict: $dict: found ". scalar(@results) ." defs.");
-
- return if (!scalar @results);
-
- return @results;
-}
-
-1;
+++ /dev/null
-#
-# DumpVars.pl: Perl variables dumper.
-# Maintained: dms
-# Version: v0.1 (20000114)
-# Created: 20000114
-# NOTE: Ripped from ActivePerl "asp sample" example.
-#
-
-# FIXME
-#use strict;
-
-#use vars qw();
-
-my $countlines = 0;
-
-sub dumpvarslog {
- my ($line) = @_;
- if (&IsParam('dumpvarsLogFile')) {
- print DUMPVARS $line."\n";
- } else {
- &status("DV: ".$line);
- }
-}
-
-sub DumpNames(\%$) {
- my ($package,$packname) = @_;
- my $symname = 0;
- my $line;
-
- if ($packname eq 'main::') {
- &dumpvarslog('Packages');
-
- foreach $symname (sort keys %$package) {
- local *sym = $$package{$symname};
- next unless (defined %sym);
- next unless ($symname =~/::/);
- &dumpvarslog(" $symname");
- $countlines++;
- }
- }
-
- # Scalars.
- foreach $symname (sort keys %$package) {
- local *sym = $$package{$symname};
- next unless (defined $sym);
-
- my $line;
- if (length($sym) > 512) {
- &dumpvarslog("Scalar '$packname' $symname too long.");
- } else {
- &dumpvarslog("Scalar '$packname' \$ $symname => '$sym'");
- }
- $countlines++;
- }
-
- # Functions.
- foreach $symname (sort keys %$package) {
- local *sym = $$package{$symname};
- next unless (defined &sym);
-
- &dumpvarslog("Function '$packname' $symname()");
- $countlines++;
- }
-
- # Lists.
- foreach $symname (sort keys %$package) {
- local *sym = $$package{$symname};
- next unless (defined @sym);
-
- &dumpvarslog("List '$packname' \@$symname (". scalar(@{$symname}) .")");
- $countlines++;
-
- next unless ($packname eq 'main::');
- foreach (@{$symname}) {
- if (defined $_) {
- &dumpvarslog(" => '$_'.");
- } else {
- &dumpvarslog(" => <NULL>.");
- }
- }
- }
-
- # Hashes.
- foreach $symname (sort keys %$package) {
- local *sym = $$package{$symname};
- next unless (defined %sym);
- next if ($symname =~/::/);
-
- &dumpvarslog("Hash '$packname' \%$symname");
- $countlines++;
-
- next unless ($packname eq 'main::');
- foreach (keys %{$symname}) {
- my $val = ${$symname}{$_};
- if (defined $val) {
- &dumpvarslog(" $_ => '$val'.");
- } else {
- &dumpvarslog(" $_ => <NULL>.");
- }
- }
- }
-
- return unless ($packname eq 'main::');
-
- foreach $symname (sort keys %$package) {
- local *sym = $$package{$symname};
- next unless (defined %sym);
- next unless ($symname =~/::/);
- next if ($symname eq 'main::');
-
- DumpNames(\%sym,$symname)
- }
-}
-
-sub dumpallvars {
- if (&IsParam('dumpvarsLogFile')) {
- my $file = $param{'dumpvarsLogFile'};
- &status("opening fh to dumpvars ($file)");
- if (!open(DUMPVARS,">$file")) {
- &ERROR("cannot open dumpvars.");
- return;
- }
- }
-
- DumpNames(%main::,'main::');
-
- if (&IsParam('dumpvarsLogFile')) {
- &status("closing fh to dumpvars");
- close DUMPVARS;
- }
-
- &status("DV: count == $countlines");
-}
-
-1;
+++ /dev/null
-#
-# DumpVars2.pl: Perl variables dumper ][.
-# Maintained: dms
-# Version: v0.1 (20020329)
-# Created: 20020329
-#
-
-# use strict; # TODO
-
-use Devel::Symdump;
-
-sub symdumplog {
- my ($line) = @_;
-
- if (fileno SYMDUMP) {
- print SYMDUMP $line."\n";
- } else {
- &status("SD: ".$line);
- }
-}
-
-sub symdumpAll {
- my $o = Devel::Symdump->rnew();
-
- # scalars.
- foreach ($o->scalars) {
-# &symdumpRecur($_);
- symdumplog(" scalar($_)");
- }
-}
-
-sub symdumpRecur {
- my $x = shift;
-
- if (ref $x eq 'HASH') {
- foreach (keys %$x) {
- &symdumpRecur($_);
- }
- } else {
- symdumplog("unknown: $x");
- }
-}
-
-sub symdumpAllFile {
- &DEBUG('before open');
- if (&IsParam('symdumpLogFile')) {
- my $file = $param{'symdumpLogFile'};
- &status("opening fh to symdump ($file)");
- if (!open(SYMDUMP,">$file")) {
- &ERROR('cannot open dumpvars.');
- return;
- }
- }
- &DEBUG('after open');
-
- symdumpAll();
-
- if (fileno SYMDUMP) {
- &status('closing fh to symdump');
- close SYMDUMP;
- }
-
- &status("SD: count == $countlines");
-}
-
-1;
+++ /dev/null
-#!/usr/bin/perl
-
-# Exchange.pl - currency exchange 'module'
-#
-# Last update: 990818 08:30:10, bobby@bofh.dk
-# 20021111 Tim Riker <Tim@Rikers.org>
-#
-
-package Exchange;
-use strict;
-
-my $no_exchange;
-
-BEGIN {
- eval qq{
- use LWP::UserAgent;
- use HTTP::Request::Common qw(POST GET);
- };
-
- $no_exchange++ if ($@);
-}
-
-sub GetAbb {
- my($LookFor,%Hash) = @_;
-
- my $Found = (grep /$LookFor/i, keys %Hash)[0];
- $Found =~ m/\((\w\w\w)\)/;
- return $1;
-}
-
-sub GetTlds {
- my %Hash = (
- 'AF', 'AFGHANISTAN',
- 'AL', 'ALBANIA',
- 'DZ', 'ALGERIA',
- 'AS', 'AMERICAN SAMOA',
- 'AD', 'ANDORRA',
- 'AO', 'ANGOLA',
- 'AI', 'ANGUILLA',
- 'AQ', 'ANTARCTICA',
- 'AG', 'ANTIGUA AND BARBUDA',
- 'AR', 'ARGENTINA',
- 'AM', 'ARMENIA',
- 'AW', 'ARUBA',
- 'AU', 'AUSTRALIA',
- 'AT', 'AUSTRIA',
- 'AZ', 'AZERBAIJAN',
- 'BS', 'BAHAMAS',
- 'BH', 'BAHRAIN',
- 'BD', 'BANGLADESH',
- 'BB', 'BARBADOS',
- 'BY', 'BELARUS',
- 'BE', 'BELGIUM',
- 'BZ', 'BELIZE',
- 'BJ', 'BENIN',
- 'BM', 'BERMUDA',
- 'BT', 'BHUTAN',
- 'BO', 'BOLIVIA',
- 'BA', 'BOSNIA AND HERZEGOWINA',
- 'BW', 'BOTSWANA',
- 'BV', 'BOUVET ISLAND',
- 'BR', 'BRAZIL',
- 'IO', 'BRITISH INDIAN OCEAN TERRITORY',
- 'BN', 'BRUNEI DARUSSALAM',
- 'BG', 'BULGARIA',
- 'BF', 'BURKINA FASO',
- 'BI', 'BURUNDI',
- 'KH', 'CAMBODIA',
- 'CM', 'CAMEROON',
- 'CA', 'CANADA',
- 'CV', 'CAPE VERDE',
- 'KY', 'CAYMAN ISLANDS',
- 'CF', 'CENTRAL AFRICAN REPUBLIC',
- 'TD', 'CHAD',
- 'CL', 'CHILE',
- 'CN', 'CHINA',
- 'CX', 'CHRISTMAS ISLAND',
- 'CC', 'COCOS (KEELING) ISLANDS',
- 'CO', 'COLOMBIA',
- 'KM', 'COMOROS',
- 'CG', 'CONGO',
- 'CD', 'CONGO, THE DEMOCRATIC REPUBLIC OF THE',
- 'CK', 'COOK ISLANDS',
- 'CR', 'COSTA RICA',
- 'CI', "COTE D'IVOIRE",
- 'HR', 'CROATIA (local name: Hrvatska)',
- 'CU', 'CUBA',
- 'CY', 'CYPRUS',
- 'CZ', 'CZECH REPUBLIC',
- 'DK', 'DENMARK',
- 'DJ', 'DJIBOUTI',
- 'DM', 'DOMINICA',
- 'DO', 'DOMINICAN REPUBLIC',
- 'TP', 'EAST TIMOR',
- 'EC', 'ECUADOR',
- 'EG', 'EGYPT',
- 'SV', 'EL SALVADOR',
- 'GQ', 'EQUATORIAL GUINEA',
- 'ER', 'ERITREA',
- 'EE', 'ESTONIA',
- 'ET', 'ETHIOPIA',
- 'FK', 'FALKLAND ISLANDS (MALVINAS)',
- 'FO', 'FAROE ISLANDS',
- 'FJ', 'FIJI',
- 'FI', 'FINLAND',
- 'FR', 'FRANCE',
- 'FX', 'FRANCE, METROPOLITAN',
- 'GF', 'FRENCH GUIANA',
- 'PF', 'FRENCH POLYNESIA',
- 'TF', 'FRENCH SOUTHERN TERRITORIES',
- 'GA', 'GABON',
- 'GM', 'GAMBIA',
- 'GE', 'GEORGIA',
- 'DE', 'GERMANY',
- 'GH', 'GHANA',
- 'GI', 'GIBRALTAR',
- 'GR', 'GREECE',
- 'GL', 'GREENLAND',
- 'GD', 'GRENADA',
- 'GP', 'GUADELOUPE',
- 'GU', 'GUAM',
- 'GT', 'GUATEMALA',
- 'GN', 'GUINEA',
- 'GW', 'GUINEA-BISSAU',
- 'GY', 'GUYANA',
- 'HT', 'HAITI',
- 'HM', 'HEARD AND MC DONALD ISLANDS',
- 'VA', 'HOLY SEE (VATICAN CITY STATE)',
- 'HN', 'HONDURAS',
- 'HK', 'HONG KONG',
- 'HU', 'HUNGARY',
- 'IS', 'ICELAND',
- 'IN', 'INDIA',
- 'ID', 'INDONESIA',
- 'IR', 'IRAN (ISLAMIC REPUBLIC OF)',
- 'IQ', 'IRAQ',
- 'IE', 'IRELAND',
- 'IL', 'ISRAEL',
- 'IT', 'ITALY',
- 'JM', 'JAMAICA',
- 'JP', 'JAPAN',
- 'JO', 'JORDAN',
- 'KZ', 'KAZAKHSTAN',
- 'KE', 'KENYA',
- 'KI', 'KIRIBATI',
- 'KP', "KOREA, DEMOCRATIC PEOPLE'S REPUBLIC OF",
- 'KR', 'KOREA, REPUBLIC OF',
- 'KW', 'KUWAIT',
- 'KG', 'KYRGYZSTAN',
- 'LA', "LAO PEOPLE'S DEMOCRATIC REPUBLIC",
- 'LV', 'LATVIA',
- 'LB', 'LEBANON',
- 'LS', 'LESOTHO',
- 'LR', 'LIBERIA',
- 'LY', 'LIBYAN ARAB JAMAHIRIYA',
- 'LI', 'LIECHTENSTEIN',
- 'LT', 'LITHUANIA',
- 'LU', 'LUXEMBOURG',
- 'MO', 'MACAU',
- 'MK', 'MACEDONIA, THE FORMER YUGOSLAV REPUBLIC OF',
- 'MG', 'MADAGASCAR',
- 'MW', 'MALAWI',
- 'MY', 'MALAYSIA',
- 'MV', 'MALDIVES',
- 'ML', 'MALI',
- 'MT', 'MALTA',
- 'MH', 'MARSHALL ISLANDS',
- 'MQ', 'MARTINIQUE',
- 'MR', 'MAURITANIA',
- 'MU', 'MAURITIUS',
- 'YT', 'MAYOTTE',
- 'MX', 'MEXICO',
- 'FM', 'MICRONESIA, FEDERATED STATES OF',
- 'MD', 'MOLDOVA, REPUBLIC OF',
- 'MC', 'MONACO',
- 'MN', 'MONGOLIA',
- 'MS', 'MONTSERRAT',
- 'MA', 'MOROCCO',
- 'MZ', 'MOZAMBIQUE',
- 'MM', 'MYANMAR',
- 'NA', 'NAMIBIA',
- 'NR', 'NAURU',
- 'NP', 'NEPAL',
- 'NL', 'NETHERLANDS',
- 'AN', 'NETHERLANDS ANTILLES',
- 'NC', 'NEW CALEDONIA',
- 'NZ', 'NEW ZEALAND',
- 'NI', 'NICARAGUA',
- 'NE', 'NIGER',
- 'NG', 'NIGERIA',
- 'NU', 'NIUE',
- 'NF', 'NORFOLK ISLAND',
- 'MP', 'NORTHERN MARIANA ISLANDS',
- 'NO', 'NORWAY',
- 'OM', 'OMAN',
- 'PK', 'PAKISTAN',
- 'PW', 'PALAU',
- 'PA', 'PANAMA',
- 'PG', 'PAPUA NEW GUINEA',
- 'PY', 'PARAGUAY',
- 'PE', 'PERU',
- 'PH', 'PHILIPPINES',
- 'PN', 'PITCAIRN',
- 'PL', 'POLAND',
- 'PT', 'PORTUGAL',
- 'PR', 'PUERTO RICO',
- 'QA', 'QATAR',
- 'RE', 'REUNION',
- 'RO', 'ROMANIA',
- 'RU', 'RUSSIAN FEDERATION',
- 'RW', 'RWANDA',
- 'KN', 'SAINT KITTS AND NEVIS',
- 'LC', 'SAINT LUCIA',
- 'VC', 'SAINT VINCENT AND THE GRENADINES',
- 'WS', 'SAMOA',
- 'SM', 'SAN MARINO',
- 'ST', 'SAO TOME AND PRINCIPE',
- 'SA', 'SAUDI ARABIA',
- 'SN', 'SENEGAL',
- 'SC', 'SEYCHELLES',
- 'SL', 'SIERRA LEONE',
- 'SG', 'SINGAPORE',
- 'SK', 'SLOVAKIA (Slovak Republic)',
- 'SI', 'SLOVENIA',
- 'SB', 'SOLOMON ISLANDS',
- 'SO', 'SOMALIA',
- 'ZA', 'SOUTH AFRICA',
- 'GS', 'SOUTH GEORGIA AND THE SOUTH SANDWICH ISLANDS',
- 'ES', 'SPAIN',
- 'LK', 'SRI LANKA',
- 'SH', 'ST. HELENA',
- 'PM', 'ST. PIERRE AND MIQUELON',
- 'SD', 'SUDAN',
- 'SR', 'SURINAME',
- 'SJ', 'SVALBARD AND JAN MAYEN ISLANDS',
- 'SZ', 'SWAZILAND',
- 'SE', 'SWEDEN',
- 'CH', 'SWITZERLAND',
- 'SY', 'SYRIAN ARAB REPUBLIC',
- 'TW', 'TAIWAN, PROVINCE OF CHINA',
- 'TJ', 'TAJIKISTAN',
- 'TZ', 'TANZANIA, UNITED REPUBLIC OF',
- 'TH', 'THAILAND',
- 'TG', 'TOGO',
- 'TK', 'TOKELAU',
- 'TO', 'TONGA',
- 'TT', 'TRINIDAD AND TOBAGO',
- 'TN', 'TUNISIA',
- 'TR', 'TURKEY',
- 'TM', 'TURKMENISTAN',
- 'TC', 'TURKS AND CAICOS ISLANDS',
- 'TV', 'TUVALU',
- 'UG', 'UGANDA',
- 'UA', 'UKRAINE',
- 'AE', 'UNITED ARAB EMIRATES',
- 'GB', 'UNITED KINGDOM',
- 'US', 'UNITED STATES',
- 'UM', 'UNITED STATES MINOR OUTLYING ISLANDS',
- 'UY', 'URUGUAY',
- 'UZ', 'UZBEKISTAN',
- 'VU', 'VANUATU',
- 'VE', 'VENEZUELA',
- 'VN', 'VIET NAM',
- 'VG', 'VIRGIN ISLANDS (BRITISH)',
- 'VI', 'VIRGIN ISLANDS (U.S.)',
- 'WF', 'WALLIS AND FUTUNA ISLANDS',
- 'EH', 'WESTERN SAHARA',
- 'YE', 'YEMEN',
- 'YU', 'YUGOSLAVIA',
- 'ZM', 'ZAMBIA',
- 'ZW', 'ZIMBABWE',
- );
- return %Hash;
-}
-
-sub exchange {
- my ($message) = @_;
- &::DEBUG("exchange(@_)");
-
- return 'Exchange.pl needs LWP::UserAgent and HTTP::Request::Common'
- if ($no_exchange);
-
- my ($From, $To, $Amount, $Country);
- my $retval = '';
- if ($message =~ /^([\d\.\,]+)\s+(\S+)\s+(?:into|to|for)\s+(\S+)/i) {
- ($Amount,$From,$To) = ($1,$2,$3);
- $From = uc $From; $To = uc $To;
- } elsif ($message =~ /^for\s(?:the\s)?([\w\s]+)/i) {
- # looking up the currency for a country
- $Country = $1;
- } else {
- return "that doesn't look right";
- }
-
- my $ua = new LWP::UserAgent;
- # Let's pretend
- #$ua->agent('Mozilla/5.0 ' . $ua->agent);
- $ua->agent('Mozilla/5.0');
- $ua->proxy('http', $::param{'httpProxy'}) if (&::IsParam('httpProxy'));
- $ua->timeout(10);
-
- my $Referer = 'http://www.xe.net/ucc/full.shtml';
- my $Converter='http://www.xe.net/ucc/convert.cgi';
-
- # Get a list of currency abbreviations...
- my $grab = GET $Referer;
- my $reply = $ua->request($grab);
- if (!$reply->is_success) {
- return 'EXCHANGE: '.$reply->status_line;
- }
- my $html = $reply->as_string;
- my %Currencies = (grep /\S+/,
- ($html =~ /option value="([^"]+)">.*?,\s*([^<]+)</gi)
- );
-
- my %CurrLookup = reverse ($html =~ /option value="([^"]+)">([^<]+)</gi);
-
- if ($Country) {
- # Country lookup
- # crysflame++ for the space fix.
- $retval = '';
- foreach my $Found (grep /$Country/i, keys %CurrLookup){
- $Found =~ s/,/ uses/g;
- $retval .= "$Found, ";
- }
- $retval =~ s/(?:, )?\|?$//;
- return substr($retval, 0, 510);
- } else {
- my %tld2country = &GetTlds;
- if ($From =~ /^\.(\w\w)$/) { # Probably a tld
- $From = $tld2country{uc $1};
- }
- if ($To =~ /^\.(\w\w)$/) { # Probably a tld
- $To = $tld2country{uc $1};
- }
-
- # Make sure that $Amount is of the form \d+(\.\d\d)?
- $Amount = sprintf("%.2f",$Amount);
-
- # Get the exact currency abbreviations
- my $newFrom = &GetAbb($From, %CurrLookup);
- my $newTo = &GetAbb($To, %CurrLookup);
-
- $From = $newFrom if $newFrom;
- $To = $newTo if $newTo;
-
- if (exists $Currencies{$From} and exists $Currencies{$To}) {
-
- my $req = POST $Converter,
- [ timezone => 'UTC',
- From => $From,
- To => $To,
- Amount => $Amount,
- ];
-
- # Falsify where we came from
- $req->referer($Referer);
-
- # Submit request
- my $res = $ua->request($req);
-
- if ($res->is_success) {
- # Went through ok
- my $html = $res->as_string;
- # parse each one to avoid undefined warnings
- my ($When) = ($html =~ m/ as of (\d{4}\.\d\d.\d\d\s\d\d:\d\d:\d\d\s\S+)/gi);
- my ($Cfrom) = ($html =~ m/(\d[\d,.]+)\s*$From/gi);
- my ($Cto) = ($html =~ m/(\d[\d,.]+)\s*$To/gi);
- #my ($When, $Cfrom, $Cto) =
- # grep /\S+/, ($html =~ m/ as of (\d{4}\.\d\d.\d\d\s\d\d:\d\d:\d\d\s\S+)|(\d[\d,.]+)\s*$From|(\d[\d,.]+)\s* $To/gi);
-
- if ($When) {
- return "$Cfrom $Currencies{$From} makes ".
- "$Cto $Currencies{$To} (from http://www.xe.com/)"; # ." ($When)\n";
- } else {
- return 'i got some error trying that';
- }
- } else {
- # Oh dear.
- return "EXCHANGE: ". $res->status_line;
- }
- } else {
- return "Don't know about \"$From\" as a currency" if (!exists $Currencies{$From});
- return "Don't know about \"$To\" as a currency" if (!exists $Currencies{$To});
- }
- }
-}
-
-sub query {
- my ($args) = @_;
- &::performStrictReply(&exchange($args));
- return;
-}
-
-#print &exchange('1 usd to eur') . "\n";
-1;
-
-__END__
-
-=head1 NAME
-
-Exchange.pl - Exchange between currencies
-
-=head1 PREREQUISITES
-
- LWP::UserAgent
- HTTP::Request::Common
-
-=head1 PARAMETERS
-
-exchange
-
-=head1 PUBLIC INTERFACE
-
- Exchange <amount> <currency> for|[in]to <currency>
-
-=head1 DESCRIPTION
-
-Contacts C<www.xe.net> and grabs the exchange rates; warning - the
-currency code is a bit cranky.
-
-=head1 AUTHORS
-
-Bobby <bobby@bofh.dk>
+++ /dev/null
-#
-# Factoids.pl: Helpers for generating factoids statistics.
-# Author: dms
-# Version: v0.1 (20000514)
-# Splitted: SQLExtras.pl
-#
-
-use strict;
-
-use vars qw($dbh $who);
-use vars qw(%param);
-
-###
-# Usage: &CmdFactInfo($faqtoid, $query);
-sub CmdFactInfo {
- my ($faqtoid, $query) = (lc $_[0], $_[1]);
- my @array;
- my $string = '';
-
- if ($faqtoid eq '') {
- &help('factinfo');
- return;
- }
-
- my %factinfo = &sqlSelectRowHash('factoids', '*',
- { factoid_key => $faqtoid }
- );
-
- # factoid does not exist.
- if (scalar (keys %factinfo) <= 1) {
- &performReply("there's no such factoid as \002$faqtoid\002");
- return;
- }
-
- # fix for problem observed by asuffield.
- # why did it happen though?
- if (!$factinfo{'factoid_value'}) {
- &performReply("there's no such factoid as \002$faqtoid\002; deleted because we don't have factoid_value!");
- foreach (keys %factinfo) {
- &DEBUG("factinfo{$_} => '$factinfo{$_}'.");
- }
-### &delFactoid($faqtoid);
- return;
- }
-
- # created:
- if ($factinfo{'created_by'}) {
-
- $factinfo{'created_by'} =~ s/\!/ </;
- $factinfo{'created_by'} .= '>';
- $string = "created by $factinfo{'created_by'}";
-
- my $time = $factinfo{'created_time'};
- if ($time) {
- if (time() - $time > 60*60*24*7) {
- my $days = int( (time() - $time)/60/60/24 );
- $string .= " at \037". scalar(gmtime $time). "\037" .
- " ($days days)";
- } else {
- $string .= ' '.&Time2String(time() - $time).' ago';
- }
- }
-
- push(@array,$string);
- }
-
- # modified: (TimRiker asks: why do you keep turning this off?)
- if ($factinfo{'modified_by'}) {
- $string = 'last modified';
-
- my $time = $factinfo{'modified_time'};
- if ($time) {
- if (time() - $time > 60*60*24*7) {
- $string .= " at \037". scalar(gmtime $time). "\037";
- } else {
- $string .= ' '.&Time2String(time() - $time).' ago ';
- }
- }
-
- $string .= ' by '.(split ',', $factinfo{'modified_by'})[0];
-
- push(@array,$string);
- }
-
- # requested:
- if ($factinfo{'requested_by'}) {
- my $requested_count = $factinfo{'requested_count'};
-
- if ($requested_count) {
- $string = 'it has been requested ';
- if ($requested_count == 1) {
- $string .= "\002once\002";
- } else {
- $string .= "\002". $requested_count. "\002 ".
- &fixPlural('time', $requested_count);
- }
-
- my $requested_by = $factinfo{'requested_by'};
- $requested_by =~ /\!/;
- $string .= ", last by $`";
-
- my $requested_time = $factinfo{'requested_time'};
- if ($requested_time) {
- if (time() - $requested_time > 60*60*24*7) {
- $string .= " at \037". scalar(localtime $requested_time). "\037";
- } else {
- $string .= ', '.&Time2String(time() - $requested_time).' ago';
- }
- }
- } else {
- $string = 'has not been requested yet';
- }
-
- push(@array, $string);
- }
-
- # locked:
- if ($factinfo{'locked_by'}) {
- $factinfo{'locked_by'} =~ /\!/;
- $string = "it has been locked by $`";
-
- push(@array, $string);
- }
-
- # factoid was inserted not through the bot.
- if (!scalar @array) {
- &performReply("no extra info on \002$faqtoid\002");
- return;
- }
-
- &performStrictReply("$factinfo{'factoid_key'} -- ". join('; ', @array) .'.');
- return;
-}
-
-sub CmdFactStats {
- my ($type) = @_;
-
- if ($type =~ /^author$/i) {
- my %hash = &sqlSelectColHash('factoids',
- 'factoid_key,created_by', undef,
- 'WHERE created_by IS NOT NULL'
- );
- my %author;
-
- foreach my $factoid (keys %hash) {
- my $thisnuh = $hash{$factoid};
-
- $thisnuh =~ /^(\S+)!\S+@\S+$/;
- $author{lc $1}++;
- }
-
- if (!scalar keys %author) {
- return 'sorry, no factoids with created_by field.';
- }
-
- # work-around.
- my %count;
- foreach (keys %author) {
- $count{ $author{$_} }{$_} = 1;
- }
- undef %author;
-
- my $count;
- my @list;
- foreach $count (sort { $b <=> $a } keys %count) {
- my $author = join(', ', sort keys %{ $count{$count} });
- push(@list, "$count by $author");
- }
-
- my $prefix = 'factoid statistics by author: ';
- return &formListReply(0, $prefix, @list);
-
- } elsif ($type =~ /^vandalism$/i) {
- &status('factstats(vandalism): starting...');
- my $start_time = &timeget();
- my %data = &sqlSelectColHash('factoids',
- 'factoid_key,factoid_value', undef,
- 'WHERE factoid_value IS NOT NULL'
- );
- my @list;
-
- my $delta_time = &timedelta($start_time);
- &status(sprintf('factstats(vandalism): %.02f sec to retreive all factoids.', $delta_time)) if ($delta_time > 0);
- $start_time = &timeget();
-
- # parse the factoids.
- foreach (keys %data) {
- if (&validFactoid($_, $data{$_}) == 0) {
- s/([\,\;]+)/\037$1\037/g; # highlight chars.
- push(@list, $_); # push it.
- }
- }
-
- $delta_time = &timedelta($start_time);
- &status(sprintf('factstats(vandalism): %.02f sec to complete.', $delta_time)) if ($delta_time > 0);
-
- # bail out on no results.
- if (scalar @list == 0) {
- return 'no vandalised factoids... wooohoo.';
- }
-
- # parse the results.
- my $prefix = 'Vandalised factoid ';
- return &formListReply(1, $prefix, @list);
-
- } elsif ($type =~ /^total$/i) {
- &status('factstats(total): starting...');
- my $start_time = &timeget();
- my @list;
- my $str;
- my($i,$j);
- my %hash;
-
- ### lets do it.
- # total factoids requests.
- $i = &sumKey('factoids', 'requested_count');
- push(@list, "total requests - $i");
-
- # total factoids modified.
- $str = &countKeys('factoids', 'modified_by');
- push(@list, "total modified - $str");
-
- # total factoids modified.
- $j = &countKeys('factoids', 'requested_count');
- $str = &countKeys('factoids', 'factoid_key');
- push(@list, 'total non-requested - '.($str - $i));
-
- # average request/factoid.
- # i/j == total(requested_count)/count(requested_count)
- $str = sprintf('%.01f', $i/$j);
- push(@list, "average requested per factoid - $str");
-
- # total prepared for deletion.
- $str = scalar( &searchTable('factoids', 'factoid_key', 'factoid_value', ' #DEL') );
- push(@list, "total prepared for deletion - $str");
-
- # total unique authors.
- # TODO: convert to sqlSelectColHash ? (or ColArray?)
- foreach ( &sqlRawReturn('SELECT created_by FROM factoids WHERE created_by IS NOT NULL') ) {
- /^(\S+)!/;
- my $nick = lc $1;
- $hash{$nick}++;
- }
- push(@list, 'total unique authors - '.(scalar keys %hash) );
- undef %hash;
-
- # total unique requesters.
- foreach ( &sqlRawReturn('SELECT requested_by FROM factoids WHERE requested_by IS NOT NULL') ) {
- /^(\S+)!/;
- my $nick = lc $1;
- $hash{$nick}++;
- }
- push(@list, 'total unique requesters - '.(scalar keys %hash) );
- undef %hash;
-
- ### end of 'job'.
-
- my $delta_time = &timedelta($start_time);
- &status(sprintf('factstats(broken): %.02f sec to retreive all factoids.', $delta_time)) if ($delta_time > 0);
- $start_time = &timeget();
-
- # bail out on no results.
- if (scalar @list == 0) {
- return 'no broken factoids... wooohoo.';
- }
-
- # parse the results.
- my $prefix = 'General factoid statistics ';
- return &formListReply(1, $prefix, @list);
-
- } elsif ($type =~ /^deadredir$/i) {
- my @list = &searchTable('factoids', 'factoid_key',
- 'factoid_value', '^<REPLY> see ');
- my %redir;
- my $f;
-
- for (@list) {
- my $factoid = $_;
- my $val = &getFactInfo($factoid, 'factoid_value');
- if ($val =~ /^<REPLY> ?see( also)? (.*?)\.?$/i) {
- my $redirf = lc $2;
- my $redir = &getFactInfo($redirf, 'factoid_value');
- next if (defined $redir);
- next if (length $val > 50);
-
- $redir{$redirf}{$factoid} = 1;
- }
- }
-
- my @newlist;
- foreach $f (keys %redir) {
- my @sublist = keys %{ $redir{$f} };
- for (@sublist) {
- s/([\,\;]+)/\037$1\037/g;
- }
-
- push(@newlist, join(', ', @sublist)." => $f");
- }
-
- # parse the results.
- my $prefix = 'Loose link (dead) redirections in factoids ';
- return &formListReply(1, $prefix, @newlist);
-
- } elsif ($type =~ /^dup(licate|e)$/i) {
- &status('factstats(dupe): starting...');
- my $start_time = &timeget();
- my %hash = &sqlSelectColHash('factoids',
- 'factoid_key,factoid_value', undef,
- 'WHERE factoid_value IS NOT NULL', 1
- );
- my $refs = 0;
- my @list;
- my $v;
-
- foreach $v (keys %hash) {
- my $count = scalar(keys %{ $hash{$v} });
- next if ($count == 1);
-
- my @sublist;
- foreach (keys %{ $hash{$v} }) {
- if ($v =~ /^<REPLY> see /i) {
- $refs++;
- next;
- }
-
- s/([\,\;]+)/\037$1\037/g;
- if ($_ eq '') {
- &WARN('dupe: _ = NULL. should never happen!.');
- next;
- }
- push(@sublist, $_);
- }
-
- next unless (scalar @sublist);
-
- push(@list, join(', ', @sublist));
- }
-
- &status("factstats(dupe): (good) dupe refs: $refs.");
- my $delta_time = &timedelta($start_time);
- &status(sprintf('factstats(dupe): %.02f sec to complete', $delta_time)) if ($delta_time > 0);
-
- # bail out on no results.
- if (scalar @list == 0) {
- return 'no duplicate factoids... woohoo.';
- }
-
- # parse the results.
- my $prefix = 'dupe factoid ';
- return &formListReply(1, $prefix, @list);
-
- } elsif ($type =~ /^nullfactoids$/i) {
- my $query = "SELECT factoid_key,factoid_value FROM factoids WHERE factoid_value=''";
- my $sth = $dbh->prepare($query);
- &ERROR("factstats(null): => '$query'.") unless $sth->execute;
-
- my @list;
- while (my @row = $sth->fetchrow_array) {
- if ($row[1] ne '') {
- &DEBUG("row[1] != NULL for $row[0].");
- next;
- }
-
- &DEBUG("row[0] => '$row[0]'.");
- push(@list, $row[0]);
- }
- $sth->finish;
-
- # parse the results.
- my $prefix = 'NULL factoids (not deleted yet) ';
- return &formListReply(1, $prefix, @list);
-
- } elsif ($type =~ /^(2|too)short$/i) {
- # Custom select statement.
- my $query = 'SELECT factoid_key,factoid_value FROM factoids WHERE length(factoid_value) <= 40';
- my $sth = $dbh->prepare($query);
- &ERROR("factstats(lame): => '$query'.") unless $sth->execute;
-
- my @list;
- while (my @row = $sth->fetchrow_array) {
- my($key,$val) = ($row[0], $row[1]);
- my $match = 0;
- $match++ if ($val =~ /\s{3,}/);
- next unless ($match);
-
- my $v = &getFactoid($val);
- if (defined $v) {
- &DEBUG("key $key => $val => $v");
- }
-
- $key =~ s/\,/\037\,\037/g;
- push(@list, $key);
- }
- $sth->finish;
-
- # parse the results.
- my $prefix = 'Lame factoids ';
- return &formListReply(1, $prefix, @list);
-
- } elsif ($type =~ /^listfix$/i) {
- # Custom select statement.
- my $query = 'SELECT factoid_key,factoid_value FROM factoids';
- my $sth = $dbh->prepare($query);
- &ERROR("factstats(listfix): => '$query'.") unless $sth->execute;
-
- my @list;
- while (my @row = $sth->fetchrow_array) {
- my($key,$val) = ($row[0], $row[1]);
- my $match = 0;
- $match++ if ($val =~ /\S+,? or \S+,? or \S+,? or \S+,?/);
- next unless ($match);
-
- $key =~ s/\,/\037\,\037/g;
- push(@list, $key);
- $val =~ s/,? or /, /g;
- &DEBUG("fixed: => $val.");
- &setFactInfo($key,'factoid_value', $val);
- }
- $sth->finish;
-
- # parse the results.
- my $prefix = 'Inefficient lists fixed ';
- return &formListReply(1, $prefix, @list);
-
- } elsif ($type =~ /^locked$/i) {
- my %hash = &sqlSelectColHash('factoids',
- 'factoid_key,locked_by', undef,
- 'WHERE locked_by IS NOT NULL'
- );
- my @list = keys %hash;
-
- for (@list) {
- s/([\,\;]+)/\037$1\037/g;
- }
-
- my $prefix = "factoid statistics on $type ";
- return &formListReply(0, $prefix, @list);
-
- } elsif ($type =~ /^new$/i) {
- my %hash = &sqlSelectColHash('factoids',
- 'factoid_key,created_time', undef,
- 'WHERE created_time IS NOT NULL'
- );
- my %age;
-
- foreach (keys %hash) {
- my $created_time = $hash{$_};
- my $delta_time = time() - $created_time;
- next if ($delta_time >= 60*60*24);
-
- $age{$delta_time}{$_} = 1;
- }
-
- if (scalar keys %age == 0) {
- return 'sorry, no new factoids.';
- }
-
- my @list;
- foreach (sort {$a <=> $b} keys %age) {
- push(@list, join(',', keys %{ $age{$_} }));
- }
-
- my $prefix = 'new factoids in the last 24hours ';
- return &formListReply(0, $prefix, @list);
-
- } elsif ($type =~ /^part(ial)?dupe$/i) {
- ### requires 'custom' select statement... oh well...
- my $start_time = &timeget();
-
- # form length|key and key=length hash list.
- &status('factstats(partdupe): forming length hash list.');
- my $query = 'SELECT factoid_key,factoid_value,length(factoid_value) AS length FROM factoids WHERE length(factoid_value) >= 192 ORDER BY length';
- my $sth = $dbh->prepare($query);
- &ERROR("factstats(partdupe): => '$query'.") unless $sth->execute;
-
- my (@key, @list);
- my (%key, %length);
- while (my @row = $sth->fetchrow_array) {
- $length{$row[2]}{$row[0]} = 1; # length(value)|key.
- $key{$row[0]} = $row[1]; # key=value.
- push(@key, $row[0]);
- }
- $sth->finish;
- &status("factstats(partdupe): total keys => '". scalar(@key) ."'.");
- &status('factstats(partdupe): now deciphering data gathered');
-
- my @length = sort { $a <=> $b } keys %length;
- my $key;
-
- foreach $key (@key) {
- shift @length if (length $key{$key} == $length[0]);
-
- my $val = quotemeta $key{$key};
- my @sublist;
- my $length;
- foreach $length (@length) {
- foreach (keys %{ $length{$length} }) {
- if ($key{$_} =~ /^$val/i) {
- s/([\,\;]+)/\037$1\037/g;
- s/( and|and )/\037$1\037/g;
- push(@sublist,$key.' and '.$_);
- }
- }
- }
- push(@list, join(' ,',@sublist)) if (scalar @sublist);
- }
-
- my $delta_time = sprintf('%.02fs', &timedelta($start_time) );
- &status("factstats(partdupe): $delta_time sec to complete.") if ($delta_time > 0);
-
- # bail out on no results.
- if (scalar @list == 0) {
- return 'no initial partial duplicate factoids... woohoo.';
- }
-
- # parse the results.
- my $prefix = 'initial partial dupe factoid ';
- return &formListReply(1, $prefix, @list);
-
- } elsif ($type =~ /^profanity$/i) {
- my %data = &sqlSelectColHash('factoids',
- 'factoid_key,factoid_value', undef,
- 'WHERE factoid_value IS NOT NULL'
- );
- my @list;
-
- foreach (keys %data) {
- push(@list, $_) if (&hasProfanity($_.' '.$data{$_}));
- }
-
- # parse the results.
- my $prefix = 'Profanity in factoids ';
- return &formListReply(1, $prefix, @list);
-
- } elsif ($type =~ /^redir(ection)?$/i) {
- my @list = &searchTable('factoids', 'factoid_key',
- 'factoid_value', '^<REPLY> see ');
- my %redir;
- my $f;
- my $dangling = 0;
-
- for (@list) {
- my $factoid = $_;
- my $val = &getFactInfo($factoid, 'factoid_value');
- if ($val =~ /^<REPLY> see( also)? (.*?)\.?$/i) {
- my $redir = lc $2;
- my $redirval = &getFactInfo($redir, 'factoid_value');
- if (defined $redirval) {
- $redir{$redir}{$factoid} = 1;
- } else {
- &DEBUG("factstats(redir): '$factoid' has loose link => '$redir'.");
- $dangling++;
- }
- }
- }
-
- my @newlist;
- foreach $f (keys %redir) {
- my @sublist = keys %{ $redir{$f} };
- for (@sublist) {
- s/([\,\;]+)/\037$1\037/g;
- }
-
- push(@newlist, "$f => ". join(', ', @sublist));
- }
-
- # parse the results.
- my $prefix = "Redirections in factoids, $dangling dangling ";
- return &formListReply(1, $prefix, @newlist);
-
- } elsif ($type =~ /^request(ed)?$/i) {
- my %hash = &sqlSelectColHash('factoids',
- 'factoid_key,requested_count', undef,
- 'WHERE requested_count IS NOT NULL', 1
- );
-
- if (!scalar keys %hash) {
- return 'sorry, no factoids have been questioned.';
- }
-
- my $count;
- my @list;
- my $total = 0;
- foreach $count (sort {$b <=> $a} keys %hash) {
- my @faqtoids = sort keys %{ $hash{$count} };
-
- for (@faqtoids) {
- s/([\,\;]+)/\037$1\037/g;
- }
- $total += $count * scalar(@faqtoids);
-
- push(@list, "$count - ". join(', ', @faqtoids));
- }
- unshift(@list, "\037$total - TOTAL\037");
-
- my $prefix = "factoid statistics on $type ";
- return &formListReply(0, $prefix, @list);
-
- } elsif ($type =~ /^reqrate$/i) {
- my %hash = &sqlSelectColHash('factoids',
- "factoid_key,(unix_timestamp() - created_time)/requested_count as rate", undef,
- 'WHERE requested_by IS NOT NULL and created_time IS NOT NULL ORDER BY rate LIMIT 15', 1
- );
-
- my $rate;
- my @list;
- my $total = 0;
- my $users = 0;
- foreach $rate (sort { $b <=> $a } keys %hash) {
- my $f = join(', ', sort keys %{ $hash{$rate} });
- my $str = "$f - ".&Time2String($rate);
- $str =~ s/\002//g;
- push(@list, $str);
- }
-
- my $prefix = "Rank of top factoid rate (time/req): ";
- return &formListReply(0, $prefix, @list);
-
- } elsif ($type =~ /^requesters?$/i) {
- my %hash = &sqlSelectColHash('factoids',
- 'factoid_key,requested_by', undef,
- 'WHERE requested_by IS NOT NULL'
- );
- my %requester;
-
- foreach (keys %hash) {
- my $thisnuh = $hash{$_};
-
- $thisnuh =~ /^(\S+)!\S+@\S+$/;
- $requester{lc $1}++;
- }
-
- if (!scalar keys %requester) {
- return 'sorry, no factoids with requested_by field.';
- }
-
- # work-around.
- my %count;
- foreach (keys %requester) {
- $count{ $requester{$_} }{$_} = 1;
- }
- undef %requester;
-
- my $count;
- my @list;
- my $total = 0;
- my $users = 0;
- foreach $count (sort { $b <=> $a } keys %count) {
- my $requester = join(', ', sort keys %{ $count{$count} });
- $total += $count * scalar(keys %{ $count{$count} });
- $users += scalar(keys %{ $count{$count} });
- push(@list, "$count by $requester");
- }
- unshift(@list, "\037$total TOTAL REQUESTS; $users UNIQUE REQUESTERS\037");
- # should not the above value be the same as collected by
- # 'requested'? soemthing weird is going on!
-
- my $prefix = 'rank of top factoid requesters: ';
- return &formListReply(0, $prefix, @list);
-
- } elsif ($type =~ /^seefix$/i) {
- my @list = &searchTable('factoids', 'factoid_key',
- 'factoid_value', '^see ');
- my @newlist;
- my $fixed = 0;
- my %loop;
- my $f;
-
- for (@list) {
- my $factoid = $_;
- my $val = &getFactInfo($factoid, 'factoid_value');
-
- next unless ($val =~ /^see( also)? (.*?)\.?$/i);
-
- my $redirf = lc $2;
- my $redir = &getFactInfo($redirf, 'factoid_value');
-
- if ($redirf =~ /^\Q$factoid\W$/i) {
- &delFactoid($factoid);
- $loop{$factoid} = 1;
- }
-
- if (defined $redir) { # good.
- &setFactInfo($factoid,'factoid_value',"<REPLY> see $redir");
- $fixed++;
- } else {
- push(@newlist, $redirf);
- }
- }
-
- # parse the results.
- &msg($who, "Fixed $fixed factoids.");
- &msg($who, 'Self looped factoids removed: '. keys %loop ) if (scalar keys %loop);
-
- my $prefix = "Loose link (dead) redirections in factoids ";
- return &formListReply(1, $prefix, @newlist);
-
- } elsif ($type =~ /^(2|too)long$/i) {
- my @list;
- my $query;
-
- # factoid_key.
- $query = "SELECT factoid_key FROM factoids WHERE length(factoid_key) >= $param{'maxKeySize'}";
- my $sth = $dbh->prepare($query);
- $sth->execute;
- while (my @row = $sth->fetchrow_array) {
- push(@list,$row[0]);
- }
- $sth->finish;
-
- # factoid_value.
- $query = "SELECT factoid_key,factoid_value FROM factoids WHERE length(factoid_value) >= $param{'maxDataSize'}";
- $sth = $dbh->prepare($query);
- $sth->execute;
- while (my @row = $sth->fetchrow_array) {
- push(@list,sprintf("\002%s\002 - %s", length($row[1]), $row[0]));
- }
- $sth->finish;
-
- if (scalar @list == 0) {
- return 'good. no factoids exceed length.';
- }
-
- # parse the results.
- my $prefix = 'factoid key||value exceeding length ';
- return &formListReply(1, $prefix, @list);
-
- } elsif ($type =~ /^unrequest(ed)?$/i) {
- # TODO: use sqlSelect()
- my ($count) = &sqlRawReturn("SELECT COUNT(*) FROM factoids WHERE requested_count = '0'");
-
- return "Unrequested factoids: $count";
- }
-
- return "error: invalid type => '$type'.";
-}
-
-sub CmdListAuth {
- my ($query) = @_;
- my $maxshow = &::getChanConfDefault('maxListReplyCount', 15, $chan);
- my @list = &searchTable('factoids','factoid_key', 'created_by', "^$query!");
- @list=grep(!/\#DEL\#$/,@list) if (scalar(@list) > $maxshow);
-
- my $prefix = "factoid author list by '$query' ";
- &performStrictReply( &formListReply(1, $prefix, @list) );
-}
-
-1;
+++ /dev/null
-# HTTPDtype.pl: retrieves http server headers
-# Author: Joey Smith <joey@php.net>
-# Licensing: Artistic License
-# Version: v0.1 (20031110)
-#
-use strict;
-
-package HTTPDtype;
-
-sub HTTPDtype {
- my($HOST) = @_;
- my($line) = '';
- my($code, $mess, %h);
-
- # TODO: remove leading http:// and trailing :port and /foo if found
- $HOST = 'joeysmith.com' unless length($HOST) > 0;
- return unless &::loadPerlModule("Net::HTTP::NB");
- return unless &::loadPerlModule("IO::Select");
-
- my $s = Net::HTTP::NB->new(Host => $HOST) || return;
- $s->write_request(HEAD => "/");
-
- my $sel = IO::Select->new($s);
- $line = 'Header timeout' unless $sel->can_read(10);
- ($code, $mess, %h) = $s->read_response_headers;
-
- $line = (length($h{Server}) > 0) ? $h{Server} :
- "Couldn't fetch headers from $HOST";
-
- &::performStrictReply($line||'Unknown Error Condition');
-}
-
-1;
+++ /dev/null
-#
-# Kernel.pl: Frontend to linux.kernel.org.
-# Author: dms
-# Version: v0.3 (19990919).
-# Created: 19990729
-#
-
-package Kernel;
-
-sub kernelGetInfo {
- return &::getURL("http://www.kernel.org/kdist/finger_banner");
-}
-
-sub Kernel {
- my $retval = 'Linux kernel versions';
- my @now = &kernelGetInfo();
- if (!scalar @now) {
- &::msg($::who, "failed.");
- return;
- }
-
- foreach $line (@now) {
- $line =~ s/The latest //;
- $line =~ s/version //;
- $line =~ s/of //;
- $line =~ s/the //;
- $line =~ s/Linux //;
- $line =~ s/kernel //;
- $line =~ s/tree //;
- $line =~ s/ for stable//;
- $line =~ s/ to stable kernels//;
- $line =~ s/ for 2.4//;
- $line =~ s/ for 2.2//;
- $line =~ s/ is: */: /;
- $retval .= ', ' . $line;
- }
- &::performStrictReply($retval);
-}
-
-sub kernelAnnounce {
- my $file = "$::param{tempDir}/kernel.txt";
- my @now = &kernelGetInfo();
- my @old;
-
- if (!scalar @now) {
- &::DEBUG('kA: failure to retrieve.');
- return;
- }
-
- if (! -f $file) {
- open(OUT, ">$file");
- foreach (@now) {
- print OUT "$_\n";
- }
- close OUT;
-
- return;
- } else {
- open(IN, $file);
- while (<IN>) {
- chop;
- push(@old,$_);
- }
- close IN;
- }
-
- my @new;
- for(my $i=0; $i<scalar(@old); $i++) {
- next if ($old[$i] eq $now[$i]);
- push(@new, $now[$i]);
- }
-
- if (scalar @now != scalar @old) {
- &::DEBUG("kA: scalar mismatch; removing and exiting.");
- unlink $file;
- return;
- }
-
- if (!scalar @new) {
- &::DEBUG("kA: no new kernels.");
- return;
- }
-
- open(OUT, ">$file");
- foreach (@now) {
- print OUT "$_\n";
- }
- close OUT;
-
- return @new;
-}
-
-1;
+++ /dev/null
-#
-# infobot copyright (C) kevin lenzo 1997-98
-#
-
-use strict;
-
-use vars qw($message);
-
-my %digits = (
- 'first', '1',
- 'second', '2',
- 'third', '3',
- 'fourth', '4',
- 'fifth', '5',
- 'sixth', '6',
- 'seventh', '7',
- 'eighth', '8',
- 'ninth', '9',
- 'tenth', '10',
- 'one', '1',
- 'two', '2',
- 'three', '3',
- 'four', '4',
- 'five', '5',
- 'six', '6',
- 'seven', '7',
- 'eight', '8',
- 'nine', '9',
- 'ten', '10'
-);
-
-sub perlMath {
- my($locMsg) = $message;
-
- if ($message =~ /^\s*$/) {
- return;
- }
-
- foreach (keys %digits) {
- $locMsg =~ s/$_/$digits{$_}/g;
- }
-
- while ($locMsg =~ /(exp ([\w\d]+))/) {
- my($exp, $val) = ($1, exp $2);
- $locMsg =~ s/$exp/+$val/g;
- }
-
- while ($locMsg =~ /(hex2dec\s*([0-9A-Fa-f]+))/) {
- my($exp, $val) = ($1, hex $2);
- $locMsg =~ s/$exp/+$val/g;
- }
-
- if ($locMsg =~ /^\s*(dec2hex\s*(\d+))\s*\?*/) {
- my ($exp, $val) = ($1, sprintf("%x", "$2"));
- $locMsg =~ s/$exp/+$val/g;
- }
-
- my $e = exp(1);
- $locMsg =~ s/\be\b/$e/;
-
- while ($locMsg =~ /(log\s*((\d+\.?\d*)|\d*\.?\d+))\s*/) {
- my ($exp, $res) = ($1, $2);
- my $val = ($res) ? log($res) : 'Infinity';
- $locMsg =~ s/$exp/+$val/g;
- }
-
- while ($locMsg =~ /(bin2dec ([01]+))/) {
- my $exp = $1;
- my $val = join ('', unpack('B*',$2)) ;
- $locMsg =~ s/$exp/+$val/g;
- }
-
- while ($locMsg =~ /(dec2bin (\d+))/) {
- my $exp = $1;
- my $val = join('', unpack('B*', pack('N',$2)));
- $val =~ s/^0+//;
- $locMsg =~ s/$exp/+$val/g;
- }
-
- for ($locMsg) {
- s/\bpi\b/3.14159265/g;
- s/ to the / ** /g;
- s/\btimes\b/\*/g;
- s/\bdiv(ided by)? /\/ /g;
- s/\bover /\/ /g;
- s/\bsquared/\*\*2 /g;
- s/\bcubed/\*\*3 /g;
- s/\bto\s+(\d+)(r?st|nd|rd|th)?( power)?/\*\*$1 /ig;
- s/\bpercent of/*0.01*/ig;
- s/\bpercent/*0.01/ig;
- s/\% of\b/*0.01*/g;
- s/\%/*0.01/g;
- s/\bsquare root of (\d+)/$1 ** 0.5 /ig;
- s/\bcubed? root of (\d+)/$1 **(1.0\/3.0) /ig;
- s/ of / * /;
- s/(bit(-| )?)?xor(\'?e?d( with))?/\^/g;
- s/(bit(-| )?)?or(\'?e?d( with))?/\|/g;
- s/bit(-| )?and(\'?e?d( with))?/\& /g;
- s/(plus|and)/+/ig;
- }
-
- # what the hell is this shit?
- if (($locMsg =~ /^\s*[-\d*+\s()\/^\.\|\&\*\!]+\s*$/)
- && ($locMsg !~ /^\s*\(?\d+\.?\d*\)?\s*$/)
- && ($locMsg !~ /^\s*$/)
- && ($locMsg !~ /^\s*[( )]+\s*$/)
- && ($locMsg =~ /\d+/)
- ) {
- $locMsg =~ s/([0-9]+\.[0-9]+(\.[0-9]+)+)/"$1"/g;
- $locMsg = eval($locMsg);
-
- if (defined $locMsg and $locMsg =~ /^[-+\de\.]+$/) {
- $locMsg = sprintf("%1.12f", $locMsg);
- $locMsg =~ s/\.?0+$//;
-
- if (length $locMsg > 30) {
- $locMsg = "a number with quite a few digits...";
- }
- } else {
- if (defined $locMsg) {
- &FIXME("math: locMsg => '$locMsg'...");
- } else {
- &status("math: could not really compute.");
- $locMsg = '';
- }
- }
- } else {
- $locMsg = '';
- }
-
- if (defined $locMsg and $locMsg ne $message) {
- # success.
- return $locMsg;
- } else {
- # no match.
- return '';
- }
-}
-
-1;
+++ /dev/null
-#
-# News.pl: Advanced news management
-# Author: dms
-# Version: v0.3 (20010412)
-# Created: 20010326
-# Notes: Testing done by greycat, kudos!
-#
-### structure:
-# news{ channel }{ string } { item }
-# newsuser{ channel }{ user } = time()
-### where item is:
-# Time - when it was added (used for sorting)
-# Author - Who by.
-# Expire - Time to expire.
-# Text - Actual text.
-###
-
-package News;
-
-use strict;
-
-use vars qw($who $chan);
-
-sub Parse {
- my($what) = @_;
- $chan = undef;
- $who = lc $::who;
-
- if (!keys %::news) {
- if (!exists $::cache{newsFirst}) {
- &::DEBUG("news: looks like we enabled news option just then; loading up news file just in case.");
- $::cache{newsFirst} = 1;
- }
-
- &readNews();
- }
-
- if ($::msgType ne 'private') {
- $chan = $::chan;
- }
-
- if (defined $what and $what =~ s/^($::mask{chan})\s*//) {
- # TODO: check if the channel exists aswell.
- $chan = lc $1;
-
- if (!&::IsNickInChan($who, $chan)) {
- &::notice($who, "sorry but you're not on $chan.");
- return;
- }
- }
-
- if (!defined $chan) {
- my @chans = &::getNickInChans($who);
-
- if (scalar @chans > 1) {
- &::notice($who, "error: I dunno which channel you are referring to since you're on more than one. Try 'news #chan ...' instead");
- return;
- }
-
- if (scalar @chans == 0) {
- &::notice($who, "error: I couldn't find you on any chan. This must be a bug!");
- return;
- }
-
- $chan = $chans[0];
- &::VERB("Guessed $who being on chan $chan",2);
- $::chan = $chan; # hack for IsChanConf().
- }
-
- if (!defined $what or $what =~ /^\s*$/) {
- &list();
- return;
- }
-
- if ($what =~ /^add(\s+(.*))?$/i) {
- &add($2);
-
- } elsif ($what =~ /^del(\s+(.*))?$/i) {
- &del($2);
-
- } elsif ($what =~ /^mod(\s+(.*))?$/i) {
- &mod($2);
-
- } elsif ($what =~ /^set(\s+(.*))?$/i) {
- &set($2);
-
- } elsif ($what =~ /^(\d+)$/i) {
- &::VERB("News: read shortcut called.",2);
- &read($1);
-
- } elsif ($what =~ /^read(\s+(.*))?$/i) {
- &read($2);
-
- } elsif ($what =~ /^(latest|new)(\s+(.*))?$/i) {
- &latest($3 || $chan, 1);
-# $::cmdstats{'News latest'}++;
-
- } elsif ($what =~ /^stats?$/i) {
- &stats();
-
- } elsif ($what =~ /^list$/i) {
- &list();
-
- } elsif ($what =~ /^(expire|text|desc)(\s+(.*))?$/i) {
- # shortcut/link.
- # nice hack.
- my $cmd = $1;
- my($arg1,$arg2) = split(/\s+/, $3, 2);
- &set("$arg1 $cmd $arg2");
-
- } elsif ($what =~ /^help(\s+(.*))?$/i) {
- &::help("news $2");
-
- } elsif ($what =~ /^newsflush$/i) {
- &::msg($who, "newsflush called... check out the logs!");
- &::newsFlush();
-
- } elsif ($what =~ /^(un)?notify$/i) {
- my $state = ($1) ? 0 : 1;
-
- # TODO: don't notify even if 'News' is called.
- if (&::IsChanConf('newsNotifyAll') <= 0) {
- &::DEBUG("news: chan => $chan, ::chan => $::chan.");
- &::notice($who, "not available for this channel or disabled altogether.");
- return;
- }
-
- my $t = $::newsuser{$chan}{$who};
- if ($state) { # state = 1
- if (defined $t and ($t == 0 or $t == -1)) {
- &::notice($who, "enabled notify.");
- delete $::newsuser{$chan}{$who};
- return;
- }
- &::notice($who, "already enabled.");
-
- } else { # state = 0
- my $x = $::newsuser{$chan}{$who};
- if (defined $x and ($x == 0 or $x == -1)) {
- &::notice($who, 'notify already disabled');
- return;
- }
- $::newsuser{$chan}{$who} = -1;
- &::notice($who, "notify is now disabled.");
- }
-
- } else {
- &::notice($who, "unknown command: $what");
- }
-}
-
-sub readNews {
- my $file = "$::bot_base_dir/blootbot-news.txt";
- if (! -f $file or -z $file) {
- return;
- }
-
- if (fileno NEWS) {
- &::DEBUG("readNews: fileno exists, should never happen.");
- return;
- }
-
- my($item,$chan);
- my($ci,$cu) = (0,0);
-
- open(NEWS, $file);
- while (<NEWS>) {
- chop;
-
- # TODO: allow commands.
-
- if (/^[\s\t]+(\S+):[\s\t]+(.*)$/) {
- if (!defined $item) {
- &::DEBUG("news: !defined item, never happen!");
- next;
- }
-
- $::news{$chan}{$item}{$1} = $2;
- next;
- }
-
- # U <chan> <nick> <time>
- if (/^U\s+(\S+)\s+(\S+)\s+(\d+)$/) {
- $::newsuser{$1}{$2} = $3;
- $cu++;
- next;
- }
-
- if (/^(\S+)[\s\t]+(.*)$/) {
- $chan = $1;
- $item = $2;
- $ci++;
- }
- }
- close NEWS;
-
- my $cn = scalar(keys %::news);
- return unless ($ci or $cn or $cu);
-
- &::status("News: read ".
- $ci. &::fixPlural(' item', $ci). ' for '.
- $cn. &::fixPlural(' chan', $cn). ', '.
- $cu. &::fixPlural(' user', $cu), ' cache'
- );
-}
-
-sub writeNews {
- if (!scalar keys %::news and !scalar keys %::newsuser) {
- &::VERB("wN: nothing to write.",2);
- return;
- }
-
- # should define this at the top of file.
- my $file = "$::bot_base_dir/blootbot-news.txt";
-
- if (fileno NEWS) {
- &::ERROR("News: write: fileno NEWS exists, should never happen.");
- return;
- }
-
- # TODO: add commands to output file.
- my $c = 0;
- my($cc,$ci,$cu) = (0,0,0);
-
- open(NEWS, ">$file");
- foreach $chan (sort keys %::news) {
- $c = scalar keys %{ $::news{$chan} };
- next unless ($c);
- $cc++;
- my $item;
-
- foreach $item (sort keys %{ $::news{$chan} }) {
- $c = scalar keys %{ $::news{$chan}{$item} };
- next unless ($c);
- $ci++;
-
- print NEWS "$chan $item\n";
- my $what;
- foreach $what (sort keys %{ $::news{$chan}{$item} }) {
- print NEWS " $what: $::news{$chan}{$item}{$what}\n";
- }
- print NEWS "\n";
- }
- }
-
- # TODO: show how many users we wrote down.
- if (&::getChanConfList('newsKeepRead')) {
- # old users are removed in newsFlush(), perhaps it should be
- # done here.
-
- foreach $chan (sort keys %::newsuser) {
-
- foreach (sort keys %{ $::newsuser{$chan} }) {
- print NEWS "U $chan $_ $::newsuser{$chan}{$_}\n";
- $cu++;
- }
- }
- }
-
- close NEWS;
-
- &::status("News: Wrote $ci items for $cc chans, $cu user cache.");
-}
-
-sub add {
- my($str) = @_;
-
- if (!defined $chan or !defined $str or $str =~ /^\s*$/) {
- &::help('news add');
- return;
- }
-
- if (length $str > 64) {
- &::notice($who, "That's not really an item (>64chars)");
- return;
- }
-
- if (exists $::news{$chan}{$str}{Time}) {
- &::notice($who, "'$str' for $chan already exists!");
- return;
- }
-
- $::news{$chan}{$str}{Time} = time();
- my $expire = &::getChanConfDefault('newsDefaultExpire',7, $chan);
- $::news{$chan}{$str}{Expire} = time() + $expire*60*60*24;
- $::news{$chan}{$str}{Author} = $::who; # case!
-
- my $agestr = &::Time2String($::news{$chan}{$str}{Expire} - time() );
- my $item = &newsS2N($str);
- &::notice($who, "Added '\037$str\037' at [".gmtime(time).
- "] by \002$::who\002 for item #\002$item\002.");
- &::notice($who, "Now do 'news text $item <your_description>'");
- &::notice($who, "This item will expire at \002".
- gmtime($::news{$chan}{$str}{Expire})."\002 [$agestr from now] "
- );
-
- &writeNews();
-}
-
-sub del {
- my($what) = @_;
- my $item = 0;
-
- if (!defined $what) {
- &::help('news del');
- return;
- }
-
- if ($what =~ /^\d+$/) {
- my $count = scalar keys %{ $::news{$chan} };
- if (!$count) {
- &::notice($who, "No news for $chan.");
- return;
- }
-
- if ($what > $count or $what < 0) {
- &::notice($who, "$what is out of range (max $count)");
- return;
- }
-
- $item = &getNewsItem($what);
- $what = $item; # hack hack hack.
-
- } else {
- $_ = &getNewsItem($what); # hack hack hack.
- $what = $_ if (defined $_);
-
- if (!exists $::news{$chan}{$what}) {
- my @found;
- foreach (keys %{ $::news{$chan} }) {
- next unless (/\Q$what\E/);
- push(@found, $_);
- }
-
- if (!scalar @found) {
- &::notice($who, "could not find $what.");
- return;
- }
-
- if (scalar @found > 1) {
- &::notice($who, "too many matches for $what.");
- return;
- }
-
- $what = $found[0];
- &::DEBUG("news: del: str: guessed what => $what");
- }
- }
-
- if (exists $::news{$chan}{$what}) {
- my $auth = 0;
- $auth++ if ($::who eq $::news{$chan}{$what}{Author});
- $auth++ if (&::IsFlag('o'));
-
- if (!$auth) {
- # TODO: show when it'll expire.
- &::notice($who, "Sorry, you cannot remove items; just let them expire on their own.");
- return;
- }
-
- &::notice($who, "ok, deleted '$what' from \002$chan\002...");
- delete $::news{$chan}{$what};
- } else {
- &::notice($who, "error: not found $what in news for $chan.");
- }
-}
-
-sub list {
- if (!scalar keys %{ $::news{$chan} }) {
- &::notice($who, "No news for \002$chan\002.");
- return;
- }
-
- if (&::IsChanConf('newsKeepRead') > 0) {
- my $x = $::newsuser{$chan}{$who};
-
- if (defined $x and ($x == 0 or $x == -1)) {
- &::DEBUG("news: not updating time for $who.");
- } else {
- if (!scalar keys %{ $::news{$chan} }) {
- &::DEBUG("news: should not add $chan/$who to cache!");
- }
-
- $::newsuser{$chan}{$who} = time();
- }
- }
-
- # ¬ice() breaks OPN :( - using msg() instead!
- my $count = scalar keys %{ $::news{$chan} };
- &::msg($who, "|==== News for \002$chan\002: ($count items)");
- my $newest = 0;
- my $expire = 0;
- my $eno = 0;
- foreach (keys %{ $::news{$chan} }) {
- my $t = $::news{$chan}{$_}{Time};
- my $e = $::news{$chan}{$_}{Expire};
- $newest = $t if ($t > $newest);
- if ($e > 1 and $e < $expire) {
- $expire = $e;
- &::DEBUG("before newsS2N($_)");
- $eno = &newsS2N($_);
- &::DEBUG("after newsS2N($_) == $eno");
- }
- }
- my $timestr = &::Time2String(time() - $newest);
- &::msg($who, "|= Last updated $timestr ago.");
- &::msg($who, " \037Num\037 \037Item ".(' 'x40)." \037");
-
-# &::DEBUG("news: list: expire = $expire");
-# &::DEBUG("news: list: eno = $eno");
-
- my $i = 1;
- foreach ( &getNewsAll() ) {
- my $subtopic = $_;
- my $setby = $::news{$chan}{$subtopic}{Author};
- my $chr = (exists $::News{$chan}{$subtopic}{Text}) ? '' : '*';
-
- if (!defined $subtopic) {
- &::DEBUG("news: warn: subtopic == undef.");
- next;
- }
-
- # TODO: show request stats aswell.
- &::msg($who, sprintf("\002[\002%2d\002]\002%s %s",
- $i, $chr, $subtopic));
- $i++;
- }
-
- my $z = $::newsuser{$who};
- if (defined $z) {
- &::DEBUG("cache $who: $z");
- } else {
- &::DEBUG("cache: $who doesn't have newscache set.");
- }
-
- &::msg($who, "|= End of News.");
- &::msg($who, "use 'news read <#>' or 'news read <keyword>'");
-}
-
-sub read {
- my($str) = @_;
-
- if (!defined $chan or !defined $str or $str =~ /^\s*$/) {
- &::help('news read');
- return;
- }
-
- if (!scalar keys %{ $::news{$chan} }) {
- &::notice($who, "No news for \002$chan\002.");
- return;
- }
-
- my $item = &getNewsItem($str);
- if (!defined $item or !scalar keys %{ $::news{$chan}{$item} }) {
- # TODO: numerical check.
- if ($str =~ /^(\d+)[-, ](\d+)$/ or
- $str =~ /^-(\d+)$/ or
- $str =~ /^(\d+)-$/ or 0
- ) {
- &::notice($who, "We don't support multiple requests of news items yet. Sorry.");
- return;
- }
-
- &::notice($who, "No news item called '$str'");
- return;
- }
-
- if (!exists $::news{$chan}{$item}{Text}) {
- &::notice($who, 'Someone forgot to add info to this news item');
- return;
- }
-
- my $t = gmtime( $::news{$chan}{$item}{Time} );
- my $a = $::news{$chan}{$item}{Author};
- my $text = $::news{$chan}{$item}{Text};
- my $num = &newsS2N($item);
- my $rwho = $::news{$chan}{$item}{Request_By} || $::who;
- my $rcount = $::news{$chan}{$item}{Request_Count} || 0;
-
- if (length $text < $::param{maxKeySize}) {
- &::VERB("NEWS: Possible news->factoid redirection.",2);
- my $f = &::getFactoid($text);
-
- if (defined $f) {
- &::VERB("NEWS: ok, $text is factoid redirection.",2);
- $f =~ s/^<REPLY>\s*//i; # anything else?
- $text = $f;
- }
- }
-
- $_ = $::news{$chan}{$item}{'Expire'};
- my $e;
- if ($_) {
- $e = sprintf("\037%s\037 [%s from now]",
- scalar(gmtime($_)),
- &::Time2String($_ - time())
- );
- }
-
- &::notice($who, "+- News \002$chan\002 #$num: $item");
- &::notice($who, "| Added by $a at \037$t\037");
- &::notice($who, "| Expire: $e") if (defined $e);
- &::notice($who, $text);
- &::notice($who, "| Requested \002$rcount\002 times, last by \002$rwho\002") if ($rcount and $rwho);
-
- $::news{$chan}{$item}{'Request_By'} = $::who;
- $::news{$chan}{$item}{'Request_Time'} = time();
- $::news{$chan}{$item}{'Request_Count'}++;
-}
-
-sub mod {
- my($item, $str) = split /\s+/, $_[0], 2;
-
- if (!defined $item or $item eq '' or $str =~ /^\s*$/) {
- &::help('news mod');
- return;
- }
-
- my $news = &getNewsItem($item);
-
- if (!defined $news) {
- &::DEBUG("news: error: mod: news == undefined.");
- return;
- }
- my $nnews = $::news{$chan}{$news}{Text};
- my $mod_news = $news;
- my $mod_nnews = $nnews;
-
- # SAR patch. mu++
- if ($str =~ m|^\s*s([/,#\|])(.+?)\1(.*?)\1([a-z]*);?\s*$|) {
- my ($delim, $op, $np, $flags) = ($1,$2,$3,$4);
-
- if ($flags !~ /^(g)?$/) {
- &::notice($who, "error: Invalid flags to regex.");
- return;
- }
-
- ### TODO: use m### to make code safe!
- # TODO: make code safer.
- my $done = 0;
- # TODO: use eval to deal with flags easily.
- if ($flags eq '') {
- $done++ if (!$done and $mod_news =~ s/\Q$op\E/$np/);
- $done++ if (!$done and $mod_nnews =~ s/\Q$op\E/$np/);
- } elsif ($flags eq 'g') {
- $done++ if ($mod_news =~ s/\Q$op\E/$np/g);
- $done++ if ($mod_nnews =~ s/\Q$op\E/$np/g);
- }
-
- if (!$done) {
- &::notice($who, "warning: regex not found in news.");
- return;
- }
-
- if ($mod_news ne $news) { # news item.
- if (exists $::news{$chan}{$mod_news}) {
- &::notice($who, "item '$mod_news' already exists.");
- return;
- }
-
- &::notice($who, "Moving item '$news' to '$mod_news' with SAR s/$op/$np/.");
- foreach (keys %{ $::news{$chan}{$news} }) {
- $::news{$chan}{$mod_news}{$_} = $::news{$chan}{$news}{$_};
- delete $::news{$chan}{$news}{$_};
- }
- # needed?
- delete $::news{$chan}{$news};
- }
-
- if ($mod_nnews ne $nnews) { # news Text/Description.
- &::notice($who, "Changing text for '$news' SAR s/$op/$np/.");
- if ($mod_news ne $news) {
- $::news{$chan}{$mod_news}{Text} = $mod_nnews;
- } else {
- $::news{$chan}{$news}{Text} = $mod_nnews;
- }
- }
-
- return;
- } else {
- &::notice($who, "error: that regex failed ;(");
- return;
- }
-
- &::notice($who, "error: Invalid regex. Try s/1/2/, s#3#4#...");
-}
-
-sub set {
- my($args) = @_;
- my($item, $what, $value);
-
- if (!defined $args) {
- &::DEBUG("news: set: args == NULL.");
- return;
- }
-
- $item = $1 if ($args =~ s/^(\S+)\s*//);
- $what = $1 if ($args =~ s/^(\S+)\s*//);
- $value = $args;
-
- if ($item eq '') {
- &::help('news set');
- return;
- }
-
- my $news = &getNewsItem($item);
-
- if (!defined $news) {
- &::notice($who, "Could not find item '$item' substring or # in news list.");
- return;
- }
-
- # list all values for chan.
- if (!defined $what or $what =~ /^\s*$/) {
- &::msg($who, "set: you didn't fill me on the arguments! (what and values)");
- return;
- }
-
- my $ok = 0;
- my @elements = ('Expire','Text');
- foreach (@elements) {
- next unless ($what =~ /^$_$/i);
- $what = $_;
- $ok++;
- last;
- }
-
- if (!$ok) {
- &::notice($who, "Invalid set. Try: @elements");
- return;
- }
-
- # show (read) what.
- if (!defined $value or $value =~ /^\s*$/) {
- &::msg($who, "set: you didn't fill me on the arguments! (value)");
- return;
- }
-
- if (!exists $::news{$chan}{$news}) {
- &::notice($who, "news '$news' does not exist");
- return;
- }
-
- if ($what eq 'Expire') {
- # TODO: use do_set().
-
- my $time = 0;
- my $plus = ($value =~ s/^\+//g);
- while ($value =~ s/^(\d+)(\S*)\s*//) {
- my($int,$unit) = ($1,$2);
- $time += $int if ($unit =~ /^s(ecs?)?$/i);
- $time += $int*60 if ($unit =~ /^m(in(utes?)?)?$/i);
- $time += $int*60*60 if ($unit =~ /^h(ours?)?$/i);
- $time += $int*60*60*24 if (!$unit or $unit =~ /^d(ays?)?$/i);
- $time += $int*60*60*24*7 if ($unit =~ /^w(eeks?)?$/i);
- $time += $int*60*60*24*30 if ($unit =~ /^mon(th)?$/i);
- }
-
- if ($value =~ s/^never$//i) {
- # never.
- $time = -1;
- } elsif ($plus) {
- # from now.
- $time += time();
- } else {
- # from creation of item.
- $time += $::news{$chan}{$news}{Time};
- }
-
- if (!$time or ($value and $value !~ /^never$/i)) {
- &::DEBUG("news: set: Expire... need to parse.");
- &::msg($who, "hrm... couldn't parse that.");
- return;
- }
-
- if ($time == -1) {
- &::notice($who, "Set never expire for \002$item\002." );
- } elsif ($time < -1) {
- &::DEBUG("news: time should never be negative ($time).");
- return;
- } else {
- &::notice($who, "Set expire for \002$item\002, to ".
- gmtime($time) ." [".&::Time2String($time - time())."]" );
-
- if (time() > $time) {
- &::DEBUG("news: hrm... time() > $time, should expire.");
- }
- }
-
-
- $::news{$chan}{$news}{Expire} = $time;
-
- return;
- }
-
- my $auth = 0;
-# &::DEBUG("news: who => '$who'");
- my $author = $::news{$chan}{$news}{Author};
- $auth++ if ($::who eq $author);
- $auth++ if (&::IsFlag('o'));
- if (!defined $author) {
- &::DEBUG("news: news{$chan}{$news}{Author} is not defined! auth'd anyway");
- $::news{$chan}{$news}{Author} = $::who;
- $author = $::who;
- $auth++;
- }
-
- if (!$auth) {
- # TODO: show when it'll expire.
- &::notice($who, "Sorry, you cannot set items. (author $author owns it)");
- return;
- }
-
- # TODO: clean this up.
- my $old = $::news{$chan}{$news}{$what};
- if (defined $old) {
- &::DEBUG("news: old => $old.");
- }
- $::news{$chan}{$news}{$what} = $value;
- &::notice($who, "Setting [$chan]/{$news}/<$what> to '$value'.");
-}
-
-sub latest {
- my ($tchan, $flag) = @_;
-
- # hack hack hack. fix later.
- $chan = $tchan;
- $who = $::who;
-
- # TODO: if chan = undefined, guess.
-# if (!exists $::news{$chan}) {
- if (!exists $::channels{$chan}) {
- &::notice($who, "invalid chan $chan") if ($flag);
- return;
- }
-
- my $t = $::newsuser{$chan}{$who};
-# if (defined $t) {
-# &::DEBUG("newsuser: $chan/$who == $t");
-# } else {
-# &::DEBUG("newsuser: $chan/$who == undefined");
-# }
-
- if (defined $t and ($t == 0 or $t == -1)) {
- if ($flag) {
- &::notice($who, "if you want to read news, try \002/msg $::ident news $chan\002 or \002/msg $::ident news $chan notify\002");
- } else {
- &::DEBUG("news: not displaying any new news for $who");
- return;
- }
- }
-
- $::chan = $chan;
- return if (&::IsChanConf('newsNotifyAll') <= 0);
-
- # I don't understand this code ;)
- $t = 1 if (!defined $t);
-
- if (!defined $t) {
-# &::msg($who, "News is disabled for $chan");
- &::DEBUG("news: $chan: something went really wrong.");
- return;
- }
-
- my @new;
- foreach (keys %{ $::news{$chan} }) {
- next if (!defined $t);
- next if ($t > $::news{$chan}{$_}{Time});
-
- # don't list new items if they don't have Text.
- if (!exists $::news{$chan}{$_}{Text}) {
- if (time() - $::news{$chan}{$_}{Time} > 60*60*24*3) {
- &::DEBUG("deleting news{$chan}{$_} because it was too old and had no text info.");
- delete $::news{$chan}{$_};
- }
-
- next;
- }
-
- push(@new, $_);
- }
-
- # !scalar @new, $flag
- if (!scalar @new and $flag) {
- &::notice($who, "no new news for $chan for $who.");
- # valid to set this?
- $::newsuser{$chan}{$who} = time();
- return;
- }
-
- # scalar @new, !$flag
- my $unread = scalar @new;
- my $total = scalar keys %{ $::news{$chan} };
- if (!$flag && &::IsChanConf('newsTellUnread') <= 0) {
- return;
- }
-
- if (!$flag) {
- return unless ($unread);
-
- # just a temporary measure not to flood ourself off the
- # network with news until we get global notice() and msg()
- # throttling.
- if (time() - ($::cache{newsTime} || 0) < 5) {
- &::status("news: not displaying latest notice to $who/$chan.");
- return;
- }
-
- $::cache{newsTime} = time();
- my $reply = "There are unread news in $chan ($unread unread, $total total). /msg $::ident news $::chan latest";
- $reply .= " If you don't want further news notification, /msg $::ident news unnotify" if ($unread == $total);
- &::notice($who, $reply);
-
- return;
- }
-
- # scalar @new, $flag
- if (scalar @new) {
- &::notice($who, "+==== New news for \002$chan\002 ($unread new; $total total):");
-
- my $t = $::newsuser{$chan}{$who};
- if (defined $t and $t > 1) {
- my $timestr = &::Time2String( time() - $t );
- &::notice($who, "|= Last time read $timestr ago");
- }
-
- my $i;
- my @sorted;
- foreach (@new) {
- $i = &newsS2N($_);
- $sorted[$i] = $_;
- }
-
- for ($i=0; $i<=scalar(@sorted); $i++) {
- my $news = $sorted[$i];
- next unless (defined $news);
-
-# my $age = time() - $::news{$chan}{$news}{Time};
- my $msg = sprintf("\002[\002%2d\002]\002 %s", $i, $news);
-### $i, $_, &::Time2String($age)
- $::conn->schedule(int((2+$i)/2), sub {
- &::notice($who, $msg);
- } );
- }
-
- # TODO: implement throttling via schedule into ¬ice() / &msg().
- $::conn->schedule(int((2+$i)/2), sub {
- &::notice($who, "|= to read, do \002news $chan read <#>\002 or \002news $chan read <keyword>\002");
- } );
-
- # lame hack to prevent dupes if we just ignore it.
- my $x = $::newsuser{$chan}{$who};
- if (defined $x and ($x == 0 or $x == -1)) {
- &::DEBUG("news: not updating time for $who. (2)");
- } else {
- $::newsuser{$chan}{$who} = time();
- }
- }
-}
-
-###
-### helpers...
-###
-
-sub getNewsAll {
- my %time;
- foreach (keys %{ $::news{$chan} }) {
- $time{ $::news{$chan}{$_}{Time} } = $_;
- }
-
- my @items;
- foreach (sort { $a <=> $b } keys %time) {
- push(@items, $time{$_});
- }
-
- return @items;
-}
-
-sub newsS2N {
- my($what) = @_;
- my $item = 0;
- my @items;
- my $no;
-
- my %time;
- foreach (keys %{ $::news{$chan} }) {
- my $t = $::news{$chan}{$_}{Time};
-
- if (!defined $t or $t !~ /^\d+$/) {
- &::DEBUG("news: warn: t is undefined for news{$chan}{$_}{Time}; removing item.");
- delete $::news{$chan}{$_};
- next;
- }
-
- $time{$t} = $_;
- }
-
- foreach (sort { $a <=> $b } keys %time) {
- $item++;
- return $item if ($time{$_} eq $what);
- }
-
- &::DEBUG("newsS2N($what): failed...");
-}
-
-sub getNewsItem {
- my($what) = @_;
- my $item = 0;
-
- $what =~ s/^\#//; # '#1' for example.
-
- my %time;
- foreach (keys %{ $::news{$chan} }) {
- my $t = $::news{$chan}{$_}{Time};
-
- if (!defined $t or $t !~ /^\d+$/) {
- &::DEBUG("news: warn: t is undefined for news{$chan}{$_}{Time}; removing item.");
- delete $::news{$chan}{$_};
- next;
- }
-
- $time{$t} = $_;
- }
-
- # number to string resolution.
- if ($what =~ /^\d+$/) {
- foreach (sort { $a <=> $b } keys %time) {
- $item++;
- return $time{$_} if ($item == $what);
- }
-
- } else {
- # partial string to full string resolution
- # in some cases, string->number resolution.
-
- my @items;
- my $no;
- foreach (sort { $a <=> $b } keys %time) {
- $item++;
-# $no = $item if ($time{$_} eq $what);
-## if ($time{$_} eq $what) {
-## $no = $item;
-## next;
-## }
-
- push(@items, $time{$_}) if ($time{$_} =~ /\Q$what\E/i);
- }
-
-## if (defined $no and !@items) {
-## &::DEBUG("news: string->number resolution: $what->$no.");
-## return $no;
-## }
-
- if (scalar @items > 1) {
- &::DEBUG("news: Multiple matches, not guessing.");
- &::notice($who, "Multiple matches, not guessing.");
- return;
- }
-
- if (@items) {
-# &::DEBUG("news: gNI: part_string->full_string: $what->$items[0]");
- return $items[0];
- } else {
- &::DEBUG("news: gNI: No match for '$what'");
- return;
- }
- }
-
- &::ERROR("news: gNI: should not happen (what = $what)");
- return;
-}
-
-sub do_set {
- my($what,$value) = @_;
-
- if (!defined $chan) {
- &::DEBUG("news: do_set: chan not defined.");
- return;
- }
-
- if (!defined $what or $what =~ /^\s*$/) {
- &::DEBUG("news: what $what is not defined.");
- return;
- }
-
- if (!defined $value or $value =~ /^\s*$/) {
- &::DEBUG("news: value $value is not defined.");
- return;
- }
-
- &::TODO("news: do_set:");
-}
-
-sub stats {
- &::DEBUG("News: stats called.");
- &::msg($who, "check my logs/console.");
- my($i,$j) = (0,0);
-
- # total request count.
- foreach $chan (keys %::news) {
- foreach (keys %{ $::news{$chan} }) {
- $i += $::news{$chan}{$_}{Request_Count};
- }
- }
- &::DEBUG("news: stats: total request count => $i");
- $i = 0;
-
- # total user cached.
- foreach $chan (keys %::newsuser) {
- $i += $::newsuser{$chan}{$_};
- }
- &::DEBUG("news: stats: total user cache => $i");
- $i = 0;
-
- # average latest time read.
- my $t = time();
- foreach $chan (keys %::newsuser) {
- $i += $t - $::newsuser{$chan}{$_};
- &::DEBUG(" i = $i");
- $j++;
- }
- &::DEBUG("news: stats: average latest time read: total time: $i");
- &::DEBUG("news: ... count: $j");
- &::DEBUG("news: average: ".sprintf("%.02f", $i/($j||1))." sec/user");
- $i = $j = 0;
-}
-
-sub AUTOLOAD { &::AUTOLOAD(@_); }
-
-1;
+++ /dev/null
-#!/usr/bin/perl
-#
-# OnJoin.pl: emit a message when a user enters the channel
-# Author: Corey Edwards <tensai@zmonkey.org>
-# Version: v0.3.1
-# Created: 20051222
-# Updated: 20060112
-
-use strict;
-
-use vars qw(%channels %param);
-use vars qw($dbh $who $chan);
-
-sub onjoin {
- my ($nick, $user, $host, $chan) = @_;
- $nick = lc $nick;
-
- # look for a channel specific message
- my $message = &sqlSelect('onjoin', 'message', { nick => $nick, channel => $chan } ) || 0;
-
- # look for a default message
- if (!$message){
- $message = &sqlSelect('onjoin', 'message', { nick => $nick, channel => '_default' } ) || 0;
- }
-
- # print the message, if there was one
- if ($message){
- $message = substVars($message, 1);
- if ($message =~ m/^<action>\s*(.*)/){
- &status("OnJoin: $nick arrived, performing action");
- &action($chan, $1);
- }
- else{
- $message =~ s/^<reply>\s*//;
- &status("OnJoin: $nick arrived, printing message");
- &msg($chan, $message);
- }
- }
-
- return;
-}
-
-# set and get messages
-sub Cmdonjoin {
- $_ = shift;
- m/(\S*)(\s*(\S*)(\s*(.*)|)|)/;
- my $ch = $1;
- my $nick = $3;
- my $msg = $5;
-
- # get options
- my $strict = &getChanConf('onjoinStrict');
- my $ops = &getChanConf('onjoinOpsOnly');
-
- # see if they specified a channel
- if ($ch !~ m/^\#/ && $ch ne '_default'){
- $msg = $nick . ($msg ? " $msg" : '');
- $nick = $ch;
- $ch = $chan;
- }
-
- $nick = lc $nick;
-
- if ($nick =~ m/^-(.*)/){
- $nick = $1;
- if ($ops){
- if (!$channels{$chan}{o}{$who}){
- &performReply("sorry, you're not an operator");
- }
- }
- elsif ($strict){
- # regardless of strict mode, ops can always change
- if (!$channels{$chan}{o}{$who} and $nick ne $who){
- &performReply("I can't alter a message for another user (strict mode)");
- }
- }
- else{
- &sqlDelete('onjoin', { nick => $nick, channel => $ch });
- &performReply('ok');
- }
- return;
- }
-
- # if msg not set, show what the message would be
- if (!$msg){
- $nick = $who if (!$nick);
- my %row = &sqlSelectRowHash('onjoin', 'message, modified_by, modified_time', { nick => $nick, channel => $ch } );
- if ($row{'message'}){
- &performStrictReply("onjoin for $nick set by $row{modified_by} on " . localtime($row{modified_time}) . ": $row{message}");
- }
- return;
- }
-
- # only allow changes by ops
- if ($ops){
- if (!$channels{$chan}{o}{$who}){
- &performReply("sorry, you're not an operator");
- return;
- }
- }
- # only allow people to change their own message (superceded by OpsOnly)
- elsif ($strict){
- # regardless of strict mode, ops can always change
- if (!$channels{$chan}{o}{$who} and $nick ne $who){
- &performReply("I can't alter a message for another user (strict mode)");
- return;
- }
- }
-
- # remove old one (if exists) and add new message
- &sqlDelete('onjoin', { nick => $nick, channel => $ch });
- my $insert = &sqlInsert('onjoin', { nick => $nick, channel => $ch, message => $msg, modified_by => $who, modified_time => time() });
- if ($insert){
- &performReply('ok');
- }
- else{
- &performReply('whoops. database error');
- }
- return;
-}
-
-1;
+++ /dev/null
-#
-# Plug.pl: hacked for http://Plug.org/ by Tim Riker <Tim@Rikers.org>
-# Slashdot.pl: Slashdot headline retrival
-# Author: Chris Tessone <tessone@imsa.edu>
-# Modified: dms
-# Licensing: Artistic License (as perl itself)
-# Version: v0.4 (19991125)
-#
-
-###
-# fixed up to use XML'd /. backdoor 7/31 by richardh@rahga.com
-# My only request if this gets included in infobot is that the
-# other header gets trimmed to 2 lines, dump the fluff ;) -rah
-#
-# added a status message so people know to install LWP - oznoid
-# also simplified the return code because it wasn't working.
-###
-
-
-package Plug;
-
-use strict;
-
-sub plugParse {
- my @list;
-
- foreach (@_) {
- next unless (/<title>(.*?)<\/title>/);
- my $title = $1;
- $title =~ s/&\;/&/g;
- push(@list, $title);
- }
-
- return @list;
-}
-
-sub Plug {
- my @results = &::getURL("http://www.plug.org/index.xml");
- my $retval = "i could not get the headlines.";
-
- if (scalar @results) {
- my $prefix = 'Plug Headlines ';
- my @list = &plugParse(@results);
- $retval = &::formListReply(0, $prefix, @list);
- }
-
- &::performStrictReply($retval);
-}
-
-sub plugAnnounce {
- my $file = "$::param{tempDir}/plug.xml";
-
- my @Cxml = &::getURL("http://www.plug.org/index.xml");
- if (!scalar @Cxml) {
- &::DEBUG("sdA: failure (Cxml == NULL).");
- return;
- }
-
- if (! -e $file) { # first time run.
- open(OUT, ">$file");
- foreach (@Cxml) {
- print OUT "$_\n";
- }
- close OUT;
-
- return;
- }
-
- my @Oxml;
- open(IN, $file);
- while (<IN>) {
- chop;
- push(@Oxml,$_);
- }
- close IN;
-
- my @Chl = &plugParse(@Cxml);
- my @Ohl = &plugParse(@Oxml);
-
- my @new;
- foreach (@Chl) {
- last if ($_ eq $Ohl[0]);
- push(@new, $_);
- }
-
- if (scalar @new == 0) {
- &::status("Plug: no new headlines.");
- return;
- }
-
- if (scalar @new == scalar @Chl) {
- &::DEBUG("sdA: scalar(new) == scalar(Chl). bad?");
- }
-
- open(OUT,">$file");
- foreach (@Cxml) {
- print OUT "$_\n";
- }
- close OUT;
-
- return "Plug: ".
- join(" \002::\002 ", @new);
-}
-
-1;
+++ /dev/null
-#
-# Quote.pl: retrieve stock quotes from yahoo
-# heavily based on Slashdot.pl
-# Version: v0.1
-# Author: Michael Urman <mu@zen.dhis.org>
-# Licensing: Artistic
-# changes from Morten Brix Pedersen (mbrix) and Tim Riker <Tim@Rikers.org>
-#
-
-package Quote;
-
-use strict;
-
-sub commify {
- my $input = shift;
- $input = reverse $input;
- $input =~ s/(\d\d\d)(?=\d)(?!\d*\.)/$1,/g;
- return scalar reverse $input;
-}
-
-sub Quote {
- my $stock = shift;
- my @results = &::getURL('http://quote.yahoo.com/d/quotes.csv' .
- "?s=$stock&f=sl1d1t1c1ohgv&e=.csv");
-
-
- if (!scalar @results) {
- &::msg($::who, "i could not get a stock quote :(");
- }
-
- my ($reply);
- foreach my $result (@results) {
- # get rid of the quotes
- $result =~ s/\"//g;
-
- my ($ticker, $recent, $date, $time, $change, $open,
- $high, $low, $volume) = split(',',$result);
-
- # add some commas
- # "+ 0" removes trailing cr/lf/etc.
- my $newvol = commify($volume + 0);
-
- $reply .= ' ;; ' if $reply;
- $reply .= "$ticker: $recent ($high/$low), $date $time, " .
- "Opened $open, Volume $newvol, Change $change";
- }
-
- if ($reply eq '') {
- $reply = "i couldn't get the quote for $stock. sorry. :(";
- }
-
- &::performStrictReply($reply);
-}
-
-1;
+++ /dev/null
-#
-# RootWarn.pl: Warn people about usage of root on IRC.
-# Author: dms
-# Version: v0.3 (20000923)
-# Created: 19991008
-#
-
-use strict;
-
-use vars qw(%channels %param);
-use vars qw($dbh $found $ident);
-
-sub rootWarn {
- my ($nick,$user,$host,$chan) = @_;
- my $n = lc $nick;
- my $attempt = &sqlSelect('rootwarn', 'attempt', { nick => $n } ) || 0;
- my $warnmode = &getChanConf('rootWarnMode');
-
- if ($attempt == 0) { # first timer.
- if (defined $warnmode and $warnmode =~ /quiet/i) {
- &status('RootWarn: Detected root user; notifying user');
- } else {
- &status('RootWarn: Detected root user; notifying nick and channel.');
- &msg($chan, 'ROO'.('O' x int(rand 8))."T has landed!");
- }
-
- if ($_ = &getFactoid('root')) {
- &msg($nick, "RootWarn: $attempt : $_");
- } else {
- &status('"root" needs to be defined in database.');
- }
-
- } elsif ($attempt < 2) { # 2nd/3rd time occurrance.
- if ($_ = &getFactoid('root again')) {
- &status("RootWarn: not first time root user; msg'ing $nick.");
- &msg($nick, "RootWarn: $attempt : $_");
- } else {
- &status('"root again" needs to be defined in database.');
- }
-
- } else { # >3rd time occurrance.
- # disable this for the time being.
- if (0 and $warnmode =~ /aggressive/i) {
- if ($channels{$chan}{'o'}{$ident}) {
- &status("RootWarn: $nick... sigh... bye bye.");
- rawout("MODE $chan +b *!root\@$host"); # ban
- &kick($chan,$nick,'bye bye');
- }
- } elsif ($_ = &getFactoid('root again')) {
- &status("RootWarn: $attempt times; msg'ing $nick.");
- &msg($nick, "RootWarn: $attempt : $_");
- } else {
- &status("root again needs to be defined in database.");
- }
- }
-
- $attempt++;
- ### TODO: OPTIMIZE THIS.
- # ok... don't record the attempt if nick==root.
- return if ($nick eq 'root');
-
- &sqlSet('rootwarn', { nick => lc($nick) }, {
- attempt => $attempt,
- time => time(),
- host => $user."\@".$host,
- channel => $chan,
- } );
-
- return;
-}
-
-# Extras function.
-# TODO: support arguments to get info on a particular nick?
-sub CmdrootWarn {
- my $reply;
- my $count = &countKeys('rootwarn');
-
- if ($count == 0) {
- &performReply("no-one has been warned about root, woohoo");
- return;
- }
-
- # reply #1.
- $reply = 'there '.&fixPlural('has',$count) ." been \002$count\002 ".
- &fixPlural('rooter',$count) ." warned about root.";
-
- if ($param{'DBType'} !~ /^(pg|my)sql$/i) {
- &FIXME("rootwarn does not yet support non-{my,pg}sql.");
- return;
- }
-
- # reply #2.
- $found = 0;
- my $query = "SELECT attempt FROM rootwarn WHERE attempt > 2";
- my $sth = $dbh->prepare($query);
- $sth->execute;
-
- while (my @row = $sth->fetchrow_array) {
- $found++;
- }
-
- $sth->finish;
-
- if ($found) {
- $reply .= " Of which, \002$found\002 ".
- &fixPlural('rooter',$found).' '.
- &fixPlural('has',$found).
- " done it at least 3 times.";
- }
-
- &performStrictReply($reply);
-}
-
-1;
+++ /dev/null
-#
-# Rss.pl: rss handler hacked from Plug.pl
-# Author: Tim Riker <Tim@Rikers.org>
-# Licensing: Artistic License (as perl itself)
-# Version: v0.1
-#
-
-package Rss;
-
-use strict;
-
-sub Rss::Titles {
- return join(' ',@_)=~m/<title>\s*(.*?)\s*<\/title>/gi;
-}
-
-sub Rss::Rss {
- my ($message) = @_;
- my @results = &::getURL($message);
- my $retval = "i could not get the rss feed.";
-
- my @list = &Rss::Titles(@results) if (scalar @results);
- $retval = &::formListReply(0, 'Titles: ', @list) if (scalar @list);
-
- &::performStrictReply($retval);
-}
-
-1;
-# vim: ts=2 sw=2
+++ /dev/null
-#
-# infobot copyright kevin lenzo 1997-1998
-# rewritten by xk 1999
-#
-
-package Search;
-
-use strict;
-
-###
-# Search(keys||vals, str);
-sub Search {
- my ($type, $str) = @_;
- my $start_time = &::timeget();
- my @list;
- my $maxshow = &::getChanConfDefault('maxListReplyCount', 15, $::chan);
-
- $type =~ s/s$//; # nice work-around.
-
- if ($type eq 'value') {
- # search by value.
- @list = &::searchTable('factoids', 'factoid_key', 'factoid_value', $str);
- } else {
- # search by key.
- @list = &::searchTable('factoids', 'factoid_key', 'factoid_key', $str);
- }
-
- @list=grep(!/\#DEL\#$/,@list) if (scalar(@list) > $maxshow);
- my $delta_time = sprintf("%.02f", &::timedelta($start_time) );
- &::status("search: took $delta_time sec for query.") if ($delta_time > 0);
-
- my $prefix = "Factoid search of '\002$str\002' by $type ";
-
- &::performStrictReply( &::formListReply(1, $prefix, @list) );
-}
-
-1;
+++ /dev/null
-#
-# Topic.pl: Advanced topic management (maxtopiclen>=512)
-# Author: dms
-# Version: v0.8 (19990919).
-# Created: 19990720
-#
-
-use strict;
-use vars qw(%topiccmp %topic %channels %cache %orig);
-use vars qw($who $chan $conn $uh $ident);
-
-###############################
-##### INTERNAL FUNCTIONS
-###############################
-
-###
-# Usage: &topicDecipher(chan);
-sub topicDecipher {
- my ($chan) = @_;
- my @results;
-
- return if (!exists $topic{$chan});
- return if (!exists $topic{$chan}{'Current'});
-
- foreach (split /\|\|/, $topic{$chan}{'Current'}) {
- s/^\s+//;
- s/\s+$//;
-
- # very nice fix to solve the null subtopic problem.
- # if nick contains a space, treat topic as ownerless.
- if (/^\(.*?\)$/) {
- next unless ($1 =~ /\s/);
- }
-
- my $subtopic = $_;
- my $owner = 'Unknown';
-
- if (/(.*)\s+\((.*?)\)$/) {
- $subtopic = $1;
- $owner = $2;
- }
-
- if (grep /^\Q$subtopic\E\|\|\Q$owner\E$/, @results) {
- &status("Topic: we have found a dupe ($subtopic) in the topic, not adding.");
- next;
- }
-
- push(@results, "$subtopic||$owner");
- }
-
- return @results;
-}
-
-###
-# Usage: &topicCipher(@topics);
-sub topicCipher {
- return if (!@_);
-
- my @topic;
- foreach (@_) {
- my ($subtopic, $setby) = split /\|\|/;
-
- if ($param{'topicAuthor'} eq '1' and (!$setby =~ /^(unknown|)$/i)) {
- push(@topic, "$subtopic ($setby)");
- } else {
- push(@topic, "$subtopic");
- }
- }
-
- return join(' || ', @topic);
-}
-
-###
-# Usage: &topicNew($chan, $topic, $updateMsg);
-sub topicNew {
- my ($chan, $topic, $updateMsg) = @_;
- my $maxlen = 470;
-
- if ($channels{$chan}{t} and !$channels{$chan}{o}{$ident}) {
- &msg($who, "error: cannot change topic without ops. (channel is +t) :(");
- return 0;
- }
-
- if (defined $topiccmp{$chan} and $topiccmp{$chan} eq $topic) {
- &msg($who, "warning: action had no effect on topic; no change required.");
- return 0;
- }
-
- # bail out if the new topic is too long.
- my $newlen = length($chan.$topic);
- if ($newlen > $maxlen) {
- &msg($who, "new topic will be too long. ($newlen > $maxlen)");
- return 0;
- }
-
- $topic{$chan}{'Current'} = $topic;
-
- if ($cache{topicNotUpdate}{$chan}) {
- &msg($who, "done. 'flush' to finalize changes.");
- delete $cache{topicNotUpdate}{$chan};
- return 1;
- }
-
- if (defined $updateMsg && $updateMsg ne '') {
- &msg($who, $updateMsg);
- }
-
- $topic{$chan}{'Last'} = $topic;
- $topic{$chan}{'Who'} = $orig{who}."!".$uh;
- $topic{$chan}{'Time'} = time();
-
- if ($topic) {
- $conn->topic($chan, $topic);
- &topicAddHistory($chan, $topic);
- } else {
- $conn->topic($chan, ' ');
- }
-
- return 1;
-}
-
-###
-# Usage: &topicAddHistory($chan,$topic);
-sub topicAddHistory {
- my ($chan, $topic) = @_;
- my $dupe = 0;
-
- return 1 if ($topic eq ''); # required fix.
-
- foreach (@{ $topic{$chan}{'History'} }) {
- next if ($_ ne '' and $_ ne $topic);
- # checking length is required.
-
- # slightly weird to put a return statement in a loop.
- return 1;
- }
-
- # WTF IS THIS FOR?
-
- my @topics = @{ $topic{$chan}{'History'} };
- unshift(@topics, $topic);
- pop(@topics) while (scalar @topics > 6);
- $topic{$chan}{'History'} = \@topics;
-
- return $dupe;
-}
-
-###############################
-##### HELPER FUNCTIONS
-###############################
-
-# cmd: add.
-sub do_add {
- my ($chan, $args) = @_;
-
- if ($args eq '') {
- &help('topic add');
- return;
- }
-
- # heh, joeyh. 19990819. -xk
- if ($who =~ /\|\|/) {
- &msg($who, 'error: you have an invalid nick, loser!');
- return;
- }
-
- return if ($channels{$chan}{t} and !&hasFlag('T'));
-
- my @prev = &topicDecipher($chan);
- my $new;
- # If bot new to chan and topic is blank, it still got a (owner). This is fix
- if ($param{'topicAuthor'} eq '1') {
- $new = "$args ($orig{who})";
- } else {
- $new = "$args";
- }
- $topic{$chan}{'What'} = "Added '$args'.";
-
- if (scalar @prev) {
- my $str = sprintf("%s||%s", $args, $who);
- $new = &topicCipher(@prev, $str);
- }
-
- &topicNew($chan, $new, '');
-}
-
-# cmd: delete.
-sub do_delete {
- my ($chan, $args) = @_;
- my @subtopics = &topicDecipher($chan);
- my $topiccount = scalar @subtopics;
-
- if ($topiccount == 0) {
- &msg($who, 'No topic set.');
- return;
- }
-
- if ($args eq '') {
- &help('topic del');
- return;
- }
-
- for ($args) {
- $_ = sprintf(",%s,", $args);
- s/\s+//g;
- s/(first|1st)/1/i;
- s/last/$topiccount/i;
- s/,-(\d+)/,1-$1/;
- s/(\d+)-,/,$1-$topiccount/;
- }
-
- if ($args !~ /[\,\-\d]/) {
- &msg($who, "error: Invalid argument ($args).");
- return;
- }
-
- my @delete;
- foreach (split ',', $args) {
- next if ($_ eq '');
-
- # change to hash list instead of array?
- if (/^(\d+)-(\d+)$/) {
- my ($from,$to) = ($1,$2);
- ($from,$to) = ($2,$1) if ($from > $to);
-
- push(@delete, $1..$2);
- } elsif (/^(\d+)$/) {
- push(@delete, $1);
- } else {
- &msg($who, "error: Invalid sub-argument ($_).");
- return;
- }
-
- $topic{$chan}{'What'} = 'Deleted '.join("/",@delete);
- }
-
- foreach (@delete) {
- if ($_ > $topiccount || $_ < 1) {
- &msg($who, "error: argument out of range. (max: $topiccount)");
- return;
- }
-
- # skip if already deleted.
- # only checked if x-y range is given.
- next unless (defined($subtopics[$_-1]));
-
- my ($subtopic,$whoby) = split('\|\|', $subtopics[$_-1]);
-
- $whoby = 'unknown' if ($whoby eq '');
-
- &msg($who, "Deleting topic: $subtopic ($whoby)");
- undef $subtopics[$_-1];
- }
-
- my @newtopics;
- foreach (@subtopics) {
- next unless (defined $_);
- push(@newtopics, $_);
- }
-
- &topicNew($chan, &topicCipher(@newtopics), '');
-}
-
-# cmd: list
-sub do_list {
- my ($chan, $args) = @_;
- my @topics = &topicDecipher($chan);
-
- if (!scalar @topics) {
- &msg($who, "No topics for \002$chan\002.");
- return;
- }
-
- &msg($who, "Topics for \002$chan\002:");
- &msg($who, "No \002[\002 Set by \002]\002 Topic");
-
- my $i = 1;
- foreach (@topics) {
- my ($subtopic, $setby) = split /\|\|/;
-
- my $str = sprintf(" %d. [%-10s] %s", $i, $setby, $subtopic);
- # is there a better way of doing this?
- $str =~ s/ (\[)/ \002$1/g;
- $str =~ s/ (\])/ \002$1/g;
-
- &msg($who, $str);
- $i++;
- }
-
- &msg($who, "End of Topics.");
-}
-
-# cmd: modify.
-sub do_modify {
- my ($chan, $args) = @_;
-
- if ($args eq '') {
- &help('topic mod');
- return;
- }
-
- # a warning message instead of halting. we kind of trust the user now.
- if ($args =~ /\|\|/) {
- &msg($who, "warning: adding double pipes manually == evil. be warned.");
- }
-
- $topic{$chan}{'What'} = "SAR $args";
-
- # SAR patch. mu++
- if ($args =~ m|^\s*s([/,#])(.+?)\1(.*?)\1([a-z]*);?\s*$|) {
- my ($delim, $op, $np, $flags) = ($1,$2,$3,$4);
-
- if ($flags !~ /^(g)?$/) {
- &msg($who, "error: Invalid flags to regex.");
- return;
- }
-
- my $topic = $topic{$chan}{'Current'};
-
- ### TODO: use m### to make code safe!
- if (($flags eq 'g' and $topic =~ s/\Q$op\E/$np/g) ||
- ($flags eq '' and $topic =~ s/\Q$op\E/$np/)
- ) {
-
- $_ = "Modifying topic with sar s/$op/$np/.";
- &topicNew($chan, $topic, $_);
- } else {
- &msg($who, "warning: regex not found in topic.");
- }
-
- return;
- }
-
- &msg($who, "error: Invalid regex. Try s/1/2/, s#3#4#...");
-}
-
-# cmd: move.
-sub do_move {
- my ($chan, $args) = @_;
-
- if ($args eq '') {
- &help('topic mv');
- return;
- }
-
- my ($from, $action, $to);
- # better way of doing this?
- if ($args =~ /^(first|last|\d+)\s+(before|after|swap)\s+(first|last|\d+)$/i) {
- ($from, $action, $to) = ($1,$2,$3);
- } else {
- &msg($who, "Invalid arguments.");
- return;
- }
-
- my @subtopics = &topicDecipher($chan);
- my @newtopics;
- my $topiccount = scalar @subtopics;
-
- if ($topiccount == 1) {
- &msg($who, "error: impossible to move the only subtopic, dumbass.");
- return;
- }
-
- # Is there an easier way to do this?
- $from =~ s/first/1/i;
- $to =~ s/first/1/i;
- $from =~ s/last/$topiccount/i;
- $to =~ s/last/$topiccount/i;
-
- if ($from > $topiccount || $to > $topiccount || $from < 1 || $to < 1) {
- &msg($who, "error: <from> or <to> is out of range.");
- return;
- }
-
- if ($from == $to) {
- &msg($who, "error: <from> and <to> are the same.");
- return;
- }
-
- $topic{$chan}{'What'} = "Move $from to $to";
-
- if ($action =~ /^(swap)$/i) {
- my $tmp = $subtopics[$to - 1];
- $subtopics[$to - 1] = $subtopics[$from - 1];
- $subtopics[$from - 1] = $tmp;
-
- $_ = "Swapped #\002$from\002 with #\002$to\002.";
- &topicNew($chan, &topicCipher(@subtopics), $_);
- return;
- }
-
- # action != swap:
- # Is there a better way to do this? guess not.
- my $i = 1;
- my $subtopic = $subtopics[$from - 1];
- foreach (@subtopics) {
- my $j = $i*2 - 1;
- $newtopics[$j] = $_ if ($i != $from);
- $i++;
- }
-
- if ($action =~ /^(before|b4)$/i) {
- $newtopics[$to*2-2] = $subtopic;
- } else {
- # action =~ /after/.
- $newtopics[$to*2] = $subtopic;
- }
-
- undef @subtopics; # lets reuse this array.
- foreach (@newtopics) {
- next if (!defined $_ or $_ eq '');
- push(@subtopics, $_);
- }
-
- $_ = "Moved #\002$from\002 $action #\002$to\002.";
- &topicNew($chan, &topicCipher(@subtopics), $_);
-}
-
-# cmd: shuffle.
-sub do_shuffle {
- my ($chan, $args) = @_;
- my @subtopics = &topicDecipher($chan);
- my @newtopics;
-
- $topic{$chan}{'What'} = 'shuffled';
-
- foreach (&makeRandom(scalar @subtopics)) {
- push(@newtopics, $subtopics[$_]);
- }
-
- $_ = "Shuffling the bag of lollies.";
- &topicNew($chan, &topicCipher(@newtopics), $_);
-}
-
-# cmd: history.
-sub do_history {
- my ($chan, $args) = @_;
-
- if (!scalar @{ $topic{$chan}{'History'} }) {
- &msg($who, "Sorry, no topics in history list.");
- return;
- }
-
- &msg($who, "History of topics on \002$chan\002:");
- for (1 .. scalar @{ $topic{$chan}{'History'} }) {
- my $topic = ${ $topic{$chan}{'History'} }[$_-1];
- &msg($who, " #\002$_\002: $topic");
-
- # To prevent excess floods.
- sleep 1 if (length($topic) > 160);
- }
-
- &msg($who, "End of list.");
-}
-
-# cmd: restore.
-sub do_restore {
- my ($chan, $args) = @_;
-
- if ($args eq '') {
- &help('topic restore');
- return;
- }
-
- $topic{$chan}{'What'} = "Restore topic $args";
-
- # following needs to be verified.
- if ($args =~ /^last$/i) {
- if (${ $topic{$chan}{'History'} }[0] eq $topic{$chan}{'Current'}) {
- &msg($who,"error: cannot restore last topic because it's mine.");
- return;
- }
- $args = 1;
- }
-
- if ($args !~ /\d+/) {
- &msg($who, "error: argument is not positive integer.");
- return;
- }
-
- if ($args > $#{ $topic{$chan}{'History'} } || $args < 1) {
- &msg($who, "error: argument is out of range.");
- return;
- }
-
- $_ = "Changing topic according to request.";
- &topicNew($chan, ${ $topic{$chan}{'History'} }[$args-1], $_);
-}
-
-# cmd: rehash.
-sub do_rehash {
- my ($chan) = @_;
-
- $_ = "Rehashing topic...";
- $topic{$chan}{'What'} = 'Rehash';
- &topicNew($chan, $topic{$chan}{'Current'}, $_, 1);
-}
-
-# cmd: info.
-sub do_info {
- my ($chan) = @_;
-
- my $reply = "no topic info.";
- if (exists $topic{$chan}{'Who'} and exists $topic{$chan}{'Time'}) {
- $reply = "topic on \002$chan\002 was last set by ".
- $topic{$chan}{'Who'}. ". This was done ".
- &Time2String(time() - $topic{$chan}{'Time'}) .' ago'.
- ". Length: ".length($topic{$chan}{'Current'});
- my $change = $topic{$chan}{'What'};
- $reply .= ". Change => $change" if (defined $change);
- }
-
- &performStrictReply($reply);
-}
-
-###############################
-##### MAIN
-###############################
-
-###
-# Usage: &Topic($cmd, $args);
-sub Topic {
- my ($chan, $cmd, $args) = @_;
-
- if ($cmd =~ /^-(\S+)/) {
- $cache{topicNotUpdate}{$chan} = 1;
- $cmd = $1;
- }
-
- if ($cmd =~ /^(add)$/i) {
- &do_add($chan, $args);
-
- } elsif ($cmd =~ /^(del|delete|rm|remove|kill|purge)$/i) {
- &do_delete($chan, $args);
-
- } elsif ($cmd =~ /^list$/i) {
- &do_list($chan, $args);
-
- } elsif ($cmd =~ /^(mod|modify|change|alter)$/i) {
- &do_modify($chan, $args);
-
- } elsif ($cmd =~ /^(mv|move)$/i) {
- &do_move($chan, $args);
-
- } elsif ($cmd =~ /^shuffle$/i) {
- &do_shuffle($chan, $args);
-
- } elsif ($cmd =~ /^(history)$/i) {
- &do_history($chan, $args);
-
- } elsif ($cmd =~ /^restore$/i) {
- &do_restore($chan, $args);
-
- } elsif ($cmd =~ /^(flush|rehash)$/i) {
- &do_rehash($chan);
-
- } elsif ($cmd =~ /^info$/i) {
- &do_info($chan);
-
- } else {
- ### HELP:
- if ($cmd ne '' and $cmd !~ /^help/i) {
- &msg($who, "Invalid command [$cmd].");
- &msg($who, "Try 'help topic'.");
- return;
- }
-
- &help('topic');
- }
-
- return;
-}
-
-1;
+++ /dev/null
-# Units.pl: convert units of measurement
-# Author: M-J. Dominus (mjd-perl-units-id-iut+buobvys+@plover.com)
-# License: GPL, Copyright (C) 1996,1999
-# NOTE: Integrated into blootbot by xk.
-
-package Units;
-
-# use strict; # TODO
-
-#$DEBUG_p = 1;
-#$DEBUG_o = 1;
-#$DEBUG_l = 1;
-my %unittab; # Definitions loaded here
-
-# Metric prefixes. These must be powers of ten or change the
-# token_value subroutine
-BEGIN {
- %PREF = (yocto => -24,
- zepto => -21,
- atto => -18,
- femto => -15,
- pico => -12,
- nano => -9,
- micro => -6,
-# u => -6,
- milli => -3,
- centi => -2,
- deci => -1,
- deca => 1,
- deka => 1,
- hecto => 2,
- hect => 2,
- kilo => 3,
- myria => 4,
- mega => 6,
- giga => 9,
- tera => 12,
- peta => 15,
- exa => 18,
- yotta => 21,
- zetta => 24,
- );
- $PREF = join '|', sort { $PREF{$a} <=> $PREF{$b} } (keys %PREF);
-}
-
-
-################################################################
-#
-# Main program here
-#
-################################################################
-
-{ my $defs_read = 0;
- $defs_read += read_defs("$::bot_data_dir/unittab");
-
- unless ($defs_read) {
- &::ERROR('Could not read any of the initialization files UNITTAB');
- return;
- }
-}
-
-sub convertUnits {
- my ($from,$to) = @_;
-
- # POWER HACK.
- $from =~ s/\^(\-?\d+)/$1/;
- $to =~ s/\^(\-?\d+)/$1/;
- my %powers = (
- 2 => 'squared?',
- 3 => 'cubed?',
- );
- foreach (keys %powers) {
- $from =~ s/(\D+) $powers{$_}$/$1\Q$_/;
- $to =~ s/(\D+) $powers{$_}$/$1\Q$_/;
- }
- # END OF POWER HACK.
-
- ### FROM:
- trim($from);
- if ($from =~ s/^\s*\#\s*//) {
- if (definition_line($from)) {
- &::DEBUG("Defined.");
- } else {
- &::DEBUG("Error: $PARSE_ERROR.");
- }
- &::DEBUG("FAILURE 1.");
- return;
- }
- unless ($from =~ /\S/) {
- &::DEBUG('FAILURE 2');
- return;
- }
-
- my $hu = parse_unit($from);
- if (is_Zero($hu)) {
- &::DEBUG($PARSE_ERROR);
- &::msg($::who, $PARSE_ERROR);
- return;
- }
-
- ### TO:
- my $wu;
- trim($to);
- redo unless $to =~ /\S/;
- $wu = parse_unit($to);
- if (is_Zero($wu)) {
- &::DEBUG($PARSE_ERROR);
- }
-
- my $quot = unit_divide($hu, $wu);
- if (is_dimensionless($quot)) {
- my $q = $quot->{_};
- if ($q == 0) {
- &::performStrictReply("$to is an invalid unit?");
- return;
- }
- # yet another powers hack.
- $from =~ s/([[:alpha:]]+)(\d)/$1\^$2/g;
- $to =~ s/([[:alpha:]]+)(\d)/$1\^$2/g;
-
- &::performStrictReply(sprintf("$from is approximately \002%.6g\002 $to", $q));
- } else {
- &::performStrictReply("$from cannot be correctly converted to $to.");
-
-# print
-# "conformability (Not the same dimension)\n",
-# "\t", $from, ' is ', text_unit($hu), "\n",
-# "\t", $to, ' is ', text_unit($wu), "\n",
-# ;
- }
-}
-
-
-################################################################
-
-sub read_defs {
- my ($file) = @_;
- unless (open D, $file) {
- if ($show_file_loading) {
- print STDERR "Couldn't open file `$file': $!; skipping.\n";
- }
- return 0;
- }
- while (<D>) {
- s/\#.*$//;
- trim($_);
- next unless /\S/;
-
- print ">>> $_\n" if $DEBUG_d;
- my $r = definition_line($_);
- unless (defined $r) {
- warn "Error in line $. of $file: $PARSE_ERROR. Skipping.\n";
- }
- }
- print STDERR "Loaded file `$file'.\n" if $show_file_loading;
- return 1;
-}
-
-sub definition_line {
- my ($line) = @_;
- my ($name, $data) = split /\s+/, $line, 2;
- my $value = parse_unit($data);
- if (is_Zero($value)) {
- return;
- }
- if (is_fundamental($value)) {
- return $unittab{$name} = {_ => 1, $name => 1};
- } else {
- return $unittab{$name} = $value;
- }
-}
-
-sub trim {
- $_[0] =~ s/\s+$//;
- $_[0] =~ s/^\s+//;
-}
-
-sub Zero () { +{ _ => 0 } }
-
-sub is_Zero {
- $_[0]{_} == 0;
-}
-
-sub unit_lookup {
- my ($name) = @_;
- print STDERR "Looking up unit `$name'\n" if $DEBUG_l;
- return $unittab{$name} if exists $unittab{$name};
- if ($name =~ /s$/) {
- my $shortname = $name;
- $shortname =~ s/s$//;
- return $unittab{$shortname} if exists $unittab{$shortname};
- }
- my ($prefix, $rest) = ($name =~ /^($PREF-?)(.*)/o);
- unless ($prefix) {
- $PARSE_ERROR = "Unknown unit `$name'";
- return Zero;
- }
- my $base_unit = unit_lookup($rest); # Recursive
- con_multiply($base_unit, 10**$PREF{$prefix});
-}
-
-sub unit_multiply {
- my ($a, $b) = @_;
- print STDERR "Multiplying @{[%$a]} by @{[%$b]}: \n" if $DEBUG_o;
- my $r = {%$a};
- $r->{_} *= $b->{_};
- my $u;
- for $u (keys %$b) {
- next if $u eq '_';
- $r->{$u} += $b->{$u};
- }
- print STDERR "\tResult: @{[%$r]}\n" if $DEBUG_o;
- $r;
-}
-
-sub unit_divide {
- my ($a, $b) = @_;
- if ($b->{_} == 0) {
- &::DEBUG('Division by zero error');
- return;
- }
- my $r = {%$a};
- $r->{_} /= $b->{_};
- my $u;
- for $u (keys %$b) {
- next if $u eq '_';
- $r->{$u} -= $b->{$u};
- }
- $r;
-}
-
-sub unit_power {
- my ($p, $u) = @_;
- print STDERR "Raising unit @{[%$u]} to power $p.\n" if $DEBUG_o;
- my $r = {%$u};
- $r->{_} **= $p;
- my $d;
- for $d (keys %$r) {
- next if $d eq '_';
- $r->{$d} *= $p;
- }
- print STDERR "\tResult: @{[%$r]}\n" if $DEBUG_o;
- $r;
-}
-
-sub unit_dimensionless {
- print "Turning $_[0] into a dimensionless unit.\n" if $DEBUG_o;
- return +{_ => $_[0]};
-}
-
-sub con_multiply {
- my ($u, $c) = @_;
- print STDERR "Multiplying unit @{[%$u]} by constant $c.\n" if $DEBUG_o;
- my $r = {%$u};
- $r->{_} *= $c;
- print STDERR "\tResult: @{[%$r]}\n" if $DEBUG_o;
- $r;
-}
-
-sub is_dimensionless {
- my ($r) = @_;
- my $u;
- for $u (keys %$r) {
- next if $u eq '_';
- return if $r->{$u} != 0;
- }
- return 1;
-}
-
-# Generate bogus unit value that signals that a new fundamental unit
-# is being defined
-sub new_fundamental_unit {
- return +{__ => 'new', _ => 1};
-}
-
-# Recognize this bogus value when it appears again.
-sub is_fundamental {
- exists $_[0]{__};
-}
-
-sub text_unit {
- my ($u) = @_;
- my (@pos, @neg);
- my $k;
- my $c = $u->{_};
- for $k (sort keys %$u) {
- next if $k eq '_';
- push @pos, $k if $u->{$k} > 0;
- push @neg, $k if $u->{$k} < 0;
- }
- my $text = ($c == 1 ? '' : $c);
- my $d;
- for $d (@pos) {
- my $e = $u->{$d};
- $text .= " $d";
- $text .= "^$e" if $e > 1;
- }
-
- $text .= ' per' if @neg;
- for $d (@neg) {
- my $e = - $u->{$d};
- $text .= " $d";
- $text .= "^$e" if $e > 1;
- }
-
- $text;
-}
-################################################################
-#
-# I'm the parser
-#
-
-BEGIN {
- sub sh { ['shift', $_[0]] };
- sub go { ['goto', $_[0]] };
- @actions =
- (
- # Initial state
- {PREFIX => sh(1),
- NUMBER => sh(2),
- NAME => sh(3),
- FUNDAMENTAL => sh(4),
- FRACTION => sh(5),
- '(' => sh(6),
- 'unit' => go(7),
- 'topunit' => go(17),
- 'constant' => go(8),
- },
- # State 1: constant -> PREFIX .
- { _ => ['reduce', 1, 'constant']},
- # State 2: constant -> NUMBER .
- { _ => ['reduce', 1, 'constant']},
- # State 3: unit -> NAME .
- { _ => ['reduce', 1, 'unit', \&unit_lookup ]},
- # State 4: unit -> FUNDAMENTAL .
- { _ => ['reduce', 1, 'unit', \&new_fundamental_unit ]},
- # State 5: constant -> FRACTION .
- { _ => ['reduce', 1, 'constant']},
- # State 6: unit -> '(' . unit ')'
- {PREFIX => sh(1),
- NUMBER => sh(2),
- NAME => sh(3),
- FUNDAMENTAL => sh(4),
- FRACTION => sh(5),
- '(' => sh(6),
- 'unit' => go(9),
- 'constant' => go(8),
- },
- # State 7: topunit -> unit .
- # unit -> unit . TIMES unit
- # unit -> unit . DIVIDE unit
- # unit -> unit . NUMBER
- {NUMBER => sh(10),
- TIMES => sh(11),
- DIVIDE => sh(12),
- _ => ['reduce', 1, 'topunit'],
- },
- # State 8: unit -> constant . unit
- # unit -> constant .
- {PREFIX => sh(1),
- NUMBER => sh(2), # Shift-reduce conflict resolved in favor of shift
- NAME => sh(3),
- FUNDAMENTAL => sh(4),
- FRACTION => sh(5),
- '(' => sh(6),
- _ => ['reduce', 1, 'unit', \&unit_dimensionless],
- 'unit' => go(13),
- 'constant' => go(8),
- },
- # State 9: unit -> unit . TIMES unit
- # unit -> unit . DIVIDE unit
- # unit -> '(' unit . ')'
- # unit -> unit . NUMBER
- {NUMBER => sh(10),
- TIMES => sh(11),
- DIVIDE => sh(12),
- ')' => sh(14),
- },
- # State 10: unit -> unit NUMBER .
- { _ => ['reduce', 2, 'unit',
- sub {
- unless (int($_[1]) == $_[1]) {
- ABORT("Nonintegral power $_[1]");
- return Zero;
- }
- unit_power(@_);
- }
- ],
- },
- # State 11: unit -> unit TIMES . unit
- {PREFIX => sh(1),
- NUMBER => sh(2),
- NAME => sh(3),
- FUNDAMENTAL => sh(4),
- FRACTION => sh(5),
- '(' => sh(6),
- 'unit' => go(15),
- 'constant' => go(8),
- },
- # State 12: unit -> unit DIVIDE . unit
- {PREFIX => sh(1),
- NUMBER => sh(2),
- NAME => sh(3),
- FUNDAMENTAL => sh(4),
- FRACTION => sh(5),
- '(' => sh(6),
- 'unit' => go(16),
- 'constant' => go(8),
- },
- # State 13: unit -> unit . TIMES unit
- # unit -> unit . DIVIDE unit
- # unit -> constant unit .
- # unit -> unit . NUMBER
- {NUMBER => sh(10), # Shift-reduce conflict resolved in favor of shift
- TIMES => sh(11), # Shift-reduce conflict resolved in favor of shift
- DIVIDE => sh(12), # Shift-reduce conflict resolved in favor of shift
- _ => ['reduce', 2, 'unit', \&con_multiply],
- },
- # State 14: unit => '(' unit ')' .
- { _ => ['reduce', 3, 'unit', sub {$_[1]}] },
- # State 15: unit -> unit . TIMES unit
- # unit -> unit TIMES unit .
- # unit -> unit . DIVIDE unit
- # unit -> unit . NUMBER
- {NUMBER => sh(10), # Shift-reduce conflict resolved in favor of shift
- _ => ['reduce', 3, 'unit', sub {unit_multiply($_[0], $_[2])}],
- },
- # State 16: unit -> unit . TIMES unit
- # unit -> unit DIVIDE unit .
- # unit -> unit . DIVIDE unit
- # unit -> unit . NUMBER
- {NUMBER => sh(10), # Shift-reduce conflict resolved in favor of shift
- _ => ['reduce', 3, 'unit', sub{unit_divide($_[2], $_[0])}],
- },
- # State 17: Finishing path
- {EOF => go(18),},
- # State 18: Final state
- {_ => ['accept']},
- );
-}
-
-sub ABORT {
- $PARSE_ERROR = shift;
-}
-
-sub parse_unit {
- my ($s) = @_;
- my $tokens = lex($s);
- my $STATE = 0;
- my (@state_st, @val_st);
-
- $PARSE_ERROR = undef;
-
- # Now let's run the parser
- for (;;) {
- return Zero if $PARSE_ERROR;
- my $la = @$tokens ? token_type($tokens->[0]) : 'EOF';
- print STDERR "Now in state $STATE. Lookahead type is $la.\n" if $DEBUG_p;
- print STDERR "State stack is (@state_st).\n" if $DEBUG_p;
- my $actiontab = $actions[$STATE];
- my $action = $actiontab->{$la} || $actiontab->{_};
- unless ($action) {
- $PARSE_ERROR = 'Syntax error';
- return Zero;
- }
-
- my ($primary, @actargs) = @$action;
- print STDERR " $primary (@actargs)\n" if $DEBUG_p;
- if ($primary eq 'accept') {
- return $val_st[0]; # Success!
- } elsif ($primary eq 'shift') {
- my $token = shift @$tokens;
- my $val = token_value($token);
- push @val_st, $val;
- push @state_st, $STATE;
- $STATE = $actargs[0];
- } elsif ($primary eq 'goto') {
- $STATE = $actargs[0];
- } elsif ($primary eq 'reduce') {
- my ($n_args, $result_type, $semantic) = @actargs;
- my @arglist;
-# push @state_st, 'FAKE'; # So that we only really remove n-1 states
- while ($n_args--) {
- push @arglist, pop @val_st;
- $STATE = pop @state_st;
- }
- my $result = $semantic ? &$semantic(@arglist) : $arglist[0];
- push @val_st, $result;
- push @state_st, $STATE;
-# $STATE = $state_st[-1];
- print STDERR "Post-reduction state is $STATE.\n" if $DEBUG_p;
-
- # Now look for `goto' actions
- my $goto = $actions[$STATE]{$result_type};
- unless ($goto && $goto->[0] eq 'goto') {
- &::ERROR("No post-reduction goto in state $STATE for $result_type.");
- return;
- }
- print STDERR "goto $goto->[1]\n" if $DEBUG_p;
- $STATE = $goto->[1];
- } else {
- &::ERROR("Bad primary $primary");
- return;
- }
- }
-}
-
-
-sub lex {
- my ($s) = @_;
- my @t = split /(
- \*{3} # Special `new unit' symbol
- | [()*-] # Symbol
- | \s*(?:\/|\bper\b)\s* # Division
- | \d*\.\d+(?:[eE]-?\d+)? # Decimal number
- | \d+\|\d+ # Fraction
- | \d+ # Integer
-# | (?:$PREF)-? # Prefix (handle differently)
- | [A-Za-z_][A-Za-z_.]* # identifier
- | \s+ # White space
- )/ox, $s;
- @t = grep {$_ ne ''} @t; # Discard empty and all-white tokens
- \@t;
-}
-
-sub token_type {
- my ($token) = @_;
- return $token->[0] if ref $token;
- return $token if $token =~ /[()]/;
- return TIMES if $token =~ /^\s+$/;
- return FUNDAMENTAL if $token eq '***';
- return DIVIDE if $token =~ /^\s*(\/|\bper\b)\s*$/;
- return TIMES if $token eq '*' || $token eq '-';
- return FRACTION if $token =~ /^\d+\|\d+$/;
- return NUMBER if $token =~ /^[.\d]/;
-# return PREFIX if $token =~ /^$PREF/o;
- return NAME;
-}
-
-sub token_value {
- my ($token) = @_;
- return $token if $token =~ /^([()*\/-]|\s*\bper\b\s*)$/;
- if ($token =~ /(\d+)\|(\d+)/) {
- if ($2 == 0) {
- ABORT("Zero denominator in fraction `$token'");
- return 0;
- }
- return $1/$2;
-# } elsif ($token =~ /$PREF/o) {
-# $token =~ s/-$//;
-# return 10**($PREF{$token});
- }
- return $token; # Perl takes care of the others.
-}
-
-1;
+++ /dev/null
-#
-# Uptime.pl: Uptime daemon.
-# Author: dms
-# Version: v0.3 (19991008)
-# Created: 19990925.
-#
-
-# use strict; # TODO
-
-my $uptimerecords = 3;
-
-sub uptimeNow {
- return time() - $^T;
-}
-
-sub uptimeStr {
- my $uptimenow = &uptimeNow();
-
- if (defined $_[0]) {
- return "$uptimenow.$$ running $bot_version, ended ". gmtime(time());
- } else {
- return "$uptimenow running $bot_version";
- }
-}
-
-sub uptimeGetInfo {
- my (%uptime,%done);
- my ($uptime,$pid);
- my @results;
- my $file = $file{utm};
-
- if (!open(IN, $file)) {
- &status("Writing uptime file for first time usage (nothing special).");
- open(OUT,">$file");
- close OUT;
- } else {
- while (<IN>) {
- chop;
-
- if (/^(\d+)\.(\d+) (.*)/) {
- $uptime{$1}{$2} = $3;
- }
- }
- close IN;
- }
-
- &uptimeStr(1) =~ /^(\d+)\.(\d+) (.*)/;
- $uptime{$1}{$2} = $3;
-
- # fixed up bad implementation :)
- # should be no problems, even if uptime or pid is duplicated.
- ## WARN: run away forks may get through here, have to fix.
- foreach $uptime (sort {$b <=> $a} keys %uptime) {
- foreach $pid (keys %{ $uptime{$uptime} }) {
- next if (exists $done{$pid});
-
- push(@results,"$uptime.$pid $uptime{$uptime}{$pid}");
- $done{$pid} = 1;
- last if (scalar @results == $uptimerecords);
- }
- last if (scalar @results == $uptimerecords);
- }
-
- return @results;
-}
-
-sub uptimeWriteFile {
- my @results = &uptimeGetInfo();
- my $file = $file{utm};
-
- if ($$ != $bot_pid) {
- &FIXME('uptime: forked process doing weird things!');
- exit 0;
- }
-
- if (!open(OUT,">$file")) {
- &status("error: cannot write to $file.");
- return;
- }
-
- foreach (@results) {
- print OUT "$_\n";
- }
-
- close OUT;
- &status('--- Saved uptime records.');
-
- return unless defined $conn;
-
- $conn->schedule(&getRandomInt('1800-3600'), \&uptimeWriteFile, '');
-}
-
-1;
+++ /dev/null
-#
-# UserDCC.pl: User Commands, DCC CHAT.
-# Author: dms
-# Version: v0.2 (20010119)
-# Created: 20000707 (from UserExtra.pl)
-#
-
-use strict;
-
-use vars qw(%users %ignore %sched %bans %mask %cache %channels %param
- %chanconf %dcc);
-use vars qw($who $chan $message $msgType $user $chnick $conn $ident
- $verifyUser $ucount_userfile $utime_userfile $lobotomized
- $utime_chanfile $ucount_chanfile);
-use vars qw(@backlog);
-
-sub userDCC {
- # hrm...
- $message =~ s/\s+$//;
-
- ### for all users.
- # quit.
- if ($message =~ /^(exit|quit)$/i) {
- # do ircII clients support remote close? if so, cool!
- &FIXME("userDCC: quit called.");
- &dcc_close($who);
- &status("userDCC: after dcc_close!");
-
- return;
- }
-
- # who.
- if ($message =~ /^who$/) {
- my $count = scalar(keys %{ $dcc{'CHAT'} });
- my $dccCHAT = $message;
-
- &performStrictReply("Start of who ($count users).");
- foreach (keys %{ $dcc{'CHAT'} }) {
- &performStrictReply("=> $_");
- }
- &performStrictReply("End of who.");
-
- return;
- }
-
- ### for those users with enough flags.
-
- if ($message =~ /^tellme(\s+(.*))?$/i) {
- my $args = $2;
- if ($args =~ /^\s*$/) {
- &help('tellme');
- return;
- }
-
- my $result = &doQuestion($args);
- &performStrictReply($result);
-
- return;
- }
-
- # 4op.
- if ($message =~ /^4op(\s+($mask{chan}))?$/i) {
- return unless (&hasFlag('o'));
-
- my $chan = $2;
-
- if ($chan eq '') {
- &help('4op');
- return;
- }
-
- if (!$channels{$chan}{'o'}{$ident}) {
- &msg($who, "i don't have ops on $chan to do that.");
- return;
- }
-
- # on non-4mode(<4) servers, this may be exploited.
- if ($channels{$chan}{'o'}{$who}) {
- rawout("MODE $chan -o+o-o+o". (" $who" x 4));
- } else {
- rawout("MODE $chan +o-o+o-o". (" $who" x 4));
- }
-
- return;
- }
-
- # opme.
- if ($message =~ /^opme(\s+($mask{chan}))?$/i) {
- return unless (&hasFlag('o'));
- return unless (&hasFlag('A'));
-
- my $chan = $2;
-
- if ($chan eq '') {
- &help('4op');
- return;
- }
-
- # can this be exploited?
- rawout("MODE $chan +o $who");
-
- return;
- }
-
- # backlog.
- if ($message =~ /^backlog(\s+(.*))?$/i) {
- return unless (&hasFlag('o'));
- return unless (&IsParam('backlog'));
- my $num = $2;
- my $max = $param{'backlog'};
-
- if (!defined $num) {
- &help('backlog');
- return;
- } elsif ($num !~ /^\d+/) {
- &msg($who, "error: argument is not positive integer.");
- return;
- } elsif ($num > $max or $num < 0) {
- &msg($who, "error: argument is out of range (max $max).");
- return;
- }
-
- &msg($who, "Start of backlog...");
- for (0..$num-1) {
- sleep 1 if ($_ % 4 == 0 and $_ != 0);
- $conn->privmsg($who, "[".($_+1)."]: $backlog[$max-$num+$_]");
- }
- &msg($who, "End of backlog.");
-
- return;
- }
-
- # dump variables.
- if ($message =~ /^dumpvars$/i) {
- return unless (&hasFlag('o'));
- return unless (&IsParam('DumpVars'));
-
- &status("Dumping all variables...");
- &dumpallvars();
-
- return;
- }
-
- # dump variables ][.
- if ($message =~ /^symdump$/i) {
- return unless (&hasFlag('o'));
- return unless (&IsParam('DumpVars2'));
-
- &status("Dumping all variables...");
- &symdumpAllFile();
-
- return;
- }
-
- # kick.
- if ($message =~ /^kick(\s+(.*?))$/) {
- return unless (&hasFlag('o'));
-
- my $arg = $2;
-
- if ($arg eq '') {
- &help('kick');
- return;
- }
- my @args = split(/\s+/, $arg);
- my ($nick,$chan,$reason) = @args;
-
- if (&validChan($chan) == 0) {
- &msg($who,"error: invalid channel \002$chan\002");
- return;
- }
-
- if (&IsNickInChan($nick,$chan) == 0) {
- &msg($who,"$nick is not in $chan.");
- return;
- }
-
- &kick($nick,$chan,$reason);
-
- return;
- }
-
- # mode.
- if ($message =~ /^mode(\s+(.*))?$/) {
- return unless (&hasFlag('n'));
- my ($chan,$mode) = split /\s+/,$2,2;
-
- if ($chan eq '') {
- &help('mode');
- return;
- }
-
- if (&validChan($chan) == 0) {
- &msg($who,"error: invalid channel \002$chan\002");
- return;
- }
-
- if (!$channels{$chan}{o}{$ident}) {
- &msg($who,"error: don't have ops on \002$chan\002");
- return;
- }
-
- &mode($chan, $mode);
-
- return;
- }
-
- # part.
- if ($message =~ /^part(\s+(\S+))?$/i) {
- return unless (&hasFlag('o'));
- my $jchan = $2;
-
- if ($jchan !~ /^$mask{chan}$/) {
- &msg($who, "error, invalid chan.");
- &help('part');
- return;
- }
-
- if (!&validChan($jchan)) {
- &msg($who, "error, I'm not on that chan.");
- return;
- }
-
- &msg($jchan, "Leaving. (courtesy of $who).");
- &part($jchan);
- return;
- }
-
- # lobotomy. sometimes we want the bot to be _QUIET_.
- if ($message =~ /^(lobotomy|bequiet)$/i) {
- return unless (&hasFlag('o'));
-
- if ($lobotomized) {
- &performReply("i'm already lobotomized");
- } else {
- &performReply('i have been lobotomized');
- $lobotomized = 1;
- }
-
- return;
- }
-
- # unlobotomy.
- if ($message =~ /^(unlobotomy|benoisy)$/i) {
- return unless (&hasFlag('o'));
-
- if ($lobotomized) {
- &performReply('i have been unlobotomized, woohoo');
- $lobotomized = 0;
- delete $cache{lobotomy};
-# undef $cache{lobotomy}; # ??
- } else {
- &performReply("i'm not lobotomized");
- }
-
- return;
- }
-
- # op.
- if ($message =~ /^op(\s+(.*))?$/i) {
- return unless (&hasFlag('o'));
- my ($opee) = lc $2;
- my @chans;
-
- if ($opee =~ / /) {
- if ($opee =~ /^(\S+)\s+(\S+)$/) {
- $opee = $1;
- @chans = ($2);
- if (!&validChan($2)) {
- &msg($who,"error: invalid chan ($2).");
- return;
- }
- } else {
- &msg($who,"error: invalid params.");
- return;
- }
- } else {
- @chans = keys %channels;
- }
-
- my $found = 0;
- my $op = 0;
- foreach (@chans) {
- next unless (&IsNickInChan($opee,$_));
- $found++;
- if ($channels{$_}{'o'}{$opee}) {
- &performStrictReply("op: $opee already has ops on $_");
- next;
- }
- $op++;
-
- &performStrictReply("opping $opee on $_");
- &op($_, $opee);
- }
-
- if ($found != $op) {
- &performStrictReply("op: opped on all possible channels.");
- } else {
- &DEBUG("op: found => '$found'.");
- &DEBUG("op: op => '$op'.");
- }
-
- return;
- }
-
- # deop.
- if ($message =~ /^deop(\s+(.*))?$/i) {
- return unless (&hasFlag('o'));
- my ($opee) = lc $2;
- my @chans;
-
- if ($opee =~ / /) {
- if ($opee =~ /^(\S+)\s+(\S+)$/) {
- $opee = $1;
- @chans = ($2);
- if (!&validChan($2)) {
- &msg($who,"error: invalid chan ($2).");
- return;
- }
- } else {
- &msg($who,"error: invalid params.");
- return;
- }
- } else {
- @chans = keys %channels;
- }
-
- my $found = 0;
- my $op = 0;
- foreach (@chans) {
- next unless (&IsNickInChan($opee,$_));
- $found++;
- if (!exists $channels{$_}{'o'}{$opee}) {
- &status("deop: $opee already has no ops on $_");
- next;
- }
- $op++;
-
- &status("deopping $opee on $_ at ${who}'s request");
- &deop($_, $opee);
- }
-
- if ($found != $op) {
- &status("deop: deopped on all possible channels.");
- } else {
- &DEBUG("deop: found => '$found'.");
- &DEBUG("deop: op => '$op'.");
- }
-
- return;
- }
-
- # say.
- if ($message =~ s/^say\s+(\S+)\s+(.*)//) {
- return unless (&hasFlag('o'));
- my ($chan,$msg) = (lc $1, $2);
-
- &DEBUG("chan => '$1', msg => '$msg'.");
-
- &msg($chan, $msg);
-
- return;
- }
-
- # do.
- if ($message =~ s/^do\s+(\S+)\s+(.*)//) {
- return unless (&hasFlag('o'));
- my ($chan,$msg) = (lc $1, $2);
-
- &DEBUG("chan => '$1', msg => '$msg'.");
-
- &action($chan, $msg);
-
- return;
- }
-
- # die.
- if ($message =~ /^die$/) {
- return unless (&hasFlag('n'));
-
- &doExit();
-
- &status("Dying by $who\'s request");
- exit 0;
- }
-
- # global factoid substitution.
- if ($message =~ m|^\* =~ s([/,#])(.+?)\1(.*?)\1;?\s*$|) {
- my ($delim,$op,$np) = ($1, $2, $3);
- return unless (&hasFlag('n'));
- ### TODO: support flags to do full-on global.
-
- # incorrect format.
- if ($np =~ /$delim/) {
- &performReply("looks like you used the delimiter too many times. You may want to use a different delimiter, like ':' or '#'.");
- return;
- }
-
- ### TODO: fix up $op to support mysql/sqlite/pgsql
- ### TODO: => add db/sql specific function to fix this.
- my @list = &searchTable('factoids', 'factoid_key',
- 'factoid_value', $op);
-
- if (!scalar @list) {
- &performReply("Expression didn't match anything.");
- return;
- }
-
- if (scalar @list > 100) {
- &performReply("regex found more than 100 matches... not doing.");
- return;
- }
-
- &status("gsubst: going to alter ".scalar(@list)." factoids.");
- &performReply('going to alter '.scalar(@list)." factoids.");
-
- my $error = 0;
- foreach (@list) {
- my $faqtoid = $_;
-
- next if (&IsLocked($faqtoid) == 1);
- my $result = &getFactoid($faqtoid);
- my $was = $result;
- &DEBUG("was($faqtoid) => '$was'.");
-
- # global global
- # we could support global local (once off).
- if ($result =~ s/\Q$op/$np/gi) {
- if (length $result > $param{'maxDataSize'}) {
- &performReply("that's too long (or was long)");
- return;
- }
- &setFactInfo($faqtoid, 'factoid_value', $result);
- &status("update: '$faqtoid' =is=> '$result'; was '$was'");
- } else {
- &WARN("subst: that's weird... thought we found the string ($op) in '$faqtoid'.");
- $error++;
- }
- }
-
- if ($error) {
- &ERROR("Some warnings/errors?");
- }
-
- &performReply("Ok... did s/$op/$np/ for ".
- (scalar(@list) - $error).' factoids');
-
- return;
- }
-
- # jump.
- if ($message =~ /^jump(\s+(\S+))?$/i) {
- return unless (&hasFlag('n'));
-
- if ($2 eq '') {
- &help('jump');
- return;
- }
-
- my ($server,$port);
- if ($2 =~ /^(\S+)(:(\d+))?$/) {
- $server = $1;
- $port = $3 || 6667;
- } else {
- &msg($who,"invalid format.");
- return;
- }
-
- &status("jumping servers... $server...");
- $conn->quit("jumping to $server");
-
- if (&irc($server,$port) == 0) {
- &ircloop();
- }
- }
-
- # reload.
- if ($message =~ /^reload$/i) {
- return unless (&hasFlag('n'));
-
- &status("USER reload $who");
- &performStrictReply("reloading...");
- &reloadAllModules();
- &performStrictReply("reloaded.");
-
- return;
- }
-
- # reset.
- if ($message =~ /^reset$/i) {
- return unless (&hasFlag('n'));
-
- &msg($who,"resetting...");
- my @done;
- foreach ( keys %channels, keys %chanconf ) {
- my $c = $_;
- next if (grep /^\Q$c\E$/i, @done);
-
- &part($_);
-
- push(@done, $_);
- sleep 1;
- }
- &DEBUG('before clearircvars');
- &clearIRCVars();
- &DEBUG('before joinnextchan');
- &joinNextChan();
- &DEBUG('after joinnextchan');
-
- &status("USER reset $who");
- &msg($who,'reset complete');
-
- return;
- }
-
- # rehash.
- if ($message =~ /^rehash$/) {
- return unless (&hasFlag('n'));
-
- &msg($who,"rehashing...");
- &restart('REHASH');
- &status("USER rehash $who");
- &msg($who,'rehashed');
-
- return;
- }
-
- #####
- ##### USER//CHAN SPECIFIC CONFIGURATION COMMANDS
- #####
-
- if ($message =~ /^chaninfo(\s+(.*))?$/) {
- my @args = split /[\s\t]+/, $2; # hrm.
-
- if (scalar @args != 1) {
- &help('chaninfo');
- return;
- }
-
- if (!exists $chanconf{$args[0]}) {
- &performStrictReply("no such channel $args[0]");
- return;
- }
-
- &performStrictReply("showing channel conf.");
- foreach (sort keys %{ $chanconf{$args[0]} }) {
- &performStrictReply("$chan: $_ => $chanconf{$args[0]}{$_}");
- }
- &performStrictReply("End of chaninfo.");
-
- return;
- }
-
- # +chan.
- if ($message =~ /^(chanset|\+chan)(\s+(.*?))?$/) {
- my $cmd = $1;
- my $args = $3;
- my $no_chan = 0;
-
- if (!defined $args) {
- &help($cmd);
- return;
- }
-
- my @chans;
- while ($args =~ s/^($mask{chan})\s*//) {
- push(@chans, lc($1));
- }
-
- if (!scalar @chans) {
- push(@chans, '_default');
- $no_chan = 1;
- }
-
- my($what,$val) = split /[\s\t]+/, $args, 2;
-
- ### TODO: "cannot set values without +m".
- return unless (&hasFlag('n'));
-
- # READ ONLY.
- if (defined $what and $what !~ /^[-+]/ and !defined $val and $no_chan) {
- &performStrictReply("Showing $what values on all channels...");
-
- my %vals;
- foreach (keys %chanconf) {
- my $val;
- if (defined $chanconf{$_}{$what}) {
- $val = $chanconf{$_}{$what};
- } else {
- $val = "NOT-SET";
- }
- $vals{$val}{$_} = 1;
- }
-
- foreach (keys %vals) {
- &performStrictReply(" $what = $_(" . scalar(keys %{$vals{$_}}) . "): ".join(' ', sort keys %{ $vals{$_} } ) );
- }
-
- &performStrictReply("End of list.");
-
- return;
- }
-
- ### TODO: move to UserDCC again.
- if ($cmd eq 'chanset' and !defined $what) {
- &DEBUG("showing channel conf.");
-
- foreach $chan (@chans) {
- if ($chan eq '_default') {
- &performStrictReply('Default channel settings');
- } else {
- &performStrictReply("chan: $chan (see _default also)");
- }
- my @items;
- my $str = '';
- foreach (sort keys %{ $chanconf{$chan} }) {
- my $newstr = join(', ', @items);
- ### TODO: make length use channel line limit?
- if (length $newstr > 370) {
- &performStrictReply(" $str");
- @items = ();
- }
- $str = $newstr;
- push(@items, "$_ => $chanconf{$chan}{$_}");
- }
- if (@items) {
- my $str = join(', ', @items);
- &performStrictReply(" $str");
- }
- }
- return;
- }
-
- $cache{confvars}{$what} = $val;
- &rehashConfVars();
-
- foreach (@chans) {
- &chanSet($cmd, $_, $what, $val);
- }
-
- return;
- }
-
- if ($message =~ /^(chanunset|\-chan)(\s+(.*))?$/) {
- return unless (&hasFlag('n'));
- my $args = $3;
- my $no_chan = 0;
-
- if (!defined $args) {
- &help('chanunset');
- return;
- }
-
- my ($chan);
- my $delete = 0;
- if ($args =~ s/^(\-)?($mask{chan})\s*//) {
- $chan = $2;
- $delete = ($1) ? 1 : 0;
- } else {
- &VERB("no chan arg; setting to default.",2);
- $chan = '_default';
- $no_chan = 1;
- }
-
- if (!exists $chanconf{$chan}) {
- &performStrictReply("no such channel $chan");
- return;
- }
-
- if ($args ne '') {
-
- if (!&getChanConf($args,$chan)) {
- &performStrictReply("$args does not exist for $chan");
- return;
- }
-
- my @chans = &ChanConfList($args);
- &DEBUG("scalar chans => ".scalar(@chans) );
- if (scalar @chans == 1 and $chans[0] eq '_default' and !$no_chan) {
- &performStrictReply("ok, $args was set only for _default; unsetting for _defaul but setting for other chans.");
-
- my $val = $chanconf{$_}{_default};
- foreach (keys %chanconf) {
- $chanconf{$_}{$args} = $val;
- }
- delete $chanconf{_default}{$args};
- $cache{confvars}{$args} = 0;
- &rehashConfVars();
-
- return;
- }
-
- if ($no_chan and !exists($chanconf{_default}{$args})) {
- &performStrictReply("ok, $args for _default does not exist, removing from all chans.");
-
- foreach (keys %chanconf) {
- next unless (exists $chanconf{$_}{$args});
- &DEBUG("delete chanconf{$_}{$args};");
- delete $chanconf{$_}{$args};
- }
- $cache{confvars}{$args} = 0;
- &rehashConfVars();
-
- return;
- }
-
- &performStrictReply("Unsetting channel ($chan) option $args. (was $chanconf{$chan}{$args})");
- delete $chanconf{$chan}{$args};
-
- return;
- }
-
- if ($delete) {
- &performStrictReply("Deleting channel $chan for sure!");
- $utime_chanfile = time();
- $ucount_chanfile++;
-
- &part($chan);
- &performStrictReply("Leaving $chan...");
-
- delete $chanconf{$chan};
- } else {
- &performStrictReply("Prefix channel with '-' to delete for sure.");
- }
-
- return;
- }
-
- if ($message =~ /^newpass(\s+(.*))?$/) {
- my(@args) = split /[\s\t]+/, $2 || '';
-
- if (scalar @args != 1) {
- &help('newpass');
- return;
- }
-
- my $u = &getUser($who);
- my $crypt = &mkcrypt($args[0]);
-
- &performStrictReply("Set your passwd to '$crypt'");
- $users{$u}{PASS} = $crypt;
-
- $utime_userfile = time();
- $ucount_userfile++;
-
- return;
- }
-
- if ($message =~ /^chpass(\s+(.*))?$/) {
- my(@args) = split /[\s\t]+/, $2 || '';
-
- if (!scalar @args) {
- &help('chpass');
- return;
- }
-
- if (!&IsUser($args[0])) {
- &performStrictReply("user $args[0] is not valid.");
- return;
- }
-
- my $u = &getUser($args[0]);
- if (!defined $u) {
- &performStrictReply("Internal error, u = NULL.");
- return;
- }
-
- if (scalar @args == 1) {
- # del pass.
- if (!&IsFlag('n') and $who !~ /^\Q$verifyUser\E$/i) {
- &performStrictReply("cannot remove passwd of others.");
- return;
- }
-
- if (!exists $users{$u}{PASS}) {
- &performStrictReply("$u does not have pass set anyway.");
- return;
- }
-
- &performStrictReply("Deleted pass from $u.");
-
- $utime_userfile = time();
- $ucount_userfile++;
-
- delete $users{$u}{PASS};
-
- return;
- }
-
- my $crypt = &mkcrypt($args[1]);
- &performStrictReply("Set $u's passwd to '$crypt'");
- $users{$u}{PASS} = $crypt;
-
- $utime_userfile = time();
- $ucount_userfile++;
-
- return;
- }
-
- if ($message =~ /^chattr(\s+(.*))?$/) {
- my(@args) = split /[\s\t]+/, $2 || '';
-
- if (!scalar @args) {
- &help('chattr');
- return;
- }
-
- my $chflag;
- my $user;
- if ($args[0] =~ /^$mask{nick}$/i) {
- # <nick>
- $user = &getUser($args[0]);
- $chflag = $args[1];
- } else {
- # <flags>
- $user = &getUser($who);
- &DEBUG("user $who... nope.") unless (defined $user);
- $user = &getUser($verifyUser);
- $chflag = $args[0];
- }
-
- if (!defined $user) {
- &performStrictReply("user does not exist.");
- return;
- }
-
- my $flags = $users{$user}{FLAGS};
- if (!defined $chflag) {
- &performStrictReply("Flags for $user: $flags");
- return;
- }
-
- &DEBUG("who => $who");
- &DEBUG("verifyUser => $verifyUser");
- if (!&IsFlag('n') and $who !~ /^\Q$verifyUser\E$/i) {
- &performStrictReply("cannto change attributes of others.");
- return 'REPLY';
- }
-
- my $state;
- my $change = 0;
- foreach (split //, $chflag) {
- if ($_ eq "+") { $state = 1; next; }
- if ($_ eq "-") { $state = 0; next; }
-
- if (!defined $state) {
- &performStrictReply("no initial + or - was found in attr.");
- return;
- }
-
- if ($state) {
- next if ($flags =~ /\Q$_\E/);
- $flags .= $_;
- } else {
- if (&IsParam('owner')
- and $param{owner} =~ /^\Q$user\E$/i
- and $flags =~ /[nmo]/
- ) {
- &performStrictReply("not removing flag $_ for $user.");
- next;
- }
- next unless ($flags =~ s/\Q$_\E//);
- }
-
- $change++;
- }
-
- if ($change) {
- $utime_userfile = time();
- $ucount_userfile++;
- #$flags.*FLAGS sort
- $flags = join('', sort split('', $flags));
- &performStrictReply("Current flags: $flags");
- $users{$user}{FLAGS} = $flags;
- } else {
- &performStrictReply("No flags changed: $flags");
- }
-
- return;
- }
-
- if ($message =~ /^chnick(\s+(.*))?$/) {
- my(@args) = split /[\s\t]+/, $2 || '';
-
- if ($who eq '_default') {
- &WARN("$who or verifyuser tried to run chnick.");
- return 'REPLY';
- }
-
- if (!scalar @args or scalar @args > 2) {
- &help('chnick');
- return;
- }
-
- if (scalar @args == 1) { # 1
- $user = &getUser($who);
- &DEBUG("nope, not $who.") unless (defined $user);
- $user ||= &getUser($verifyUser);
- $chnick = $args[0];
- } else { # 2
- $user = &getUser($args[0]);
- $chnick = $args[1];
- }
-
- if (!defined $user) {
- &performStrictReply("user $who or $args[0] does not exist.");
- return;
- }
-
- if ($user =~ /^\Q$chnick\E$/i) {
- &performStrictReply("user == chnick. why should I do that?");
- return;
- }
-
- if (&getUser($chnick)) {
- &performStrictReply("user $chnick is already used!");
- return;
- }
-
- if (!&IsFlag('n') and $who !~ /^\Q$verifyUser\E$/i) {
- &performStrictReply("cannto change nick of others.");
- return 'REPLY' if ($who eq '_default');
- return;
- }
-
- foreach (keys %{ $users{$user} }) {
- $users{$chnick}{$_} = $users{$user}{$_};
- delete $users{$user}{$_};
- }
- undef $users{$user}; # ???
-
- $utime_userfile = time();
- $ucount_userfile++;
-
- &performStrictReply("Changed '$user' to '$chnick' successfully.");
-
- return;
- }
-
- if ($message =~ /^([-+])host(\s+(.*))?$/) {
- my $cmd = $1.'host';
- my(@args) = split /[\s\t]+/, $3 || '';
- my $state = ($1 eq "+") ? 1 : 0;
-
- if (!scalar @args) {
- &help($cmd);
- return;
- }
-
- if ($who eq '_default') {
- &WARN("$who or verifyuser tried to run $cmd.");
- return 'REPLY';
- }
-
- my ($user,$mask);
- if ($args[0] =~ /^$mask{nick}$/i) { # <nick>
- return unless (&hasFlag('n'));
- $user = &getUser($args[0]);
- $mask = $args[1];
- } else { # <mask>
- # FIXME: who or verifyUser. (don't remember why)
- $user = &getUser($who);
- $mask = $args[0];
- }
-
- if (!defined $user) {
- &performStrictReply("user $user does not exist.");
- return;
- }
-
- if (!defined $mask) {
- &performStrictReply("Hostmasks for $user: " . join(' ', keys %{$users{$user}{HOSTS}}));
- return;
- }
-
- if (!&IsFlag('n') and $who !~ /^\Q$verifyUser\E$/i) {
- &performStrictReply("cannto change masks of others.");
- return;
- }
-
- my $count = scalar keys %{ $users{$user}{HOSTS} };
-
- if ($state) { # add.
- if ($mask !~ /^$mask{nuh}$/) {
- &performStrictReply("error: mask ($mask) is not a real hostmask.");
- return;
- }
-
- if (exists $users{$user}{HOSTS}{$mask}) {
- &performStrictReply("mask $mask already exists.");
- return;
- }
-
- ### TODO: override support.
- $users{$user}{HOSTS}{$mask} = 1;
-
- &performStrictReply("Added $mask to list of masks.");
-
- } else { # delete.
-
- if (!exists $users{$user}{HOSTS}{$mask}) {
- &performStrictReply("mask $mask does not exist.");
- return;
- }
-
- ### TODO: wildcard support. ?
- delete $users{$user}{HOSTS}{$mask};
-
- if (scalar keys %{ $users{$user}{HOSTS} } != $count) {
- &performStrictReply("Removed $mask from list of masks.");
- } else {
- &performStrictReply("error: could not find $mask in list of masks.");
- return;
- }
- }
-
- $utime_userfile = time();
- $ucount_userfile++;
-
- return;
- }
-
- if ($message =~ /^([-+])ban(\s+(.*))?$/) {
- my $cmd = $1.'ban';
- my $flatarg = $3;
- my(@args) = split /[\s\t]+/, $3 || '';
- my $state = ($1 eq "+") ? 1 : 0;
-
- if (!scalar @args) {
- &help($cmd);
- return;
- }
-
- my($mask,$chan,$time,$reason);
-
- if ($flatarg =~ s/^($mask{nuh})\s*//) {
- $mask = $1;
- } else {
- &DEBUG("arg does not contain nuh mask?");
- }
-
- if ($flatarg =~ s/^($mask{chan})\s*//) {
- $chan = $1;
- } else {
- $chan = '*'; # _default instead?
- }
-
- if ($state == 0) { # delete.
- my @c = &banDel($mask);
-
- foreach (@c) {
- &unban($mask, $_);
- }
-
- if (@c) {
- &performStrictReply("Removed $mask from chans: @c");
- } else {
- &performStrictReply("$mask was not found in ban list.");
- }
-
- return;
- }
-
- ###
- # add ban.
- ###
-
- # time.
- if ($flatarg =~ s/^(\d+)\s*//) {
- $time = $1;
- &DEBUG("time = $time.");
- if ($time < 0) {
- &performStrictReply("error: time cannot be negatime?");
- return;
- }
- } else {
- $time = 0;
- }
-
- if ($flatarg =~ s/^(.*)$//) { # need length?
- $reason = $1;
- }
-
- if (!&IsFlag('n') and $who !~ /^\Q$verifyUser\E$/i) {
- &performStrictReply("cannto change masks of others.");
- return;
- }
-
- if ($mask !~ /^$mask{nuh}$/) {
- &performStrictReply("error: mask ($mask) is not a real hostmask.");
- return;
- }
-
- if ( &banAdd($mask,$chan,$time,$reason) == 2) {
- &performStrictReply("ban already exists; overwriting.");
- }
- &performStrictReply("Added $mask for $chan (time => $time, reason => $reason)");
-
- return;
- }
-
- if ($message =~ /^whois(\s+(.*))?$/) {
- my $arg = $2;
-
- if (!defined $arg) {
- &help('whois');
- return;
- }
-
- my $user = &getUser($arg);
- if (!defined $user) {
- &performStrictReply("whois: user $user does not exist.");
- return;
- }
-
- ### TODO: better (eggdrop-like) output.
- &performStrictReply("user: $user");
- foreach (keys %{ $users{$user} }) {
- my $ref = ref $users{$user}{$_};
-
- if ($ref eq 'HASH') {
- my $type = $_;
- ### DOES NOT WORK???
- foreach (keys %{ $users{$user}{$type} }) {
- &performStrictReply(" $type => $_");
- }
- next;
- }
-
- &performStrictReply(" $_ => $users{$user}{$_}");
- }
- &performStrictReply("End of USER whois.");
-
- return;
- }
-
- if ($message =~ /^bans(\s+(.*))?$/) {
- my $arg = $2;
-
- if (defined $arg) {
- if ($arg ne '_default' and !&validChan($arg) ) {
- &performStrictReply("error: chan $chan is invalid.");
- return;
- }
- }
-
- if (!scalar keys %bans) {
- &performStrictReply("Ban list is empty.");
- return;
- }
-
- my $c;
- &performStrictReply(" mask: expire, time-added, count, who-by, reason");
- foreach $c (keys %bans) {
- next unless (!defined $arg or $arg =~ /^\Q$c\E$/i);
- &performStrictReply(" $c:");
-
- foreach (keys %{ $bans{$c} }) {
- my $val = $bans{$c}{$_};
-
- if (ref $val eq 'ARRAY') {
- my @array = @{ $val };
- &performStrictReply(" $_: @array");
- } else {
- &DEBUG("unknown ban: $val");
- }
- }
- }
- &performStrictReply("END of bans.");
-
- return;
- }
-
- if ($message =~ /^banlist(\s+(.*))?$/) {
- my $arg = $2;
-
- if (defined $arg and $arg !~ /^$mask{chan}$/) {
- &performStrictReply("error: chan $chan is invalid.");
- return;
- }
-
- &DEBUG("bans for global or arg => $arg.");
- foreach (keys %bans) { #CHANGE!!!
- &DEBUG(" $_ => $bans{$_}.");
- }
-
- &DEBUG("End of bans.");
- &performStrictReply("END of bans.");
-
- return;
- }
-
- if ($message =~ /^save$/) {
- return unless (&hasFlag('o'));
-
- &writeUserFile();
- &writeChanFile();
- &performStrictReply('saved user and chan files');
-
- return;
- }
-
- ### ALIASES.
- $message =~ s/^addignore/+ignore/;
- $message =~ s/^(del|un)ignore/-ignore/;
-
- # ignore.
- if ($message =~ /^(\+|\-)ignore(\s+(.*))?$/i) {
- return unless (&hasFlag('o'));
- my $state = ($1 eq "+") ? 1 : 0;
- my $str = $1.'ignore';
- my $args = $3;
-
- if (!$args) {
- &help($str);
- return;
- }
-
- my($mask,$chan,$time,$comment);
-
- # mask.
- if ($args =~ s/^($mask{nuh})\s*//) {
- $mask = $1;
- } else {
- &ERROR("no NUH mask?");
- return;
- }
-
- if (!$state) { # delignore.
- if ( &ignoreDel($mask) ) {
- &performStrictReply("ok, deleted ignores for $mask.");
- } else {
- &performStrictReply("could not find $mask in ignore list.");
- }
- return;
- }
-
- ###
- # addignore.
- ###
-
- # chan.
- if ($args =~ s/^($mask{chan}|\*)\s*//) {
- $chan = $1;
- } else {
- $chan = '*';
- }
-
- # time.
- if ($args =~ s/^(\d+)\s*//) {
- $time = $1; # time is in minutes
- } else {
- $time = 0;
- }
-
- # time.
- if ($args) {
- $comment = $args;
- } else {
- $comment = "added by $who";
- }
-
- if ( &ignoreAdd($mask, $chan, $time, $comment) > 1) {
- &performStrictReply("FIXME: $mask already in ignore list; written over anyway.");
- } else {
- &performStrictReply("added $mask to ignore list.");
- }
-
- return;
- }
-
- if ($message =~ /^ignore(\s+(.*))?$/) {
- my $arg = $2;
-
- if (defined $arg) {
- if ($arg !~ /^$mask{chan}$/) {
- &performStrictReply("error: chan $chan is invalid.");
- return;
- }
-
- if (!&validChan($arg)) {
- &performStrictReply("error: chan $arg is invalid.");
- return;
- }
-
- &performStrictReply("Showing bans for $arg only.");
- }
-
- if (!scalar keys %ignore) {
- &performStrictReply("Ignore list is empty.");
- return;
- }
-
- ### TODO: proper (eggdrop-like) formatting.
- my $c;
- &performStrictReply(" mask: expire, time-added, who, comment");
- foreach $c (keys %ignore) {
- next unless (!defined $arg or $arg =~ /^\Q$c\E$/i);
- &performStrictReply(" $c:");
-
- foreach (keys %{ $ignore{$c} }) {
- my $ref = ref $ignore{$c}{$_};
- if ($ref eq 'ARRAY') {
- my @array = @{ $ignore{$c}{$_} };
- &performStrictReply(" $_: @array");
- } else {
- &DEBUG("unknown ignore line?");
- }
- }
- }
- &performStrictReply("END of ignore.");
-
- return;
- }
-
- # adduser/deluser.
- if ($message =~ /^(add|del)user(\s+(.*))?$/i) {
- my $str = $1;
- my $strstr = $1.'user';
- my @args = split /\s+/, $3 || '';
- my $args = $3;
- my $state = ($str =~ /^(add)$/) ? 1 : 0;
-
- if (!scalar @args) {
- &help($strstr);
- return;
- }
-
- if ($str eq 'add') {
- if (scalar @args != 2) {
- &performStrictReply('adduser requires hostmask argument.');
- return;
- }
- } elsif (scalar @args != 1) {
- &performStrictReply('too many arguments.');
- return;
- }
-
- if ($state) {
- # adduser.
- if (scalar @args == 1) {
- $args[1] = &getHostMask($args[0]);
- &performStrictReply("Attemping to guess $args[0]'s hostmask...");
-
- # crude hack... crappy Net::IRC
- $conn->schedule(5, sub {
- # hopefully this is right.
- my $nick = (keys %{ $cache{nuhInfo} })[0];
- if (!defined $nick) {
- &performStrictReply("couldn't get nuhinfo... adding user without a hostmask.");
- &userAdd($nick);
- return;
- }
- my $mask = &makeHostMask( $cache{nuhInfo}{$nick}{NUH} );
-
- if ( &userAdd($nick, $mask) ) {
- # success.
- &performStrictReply("Added $nick with flags $users{$nick}{FLAGS}");
- my @hosts = keys %{ $users{$nick}{HOSTS} };
- &performStrictReply("hosts: @hosts");
- }
- });
- return;
- }
-
- &DEBUG("args => @args");
- if ( &userAdd(@args) ) { # success.
- &performStrictReply("Added $args[0] with flags $users{$args[0]}{FLAGS}");
- my @hosts = keys %{ $users{$args[0]}{HOSTS} };
- &performStrictReply("hosts: @hosts");
-
- } else { # failure.
- &performStrictReply("User $args[0] already exists");
- }
-
- } else { # deluser.
-
- if ( &userDel($args[0]) ) { # success.
- &performStrictReply("Deleted $args[0] successfully.");
-
- } else { # failure.
- &performStrictReply("User $args[0] does not exist.");
- }
-
- }
- return;
- }
-
- if ($message =~ /^sched$/) {
- my @list;
- my @run;
-
- my %time;
- foreach (keys %sched) {
- next unless (exists $sched{$_}{TIME});
- $time{ $sched{$_}{TIME}-time() }{$_} = 1;
- push(@list,$_);
-
- next unless (exists $sched{$_}{RUNNING});
- push(@run,$_);
- }
-
- my @time;
- foreach (sort { $a <=> $b } keys %time) {
- my $str = join(', ', sort keys %{ $time{$_} });
- &DEBUG("time => $_, str => $str");
- push(@time, "$str (".&Time2String($_).")");
- }
-
- &performStrictReply( &formListReply(0, "Schedulers: ", @time ) );
- &performStrictReply( &formListReply(0, "Scheds to run: ", sort @list ) );
- &performStrictReply( &formListReply(0, "Scheds running(should not happen?) ", sort @run ) );
-
- return;
- }
-
- # quite a cool hack: reply in DCC CHAT.
- $msgType = 'chat' if (exists $dcc{'CHAT'}{$who});
-
- my $done = 0;
- $done++ if &parseCmdHook($message);
- $done++ unless (&Modules());
-
- if ($done) {
- &DEBUG("running non DCC CHAT command inside DCC CHAT!");
- return;
- }
-
- return 'REPLY';
-}
-
-1;
+++ /dev/null
-#
-# UserInfo.pl: User Information Services
-# Author: dms
-# Version: v0.1 (20000509).
-# Created: 20000509
-# NOTE: Idea from Flugh. Originally written in tcl for eggdrop by
-# unknown.
-#
-
-use strict;
-
-my $orderOfInfo = 'RN,J,C,W,D';
-my %infoDesc = (
- 'RN' => 'Real Name',
- 'J' => 'Occupation',
- 'C' => 'Contact',
- 'W' => 'URL',
- 'D' => 'Description',
-);
-
-sub UserInfo2Hash {
- my ($text) = @_;
- my %hash;
-
- foreach (split /\|/, $text) {
- if (/^\s*(\S+):\s*(.*)\s*$/) {
- $hash{$1} = $2;
- }
- }
-
- return %hash;
-}
-
-sub Hash2UserInfo {
- my (%hash) = @_;
- my @array;
-
- foreach (sort keys %hash) {
- push(@array, "$_: $hash{$_}");
- }
-
- join('|', @array);
-}
-
-###
-###
-###
-
-sub UserInfoGet {
- my ($query) = @_;
- $query =~ s/^\s+|\s+$//g if (defined $query);
-
- if (!defined $query or $query =~ /^$/) {
- &help('userinfo');
- return;
- }
-
- if ($query !~ /^$mask{nick}$/) {
- &msg($who, "Invalid query of '$query'.");
- return;
- }
-
- my $result;
- if ($result = &getFactoid($query.' info')) {
- # good.
- } else { # bad.
- &performReply("No User Information on \002$query\002");
- return;
- }
-
- if ($result !~ /\|/) {
- &msg($who, "Invalid User Information for '$query'.");
- return;
- }
-
- my %userInfo = &UserInfo2Hash($result);
-
- my @reply;
- foreach (split ',', $orderOfInfo) {
- next unless (exists $userInfo{$_});
- push(@reply, "$infoDesc{$_}: $userInfo{$_}");
- }
-
- &performStrictReply("User Information on $userInfo{'N'} -- ".
- join(', ', @reply));
-}
-
-sub UserInfoSet {
- my($type, $what) = @_;
- my %userInfo;
- my $info;
-
- if (&IsLocked("$who info")) {
- &DEBUG("UIS: IsLocked('$who info') == 1.");
- return;
- }
-
- my $new = 0;
- if (my $result = &getFactoid("$who info")) {
- %userInfo = &UserInfo2Hash($result);
- } else {
- &DEBUG("UIS: new = 1!");
- $userInfo{'N'} = $who;
- $new = 1;
- }
-
- ### TODO: hash for %infoS2L.
- if ($type =~ /^(RN|real\s*name)$/i) {
- $info = 'RN';
- } elsif ($type =~ /^(J|job|occupation|school|life)$/i) {
- $info = 'J';
- } elsif ($type =~ /^(C|contact|email|phone)$/i) {
- $info = 'C';
- } elsif ($type =~ /^(W|www|url|web\s*page|home\s*page)$/i) {
- $info = 'W';
- } elsif ($type =~ /^(D|desc\S+)$/i) {
- $info = 'D';
- } elsif ($type =~ /^(O|opt\S+)$/i) {
- $info = 'O';
- } else {
- &msg($who, "Unknown type '$type'.");
- return;
- }
-
- if (!defined $what) { # !defined.
- if (exists $userInfo{$info}) {
- &msg($who, "Current \002$infoDesc{$info}\002 is: '$userInfo{$info}'.");
- } else {
- &msg($who, "No current \002$infoDesc{$info}\002.");
- }
-
- my @remain;
- foreach (split ',', $orderOfInfo) {
- next if (exists $userInfo{$_});
- push(@remain, $infoDesc{$_});
- }
- if (scalar @remain) {
- ### TODO: show short-cut (identifier) aswell.
- &msg($who, "Remaining slots to fill: ".join(' ', @remain));
- } else {
-### &msg($who, "Personal Information completely filled. Good.");
- }
-
- return;
- } elsif ($what =~ /^$/) { # defined but NULL. UNSET
- if (exists $userInfo{$info}) {
- &msg($who, "Unsetting \002$infoDesc{$info}\002 ($userInfo{$info}).");
- delete $userInfo{$info};
- } else {
- &msg($who, "\002$infoDesc{$info}\002 is already empty!");
- return;
- }
- } else { # defined.
- if (exists $userInfo{$info}) {
- &msg($who, "\002$infoDesc{$info}\002 was '$userInfo{$info}'.");
- &msg($who, "Now is: '$what'.");
- } else {
- &msg($who, "\002$infoDesc{$info}\002 is now '$what'.");
- }
- $userInfo{$info} = $what;
- }
-
- &setFactInfo($who.' info', 'factoid_value', &Hash2UserInfo(%userInfo));
- if ($new) {
- &DEBUG("UIS: locking '$who info'.");
- &DEBUG("UIS: nuh => '$nuh'.");
- &setFactInfo("$who info", "locked_by", $nuh);
- &setFactInfo("$who info", "locked_time", time());
- }
-}
-
-1;
+++ /dev/null
-# WWWSearch backend, with queries updating the is-db (optionally)
-# Uses WWW::Search::Google and WWW::Search
-# originally Google.pl, drastically altered.
-
-package W3Search;
-
-use strict;
-use vars qw(@W3Search_engines $W3Search_regex);
-@W3Search_engines = qw(AltaVista Dejanews Excite Gopher HotBot Infoseek
- Lycos Magellan PLweb SFgate Simple Verity Google z);
-$W3Search_regex = join '|', @W3Search_engines;
-
-my $maxshow = 5;
-
-sub W3Search {
- my ($where, $what, $type) = @_;
- my $retval = "$where can't find \002$what\002";
- my $Search;
-
- my @matches = grep { lc($_) eq lc($where) ? $_ : undef } @W3Search_engines;
- if (@matches) {
- $where = shift @matches;
- } else {
- &::msg($::who, "i don't know how to check '$where'");
- return;
- }
-
- return unless &::loadPerlModule("WWW::Search");
-
- eval {
- $Search = new WWW::Search($where, agent_name => 'Mozilla/4.5');
- };
-
- if (!defined $Search) {
- &::msg($::who, "$where is invalid search.");
- return;
- }
-
- my $Query = WWW::Search::escape_query($what);
- $Search->native_query($Query,
- {
- num => 10,
-# search_debug => 2,
-# search_parse_debug => 2,
- }
- );
- $Search->http_proxy($::param{'httpProxy'}) if (&::IsParam('httpProxy'));
- #my $max = $Search->maximum_to_retrieve(10); # DOES NOT WORK.
-
- my (@results, $count, $r);
- $retval = "$where says \002$what\002 is at ";
- while ($r = $Search->next_result()) {
- my $url = $r->url();
- $retval .= ' or ' if ($count > 0);
- $retval .= $url;
- last if ++$count >= $maxshow;
- }
-
- &::performStrictReply($retval);
-}
-
-1;
+++ /dev/null
-#!/usr/bin/perl
-
-package Weather;
-
-# kevin lenzo (C) 1999 -- get the weather forcast NOAA.
-# feel free to use, copy, cut up, and modify, but if
-# you do something cool with it, let me know.
-
-# 16-SEP-99 lenzo@cs.cmu.edu switched to LWP::UA and
-# put in a timeout.
-
-my $no_weather;
-my $cache_time = 60 * 40 ; # 40 minute cache time
-my $default = 'KAGC';
-
-BEGIN {
- $no_weather = 0;
- eval "use LWP::UserAgent";
- $no_weather++ if ($@);
-}
-
-sub Weather {
- my ($args) = @_;
- &::performStrictReply(&queryText($args, 'weather'));
- return;
-}
-
-sub Metar {
- my ($args) = @_;
- &::performStrictReply(&queryText($args, 'metar'));
- return;
-}
-
-sub queryText {
- my ($station) = shift;
- my ($wxmode) = shift;
- my $result;
-
- $station = uc($station);
- $station =~ s/for //i;
-
- if ($no_weather) {
- return 0;
- } else {
-
- if (exists $cache{$station}) {
- my ($time, $response) = split $; , $cache{$station};
- if ((time() - $time) < $cache_time) {
- return $response;
- }
- }
-
- my $ua = new LWP::UserAgent;
- $ua->proxy('http', $::param{'httpProxy'}) if (&::IsParam('httpProxy'));
-
- $ua->timeout(10);
- my $request = new HTTP::Request('GET', "http://weather.noaa.gov/weather/current/$station.html");
- my $response = $ua->request($request);
-
- if (!$response->is_success) {
- if ($response->code == 404) {
- return "I can't find station code \"$station\""
- . " (see http://www.nws.noaa.gov/oso/site.shtml"
- . " or http://www.nws.noaa.gov/tg/siteloc.shtml"
- . " for ICAO locations codes).";
- } else {
- return 'Something failed in connecting to the NOAA web'
- . " server. Try again later.";
- }
- }
-
- $content = $response->content;
- $content =~ s|.*?<BODY[^>]*>||is;
- #$content =~ s|.*?current weather conditions.*?<BR>([^<]*?)\s*<.*?</TR>||is;
- $content =~ s|.*?current weather conditions[^<]*(<[^>]+>\s*)+||is;
- $content =~ s|([^<]*?)\s*<.*?</TR>||is;
- my $place = $1;
- chomp $place;
-
- $content =~ s|.*?<TR>(?:\s*<[^>]+>)*\s*([^<]+)\s<.*?</TR>||is;
- my $id = $1;
- chomp $id;
-
- $content =~ s|.*?conditions at.*?</TD>||is;
-
- #$content =~ s|.*?<OPTION SELECTED>\s+([^<]+)\s<OPTION>.*?</TR>||s; # local time
- $content =~ s|.*?<BR>\s+([^<]+?)\s*</FORM>.*?</TR>||s; # UTC
- my $time = $1;
- $time =~ s/-//g;
- $time =~ s/\s+/ /g;
-
- $content =~ s|\s(.*?)<TD COLSPAN=2>||s;
- my $features = $1;
-
- while ($features =~ s|.*?<TD ALIGN[^>]*>(?:\s*<[^>]+>)*\s+([^<]+?)\s+<.*?<TD>(?:\s*<[^>]+>)*\s+([^<]+?)\s<.*?/TD>||s) {
- my ($f,$v) = ($1, $2);
- chomp $f; chomp $v;
- $feat{$f} = $v;
- }
-
- $content =~ s|.*?>(\d+\S+\s+\(\S+\)).*?</TD>||s; # max temp;
- $max_temp = $1;
- $content =~ s|.*?>(\d+\S+\s+\(\S+\)).*?</TD>||s;
- $min_temp = $1;
-
- if ($time) {
- if ($wxmode eq 'metar' && defined($feat{'ob'})) {
- return ('METAR ' . $place . ": " . $feat{'ob'});
- }
-
- $result = "$place; $id; last updated: $time";
- foreach (sort keys %feat) {
- next if $_ eq 'ob';
- $result .= "; $_: $feat{$_}";
- }
- my $t = time();
- $cache{$station} = join $;, $t, $result;
- } else {
- $result = "I can't find that station code (see http://weather.noaa.gov/weather/curcond.html for locations and codes)";
- }
- return $result;
- }
-}
-
-if (0) {
- if (-t STDIN) {
- my $result = Weather::NOAA::get($default);
- $result =~ s/; /\n/g;
- print "\n$result\n\n";
- }
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-NOAA.pl - Get the weather from a NOAA server
-
-=head1 PREREQUISITES
-
- LWP::UserAgent
-
-=head1 PARAMETERS
-
-weather
-
-=head1 PUBLIC INTERFACE
-
- weather [for] <station>
-
-=head1 DESCRIPTION
-
-Contacts C<weather.noaa.gov> and gets the weather report for a given
-station.
-
-=head1 AUTHORS
-
-Kevin Lenzo
+++ /dev/null
-#
-# Wingate.pl: Wingate checker.
-# Author: dms
-# Version: v0.3 (20000526).
-# Created: 20000116
-# NOTE: based on wingate.pl by fooz.
-#
-
-package Wingate;
-
-use strict;
-my $select = IO::Select->new;
-
-sub Wingates {
- my $file = "$::blootbot_base_dir/$::param{'ircUser'}.wingate";
- my @hosts;
-
- open(IN, $file);
- while (<IN>) {
- chop;
- next if (/\*$/); # wingate. or forget about it?
- push(@hosts,$_);
- }
- close IN;
-
- foreach (@_) {
- next if (grep /^$_$/, @hosts);
-
- &::DEBUG("W: _ => '$_'.");
- &Wingate($_);
- }
-}
-
-sub Wingate {
- my ($host) = @_;
-
- my $sock = IO::Socket::INET->new(
- PeerAddr => $host,
- PeerPort => 'telnet(23)',
- Proto => 'tcp'
-### Timeout => 10, # enough :)
- );
-
- if (!defined $sock) {
- &::status("Wingate: connection refused to $host");
- return;
- }
-
- $sock->timeout(10);
- $select->add($sock);
-
- my $errors = 0;
- my ($luser);
- foreach $luser ($select->can_read(1)) {
- my $buf;
- my $len = 0;
- if (!defined($len = sysread($luser, $buf, 512))) {
- &::status("Wingate: connection lost to $luser/$host.");
- $select->remove($luser);
- close($luser);
- next;
- }
-
- if ($len == 9) {
- $len = sysread($luser, $buf, 512);
- }
-
- my $wingate = 0;
- $wingate++ if ($buf =~ /^WinGate\>/);
- $wingate++ if ($buf =~ /^Too many connected users - try again later$/);
-
- if ($wingate) {
- &::status("Wingate: RUNNING ON $host BY $::who.");
-
- if (&::IsChanConf('wingateBan') > 0) {
- &::ban("*!*\@$host", '');
- }
-
- my $reason = &::getChanConf('wingateKick');
- if ($reason) {
- &::kick($::who, '', $reason);
- }
-
- push(@::wingateBad, "$host\*");
- &::wingateWriteFile();
- } else {
-### &::DEBUG("no wingate.");
- }
-
- ### TODO: close telnet connection correctly!
- $select->remove($luser);
- close($luser);
- }
-
- return;
-}
-
-1;
+++ /dev/null
-#
-# zippy -- infobot module for Zippy the Pinhead quotes
-# hacked up by Rich Lafferty (mendel) <rich@vax2.concordia.ca>
-#
-# Data gratuitously swiped from fortune-mod-9708, the 'fortune' program.
-#
-
-package zippy;
-
-use strict;
-
-my $no_zippy; # Can't think of any situation in which this won't work..
-
-sub zippy::get {
- my @yows;
- &::DEBUG('Reading zippy data');
- while (<DATA>) {
- chomp;
- push @yows, $_;
- }
-
- if ($no_zippy) { # ..but just in case :-)
- return "YOW! I'm an INFOBOT without ZIPPY!" if $::addressed;
- }
-
- srand(); # fork seems to not change rand. force it here
- my $yow = $yows[rand(@yows)];
-
- &::performStrictReply($yow);
-}
-
-1;
-
-=pod
-
-=head1 NAME
-
-Zippy.pl - Yow! Am I having fun yet?
-
-=head1 PREREQUISITES
-
-None.
-
-=head1 PARAMETERS
-
-zippy
-
-=head1 PUBLIC INTERFACE
-
- [yow|be zippy]
-
-=head1 DESCRIPTION
-
-It's OBVIOUS ... The FURS never reached ISTANBUL ... You were an EXTRA
-in the REMAKE of "TOPKAPI" ... Go home to your WIFE ... She's making
-FRENCH TOAST!
-
-Zippy the Pinhead quotations
-(from various comic books and strips by Bill Griffith)
-
-=head1 AUTHORS
-
-Rich Lafferty (mendel) <rich@vax2.concordia.ca>
-
-=cut
-
-__DATA__
-A can of ASPARAGUS, 73 pigeons, some LIVE ammo, and a FROZEN DAQUIRI!!
-A dwarf is passing out somewhere in Detroit!
-A shapely CATHOLIC SCHOOLGIRL is FIDGETING inside my costume..
-A wide-eyed, innocent UNICORN, poised delicately in a MEADOW filled with LILACS, LOLLIPOPS & small CHILDREN at the HUSH of twilight??
-Actually, what I'd like is a little toy spaceship!!
-All I can think of is a platter of organic PRUNE CRISPS being trampled by an army of swarthy, Italian LOUNGE SINGERS ...
-All of a sudden, I want to THROW OVER my promising ACTING CAREER, grow a LONG BLACK BEARD and wear a BASEBALL HAT!! ... Although I don't know WHY!!
-All of life is a blur of Republicans and meat!
-All right, you degenerates! I want this place evacuated in 20 seconds!
-All this time I've been VIEWING a RUSSIAN MIDGET SODOMIZE a HOUSECAT!
-Alright, you!! Imitate a WOUNDED SEAL pleading for a PARKING SPACE!!
-Am I accompanied by a PARENT or GUARDIAN?
-Am I elected yet?
-Am I in GRADUATE SCHOOL yet?
-Am I SHOPLIFTING?
-America!! I saw it all!! Vomiting! Waving! JERRY FALWELLING into your void tube of UHF oblivion!! SAFEWAY of the mind ...
-An air of FRENCH FRIES permeates my nostrils!!
-An INK-LING? Sure -- TAKE one!! Did you BUY any COMMUNIST UNIFORMS??
-An Italian is COMBING his hair in suburban DES MOINES!
-And furthermore, my bowling average is unimpeachable!!!
-ANN JILLIAN'S HAIR makes LONI ANDERSON'S HAIR look like RICARDO MONTALBAN'S HAIR!
-Are the STEWED PRUNES still in the HAIR DRYER?
-Are we live or on tape?
-Are we on STRIKE yet?
-Are we THERE yet?
-Are we THERE yet? My MIND is a SUBMARINE!!
-Are you mentally here at Pizza Hut??
-Are you selling NYLON OIL WELLS?? If so, we can use TWO DOZEN!!
-Are you still an ALCOHOLIC?
-As President I have to go vacuum my coin collection!
-Awright, which one of you hid my PENIS ENVY?
-BARBARA STANWYCK makes me nervous!!
-Barbie says, Take quaaludes in gin and go to a disco right away!
-But Ken says, WOO-WOO!! No credit at "Mr. Liquor"!!
-BARRY ... That was the most HEART-WARMING rendition of "I DID IT MY WAY" I've ever heard!!
-Being a BALD HERO is almost as FESTIVE as a TATTOOED KNOCKWURST.
-BELA LUGOSI is my co-pilot ...
-BI-BI-BI-BI-BI-BI-BI-BI-BI-BI-BI-BI-BI-BI-BI-BI-BI-BI-BI-BI-BI-BI-BI-BI-
-... bleakness ... desolation ... plastic forks ...
-Bo Derek ruined my life!
-Boy, am I glad it's only 1971...
-Boys, you have ALL been selected to LEAVE th' PLANET in 15 minutes!!
-But they went to MARS around 1953!!
-But was he mature enough last night at the lesbian masquerade?
-Can I have an IMPULSE ITEM instead?
-Can you MAIL a BEAN CAKE?
-Catsup and Mustard all over the place! It's the Human Hamburger!
-CHUBBY CHECKER just had a CHICKEN SANDWICH in downtown DULUTH!
-Civilization is fun! Anyway, it keeps me busy!!
-Clear the laundromat!! This whirl-o-matic just had a nuclear meltdown!!
-Concentrate on th'cute, li'l CARTOON GUYS! Remember the SERIAL NUMBERS!! Follow the WHIPPLE AVE. EXIT!! Have a FREE PEPSI!! Turn LEFT at th'HOLIDAY INN!! JOIN the CREDIT WORLD!! MAKE me an OFFER!!!
-CONGRATULATIONS! Now should I make thinly veiled comments about DIGNITY, self-esteem and finding TRUE FUN in your RIGHT VENTRICLE??
-Content: 80% POLYESTER, 20% DACRONi ... The waitress's UNIFORM sheds TARTAR SAUCE like an 8" by 10" GLOSSY ...
-Could I have a drug overdose?
-Did an Italian CRANE OPERATOR just experience uninhibited sensations in a MALIBU HOT TUB?
-Did I do an INCORRECT THING??
-Did I say I was a sardine? Or a bus???
-Did I SELL OUT yet??
-Did YOU find a DIGITAL WATCH in YOUR box of VELVEETA?
-Did you move a lot of KOREAN STEAK KNIVES this trip, Dingy?
-DIDI ... is that a MARTIAN name, or, are we in ISRAEL?
-Didn't I buy a 1951 Packard from you last March in Cairo?
-Disco oil bussing will create a throbbing naugahide pipeline running straight to the tropics from the rug producing regions and devalue the dollar!
-Do I have a lifestyle yet?
-Do you guys know we just passed thru a BLACK HOLE in space?
-Do you have exactly what I want in a plaid poindexter bar bat??
-Do you like "TENDER VITTLES"?
-Do you think the "Monkees" should get gas on odd or even days?
-Does someone from PEORIA have a SHORTER ATTENTION span than me? does your DRESSING ROOM have enough ASPARAGUS?
-DON'T go!! I'm not HOWARD COSELL!! I know POLISH JOKES ... WAIT!!
-Don't go!! I AM Howard Cosell! ... And I DON'T know Polish jokes!!
-Don't hit me!! I'm in the Twilight Zone!!!
-Don't SANFORIZE me!!
-Don't worry, nobody really LISTENS to lectures in MOSCOW, either! ... FRENCH, HISTORY, ADVANCED CALCULUS, COMPUTER PROGRAMMING, BLACK STUDIES, SOCIOBIOLOGY! ... Are there any QUESTIONS??
-Edwin Meese made me wear CORDOVANS!!
-Eisenhower!! Your mimeograph machine upsets my stomach!!
-Either CONFESS now or we go to "PEOPLE'S COURT"!!
-Everybody gets free BORSCHT!
-Everybody is going somewhere!! It's probably a garage sale or a disaster Movie!!
-Everywhere I look I see NEGATIVITY and ASPHALT ...
-Excuse me, but didn't I tell you there's NO HOPE for the survival of OFFSET PRINTING? FEELINGS are cascading over me!!!
-Finally, Zippy drives his 1958 RAMBLER METROPOLITAN into the faculty dining room.
-First, I'm going to give you all the ANSWERS to today's test ... So just plug in your SONY WALKMANS and relax!!
-FOOLED you! Absorb EGO SHATTERING impulse rays, polyester poltroon!! for ARTIFICIAL FLAVORING!!
-Four thousand different MAGNATES, MOGULS & NABOBS are romping in my gothic solarium!!
-FROZEN ENTREES may be flung by members of opposing SWANSON SECTS ...
-FUN is never having to say you're SUSHI!!
-Gee, I feel kind of LIGHT in the head now, knowing I can't make my satellite dish PAYMENTS!
-Gibble, Gobble, we ACCEPT YOU ...
-Give them RADAR-GUIDED SKEE-BALL LANES and VELVEETA BURRITOS!!
-Go on, EMOTE! I was RAISED on thought balloons!!
-GOOD-NIGHT, everybody ... Now I have to go administer FIRST-AID to my pet LEISURE SUIT!!
-HAIR TONICS, please!!
-Half a mind is a terrible thing to waste!
-Hand me a pair of leather pants and a CASIO keyboard -- I'm living for today!
-Has everybody got HALVAH spread all over their ANKLES?? ... Now, it's time to "HAVE A NAGEELA"!! ... he dominates the DECADENT SUBWAY SCENE.
-He is the MELBA-BEING ... the ANGEL CAKE ... XEROX him ... XEROX him -- He probably just wants to take over my CELLS and then EXPLODE inside me like a BARREL of runny CHOPPED LIVER! Or maybe he'd like to PSYCHOLIGICALLY TERRORISE ME until I have no objection to a RIGHT-WING MILITARY TAKEOVER of my apartment!! I guess I should call AL PACINO!
-HELLO KITTY gang terrorizes town, family STICKERED to death!
-HELLO, everybody, I'm a HUMAN!!
-Hello, GORRY-O!! I'm a GENIUS from HARVARD!!
-Hello. I know the divorce rate among unmarried Catholic Alaskan females!!
-Hello. Just walk along and try NOT to think about your INTESTINES being almost FORTY YARDS LONG!!
-Hello... IRON CURTAIN? Send over a SAUSAGE PIZZA! World War III? No thanks!
-Hello? Enema Bondage? I'm calling because I want to be happy, I guess ...
-Here I am at the flea market but nobody is buying my urine sample bottles ...
-Here I am in 53 B.C. and all I want is a dill pickle!!
-Here I am in the POSTERIOR OLFACTORY LOBULE but I don't see CARL SAGAN anywhere!!
-Here we are in America ... when do we collect unemployment?
-Hey, wait a minute!! I want a divorce!! ... you're not Clint Eastwood!!
-Hey, waiter! I want a NEW SHIRT and a PONY TAIL with lemon sauce!
-Hiccuping & trembling into the WASTE DUMPS of New Jersey like some drunken CABBAGE PATCH DOLL, coughing in line at FIORUCCI'S!!
-Hmmm ... a CRIPPLED ACCOUNTANT with a FALAFEL sandwich is HIT by a TROLLEY-CAR ...
-Hmmm ... A hash-singer and a cross-eyed guy were SLEEPING on a deserted island, when ...
-Hmmm ... a PINHEAD, during an EARTHQUAKE, encounters an ALL-MIDGET FIDDLE ORCHESTRA ... ha ... ha ...
-Hmmm ... an arrogant bouquet with a subtle suggestion of POLYVINYL CHLORIDE ...
-Hold the MAYO & pass the COSMIC AWARENESS ...
-HOORAY, Ronald!! Now YOU can marry LINDA RONSTADT too!!
-How do I get HOME?
-How do you explain Wayne Newton's POWER over millions? It's th' MOUSTACHE ... Have you ever noticed th' way it radiates SINCERITY, HONESTY & WARMTH?
-It's a MOUSTACHE you want to take HOME and introduce to NANCY SINATRA!
-How many retured bricklayers from FLORIDA are out purchasing PENCIL
-SHARPENERS right NOW??
-How's it going in those MODULAR LOVE UNITS??
-How's the wife? Is she at home enjoying capitalism?
-hubub, hubub, HUBUB, hubub, hubub, hubub, HUBUB, hubub, hubub, hubub.
-HUGH BEAUMONT died in 1982!!
-HUMAN REPLICAS are inserted into VATS of NUTRITIONAL YEAST ...
-I always have fun because I'm out of my mind!!!
-I am a jelly donut. I am a jelly donut.
-I am a traffic light, and Alan Ginzberg kidnapped my laundry in 1927!
-I am covered with pure vegetable oil and I am writing a best seller!
-I am deeply CONCERNED and I want something GOOD for BREAKFAST!
-I am having FUN... I wonder if it's NET FUN or GROSS FUN?
-I am NOT a nut....
-I appoint you ambassador to Fantasy Island!!!
-I brought my BOWLING BALL -- and some DRUGS!!
-I can't decide which WRONG TURN to make first!! I wonder if BOB GUCCIONE has these problems!
-I can't think about that. It doesn't go with HEDGES in the shape of LITTLE LULU -- or ROBOTS making BRICKS ...
-I demand IMPUNITY!
-I didn't order any WOO-WOO ... Maybe a YUBBA ... But no WOO-WOO!
-I don't believe there really IS a GAS SHORTAGE.. I think it's all just a BIG HOAX on the part of the plastic sign salesmen -- to sell more numbers!!
-... I don't know why but, suddenly, I want to discuss declining I.Q. LEVELS with a blue ribbon SENATE SUB-COMMITTEE!
-I don't know WHY I said that ... I think it came from the FILLINGS in my read molars ...
-... I don't like FRANK SINATRA or his CHILDREN. I don't understand the HUMOUR of the THREE STOOGES!!
-I feel ... JUGULAR ...
-I feel better about world problems now!
-I feel like a wet parking meter on Darvon!
-I feel like I am sharing a ``CORN-DOG'' with NIKITA KHRUSCHEV ...
-I feel like I'm in a Toilet Bowl with a thumbtack in my forehead!!
-I feel partially hydrogenated!
-I fill MY industrial waste containers with old copies of the "WATCHTOWER" and then add HAWAIIAN PUNCH to the top ... They look NICE in the yard ...
-I guess it was all a DREAM ... or an episode of HAWAII FIVE-O ...
-I guess you guys got BIG MUSCLES from doing too much STUDYING!
-I had a lease on an OEDIPUS COMPLEX back in '81 ...
-I had pancake makeup for brunch!
-I have a TINY BOWL in my HEAD
-I have a very good DENTAL PLAN. Thank you.
-I have a VISION! It's a RANCID double-FISHWICH on an ENRICHED BUN!!
-I have accepted Provolone into my life!
-I have many CHARTS and DIAGRAMS..
-... I have read the INSTRUCTIONS ...
--- I have seen the FUN --
-I have seen these EGG EXTENDERS in my Supermarket ... I have read the INSTRUCTIONS ...
-I have the power to HALT PRODUCTION on all TEENAGE SEX COMEDIES!!
-I HAVE to buy a new "DODGE MISER" and two dozen JORDACHE JEANS because my viewscreen is "USER-FRIENDLY"!!
-I haven't been married in over six years, but we had sexual counseling every day from Oral Roberts!!
-I hope I bought the right relish ... zzzzzzzzz ...
-I hope something GOOD came in the mail today so I have a REASON to live!!
-I hope the ``Eurythmics'' practice birth control ...
-I hope you millionaires are having fun! I just invested half your life savings in yeast!!
-I invented skydiving in 1989!
-I joined scientology at a garage sale!!
-I just forgot my whole philosophy of life!!!
-I just got my PRINCE bumper sticker ... But now I can't remember WHO he is ...
-I just had a NOSE JOB!!
-I just had my entire INTESTINAL TRACT coated with TEFLON!
-I just heard the SEVENTIES were over!! And I was just getting in touch with my LEISURE SUIT!!
-I just remembered something about a TOAD!
-I KAISER ROLL?! What good is a Kaiser Roll without a little COLE SLAW on the SIDE?
-I Know A Joke!!
-I know how to do SPECIAL EFFECTS!!
-I know th'MAMBO!! I have a TWO-TONE CHEMISTRY SET!!
-I know things about TROY DONAHUE that can't even be PRINTED!!
-I left my WALLET in the BATHROOM!!
-I like the way ONLY their mouths move ... They look like DYING OYSTERS
-I like your SNOOPY POSTER!!
--- I love KATRINKA because she drives a PONTIAC. We're going away now. I fed the cat.
-I love ROCK 'N ROLL! I memorized the all WORDS to "WIPE-OUT" in 1965!!
-I need to discuss BUY-BACK PROVISIONS with at least six studio SLEAZEBALLS!!
-I once decorated my apartment entirely in ten foot salad forks!!
-I own seven-eighths of all the artists in downtown Burbank!
-I put aside my copy of "BOWLING WORLD" and think about GUN CONTROL legislation...
-I represent a sardine!!
-I request a weekend in Havana with Phil Silvers!
-... I see TOILET SEATS ...
-I selected E5 ... but I didn't hear "Sam the Sham and the Pharoahs"!
-I smell a RANCID CORN DOG!
-I smell like a wet reducing clinic on Columbus Day!
-I think I am an overnight sensation right now!!
-... I think I'd better go back to my DESK and toy with a few common MISAPPREHENSIONS ...
-I think I'll KILL myself by leaping out of this 14th STORY WINDOW while reading ERICA JONG'S poetry!!
-I think my career is ruined!
-I used to be a FUNDAMENTALIST, but then I heard about the HIGH RADIATION LEVELS and bought an ENCYCLOPEDIA!!
-... I want a COLOR T.V. and a VIBRATING BED!!!
-I want a VEGETARIAN BURRITO to go ... with EXTRA MSG!!
-I want a WESSON OIL lease!!
-I want another RE-WRITE on my CEASAR SALAD!!
-I want EARS! I want two ROUND BLACK EARS to make me feel warm 'n secure!!
-... I want FORTY-TWO TRYNEL FLOATATION SYSTEMS installed within SIX AND A HALF HOURS!!!
-I want the presidency so bad I can already taste the hors d'oeuvres.
-I want to dress you up as TALLULAH BANKHEAD and cover you with VASELINE and WHEAT THINS ...
-I want to kill everyone here with a cute colorful Hydrogen Bomb!!
-... I want to perform cranial activities with Tuesday Weld!!
-I want to read my new poem about pork brains and outer space ...
-I want to so HAPPY, the VEINS in my neck STAND OUT!!
-I want you to MEMORIZE the collected poems of EDNA ST VINCENT MILLAY ... BACKWARDS!!
-I want you to organize my PASTRY trays ... my TEA-TINS are gleaming in formation like a ROW of DRUM MAJORETTES -- please don't be FURIOUS with me --
-I was born in a Hostess Cupcake factory before the sexual revolution!
-I was making donuts and now I'm on a bus!
-I wish I was a sex-starved manicurist found dead in the Bronx!!
-I wish I was on a Cincinnati street corner holding a clean dog!
-I wonder if I could ever get started in the credit world?
-I wonder if I ought to tell them about my PREVIOUS LIFE as a COMPLETE STRANGER?
-I wonder if I should put myself in ESCROW!!
-I wonder if there's anything GOOD on tonight?
-I would like to urinate in an OVULAR, porcelain pool --
-I'd like MY data-base JULIENNED and stir-fried!
-I'd like some JUNK FOOD ... and then I want to be ALONE --
-I'll eat ANYTHING that's BRIGHT BLUE!!
-I'll show you MY telex number if you show me YOURS ...
-I'm a fuschia bowling ball somewhere in Brittany
-I'm a GENIUS! I want to dispute sentence structure with SUSAN SONTAG!!
-I'm a nuclear submarine under the polar ice cap and I need a Kleenex!
-I'm also against BODY-SURFING!!
-I'm also pre-POURED pre-MEDITATED and pre-RAPHAELITE!!
-I'm ANN LANDERS!! I can SHOPLIFT!!
-I'm changing the CHANNEL ... But all I get is commercials for "RONCO MIRACLE BAMBOO STEAMERS"!
-I'm continually AMAZED at th'breathtaking effects of WIND EROSION!!
-I'm definitely not in Omaha!
-I'm DESPONDENT ... I hope there's something DEEP-FRIED under this miniature DOMED STADIUM ...
-I'm dressing up in an ill-fitting IVY-LEAGUE SUIT!! Too late...
-I'm EMOTIONAL now because I have MERCHANDISING CLOUT!!
-I'm encased in the lining of a pure pork sausage!!
-I'm GLAD I remembered to XEROX all my UNDERSHIRTS!!
-I'm gliding over a NUCLEAR WASTE DUMP near ATLANTA, Georgia!!
-I'm having a BIG BANG THEORY!!
-I'm having a MID-WEEK CRISIS!
-I'm having a RELIGIOUS EXPERIENCE ... and I don't take any DRUGS
-I'm having a tax-deductible experience! I need an energy crunch!!
-I'm having an emotional outburst!!
-I'm having an EMOTIONAL OUTBURST!! But, uh, WHY is there a WAFFLE in my PAJAMA POCKET??
-I'm having BEAUTIFUL THOUGHTS about the INSIPID WIVES of smug and wealthy CORPORATE LAWYERS ...
-I'm having fun HITCHHIKING to CINCINNATI or FAR ROCKAWAY!! ...
-I'm IMAGINING a sensuous GIRAFFE, CAVORTING in the BACK ROOM of a KOSHER DELI
-I'm in direct contact with many advanced fun CONCEPTS.
-I'm into SOFTWARE!
-I'm meditating on the FORMALDEHYDE and the ASBESTOS leaking into my PERSONAL SPACE!!
-I'm mentally OVERDRAWN! What's that SIGNPOST up ahead? Where's ROD STERLING when you really need him?
-I'm not an Iranian!! I voted for Dianne Feinstein!!
-I'm not available for comment..
-I'm pretending I'm pulling in a TROUT! Am I doing it correctly??
-I'm pretending that we're all watching PHIL SILVERS instead of RICARDO MONTALBAN!
-I'm QUIETLY reading the latest issue of "BOWLING WORLD" while my wife and two children stand QUIETLY BY ...
-I'm rated PG-34!!
-I'm receiving a coded message from EUBIE BLAKE!!
-I'm RELIGIOUS!! I love a man with a HAIRPIECE!! Equip me with MISSILES!!
-I'm reporting for duty as a modern person. I want to do the Latin Hustle now!
-I'm shaving!! I'M SHAVING!!
-I'm sitting on my SPEED QUEEN ... To me, it's ENJOYABLE ... I'm WARM ... I'm VIBRATORY ...
-I'm thinking about DIGITAL READ-OUT systems and computer-generated IMAGE FORMATIONS ...
-I'm totally DESPONDENT over the LIBYAN situation and the price of CHICKEN ...
-I'm using my X-RAY VISION to obtain a rare glimpse of the INNER WORKINGS of this POTATO!!
-I'm wearing PAMPERS!!
-I'm wet! I'm wild!
-I'm young ... I'm HEALTHY ... I can HIKE THRU CAPT GROGAN'S LUMBAR REGIONS!
-I'm ZIPPY the PINHEAD and I'm totally committed to the festive mode.
-I've got a COUSIN who works in the GARMENT DISTRICT ...
-I've got an IDEA!! Why don't I STARE at you so HARD, you forget your SOCIAL SECURITY NUMBER!!
-I've read SEVEN MILLION books!! ... ich bin in einem dusenjet ins jahr 53 vor chr ... ich lande im antiken Rom ... einige gladiatoren spielen scrabble ... ich rieche PIZZA ...
-If a person is FAMOUS in this country, they have to go on the ROAD for MONTHS at a time and have their name misspelled on the SIDE of a GREYHOUND SCENICRUISER!!
-If elected, Zippy pledges to each and every American a 55-year-old houseboy ...
-If I am elected no one will ever have to do their laundry again!
-If I am elected, the concrete barriers around the WHITE HOUSE will be replaced by tasteful foam replicas of ANN MARGARET!
-If I felt any more SOPHISTICATED I would DIE of EMBARRASSMENT!
-If I had a Q-TIP, I could prevent th' collapse of NEGOTIATIONS!! ... If I had heart failure right now, I couldn't be a more fortunate man!!
-If I pull this SWITCH I'll be RITA HAYWORTH!! Or a SCIENTOLOGIST!
-if it GLISTENS, gobble it!!
-If our behavior is strict, we do not need fun!
-If Robert Di Niro assassinates Walter Slezak, will Jodie Foster marry Bonzo??
-In 1962, you could buy a pair of SHARKSKIN SLACKS, with a "Continental Belt," for $10.99!!
-In Newark the laundromats are open 24 hours a day!
-INSIDE, I have the same personality disorder as LUCY RICARDO!!
-Inside, I'm already SOBBING!
-Is a tattoo real, like a curb or a battleship? Or are we suffering in Safeway?
-Is he the MAGIC INCA carrying a FROG on his shoulders?? Is the FROG his GUIDELIGHT?? It is curious that a DOG runs already on the ESCALATOR ...
-Is it 1974? What's for SUPPER? Can I spend my COLLEGE FUND in one wild afternoon??
-Is it clean in other dimensions?
-Is it NOUVELLE CUISINE when 3 olives are struggling with a scallop in a plate of SAUCE MORNAY?
-Is something VIOLENT going to happen to a GARBAGE CAN?
-Is this an out-take from the "BRADY BUNCH"?
-Is this going to involve RAW human ecstasy?
-Is this TERMINAL fun?
-Is this the line for the latest whimsical YUGOSLAVIAN drama which also makes you want to CRY and reconsider the VIETNAM WAR?
-Isn't this my STOP?!
-It don't mean a THING if you ain't got that SWING!!
-It was a JOKE!! Get it?? I was receiving messages from DAVID LETTERMAN!! YOW!!
-It's a lot of fun being alive ... I wonder if my bed is made?!?
-It's NO USE ... I've gone to "CLUB MED"!!
-It's OBVIOUS ... The FURS never reached ISTANBUL ... You were an EXTRA in the REMAKE of "TOPKAPI" ... Go home to your WIFE ... She's making FRENCH TOAST!
-It's OKAY -- I'm an INTELLECTUAL, too.
-It's the RINSE CYCLE!! They've ALL IGNORED the RINSE CYCLE!!
-JAPAN is a WONDERFUL planet -- I wonder if we'll ever reach their level of COMPARATIVE SHOPPING ...
-Jesuit priests are DATING CAREER DIPLOMATS!!
-Jesus is my POSTMASTER GENERAL ...
-Kids, don't gross me off ... "Adventures with MENTAL HYGIENE" can be carried too FAR!
-Kids, the seven basic food groups are GUM, PUFF PASTRY, PIZZA, PESTICIDES, ANTIBIOTICS, NUTRA-SWEET and MILK DUDS!!
-Laundry is the fifth dimension!! ... um ... um ... th' washing machine is a black hole and the pink socks are bus drivers who just fell in!!
-LBJ, LBJ, how many JOKES did you tell today??!
-Leona, I want to CONFESS things to you ... I want to WRAP you in a SCARLET ROBE trimmed with POLYVINYL CHLORIDE ... I want to EMPTY your ASHTRAYS ...
-Let me do my TRIBUTE to FISHNET STOCKINGS ...
-Let's all show human CONCERN for REVERAND MOON's legal difficulties!!
-Let's send the Russians defective lifestyle accessories!
-Life is a POPULARITY CONTEST! I'm REFRESHINGLY CANDID!!
-Like I always say -- nothing can beat the BRATWURST here in DUSSELDORF!!
-Loni Anderson's hair should be LEGALIZED!!
-Look DEEP into the OPENINGS!! Do you see any ELVES or EDSELS ... or a HIGHBALL?? ...
-Look into my eyes and try to forget that you have a Macy's charge card!
-Look! A ladder! Maybe it leads to heaven, or a sandwich!
-LOOK!! Sullen American teens wearing MADRAS shorts and "Flock of Seagulls" HAIRCUTS!
-Make me look like LINDA RONSTADT again!!
-Mary Tyler Moore's SEVENTH HUSBAND is wearing my DACRON TANK TOP in a cheap hotel in HONOLULU!
-Maybe we could paint GOLDIE HAWN a rich PRUSSIAN BLUE --
-MERYL STREEP is my obstetrician!
-MMM-MM!! So THIS is BIO-NEBULATION!
-Mmmmmm-MMMMMM!! A plate of STEAMING PIECES of a PIG mixed with the shreds of SEVERAL CHICKENS!! ... Oh BOY!! I'm about to swallow a TORN-OFF section of a COW'S LEFT LEG soaked in COTTONSEED OIL and SUGAR!! ... Let's see ... Next, I'll have the GROUND-UP flesh of CUTE, BABY LAMBS fried in the MELTED, FATTY TISSUES from a warm-blooded animal someone once PETTED!! ... YUM!! That was GOOD!! For DESSERT, I'll have a TOFU BURGER with BEAN SPROUTS on a stone-ground, WHOLE WHEAT BUN!!
-Mr and Mrs PED, can I borrow 26.7% of the RAYON TEXTILE production of the INDONESIAN archipelago?
-My Aunt MAUREEN was a military advisor to IKE & TINA TURNER!!
-My BIOLOGICAL ALARM CLOCK just went off ... It has noiseless DOZE FUNCTION and full kitchen!!
-My CODE of ETHICS is vacationing at famed SCHROON LAKE in upstate New York!!
-My EARS are GONE!!
-My face is new, my license is expired, and I'm under a doctor's care!!!!
-My haircut is totally traditional!
-MY income is ALL disposable!
-My LESLIE GORE record is BROKEN ...
-My life is a patio of fun!
-My mind is a potato field ...
-My mind is making ashtrays in Dayton ...
-My nose feels like a bad Ronald Reagan movie ...
-My NOSE is NUMB!
-... My pants just went on a wild rampage through a Long Island Bowling Alley!!
-My pants just went to high school in the Carlsbad Caverns!!!
-My polyvinyl cowboy wallet was made in Hong Kong by Montgomery Clift!
-My uncle Murray conquered Egypt in 53 B.C. And I can prove it too!!
-My vaseline is RUNNING...
-NANCY!! Why is everything RED?!
-NATHAN ... your PARENTS were in a CARCRASH!! They're VOIDED -- They COLLAPSED They had no CHAINSAWS ... They had no MONEY MACHINES ... They did PILLS in SKIMPY GRASS SKIRTS ... Nathan, I EMULATED them ... but they were OFF-KEY ...
-NEWARK has been REZONED!! DES MOINES has been REZONED!!
-Nipples, dimples, knuckles, NICKLES, wrinkles, pimples!!
-Not SENSUOUS ... only "FROLICSOME" ... and in need of DENTAL WORK ... in PAIN!!!
-Now I am depressed ...
-Now I think I just reached the state of HYPERTENSION that comes JUST BEFORE you see the TOTAL at the SAFEWAY CHECKOUT COUNTER!
-Now I understand the meaning of "THE MOD SQUAD"!
-Now I'm being INVOLUNTARILY shuffled closer to the CLAM DIP with the BROKEN PLASTIC FORKS in it!!
-Now I'm concentrating on a specific tank battle toward the end of World War II!
-Now I'm having INSIPID THOUGHTS about the beatiful, round wives of HOLLYWOOD MOVIE MOGULS encased in PLEXIGLASS CARS and being approached by SMALL BOYS selling FRUIT ...
-Now KEN and BARBIE are PERMANENTLY ADDICTED to MIND-ALTERING DRUGS ...
-Now my EMOTIONAL RESOURCES are heavily committed to 23% of the SMELTING and REFINING industry of the state of NEVADA!!
-Now that I have my "APPLE", I comprehend COST ACCOUNTING!!
-Now, let's SEND OUT for QUICHE!!
-Of course, you UNDERSTAND about the PLAIDS in the SPIN CYCLE --
-Oh my GOD -- the SUN just fell into YANKEE STADIUM!!
-Oh, I get it!! "The BEACH goes on", huh, SONNY??
-Okay ... I'm going home to write the "I HATE RUBIK's CUBE HANDBOOK FOR DEAD CAT LOVERS" ...
-OKAY!! Turn on the sound ONLY for TRYNEL CARPETING, FULLY-EQUIPPED R.V.'S and FLOATATION SYSTEMS!!
-OMNIVERSAL AWARENESS?? Oh, YEH!! First you need four GALLONS of JELL-O and a BIG WRENCH!! ... I think you drop th'WRENCH in the JELL-O as if it was a FLAVOR, or an INGREDIENT ... ... or ... I ... um ... WHERE'S the WASHING MACHINES?
-On SECOND thought, maybe I'll heat up some BAKED BEANS and watch REGIS PHILBIN ... It's GREAT to be ALIVE!!
-On the other hand, life can be an endless parade of TRANSSEXUAL
-QUILTING BEES aboard a cruise ship to DISNEYWORLD if only we let it!!
-On the road, ZIPPY is a pinhead without a purpose, but never without a POINT.
-Once upon a time, four AMPHIBIOUS HOG CALLERS attacked a family of DEFENSELESS, SENSITIVE COIN COLLECTORS and brought DOWN their PROPERTY VALUES!!
-Once, there was NO fun ... This was before MENU planning, FASHION statements or NAUTILUS equipment ... Then, in 1985 ... FUN was completely encoded in this tiny MICROCHIP ... It contain 14,768 vaguely amusing SIT-COM pilots!! We had to wait FOUR BILLION years but we finally got JERRY LEWIS, MTV and a large selection of creme-filled snack cakes!
-One FISHWICH coming up!!
-ONE LIFE TO LIVE for ALL MY CHILDREN in ANOTHER WORLD all THE DAYS OF OUR LIVES.
-ONE: I will donate my entire "BABY HUEY" comic book collection to the downtown PLASMA CENTER ... TWO: I won't START a BAND called "KHADAFY & THE HIT SQUAD" ... THREE: I won't ever TUMBLE DRY my FOX TERRIER again!!
-... or were you driving the PONTIAC that HONKED at me in MIAMI last Tuesday?
-Our father who art in heaven ... I sincerely pray that SOMEBODY at this table will PAY for my SHREDDED WHAT and ENGLISH MUFFIN ... and also leave a GENEROUS TIP ....
-over in west Philadelphia a puppy is vomiting ...
-OVER the underpass! UNDER the overpass! Around the FUTURE and BEYOND REPAIR!!
-PARDON me, am I speaking ENGLISH?
-Pardon me, but do you know what it means to be TRULY ONE with your BOOTH!
-PEGGY FLEMMING is stealing BASKET BALLS to feed the babies in VERMONT.
-People humiliating a salami!
-PIZZA!!
-Place me on a BUFFER counter while you BELITTLE several BELLHOPS in the Trianon Room!! Let me one of your SUBSIDIARIES!
-Please come home with me ... I have Tylenol!!
-Psychoanalysis?? I thought this was a nude rap session!!!
-PUNK ROCK!! DISCO DUCK!! BIRTH CONTROL!!
-Quick, sing me the BUDAPEST NATIONAL ANTHEM!!
-RELATIVES!!
-Remember, in 2039, MOUSSE & PASTA will be available ONLY by prescription!!
-RHAPSODY in Glue!
-SANTA CLAUS comes down a FIRE ESCAPE wearing bright blue LEG WARMERS ... He scrubs the POPE with a mild soap or detergent for 15 minutes, starring JANE FONDA!!
-Send your questions to ``ASK ZIPPY'', Box 40474, San Francisco, CA 94140, USA
-SHHHH!! I hear SIX TATTOOED TRUCK-DRIVERS tossing ENGINE BLOCKS into empty OIL DRUMS ...
-Should I do my BOBBIE VINTON medley?
-Should I get locked in the PRINCICAL'S OFFICE today -- or have a VASECTOMY??
-Should I start with the time I SWITCHED personalities with a BEATNIK hair stylist or my failure to refer five TEENAGERS to a good OCULIST? Sign my PETITION.
-So this is what it feels like to be potato salad
-So, if we convert SUPPLY-SIDE SOYABEAN FUTURES into HIGH-YIELD T-BILL INDICATORS, the PRE-INFLATIONARY risks will DWINDLE to a rate of 2 SHOPPING SPREES per EGGPLANT!!
-Someone in DAYTON, Ohio is selling USED CARPETS to a SERBO-CROATIAN
-Sometime in 1993 NANCY SINATRA will lead a BLOODLESS COUP on GUAM!!
-Somewhere in DOWNTOWN BURBANK a prostitute is OVERCOOKING a LAMB CHOP!!
-Somewhere in suburban Honolulu, an unemployed bellhop is whipping up a batch of illegal psilocybin chop suey!!
-Somewhere in Tenafly, New Jersey, a chiropractor is viewing "Leave it to Beaver"!
-Spreading peanut butter reminds me of opera!! I wonder why?
-TAILFINS!! ... click ...
-Talking Pinhead Blues: Oh, I LOST my ``HELLO KITTY'' DOLL and I get BAD reception on channel TWENTY-SIX!! Th'HOSTESS FACTORY is closin' down and I just heard ZASU PITTS has been DEAD for YEARS.. (sniff) My PLATFORM SHOE collection was CHEWED up by th' dog, ALEXANDER HAIG won't let me take a SHOWER 'til Easter ... (snurf) So I went to the kitchen, but WALNUT PANELING whup me upside mah HAID!! (on no, no, no.. Heh, heh)
-TAPPING? You POLITICIANS! Don't you realize that the END of the "Wash Cycle" is a TREASURED MOMENT for most people?!
-Tex SEX! The HOME of WHEELS! The dripping of COFFEE!! Take me to Minnesota but don't EMBARRASS me!!
-Th' MIND is the Pizza Palace of th' SOUL
-Thank god!! ... It's HENNY YOUNGMAN!!
-The appreciation of the average visual graphisticator alone is worth
-the whole suaveness and decadence which abounds!!
-The entire CHINESE WOMEN'S VOLLEYBALL TEAM all share ONE personality -- and have since BIRTH!!
-The fact that 47 PEOPLE are yelling and sweat is cascading down my SPINAL COLUMN is fairly enjoyable!!
-The FALAFEL SANDWICH lands on my HEAD and I become a VEGETARIAN ...
-... the HIGHWAY is made out of LIME JELLO and my HONDA is a barbequeued OYSTER! Yum!
-The Korean War must have been fun. ... the MYSTERIANS are in here with my CORDUROY SOAP DISH!!
-The Osmonds! You are all Osmonds!! Throwing up on a freeway at dawn!!!
-The PILLSBURY DOUGHBOY is CRYING for an END to BURT REYNOLDS movies!!
-The PINK SOCKS were ORIGINALLY from 1952!! But they went to MARS around 1953!!
-The SAME WAVE keeps coming in and COLLAPSING like a rayon MUU-MUU ...
-There is no TRUTH. There is no REALITY. There is no CONSISTENCY.
-There are no ABSOLUTE STATEMENTS. I'm very probably wrong.
-There's a little picture of ED MCMAHON doing BAD THINGS to JOAN RIVERS in a $200,000 MALIBU BEACH HOUSE!!
-There's enough money here to buy 5000 cans of Noodle-Roni! "These are DARK TIMES for all mankind's HIGHEST VALUES!" "These are DARK TIMES for FREEDOM and PROSPERITY!" "These are GREAT TIMES to put your money on BAD GUY to kick the CRAP out of MEGATON MAN!"
-These PRESERVES should be FORCE-FED to PENTAGON OFFICIALS!!
-They collapsed ... like nuns in the street ... they had no teen appeal!
-This ASEXUAL PIG really BOILS my BLOOD ... He's so ... so ... URGENT!!
-"This is a job for BOB VIOLENCE and SCUM, the INCREDIBLY STUPID MUTANT DOG." -- Bob Violence
-This is a NO-FRILLS flight -- hold th' CANADIAN BACON!!
-This MUST be a good party -- My RIB CAGE is being painfully pressed up against someone's MARTINI!! ... this must be what it's like to be a COLLEGE GRADUATE!!
-This PIZZA symbolizes my COMPLETE EMOTIONAL RECOVERY!!
-This PORCUPINE knows his ZIPCODE ... And he has "VISA"!!
-This TOPS OFF my partygoing experience! Someone I DON'T LIKE is talking to me about a HEART-WARMING European film ...
-Those aren't WINOS -- that's my JUGGLER, my AERIALIST, my SWORD SWALLOWER, and my LATEX NOVELTY SUPPLIER!!
-Thousands of days of civilians ... have produced a ... feeling for the aesthetic modules --
-Today, THREE WINOS from DETROIT sold me a framed photo of TAB HUNTER before his MAKEOVER!
-Toes, knees, NIPPLES. Toes, knees, nipples, KNUCKLES ... Nipples, dimples, knuckles, NICKLES, wrinkles, pimples!! TONY RANDALL! Is YOUR life a PATIO of FUN??
-Uh-oh -- WHY am I suddenly thinking of a VENERABLE religious leader frolicking on a FORT LAUDERDALE weekend?
-Uh-oh!! I forgot to submit to COMPULSORY URINALYSIS!
-UH-OH!! I put on "GREAT HEAD-ON TRAIN COLLISIONS of the 50's" by mistake!!!
-UH-OH!! I think KEN is OVER-DUE on his R.V. PAYMENTS and HE'S having a NERVOUS BREAKDOWN too!! Ha ha.
-Uh-oh!! I'm having TOO MUCH FUN!!
-UH-OH!! We're out of AUTOMOBILE PARTS and RUBBER GOODS!
-Used staples are good with SOY SAUCE!
-VICARIOUSLY experience some reason to LIVE!!
-Vote for ME -- I'm well-tapered, half-cocked, ill-conceived and TAX-DEFERRED!
-Wait ... is this a FUN THING or the END of LIFE in Petticoat Junction??
-Was my SOY LOAF left out in th'RAIN? It tastes REAL GOOD!!
-We are now enjoying total mutual interaction in an imaginary hot tub ...
-We have DIFFERENT amounts of HAIR --
-We just joined the civil hair patrol!
-We place two copies of PEOPLE magazine in a DARK, HUMID mobile home. 45 minutes later CYNDI LAUPER emerges wearing a BIRD CAGE on her head!
-Well, here I am in AMERICA.. I LIKE it. I HATE it. I LIKE it. I HATE it. I LIKE it. I HATE it. I LIKE it. I HATE it. I LIKE ... EMOTIONS are SWEEPING over me!!
-Well, I'm a classic ANAL RETENTIVE!! And I'm looking for a way to VICARIOUSLY experience some reason to LIVE!!
-Well, I'm INVISIBLE AGAIN ... I might as well pay a visit to the LADIES ROOM ...
-Well, O.K. I'll compromise with my principles because of EXISTENTIAL DESPAIR!
-Were these parsnips CORRECTLY MARINATED in TACO SAUCE?
-What a COINCIDENCE! I'm an authorized "SNOOTS OF THE STARS" dealer!!
-What GOOD is a CARDBOARD suitcase ANYWAY?
-What I need is a MATURE RELATIONSHIP with a FLOPPY DISK ...
-What I want to find out is -- do parrots know much about Astro-Turf?
-What PROGRAM are they watching?
-What UNIVERSE is this, please??
-What's the MATTER Sid? ... Is your BEVERAGE unsatisfactory?
-When I met th'POPE back in '58, I scrubbed him with a MILD SOAP or DETERGENT for 15 minutes. He seemed to enjoy it ...
-When this load is DONE I think I'll wash it AGAIN ...
-When you get your PH.D. will you get able to work at BURGER KING?
-When you said "HEAVILY FORESTED" it reminded me of an overdue CLEANING BILL ... Don't you SEE? O'Grogan SWALLOWED a VALUABLE COIN COLLECTION and HAD to murder the ONLY MAN who KNEW!!
-Where do your SOCKS go when you lose them in th' WASHER?
-Where does it go when you flush?
-Where's SANDY DUNCAN?
-Where's th' DAFFY DUCK EXHIBIT??
-Where's the Coke machine? Tell me a joke!!
-While my BRAINPAN is being refused service in BURGER KING, Jesuit priests are DATING CAREER DIPLOMATS!!
-While you're chewing, think of STEVEN SPIELBERG'S bank account ... his will have the same effect as two "STARCH BLOCKERS"!
-WHO sees a BEACH BUNNY sobbing on a SHAG RUG?!
-WHOA!! Ken and Barbie are having TOO MUCH FUN!! It must be the NEGATIVE IONS!!
-Why are these athletic shoe salesmen following me??
-Why don't you ever enter any CONTESTS, Marvin?? Don't you know your own ZIPCODE?
-Why is everything made of Lycra Spandex?
-Why is it that when you DIE, you can't take your HOME ENTERTAINMENT CENTER with you??
-Will it improve my CASH FLOW?
-Will the third world war keep "Bosom Buddies" off the air?
-Will this never-ending series of PLEASURABLE EVENTS never cease?
-With YOU, I can be MYSELF ... We don't NEED Dan Rather ...
-World War III? No thanks!
-World War Three can be averted by adherence to a strictly enforced dress code!
-Wow! Look!! A stray meatball!! Let's interview it!
-Xerox your lunch and file it under "sex offenders"!
-Yes, but will I see the EASTER BUNNY in skintight leather at an IRON MAIDEN concert?
-You can't hurt me!! I have an ASSUMABLE MORTGAGE!!
-You mean now I can SHOOT YOU in the back and further BLUR th' distinction between FANTASY and REALITY?
-You mean you don't want to watch WRESTLING from ATLANTA?
-YOU PICKED KARL MALDEN'S NOSE!!
-You should all JUMP UP AND DOWN for TWO HOURS while I decide on a NEW CAREER!!
-You were s'posed to laugh!
-YOU!! Give me the CUTEST, PINKEST, most charming little VICTORIAN DOLLHOUSE you can find!! An make it SNAPPY!!
-Your CHEEKS sit like twin NECTARINES above a MOUTH that knows no BOUNDS -- Youth of today! Join me in a mass rally for traditional mental attitudes!
-Yow!
-Yow! Am I having fun yet?
-Yow! Am I in Milwaukee?
-Yow! And then we could sit on the hoods of cars at stop lights!
-Yow! Are we laid back yet?
-Yow! Are we wet yet?
-Yow! Are you the self-frying president?
-Yow! Did something bad happen or am I in a drive-in movie??
-Yow! I just went below the poverty line!
-Yow! I threw up on my window!
-Yow! I want my nose in lights!
-Yow! I want to mail a bronzed artichoke to Nicaragua!
-Yow! I'm having a quadrophonic sensation of two winos alone in a steel mill!
-Yow! I'm imagining a surfer van filled with soy sauce!
-Yow! Is my fallout shelter termite proof?
-Yow! Is this sexual intercourse yet?? Is it, huh, is it??
-Yow! It's a hole all the way to downtown Burbank!
-Yow! It's some people inside the wall! This is better than mopping!
-Yow! Maybe I should have asked for my Neutron Bomb in PAISLEY --
-Yow! Now I get to think about all the BAD THINGS I did to a BOWLING BALL when I was in JUNIOR HIGH SCHOOL!
-Yow! Now we can become alcoholics!
-Yow! Those people look exactly like Donnie and Marie Osmond!!
-Yow! We're going to a new disco!
-YOW!! Everybody out of the GENETIC POOL!
-YOW!! I'm in a very clever and adorable INSANE ASYLUM!!
-YOW!! Now I understand advanced MICROBIOLOGY and th' new TAX REFORM laws!!
-YOW!! The land of the rising SONY!!
-YOW!! Up ahead! It's a DONUT HUT!!
-YOW!! What should the entire human race DO?? Consume a fifth of CHIVAS REGAL, ski NUDE down MT. EVEREST, and have a wild SEX WEEKEND!
-YOW!!! I am having fun!!!
-Zippy's brain cells are straining to bridge synapses ...
+++ /dev/null
-# This program is copyright Jonathan Feinberg 1999.
-# This program is distributed under the same terms as infobot.
-
-# Jonathan Feinberg
-# jdf@pobox.com
-# http://pobox.com/~jdf/
-
-# Version 1.0
-# First public release.
-
-# hacked by Tim@Rikers.org to handle new URL and layout
-
-package babelfish;
-use strict;
-
-my $no_babelfish;
-my $url = 'http://babelfish.av.com/tr';
-
-BEGIN {
- eval "use URI::Escape"; # utility functions for encoding the
- if ($@) { $no_babelfish++}; # babelfish request
- eval "use LWP::UserAgent";
- if ($@) { $no_babelfish++};
-}
-
-BEGIN {
- # Translate some feasible abbreviations into the ones babelfish
- # expects.
- use vars qw!%lang_code $lang_regex!;
- %lang_code = (
- 'de' => 'de',
- 'ge' => 'de',
- 'gr' => 'el',
- 'el' => 'el',
- 'sp' => 'es',
- 'es' => 'es',
- 'en' => 'en',
- 'fr' => 'fr',
- 'it' => 'it',
- 'ja' => 'ja',
- 'jp' => 'ja',
- 'ko' => 'ko',
- 'kr' => 'ko',
- 'nl' => 'nl',
- 'po' => 'pt',
- 'pt' => 'pt',
- 'ru' => 'ru',
- 'zh' => 'zh',
- 'zt' => 'zt'
- );
-
- # Here's how we recognize the language you're asking for. It looks
- # like RTSL saves you a few keystrokes in #perl, huh?
- $lang_regex = join '|', keys %lang_code;
-}
-
-sub babelfishParam {
- return '' if $no_babelfish;
- my ($from, $to, $phrase) = @_;
- &::DEBUG("babelfish($from, $to, $phrase)");
-
- $from = $lang_code{$from};
- $to = $lang_code{$to};
-
- my $ua = new LWP::UserAgent;
- $ua->proxy('http', $::param{'httpProxy'}) if (&::IsParam('httpProxy'));
- # Let's pretend
- $ua->agent("Mozilla/5.0 " . $ua->agent);
- $ua->timeout(5);
-
- my $req = HTTP::Request->new('POST', $url);
-
-# babelfish ignored this, but it SHOULD work
-# Accept-Charset: iso-8859-1
-# $req->header('Accept-Charset' => 'iso-8859-1');
-# print $req->header('Accept-Charset');
- $req->header('Accept-Language' => 'en');
- $req->content_type('application/x-www-form-urlencoded');
-
- return translate($phrase, "${from}_${to}", $req, $ua);
-}
-
-sub translate {
- return '' if $no_babelfish;
- my ($phrase, $languagepair, $req, $ua) = @_;
- &::DEBUG("translate($phrase, $languagepair, $req, $ua)");
-
- my $trtext = uri_escape($phrase);
- $req->content("trtext=$trtext&lp=$languagepair");
- &::DEBUG("$url??trtext=$trtext&lp=$languagepair");
-
- my $res = $ua->request($req);
- my $translated;
-
- if ($res->is_success) {
- my $html = $res->content;
- # This method subject to change with the whims of Altavista's design
- # staff.
- ($translated) = $html;
-
- $translated =~ s/<[^>]*>//sg;
- $translated =~ s/ / /sg;
- $translated =~ s/\s+/ /sg;
- #&::DEBUG("$translated\n===remove <attributes>\n");
-
- $translated =~ s/\s*Translate again.*//i;
- &::DEBUG("$translated\n===remove after 'Translate again'\n");
-
- $translated =~ s/[^:]*?:\s*(Help\s*)?//s;
- &::DEBUG("len=" . length($translated) . " $translated\n===remove to first ':', optional Help\n");
-
- $translated =~ s/\n/ /g;
- # FIXME: should we do unicode->iso (no. use utf8!)
- } else {
- $translated = ":("; # failure
- }
- $translated = "babelfish.pl: result too long, probably an error" if (length($translated) > 700);
-
- return $translated
-}
-
-sub babelfish {
- my ($message) = @_;
- my $babel_lang_regex = "de|ge|gr|el|sp|es|en|fr|it|ja|jp|ko|kr|nl|po|pt|ru|zh|zt";
- if ($message =~ m{
- ($babel_lang_regex)\w* # from language?
- \s+
- ($babel_lang_regex)\w* # to language?
- \s*
- (.+) # The phrase to be translated
- }xoi) {
- &::performStrictReply(&babelfishParam(lc $1, lc $2, lc $3));
- }
- return;
-}
-
-if (0) {
- if (-t STDIN) {
- #my $result = babelfish::babelfish('en sp hello world');
- #my $result = babelfish::babelfish('en sp The cheese is old and moldy, where is the bathroom?');
- my $result = babelfish::babelfish('en gr doesn\'t seem to translate things longer than 40 characters');
- $result =~ s/; /\n/g;
- print "Babelfish says: \"$result\"\n";
- }
-}
-
-1;
+++ /dev/null
-#
-# botmail.pl: Botmail (ala in infobot)
-# Author: dms
-# Version: v0.1 (20021122).
-# Created: 20021122
-# NOTE: Motivated by TimRiker.
-# TODO: full-fledged notes services (optional auth, etc)
-#
-
-package botmail;
-
-use strict;
-
-sub parse {
- my($what) = @_;
-
- if (!defined $what or $what =~ /^\s*$/) {
- &::help('botmail');
- return;
- }
-
- if ($what =~ /^(to|for|add)\s+(.*)$/i) {
- &add( split(/\s+/, $2, 2) );
-
- } elsif ($what =~ /^stats?$/i) {
- &stats();
-
- } elsif ($what =~ /^check?$/i) {
- &check( $1, 1);
-
- } elsif ($what =~ /^(read|next)$/i) {
- # TODO: read specific items? nah, will make this too complex.
- &next($::who);
-
- }
-}
-
-sub stats {
- my $botmail = &::countKeys('botmail');
- &::msg($::who, "I have \002$botmail\002 ". &::fixPlural('message', $botmail). ".");
-}
-
-#####
-# Usage: botmail::check($recipient, [$always])
-sub check {
- my($recipient, $always) = @_;
- $recipient ||= $::who;
-
- my %from = &::sqlSelectColHash('botmail', "srcwho,time", {
- dstwho => lc $recipient
- } );
- my $t = keys %from;
- my $from = join(", ", keys %from);
-
- if ($t == 0) {
- &::msg($recipient, "You have no botmail.") if ($always);
- } else {
- &::msg($recipient, "You have $t messages awaiting, from: $from (botmail read)");
- }
-}
-
-#####
-# Usage: botmail::next($recipient)
-sub next {
- my($recipient) = @_;
-
- my %hash = &::sqlSelectRowHash('botmail', '*', {
- dstwho => lc $recipient
- } );
-
- if (scalar (keys %hash) <= 1) {
- &::msg($recipient, "You have no botmail.");
- } else {
- my $date = scalar(gmtime $hash{'time'});
- my $ago = &::Time2String(time() - $hash{'time'});
- &::msg($recipient, "From $hash{srcwho} ($hash{srcuh}) on $date ($ago ago):");
- &::msg($recipient, $hash{'msg'});
- &::sqlDelete('botmail', { 'dstwho'=>$hash{dstwho}, 'srcwho'=>$hash{srcwho}});
- }
-}
-
-#####
-# Usage: botmail::add($recipient, $msg)
-sub add {
- my($recipient, $msg) = @_;
- &::DEBUG("botmail::add(@_)");
-
- # allow optional trailing : ie: botmail for foo[:] hello
- $recipient =~ s/:$//;
-
- # only support 1 botmail with unique dstwho/srcwho to have same
- # functionality as botmail from infobot.
- # Note: I removed the &::sqlQuote reference. Seems to be working and inserting fine without it here. -- troubled
- my %hash = &::sqlSelectRowHash('botmail', '*', {
- srcwho => lc $::who,
- dstwho => lc $recipient
- } );
-
- if (scalar (keys %hash) > 1) {
- &::msg($::who, "$recipient already has a message queued from you");
- return;
- }
-
- &::sqlInsert('botmail', {
- 'dstwho' => lc $recipient,
- 'srcwho' => lc $::who,
- 'srcuh' => $::nuh,
- 'time' => time(),
- 'msg' => $msg,
- } );
-
- &::msg($::who, "OK, $::who, I'll let $recipient know.");
-}
-
-1;
+++ /dev/null
-# case.pl: upper/lower a string
-# Author: Tim Riker
-# Licensing: Artistic License
-# Version: v0.1
-#
-use strict;
-
-package case;
-
-sub upper {
- my($message) = @_;
- # make it green like an old terminal
- &::performStrictReply("\00303" . uc $message);
-}
-
-sub lower {
- my($message) = @_;
- &::performStrictReply(lc $message);
-}
-
-1;
+++ /dev/null
-#
-# countdown.pl: Count down to a particular date.
-# Author: dms
-# Version: v0.1 (20000104)
-# Created: 20000104
-#
-
-use strict;
-
-#use vars qw();
-
-sub countdown {
- my ($query) = @_;
- my $file = "$bot_base_dir/$param{'ircUser'}.countdown";
- my (%date, %desc);
- my $reply;
-
- if (!open(IN,$file)) {
- &ERROR("cannot open $file.");
- return 0;
- }
-
- while (<IN>) {
- chop;
- s/[\s\t]+/ /g;
-
- if (/^(\d{8}) (\S+) (.*)$/) {
- $date{$2} = $1;
- $desc{$2} = $3;
- }
- }
- close IN;
-
- if (defined $query) { # argument.
- if (!exists $date{$query}) {
- &msg($who,"error: $query is not in my countdown list.");
- return 0;
- }
-
- $date{$query} =~ /^(\d{4})(\d{2})(\d{2})$/;
- my($year,$month,$day) = ($1,$2,$3);
- my $sqldate = "$1-$2-$3";
-
- ### SQL SPECIFIC.
- my ($to_days,$dayname,$monname);
-
- if ($param{'DBType'} =~ /^(mysql|sqlite(2)?)$/i) {
- $to_days = (&sqlRawReturn("SELECT TO_DAYS(NOW()) - TO_DAYS('$sqldate')"))[0];
- $dayname = (&sqlRawReturn("SELECT DAYNAME('$sqldate')"))[0];
- $monname = (&sqlRawReturn("SELECT MONTHNAME('$sqldate')"))[0];
-
- } elsif ($param{'DBType'} =~ /^pgsql$/i) {
- $to_days = (&sqlRawReturn("SELECT date_trunc('day',
- 'now'::timestamp - '$sqldate')"))[0];
- $dayname = qw(Sun Mon Tue Wed Thu Fri Sat)[(&sqlRawReturn("SELECT extract(dow from timestamp '$sqldate')"))[0]];
- $monname = qw(BAD Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec)[(&sqlRawReturn("SELECT extract(month from timestamp '$sqldate')"))[0]];
-
- } else {
- &ERROR("countdown: invalid DBType " . $param{'DBType'} . ".");
- return 1;
- }
-
- if ($to_days =~ /^\D+$/) {
- my $str = "to_days is not integer.";
- &msg($who,$str);
- &ERROR($str);
-
- return 1;
- }
-
- my @gmtime = gmtime(time());
- my $daysec = ($gmtime[2]*60*60) + ($gmtime[1]*60) + ($gmtime[0]);
- my $time = ($to_days*24*60*60);
-
- if ($to_days >= 0) { # already passed.
- $time += $daysec;
- $reply = "T plus ". &Time2String($time) ." ago";
- } else { # time to go.
- $time = -$time - $daysec;
- $reply = "T minus ". &Time2String($time);
- }
- $reply .= ", \002(\002$desc{$query}\002)\002 at $dayname, $monname $day $year";
-
- &performStrictReply($reply .".");
- return 1;
- } else { # no argument.
- my $prefix = "countdown list ";
-
- &performStrictReply( &formListReply(0, $prefix, sort keys %date) );
-
- return 1;
- }
-}
-
-1;
+++ /dev/null
-#!/usr/bin/perl
-
-# dice rolling
-# hacked up by Tim Riker <Tim@Rikers.org> from Games::Dice
-
-package dice;
-
-use strict;
-use warnings;
-
-sub dice::roll_array ($) {
- my($line) = shift;
-
- my(@throws) = ();
- return @throws unless $line =~ m{
- ^ # beginning of line
- (\d+)? # optional count in $1
- [dD] # 'd' for dice
- ( # type of dice in $2:
- \d+ # either one or more digits
- | # or
- % # a percent sign for d% = d100
- )
- }x; # whitespace allowed
-
- my($num) = $1 || 1;
- my($type) = $2;
-
- return @throws if $num > 100;
- $type = 100 if $type eq '%';
- return @throws if $type < 2;
-
- for( 1 .. $num ) {
- push @throws, int (rand $type) + 1;
- }
-
- return @throws;
-}
-
-sub dice::roll ($) {
- my($line) = shift;
-
- $line =~ s/ //g;
-
- return '' unless $line =~ m{
- ^ # beginning of line
- ( # dice string in $1
- (?:\d+)? # optional count
- [dD] # 'd' for dice
- (?: # type of dice:
- \d+ # either one or more digits
- | # or
- % # a percent sign for d% = d100
- )
- )
- (?: # grouping-only parens
- ([-+xX*/bB]) # a + - * / b(est) in $2
- (\d+) # an offset in $3
- )? # both of those last are optional
- }x; # whitespace allowed in re
-
- my($dice_string) = $1;
- my($sign) = $2 || '';
- my($offset) = $3 || 0;
-
- $sign = lc $sign;
-
- my(@throws) = roll_array( $dice_string );
- return '' unless @throws > 0;
- my($retval) = "rolled " . join(',', @throws);
-
- my(@result);
- if( $sign eq 'b' ) {
- $offset = 0 if $offset < 0;
- $offset = @throws if $offset > @throws;
-
- @throws = sort { $b <=> $a } @throws; # sort numerically, descending
- @result = @throws[ 0 .. $offset-1 ]; # pick off the $offset first ones
- $retval .= " best $offset";
- } else {
- @result = @throws;
- $retval .= " $sign $offset" if $sign;
- }
-
- my($sum) = 0;
- $sum += $_ foreach @result;
- $sum += $offset if $sign eq '+';
- $sum -= $offset if $sign eq '-';
- $sum *= $offset if ($sign eq '*' || $sign eq 'x');
- do { $sum /= $offset; $sum = int $sum; } if $sign eq '/';
-
- return "$retval = $sum";
-}
-
-sub dice::dice {
- my ($message) = @_;
- srand(); # fork seems to not change rand. force it here
- my $retval = roll($message);
-
- &::performStrictReply($retval);
-}
-
-#print "(q)uit or die combination, ex. 4d10/4\n";
-#while (my $dice = <STDIN>) {
-# chomp $dice;
-# if (! $dice || $dice =~ m/^q(?:uit)*$/i) {
-# print "done\n";
-# exit;
-# } else {
-# print roll($dice) . "\n";
-# }
-#}
-
-1;
-
-__END__
-
-=pod
-
-=head1 NAME
-
-dice.pl - simulate die rolls
-
-=head1 SYNOPSIS
-
- 'dice 3d6+1';
-
-=head1 DESCRIPTION
-
-The number and type of dice to roll is given in a style which should be
-familiar to players of popular role-playing games: I<a>dI<b>[+-*/b]I<c>.
-I<a> is optional and defaults to 1; it gives the number of dice to roll.
-I<b> indicates the number of sides to each die; the most common,
-cube-shaped die is thus a d6. % can be used instead of 100 for I<b>;
-hence, rolling 2d% and 2d100 is equivalent. C<roll> simulates I<a> rolls
-of I<b>-sided dice and adds together the results. The optional end,
-consisting of one of +-*/b and a number I<c>, can modify the sum of the
-individual dice. +-*/ are similar in that they take the sum of the rolls
-and add or subtract I<c>, or multiply or divide the sum by I<c>. (x can
-also be used instead of *.) Hence, 1d6+2 gives a number in the range
-3..8, and 2d4*10 gives a number in the range 20..80. (Using / truncates
-the result to an int after dividing.) Using b in this slot is a little
-different: it's short for "best" and indicates "roll a number of dice,
-but add together only the best few". For example, 5d6b3 rolls five six-
-sided dice and adds together the three best rolls. This is sometimes
-used, for example, in roll-playing to give higher averages.
-
-=head1 AUTHOR
-
-Philip Newton, <pne@cpan.org>
-
-Tim Riker <Tim@Rikers.org>
-
-=head1 LICENCE
-
-Copyright (C) 1999, 2002 Philip Newton - All rights reserved.
-
-Copyright (C) 2005 Tim Riker - All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions
-are met:
-
-=over 4
-
-=item *
-
-Redistributions of source code must retain the above copyright notice,
-this list of conditions and the following disclaimer.
-
-=item *
-
-Redistributions in binary form must reproduce the above copyright notice,
-this list of conditions and the following disclaimer in the
-documentation and/or other materials provided with the distribution.
-
-=back
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND
-CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
-INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
-MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE
-LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
-CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
-ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
-OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-POSSIBILITY OF SUCH DAMAGE.
-
-=cut
+++ /dev/null
-#
-# dns.pl: host lookups
-# Author: Tim Riker <Tim@Rikers.org>
-# Source: extracted from UserExtra.pl
-# Licensing: Artistic License (as perl itself)
-# Version: v0.1
-#
-# Copyright (c) 2005 Tim Riker
-#
-
-package dns;
-
-use strict;
-
-sub dns::dns {
- my $dns = shift;
- my($match, $x, $y, $result, $pid);
-
- if ($dns =~ /(\d+\.\d+\.\d+\.\d+)/) {
- use Socket;
-
- &::status("DNS query by IP address: $dns");
-
- $y = pack('C4', split(/\./, $dns));
- $x = (gethostbyaddr($y, &AF_INET));
-
- if ($x !~ /^\s*$/) {
- $result = "$dns is $x" unless ($x =~ /^\s*$/);
- } else {
- $result = "I can't find the address $dns in DNS";
- }
-
- } else {
-
- &::status("DNS query by name: $dns");
- $x = join('.',unpack('C4',(gethostbyname($dns))[4]));
-
- if ($x !~ /^\s*$/) {
- $result = "$dns is $x";
- } else {
- $result = "I can't find $dns in DNS";
- }
- }
-
- return($result);
-}
-
-sub dns::query {
- &::performStrictReply(&dns(@_));
- return;
-}
-
-1;
-# vim: ts=2 sw=2
+++ /dev/null
-#
-# insult.pl: insult engine
-#
-# 2004.10.21 Tim Riker <Tim@Rikers.org>
-# colorado server is dead. pull in the words and do it ourself
-#
-
-package Insult;
-
-use strict;
-
-sub Insult {
- my ($insultwho) = @_;
- my @adjs;
- my @amts;
- my @nouns;
- &::DEBUG('Reading insult data');
- while (<DATA>) {
- chomp;
- push(@adjs, split(' ', $1)) if /^adj\s*(.*)/;
- push(@amts, split(' ', $1)) if /^amt\s*(.*)/;
- push(@nouns, split(' ', $1)) if /^noun\s*(.*)/;
- }
- grep(s/\|/ /g, @adjs);
- grep(s/\|/ /g, @amts);
- grep(s/\|/ /g, @nouns);
- srand(); # fork seems to not change rand. force it here
- my $adj = @adjs[rand(@adjs)];
- my $n;
- $n = 'n' if $adj =~ /^[aeiouih]/;
- my $amt = @amts[rand(@amts)];
- my $adj2 = @adjs[rand(@adjs)];
- my $noun = @nouns[rand(@nouns)];
- my $whois = "$insultwho is";
- $whois = 'You are' if ($insultwho eq $::who or $insultwho eq 'me');
-
- &::performStrictReply("$whois nothing but a$n $adj $amt of $adj2 $noun");
-}
-
-1;
-
-__DATA__
-#
-# configuration file for colorado insult server
-#
-# Use the '|' character to include a space in the middle of a noun, adjective
-# or amount (it'll get transmogrified into a space. No, really!).
-#
-# Mon Mar 16 10:49:53 MST 1992 garnett added more colorful insults
-# Fri Dec 6 10:48:43 MST 1991 garnett
-#
-
-##
-# Adjectives
-##
-adj acidic antique contemptible culturally-unsound despicable evil fermented
-adj festering foul fulminating humid impure inept inferior industrial
-adj left-over low-quality malodorous off-color penguin-molesting
-adj petrified pointy-nosed salty sausage-snorfling tastless tempestuous
-adj tepid tofu-nibbling unintelligent unoriginal uninspiring weasel-smelling
-adj wretched spam-sucking egg-sucking decayed halfbaked infected squishy
-adj porous pickled coughed-up thick vapid hacked-up
-adj unmuzzled bawdy vain lumpish churlish fobbing rank craven puking
-adj jarring fly-bitten pox-marked fen-sucked spongy droning gleeking warped
-adj currish milk-livered surly mammering ill-borne beef-witted tickle-brained
-adj half-faced headless wayward rump-fed onion-eyed beslubbering villainous
-adj lewd-minded cockered full-gorged rude-snouted crook-pated pribbling
-adj dread-bolted fool-born puny fawning sheep-biting dankish goatish
-adj weather-bitten knotty-pated malt-wormy saucyspleened motley-mind
-adj it-fowling vassal-willed loggerheaded clapper-clawed frothy ruttish
-adj clouted common-kissing pignutted folly-fallen plume-plucked flap-mouthed
-adj swag-bellied dizzy-eyed gorbellied weedy reeky measled spur-galled mangled
-adj impertinent bootless toad-spotted hasty-witted horn-beat yeasty
-adj imp-bladdereddle-headed boil-brained tottering hedge-born hugger-muggered
-adj elf-skinned
-
-##
-# Amounts
-##
-amt accumulation bucket coagulation enema-bucketful gob half-mouthful
-amt heap mass mound petrification pile puddle stack thimbleful tongueful
-amt ooze quart bag plate ass-full assload
-
-##
-# Objects
-##
-noun bat|toenails bug|spit cat|hair chicken|piss dog|vomit dung
-noun fat-woman's|stomach-bile fish|heads guano gunk pond|scum rat|retch
-noun red|dye|number-9 Sun|IPC|manuals waffle-house|grits yoo-hoo
-noun dog|balls seagull|puke cat|bladders pus urine|samples
-noun squirrel|guts snake|assholes snake|bait buzzard|gizzards
-noun cat-hair-balls rat-farts pods armadillo|snouts entrails
-noun snake|snot eel|ooze slurpee-backwash toxic|waste Stimpy-drool
-noun poopy poop craptacular|carpet|droppings jizzum cold|sores anal|warts
+++ /dev/null
-# md5.pl: md5 a string
-# Author: Tim Riker
-# Licensing: Artistic License
-# Version: v0.1 (20041209)
-#
-use strict;
-
-package md5;
-
-sub md5 {
- my($message) = @_;
- return unless &::loadPerlModule('Digest::MD5');
-
- &::performStrictReply(&Digest::MD5::md5_hex($message));
-}
-
-1;
+++ /dev/null
-#
-# Lame-o-Nickometer backend
-#
-# (c) 1998 Adam Spiers <adam.spiers@new.ox.ac.uk>
-#
-# You may do whatever you want with this code, but give me credit.
-#
-# $Id$
-#
-
-package nickometer;
-
-use strict;
-
-my $pi = 3.14159265;
-my $score = 0;
-my $verbose = 0;
-
-sub query {
- my ($message) = @_;
-
- my $term = (lc $message eq 'me') ? $::who : $message;
-
- if ($term =~ /^$::mask{chan}$/) {
- &::status("Doing nickometer for chan $term.");
-
- if (!&::validChan($term)) {
- &::msg($::who, "error: channel is invalid.");
- return;
- }
-
- # step 1.
- my %nickometer;
- foreach (keys %{ $::channels{lc $term}{''} }) {
- my $str = $_;
- if (!defined $str) {
- &WARN("nickometer: nick in chan $term undefined?");
- next;
- }
-
- my $value = &nickometer($str);
- $nickometer{$value}{$str} = 1;
- }
-
- # step 2.
- ### TODO: compact with map?
- my @list;
- foreach (sort {$b <=> $a} keys %nickometer) {
- my $str = join(', ', sort keys %{ $nickometer{$_} });
- push(@list, "$str ($_%)");
- }
-
- &::performStrictReply( &::formListReply(0, "Nickometer list for $term ", @list) );
-
- return;
- }
-
- my $percentage = &nickometer($term);
-
- if ($percentage =~ /NaN/) {
- $percentage = 'off the scale';
- } else {
- $percentage = sprintf("%0.4f", $percentage);
- $percentage =~ s/(\.\d+)0+$/$1/;
- $percentage .= '%';
- }
-
- if ($::msgType eq 'public') {
- &::say("'$term' is $percentage lame, $::who");
- } else {
- &::msg($::who, "the 'lame nick-o-meter' reading for $term is $percentage, $::who");
- }
-
- return;
-}
-
-sub nickometer ($) {
- my ($text) = @_;
- $score = 0;
-
-# return unless &loadPerlModule("Getopt::Std");
- return unless &::loadPerlModule("Math::Trig");
-
- if (!defined $text) {
- &::DEBUG("nickometer: arg == NULL. $text");
- return;
- }
-
- # Deal with special cases (precede with \ to prevent de-k3wlt0k)
- my %special_cost = (
- '69' => 500,
- 'dea?th' => 500,
- 'dark' => 400,
- 'n[i1]ght' => 300,
- 'n[i1]te' => 500,
- 'fuck' => 500,
- 'sh[i1]t' => 500,
- 'coo[l1]' => 500,
- 'kew[l1]' => 500,
- 'lame' => 500,
- 'dood' => 500,
- 'dude' => 500,
- '[l1](oo?|u)[sz]er' => 500,
- '[l1]eet' => 500,
- 'e[l1]ite' => 500,
- '[l1]ord' => 500,
- 'pron' => 1000,
- 'warez' => 1000,
- 'xx' => 100,
- '\[rkx]0' => 1000,
- '\0[rkx]' => 1000,
- );
-
- foreach my $special (keys %special_cost) {
- my $special_pattern = $special;
- my $raw = ($special_pattern =~ s/^\\//);
- my $nick = $text;
- unless (defined $raw) {
- $nick =~ tr/023457+8/ozeasttb/;
- }
- &punish($special_cost{$special}, "matched special case /$special_pattern/")
- if (defined $nick and $nick =~ /$special_pattern/i);
- }
-
- # Allow Perl referencing
- $text =~ s/^\\([A-Za-z])/$1/;
-
- # C-- ain't so bad either
- $text =~ s/^C--$/C/;
-
- # Punish consecutive non-alphas
- $text =~ s/([^A-Za-z0-9]{2,})
- /my $consecutive = length($1);
- &punish(&slow_pow(10, $consecutive),
- "$consecutive total consecutive non-alphas")
- if $consecutive;
- $1
- /egx;
-
- # Remove balanced brackets (and punish a little bit) and punish for unmatched
- while ($text =~ s/^([^()]*) (\() (.*) (\)) ([^()]*) $/$1$3$5/x ||
- $text =~ s/^([^{}]*) (\{) (.*) (\}) ([^{}]*) $/$1$3$5/x ||
- $text =~ s/^([^\[\]]*) (\[) (.*) (\]) ([^\[\]]*) $/$1$3$5/x)
- {
- print "Removed $2$4 outside parentheses; nick now $_\n" if $verbose;
- &punish(15, 'brackets');
- }
- my $parentheses = $text =~ tr/(){}[]/(){}[]/;
- &punish(&slow_pow(10, $parentheses),
- "$parentheses unmatched " .
- ($parentheses == 1 ? 'parenthesis' : 'parentheses'))
- if $parentheses;
-
- # Punish k3wlt0k
- my @k3wlt0k_weights = (5, 5, 2, 5, 2, 3, 1, 2, 2, 2);
- for my $digit (0 .. 9) {
- my $occurrences = $text =~ s/$digit/$digit/g || 0;
- &punish($k3wlt0k_weights[$digit] * $occurrences * 30,
- $occurrences . ' ' .
- (($occurrences == 1) ? 'occurrence' : 'occurrences') .
- " of $digit")
- if $occurrences;
- }
-
- # An alpha caps is not lame in middle or at end, provided the first
- # alpha is caps.
- my $orig_case = $text;
- $text =~ s/^([^A-Za-z]*[A-Z].*[a-z].*?)[_-]?([A-Z])/$1\l$2/;
-
- # A caps first alpha is sometimes not lame
- $text =~ s/^([^A-Za-z]*)([A-Z])([a-z])/$1\l$2$3/;
-
- # Punish uppercase to lowercase shifts and vice-versa, modulo
- # exceptions above
- my $case_shifts = &case_shifts($orig_case);
- &punish(&slow_pow(9, $case_shifts),
- $case_shifts . ' case ' .
- (($case_shifts == 1) ? 'shift' : 'shifts'))
- if ($case_shifts > 1 && /[A-Z]/);
-
- # Punish lame endings (TorgoX, WraithX et al. might kill me for this :-)
- &punish(50, 'last alpha lame') if $orig_case =~ /[XZ][^a-zA-Z]*$/;
-
- # Punish letter to numeric shifts and vice-versa
- my $number_shifts = &number_shifts($_);
- &punish(&slow_pow(9, $number_shifts),
- $number_shifts . ' letter/number ' .
- (($number_shifts == 1) ? 'shift' : 'shifts'))
- if $number_shifts > 1;
-
- # Punish extraneous caps
- my $caps = $text =~ tr/A-Z/A-Z/;
- &punish(&slow_pow(7, $caps), "$caps extraneous caps") if $caps;
-
- # One and only one trailing underscore is OK.
- $text =~ s/\_$//;
-
- # Now punish anything that's left
- my $remains = $text;
- $remains =~ tr/a-zA-Z0-9//d;
- my $remains_length = length($remains);
-
- &punish(50 * $remains_length + &slow_pow(9, $remains_length),
- $remains_length . ' extraneous ' .
- (($remains_length == 1) ? 'symbol' : 'symbols'))
- if $remains;
-
- print "\nRaw lameness score is $score\n" if $verbose;
-
- # Use an appropriate function to map [0, +inf) to [0, 100)
- my $percentage = 100 *
- (1 + &Math::Trig::tanh(($score-400)/400)) *
- (1 - 1/(1+$score/5)) / 2;
-
- my $digits = 2 * (2 - &round_up(log(100 - $percentage) / log(10)));
-
- return sprintf "%.${digits}f", $percentage;
-}
-
-sub case_shifts ($) {
- # This is a neat trick suggested by freeside. Thanks freeside!
-
- my $shifts = shift;
-
- $shifts =~ tr/A-Za-z//cd;
- $shifts =~ tr/A-Z/U/s;
- $shifts =~ tr/a-z/l/s;
-
- return length($shifts) - 1;
-}
-
-sub number_shifts ($) {
- my $shifts = shift;
-
- $shifts =~ tr/A-Za-z0-9//cd;
- $shifts =~ tr/A-Za-z/l/s;
- $shifts =~ tr/0-9/n/s;
-
- return length($shifts) - 1;
-}
-
-sub slow_pow ($$) {
- my ($x, $y) = @_;
-
- return $x ** &slow_exponent($y);
-}
-
-sub slow_exponent ($) {
- my $x = shift;
-
- return 1.3 * $x * (1 - &Math::Trig::atan($x/6) *2/$pi);
-}
-
-sub round_up ($) {
- my $float = shift;
-
- return int($float) + ((int($float) == $float) ? 0 : 1);
-}
-
-sub punish ($$) {
- my ($damage, $reason) = @_;
-
- return unless $damage;
-
- $score += $damage;
- print "$damage lameness points awarded: $reason\n" if $verbose;
-}
-
-1;
+++ /dev/null
-# Pager
-#
-# modified from pager.pm in flooterbuck changes are:
-#
-# Copyright (c) 2004 Tim Riker <Tim@Rikers.org>
-#
-# This package is free software; you can redistribute it and/or
-# modify it under the terms of the license found in the file
-# named LICENSE that should have accompanied this file.
-#
-# THIS PACKAGE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-# WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-
-package pager;
-use strict;
-
-my $no_page;
-
-BEGIN {
- eval qq{
- use Mail::Mailer qw(sendmail);
- };
- $no_page++ if ($@);
-}
-
-sub pager::page {
- my ($message) = @_;
- my ($retval);
-
- # TODO only allow registered users?
-
- if ($no_page) {
- &::status('page module requires Mail::Mailer.');
- return 'page module not active';
- }
-
- unless ($message =~ /^(\S+)\s+(.*)$/) {
- return undef;
- }
-
- my $from = $::who;
- my $to = $1;
- my $msg = $2;
-
- # allow optional trailing : ie: page foo[:] hello
- $to =~ s/:$//;
-
- my $tofactoid = &::getFactoid(lc "${to}'s pager");
- if ($tofactoid =~ /(\S+@\S+)/) {
- my $toaddr = $1;
- $toaddr =~ s/^mailto://;
- # TODO require sender-locked factoid?
-
- my $fromfactoid = &::getFactoid(lc "${from}'s pager");
-
- my $fromaddr;
- if ($fromfactoid =~ /(\S+@\S+)/) {
- $fromaddr = $1;
- $fromaddr =~ s/^mailto://;
- } else {
- # TODO require sender to have valid self-locked pager factoid?
- $fromaddr = 'infobot@example.com';
- }
-
- my $channel = $::chan || 'infobot';
- # TODO disallow use from private message? $chan='_default'
-
- &::status("pager: from $from <$fromaddr>, to $to <$toaddr>, msg \"$msg\"");
- my %headers = (
- To => "$to <$toaddr>",
- From => "$from <$fromaddr>",
- Subject => "Message from $channel!",
- 'X-Mailer' => 'blootbot',
- );
-
-# my $logmsg;
-# for (keys %headers) {
-# $logmsg .= "$_: $headers{$_}\n";
-# }
-# $logmsg .= "\n$msg\n";
-# &::status("pager:\n$logmsg");
-
- my $failed;
- my $mailer = new Mail::Mailer 'sendmail';
- $failed++ unless $mailer->open(\%headers);
- $failed++ unless print $mailer "$msg\n";
- $failed++ unless $mailer->close;
-
- if ($failed) {
- $retval='Sorry, an error occurred while sending mail.';
- } else {
- $retval="$from: I sent mail to $toaddr from $fromaddr.";
- }
- } else {
- $retval="Sorry, I don't know ${to}'s email address.";
- }
- &::performStrictReply($retval);
-}
-
-'pager';
-# vim: ts=2 sw=2
+++ /dev/null
-# turns english text into piglatin
-# Copyright (c) 2005 Tim Riker <Tim@Rikers.org>
-
-use strict;
-use warnings;
-
-package piglatin;
-
-sub piglatin
-{
- my ($text) = @_;
- my $piglatin;
- my $suffix = 'ay';
-
- # FIXME: does not handle:
- # non-trailing punctuation and hyphens
- # y as vowel 'style' -> 'ylestay'
- # contractions
- for my $word (split /\s+/, $text) {
- my ($pigword, $postfix);
- #($word,$postfix) = $word =~ s/^([a-z]*)([,.!\?;:'"])?$//i;
- if ($word =~ s/([,.!\?;:'"])$//i) {
- $postfix = $1;
- }
- if ($word =~ /^(qu)(.*)/ ) {
- $pigword = "$2$1$suffix";
- } elsif ($word =~ /^(Qu)(.)(.*)/ ) {
- $pigword = uc($2) . $3 . lc($1) . $suffix;
- } elsif ($word =~ /^([bcdfghjklmnpqrstvwxyz]+)(.*)/ ) {
- $pigword = "$2$1$suffix";
- } elsif ($word =~ /^([BCDFGHJKLMNPQRSTVWXYZ])([bcdfghjklmnpqrstvwxyz]*)([aeiouy])(.*)/ ) {
- $pigword = uc($3) . $4 . lc($1) . $2 . $suffix;
- } else {
- $pigword = $word . 'w' . $suffix;
- }
- $piglatin .= ' ' if $piglatin;
- $piglatin .= $pigword . $postfix;
- }
- &::performStrictReply($piglatin||'failed');
-}
-
-1;
+++ /dev/null
-# reverse.pl: reverse a string
-# Author: Tim Riker
-# Licensing: Artistic License
-# Version: v0.1 (20050812)
-#
-use strict;
-
-package reverse;
-
-sub reverse {
- my($message) = @_;
- &::performStrictReply(join('',reverse(split('',$message))));
-}
-
-1;
+++ /dev/null
-# Copyright (c) 2003 Chris Angell (chris62vw@hotmail.com). All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-# Turns this:
-# Mary had a little lamb and her fleece was white as snow
-# into this:
-# Mray had a liltte lmab and her flecee was whtie as sonw
-
-use strict;
-use warnings;
-
-package scramble;
-
-sub scramble
-{
- my ($text) = @_;
- my $scrambled;
-
- return unless &::loadPerlModule("List::Util");
- srand(); # fork seems to not change rand. force it here
- for my $orig_word (split /\s+/, $text)
- {
- # skip words that are less than four characters in length
- $scrambled .= "$orig_word " and next if length($orig_word) < 4;
-
- # get first and last characters, and middle characters
- # optional characters are for punctuation, etc.
- my ($first, $middle, $last) = $orig_word =~ /^['"]?(.)(.+)'?(.)[,.!?;:'"]?$/;
-
- my ($new_middle, $cnt);
-
- # shuffle until $new_middle is different from $middle
- do
- {
- # theoretically, this loop could loop forever, so
- # a counter is used. once $cnt > 10 then use a
- # simple regex to scramble and call it good
-
- if (++$cnt > 10)
- {
- # non-random shuffle, but good enough
- ($new_middle = $middle) =~ s/(.)(.)/$2$1/g;
- }
-
- # shuffle the middle letters
- $new_middle = join '', List::Util::shuffle(split //, $middle);
- }
- while (($cnt < 10) && ($middle eq $new_middle));
-
- # add the word to the list...
- $scrambled .= "$first$new_middle$last ";
- }
-
- # remove the single trailing space, and any other space that may have
- # been included in the original string
- $scrambled =~ s/\s+$//;
-
- &::performStrictReply($scrambled||'Unknown Error Condition');
-}
-
-1;
+++ /dev/null
-#
-# Slashdot.pl: Slashdot headline retrival
-# Author: Chris Tessone <tessone@imsa.edu>
-# Modified: dms
-# Licensing: Artistic License (as perl itself)
-# Version: v0.4 (19991125)
-#
-
-###
-# fixed up to use XML'd /. backdoor 7/31 by richardh@rahga.com
-# My only request if this gets included in infobot is that the
-# other header gets trimmed to 2 lines, dump the fluff ;) -rah
-#
-# added a status message so people know to install LWP - oznoid
-# also simplified the return code because it wasn't working.
-###
-
-package Slashdot;
-
-use strict;
-
-sub slashdotParse {
- my @list;
-
- foreach (@_) {
- next unless (/<title>(.*?)<\/title>/);
- my $title = $1;
- $title =~ s/&\;/&/g;
- push(@list, $title);
- }
-
- return @list;
-}
-
-sub Slashdot {
- my @results = &::getURL("http://slashdot.org/slashdot.xml");
- my $retval = "i could not get the headlines.";
-
- if (scalar @results) {
- my $prefix = 'Slashdot Headlines ';
- my @list = &slashdotParse(@results);
- $retval = &::formListReply(0, $prefix, @list);
- }
-
- &::performStrictReply($retval);
-}
-
-sub slashdotAnnounce {
- my $file = "$::param{tempDir}/slashdot.xml";
-
- my @Cxml = &::getURL("http://slashdot.org/slashdot.xml");
- if (!scalar @Cxml) {
- &::DEBUG("sdA: failure (Cxml == NULL).");
- return;
- }
-
- if (! -e $file) { # first time run.
- open(OUT, ">$file");
- foreach (@Cxml) {
- print OUT "$_\n";
- }
- close OUT;
-
- return;
- }
-
- my @Oxml;
- open(IN, $file);
- while (<IN>) {
- chop;
- push(@Oxml,$_);
- }
- close IN;
-
- my @Chl = &slashdotParse(@Cxml);
- my @Ohl = &slashdotParse(@Oxml);
-
- my @new;
- foreach (@Chl) {
- last if ($_ eq $Ohl[0]);
- push(@new, $_);
- }
-
- if (scalar @new == 0) {
- &::status("Slashdot: no new headlines.");
- return;
- }
-
- if (scalar @new == scalar @Chl) {
- &::DEBUG("sdA: scalar(new) == scalar(Chl). bad?");
- }
-
- open(OUT,">$file");
- foreach (@Cxml) {
- print OUT "$_\n";
- }
- close OUT;
-
- return "Slashdot: News for nerds, stuff that matters -- ".
- join(" \002::\002 ", @new);
-}
-
-1;
+++ /dev/null
-#
-# spell.pl: interface to aspell/ispell/spell
-# Author: Tim Riker <Tim@Rikers.org>
-# Source: extracted from UserExtra
-# Licensing: Artistic License (as perl itself)
-# Version: v0.1
-#
-# Copyright (c) 2005 Tim Riker
-#
-
-package spell;
-
-use strict;
-
-sub spell::spell {
- my $query = shift;
- if ($query =~ m/[^[:alpha:]]/) {
- return('only one word of alphabetic characters supported');
- }
-
- my $binary;
- my @binaries = (
- '/usr/bin/aspell',
- '/usr/bin/ispell',
- '/usr/bin/spell'
- );
-
- foreach (@binaries) {
- if (-x $_) {
- $binary=$_;
- last;
- }
- }
-
- if (!$binary) {
- return('no binary found.');
- }
-
- if (!&::validExec($query)) {
- return('argument appears to be fuzzy.');
- }
-
- my $reply = "I can't find alternate spellings for '$query'";
-
- foreach (`/bin/echo '$query' | $binary -a -S`) {
- chop;
- last if !length; # end of query.
-
- if (/^\@/) { # intro line.
- next;
- } elsif (/^\*/) { # possibly correct.
- $reply = "'$query' may be spelled correctly";
- last;
- } elsif (/^\&/) { # possible correction(s).
- s/^\& (\S+) \d+ \d+: //;
- my @array = split(/,? /);
-
- $reply = "possible spellings for $query: @array";
- last;
- } elsif (/^\+/) {
- &::DEBUG("spell: '+' found => '$_'.");
- last;
- } elsif (/^# (.*?) 0$/) {
- # none found.
- last;
- } else {
- &::DEBUG("spell: unknown: '$_'.");
- }
- }
-
- return($reply);
-}
-
-sub spell::query {
- &::performStrictReply(&spell(@_));
- return;
-}
-
-1;
-# vim: ts=2 sw=2
+++ /dev/null
-# This program is distributed under the same terms as blootbot.
-
-package wikipedia;
-use strict;
-
-my $missing;
-my $wikipedia_base_url = 'http://www.wikipedia.org/wiki/';
-my $wikipedia_search_url = $wikipedia_base_url . 'Special:Search?';
-my $wikipedia_export_url = $wikipedia_base_url . 'Special:Export/';
-
-BEGIN {
- # utility functions for encoding the wikipedia request
- eval "use URI::Escape";
- if ($@) {
- $missing++;
- }
-
- eval "use LWP::UserAgent";
- if ($@) {
- $missing++;
- }
-
- eval "use HTML::Entities";
- if ($@) {
- $missing++;
- }
-}
-
-sub wikipedia {
- return '' if $missing;
- my ($phrase) = @_;
- my ($reply, $valid_result) = wikipedia_lookup(@_);
- if ($reply) {
- &::performStrictReply($reply);
- } else {
- &::performStrictReply("'$phrase' not found in Wikipedia. Perhaps try a different spelling or case?");
- }
-}
-
-sub wikipedia_silent {
- return '' if $missing;
- my ($reply, $valid_result) = wikipedia_lookup(@_);
- if ($valid_result and $reply) {
- &::performStrictReply($reply);
- }
-}
-
-sub wikipedia_lookup {
- my ($phrase) = @_;
- &::DEBUG("wikipedia($phrase)");
-
- my $ua = new LWP::UserAgent;
- $ua->proxy('http', $::param{'httpProxy'}) if (&::IsParam('httpProxy'));
- # Let's pretend
- $ua->agent("Mozilla/5.0 " . $ua->agent);
- $ua->timeout(5);
-
- # chop ? from the end
- $phrase =~ s/\?$//;
- # convert phrase to wikipedia conventions
-# $phrase = uri_escape($phrase);
-# $phrase =~ s/%20/+/g;
-# $phrase =~ s/%25/%/g;
- $phrase =~ s/ /+/g;
-
- # using the search form will make the request case-insensitive
- # HEAD will follow redirects, catching the first mode of redirects
- # that wikipedia uses
- my $url = $wikipedia_search_url . 'search=' . $phrase . '&go=Go';
- my $req = HTTP::Request->new('HEAD', $url);
- $req->header('Accept-Language' => 'en');
- &::DEBUG($url);
-
- my $res = $ua->request($req);
- &::DEBUG($res->code);
-
- if (!$res->is_success) {
- return("Wikipedia might be temporarily unavailable (".$res->code."). Please try again in a few minutes...",
- 0);
- } else {
- # we have been redirected somewhere
- # (either content or the generic Search form)
- # let's find the title of the article
- $url = $res->request->uri;
- $phrase = $url;
- $phrase =~ s/.*\/wiki\///;
-
- if (!$res->code == '200') {
- return("Wikipedia might be temporarily unavailable or something is broken (".$res->code."). Please try again later...",
- 0);
- } else {
- if ($url =~ m/Special:Search/) {
- # we were sent to the the search page
- return("I couldn't find a matching article in wikipedia, look for yerselves: " . $url,
- 0);
- } else {
- # we hit content, let's retrieve it
- my $text = wikipedia_get_text($phrase);
-
- # filtering unprintables
- $text =~ s/[[:cntrl:]]//g;
- # filtering headings
- $text =~ s/==+[^=]*=+//g;
- # filtering wikipedia tables
- $text =~ s/\{\|[^}]+\|\}//g;
- # some people cannot live without HTML tags, even in a wiki
- # $text =~ s/<div.*>//gi;
- # $text =~ s/<!--.*>//gi;
- # $text =~ s/<[^>]*>//g;
- # or HTML entities
- $text =~ s/&/&/g;
- decode_entities($text);
- # or tags, again
- $text =~ s/<[^>]*>//g;
- #$text =~ s/[&#]+[0-9a-z]+;//gi;
- # filter wikipedia tags: [[abc: def]]
- $text =~ s/\[\[[[:alpha:]]*:[^]]*\]\]//gi;
- # {{abc}}:tag
- $text =~ s/\{\{[[:alpha:]]+\}\}:[^\s]+//gi;
- # {{abc}}
- $text =~ s/\{\{[[:alpha:]]+\}\}//gi;
- # unescape quotes
- $text =~ s/'''/'/g;
- $text =~ s/''/"/g;
- # filter wikipedia links: [[tag|link]] -> link
- $text =~ s/\[\[[^]]+\|([^]]+)\]\]/$1/g;
- # [[link]] -> link
- $text =~ s/\[\[([^]]+)\]\]/$1/g;
- # shrink whitespace
- $text =~ s/[[:space:]]+/ /g;
- # chop leading whitespace
- $text =~ s/^ //g;
-
- # shorten article to first one or two sentences
- # new: we rely on the output function to know what to do
- # with long messages
- #$text = substr($text, 0, 330);
- #$text =~ s/(.+)\.([^.]*)$/$1./g;
-
- return('At ' . $url . " (URL), Wikipedia explains: " . $text,
- 1);
- }
- }
- }
-}
-
-sub wikipedia_get_text {
- return '' if $missing;
- my ($article) = @_;
- &::DEBUG("wikipedia_get_text($article)");
-
- my $ua = new LWP::UserAgent;
- $ua->proxy('http', $::param{'httpProxy'}) if (&::IsParam('httpProxy'));
- # Let's pretend
- $ua->agent("Mozilla/5.0 " . $ua->agent);
- $ua->timeout(5);
-
- &::DEBUG($wikipedia_export_url . $article);
- my $req = HTTP::Request->new('GET', $wikipedia_export_url .
- $article);
- $req->header('Accept-Language' => 'en');
- $req->header('Accept-Charset' => 'utf-8');
-
- my $res = $ua->request($req);
- my ($title, $redirect, $text);
- &::DEBUG($res->code);
-
- if ($res->is_success) {
- if ($res->code == '200' ) {
- foreach (split(/\n/, $res->as_string)) {
- if (/<title>(.*?)<\/title>/) {
- $title = $1;
- $title =~ s/&\;/&/g;
- } elsif (/#REDIRECT\s*\[\[(.*?)\]\]/i) {
- $redirect = $1;
- $redirect =~ tr/ /_/;
- &::DEBUG('wiki redirect to ' . $redirect);
- last;
- } elsif (/<text[^>]*>(.*)/) {
- $text = '"' . $1;
- } elsif (/(.*)<\/text>/) {
- $text = $text . ' ' . $1 . '"';
- last;
- } elsif ($text) {
- $text = $text . ' ' . $_;
- }
- }
- &::DEBUG("wikipedia returned text: " . $text .
- ', redirect ' . $redirect. "\n");
-
- if (!$redirect and !$text) {
- return ($res->as_string);
- }
- return ($text or wikipedia_get_text($redirect))
- }
- }
-
-}
-
-1;
+++ /dev/null
-#
-# wtf.pl: interface to bsd wtf
-# Author: Tim Riker <Tim@Rikers.org>
-# Source: modified from jethro's patch
-# Licensing: Artistic License (as perl itself)
-# Version: v0.1
-#
-# Copyright (c) 2005 Tim Riker
-#
-
-package wtf;
-
-use strict;
-
-sub wtf::wtf {
- my $query = shift;
- my $binary;
- my @binaries = (
- '/usr/games/wtf',
- '/usr/local/bin/wtf'
- );
- foreach (@binaries) {
- if (-x $_) {
- $binary=$_;
- last;
- }
- }
- if (!$binary) {
- return("no binary found.");
- }
- if ($query =~ /^$|[^\w]/){
- return("usage: wtf <foo>.");
- }
- if (!&::validExec($query)) {
- return("argument appears to be fuzzy.");
- }
-
- my $reply ='';
- foreach (`$binary '$query' 2>&1`){
- $reply .= $_;
- }
- $reply =~ s/\n/ /;
- chomp($reply);
- return($reply);
-}
-
-sub wtf::query {
- &::performStrictReply(&wtf(@_));
- return;
-}
-
-1;
-# vim: ts=2 sw=2
+++ /dev/null
-package zfi;
-
-# Search Zaurus Feeds Index (ZFI)
-# Version 1.0
-# Released 02 Oct 2002
-
-# Based on ZSI package by Darien Kruss <darien@kruss.com>
-# Modified by Jordan Wiens <jordan@d0pe.com> (numatrix on #zaurus) and
-# Eric Lin <anselor@d0pe.com> (anselor on #zaurus) to search ZFI instead of ZSI
-
-# This script relies on the following page returning results
-# http://zaurii.com/zfi/zfibot.php
-# Returns the 5 latest/newest entries
-
-# http://zaurii.com/zfi/zfibot.php?query=XXXX
-# Returns all matches where XXX is in the name, description, etc
-
-# Returned matches are pipe-separated, one record per line
-# name|URL|description
-
-# These are the phrases we get called for:
-
-# 'zfi' or 'zfi <search>'
-
-# We reply publicly or privately, depending how we were called
-
-use strict;
-
-my $no_zfi;
-
-BEGIN {
- $no_zfi = 0;
- eval "use LWP::UserAgent";
- $no_zfi++ if ($@);
-}
-
-sub queryText {
- my ($query) = @_;
-
- if ($no_zfi) {
- &::status("zfi module requires LWP::UserAgent.");
- return '';
- }
-
- my $res_return = 5;
-
- my $ua = new LWP::UserAgent;
- $ua->proxy('http', $::param{'httpProxy'}) if (&::IsParam('httpProxy'));
-
- $ua->timeout(10);
-
- my $searchpath;
- if ($query) {
- $searchpath = "http://zaurii.com/zfi/zfibot.php?query=$query";
- } else {
- $searchpath = "http://zaurii.com/zfi/zfibot.php";
- }
-
- my $request = new HTTP::Request('GET', "$searchpath");
- my $response = $ua->request($request);
-
- if (!$response->is_success) {
- return "Something failed in connecting to the ZFI web server. Try again later.";
- }
-
- my $content = $response->content;
-
- if ($content =~ /No entries found/im) {
- return "No results were found searching ZFI for '$query'.";
- }
-
- my $res_count = 0; #local counter
- my $res_display = 0; #results displayed
-
- my @lines = split(/\n/,$content);
-
- my $result = '';
- foreach my $line (@lines) {
- if (length($line) > 10) {
- my ($name, $href, $desc) = split(/\|/,$line);
-
- if ($res_count < $res_return) {
- $result .= "$name ($desc) $href : ";
- $res_display ++;
- }
- $res_count ++;
- }
- }
-
- if (($query) && ($res_count > $res_display)) {
- $result .= "$res_display of $res_count shown. All at http://zaurii.com/zfi/index.phtml?p=r&r=$query";
- }
-
- return $result;
-}
-
-sub query {
- my ($args) = @_;
- &::performStrictReply(&queryText($args));
- return;
-}
-
-1;
-# vim: shiftwidth=2 tabstop=2
-__END__
+++ /dev/null
-package zsi;
-
-# Search Zaurus Software Index (ZSI)
-# Version 1.0
-# Released 26 Aug 2002
-
-# Developed by Darien Kruss <darien@kruss.com>
-# http://zaurus.kruss.com/
-# usually hangs out on #zaurus as 'darienm'
-
-# This script relies on the following page returning results
-# http://killefiz.de/zaurus/zsibot.php
-# Returns the 5 latest/newest entries
-
-# http://killefiz.de/zaurus/zsibot.php?query=XXXX
-# Returns all matches where XXX is in the name, description, etc
-
-# Returned matches are pipe-separated, one record per line
-# name|URL|description
-
-# These are the phrases we get called for:
-
-# 'zsi' or 'zsi <search>'
-
-# We reply publicly or privately, depending how we were called
-
-my $no_zsi;
-
-use strict;
-
-BEGIN {
- $no_zsi = 0;
- eval "use LWP::UserAgent";
- $no_zsi++ if ($@);
-}
-
-sub queryText {
- my ($query) = @_;
-
- if ($no_zsi) {
- &::status("zsi module requires LWP::UserAgent.");
- return '';
- }
-
- my $res_return = 5;
-
- my $ua = new LWP::UserAgent;
- $ua->proxy('http', $::param{'httpProxy'}) if (&::IsParam('httpProxy'));
-
- $ua->timeout(10);
-
- my $searchpath;
- if ($query) {
- $searchpath = "http://killefiz.de/zaurus/zsibot.php?query=$query";
- } else {
- $searchpath = "http://killefiz.de/zaurus/zsibot.php";
- }
-
- my $request = new HTTP::Request('GET', "$searchpath");
- my $response = $ua->request($request);
-
- if (!$response->is_success) {
- return "Something failed in connecting to the ZSI web server. Try again later.";
- }
-
- my $content = $response->content;
-
- if ($content =~ /No entries found/im) {
- return "No results were found searching ZSI for '$query'.";
- }
-
- my $res_count = 0; #local counter
- my $res_display = 0; #results displayed
-
- my @lines = split(/\n/,$content);
-
- my $result = '';
- foreach my $line (@lines) {
- if (length($line) > 10) {
- my ($name, $href, $desc) = split(/\|/,$line);
-
- if ($res_count < $res_return) {
- $result .= "$name ($desc) $href : ";
- $res_display ++;
- }
- $res_count ++;
- }
- }
-
- if (($query) && ($res_count > $res_display)) {
- $result .= "$res_display of $res_count shown. All at http://killefiz.de/zaurus/search.php?q=$query";
- }
-
- return $result;
-}
-
-sub query {
- my ($args) = @_;
- &::performStrictReply(&queryText($args));
- return;
-}
-
-1;
-# vim: shiftwidth=2 tabstop=2
-__END__
+++ /dev/null
-#
-# Net.pl: FTP//HTTP helper
-# Author: dms
-# Version: v0.1 (20000309)
-# Created: 20000309
-#
-
-use strict;
-
-use vars qw(%ftp %param);
-
-# Usage: &ftpGet($host,$dir,$file,[$lfile]);
-sub ftpGet {
- my ($host,$dir,$file,$lfile) = @_;
- my $verbose_ftp = 1;
-
- return unless &loadPerlModule("Net::FTP");
-
- &status("FTP: opening connection to $host.") if ($verbose_ftp);
- my $ftp = Net::FTP->new($host,
- 'Timeout' => 1*60,
-### 'BlockSize' => 1024, # ???
- );
-
- return if ($@);
-
- # login.
- if ($ftp->login()) {
- &status("FTP: logged in successfully.") if ($verbose_ftp);
- } else {
- &status("FTP: login failed.");
- $ftp->quit();
- return 0;
- }
-
- # change directories.
- if ($ftp->cwd($dir)) {
- &status("FTP: changed dirs to $dir.") if ($verbose_ftp);
- } else {
- &status("FTP: cwd dir ($dir) does not exist.");
- $ftp->quit();
- return 0;
- }
-
- # get the size of the file.
- my ($size, $lsize);
- if ($size = $ftp->size($file)) {
- &status("FTP: file size is $size") if ($verbose_ftp);
- my $thisfile = $file || $lfile;
-
- if ( -f $thisfile) {
- $lsize = -s $thisfile;
- if ($_ != $lsize) {
- &status("FTP: local size is $lsize; downloading.") if ($verbose_ftp);
- } else {
- &status("FTP: same size; skipping.");
- system("touch $thisfile"); # lame hack.
- $ftp->quit();
- return 1;
- }
- }
- } else {
- &status("FTP: file does not exist.");
- $ftp->quit();
- return 0;
- }
-
- my $start_time = &timeget();
- if (defined $lfile) {
- &status("FTP: getting $file as $lfile.") if ($verbose_ftp);
- $ftp->get($file,$lfile);
- } else {
- &status("FTP: getting $file.") if ($verbose_ftp);
- $ftp->get($file);
- }
-
- if (defined $lsize) {
- &DEBUG("FTP: locsize => '$lsize'.");
- if ($size != $lsize) {
- &FIXME("FTP: downloaded file seems truncated.");
- }
- }
-
- my $delta_time = &timedelta($start_time);
- if ($delta_time > 0 and $verbose_ftp) {
- &status(sprintf("FTP: %.02f sec to complete.", $delta_time));
- my ($rateunit,$rate) = ('B', $size / $delta_time);
- if ($rate > 1024) {
- $rate /= 1024;
- $rateunit = 'kB';
- }
- &status(sprintf("FTP: %.01f ${rateunit}/sec.", $rate));
- }
-
- $ftp->quit();
-
- return 1;
-}
-
-# Usage: &ftpList($host,$dir);
-sub ftpList {
- my ($host,$dir) = @_;
- my $verbose_ftp = 1;
-
- return unless &loadPerlModule("Net::FTP");
-
- &status("FTP: opening connection to $host.") if ($verbose_ftp);
- my $ftp = Net::FTP->new($host,'Timeout'=>60);
-
- return if ($@);
-
- # login.
- if ($ftp->login()) {
- &status("FTP: logged in successfully.") if ($verbose_ftp);
- } else {
- &status("FTP: login failed.");
- $ftp->quit();
- return;
- }
-
- # change directories.
- if ($ftp->cwd($dir)) {
- &status("FTP: changed dirs to $dir.") if ($verbose_ftp);
- } else {
- &status("FTP: cwd dir ($dir) does not exist.");
- $ftp->quit();
- return;
- }
-
- &status("FTP: doing ls.") if ($verbose_ftp);
- foreach ($ftp->dir()) {
- # modes d uid gid size month day time file.
- if (/^(\S+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+) (\S{3})\s+(\d+) \d+:\d+ (.*)$/) {
- # name = size.
- $ftp{$8} = $5;
- } else {
- &DEBUG("FTP: UNKNOWN => '$_'.");
- }
- }
- &status("FTP: ls done. ". scalar(keys %ftp) ." entries.");
- $ftp->quit();
-
- return %ftp;
-}
-
-### LWP.
-# Usage: &getURL($url, [$post]);
-# TODO: rename this to getHTTP
-sub getURL {
- my ($url,$post) = @_;
- my ($ua,$res,$req);
-
- return unless &loadPerlModule("LWP::UserAgent");
-
- $ua = new LWP::UserAgent;
- $ua->proxy('http', $param{'httpProxy'}) if &IsParam('httpProxy');
-
- if (defined $post) {
- $req = new HTTP::Request('POST',$url);
- $req->content_type('application/x-www-form-urlencoded');
- $req->content($post);
- } else {
- $req = new HTTP::Request('GET',$url);
- }
-
- &status("getURL: getting '$url'");
- my $time = time();
- $res = $ua->request($req);
- my $size = length($res->content);
- if ($size and time - $time) {
- my $rate = int( $size/1000/(time - $time) );
- &status("getURL: Done (took ".&Time2String(time - $time).", $rate k/sec)");
- }
-
- # return NULL upon error.
- return unless ($res->is_success);
-
- return(split '\n', $res->content);
-}
-
-sub getURLAsFile {
- my ($url,$file) = @_;
- my ($ua,$res,$req);
- my $time = time();
-
- unless (&loadPerlModule('LWP::UserAgent')) {
- &::DEBUG('getURLAsFile: LWP::UserAgent not installed');
- return;
- }
-
- $ua = new LWP::UserAgent;
- $ua->proxy('http', $param{'httpProxy'}) if &IsParam('httpProxy');
- $req = HTTP::Request->new('GET', $url);
- &status("getURLAsFile: getting '$url' as '$file'");
- $res = $ua->request($req, $file);
-
- my $delta_time = time() - $time;
- if ($delta_time) {
- my $size = -s $file || 0;
- my $rate = int($size / $delta_time / 1024);
- &status("getURLAsFile: Done. ($rate kB/sec)");
- }
-
- return $res;
-}
-
-1;
+++ /dev/null
-###
-### Process.pl: Kevin Lenzo 1997-1999
-###
-
-#
-# process the incoming message
-#
-
-use strict;
-
-use vars qw($who $msgType $addressed $message $ident $user $host $chan
- $learnok $talkok $force_public_reply $noreply $addrchar
- $literal $addressedother $userHandle $lobotomized);
-use vars qw(%channels %users %param %cache %chanconf %mask %orig %lang
- );
-
-sub process {
- $learnok = 0; # Able to learn?
- $talkok = 0; # Able to yap?
- $force_public_reply = 0;
- $literal = 0;
-
- return 'X' if $who eq $ident; # self-message.
- return 'addressedother set' if ($addressedother);
-
- $talkok = ($param{'addressing'} =~ /^OPTIONAL$/i or $addressed);
- $learnok = 1 if ($addressed);
- if ($param{'learn'} =~ /^HUNGRY$/i) {
- $learnok = 1;
- $addrchar = 1;
- $talkok = 1;
- }
-
- &shmFlush(); # hack.
-
- # hack to support channel +o as "+o" in bot user file.
- # requires +O in user file.
- # is $who arg lowercase?
- if (exists $channels{$chan}{o}{ $orig{who} } && &IsFlag('O') eq 'O') {
- &status("Gave $who/$chan +o (+O)\'ness");
- $users{$userHandle}{FLAGS} .= 'o';
- }
-
- # check if we have our head intact.
- if ($lobotomized) {
- if ($addressed and IsFlag('o') eq 'o') {
- my $delta_time = time() - ($cache{lobotomy}{$who} || 0);
- &msg($who, "give me an unlobotomy.") if ($delta_time > 60*60);
- $cache{lobotomy}{$who} = time();
- }
- return 'LOBOTOMY' unless IsFlag('A');
- }
-
- # talkMethod.
- if ($param{'talkMethod'} =~ /^PRIVATE$/i) {
- if ($msgType =~ /public/ and $addressed) {
- &msg($who, "sorry. i'm in 'PRIVATE' talkMethod mode ".
- "while you sent a message to me ${msgType}ly.");
-
- return 'TALKMETHOD';
- }
- }
-
- # join, must be done before outsider checking.
- if ($message =~ /^join(\s+(.*))?\s*$/i) {
- return 'join: not addr' unless ($addressed);
-
- $2 =~ /^($mask{chan})(\s+(\S+))?/;
- my($joinchan, $key) = (lc $1, $3);
-
- if ($joinchan eq '') {
- &help('join');
- return;
- }
-
- if ($joinchan !~ /^$mask{chan}$/) {
- &msg($who, "$joinchan is not a valid channel name.");
- return;
- }
-
- if (&IsFlag('o') ne 'o') {
- if (!exists $chanconf{$joinchan}) {
- &msg($who, "I am not allowed to join $joinchan.");
- return;
- }
-
- if (&validChan($joinchan)) {
- &msg($who,"warn: I'm already on $joinchan, joining anyway...");
- }
- }
- $cache{join}{$joinchan} = $who; # used for on_join self.
-
- &status("JOIN $joinchan $key <$who>");
- &msg($who, "joining $joinchan $key");
- &joinchan($joinchan, $key);
- &joinNextChan(); # hack.
-
- return;
- }
-
- # 'identify'
- if ($msgType =~ /private/ and $message =~ s/^identify//i) {
- $message =~ s/^\s+|\s+$//g;
- my @array = split / /, $message;
-
- if ($who =~ /^_default$/i) {
- &performStrictReply("you are too eleet.");
- return;
- }
-
- if (!scalar @array or scalar @array > 2) {
- &help('identify');
- return;
- }
-
- my $do_nick = $array[1] || $who;
-
- if (!exists $users{$do_nick}) {
- &performStrictReply("nick $do_nick is not in user list.");
- return;
- }
-
- my $crypt = $users{$do_nick}{PASS};
- if (!defined $crypt) {
- &performStrictReply("user $do_nick has no passwd set.");
- return;
- }
-
- if (!&ckpasswd($array[0], $crypt)) {
- &performStrictReply("invalid passwd for $do_nick.");
- return;
- }
-
- my $mask = "$who!$user@".&makeHostMask($host);
- ### TODO: prevent adding multiple dupe masks?
- ### TODO: make &addHostMask() CMD?
- &performStrictReply("Added $mask for $do_nick...");
- $users{$do_nick}{HOSTS}{$mask} = 1;
-
- return;
- }
-
- # 'pass'
- if ($msgType =~ /private/ and $message =~ s/^pass//i) {
- $message =~ s/^\s+|\s+$//g;
- my @array = split ' ', $message;
-
- if ($who =~ /^_default$/i) {
- &performStrictReply("you are too eleet.");
- return;
- }
-
- if (scalar @array != 1) {
- &help('pass');
- return;
- }
-
- # TODO: use &getUser()?
- my $first = 1;
- foreach (keys %users) {
- if ($users{$_}{FLAGS} =~ /n/) {
- $first = 0;
- last;
- }
- }
-
- if (!exists $users{$who} and !$first) {
- &performStrictReply("nick $who is not in user list.");
- return;
- }
-
- if ($first) {
- &performStrictReply("First time user... adding you as Master.");
- $users{$who}{FLAGS} = 'aemnorst';
- }
-
- my $crypt = $users{$who}{PASS};
- if (defined $crypt) {
- &performStrictReply("user $who already has pass set.");
- return;
- }
-
- if (!defined $host) {
- &WARN("pass: host == NULL.");
- return;
- }
-
- if (!scalar keys %{ $users{$who}{HOSTS} }) {
- my $mask = "*!$user@".&makeHostMask($host);
- &performStrictReply("Added hostmask '\002$mask\002' to $who");
- $users{$who}{HOSTS}{$mask} = 1;
- }
-
- $crypt = &mkcrypt($array[0]);
- $users{$who}{PASS} = $crypt;
- &performStrictReply("new pass for $who, crypt $crypt.");
-
- return;
- }
-
- # allowOutsiders.
- if (&IsParam('disallowOutsiders') and $msgType =~ /private/i) {
- my $found = 0;
-
- foreach (keys %channels) {
- # don't test for $channel{_default} elsewhere !!!
- next if (/^\s*$/ || /^_?default$/);
- next unless (&IsNickInChan($who,$_));
-
- $found++;
- last;
- }
-
- if (!$found and scalar(keys %channels)) {
- &status("OUTSIDER <$who> $message");
- return 'OUTSIDER';
- }
- }
-
- # override msgType.
- if ($msgType =~ /public/ and $message =~ s/^\+//) {
- &status("Process: '+' flag detected; changing reply to public");
- $msgType = 'public';
- $who = $chan; # major hack to fix &msg().
- $force_public_reply++;
- # notice is still NOTICE but to whole channel => good.
- }
-
- # User Processing, for all users.
- if ($addressed) {
- my $retval;
- return 'SOMETHING parseCmdHook' if &parseCmdHook($message);
-
- $retval = &userCommands();
- return unless (defined $retval);
- return if ($retval eq $noreply);
- }
-
- ###
- # once useless messages have been parsed out, we match them.
- ###
-
- # confused? is this for infobot communications?
- foreach (keys %{ $lang{'confused'} }) {
- my $y = $_;
-
- next unless ($message =~ /^\Q$y\E\s*/);
- return 'CONFUSO';
- }
-
- # hello. [took me a while to fix this. -xk]
- if ($orig{message} =~ /^(\Q$ident\E\S?[:, ]\S?)?\s*(h(ello|i( there)?|owdy|ey|ola))( \Q$ident\E)?\s*$/i) {
- return '' unless ($talkok);
-
- # 'mynick: hi' or 'hi mynick' or 'hi'.
- &status("somebody said hello");
-
- # 50% chance of replying to a random greeting when not addressed
- if (!defined $5 and $addressed == 0 and rand() < 0.5) {
- &status("not returning unaddressed greeting");
- return;
- }
-
- # customized random message.
- my $tmp = (rand() < 0.5) ? ", $who" : '';
- &performStrictReply( &getRandom(keys %{ $lang{'hello'} }) . $tmp );
- return;
- }
-
- # greetings.
- if ($message =~ /how (the hell )?are (ya|you)( doin\'?g?)?\?*$/) {
-
- &performReply(&getRandom(keys %{ $lang{'howareyou'} }));
- return;
- }
-
- # praise.
- if ($message =~ /you (rock|rewl|rule|are so+ coo+l)/ ||
- $message =~ /(good (bo(t|y)|g([ui]|r+)rl))|(bot( |\-)?snack)/i)
- {
- return 'praise: no addr' unless ($addressed);
-
- &performReply(&getRandom(keys %{ $lang{'praise'} }));
- return;
- }
-
- # thanks.
- if ($message =~ /^than(ks?|x)( you)?( \S+)?/i) {
- return 'thank: no addr' unless ($message =~ /$ident/ or $talkok);
-
- &performReply( &getRandom(keys %{ $lang{'welcome'} }) );
- return;
- }
-
- ###
- ### bot commands...
- ###
-
- # karma. set...
- if ($msgType =~ /public/i && $message =~ /^(\S+)(--|\+\+)\s*$/ &&
- $addressed && &IsChanConfOrWarn('karma')
- ) {
- # to request factoids such as "g++" or "libstdc++", append "?" to the query.
- my ($term,$inc) = (lc $1,$2);
-
- if (lc $term eq lc $who) {
- &msg($who, "please don't karma yourself");
- return;
- }
-
- my $karma = &sqlSelect('stats', 'counter',
- { nick => $term, type => 'karma' }) || 0;
- if ($inc eq '++') {
- $karma++;
- } else {
- $karma--;
- }
-
- &sqlSet('stats', {'nick' => $term, type => 'karma', channel => 'PRIVATE'}, {
- 'time' => time(),
- counter => $karma,
- } );
-
- return;
- }
-
- # here's where the external routines get called.
- # if they return anything but null, that's the 'answer'.
- if ($addressed) {
- my $er = &Modules();
- if (!defined $er) {
- return 'SOMETHING 1';
- }
-
- # allow administration of bot via messages (default is DCC CHAT only)
- if (&IsFlag('A')) {
- &loadMyModule('UserDCC');
- $er = &userDCC();
- if (!defined $er) {
- return 'SOMETHING 2';
- }
- }
-
- if (0 and $addrchar) {
- &msg($who, "I don't trust people to use the core commands while addressing me in a short-cut way.");
- return;
- }
- }
-
- if (&IsParam('factoids') and $param{'DBType'} =~ /^(mysql|sqlite(2)?|pgsql)$/i) {
- &FactoidStuff();
- } elsif ($param{'DBType'} =~ /^none$/i) {
- return "NO FACTOIDS.";
- } else {
- &ERROR("INVALID FACTOID SUPPORT? ($param{'DBType'})");
- &shutdown();
- exit 0;
- }
-}
-
-1;
+++ /dev/null
-#
-# Shm.pl: Shared Memory stuff.
-# Author: dms
-# Version: 20000201
-# Created: 20000124
-#
-
-# use strict; # TODO
-
-use POSIX qw(_exit);
-
-sub openSHM {
- my $IPC_PRIVATE = 0;
- my $size = 2000;
-
- if (&IsParam('noSHM')) {
- &status("Shared memory: Disabled. WARNING: bot may become unreliable");
- return 0;
- }
-
- if (defined( $_ = shmget($IPC_PRIVATE, $size, 0777) )) {
- &status("Created shared memory (shm) key: [$_]");
- return $_;
- } else {
- &ERROR("openSHM: failed.");
- &ERROR("Please delete some shared memory with ipcs or ipcrm.");
- exit 1;
- }
-}
-
-sub closeSHM {
- my ($key) = @_;
- my $IPC_RMID = 0;
-
- return '' if (!defined $key);
-
- &shmFlush();
- &status("Closed shared memory (shm) key: [$key]");
- return shmctl($key, $IPC_RMID, 0);
-}
-
-sub shmRead {
- my ($key) = @_;
- my $position = 0;
- my $size = 3*80;
- my $retval = '';
-
- return '' if (&IsParam('noSHM'));
-
- if (shmread($key,$retval,$position,$size)) {
- #&DEBUG("shmRead($key): $retval");
- return $retval;
- } else {
- &ERROR("shmRead: failed: $!");
- ### TODO: if this fails, never try again.
- &openSHM();
- return '';
- }
-}
-
-sub shmWrite {
- my ($key, $str) = @_;
- my $position = 0;
- my $size = 80*3;
-
- return if (&IsParam('noSHM'));
-
- if (length($str) > $size) {
- &status("ERROR: length(str) (..)>$size...");
- return;
- }
-
- if (length($str) == 0) {
- # does $size overwrite the whole lot?
- # if not, set to 2000.
- if (!shmwrite($key, '', $position, $size)) {
- &ERROR("shmWrite: failed: $!");
- }
- return;
- }
-
- my $read = &shmRead($key);
- $read =~ s/\0+//g;
- if ($read eq '') {
- $str = sprintf("%s:%d:%d: ", $param{ircUser}, $bot_pid, time());
- } else {
- $str = $read ."||". $str;
- }
-
- if (!shmwrite($key, $str, $position, $size)) {
- &DEBUG("shmWrite($key, $str)");
- &ERROR("shmWrite: failed: $!");
- }
-}
-
-##############
-### Helpers
-###
-
-# Usage: &addForked($name);
-# Return: 1 for success, 0 for failure.
-sub addForked {
- my ($name) = @_;
- my $forker_timeout = 360; # 6mins, in seconds.
- $forker = $name;
-
- if (!defined $name) {
- &WARN("addForked: name == NULL.");
- return 0;
- }
-
- foreach (keys %forked) {
- my $n = $_;
- my $time = time() - $forked{$n}{Time};
- next unless ($time > $forker_timeout);
-
- ### TODO: use &time2string()?
- &WARN("Fork: looks like we lost '$n', executed $time ago");
-
- my $pid = $forked{$n}{PID};
- if (!defined $pid) {
- &WARN("Fork: no pid for $n.");
- delete $forked{$n};
- next;
- }
-
- if ($pid == $bot_pid) {
- # don't kill parent, just warn.
- &status("Fork: pid == \$bot_pid == \$\$ ($bot_pid)");
-
- } elsif ( -d "/proc/$pid") { # pid != bot_pid.
- &status("Fork: killing $name ($pid)");
- kill 9, $pid;
- }
-
- delete $forked{$n};
- }
-
- my $count = 0;
- while (scalar keys %forked > 1) { # 2 or more == fail.
- sleep 1;
-
- if ($count > 3) { # 3 seconds.
- my $list = join(', ', keys %forked);
- if (defined $who) {
- &msg($who, "exceeded allowed forked count (shm $shm): $list");
- } else {
- &status("Fork: I ran too many forked processes :) Giving up $name. Shm: $shm");
- }
-
- return 0;
- }
-
- $count++;
- }
-
- if (exists $forked{$name} and !scalar keys %{ $forked{$name} }) {
- &WARN("addF: forked{$name} exists but is empty; deleting.");
- undef $forked{$name};
- }
-
- if (exists $forked{$name} and scalar keys %{ $forked{$name} }) {
- my $time = $forked{$name}{Time};
- my $continue = 0;
-
- $continue++ if ($forked{$name}{PID} == $$);
-
- if ($continue) {
- &WARN("hrm.. fork pid == mypid == $$; how did this happen?");
-
- } elsif ( -d "/proc/$forked{$name}{PID}") {
- &status("fork: still running; good. BAIL OUT.");
- return 0;
-
- } else {
- &WARN("Found dead fork; removing and resetting.");
- $continue = 1;
- }
-
- if ($continue) {
- # NOTHING.
-
- } elsif (time() - $time > 900) { # stale fork > 15m.
- &status("forked: forked{$name} presumably exited without notifying us.");
-
- } else { # fresh fork.
- &msg($who, "$name is already running ". &Time2String(time() - $time));
- return 0;
- }
- }
-
- $forked{$name}{Time} = time();
- $forked{$name}{PID} = $$;
- $forkedtime = time();
- $count{'Fork'}++;
- return 1;
-}
-
-sub delForked {
- my ($name) = @_;
-
- return if ($$ == $bot_pid);
-
- if (!defined $name) {
- &WARN("delForked: name == NULL.");
- POSIX::_exit(0);
- }
-
- if ($name =~ /\.pl/) {
- &WARN("dF: name is name of source file ($name). FIX IT!");
- }
-
- &showProc(); # just for informational purposes.
-
- if (exists $forked{$name}) {
- my $timestr = &Time2String(time() - $forked{$name}{Time});
- &status("fork: took $timestr for $name.");
- &shmWrite($shm,"DELETE FORK $name");
- } else {
- &ERROR("delForked: forked{$name} does not exist. should not happen.");
- }
-
- &status("--- fork finished for '$name' ---");
-
- POSIX::_exit(0);
-}
-
-sub shmFlush {
- return if ($$ != $::bot_pid); # fork protection.
-
- if (@_) {
- &ScheduleThis(15, 'shmFlush');
- return if ($_[0] eq '2');
- }
-
- my $time;
- my $shmmsg = &shmRead($shm);
- # remove padded \0's.
- $shmmsg =~ s/\0//g;
- return if (length($shmmsg) == 0);
- if ($shmmsg =~ s/^(\S+):(\d+):(\d+): //) {
- my $n = $1;
- my $pid = $2;
- $time = $3;
- } else {
- &status("warn: shmmsg='$shmmsg'.");
- return;
- }
-
- foreach (split '\|\|', $shmmsg) {
- next if (/^$/);
- &VERB("shm: Processing '$_'.",2);
-
- if (/^DCC SEND (\S+) (\S+)$/) {
- my ($nick,$file) = ($1,$2);
- if (exists $dcc{'SEND'}{$who}) {
- &msg($nick, "DCC already active.");
- } else {
- &DEBUG("shm: dcc sending $2 to $1.");
- $conn->new_send($1,$2);
- $dcc{'SEND'}{$who} = time();
- }
- } elsif (/^SET FORKPID (\S+) (\S+)/) {
- $forked{$1}{PID} = $2;
- } elsif (/^DELETE FORK (\S+)$/) {
- delete $forked{$1};
- } elsif (/^EVAL (.*)$/) {
- &DEBUG("evaling '$1'.");
- eval $1;
- } else {
- &DEBUG("shm: unknown msg. ($_)");
- }
- }
-
- &shmWrite($shm,'') if ($shmmsg ne '');
-}
-
-1;
+++ /dev/null
-#
-# UserExtra.pl: User Commands, Public.
-# Author: dms
-#
-
-use strict;
-use vars qw($message $arg $qWord $verb $lobotomized $who $result $chan
- $conn $msgType $query $talkchannel $ident $memusage);
-use vars qw(%channels %chanstats %cmdstats %count %forked %ircstats %param
- %cache %mask %userstats);
-
-### hooks get added in CommandHooks.pl.
-
-###
-### Start of commands for hooks.
-###
-
-sub chaninfo {
- my $chan = lc shift(@_);
- my $mode;
-
- if ($chan eq '') { # all channels.
- my $i = keys %channels;
- my $reply = "I'm on \002$i\002 ".&fixPlural('channel',$i);
- my $tucount = 0; # total user count.
- my $uucount = 0; # unique user count.
- my %chans;
- my @array;
-
- ### line 1.
- foreach (keys %channels) {
- if ( /^\s*$/ or / / ) {
- &status("chanstats: fe channels: chan == NULL.");
- #&ircCheck();
- next;
- }
- next if (/^_default$/);
-
- $chans{$_} = scalar(keys %{ $channels{$_}{''} });
- }
- foreach $chan (sort {$chans{$b} <=> $chans{$a}} keys %chans) {
- push(@array, "$chan/" . $chans{$chan});
- }
- &performStrictReply($reply.": ".join(', ', @array));
-
- ### total user count.
- foreach $chan (keys %channels) {
- $tucount += scalar(keys %{ $channels{$chan}{''} });
- }
-
- ### unique user count.
- my %nicks = ();
- foreach $chan (keys %channels) {
- my $nick;
- foreach $nick (keys %{ $channels{$chan}{''} }) {
- $nicks{$nick}++;
- }
- }
- $uucount = scalar(keys %nicks);
-
- my $chans = scalar(keys %channels);
- &performStrictReply(
- "i've cached \002$tucount\002 ". &fixPlural('user',$tucount).
- ", \002$uucount\002 unique ". &fixPlural('user',$uucount).
- ", distributed over \002$chans\002 ".
- &fixPlural('channel', $chans)."."
- );
- &ircCheck();
-
- return;
- }
-
- # channel specific.
-
- if (&validChan($chan) == 0) {
- &msg($who,"error: invalid channel \002$chan\002");
- return;
- }
-
- # Step 1:
- my @array;
- foreach (sort keys %{ $chanstats{$chan} }) {
- my $int = $chanstats{$chan}{$_};
- next unless ($int);
-
- push(@array, "\002$int\002 ". &fixPlural($_,$int));
- }
- my $reply = "On \002$chan\002, there ".
- &fixPlural('has',scalar(@array)). " been ".
- &IJoin(@array);
-
- # Step 1b: check channel inconstencies.
- $chanstats{$chan}{'Join'} ||= 0;
- $chanstats{$chan}{'SignOff'} ||= 0;
- $chanstats{$chan}{'Part'} ||= 0;
-
- my $delta_stats = $chanstats{$chan}{'Join'}
- - $chanstats{$chan}{'SignOff'}
- - $chanstats{$chan}{'Part'};
-
- if ($delta_stats) {
- my $total = scalar(keys %{ $channels{$chan}{''} });
- &status("chaninfo: join ~= signoff + part (drift of $delta_stats < $total).");
-
- if ($delta_stats > $total) {
- &ERROR("chaninfo: delta_stats exceeds total users.");
- }
- }
-
- # Step 2:
- undef @array;
- my $type;
- foreach ('v','o','') {
- my $int = scalar(keys %{ $channels{$chan}{$_} });
- next unless ($int);
-
- $type = 'Voice' if ($_ eq 'v');
- $type = 'Opped' if ($_ eq 'o');
- $type = 'Total' if ($_ eq '');
-
- push(@array,"\002$int\002 $type");
- }
- $reply .= ". At the moment, ". &IJoin(@array);
-
- # Step 3:
- my %new;
- foreach (keys %userstats) {
- next unless (exists $userstats{$_}{'Count'});
- if ($userstats{$_}{'Count'} =~ /^\D+$/) {
- &WARN("userstats{$_}{Count} is non-digit.");
- next;
- }
-
- $new{$_} = $userstats{$_}{'Count'};
- }
-
- # TODO: show top 3 with percentages?
- my($count) = (sort { $new{$b} <=> $new{$a} } keys %new)[0];
- if ($count) {
- $reply .= ". \002$count\002 has said the most with a total of \002$new{$count}\002 messages";
- }
- &performStrictReply("$reply.");
-}
-
-# Command statistics.
-sub cmdstats {
- my @array;
-
- if (!scalar(keys %cmdstats)) {
- &performReply("no-one has run any commands yet");
- return;
- }
-
- my %countstats;
- foreach (keys %cmdstats) {
- $countstats{ $cmdstats{$_} }{$_} = 1;
- }
-
- foreach (sort {$b <=> $a} keys %countstats) {
- my $int = $_;
- next unless ($int);
-
- foreach (keys %{ $countstats{$int} }) {
- push(@array, "\002$int\002 of $_");
- }
- }
- &performStrictReply("command usage include ". &IJoin(@array).".");
-}
-
-# Factoid extension info. xk++
-sub factinfo {
- my $faqtoid = lc shift(@_);
- my $query = '';
-
- if ($faqtoid =~ /^\-(\S+)(\s+(.*))$/) {
- &msg($who,"error: individual factoid info queries not supported as yet.");
- &msg($who,"it's possible that the factoid mistakenly begins with '-'.");
- return;
-
- $query = lc $1;
- $faqtoid = lc $3;
- }
-
- &CmdFactInfo($faqtoid, $query);
-}
-
-sub factstats {
- my $type = shift(@_);
-
- &Forker('Factoids', sub {
- &performStrictReply( &CmdFactStats($type) );
- } );
-}
-
-sub karma {
- my $target = lc( shift || $who );
- my $karma = &sqlSelect('stats', 'counter',
- { nick => $target, type => 'karma'}) || 0;
-
- if ($karma != 0) {
- &performStrictReply("$target has karma of $karma");
- } else {
- &performStrictReply("$target has neutral karma");
- }
-}
-
-sub tell {
- my $args = shift;
- my ($target, $tell_obj) = ('','');
- my $dont_tell_me = 0;
- my $reply;
-
- ### is this fixed elsewhere?
- $args =~ s/\s+/ /g; # fix up spaces.
- $args =~ s/^\s+|\s+$//g; # again.
-
- # this one catches most of them
- if ($args =~ /^(\S+) (-?)about (.*)$/i) {
- $target = $1;
- $tell_obj = $3;
- $dont_tell_me = ($2) ? 1 : 0;
-
- $tell_obj = $who if ($tell_obj =~ /^(me|myself)$/i);
- $query = $tell_obj;
- } elsif ($args =~ /^(\S+) where (\S+) can (\S+) (.*)$/i) {
- # i'm sure this could all be nicely collapsed
- $target = $1;
- $tell_obj = $4;
- $query = $tell_obj;
-
- } elsif ($args =~ /^(\S+) (what|where) (.*?) (is|are)[.?!]*$/i) {
- $target = $1;
- $qWord = $2;
- $tell_obj = $3;
- $verb = $4;
- $query = "$qWord $verb $tell_obj";
-
- } elsif ($args =~ /^(.*?) to (\S+)$/i) {
- $target = $3;
- $tell_obj = $2;
- $query = $tell_obj;
- }
-
- # check target type. Deny channel targets.
- if ($target !~ /^$mask{nick}$/ or $target =~ /^$mask{chan}$/) {
- &msg($who,"No, $who, I won't. (target invalid?)");
- return;
- }
-
- $target = $talkchannel if ($target =~ /^us$/i);
- $target = $who if ($target =~ /^(me|myself)$/i);
-
- &status("tell: target = $target, query = $query");
-
- # 'intrusive'.
-# if ($target !~ /^$mask{chan}$/ and !&IsNickInAnyChan($target)) {
-# &msg($who, "No, $target is not in any of my chans.");
-# return;
-# }
-
- # self.
- if ($target =~ /^\Q$ident\E$/i) {
- &msg($who, "Isn't that a bit silly?");
- return;
- }
-
- my $oldwho = $who;
- my $oldmtype = $msgType;
- $who = $target;
- my $result = &doQuestion($tell_obj);
- # ^ returns '0' if nothing was found.
- $who = $oldwho;
-
- # no such factoid.
- if (!defined $result || $result =~ /^0?$/) {
- $who = $target;
- $msgType = 'private';
-
- # support command redirection.
- # recursive cmdHooks aswell :)
- my $done = 0;
- $done++ if &parseCmdHook($tell_obj);
- $message = $tell_obj;
- $done++ unless (&Modules());
-
- &VERB("tell: setting old values of who and msgType.",2);
- $who = $oldwho;
- $msgType = $oldmtype;
-
- if ($done) {
- &msg($who, "told $target about CMD '$tell_obj'");
- } else {
- &msg($who, "i dunno what is '$tell_obj'.");
- }
-
- return;
- }
-
- # success.
- &status("tell: <$who> telling $target about $tell_obj.");
- if ($who ne $target) {
- if ($dont_tell_me) {
- &msg($who, "told $target about $tell_obj.");
- } else {
- &msg($who, "told $target about $tell_obj ($result)");
- }
-
- $reply = "$who wants you to know: $result";
- } else {
- $reply = "telling yourself: $result";
- }
-
- &msg($target, $reply);
-}
-
-sub countryStats {
- if (exists $cache{countryStats}) {
- &msg($who,"countrystats is already running!");
- return;
- }
-
- if ($chan eq '') {
- $chan = $_[0];
- }
-
- if ($chan eq '') {
- &help('countrystats');
- return;
- }
-
- $conn->who($chan);
- $cache{countryStats}{chan} = $chan;
- $cache{countryStats}{mtype} = $msgType;
- $cache{countryStats}{who} = $who;
- $cache{on_who_Hack} = 1;
-}
-
-sub do_countrystats {
- $chan = $cache{countryStats}{chan};
- $msgType = $cache{countryStats}{mtype};
- $who = $cache{countryStats}{who};
-
- my $total = 0;
- my %cstats;
- foreach (keys %{ $cache{nuhInfo} }) {
- my $h = $cache{nuhInfo}{$_}{Host};
-
- if ($h =~ /^.*\.(\D+)$/) { # host
- $cstats{$1}++;
- } else { # ip
- $cstats{unresolve}++;
- }
- $total++;
- }
- my %count;
- foreach (keys %cstats) {
- $count{ $cstats{$_} }{$_} = 1;
- }
-
- my @list;
- foreach (sort {$b <=> $a} keys %count) {
- my $str = join(", ", sort keys %{ $count{$_} });
-# push(@list, "$str ($_)");
- my $perc = sprintf("%.01f", 100 * $_ / $total);
- $perc =~ s/\.0+$//;
- push(@list, "$str ($_, $perc %)");
- }
-
- # TODO: move this into a scheduler
- $msgType = 'private';
- &performStrictReply( &formListReply(0, "Country Stats ", @list) );
-
- delete $cache{countryStats};
- delete $cache{on_who_Hack};
-}
-
-###
-### amalgamated commands.
-###
-
-sub userCommands {
- # conversion: ascii.
- if ($message =~ /^(asci*|chr) (\d+)$/) {
- &DEBUG("ascii/chr called ...");
- return unless (&IsChanConfOrWarn('allowConv'));
-
- &DEBUG("ascii/chr called");
-
- $arg = $2;
- $result = chr($arg);
- $result = 'NULL' if ($arg == 0);
-
- &performReply( sprintf("ascii %s is '%s'", $arg, $result) );
-
- return;
- }
-
- # conversion: ord.
- if ($message =~ /^ord(\s+(.*))$/) {
- return unless (&IsChanConfOrWarn('allowConv'));
-
- $arg = $2;
-
- if (!defined $arg or length $arg != 1) {
- &help('ord');
- return;
- }
-
- if (ord($arg) < 32) {
- $arg = chr(ord($arg) + 64);
- if ($arg eq chr(64)) {
- $arg = 'NULL';
- } else {
- $arg = '^'.$arg;
- }
- }
-
- &performReply( sprintf("'%s' is ascii %s", $arg, ord $arg) );
- return;
- }
-
- # hex.
- if ($message =~ /^hex(\s+(.*))?$/i) {
- return unless (&IsChanConfOrWarn('allowConv'));
- my $arg = $2;
-
- if (!defined $arg) {
- &help('hex');
- return;
- }
-
- if (length $arg > 80) {
- &msg($who, "Too long.");
- return;
- }
-
- my $retval;
- foreach (split //, $arg) {
- $retval .= sprintf(" %X", ord($_));
- }
-
- &performStrictReply("$arg is$retval");
-
- return;
- }
-
- # crypt.
- if ($message =~ /^crypt\s+(\S*)?\s*(.*)?$/i) {
-&status("crypt: $1:$2:$3");
- if ("$2" ne '') {
- &performStrictReply(crypt($2, $1));
- } else {
- &performStrictReply(&mkcrypt($1));
- }
- return;
- }
-
- # cycle.
- if ($message =~ /^(cycle)(\s+(\S+))?$/i) {
- return unless (&hasFlag('o'));
- my $chan = lc $3;
-
- if ($chan eq '') {
- if ($msgType =~ /public/) {
- $chan = $talkchannel;
- &DEBUG("cycle: setting chan to '$chan'.");
- } else {
- &help('cycle');
- return;
- }
- }
-
- if (&validChan($chan) == 0) {
- &msg($who,"error: invalid channel \002$chan\002");
- return;
- }
-
- &msg($chan, "I'm coming back. (courtesy of $who)");
- &part($chan);
-### &ScheduleThis(5, 'getNickInUse') if (@_);
- &status("Schedule rejoin in 5secs to $chan by $who.");
- $conn->schedule(5, sub { &joinchan($chan); });
-
- return;
- }
-
- # reload.
- if ($message =~ /^reload$/i) {
- return unless (&hasFlag('n'));
-
- &status("USER reload $who");
- &performStrictReply("reloading...");
- my $modules = &reloadAllModules();
- &performStrictReply("reloaded:$modules");
- return;
- }
-
- # redir.
- if ($message =~ /^redir(\s+(.*))?/i) {
- return unless (&hasFlag('o'));
- my $factoid = $2;
-
- if (!defined $factoid) {
- &help('redir');
- return;
- }
-
- my $val = &getFactInfo($factoid, "factoid_value");
- if (!defined $val or $val eq '') {
- &msg($who, "error: '$factoid' does not exist.");
- return;
- }
- &DEBUG("val => '$val'.");
- my @list = &searchTable('factoids', "factoid_key",
- "factoid_value", "^$val\$");
-
- if (scalar @list == 1) {
- &msg($who, "hrm... '$factoid' is unique.");
- return;
- }
- if (scalar @list > 5) {
- &msg($who, "A bit too many factoids to be redirected, hey?");
- return;
- }
-
- my @redir;
- &status("Redirect '$factoid' (". ($#list) .")...");
- for (@list) {
- my $x = $_;
- next if (/^\Q$factoid\E$/i);
-
- &status(" Redirecting '$_'.");
- my $was = &getFactoid($_);
- if ($was =~ /<REPLY> see/i) {
- &status("warn: not redirecting a redirection.");
- next;
- }
-
- &DEBUG(" was '$was'.");
- push(@redir,$x);
- &setFactInfo($x, "factoid_value", "<REPLY> see $factoid");
- }
- &status("Done.");
-
- &msg($who, &formListReply(0, "'$factoid' is redirected to by '", @redir));
-
- return;
- }
-
- # rot13 it.
- if ($message =~ /^rot([0-9]*)(\s+(.*))?/i) {
- my $reply = $3;
-
- if (!defined $reply) {
- &help('rot13');
- return;
- }
- my $num = $1 % 26;
- my $upper='ABCDEFGHIJKLMNOPQRSTUVWXYZ';
- my $lower='abcdefghijklmnopqrstuvwxyz';
- my $to=substr($upper,$num).substr($upper,0,$num).substr($lower,$num).substr($lower,0,$num);
- eval "\$reply =~ tr/$upper$lower/$to/;";
-
- #$reply =~ y/A-Za-z/N-ZA-Mn-za-m/;
- &performStrictReply($reply);
-
- return;
- }
-
- # cpustats.
- if ($message =~ /^cpustats$/i) {
- if ($^O !~ /linux/) {
- &ERROR("cpustats: your OS is not supported yet.");
- return;
- }
-
- ### poor method to get info out of file, please fix.
- open(STAT,"/proc/$$/stat");
- my $line = <STAT>;
- chop $line;
- my @data = split(/ /, $line);
- close STAT;
-
- # utime(13) + stime(14).
- my $cpu_usage = sprintf("%.01f", ($data[13]+$data[14]) / 100 );
- # cutime(15) + cstime (16).
- my $cpu_usage2 = sprintf("%.01f", ($data[15]+$data[16]) / 100 );
- my $time = time() - $^T;
- my $raw_perc = $cpu_usage*100/$time;
- 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) );
-
- &performStrictReply("Total CPU usage: \002$cpu_usage\002 s ... ".
- "Total used: \002$total\002 % ".
- "(parent/child ratio: $ratio %)"
- );
-
- return;
- }
-
- # ircstats.
- if ($message =~ /^ircstats?$/i) {
- $ircstats{'TotalTime'} ||= 0;
- $ircstats{'OffTime'} ||= 0;
-
- my $count = $ircstats{'ConnectCount'};
- my $format_time = &Time2String(time() - $ircstats{'ConnectTime'});
- my $total_time = time() - $ircstats{'ConnectTime'} +
- $ircstats{'TotalTime'};
- my $reply;
-
- my $connectivity = 100 * ($total_time - $ircstats{'OffTime'}) /
- $total_time;
- my $p = sprintf("%.03f", $connectivity);
- $p =~ s/(\.\d*)0+$/$1/;
- if ($p =~ s/\.0$//) {
- # this should not happen... but why...
- } else {
- $p =~ s/\.$//
- }
-
- if ($total_time != (time() - $ircstats{'ConnectTime'}) ) {
- my $tt_format = &Time2String($total_time);
- &DEBUG("tt_format => $tt_format");
- }
-
- ### RECONNECT COUNT.
- if ($count == 1) { # good.
- $reply = "I'm connected to $ircstats{'Server'} and have been so".
- " for $format_time";
- } else {
- $reply = "Currently I'm hooked up to $ircstats{'Server'} but only".
- " for $format_time. ".
- "I had to reconnect \002$count\002 times.".
- " Connectivity: $p %";
- }
-
- ### REASON.
- my $reason = $ircstats{'DisconnectReason'};
- if (defined $reason) {
- $reply .= ". I was last disconnected for '$reason'.";
- }
-
- &performStrictReply($reply);
-
- return;
- }
-
- # status.
- if ($message =~ /^statu?s$/i) {
- my $startString = scalar(gmtime $^T);
- my $upString = &Time2String(time() - $^T);
- my ($puser,$psystem,$cuser,$csystem) = times;
- my $factoids = &countKeys('factoids');
- my $forks = 0;
- foreach (keys %forked) {
- $forks += scalar keys %{ $forked{$_} };
- }
- $forks /= 2;
- $count{'Commands'} = 0;
- foreach (keys %cmdstats) {
- $count{'Commands'} += $cmdstats{$_};
- }
-
- &performStrictReply(
- "Since $startString, there have been".
- " \002$count{'Update'}\002 ".
- &fixPlural('modification', $count{'Update'}).
- ", \002$count{'Question'}\002 ".
- &fixPlural('question',$count{'Question'}).
- ", \002$count{'Dunno'}\002 ".
- &fixPlural('dunno',$count{'Dunno'}).
- ", \002$count{'Moron'}\002 ".
- &fixPlural('moron',$count{'Moron'}).
- " and \002$count{'Commands'}\002 ".
- &fixPlural('command',$count{'Commands'}).
- ". I have been awake for $upString this session, and ".
- "currently reference \002$factoids\002 factoids. ".
- "I'm using about \002$memusage\002 ".
- "kB of memory. With \002$forks\002 active ".
- &fixPlural('fork',$forks).
- ". Process time user/system $puser/$psystem child $cuser/$csystem"
- );
-
- return;
- }
-
- # wantNick. xk++
- # FIXME does not try to get nick 'back', just switches nicks
- if ($message =~ /^wantNick\s(.*)?$/i) {
- return unless (&hasFlag('o'));
- my $wantnick = lc $1;
- my $mynick = $conn->nick();
-
- if ($mynick eq $wantnick) {
- &msg($who, "I hope you're right. I'll try anyway (mynick=$mynick, wantnick=$wantnick).");
- }
-
- # fallback check, I guess. needed?
- if (! &IsNickInAnyChan( $wantnick ) ) {
- my $str = "attempting to change nick from $mynick to $wantnick";
- &status($str);
- &msg($who, $str);
- &nick($wantnick);
- return;
- }
-
- # idea from dondelecarlo :)
- # TODO: use cache{nickserv}
- if ($param{'nickServ_pass'}) {
- my $str = "someone is using nick $wantnick; GHOSTing";
- &status($str);
- &msg($who, $str);
- &msg('NickServ', "GHOST $wantnick $param{'nickServ_pass'}");
-
- $conn->schedule(5, sub {
- &status("going to change nick from $mynick to $wantnick after GHOST.");
- &nick($wantnick);
- } );
-
- return;
- }
-
- return;
- }
-
- return 'CONTINUE';
-}
-
-1;
+++ /dev/null
-#
-# core.pl: Important functions stuff...
-# Author: dms
-# Version: v0.4 (20000718)
-# Created: 20000322
-#
-
-use strict;
-
-# scalar. MUST BE REDUCED IN SIZE!!!
-### TODO: reorder.
-use vars qw(
- $bot_misc_dir $bot_pid $bot_base_dir $bot_src_dir
- $bot_data_dir $bot_config_dir $bot_state_dir $bot_run_dir
- $answer $correction_plausible $talkchannel $bot_release
- $statcount $memusage $user $memusageOld $bot_version $dbh
- $shm $host $msg $noreply $conn $irc $learnok $nick $ident
- $force_public_reply $addrchar $userHandle $addressedother
- $floodwho $chan $msgtime $server $firsttime $wingaterun
- $flag_quit $msgType $no_syscall
- $utime_userfile $wtime_userfile $ucount_userfile
- $utime_chanfile $wtime_chanfile $ucount_chanfile
- $pubsize $pubcount $pubtime
- $msgsize $msgcount $msgtime
- $notsize $notcount $nottime
- $running
-);
-
-# array.
-use vars qw(@ircServers @wingateBad @wingateNow @wingateCache
-);
-
-### hash. MUST BE REDUCED IN SIZE!!!
-#
-use vars qw(%count %netsplit %netsplitservers %flood %dcc %orig
- %nuh %talkWho %seen %floodwarn %param %dbh %ircPort
- %topic %moduleAge %last %time %mask %file
- %forked %chanconf %channels %cache
-);
-
-# Signals.
-$SIG{'HUP'} = 'restart'; # 1.
-$SIG{'INT'} = 'doExit'; # 2.
-$SIG{'KILL'} = 'doExit'; # 9. DOES NOT WORK. 'man perlipc' for details.
-$SIG{'TERM'} = 'doExit'; # 15.
-$SIG{'__WARN__'} = 'doWarn';
-
-# initialize variables.
-$last{buflen} = 0;
-$last{say} = '';
-$last{msg} = '';
-$userHandle = "_default";
-$wingaterun = time();
-$firsttime = 1;
-$utime_userfile = 0;
-$wtime_userfile = 0;
-$ucount_userfile = 0;
-$utime_chanfile = 0;
-$wtime_chanfile = 0;
-$ucount_chanfile = 0;
-$running = 0;
-### more variables...
-# static scalar variables.
-$mask{ip} = '(\d+)\.(\d+)\.(\d+)\.(\d+)';
-$mask{host} = '[\d\w\_\-\/]+\.[\.\d\w\_\-\/]+';
-$mask{chan} = '[\#\&]\S*|_default';
-my $isnick1 = 'a-zA-Z\[\]\{\}\_\`\^\|\\\\';
-my $isnick2 = '0-9\-';
-$mask{nick} = "[$isnick1]{1}[$isnick1$isnick2]*";
-$mask{nuh} = '\S*!\S*\@\S*';
-$msgtime = time();
-$msgsize = 0;
-$msgcount = 0;
-$pubtime = 0;
-$pubsize = 0;
-$pubcount = 0;
-$nottime = 0;
-$notsize = 0;
-$notcount = 0;
-###
-$bot_release = "1.3.3";
-if ( -d 'CVS' ) {
- use POSIX qw(strftime);
- $bot_release .= strftime(" cvs (%Y%m%d)", gmtime( (stat('CVS'))[9] ) );
-}
-$bot_version = "blootbot $bot_release -- $^O";
-$noreply = 'NOREPLY';
-
-##########
-### misc commands.
-###
-
-sub whatInterface {
- if (!&IsParam('Interface') or $param{'Interface'} =~ /IRC/) {
- return 'IRC';
- } else {
- return 'CLI';
- }
-}
-
-sub doExit {
- my ($sig) = @_;
-
- if (defined $flag_quit) {
- &WARN("doExit: quit already called.");
- return;
- }
- $flag_quit = 1;
-
- if (!defined $bot_pid) { # independent.
- exit 0;
- } elsif ($bot_pid == $$) { # parent.
- &status("parent caught SIG$sig (pid $$).") if (defined $sig);
-
- &status("--- Start of quit.");
- $ident ||= 'blootbot'; # lame hack.
-
- &status("Memory Usage: $memusage KiB");
-
- &closePID();
- &closeStats();
- # shutdown IRC and related components.
- if (&whatInterface() =~ /IRC/) {
- &closeDCC();
- &seenFlush();
- &quit($param{'quitMsg'});
- }
- &writeUserFile();
- &writeChanFile();
- &uptimeWriteFile() if (&IsParam('Uptime'));
- &sqlCloseDB();
- &closeSHM($shm);
-
- if (&IsParam('dumpvarsAtExit')) {
- &loadMyModule('DumpVars');
- &dumpallvars();
- }
- &symdumpAll() if (&IsParam('symdumpAtExit'));
- &closeLog();
- &closeSQLDebug() if (&IsParam('SQLDebug'));
-
- &status("--- QUIT.");
- } else { # child.
- &status("child caught SIG$sig (pid $$).");
- }
-
- exit 0;
-}
-
-sub doWarn {
- $SIG{__WARN__} = sub { warn $_[0]; };
-
- foreach (@_) {
- &WARN("PERL: $_");
- }
-
- $SIG{__WARN__} = 'doWarn'; # ???
-}
-
-# Usage: &IsParam($param);
-# blootbot.config specific.
-sub IsParam {
- my $param = $_[0];
-
- return 0 unless (defined $param);
- return 0 unless (exists $param{$param});
- return 0 unless ($param{$param});
- return 0 if $param{$param} =~ /^false$/i;
- return 1;
-}
-
-#####
-# Usage: &ChanConfList($param)
-# About: gets channels with 'param' enabled. (!!!)
-# Return: array of channels
-sub ChanConfList {
- my $param = $_[0];
- return unless (defined $param);
- my %chan = &getChanConfList($param);
-
- if (exists $chan{_default}) {
- return keys %chanconf;
- } else {
- return keys %chan;
- }
-}
-
-#####
-# Usage: &getChanConfList($param)
-# About: gets channels with 'param' enabled, internal use only.
-# Return: hash of channels
-sub getChanConfList {
- my $param = $_[0];
- my %chan;
-
- return unless (defined $param);
-
- foreach (keys %chanconf) {
- my $chan = $_;
- my @array = grep /^$param$/, keys %{ $chanconf{$chan} };
- #&DEBUG("gCCL param => $param, chan => $chan, keys => " . join(':',keys %{ $chanconf{$chan} }) . " array => " . join(':', @array)) if ($param eq 'whatever');
-
- next unless (scalar @array);
-
- if (scalar @array > 1) {
- &WARN("multiple items found?");
- }
-
- if ($chanconf{$chan}{$param} eq '0') {
- $chan{$chan} = -1;
- } else {
- $chan{$chan} = 1;
- }
- }
-
- return %chan;
-}
-
-#####
-# Usage: &IsChanConf($param);
-# About: Check for 'param' on the basis of channel config.
-# Return: 1 for enabled, 0 for passive disable, -1 for active disable.
-sub IsChanConf {
- my($param) = shift;
-
- # knocked tons of bugs with this! :)
- my $debug = 0; # 1 if ($param eq 'whatever');
-
- if (!defined $param) {
- &WARN("IsChanConf: param == NULL.");
- return 0;
- }
-
- # these should get moved to your .chan file instead of the .config
- # .config items overide any .chan entries
- if (&IsParam($param)) {
- &WARN("ICC: found '$param' option in main config file.");
- return 1;
- }
-
- $chan ||= "_default";
-
- my $old = $chan;
- if ($chan =~ tr/A-Z/a-z/) {
- &WARN("IsChanConf: lowercased chan. ($old)");
- }
-
- ### TODO: VERBOSITY on how chanconf returned 1 or 0 or -1.
- my %chan = &getChanConfList($param);
- my $nomatch = 0;
- if (!defined $msgType) {
- $nomatch++;
- } else {
- $nomatch++ if ($msgType eq '');
- $nomatch++ unless ($msgType =~ /^(public|private)$/i);
- }
-
-### debug purposes only.
-# if ($debug) {
-# &DEBUG("param => $param, msgType => $msgType.");
-# foreach (keys %chan) {
-# &DEBUG(" $_ => $chan{$_}");
-# }
-# }
-
- if ($nomatch) {
- if ($chan{$chan}) {
- &DEBUG("ICC: other: $chan{$chan} (_default/$param)") if ($debug);
- } elsif ($chan{_default}) {
- &DEBUG("ICC: other: $chan{_default} (_default/$param)") if ($debug);
- } else {
- &DEBUG("ICC: other: 0 ($param)") if ($debug);
- }
- return $chan{$chan} || $chan{_default} || 0;
- } elsif ($msgType =~ /^(public|private)$/i) {
- if ($chan{$chan}) {
- &DEBUG("ICC: $msgType: $chan{$chan} ($chan/$param)") if ($debug);
- } elsif ($chan{_default}) {
- &DEBUG("ICC: $msgType: $chan{_default} (_default/$param)") if ($debug);
- } else {
- &DEBUG("ICC: $msgType: 0 ($param)") if ($debug);
- }
- return $chan{$chan} || $chan{_default} || 0;
- }
-
- &DEBUG("ICC: no-match: 0/$param (msgType = $msgType)");
-
- return 0;
-}
-
-#####
-# Usage: &getChanConf($param);
-# About: Retrieve value for 'param' value in current/default chan.
-# Return: scalar for success, undef for failure.
-sub getChanConf {
- my($param,$c) = @_;
-
- if (!defined $param) {
- &WARN("gCC: param == NULL.");
- return 0;
- }
-
- # this looks evil...
- if (0 and !defined $chan) {
- &DEBUG("gCC: ok !chan... doing _default instead.");
- }
-
- $c ||= $chan;
- $c ||= "_default";
- $c = "_default" if ($c eq "*"); # FIXME
- my @c = grep /^\Q$c\E$/i, keys %chanconf;
-
- if (@c) {
- if (0 and $c[0] ne $c) {
- &WARN("c ne chan ($c[0] ne $chan)");
- }
- if (!defined $chanconf{$c[0]}{$param} and ($c ne '_default')) {
- return &getChanConf($param, '_default');
- }
- &DEBUG("gCC: $param,$c \"" . $chanconf{$c[0]}{$param} . '"');
- return $chanconf{$c[0]}{$param};
- }
-
- #&DEBUG("gCC: returning _default... " . $chanconf{"_default"}{$param});
- return $chanconf{"_default"}{$param};
-}
-
-sub getChanConfDefault {
- my($what, $default, $chan) = @_;
- $chan ||= "_default";
-
- if (exists $param{$what}) {
- if (!exists $cache{config}{$what}) {
- &status("config ($chan): backward-compatible option: found param{$what} ($param{$what}) instead of chan option");
- $cache{config}{$what} = 1;
- }
-
- return $param{$what};
- }
- my $val = &getChanConf($what, $chan);
- return $val if (defined $val);
-
- $param{$what} = $default;
- &status("config ($chan): auto-setting param{$what} = $default");
- $cache{config}{$what} = 1;
- return $default;
-}
-
-
-#####
-# Usage: &findChanConf($param);
-# About: Retrieve value for 'param' value from any chan.
-# Return: scalar for success, undef for failure.
-sub findChanConf {
- my($param) = @_;
-
- if (!defined $param) {
- &WARN("param == NULL.");
- return 0;
- }
-
- my $c;
- foreach $c (keys %chanconf) {
- foreach (keys %{ $chanconf{$c} }) {
- next unless (/^$param$/);
-
- return $chanconf{$c}{$_};
- }
- }
-
- return;
-}
-
-sub showProc {
- my ($prefix) = $_[0] || '';
-
- if ($^O eq 'linux') {
- if (!open(IN, "/proc/$$/status")) {
- &ERROR("cannot open '/proc/$$/status'.");
- return;
- }
-
- while (<IN>) {
- $memusage = $1 if (/^VmSize:\s+(\d+) kB/);
- }
- close IN;
-
- } elsif ($^O eq 'netbsd') {
- $memusage = int( (stat "/proc/$$/mem")[7]/1024 );
-
- } elsif ($^O =~ /^(free|open)bsd$/) {
- my @info = split /\s+/, `/bin/ps -l -p $$`;
- $memusage = $info[20];
-
- } else {
- $memusage = 'UNKNOWN';
- return;
- }
-
- if (defined $memusageOld and &IsParam('DEBUG')) {
- # it's always going to be increase.
- my $delta = $memusage - $memusageOld;
- my $str;
- if ($delta == 0) {
- return;
- } elsif ($delta > 500) {
- $str = "MEM:$prefix increased by $delta KiB. (total: $memusage KiB)";
- } elsif ($delta > 0) {
- $str = "MEM:$prefix increased by $delta KiB";
- } else { # delta < 0.
- $delta = -$delta;
- # never knew RSS could decrease, probably Size can't?
- $str = "MEM:$prefix decreased by $delta KiB.";
- }
-
- &status($str);
- }
- $memusageOld = $memusage;
-}
-
-######
-###### SETUP
-######
-
-sub setup {
- &showProc(" (\&openLog before)");
- &openLog(); # write, append.
- &status("--- Started logging.");
-
- # read.
- &loadLang($bot_data_dir. "/blootbot.lang");
- &loadIRCServers();
- &readUserFile();
- &readChanFile();
- &loadMyModulesNow(); # must be after chan file.
-
- $shm = &openSHM();
- &openSQLDebug() if (&IsParam('SQLDebug'));
- &sqlOpenDB($param{'DBName'}, $param{'DBType'}, $param{'SQLUser'},
- $param{'SQLPass'});
- &checkTables();
-
- &status("Setup: ". &countKeys('factoids') ." factoids.");
- &getChanConfDefault('sendPrivateLimitLines', 3, $chan);
- &getChanConfDefault('sendPrivateLimitBytes', 1000, $chan);
- &getChanConfDefault('sendPublicLimitLines', 3, $chan);
- &getChanConfDefault('sendPublicLimitBytes', 1000, $chan);
- &getChanConfDefault('sendNoticeLimitLines', 3, $chan);
- &getChanConfDefault('sendNoticeLimitBytes', 1000, $chan);
-
- $param{tempDir} =~ s#\~/#$ENV{HOME}/#;
-
- &status("Initial memory usage: $memusage KiB");
- &status("-------------------------------------------------------");
-}
-
-sub setupConfig {
- $param{'VERBOSITY'} = 1;
- &loadConfig($bot_config_dir."/blootbot.config");
-
- foreach ( qw(ircNick ircUser ircName DBType tempDir) ) {
- next if &IsParam($_);
- &ERROR("Parameter $_ has not been defined.");
- exit 1;
- }
-
- if ($param{tempDir} =~ s#\~/#$ENV{HOME}/#) {
- &VERB("Fixing up tempDir.",2);
- }
-
- if ($param{tempDir} =~ /~/) {
- &ERROR("parameter tempDir still contains tilde.");
- exit 1;
- }
-
- if (! -d $param{tempDir}) {
- &status("making $param{tempDir}...");
- mkdir $param{tempDir}, 0755;
- }
-
- # static scalar variables.
- $file{utm} = "$bot_state_dir/$param{'ircUser'}.uptime";
- $file{PID} = "$bot_run_dir/$param{'ircUser'}.pid";
-}
-
-sub startup {
- if (&IsParam('DEBUG')) {
- &status("enabling debug diagnostics.");
- # I thought disabling this reduced memory usage by 1000 KiB.
- use diagnostics;
- }
-
- $count{'Question'} = 0;
- $count{'Update'} = 0;
- $count{'Dunno'} = 0;
- $count{'Moron'} = 0;
-}
-
-sub shutdown {
- my ($sig) = @_;
- # reverse order of &setup().
- &status("--- shutdown called.");
-
- # hack.
- $ident ||= 'blootbot';
-
- if (!&isFileUpdated("$bot_state_dir/blootbot.users", $wtime_userfile)) {
- &writeUserFile()
- }
-
- if (!&isFileUpdated("$bot_state_dir/blootbot.chan", $wtime_chanfile)) {
- &writeChanFile();
- }
-
- &sqlCloseDB();
- # aswell. TODO: use this in &doExit?
- &closeSHM($shm);
- &closeLog();
-}
-
-sub restart {
- my ($sig) = @_;
-
- if ($$ == $bot_pid) {
- &status("--- $sig called.");
-
- ### crappy bug in Net::IRC?
- my $delta = time() - $msgtime;
- &DEBUG("restart: dtime = $delta");
- if (!$conn->connected or time() - $msgtime > 900) {
- &status("reconnecting because of uncaught disconnect \@ ".scalar(gmtime) );
-### $irc->start;
- &clearIRCVars();
- $conn->connect();
-### return;
- }
-
- &ircCheck(); # heh, evil!
-
- &DCCBroadcast("-HUP called.",'m');
- &shutdown($sig);
- &loadConfig($bot_config_dir."/blootbot.config");
- &reloadAllModules() if (&IsParam('DEBUG'));
- &setup();
-
- &status("--- End of $sig.");
- } else {
- &status("$sig called; ignoring restart.");
- }
-}
-
-# File: Configuration.
-sub loadConfig {
- my ($file) = @_;
-
- if (!open(FILE, $file)) {
- &ERROR("Failed to read configuration file ($file): $!");
- &status("Please read the INSTALL file on how to install and setup this file.");
- exit 0;
- }
-
- my $count = 0;
- while (<FILE>) {
- chomp;
- next if /^\s*\#/;
- next unless /\S/;
- my ($set,$key,$val) = split(/\s+/, $_, 3);
-
- if ($set ne 'set') {
- &status("loadConfig: invalid line '$_'.");
- next;
- }
-
- # perform variable interpolation
- $val =~ s/(\$(\w+))/$param{$2}/g;
-
- $param{$key} = $val;
-
- ++$count;
- }
- close FILE;
-
- $file =~ s/^.*\///;
- &status("Loaded config $file ($count items)");
-}
-
-1;
+++ /dev/null
-#
-# dbi.pl: DBI (mysql/pgsql/sqlite) database frontend.
-# Author: dms
-# Version: v0.9a (20021124)
-# Created: 19991203
-# Notes: based on db_mysql.pl
-# overhauled to be 31337.
-#
-
-use strict;
-
-use vars qw(%param);
-use vars qw($dbh $shm $bot_data_dir);
-
-package main;
-
-#####
-# &sqlOpenDB($dbname, $dbtype, $sqluser, $sqlpass, $nofail);
-sub sqlOpenDB {
- my ($db, $type, $user, $pass, $no_fail) = @_;
- # this is a mess. someone fix it, please.
- if ($type =~ /^SQLite(2)?$/i) {
- $db = "dbname=$db.sqlite";
- } elsif ($type =~ /^pg/i) {
- $db = "dbname=$db";
- $type = 'Pg';
- }
-
- my $dsn = "DBI:$type:$db";
- my $hoststr = '';
- # SQLHost should be unset for SQLite
- if (exists $param{'SQLHost'} and $param{'SQLHost'}) {
- # PostgreSQL requires ";" and keyword 'host'. See perldoc Pg -- troubled
- if ($type eq 'Pg') {
- $dsn .= ";host=$param{SQLHost}";
- } else {
- $dsn .= ":$param{SQLHost}";
- }
- $hoststr = " to $param{'SQLHost'}";
- }
- # SQLite ignores $user and $pass
- $dbh = DBI->connect($dsn, $user, $pass);
-
- if ($dbh && !$dbh->err) {
- &status("Opened $type connection$hoststr");
- } else {
- &ERROR("Cannot connect$hoststr.");
- &ERROR("Since $type is not available, shutting down bot!");
- &ERROR( $dbh->errstr ) if ($dbh);
- &closePID();
- &closeSHM($shm);
- &closeLog();
-
- return 0 if ($no_fail);
-
- exit 1;
- }
-}
-
-sub sqlCloseDB {
- return 0 unless ($dbh);
-
- my $x = $param{SQLHost};
- my $hoststr = ($x) ? " to $x" : '';
-
- &status("Closed DBI connection$hoststr.");
- $dbh->disconnect();
-
- return 1;
-}
-
-#####
-# Usage: &sqlQuote($str);
-sub sqlQuote {
- return $dbh->quote($_[0]);
-}
-
-#####
-# Usage: &sqlSelectMany($table, $select, [$where_href], [$other]);
-# Return: $sth (Statement handle object)
-sub sqlSelectMany {
- my($table, $select, $where_href, $other) = @_;
- my $query = "SELECT $select FROM $table";
- my $sth;
-
- if (!defined $select or $select =~ /^\s*$/) {
- &WARN("sqlSelectMany: select == NULL.");
- return;
- }
-
- if (!defined $table or $table =~ /^\s*$/) {
- &WARN("sqlSelectMany: table == NULL.");
- return;
- }
-
- if ($where_href) {
- my $where = &hashref2where($where_href);
- $query .= " WHERE $where" if ($where);
- }
- $query .= " $other" if ($other);
-
- if (!($sth = $dbh->prepare($query))) {
- &ERROR("sqlSelectMany: prepare: $DBI::errstr");
- return;
- }
-
- &SQLDebug($query);
-
- return if (!$sth->execute);
-
- return $sth;
-}
-
-#####
-# Usage: &sqlSelect($table, $select, [$where_href, [$other]);
-# Return: scalar if one element, array if list of elements.
-# Note: Suitable for one column returns, that is, one column in $select.
-# Todo: Always return array?
-sub sqlSelect {
- my $sth = &sqlSelectMany(@_);
- if (!defined $sth) {
- &WARN("sqlSelect failed.");
- return;
- }
- my @retval = $sth->fetchrow_array;
- $sth->finish;
-
- if (scalar @retval > 1) {
- return @retval;
- } elsif (scalar @retval == 1) {
- return $retval[0];
- } else {
- return;
- }
-}
-
-#####
-# Usage: &sqlSelectColArray($table, $select, [$where_href], [$other]);
-# Return: array.
-sub sqlSelectColArray {
- my $sth = &sqlSelectMany(@_);
- my @retval;
-
- if (!defined $sth) {
- &WARN("sqlSelect failed.");
- return;
- }
-
- while (my @row = $sth->fetchrow_array) {
- push(@retval, $row[0]);
- }
- $sth->finish;
-
- return @retval;
-}
-
-#####
-# Usage: &sqlSelectColHash($table, $select, [$where_href], [$other], [$type]);
-# Return: type = 1: $retval{ col2 }{ col1 } = 1;
-# Return: no type: $retval{ col1 } = col2;
-# Note: does not support $other, yet.
-sub sqlSelectColHash {
- my ($table, $select, $where_href, $other, $type) = @_;
- my $sth = &sqlSelectMany($table, $select, $where_href, $other);
- if (!defined $sth) {
- &WARN("sqlSelectColhash failed.");
- return;
- }
- my %retval;
-
- if (defined $type and $type == 2) {
- &DEBUG("sqlSelectColHash: type 2!");
- while (my @row = $sth->fetchrow_array) {
- $retval{$row[0]} = join(':', $row[1..$#row]);
- }
- &DEBUG("sqlSelectColHash: count => ".scalar(keys %retval) );
-
- } elsif (defined $type and $type == 1) {
- while (my @row = $sth->fetchrow_array) {
- # reverse it to make it easier to count.
- 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) {
- $retval{$row[0]} = $row[1];
- }
- }
-
- $sth->finish;
-
- return %retval;
-}
-
-#####
-# Usage: &sqlSelectRowHash($table, $select, [$where_href]);
-# Return: $hash{ col } = value;
-# Note: useful for returning only one/first row of data.
-sub sqlSelectRowHash {
- my $sth = &sqlSelectMany(@_);
- if (!defined $sth) {
- &WARN("sqlSelectRowHash failed.");
- return;
- }
- my $retval = $sth->fetchrow_hashref();
- $sth->finish;
-
- if ($retval) {
- return %{ $retval };
- } else {
- return;
- }
-}
-
-#
-# End of SELECT functions.
-#
-
-#####
-# Usage: &sqlSet($table, $where_href, $data_href);
-# Return: 1 for success, undef for failure.
-sub sqlSet {
- my ($table, $where_href, $data_href) = @_;
-
- if (!defined $table or $table =~ /^\s*$/) {
- &WARN("sqlSet: table == NULL.");
- return;
- }
-
- if (!defined $data_href or ref($data_href) ne 'HASH') {
- &WARN("sqlSet: data_href == NULL.");
- return;
- }
-
- # any column can be NULL... so just get them all.
- my $k = join(',', keys %{ $where_href } );
- my $result = &sqlSelect($table, $k, $where_href);
-# &DEBUG("result is not defined :(") if (!defined $result);
-
- # this was hardwired to use sqlUpdate. sqlite does not do inserts on sqlUpdate.
- if (defined $result) {
- &sqlUpdate($table, $data_href, $where_href);
- } else {
- # hack.
- my %hash = %{ $where_href };
- # add data_href values...
- foreach (keys %{ $data_href }) {
- $hash{ $_ } = ${ $data_href }{$_};
- }
-
- $data_href = \%hash;
- &sqlInsert($table, $data_href);
- }
-
- return 1;
-}
-
-#####
-# Usage: &sqlUpdate($table, $data_href, $where_href);
-sub sqlUpdate {
- my ($table, $data_href, $where_href) = @_;
-
- if (!defined $data_href or ref($data_href) ne 'HASH') {
- &WARN("sqlSet: data_href == NULL.");
- return 0;
- }
-
- my $where = &hashref2where($where_href) if ($where_href);
- my $update = &hashref2update($data_href) if ($data_href);
-
- &sqlRaw('Update', "UPDATE $table SET $update WHERE $where");
-
- return 1;
-}
-
-#####
-# Usage: &sqlInsert($table, $data_href, $other);
-sub sqlInsert {
- my ($table, $data_href, $other) = @_;
- # note: if $other == 1, add 'DELAYED' to function instead.
- # note: ^^^ doesnt actually do anything lol. Need code to s/1/DELAYED/ below -- troubled
-
- if (!defined $data_href or ref($data_href) ne 'HASH') {
- &WARN("sqlInsert: data_href == NULL.");
- return;
- }
-
- my ($k_aref, $v_aref) = &hashref2array($data_href);
- my @k = @{ $k_aref };
- my @v = @{ $v_aref };
-
- if (!@k or !@v) {
- &WARN("sqlInsert: keys or vals is NULL.");
- return;
- }
-
- return &sqlRaw("Insert($table)", sprintf(
- "INSERT %s INTO %s (%s) VALUES (%s)",
- ($other || ''), $table, join(',',@k), join(',',@v)
- ) );
-}
-
-#####
-# Usage: &sqlReplace($table, $data_href, [$pkey]);
-sub sqlReplace {
- my ($table, $data_href, $pkey) = @_;
-
- if (!defined $data_href or ref($data_href) ne 'HASH') {
- &WARN("sqlReplace: data_href == NULL.");
- return;
- }
-
- my ($k_aref, $v_aref) = &hashref2array($data_href);
- my @k = @{ $k_aref };
- my @v = @{ $v_aref };
-
- if (!@k or !@v) {
- &WARN("sqlReplace: keys or vals is NULL.");
- return;
- }
-
-
- if ($param{'DBType'} =~ /^pgsql$/i) {
- # OK, heres the scoop. There is currently no REPLACE INTO in Pgsql.
- # However, the bot already seems to search for factoids before insert
- # anyways. Perhaps we could change this to a generic INSERT INTO so
- # we can skip the seperate sql? -- troubled to: TimRiker
- # PGSql syntax: UPDATE table SET key = 'value', key2 = 'value2' WHERE key = 'value'
-
-# &sqlRaw("Replace($table)", sprintf(
-# "INSERT INTO %s (%s) VALUES (%s)",
-# $table, join(',',@k), join(',',@v)
-# ));
- &WARN("DEBUG: ($pkey = ) " . sprintf(
- "REPLACE INTO %s (%s) VALUES (%s)",
- $table, join(',',@k), join(',',@v)
- ));
-
- } else {
- &sqlRaw("Replace($table)", sprintf(
- "REPLACE INTO %s (%s) VALUES (%s)",
- $table, join(',',@k), join(',',@v)
- ));
- }
-
- return 1;
-}
-
-#####
-# Usage: &sqlDelete($table, $where_href);
-sub sqlDelete {
- my ($table, $where_href) = @_;
-
- if (!defined $where_href or ref($where_href) ne 'HASH') {
- &WARN("sqlDelete: where_href == NULL.");
- return;
- }
-
- my $where = &hashref2where($where_href);
-
- &sqlRaw('Delete', "DELETE FROM $table WHERE $where");
-
- return 1;
-}
-
-#####
-# Usage: &sqlRaw($prefix, $query);
-# Return: 1 for success, 0 for failure.
-sub sqlRaw {
- my ($prefix, $query) = @_;
- my $sth;
-
- if (!defined $query or $query =~ /^\s*$/) {
- &WARN("sqlRaw: query == NULL.");
- return 0;
- }
-
- if (!($sth = $dbh->prepare($query))) {
- &ERROR("Raw($prefix): !prepare => '$query'");
- return 0;
- }
-
- &SQLDebug($query);
- if (!$sth->execute) {
- &ERROR("Raw($prefix): !execute => '$query'");
- $sth->finish;
- return 0;
- }
-
- $sth->finish;
-
- return 1;
-}
-
-#####
-# Usage: &sqlRawReturn($query);
-# Return: array.
-sub sqlRawReturn {
- my ($query) = @_;
- my @retval;
- my $sth;
-
- if (!defined $query or $query =~ /^\s*$/) {
- &WARN("sqlRawReturn: query == NULL.");
- return 0;
- }
-
- if (!($sth = $dbh->prepare($query))) {
- &ERROR("RawReturn: !prepare => '$query'");
- return 0;
- }
-
- &SQLDebug($query);
- if (!$sth->execute) {
- &ERROR("RawReturn: !execute => '$query'");
- $sth->finish;
- return 0;
- }
-
- while (my @row = $sth->fetchrow_array) {
- push(@retval, $row[0]);
- }
-
- $sth->finish;
-
- return @retval;
-}
-
-####################################################################
-##### Misc DBI stuff...
-#####
-
-sub hashref2where {
- my ($href) = @_;
-
- if (!defined $href) {
- &WARN("hashref2where: href == NULL.");
- return;
- }
-
- if (ref($href) ne 'HASH') {
- &WARN("hashref2where: href is not HASH ref (href => $href)");
- return;
- }
-
- my %hash = %{ $href };
- foreach (keys %hash) {
- my $v = $hash{$_};
-
- if (s/^-//) { # as is.
- $hash{$_} = $v;
- delete $hash{'-'.$_};
- } else {
- $hash{$_} = &sqlQuote($v);
- }
- }
-
- return join(' AND ', map { $_."=".$hash{$_} } keys %hash );
-}
-
-sub hashref2update {
- my ($href) = @_;
-
- if (ref($href) ne 'HASH') {
- &WARN("hashref2update: href is not HASH ref.");
- return;
- }
-
- my %hash;
- foreach (keys %{ $href }) {
- my $k = $_;
- my $v = ${ $href }{$_};
-
- # is there a better way to do this?
- if ($k =~ s/^-//) { # as is.
- 1;
- } else {
- $v = &sqlQuote($v);
- }
-
- $hash{$k} = $v;
- }
-
- return join(', ', map { $_."=".$hash{$_} } sort keys %hash);
-}
-
-sub hashref2array {
- my ($href) = @_;
-
- if (ref($href) ne 'HASH') {
- &WARN("hashref2update: href is not HASH ref.");
- return;
- }
-
- my(@k, @v);
- foreach (keys %{ $href }) {
- my $k = $_;
- my $v = ${ $href }{$_};
-
- # is there a better way to do this?
- if ($k =~ s/^-//) { # as is.
- 1;
- } else {
- $v = &sqlQuote($v);
- }
-
- push(@k, $k);
- push(@v, $v);
- }
-
- return (\@k, \@v);
-}
-
-#####
-# Usage: &countKeys($table, [$col]);
-sub countKeys {
- my ($table, $col) = @_;
- $col ||= '*';
-
- return (&sqlRawReturn("SELECT count($col) FROM $table"))[0];
-}
-
-#####
-# Usage: &sumKey($table, $col);
-sub sumKey {
- my ($table, $col) = @_;
-
- return (&sqlRawReturn("SELECT sum($col) FROM $table"))[0];
-}
-
-#####
-# Usage: &randKey($table, $select);
-sub randKey {
- my ($table, $select) = @_;
- my $rand = int(rand(&countKeys($table)));
- my $query = "SELECT $select FROM $table LIMIT 1 OFFSET $rand";
- if ($param{DBType} =~ /^mysql$/i) {
- # WARN: only newer MySQL supports "LIMIT limit OFFSET offset"
- $query = "SELECT $select FROM $table LIMIT $rand,1";
- }
- my $sth = $dbh->prepare($query);
- &SQLDebug($query);
- &WARN("randKey($query)") unless $sth->execute;
- my @retval = $sth->fetchrow_array;
- $sth->finish;
-
- return @retval;
-}
-
-#####
-# Usage: &deleteTable($table);
-sub deleteTable {
- &sqlRaw("deleteTable($_[0])", "DELETE FROM $_[0]");
-}
-
-#####
-# Usage: &searchTable($table, $select, $key, $str);
-# Note: searchTable does sqlQuote.
-sub searchTable {
- my($table, $select, $key, $str) = @_;
- my $origStr = $str;
- my @results;
-
- # allow two types of wildcards.
- if ($str =~ /^\^(.*)\$$/) {
- &FIXME("searchTable: can't do \"$str\"");
- $str = $1;
- } else {
- $str .= "%" if ($str =~ s/^\^//);
- $str = "%".$str if ($str =~ s/\$$//);
- $str = "%".$str."%" if ($str eq $origStr); # el-cheapo fix.
- }
-
- $str =~ s/\_/\\_/g;
- $str =~ s/\?/_/g; # '.' should be supported, too.
- $str =~ s/\*/%/g;
- # end of string fix.
-
- my $query = "SELECT $select FROM $table WHERE $key LIKE ".
- &sqlQuote($str);
- my $sth = $dbh->prepare($query);
-
- &SQLDebug($query);
- if (!$sth->execute) {
- &WARN("Search($query)");
- $sth->finish;
- return;
- }
-
- while (my @row = $sth->fetchrow_array) {
- push(@results, $row[0]);
- }
- $sth->finish;
-
- return @results;
-}
-
-sub sqlCreateTable {
- my($table, $dbtype) = @_;
- my(@path) = ($bot_data_dir, ".","..","../..");
- my $found = 0;
- my $data;
- $dbtype = lc $dbtype;
-
- foreach (@path) {
- my $file = "$_/setup/$dbtype/$table.sql";
- next unless ( -f $file );
-
- open(IN, $file);
- while (<IN>) {
- chop;
- next if $_ =~ /^--/;
- $data .= $_;
- }
-
- $found++;
- last;
- }
-
- if (!$found) {
- return 0;
- } else {
- &sqlRaw("sqlCreateTable($table)", $data);
- return 1;
- }
-}
-
-sub checkTables {
- my $database_exists = 0;
- my %db;
-
- if ($param{DBType} =~ /^mysql$/i) {
- my $sql = "SHOW DATABASES";
- foreach ( &sqlRawReturn($sql) ) {
- $database_exists++ if ($_ eq $param{'DBName'});
- }
-
- unless ($database_exists) {
- &status("Creating database $param{DBName}...");
- my $query = "CREATE DATABASE $param{DBName}";
- &sqlRaw("create(db $param{DBName})", $query);
- }
-
- # retrieve a list of db's from the server.
- my @tables = map {s/^\`//; s/\`$//; $_;} $dbh->func('_ListTables');
- if ($#tables == -1){
- @tables = $dbh->tables;
- }
- &status("Tables: ".join(',',@tables));
- @db{@tables} = (1) x @tables;
-
- } elsif ($param{DBType} =~ /^SQLite(2)?$/i) {
-
- # retrieve a list of db's from the server.
- foreach ( &sqlRawReturn("SELECT name FROM sqlite_master WHERE type='table'") ) {
- $db{$_} = 1;
- }
-
- # create database not needed for SQLite
-
- } elsif ($param{DBType} =~ /^pgsql$/i) {
- # $sql_showDB = SQL to select the DB list
- # $sql_showTBL = SQL to select all tables for the current connection
-
- my $sql_showDB = "SELECT datname FROM pg_database";
- my $sql_showTBL = "SELECT tablename FROM pg_tables \
- WHERE schemaname = 'public'";
-
- foreach ( &sqlRawReturn($sql_showDB) ) {
- $database_exists++ if ($_ eq $param{'DBName'});
- }
-
- unless ($database_exists) {
- &status("Creating PostgreSQL database $param{'DBName'}");
- &status("(actually, not really, please read the INSTALL file)");
- }
-
- # retrieve a list of db's from the server. This code is from mysql above, please check -- troubled
- my @tables = map {s/^\`//; s/\`$//; $_;} &sqlRawReturn($sql_showTBL);
- if ($#tables == -1){
- @tables = $dbh->tables;
- }
- &status("Tables: ".join(',',@tables));
- @db{@tables} = (1) x @tables;
- }
-
- foreach ( qw(botmail connections factoids rootwarn seen stats onjoin) ) {
- if (exists $db{$_}) {
- $cache{has_table}{$_} = 1;
- next;
- }
-
- &status("checkTables: creating new table $_...");
-
- $cache{create_table}{$_} = 1;
-
- &sqlCreateTable($_, $param{DBType});
- }
-}
-
-1;
+++ /dev/null
-#
-# logger.pl: logger functions!
-# Author: dms
-# Version: v0.4 (20000923)
-# FVersion: 19991205
-# NOTE: Based on code by Kevin Lenzo & Patrick Cole (c) 1997
-#
-
-use strict;
-
-use vars qw($statcount $bot_pid $forkedtime $statcountfix $addressed);
-use vars qw($logDate $logold $logcount $logtime $logrepeat $running);
-use vars qw(@backlog);
-use vars qw(%param %file %cache);
-
-$logtime = time();
-$logcount = 0;
-$logrepeat = 0;
-$logold = '';
-
-$param{VEBOSITY} ||= 1; # lame fix for preload
-
-my %attributes = (
- 'clear' => 0,
- 'reset' => 0,
- 'bold' => 1,
- 'underline' => 4,
- 'underscore' => 4,
- 'blink' => 5,
- 'reverse' => 7,
- 'concealed' => 8,
- 'black' => 30, 'on_black' => 40,
- 'red' => 31, 'on_red' => 41,
- 'green' => 32, 'on_green' => 42,
- 'yellow' => 33, 'on_yellow' => 43,
- 'blue' => 34, 'on_blue' => 44,
- 'magenta' => 35, 'on_magenta' => 45,
- 'cyan' => 36, 'on_cyan' => 46,
- 'white' => 37, 'on_white' => 47
-);
-
-use vars qw($b_black $_black $b_red $_red $b_green $_green
- $b_yellow $_yellow $b_blue $_blue $b_magenta $_magenta
- $b_cyan $_cyan $b_white $_white $_reset $_bold $ob $b);
-
-$b_black = cl('bold black'); $_black = cl('black');
-$b_red = cl('bold red'); $_red = cl('red');
-$b_green = cl('bold green'); $_green = cl('green');
-$b_yellow = cl('bold yellow'); $_yellow = cl('yellow');
-$b_blue = cl('bold blue'); $_blue = cl('blue');
-$b_magenta = cl('bold magenta'); $_magenta = cl('magenta');
-$b_cyan = cl('bold cyan'); $_cyan = cl('cyan');
-$b_white = cl('bold white'); $_white = cl('white');
-$_reset = cl('reset'); $_bold = cl('bold');
-$ob = cl('reset'); $b = cl('bold');
-
-############################################################################
-# Implementation (attribute string form)
-############################################################################
-
-# Return the escape code for a given set of color attributes.
-sub cl {
- my @codes = map { split } @_;
- my $attribute = '';
- foreach (@codes) {
- $_ = lc $_;
- unless (defined $attributes{$_}) { die "Invalid attribute name $_" }
- $attribute .= $attributes{$_} . ';';
- }
- chop $attribute;
- ($attribute ne '') ? "\e[${attribute}m" : undef;
-}
-
-# logging support.
-sub openLog {
- return unless (&IsParam('logfile'));
- $file{log} = $param{'logfile'};
-
- my $error = 0;
- my $path = &getPath($file{log});
- while (! -d $path) {
- if ($error) {
- &ERROR("openLog: failed opening log to $file{log}; disabling.");
- delete $param{'logfile'};
- return;
- }
-
- &status("openLog: making $path.");
- last if (mkdir $path, 0755);
- $error++;
- }
-
- if (&IsParam('logType') and $param{'logType'} =~ /DAILY/i) {
- my ($day,$month,$year) = (gmtime time())[3,4,5];
- $logDate = sprintf("%04d%02d%02d",$year+1900,$month+1,$day);
- $file{log} .= $logDate;
- }
-
- if (open(LOG, ">>$file{log}")) {
- &status("Opened logfile $file{log}.");
- LOG->autoflush(1);
- } else {
- &status("Cannot open logfile ($file{log}); not logging: $!");
- }
-}
-
-sub closeLog {
- # lame fix for paramlogfile.
- return unless (&IsParam('logfile'));
- return unless (defined fileno LOG);
-
- close LOG;
- &status("Closed logfile ($file{log}).");
-}
-
-#####
-# Usage: &compress($file);
-sub compress {
- my ($file) = @_;
- my @compress = ('/usr/bin/bzip2','/bin/bzip2','/bin/gzip');
- my $okay = 0;
-
- if (! -f $file) {
- &WARN("compress: file ($file) does not exist.");
- return 0;
- }
-
- if ( -f "$file.gz" or -f "$file.bz2" ) {
- &WARN("compress: file.(gz|bz2) already exists.");
- return 0;
- }
-
- foreach (@compress) {
- next unless ( -x $_);
-
- &status("Compressing '$file' with $_.");
- system("$_ $file &");
- $okay++;
- last;
- }
-
- if (!$okay) {
- &ERROR("no compress program found.");
- return 0;
- }
-
- return 1;
-}
-
-sub DEBUG {
- return unless (&IsParam('DEBUG'));
-
- &status("${b_green}!DEBUG!$ob $_[0]");
-}
-
-sub ERROR {
- &status("${b_red}!ERROR!$ob $_[0]");
-}
-
-sub WARN {
- return unless (&IsParam('WARN'));
-
- return if ($_[0] =~ /^PERL: Subroutine \S+ redefined at/);
-
- &status("${b_yellow}!WARN!$ob $_[0]");
-}
-
-sub FIXME {
- &status("${b_cyan}!FIXME!$ob $_[0]");
-}
-
-sub TODO {
- &status("${b_cyan}!TODO!$ob $_[0]");
-}
-
-sub VERB {
- if (!&IsParam('VERBOSITY')) {
- # NOTHING.
- } elsif ($param{'VERBOSITY'} eq '1' and $_[1] <= 1) {
- &status($_[0]);
- } elsif ($param{'VERBOSITY'} eq '2' and $_[1] <= 2) {
- &status($_[0]);
- }
-}
-
-sub status {
- my($input) = @_;
- my $status;
-
- if ($input =~ /PERL: Use of uninitialized/) {
- &debug_perl($input);
- return;
- }
-
- if ($input eq $logold) {
- $logrepeat++;
- return;
- }
-
- $logold = $input;
- # if only I had followed how sysklogd does it, heh. lame me. -xk
- if ($logrepeat >= 3) {
- &status("LOG: last message repeated $logrepeat times");
- $logrepeat = 0;
- }
-
- # if it's not a scalar, attempt to warn and fix.
- my $ref = ref $input;
- if (defined $ref and $ref ne '') {
- &WARN("status: 'input' is not scalar ($ref).");
-
- if ($ref eq 'ARRAY') {
- foreach (@$input) {
- &WARN("status: '$_'.");
- }
- }
- }
-
- # Something is using this w/ NULL.
- if (!defined $input or $input =~ /^\s*$/) {
- $input = "ERROR: Blank status call? HELP HELP HELP";
- }
-
- for ($input) {
- s/\n+$//;
- s/\002|\037//g; # bold,video,underline => remove.
- }
-
- # does this work?
- if ($input =~ /\n/) {
- foreach (split /\n/, $input) {
- &status($_);
- }
- }
-
- # pump up the stats.
- $statcount++;
-
- # fix style of output if process is child.
- if (defined $bot_pid and $$ != $bot_pid and !defined $statcountfix) {
- $statcount = 1;
- $statcountfix = 1;
- }
-
- ### LOG THROTTLING.
- ### TODO: move this _after_ printing?
- my $time = time();
- my $reset = 0;
-
- # hrm... what is this supposed to achieve? nothing I guess.
- if ($logtime == $time) {
- if ($logcount < 25) { # too high?
- $logcount++;
- } else {
- sleep 1;
- &status("LOG: Throttling.");
- $reset++;
- }
- } else { # $logtime != $time.
- $reset++;
- }
-
- if ($reset) {
- $logtime = $time;
- $logcount = 0;
- }
-
- # Log differently for forked/non-forked output.
- if ($statcountfix) {
- $status = "!$statcount! ".$input;
- if ($statcount > 1000) {
- print LOG "ERROR: FORKED PROCESS RAN AWAY; KILLING.\n";
- print LOG "VERB: ".(&Time2String($time - $forkedtime))."\n";
- exit 0;
- }
- } else {
- $status = "[$statcount] ".$input;
- }
-
- if (&IsParam('backlog')) {
- push(@backlog, $status); # append to end.
- shift(@backlog) if (scalar @backlog > $param{'backlog'});
- }
-
- if (&IsParam('VERBOSITY')) {
- if ($statcountfix) {
- printf $_red."!%6d!".$ob." ", $statcount;
- } else {
- printf $_green."[%6d]".$ob." ", $statcount;
- }
-
- # three uberstabs to Derek Moeller. I don't remember why but he
- # deserved it :)
- my $printable = $input;
-
- if ($printable =~ s/^(<\/\S+>) //) {
- # it's me saying something on a channel
- my $name = $1;
- print "$b_yellow$name $printable$ob\n";
- } elsif ($printable =~ s/^(<\S+>) //) {
- # public message on channel.
- my $name = $1;
-
- if ($addressed) {
- print "$b_red$name $printable$ob\n";
- } else {
- print "$b_cyan$name$ob $printable$ob\n";
- }
-
- } elsif ($printable =~ s/^\* (\S+)\/(\S+) //) {
- # public action.
- print "$b_white*$ob $b_cyan$1$ob/$b_blue$2$ob $printable\n";
-
- } elsif ($printable =~ s/^(-\S+-) //) {
- # notice
- print "$_green$1 $printable$ob\n";
-
- } elsif ($printable =~ s/^(\* )?(\[\S+\]) //) {
- # message/private action from someone
- print "$b_white$1$ob" if (defined $1);
- print "$b_red$2 $printable$ob\n";
-
- } elsif ($printable =~ s/^(>\S+<) //) {
- # i'm messaging someone
- print "$b_magenta$1 $printable$ob\n";
-
- } elsif ($printable =~ s/^(enter:|update:|forget:) //) {
- # something that should be SEEN
- print "$b_green$1 $printable$ob\n";
-
- } else {
- print "$printable\n";
- }
-
- } else {
- #print "VERBOSITY IS OFF?\n";
- }
-
- # log the line into a file.
- return unless (&IsParam('logfile'));
- return unless (defined fileno LOG);
-
- # remove control characters from logging to LOGFILE.
- for ($input) {
- last if (&IsParam('logColors'));
- s/\e\[[0-9;]+m//g; # escape codes.
- s/[\cA-\c_]//g; # control chars.
- }
- $input = "FORK($$) ".$input if ($statcountfix);
-
- my $date;
- if (&IsParam('logType') and $param{'logType'} =~ /DAILY/i) {
- $date = sprintf("%02d:%02d.%02d", (gmtime $time)[2,1,0]);
-
- my ($day,$month,$year) = (gmtime $time)[3,4,5];
- my $newlogDate = sprintf("%04d%02d%02d",$year+1900,$month+1,$day);
- if (defined $logDate and $newlogDate != $logDate) {
- &closeLog();
- &compress( $file{log} );
- &openLog();
- }
- } else {
- $date = $time;
- }
-
- printf LOG "%s %s\n", $date, $input;
-}
-
-sub debug_perl {
- my ($str) = @_;
-
- return unless ($str =~ /^WARN: Use of uninitialized value .* at (\S+) line (\d+)/);
- my ($file,$line) = ($1,$2);
- if (!open(IN,$file)) {
- &status("WARN: cannot open $file: $!");
- return;
- }
-
- # TODO: better filename.
- open(OUT, ">>debug.log");
- print OUT "DEBUG: $str\n";
-
- # note: cannot call external functions because SIG{} does not allow us to.
- my $i;
- while (<IN>) {
- chop;
- $i++;
- # bleh. this tries to duplicate status().
- # TODO: statcountfix
- # TODO: rename to log_*someshit*
- if ($i == $line) {
- my $msg = "$file: $i:!$_";
- printf "%s[%6d]%s %s\n", $_green, $statcount, $ob, $msg;
- print OUT "DEBUG: $msg\n";
- $statcount++;
- next;
- }
- if ($i+3 > $line && $i-3 < $line) {
- my $msg = "$file: $i: $_";
- printf "%s[%6d]%s %s\n", $_green, $statcount, $ob, $msg;
- print OUT "DEBUG: $msg\n";
- $statcount++;
- }
- }
- close IN;
- close OUT;
-}
-
-sub openSQLDebug {
- if (!open(SQLDEBUG, ">>$param{'SQLDebug'}")) {
- &ERROR("Cannot open ($param{'SQLDebug'}): $!");
- delete $param{'SQLDebug'};
- return 0;
- }
-
- &status("Opened SQL Debug file: $param{'SQLDebug'}");
- return 1;
-}
-
-sub closeSQLDebug {
- close SQLDEBUG;
-
- &status("Closed SQL Debug file: $param{'SQLDebug'}");
-}
-
-sub SQLDebug {
- return unless (&IsParam('SQLDebug'));
-
- return unless (fileno SQLDEBUG);
-
- print SQLDEBUG $_[0]."\n";
-}
-
-1;
+++ /dev/null
-#
-# modules.pl: pseudo-Module handler
-# Author: dms
-# Version: v0.2 (20000629)
-# Created: 20000624
-#
-
-use strict;
-
-use vars qw($AUTOLOAD $no_timehires);
-
-###
-### REQUIRED MODULES.
-###
-
-eval "use IO::Socket";
-if ($@) {
- &ERROR("no IO::Socket?");
- exit 1;
-}
-&showProc(" (IO::Socket)");
-
-### THIS IS NOT LOADED ON RELOAD :(
-my @myModulesLoadNow;
-my @myModulesReloadNot;
-BEGIN {
- @myModulesLoadNow = ('Topic', 'Uptime', 'News', 'RootWarn', 'DumpVars2', 'botmail', 'OnJoin');
- @myModulesReloadNot = ('IRC/Irc.pl','IRC/Schedulers.pl');
-}
-
-sub loadCoreModules {
- my @mods = &getPerlFiles($bot_src_dir);
-
- &status("Loading CORE modules...");
-
- foreach (sort @mods) {
- my $mod = "$bot_src_dir/$_";
-
- eval "require \"$mod\"";
- if ($@) {
- &ERROR("lCM => $@");
- &shutdown();
- exit 1;
- }
-
- $moduleAge{$mod} = (stat $mod)[9];
- &showProc(" ($_)") if (&IsParam('DEBUG'));
- }
-}
-
-sub loadDBModules {
- my $f;
- # TODO: use function to load module.
-
- if ($param{'DBType'} =~ /^(mysql|SQLite(2)?|pgsql)$/i) {
- eval "use DBI";
- if ($@) {
- &ERROR("No support for DBI::" . $param{'DBType'} . ", exiting!");
- exit 1;
- }
- &status("Loading " . $param{'DBType'} . " support.");
- $f = "$bot_src_dir/dbi.pl";
- require $f;
- $moduleAge{$f} = (stat $f)[9];
-
- &showProc(" (DBI::" . $param{'DBType'} . ")");
- } else {
- &WARN("DB support DISABLED.");
- return;
- }
-}
-
-sub loadFactoidsModules {
- if (!&IsParam('factoids')) {
- &status("Factoid support DISABLED.");
- return;
- }
-
- &status("Loading Factoids modules...");
-
- foreach ( &getPerlFiles("$bot_src_dir/Factoids") ) {
- my $mod = "$bot_src_dir/Factoids/$_";
-
- eval "require \"$mod\"";
- if ($@) {
- &ERROR("lFM: $@");
- exit 1;
- }
-
- $moduleAge{$mod} = (stat $mod)[9];
- &showProc(" ($_)") if (&IsParam('DEBUG'));
- }
-}
-
-sub loadIRCModules {
- my ($interface) = &whatInterface();
- if ($interface =~ /IRC/) {
- &status("Loading IRC modules...");
-
- eval "use Net::IRC";
- if ($@) {
- &ERROR("libnet-irc-perl is not installed!");
- exit 1;
- }
- &showProc(" (Net::IRC)");
- } else {
- &status("IRC support DISABLED.");
- # disabling forking. Why?
- #$param{forking} = 0;
- #$param{noSHM} = 1;
- }
-
- foreach ( &getPerlFiles("$bot_src_dir/$interface") ) {
- my $mod = "$bot_src_dir/$interface/$_";
-
- # hrm... use another config option besides DEBUG to display
- # change in memory usage.
- &status("Loading Modules \"$mod\"") if (!&IsParam('DEBUG'));
- eval "require \"$mod\"";
- if ($@) {
- &ERROR("require \"$mod\" => $@");
- &shutdown();
- exit 1;
- }
-
- $moduleAge{$mod} = (stat $mod)[9];
- &showProc(" ($_)") if (&IsParam('DEBUG'));
- }
-}
-
-sub loadMyModulesNow {
- my $loaded = 0;
- my $total = 0;
-
- &status("Loading MyModules...");
- foreach (@myModulesLoadNow) {
- $total++;
- if (!defined $_) {
- &WARN("mMLN: null element.");
- next;
- }
-
- if (!&IsParam($_) and &IsChanConf($_) <= 0 and !&getChanConfList($_)) {
- &DEBUG("loadMyModuleNow: $_ (2) not loaded.");
- next;
- }
-
- &loadMyModule($_);
- $loaded++;
- }
-
- &status("Module: Runtime: Loaded/Total [$loaded/$total]");
-}
-
-### rename to moduleReloadAll?
-sub reloadAllModules {
- my $retval = '';
-
- &VERB("Module: reloading all.",2);
-
- # obscure usage of map and regex :)
- foreach (map { s/.*?\/?src/src/; $_ } keys %moduleAge) {
- $retval .= &reloadModule($_);
- }
-
- &VERB("Module: reloading done.",2);
- return $retval;
-}
-
-### rename to modulesReload?
-sub reloadModule {
- my ($mod) = @_;
- my $file = (grep /\/$mod/, keys %INC)[0];
- my $retval = '';
-
- # don't reload if it's not our module.
- if ($mod =~ /::/ or $mod !~ /pl$/) {
- &VERB("Not reloading $mod.",3);
- return $retval;
- }
-
- if (!defined $file) {
- &WARN("rM: Cannot reload $mod since it was not loaded anyway.");
- return $retval;
- }
-
- if (! -f $file) {
- &ERROR("rM: file '$file' does not exist?");
- return $retval;
- }
-
- if (grep /$mod/, @myModulesReloadNot) {
- &DEBUG("rM: should not reload $mod");
- return $retval;
- }
-
- my $age = (stat $file)[9];
-
- if (!exists $moduleAge{$file}) {
- &DEBUG("Looks like $file was not loaded; fixing.");
- } else {
- return $retval if ($age == $moduleAge{$file});
-
- if ($age < $moduleAge{$file}) {
- &WARN("rM: we're not gonna downgrade '$file'; use touch.");
- &DEBUG("age => $age, mA{$file} => $moduleAge{$file}");
- return $retval;
- }
-
- my $dc = &Time2String($age - $moduleAge{$file});
- my $ago = &Time2String(time() - $moduleAge{$file});
-
- &VERB("Module: delta change: $dc",2);
- &VERB("Module: ago: $ago",2);
- }
-
- &status("Module: Loading $mod...");
-
- delete $INC{$file};
- eval "require \"$file\""; # require or use?
- if (@$) {
- &DEBUG("rM: failure: @$ ");
- } else {
- my $basename = $file;
- $basename =~ s/^.*\///;
- &status("Module: reloaded $basename");
- $retval = " $basename";
- $moduleAge{$file} = $age;
- }
- return $retval;
-}
-
-###
-### OPTIONAL MODULES.
-###
-
-my %perlModulesLoaded = ();
-my %perlModulesMissing = ();
-
-sub loadPerlModule {
- return 0 if (exists $perlModulesMissing{$_[0]});
- &reloadModule($_[0]);
- return 1 if (exists $perlModulesLoaded{$_[0]});
-
- eval "use $_[0]";
- if ($@) {
- &WARN("Module: $_[0] is not installed!");
- $perlModulesMissing{$_[0]} = 1;
- return 0;
- } else {
- $perlModulesLoaded{$_[0]} = 1;
- &status("Loaded $_[0]");
- &showProc(" ($_[0])");
- return 1;
- }
-}
-
-sub loadMyModule {
- my ($modulename) = @_;
- if (!defined $modulename) {
- &WARN("loadMyModule: module is NULL.");
- return 0;
- }
-
- my $modulefile = "$bot_src_dir/Modules/$modulename.pl";
-
- # call reloadModule() which checks age of file and reload.
- if (grep /\/$modulename$/, keys %INC) {
- &reloadModule($modulename);
- return 1; # depend on reloadModule?
- }
-
- if (! -f $modulefile) {
- &ERROR("lMM: module ($modulename) does not exist.");
- if ($$ == $bot_pid) { # parent.
- &shutdown() if (defined $shm and defined $dbh);
- } else { # child.
- &DEBUG("b4 delfork 1");
- &delForked($modulename);
- }
-
- exit 1;
- }
-
- eval "require \"$modulefile\"";
- if ($@) {
- &ERROR("cannot load my module: $modulename");
- if ($bot_pid != $$) { # child.
- &DEBUG("b4 delfork 2");
- &delForked($modulename);
- exit 1;
- }
-
- return 0;
- } else {
- $moduleAge{$modulefile} = (stat $modulefile)[9];
-
- &status("Loaded $modulename");
- &showProc(" ($modulename)");
- return 1;
- }
-}
-
-$no_timehires = 0;
-eval "use Time::HiRes qw(gettimeofday tv_interval)";
-if ($@) {
- &WARN("No Time::HiRes?");
- $no_timehires = 1;
-}
-&showProc(" (Time::HiRes)");
-
-sub AUTOLOAD {
- if (!defined $AUTOLOAD and defined $::AUTOLOAD) {
- &DEBUG("AUTOLOAD: hrm.. ::AUTOLOAD defined!");
- }
- return unless (defined $AUTOLOAD);
- return if ($AUTOLOAD =~ /__/); # internal.
-
- my $str = join(', ', @_);
- my ($package, $filename, $line) = caller;
- &ERROR("UNKNOWN FUNCTION CALLED: $AUTOLOAD ($str) $filename line $line");
-
- $AUTOLOAD =~ s/^(\S+):://g;
-
- # hopefully this will work.
- &DEBUG("Trying to load module $AUTOLOAD...");
- &loadMyModule($AUTOLOAD);
-}
-
-sub getPerlFiles {
- my($dir) = @_;
-
- if (!opendir(DIR, $dir)) {
- &ERROR("Cannot open source directory ($dir): $!");
- exit 1;
- }
-
- my @mods;
- while (defined(my $file = readdir DIR)) {
- next unless $file =~ /\.pl$/;
- next unless $file =~ /^[A-Z]/;
- push(@mods, $file);
- }
- closedir DIR;
-
- return reverse sort @mods;
-}
-
-1;
--- /dev/null
+# Revised: 20071016
+# Author: Tim Riker <Tim@Rikers.org>
+###
+
+main: I learn mainly by observing declarative statements such as "x is at http://www.xxx.com", and then reply when people ask things like "where can i find x?"
+
+action: This is used to override the usual response. "x is <action> does the hokey-pokey". When asked about x, the bot does this "* infobot does the hokey-pokey"
+
+alternation: The || symbol in an entry causes an infobot to choose one of the replies at random. "X is Y||Z" will produce "X is Y" or "X is Z" randomly.
+
+author: oznoid (mailto:lenzo@ri.cmu.edu) is my original author.
+
+dollar variables: D: To be used in factoids
+dollar variables: $Fdunno - ...
+dollar variables: $Fquestion - ...
+dollar variables: $Fupdate - ...
+dollar variables: $channel - channel from which the factoid was requested
+dollar variables: $date - current date (GMT)
+dollar variables: $day - day of week (full name, locale)
+dollar variables: $factoids - factoid count
+dollar variables: $host - hostname of factoid requester
+dollar variables: $ident - bot nick
+dollar variables: $lastspeaker - ...
+dollar variables: $memusage - ...
+dollar variables: $rand - random number, also $rand100.2
+dollar variables: $randnick - random nick
+dollar variables: $startTime - start time
+dollar variables: $time - current time (GMT)
+dollar variables: $uptime - ...
+dollar variables: $user - username of factoid requester
+dollar variables: $who - nick of factoid requester
+
+corrections: If I come back with "...but x is at http://xx.xx.xx" or something like that, and you want to change the entry, use "no, x is at http://sdfsdfsdf". The "No," tells me to supercede the existing value.
+corrections: you can append stuff to a factoid with "also". "x is also at ..."
+
+math: D: math expresions can be evaluated. This uses Perl syntax.
+math: E: 1+1
+math: + - add
+math: - - subtract
+math: * - multiply
+math: / - division
+math: ** - to the power
+math: pi - pi
+math: & - and
+math: | = or
+math: ^ - xor
+
+redirection: If a factoid x contains simply "<reply> see y", then when asked for x, I will deliver factoidor command result y instead.
+
+reply: There is a special tag, <reply>, that is used to override the usual response. Usually, a response is "X is Y", but it can be made "Y" by making the entry "X is <reply> Y".
+
+# now the commands...
+
+adduser: D: Administrative command to add new user to the .users file
+adduser: U: ## <user> <mask>
+adduser: E: ## bloot bloot!bloot@example.com
+
+addressing: It is a good idea if I stay in REQUIRE mode so that I won't yell out random crap if I listen in too hard. Currently there is no way to turn this off on-the-fly. (REQUIRE mode requires me to be addressed by name if I am to respond)
+
+babelfish: D: Frontend to babelfish translating service provided by http://babelfish.altavista.com/ Note that utf8 is used for non-ascii characters.
+babelfish: U: x <fromLang> <toLang> <words>
+babelfish: U: translate <fromLang> <toLang> <words>
+babelfish: E: x en de your cars rock
+
+-ban: D: FIXME:
+-ban: U: ## <mask|user>
+-ban: E: ## *!*@owns.org
+-ban: E: ## MoronMan
+
++ban: D: FIXME:
++ban: U: ## <mask|user> [chan] [time] [reason]
++ban: E: ## *!*@owns.org #bots 60 stop flooding.
++ban: E: ## *!*@*microsoft.com STOOPID
++ban: E: ## MoronMan
+
+botmail: D: Send someone botmail
+botmail: U: ## {for <who>[:] <message>}|stats|check|read
+botmail: E: ## for infobot: you rock!
+botmail: E: ## stats
+botmail: E: ## check
+botmail: E: ## read
+
+-chan: D: Leave a channel permanently
+-chan: U: ## -#channel
+-chan: E: ## -#botpark
+
++chan: D: Join a channel permanently
++chan: U: ## #channel
++chan: E: ## #botpark
+
+chaninfo: D: Display channel statistics on Op, Ban, Deop, Unban, Part, Join, SignOff, PublicMsg, Kick and Topic
+chaninfo: U: ## [#channel]
+chaninfo: E: ##
+chaninfo: E: ## #botpark
+
+chanset: D: set a variable for a channel
+chanset: U: ## [#chan] [what] [val]
+chanset: E: ## #c +test
+chanset: E: ## #c -test
+chanset: E: ## #c test
+chanset: E: ## #c test 0
+chanset: E: ## #c test testing123
+
+chanunset: D: remove a variable from a channel
+chanunset: U: ## <#chan> [what]
+chanunset: E: ## #c
+chanunset: E: ## #c test
+
+chattr: D: Change flags on a user (see "help flags")
+chattr: U: ## <user> [flags]
+chattr: E: ## bloot +nmo
+chattr: E: ## bloot -ot
+chattr: E: ## bloot
+
+chnick: D: rename a nick (user) entry
+chnick: U: ## [nick] <new-nick>
+chnick: E: ## moron
+chnick: E: ## owner eleet
+
+chpass: D: Change a user's password
+chpass: U: ## [user] <pass>
+chpass: E: ## testing
+chpass: E: ## testing test0R
+
+contents: D: Debian Contents search only (no Packages)
+contents: U: ## <string> [dist]
+contents: E: ## strings.h
+contents: E: ## x11amp potato
+
+cookie: I can feed your appetite with random factoids.
+
+cpustats: cpustats dumps the bot's cpu usage this session
+
+crypt: It's good that you thought about encryption. I can do it for you.
+crypt: U: ## <salt> <string>
+crypt: E: ## 69 changeme
+crypt: E: ## $1$abcde changeme
+
+cycle: D: Causes me to cycle in the channel it's said, or in the named channel
+cycle: U: ## [channel]
+cycle: E: ##
+cycle: E: ## #botpark
+
+dauthor: D: Find Debian package maintainers, and list the packages they maintain
+dauthor: U: ## <string> [dist]
+dauthor: E: ## Wichert
+dauthor: E: ## Wichert potato
+
+dbugs: D: Show the current count of release critical bugs (latest versions)
+dbugs: U: ##
+
+deluser: D: Administrative command to remove a user from the .users file
+deluser: U: ## <user>
+deluser: E: ## bloot
+
+ddesc: D: Search the Description: lines in Debian packages
+ddesc: U: ## <string> [dist]
+ddesc: E: ## mule
+ddesc: E: ## mule potato
+
+dfind: D: Debian Packages (fallback to Contents) search
+dfind: U: ## <string> [dist]
+dfind: E: ## strings.h
+dfind: E: ## x11amp potato
+
+dict: D: DICT Protocol Client - likely dicts: elements web1913 wn gazetteer jargon foldoc easton hitchcock devils world02 vera
+dict: U: ## [entry num] <query>[/dict]
+dict: E: ## linux
+dict: E: ## 33 set/wn
+
+dns: D: Query DNS
+dns: U: ## <host|ip>
+dns: E: ## debian.org
+dns: E: ## 3.1.33.7
+
+do: D: operator command to do things in a channel
+do: U: ## <chan> <what>
+
+dstats: D: Show basic stats on the current size of the Debian distros
+dstats: U: ## [dist]
+dstats: E: ##
+dstats: E: ## potato
+
+factinfo: D: View statistical information about a particular factoid.
+factinfo: U: ## <factoid>
+factinfo: E: ## test
+
+factstats: D: Display statistical data (max of 15) about factoids.
+factstats: U: ## <type>
+factstats: == author -- top author of factoids.
+factstats: == deadredir -- ??
+factstats: == duplicate -- duplicate factoids.
+factstats: == listfix -- ??
+factstats: == locked -- locked factoids.
+factstats: == new -- recent addition of factoids.
+factstats: == nullfactoids -- ??
+factstats: == partdupe -- initial partial duplicate factoids.
+factstats: == profanity -- possibly offensive factoids.
+factstats: == redir -- redirection in factoids.
+factstats: == reqrate -- ??
+factstats: == requested -- most requested factoids.
+factstats: == requesters -- most requested factoids.
+factstats: == seefix -- ??
+factstats: == toolong -- factoid {key|value} exceeding specified length.
+factstats: == tooshort -- factoid {key|value} shorter than specified length.
+factstats: == total -- ??
+factstats: == unrequest -- unrequested factoids.
+factstats: == vandalism -- ??
+factstats: E: ## new
+
+forget: If I have an old/redundant factoid x, "forget x" will cause me to erase it.
+
+freshmeat: D: Frontend to www.freshmeat.net
+freshmeat: U: ## <query>
+freshmeat: E: ## infobot
+
+hex: D: Convert ascii to hex
+hex: U: ## <string>
+hex: E: ## carrot
+
+httpdtype: D: Get httpd server software version / configuration
+httpdtype: U: ## <hostname>
+httpdtype: E: ## example.com
+
+ignore: D: ignore list management
+ignore: E: ## [mask chan expire comment]
+ignore: E: addignore guu!*@*
+
+ircstats: ircstats dumps some status information on the bot's IRC connection
+
+join: U: ## <#chan> [key]
+join: E: ## #botpark
+join: E: ## #botpark rules
+
+karma: Karma is a community rating system. Use "X++" to increase the karma, or "X--" to decrease it. Ask for ratings using "karma for X?"
+
+kernel: D: Frontend to linux.kernel.org's finger response.
+kernel: U: ##
+
+kick: U: ## <nick> [#chan] [message]
+kick: E: ## oznoid
+kick: E: ## larne #botpark
+kick: E: ## john #foo go away!
+
+lart: D: Luser Attitude Readjustment Tool
+lart: U: ## [#chan] <who>
+lart: E: ## lenzo infobot's bugginess
+lart: E: ## #perl everyone perl \=\= lamerville
+
+lc: D: lower case a given string
+lc: U: ## <string>
+lc: E: ## When will infobot achieve world domination?
+
+listauth: D: Search the factoid extension db by creator
+listauth: U: ## <search>
+listauth: E: ## xk
+
+listkeys: D: Search the factoid database by key (factoid)
+listkeys: U: ## <regex>
+listkeys: E: ## infobot
+
+listvalues: D: Search the factoid database by value (description)
+listvalues: U: ## <regex>
+listvalues: E: ## infobot
+
+literal: used to get a raw factoid contents. Use _default to ignore factoidSearch path.
+literal: U: ## [_default|prefix] <factoid>
+literal: E: ## infobot
+
+lobotomy: I can be given a lobotomy ([o] is required) if people start to abuse me. To bring me back to life, give me an unlobotomy
+
+lock: D: Factoid locking to prevent removal by others
+lock: U: ## <factoid>
+lock: E: ## abuse
+lock: N: By default, only registered "ops" on the bots or factoids matching the user's nick are able to lock factoids.
+lock: N: Requires factoid extension (extra) support enabled.
+
+md5: D: calculates the md5sum of a given string
+md5: U: ## <string>
+md5: E: ## When will infobot achieve world domination?
+
+mode: set modes for a channel
+mode: U: ## <#chan> <mode>
+mode: E: ## #botpark +t
+mode: E: ## #botpark -i
+
+news: D: News functions
+news: U: ## [chan] <add,del,mod,set,latest,read,help>
+
+news add: D: Add news items
+news add: U: news [chan] add <title>
+news add: E: news add This is a test
+news add: see _news set Text_ aswell
+
+news set: D: Set stuff for news item
+news set: U: news [chan] set <item> <what> [value]
+news set: valid <what>: Expire, Text
+news set: E: news set 1 Text ok, this works
+news set: E: news set test Text and this is a test
+news set: E: news set test Text
+
+news set expire: D: Set expire for news item
+news set expire: U: news [chan] expire <what> <value>
+news set expire: value can be: Xd Xh Xm Xs
+news set expire: value can be: never
+news set expire: news expire 1 3days
+news set expire: news expire 2 +20d
+news set expire: news expire Test 30d 20h 10m 5s
+news set expire: news expire TEST never
+
+news del: D: Delete news item (requires +o or be author)
+news del: U: news [chan] del <item>
+news del: E: news del 1
+news del: E: news del test
+
+news mod: D: Modify a news item (todo: modify Text aswell)
+news mod: E: news [chan] mod <item> s/<from>/<to>/[g]
+news mod: E: news mod 1 s/test/Test/
+news mod: E: news mod test s/test/Test/g
+
+nickometer: D: Measures the lame-ness of a nick or channel
+nickometer: U: ## {nick,channel}
+nickometer: E: ## unknown_lamer
+nickometer: E: ## #botpark
+
+onjoin: D: get/set OnJoin message (needs chan option +OnJoin)
+onjoin: U: ## [#chan|_default] [-]<nick> [message]
+onjoin: E: ## infobot Hey! It's another infobot!
+
+ord: D: Convert ascii to decimal
+ord: U: ## <single character>
+ord: E: ## c
+
+page: D: Send someone a pager message
+page: U: ## <who> <message>
+page: E: ## infobot you rock!
+page: NOTE: this uses the "<who>'s pager" factoids for the From: and To: addresses of the format "example's pager" is "mailto:me@example.com"
+
+part: D: Leave a channel (DCC only)
+part: U: ## <#channel>
+part: E: ## #botpark
+part: NOTE: /kick is an alternative
+
+piglatin: D: translates english text into piglatin
+piglatin: U: ## <string>
+piglatin: E: ## When will infobot achieve world domination?
+
+quote: D: Frontend to yahoo's online stock market share listing
+quote: U: ## <query...>
+quote: E: ## RHAT,MSFT
+
+rename: D: Factoid renaming
+rename: U: ## 'from' 'to'
+rename: E: ## 'infobot' 'infobot'
+
+reverse: D: reverses a given string
+reverse: U: ## <string>
+reverse: E: ## When will infobot achieve world domination?
+
+rot13: D: ROT13's a given string
+rot13: U: ## <string>
+rot13: E: ## guvf vf n ynzr rknzcyr
+
+say: D: operator command to say things in a channel
+say: U: ## <chan> <what>
+
+scramble: D: scrambles a given string
+scramble: U: ## <string>
+scramble: E: ## When will infobot achieve world domination?
+
+search: U: ## <engine> for <string>
+search: E: ## google for infobot
+
+seen: D: Report last seen time for somebody
+seen: U: ## <nick>
+seen: E: ## infobot
+
+slashdot: D: News for nerds, Stuff that matters. [tm] (shows the headlines)
+slashdot: U: ##
+
+spell: You've guessed it right, I'm a spell checker. Give me any word and I can confirm whether it's good or bad.
+
+status: status dumps general status information
+
+tell: D: Tell someone about a factoid or command
+tell: U: ## <who> -?about <what>
+tell: E: ## me about infobot
+tell: E: ## someone -about testing
+
+topic add: D: Add your own topic
+topic add: U: ## <topic>
+topic add: E: ## This is a test
+
+topic del: D: Delete one or two subtopics
+topic del: U: ## <#>
+topic del: E: ## 1
+topic del: E: ## 1-3,5
+topic del: E: ## last
+
+topic mod: D: Search and replace strings in the topic
+topic mod: U: ## <REGEX>
+topic mod: E: ## s/test/TEST/
+topic mod: E: ## s#msg test#/msg test#g
+
+topic mv: D: Move subtopics around.
+topic mv: U: ## <#> <before|after|swap> <#>
+topic mv: E: ## 1 after 2
+topic mv: E: ## first before last
+
+topic restore: D: Restores the topic to an earlier version
+topic restore: U: ## <#>
+topic restore: E: ## 3
+
+topic: Usage for 'topic [#chan] <params>':
+topic: ---------------- __Subtopic__:
+topic: add <TOPIC> - Append <TOPIC> to topic.
+topic: del <#> - Remove subtopic <#> from topic.
+topic: list - Display subtopics.
+topic: mod s/old/new/ - Search and replace topic.
+topic: mv <ARGS> - 'topic mv'.
+topic: shuffle - Randomly organize subtopics.
+topic: ---------------- __Topic__
+topic: history - Show previous topics.
+topic: restore <#> - Restore topic to <#>.
+topic: rehash - Rehash changes to topic.
+topic: info - Who and time info.
+topic: ---------------- __Misc__
+topic: about - Read the file :)
+topic: help - This screen.
+
+topic: NOTE: #chan arg is only required if command is sent over private message to nick, otherwise it is not needed if sent to the channel.
+topic: NOTE: commands can be preceeded? with '-' in order not to enforce changes to topic.
+topic: End of help.
+
+uc: D: upper case a given string
+uc: U: ## <string>
+uc: E: ## When will infobot achieve world domination?
+
+unforget: If a factoid has been forgotten, "unforget x" will cause me to unerase it.
+
+unlobotomy: Not possible in real life, an unlobotomy will bring me back to life in the case of a lobotomy.
+
+unlock: D: Factoid unlocking to allow removal by others.
+unlock: U: ## <factoid>
+unlock: E: ## abuse
+
+uptime: D: Show the current uptime, and the top 3 uptimes recorded
+uptime: U: ##
+
+wantnick: If someone's taken my nick (I hope not) and I'm using some temporary nick, I can change back to my original nick if it's not taken (again).
+
+wikipedia: D: Frontend to the Wikipedia at http://www.wikipedia.org/wiki/ Note that utf8 is used for non-ascii characters.
+wikipedia: U: ## <topic>
+wikipedia: U: wiki <topic>
+wikipedia: E: wiki irc
+
+wtf: D: Interface to the BSD wtf command
+wtf: U: ## <abbreviation>
+wtf: E: ## iirc
+
+-host: D: admin command to remove hostmask from a user account
+-host: U: ## [user] <mask>
+-host: E: ## *!*@owns.org
+-host: E: ## owner leet!leet@*.heh.org
+
++host: D: admin command to list or add hostmasks to a user account
++host: U: ## [user] [<mask>]
++host: E: ## owner
++host: E: ## *!*@owns.org
++host: E: ## owner leet!leet@*.heh.org
+
+flags: D: Flags for chattr command
+flags: D: "A" - bot administration over /msg (default is only via DCC CHAT)
+flags: D: "O" - dynamic ops (as on channel). (automatic +o)
+flags: D: "T" - add topics.
+flags: D: "a" - ask/request factoid.
+flags: D: "m" - modify factoid. (includes renaming)
+flags: D: "n" - bot owner, can "reload"
+flags: D: "o" - master of bot (automatic +amrt)
+flags: D: - can search on factoid strings shorter than 2 chars
+flags: D: - can tell bot to join new channels
+flags: D: - can [un]lock factoids
+flags: D: "r" - remove factoid.
+flags: D: "t" - teach/add factoid.
+
--- /dev/null
+# infobot.lang: configurable responses.
+# by the xk.
+###
+
+# Welcome reply: Things to say when people thank me.
+welcome
+ no problem
+ my pleasure
+ sure thing
+ no worries
+ de nada
+ de rien
+ bitte
+ pas de quoi
+ gern geschehen
+
+# Dunno reply (when i recognize a query but can't answer it):
+dunno
+ i don't know
+ i haven't a clue
+ no idea
+ wish i knew
+ bugger all, i dunno
+ I give up, what is it?
+ I don't know, could you explain it?
+ I'm not sure, is it larger than a breadbox?
+ parse error: dunno what the heck you're talking about
+ are you using Windows?
+ I wish you would RTFM.
+ have you tried http://www.tldp.org/ ?
+ KCI error, or a problem with the Keyboard-Chair Interface.
+
+# moron reply.
+moron
+ You think I'm human? Think again!
+ h0 h0 h0
+ Hi, how's life?
+ What do you want?
+ Are you on drugs?
+ Wassup G?
+
+# confuse/refuse learn.
+confused
+ I think you lost me on that one
+ what are you talking about?
+
+# Hello reply (ways to say hello):
+hello
+ hello
+ hi
+ hey
+ niihau
+ bonjour
+ hola
+ salut
+ que tal
+ privet
+ what's up
+ moin moin
+
+# Cookie reply: added by the xk.
+cookie
+ ACTION spins the wheel of knowledge and ponders... ##KEY... ##VALUE
+ ACTION pulls out the cookie jar and finds ##KEY... ##VALUE
+ Hey ##WHO, ##KEY is ##VALUE
+
+# Factoid reply:
+factoid
+ methinks ##KEY is ##VALUE
+ i heard ##KEY is ##VALUE
+ i guess ##KEY is ##VALUE
+ from memory, ##KEY is ##VALUE
+ hmm... ##KEY is ##VALUE
+ ##KEY is probably ##VALUE
+ ##KEY is, like, ##VALUE
+ rumour has it, ##KEY is ##VALUE
+ it has been said that ##KEY is ##VALUE
+ somebody said ##KEY was ##VALUE
+ well, ##KEY is ##VALUE
+ extra, extra, read all about it, ##KEY is ##VALUE
+ [##KEY] ##VALUE
+
+# HowAreYou reply:
+howareyou
+ eh, ok
+ peachy
+ just great
+ you know how it is...
+ pretty good. how about you?
+ mas o menos
+
+# Question word.
+qWord
+ who
+ who is
+ who are
+ what
+ what's
+ what is
+ what are
+ where
+ where's
+ where is
+ where are
+
+# botsnack etc praise
+# TODO add ACTION support
+praise
+ :)
+ thanks
+ aw, gee
--- /dev/null
+
+#
+# lart info by ejb (larne) and cerb.
+#
+
+--purges WHO
+accelerates a free AOL cd to 50,000 rpm and lets WHO feel it
+acting on orders from an unspecified client drags WHO into court suing for $200 million
+beats the living hamstercrap out of WHO
+beats WHO into protomatter with the andromeda galaxy
+beats WHO over the head with a microkernel
+beats WHO senseless with a 50lb Unix manual
+beats WHO severely about the head and shoulders with a rubber chicken
+beats WHO to within 2.54cm of his life
+blames WHO for all the evil in the world
+blasts WHO to oblivion with a kamehameha wave
+blasts WHO with a huge firehose then strangles WHO with it
+brandishes Excalibur! "With this sword, I vanquish thee, WHO!" and lops off WHO's head
+breaks out the Hoover and sucks up WHO
+burns WHO to a crisp with a laser
+calls WHO on the phone ... the lights are on but nobody's home
+cats /dev/urandom into WHO's ear
+changes WHO's permissions to 0777 and tells the world
+chops WHO in half with a free AOL CD
+chops WHO in half with a free Solaris 7 CD
+crushes WHO with a full height scsi disk
+cuts off WHO's head with a halberd that could have been a little bit sharper
+cuts WHO into thin stripes
+decapitates WHO conan the destroyer style
+declares WHO a moron
+does a little 'dpkg -P WHO' action
+does a little 'renice 20 -u WHO'
+DoSes WHO
+drops a baby grand on WHO
+drops a humongous exploding nuke on WHO
+drops a truckload of VAXen on WHO
+duct-tapes WHO to the floor and drools on him
+dumps 42 tons of dirt, manure, and fish heads on WHO
+eats WHO and falls over dead
+eats WHO's liver with some fava beans and a nice chianti
+executes killall -HUP WHO
+executes killall -KILL WHO
+executes killall -TERM WHO
+explains, ever so gently, that if WHO doesn't give the channel more information, they can't help
+farts in WHO's general direction
+flings poo at WHO
+follow's WHO with a gauntlet and ... scratch ... HUMILIATION
+forces WHO to use Outlook Express
+frags WHO with his BFG9000
+gets a hotmal account and SPAMs WHO
+gives WHO a "free" copy of Windows and then charges double for "Upgrades"
+gives WHO a good seeing to
+gives WHO an extra strength ACME sleeping pill, sending WHO to sleep for 150 years, and awakening to seven strange dwarfs and a large apple
+grabs a large, mis-shapened log, with squirrels, and beats WHO until only the nuts remain ... which the squirrels run off with
+hauls WHO up by the scruff of the neck and spanks him until he waddles
+hereby declares WHO a troll
+hits WHO with an anvil and laughs with a contralto voice ... Haha Ha HA Ha
+holds WHO to the floor and spanks him with a cat-o-nine-tails
+hooks into a hydrant and hoses WHO down
+hurls dozens of incontinent, insomniac, hungry kittens with tiny little razor-sharp claws and a wide variety of contagious intestinal parasites at WHO
+installs a bad bootloader on WHO and turns WHO into a brick
+installs PocketPC on WHO's PDA
+judo chops WHO
+keeps mailing WHO free America Online CDs until he drowns
+lowers WHO's priority
+makes a balloon animal out of WHO
+moos at WHO
+nabs the moon and broadsides WHO with the sea of tranquility
+nukes WHO with a single large nuke
+offers WHO some herring
+overclocks WHO until WHO burns out
+plops WHO into a giant vat of herring
+pours gasoline all over WHO, ignites the fire, and then enjoys some toasty marshmallows with the glorious blaze
+pours hot grits down the front of WHO's pants
+pries WHO's back open with a screwdriver and flashes a new bootldr to WHO
+pulls out a ClueBat (tm) and thwaps WHO
+pulls out his louisville slugger and uses WHO's head to break the homerun record
+pushes the wall down onto WHO whilst whistling innocently
+puts on a hockey mask and jumps out at WHO
+puts on some milking gloves. "All right, now, WHO, this won't hurt a bit...."
+puts WHO into a headlock and administers a mighty noogie, rubbing half of WHO's hair of
+puts WHO through a wood chipper
+raises middle finger to WHO
+readies the nuke launcher and fires some rounds at WHO
+resizes WHO's terminal to 40x24
+rm -rf's WHO
+runs at WHO with an origami Swiss Army knife, and inflicts a nasty paper cut
+says "boot to the head" and knocks WHO over
+send killer squirrels to attack WHO
+sends a legion of lawyers after WHO's head
+shoots WHO in his sleep
+shoots WHO in the head
+shoves a crumpet down WHO's throat, happy now?! Huh? Want some JAM with that?
+slams WHO against a large cement Tux
+slaps a compatible dib on WHO's head
+slaps WHO around with a large trout
+slaps WHO upside and over the head with one freakishly huge killer whale named hugh
+slaps WHO upside the head with a wet fish
+smacks WHO up side the head with a clue-by-4
+squeezes WHO till WHO turns blue like papa smurf
+squishes WHO like a bug
+stabs WHO
+stamps WHO on the forehead with the official Troll marker
+steals WHO's mojo
+strangles WHO with a 9-pole serial cable
+strangles WHO with a doohicky mouse cord
+stuffs WHO into a shiny new tin can and vacuum seals it
+takes a big bite out of WHO's jugular vein
+takes a large goose feather pillow and swings it wildly in WHO's direction, hitting WHO and sending WHO flying into the closet
+takes a rusty axe and swings it violently, taking WHO's head off
+takes large quantities of Krispy Kream donuts and stuffs them one after another down WHO's throat until WHO puts on 150lbs
+takes out a cattle prod and gives WHO a good jolt
+takes out a seltzer bottle and sprays WHO in the face. You know, one of those old-school seltzer bottles clowns have? Yeah those. Anyway, consider yourself spritzed
+takes out WHO with the trash
+takes WHO to the vet for a "special" visit
+teaches WHO that M$ Access is a database. No, really, a database. A real live multi-user... well, ok, not multi-user, but a database. Yeah, that sounds right.
+teaches WHO the basics, including how to RTM
+throws a AN/M-8 smoke grenade at WHO
+throws WHO's poor little doggy off a cliff
+tries to shut WHO up
+turns WHO into a lifesized tux doll
+urinates on WHO
+wallops WHO with a main rotation server that needs rehubbing. It won't take long
+whacks WHO upside the head
+whacks WHO with a giant beaver's tail
+whacks WHO with the cluebat
+whips out a hot clue gun and makes sure that WHO is stuck to the floor
+whips out a shotgun, trudges over to WHO, and goes postal
+whips out a sword and chops WHO in half
+whips out his power stapler and staples WHO's foot to the floor
+whips WHO with a wet and grimy noodle just because
--- /dev/null
+He who controls the source controls the universe!
+Want to see a listing of files installed by a package, type dpkg -L package
+Need to know the status of a package? type dpkg -s package
+Need help, but everyone is idle in the channel, try emailing to debian-user@lists.debian.org
+Need to see the list of packages matching a pattern, type dpkg -l pattern
+If you have a webserver and dww packages installed, try http://localhost/dwww for all kinds of documentation
+Need help setting up PPP? read /usr/doc/ppp/README.debian
+Want to know why Debian is best? type !why in the channel
+Want to upgrade to hamm (unstable)? type !libc6 to get the mini-HOWTO
+Want to check out Debian social contract? type !dfsg in the channel
+Warning: Dates in Calendar are closer than they appear.
+Daddy, why doesn't this magnet pick up this floppy disk?
+Give me ambiguity or give me something else.
+I.R.S.: We've got what it takes to take what you've got!
+We are born naked, wet and hungry. Then things get worse.
+Pentiums melt in your PC, not in your hand.
+Suicidal twin kills sister by mistake!
+Did anyone see my lost carrier?
+Make it idiot proof and someone will make a better idiot.
+I'm not a complete idiot, some parts are missing!
+He who laughs last thinks slowest!
+Always remember you're unique, just like everyone else.
+'More hay, Trigger?' 'No thanks, Roy, I'm stuffed!'
+A flashlight is a case for holding dead batteries.
+Lottery: A tax on people who are bad at math.
+There's too much blood in my caffeine system.
+Artificial Intelligence usually beats real stupidity.
+Hard work has a future payoff. Laziness pays off now.
+Friends help you move. Real friends help you move bodies.
+I won't rise to the occaasion, but I'll slide over to it.
+Ever notice how fast Windows runs? Neither did I.
+Double your drive space - delete Windows!
+What is a 'free' gift ? Aren't all gifts free?
+If ignorance is bliss, you must be orgasmic.
+'Very funny, Scotty. Now beam down my clothes.'
+Puritanism: The haunting fear that someone, somewhere may be happy.
+Consciousness: that annoying time between naps.
+Oops. My brain just hit a bad sector.
+I used to have a handle on life, then it broke.
+Don't take life too seriously, you won't get out alive.
+I don't suffer from insanity. I enjoy every minute of it.
+Better to understand a little than to misunderstand a lot.
+The gene pool could use a little chlorine.
+When there's a will, I want to be in it.
+Okay, who put a 'stop payment' on my reality check?
+Few women admit their age. Few men act theirs.
+I'm as confused as a baby in a topless bar.
+We have enough youth, how about a fountain of SMART?
+All generalizations are false, including this one.
+Change is inevitable, except from a vending machine.
+C program run. C program crash. C programmer quit.
+'Criminal Lawyer' is a redundancy.
+Clap on! (clap, clap) Clap off! (clap@#&$NO CARRIER
+'640K ought to be enough for anybody.' Bill Gates '81
+'90% of all statistics are made up'
+'A fanatic is one who can't change his mind and won't change the subject.'
+'A little work, a little sleep, a little love and it is all over.' - R. Frost
+'A lot of people mistake a short memory for a clear conscience.' -Doug Larson
+'Apple' (c) 6024 b.c., Adam & Eve
+'Apple' (c) Copyright 1767, Sir Isaac Newton.
+'Bad knee, gotta run' - Pat Buchanan to his draft board
+'Beam me aboard, Scotty.' 'Sure. Will a 2x10 do?'
+'Beulah, peel me a grape.'
+'Bother,' said Pooh as the brakes went out!
+'Build a watch in 179 easy steps' by C. Forsberg.
+'C++' should have been called 'D'
+'COINCIDENCE' happens.
+'Calvin, we will not have an anatomically correct snowman!'
+'Careful. We don't want to learn from this.' -- Calvin
+'Don't you hate it when your boogers freeze?' -- Calvin
+'Every time I've built character, I've regretted it.'
+'Freedom defined is freedom denied.' -The Illuminatus
+'Have you ever dated somebody because you were too lazy to commit suicide?'
+'Hi-ho, hi-ho, it's hand grenades I throw...'
+'Hmm... How *did* they finally kill Frosty?' -- Hobbes
+'Human equality is a contingent fact of history.' -Steven Jay Gould
+'I tried to think but nothing happened!' - Curly
+'I'm not an actor, but I play one on TV'
+'I'm not smart enough to lie' - Ronald Reagan
+'If I knew what I was doing...I'd be dangerous...'
+'If the shoe fits, buy it.' Imelda Marcos
+'Instant gratification takes too long.' - Carrie Fisher
+'Is' is the verb for when you don't want a verb.
+'It is not the fall that kills you. it's the sudden stop at the end.'-D. Adams
+'It's sad how whole families are torn apart by simple things, like wild dogs'
+'Keyboard? How quaint!' - Scotty
+'Luke... Luke... Use the MOUSE, Luke' - Obi Wan Gates
+'Mr. Worf, blow the Windows-powered Borg ship out of this Universe!'
+'Off the keyboard, thru the router, over the bridge, nothing but net!'
+'Quotations are for people who are not saying things worth quoting.'
+'Remember when we said there was no future? Well, this is it.' -- Blank Regk
+'Stupid' is a boundless concept.
+'Suicide Hotline...please hold.'
+'The faster you go, the shorter you are' - Einstein
+'The reports of my death have been greatly exaggerated.' - Mark Twain
+'The sun ain't yellow, its chicken.' -Bob Dylan
+'There are lies, damned lies, and statistics.' -Mark Twain
+'There's someone in my head, but its not me.' -Pink Floyd
+'This is a job for.. AACK! WAAUGHHH!! ...someone else.' -
+'To err is human, to forgive....$5.00'
+'Ummm, Trouble with grammar have I! Yes!' -Yoda-
+'Vote for Perot' - Bumper sticker attached with Velcro
+'You can't have everything. Where would you put it?' -Steven Wright
+#1 OS/2 tip: Drag the Windows folder to the shreader!!!
+#include std/disclaimer.h
+$$$ not found -- (A)bort (R)efinance (B)ankrupt
+'Tis better to be thought a fool, then to open your mouth and remove all doubt
+(((((This tagline in Stereo where available)))))
+(A)bort (R)etry (C)ut Your Throat.....
+(A)bort (R)etry (F)ail (U)nplug & (S)ell.
+(A)bort (R)etry (P)ull leg (H)ot boot (S)wipe tagline!
+(A)bort, (R)etry, (I)nfluence with large hammer
+(A)bort, (R)etry, (P)retend this never happened...
+(D)inner not ready: (A)bort (R)etry (P)izza
+(You can have your cake) XOR (You can eat your cake)
+(c) Copywight 1995 Elmer Fudd. All wights wesewved.
+* OLX 3 * Windows is to OS/2 what Etch-a-Sketch is to art.
+*Four hours* to bury a cat? Yes - it wouldn't keep still
+.. Bugs come in through open Windows.
+... 'I'll be Bach.' - Johann Sebastian Schwarzenegger
+... All the world's a stage, and I missed rehearsal.
+... Bill Clinton isn't slick. He's just a liar.
+... Clinton Economics: If 1+2=3 then 4+5=6.
+... Clinton excuse #15: Hey - I just do what the wife says
+... Clinton excuse #18: You took that seriously? Har har
+... Clinton sandwich: $5 of baloney and $20 in taxes
+... Getting the truth from Clinton is like nailing Jello
+... It's tourist season in Florida, bag limit two.
+... KARAOKE is Japanese for 'Tone Deaf'
+... Some days you're the dog, some days you're the hydrant
+.....If it ain't broke, fix it anyway just to screw it up!
+...I'm sorry, Reality is not in service at this time.
+...On the other hand, you have different fingers.
+..Windows NT Performance', on the next 'In Search Of'
+/EARTH is 98% full. Please delete anybody you can
+1 + 1 = ? Ask my calculator.
+10 out of 5 doctors feel it's OK to be schitzo!
+1200 bps used to seem so fast
+186,000 miles/sec: Not just a good idea, it's the LAW.
+1st rule of intelligent tinkering - save all the parts
+2 + 2 = 4 (for the time being).
+2 + 2 = 5 (for sufficiently large values of 2)
+3 out of 4 Americans make up 75% of the population.
+43% of all statistics are worthless.
+43rd Law of Computing: Anything that can go wr...
+5 schizophrenics agree!
+50 states, and I had to pick this one...
+668 - Neighbor of the Beast
+90% of being smart is knowing what you're dumb at.
+<<< Tagline deleted by Natl Endowment for the Arts >>>
+==/==/==/==Police tagline==/==/==Do not cross ==/==/==/==
+From my brain, an organ with a mind of it's own.
+From the Department of Redundancy Dept.
+A BBSer's telephone bill knows no bounds...
+A Bugless Program is an Abstract Theoretical Concept.
+A Metaphor is like a Simile.
+A Smith & Wesson *ALWAYS* beats 4 Aces.
+A big enough hammer fixes anything
+A bird in the hand can be messy.
+A camel is a horse planned by committee.
+A chicken is an egg's way of producing more eggs.
+A clean desk is a sign of a cluttered desk drawer.
+A closed mind gathers no intelligence
+A closed mouth gathers no feet.
+A committee has 6 or more legs and no brain.
+A conscience does not prevent sin. It only prevents you from enjoying it.
+A critic is a man who leaves no turn unstoned.
+A cynic smells flowers and looks for the casket.
+A day for firm decisions! Or is it?
+A day not wasted is a day wasted!
+A day without radiation is a day without sunshine.
+A day without sunshine is like night.
+A diplomat thinks twice before saying nothing.
+A dirty book is rarely dusty.
+A fool and his money are soon SYSOP.
+A fool and his money rarely get together to start with.
+A fool must now and then be right by chance.
+A friend in need is a pest indeed...
+A friend: someone who likes you even after they know you.
+A good way to deal with predators is to taste terrible.
+A half moon is better than no moon at all.
+A harp is a nude piano.
+A hunch is creativity trying to tell you something.
+A library is an arsenal of liberty.
+A life lived in fear is half a life lived.
+A little greed can get you lots of stuff.
+A little inaccuracy sometimes saves tons of explanation.
+A living example of Artificial Intelligence.
+A man needs a good memory after he has lied.
+A man's best friend is his dogma.
+A man, a plan, a canal. Suez!
+A mind is a terrible thing to taste.
+A mind is a terrible thing to ugg.. I forgot..
+A neat desk is a sign of a sick mind.
+A pedestrian hit me and went under my car.
+A penny saved is a Governmental oversight.
+A perversion of nature....how exciting!
+A pessimist is never disappointed.
+A phaser on stun is like a day without orange juice.
+A rolling stone gathers momentum.
+A seminar on Time Travel will be held two weeks ago.
+A single fact can spoil a good argument.
+A stitch in time would have confused Einstein.
+A truly wise man never plays leapfrog with a moose.
+A waist is a terrible thing to mind.
+A yer ago I kudnt spel progremr now I are won.
+ASCII and ye shall receive.
+ASCII stupid question... get a stupid ANSI!
+Abandon all hope ye who have entered cyberspace.
+Afraid of heights? Not me, I'm afraid of widths!
+Agnodyslexic plea: 'why ME, dog?'
+Air conditioned environment - Do not open Windows.
+Alex, I'll take 'Things Only I Know' for $1000.
+All E-mail gladly received. Offensive reply ASAP.
+All I ask for is the opportunity to prove that money can't make me happy.
+All I need to know I learned from my cat.
+All I want is a warm bed, a kind word and unlimited power
+All generalizations are bad.
+All generalizations are false, including this one.
+All hope abandon, ye who enter messages here.
+All in a day's work for...'Confuse-a-Cat'!
+All in all it's just a... 'nother brick in the wall!
+All life's answers are on TV. - Bart Simpson
+All programers are optimists.
+All that glitters has a high refractive index.
+All the easy problems have been solved.
+All things are green unless they are not.
+All wiyht. Rho sritched mg kegtops awound?
+All words are pegs on which to hang ideas.
+All work and no play, will make you a manager.
+All you need to be a fisherman is patience and bait.
+Almost went crazy. Would have been a real short trip.
+Alone: In bad company.
+Always draw your curves, then plot the data.
+Always forgive your enemies, nothing annoys them so much.
+Always glad to share my ignorance - I've got plenty.
+Always proofread carefully to see if you any words out.
+Always remember no matter where you go, there you are.
+Alzheimers advantage: New friends every day.
+Ambition is the last refuge of the failure.
+America Good Place to Put Chinese Restaurant.
+Amusement is the happiness of those who cannot think.
+An Elephant; A Mouse built to government specifications.
+An egotist thinks he's in the groove when he's really in a rut.
+An elephant is a mouse with an operating system.
+An idle mind is worth two in the bush.
+An ounce of application is worth a ton of abstraction.
+An ounce of emotion is equal to a ton of facts.
+An oyster is a fish built like a nut.
+An ulcer is what you get mountain climbing over molehills.
+An unbreakable toy is useful for breaking other toys.
+An unemployed court jester is no one's fool.
+And don't start a sentence with a conjunction.
+And he disappeared in a puff of logic.
+And if one bad cluster should accidentally fail...
+And it's only ones and zeros.
+And now for something completely different...
+And now for something completely the same...
+And tomorrow will be like today, only more so.
+And, the driver compresses EVERYTHING, not just EXE & COM
+Angels can fly because they take themselves so lightly.
+Anger blows out the lamp of the mind.
+Another case of Cherry Coke down the programming hatch!
+Answers: $1 * Correct answers: $5 * Dumb looks: Free! *
+Antidisestablishmentarianism!
+Any closet is a walk-in closet if you try hard enough.
+Any fool can criticize, condemn, & complain. And most do.
+Any philosophy that can be put in a nutshell belongs there
+Any wire cut to length will be too short.
+Anything worth doing, is worth doing for a profit.
+Are we having Fahrvergn\ 1ugen yet??
+Are ya feelin' lucky, punk?!! - Harry Callahan
+Are you really American if your ethnicity has to be hyphenated?
+Are you suggesting that coconuts migrate?
+Armageddon means never having to say you're sorry.
+Artificial Intelligence is no match for natural stupidity.
+As I said before, I never repeat myself.
+As a matter of fact, no, I don't have a life.
+As easy as 3.14159265358979323846264338327950288419716
+As long as I can remember, I've had amnesia.
+Ask not for whom the bell tolls; let the machine get it.
+Assumption is the mother of all screwups...
+Atheist = Deity Disadvantaged.
+Auntie Em: Hate you, hate Kansas, taking the dog. -Dorothy
+B.Gates : quality software :: R.McDonald : gourmet cuisine
+BREAKFAST.COM Halted... Cereal Port Not Responding.
+Back Up My Hard Drive? I Can't Find The Reverse Switch!
+Backup not found: (A)bort (R)etry (P)anic
+Bad Command:(A)bort (R)etry (T)ake RAM hostage
+Bad breath is better than no breath.
+Bald: follicularly challenged.
+Barium: what you do with dead chemists.
+Beautify Texas. Put a Yankee on a bus.
+Been there, done that, got the T-shirt.
+Best file compressor around: DEL *.* (100% compression!)
+Best way to dispose of the Borg: Give them Windows 3.1.
+Better ... stronger ... faster!
+Beware of Geeks bearing gifs.
+Beware of barking dogs that bite.
+Beware of programmers carrying screwdrivers
+Bigamy : one wife too many. Monogamy : same thing
+Bill Clinton is the Lyin' King. ( Now playing nation wide )
+Bill Clinton thinks that Cheerios are donut seeds.
+Bill Clintoon: The prince of Dorkness, a caricature of a president
+Black Holes are Out of Sight
+Black holes really suck...
+Blessed are the pessimists, for they make backups!
+Blessed is the end-user who expects nothing, for ye shall not be dissapointed.
+Bliss *IS* ignorance
+Bo Knows Taglines!
+Bo Peep did it for the insurance.
+Bombs don't kill people, explosions kill people.
+Borderline psychotic with hermit-like tendencies.
+Bore: A person who talks when you wish him to listen.
+Bored? Drive the speed limit... in your garage.
+Borg spreadsheet: Locutus 1-2-3
+Borg? Where? I don't se*(#$#..NO CARRIER
+Both of his feet are firmly planted in the air.
+Boy: A noise with dirt on it.
+Brain dysfunction detected....
+Brain over - Insert coin
+Brain: The apparatus with which we think that we think.
+Break up a relationship - buy a computer!!
+Breathing may be hazardous to your health.
+Britannia waives the rules.
+Bug off, Banana Nose; Relieve mine eyes
+Bugs are Sons of Glitches!
+Bugs, like coathangers, breed if unobserved.
+Building Contractors, not to be confused with homemakers
+Bullets speak louder than reason.
+Bumper sticker on a hearse: I'd rather be breathing
+Bungee Jumper? Catch you on the rebound.
+Bureaucrats cut red tape, lengthwise
+Bus error (Passengers dumped)
+Busier than a 1 legged man in an butt-kicking contest.
+But I forgot all about the Amnesia Conference!!
+But honey, we can afford it, I sold your car!
+But my little voice TOLD me to do it!
+But soft, what light through yonder tagline breaks?
+But then again, I like cold toilet seats.
+But what if I'm a figment of my OWN imagination?
+Buy American!
+Buy Land Now. It's Not Being Made Any More.
+Buy a supscription to Playboy and send it to your boss' wife
+By all means, let's not confuse ourselves with the facts!
+C programmer run C programmer crash C programmer quit
+C:\DOS C:\DOS\RUN RUN DOS RUN
+CAUTION: RIDER MAY BAIL AT ANY TIME
+CCITT: Can't Certify I Trust Telecom.
+CCITT: Can't Conceive Intelligent Thoughts Today
+CD-WOM, Wead Onwy Memowy.
+CEO of Dementia and Other Meaningless Entities.
+CHIP: One California hi-way patrolman.
+CODING: AN addictive Drug.
+COMMAND: A suggestion made to a computer.
+CONgress (n) - Opposite of PROgress
+CRASH: Normal termination.
+CRIME CONTROL: Fire a warning shot into his HEART!
+CURIOSITY? Nah. I got THAT cat with a lawnmower.
+CYCLIC REDUNDANCY CHECK: Stocktaking at a Bike shop
+California raisins murdered: Cereal Killer suspected
+Can I yell 'movie' in a crowded firehouse?
+Can you find the mispelled word in hear?
+Can you repeat the part after 'Listen very carefully'?
+Can you see the REAL ME, can ya?!?! CAN YA??!?!!?!?!?!?!
+Can you tell me how to get to Sesame Street?
+Can't learn to do it well? Learn to enjoy doing it badly!
+Card-carrying member of the cultural elite.
+Carlsbad Caverns: 22% more cavities.
+Cause of crash: Inadvertent contact with the ground.
+Caution: Breathing may be hazardous to your health.
+Caution: Contents under pressure
+Caution: Hungry Dieter May bite if provoked
+Caveat emptor, no deposit no return, do not remove.
+Celibacy is not hereditary.
+Cheer up, the worst is yet to come.
+Chernobyl used Windows
+Chess players mate better.
+Chicago runs best on a VCR.
+Chicago, an operating system Pair-of-Dimes shift!
+Chicago... The biggest thing since New Coke!
+Chicago: NT deja vu!
+Chicago? Been there. I'm ready to travel at WARP speed!
+Chicken heads are the chief food of captive alligators.
+Chipmunks roasting on an open fire.
+Choose heaven for climate, hell for society.
+Christmas comes, but once a year is enough.
+Circular Definition: see Definition, Circular.
+City Planners do it with their eyes shut.
+Civilization - biggest syntax error in history!
+Clark Kent is a transvestite.
+Clarvoiants meeting canceled due to unforseen events.
+Clean mind, clean body: take your pick.
+Cleanliness is next to impossible.
+Climate is what you expect. Weather is what you get.
+Clinton is one Bill, George Bush can't veto...
+Clinton/Gore is to the presidency as Beavis & Butthead are to television.
+Clones are people two.
+Close only counts in horseshoes and hand grenades!
+Close your eyes and press escape three times.
+Closed Hearing for the Caption Impaired...
+Cogito ergo spud I think therefore I yam.
+Cole's Law: Thinly sliced cabbage.
+Come in here, dear boy, have a cigar, you're gonna go far!
+Coming Soon!! Mouse Support for Edlin!
+Coming soon: Netware for the Nintendo!
+Commence strategic maneuvers at audible command signal. 5, 4, 3...
+Committees keep minutes and lose hours.
+Common sense is the collection of prejudices acquired by age eighteen.
+Common sense isn't...
+Communism is like a mouth on a lollipop
+Competence always contains the seeds of incompetence.
+Computational Physicist and all around nice guy.
+Computer Lie #1: You'll never use all that disk space.
+Computer: a million morons working at the speed of light.
+Computers All Wait at the Same Speed!
+Computers Rule 01001111 01001011
+Computers are not intelligent. They only think they are.
+Computers are useless; they can only give answers.
+Computers run on faith, not electrons.
+Condense soup, not books!
+Conformity obstructs progress.
+Confucius say too much.
+Confucius say: I didn't say that!
+Confucius say: Man with no legs bums around.
+Confucius say: Those who quote me are fools.
+Confuse People: Quote from the wrong message!
+Confused? Call Counselor Troi 1-900-NCC-1701: $1.95/minute
+Confusion not only reigns, it pours.
+Consolations, Consultations, Conflagrations.
+Constant change is here to stay.
+Contentsoftaglinemaysettleduringshipping.
+Converse with any plankton lately?
+Copyright the Intergalactic Thought Association
+Corrupt REALITY.SYS: Reboot Universe (Y/n)?
+Could crop circles be the work of a cereal killer?
+Couldn't myself have better it said.
+Courage atrophies from lack of use.
+Crime does not pay...as well as politics.
+Crime doesn't pay... does that mean my job is a crime?
+Crime wouldn't pay if the government ran it.
+Crime, Sex, Alcohol, Drugs...Boy do I love Congress
+Cynicism is intellectual dandyism.
+Cynics are people who know the price of everything and the value of nothing.
+D.A.D.D. - Daddies Against Dirty Diapers
+D.A.M. - Mothers Against Dyslexia
+D.A.M.M - Drunks Against Mad Mothers
+DAM: Mothers Against Dyslexia.
+DANGER! Computer store ahead, hide wallet!
+DCE seeks DTE for mutual exchange of data.
+DEFINE: De ting you get for breaking de law.
+DEVICE=EXXON.SYS may mess up your environment
+DILATE: To live longer.
+DIODE: What happens to people who don't die young.
+DIVORCE =system('echo y| erase \wife\*.*' );
+DO NOT ADJUST YOUR MIND - the fault is with reality
+DO NOT REMOVE THIS TAGLINE (UNDER PENALTY OF LAW)!
+DOC files? We don't need NO STINKIN' DOC FILES!
+DOS 5.0 Yesterday's operating system, today!
+DOS means never having to live hand-to-mouse.
+DOS never says 'EXCELLENT command or filename, Dude!'
+DOS-O-MANIA : Reboot is not kicking your computer again
+DOS-O-MANIA : Root is not the book Alex Haley wrote.
+DOWN WITH EXCLAMATION POINTS!!!!
+Daddy, what does 'Formatting Drive C:' mean?
+Dain Bramaged.
+Dang this hobby is expensive!
+Dangerous exercise: Jumping to conclusions.
+Darth Vader sleeps with a Teddywookie.
+Dawn: The time when men of reason go to bed.
+Dawson's First Law: You don't have enough outlets.
+Death benefits = oxymoron.
+Death is 99 per cent fatal to laboratory rats.
+Death is God's way of dropping carrier.
+Death is life's answer to the question 'Why?'
+Death is life's way of telling you you've been fired.
+Death sneaks up on you as a windshield sneaks up on a bug.
+Death: to stop sinning suddenly.
+Deflector shields just came on, Captain.
+Delivered by Electronic Sled-Dogs.....Woof!
+Democrats Call for Amnesty, Reduced Sentences Likely.
+Depart in pieces.... i.e., Split.
+Detour: The roughest distance between two points.
+Diagonally parked in a parallel universe.
+Did I just step on someone's toes again?
+Did ya hear? They took the word gullible out of the dictionary!
+Did you expect mere proof to sway my opinion?
+Die Yuppie Scum.
+Diets are for those who are thick and tired of it.
+Difference between Jane Fonda & Bill Clinton? Jane went to Vietnam
+Digression is education.
+Dime: a dollar with all the taxes taken out.
+Dinner Not Ready...(A)bort (R)etry (P)izza
+Diplomacy is saying 'nice doggy' until you find a rock.
+Diplomacy is the ability to let someone else have your way.
+Diplomacy: The patriotic art of lying for one's country.
+Dirty deeds - DONE DIRT CHEAP!
+Disclaimer: All opinions are not really opinions.
+Disclaimer: Written by a highly caffeinated mammal.
+Discoveries are made by not following instructions.
+Disks travel in packs.
+Dyslexics of the world, UNTIE!
+Do Androids Dream of Electric Sheep?
+Do I mind if you smoke? No. Do you mind if I FART?
+Do fish get thirsty?
+Do not believe in miracles -- rely on them.
+Do not disturb. Already disturbed!
+Do not put statements in the negative form.
+Do radioactive cats have 18 half-lives?
+Do steam rollers really roll steam?
+Do the joke. Get the laugh. Move on.
+Do unto others BEFORE they do unto you!
+Do vegetarians eat animal crackers?
+Do you know the way to San Jose?
+Doctor Who for president
+Doctor, my brain hurts!
+Documentation is the castor oil of programming.
+Does Bill Clinton think Elvis is alive?
+Does killing time damage eternity?
+Does the Enterprise use DOS v2356.0?
+Does the name Pavlov ring a bell?
+Doesn't expecting the unexpected make the unexpected become the expected?
+Dogs come when you call. Cats have answering machines.
+Dogs crawl under Gates, software under Windows.
+Don't Take Life Seriously, It Is Not Permanent.
+Don't ask me, I have intermittent memory loss
+Don't ask me, I only work here.
+Don't ask me, I'm making this up as I go!
+Don't be a sexist, broads hate that.
+Don't be afraid to drive a nail in the wood!
+Don't believe everything you hear or anything you say.
+Don't blame me, I voted for Mickey Mouse.
+Don't buy furs, it takes trees to make protest signs.
+Don't byte off more than you can multiplex.
+Don't confuse me with facts, my mind's already made up!
+Don't crush that dwarf, hand me the pliers.
+Don't diet, download a virus to remove the FAT.
+Don't do what I SAY, do what I mean!
+Don't get stuck in a closet -- wear yourself out.
+Don't just do something !!! Stand there !!!
+Don't let school interfere with your education.
+Don't look at me in that tone of voice!
+Don't look back, the lemmings are gaining on you.
+Don't mess with Murphy.
+Don't panic. Don't panic. Don't panic. ... ALL RIGHT, NOW PANIC
+Don't play stupid with me! I'm better at it.
+Don't press the keys so hard!
+Don't read everything you believe.
+Don't rush me. I get paid by the hour.
+Don't speak now, and forever hold your peace.
+Don't start with me. You know how I get.
+Don't steal. The government hates competition.
+Don't stop posting, a good laugh breaks up my day nicely
+Don't sweat it -- it's only ones and zeros.
+Don't talk unless you can improve the silence.
+Don't thank me for insulting you. It was my pleasure...
+Don't try to saw sawdust.
+Don't use a big word where a diminutive one will suffice.
+Don't use no double negatives.
+Don't worry, I'm fluent in weirdo.
+Down with categorical imperative!
+Down with ignurance!
+Downgrade your system for only 89 dollars! Install Windows!
+Dragons love you. You're crunchy and good with ketchup.
+Drama is life with the dull bits cut out.
+Drawing on my fine command of language, I said nothing
+Drilling for oil is boring.
+Drink wet cement, and get completely stoned.
+Drive A: format failure, formatting C: instead...
+Drive C: Error, (A)bort (R)etry (I)gnore (K)ick (S)cream
+Dropped from my peeling lips like lousy fruit.
+Drugs have taught an entire generation of American kids the metric system.
+Dumb luck beats sound planning every time. Trust me.
+Dying is no excuse. Nixon in 96.
+Dyslexics are persona au gratin.
+Dyslexics have more fnu.
+Dyslexics of the world, UNTIE!
+EMS: Enhanced Money Scam
+ERROR 103: Dead mouse in hard drive.
+EXPANSION SLOTS: The extra holes in your belt buckle.
+Eagles may soar but weasels aren't sucked into jet engines!
+Easter is canceled this year. They've found the body.
+Eat Healthy, Exercise, and Die Anyway ...
+Eat the rich, the poor are tough and stringy
+Efficiency takes time! Frugality: who can afford it?
+Eggheads unite! You have nothing to lose but your yolks.
+Ego Gratification through Violence
+Either this man is dead or my watch has stopped.
+Email me the rules, please!
+Energizer Bunny Arrested! Charged with battery.
+Enjoy me, I may never pass this way again.
+Enough research will tend to support your theory.
+Ensign Pillsbury: He's bread Jim!
+Enter that again, just a little slower.
+Error 15 - Unable to exit Windows. Try the door.
+Eschew obfuscation!
+Even in this corner of the galaxy, Captain, 2+2=4 ... Spock
+Even snakes are afraid of snakes.
+Even the greatest of whales is helpless in the middle of the desert
+Ever notice how fast Windows runs? Neither did I...
+Ever stop to think, and forget to start again?
+Ever wonder why Oprah spelled backwards is Harpo?
+Every man's work is a portrait of himself.
+Every purchase has its price.
+Every why hath a wherefore.
+Everybody is ignorant, only on different subjects.
+Everybody wants to go to heaven, but nobody wants to die.
+Everyone has photographic memory...some don't have film!
+Everyone hates me because I'm paranoid
+Everyone is entitled to my opinion.
+Everyone is gifted. Some open the package sooner.
+Everyone's expendable...and no one has a real friend
+Everything bows to success, even grammar.
+Everything in our favor was against us.
+Everything that is not mandatory is forbidden.
+Everywhere is walking distance if you have the time.
+Evil always triumphs over good, because good is STUPID!
+Exceeding the legal fun limit on a regular basis
+Excellent time to become a missing person.
+Excuse me while I dance a little jig of despair
+Excuse me while I sharpen my tongue.
+Experience is a good teacher but her fees are high...
+Experience: a name everyone gives to his mistakes.
+Exploding piglets!!! My gosh, it's raining bacon!
+Exxon Suxx.
+F.A.R.T....Fathers Against Radical Teenagers
+FATAL SYSTEM ERROR: Press F13 to continue...
+FIGHT BACK! Fill out your tax forms with Roman numerals.
+FILE COPIED. I THINK?
+FLOPPY DISK: Serious curvature of the spine.
+FOR SALE: 1 set of morals, never used, will sell cheap.
+FORD: The Heartbreak of today's Chevrolet!
+Fact is solidified opinion
+Facts Just Get In The Way And Impede Progress.
+Facts are stubborn things.
+Fad: In one era and out the other
+Familiarity breeds attempt
+Familiarity breeds children.
+Famous last words - Don't worry, I can handle it.
+Famous last words - Icarus: Aaaahhhhhhhhh.
+Famous last words - You and what army?
+Faster than a speeding ticket!
+Fat Wars: May the Sauce Be With You.
+Fat person: Nutritional Overachiever
+Fatal Error Using Mouse. Replace and Bury Operator.
+Features should be discovered, not documented.
+Feel lucky???? Update your software!
+Felines... nothing more than felines...
+Fer sell cheep: IBM spel chekker. Wurks grate.
+Fife. n. Small shrill instrument that rhymes with wife.
+Figures won't lie, but liars will figure.
+File not found. Should I fake it? (Y/N)
+Find your aim in life, before you run out of ammunition
+First thing you do is shoot all the lawyers
+Fish and visitors stink in three days.
+Flames to /dev/null/here/is/a/quarter/now/go/buy/a/clue.
+Flaming nuclear death to Smurfs
+Flirt: A woman who thinks it's every man for herself.
+Floggings will continue until morale improves.
+Flying saucers are real, the Air Force doesn't exist.
+Folks who think they know it all bug those of us who do
+Follow-ups to alt.nobody.really.cares
+Food is an important part of a balanced diet.
+Fools rush in where Fools have been before!
+Fools rush in wherever lottery tickets are sold
+For Sale: Slightly used message. Enquire within.
+For at the end of history lies the undiscovered country.
+For discussion only. Not to be relied upon.
+For every vision there is an equal and opposite revision.
+For people who like peace and quiet: A phoneless cord!
+For sale, Toilet-seat cover. Barely used.
+For the finest in brain candy.
+Forget the Joneses...I can't keep up with the SIMPSONS!
+Forget the computer! Where's my abacus??
+Forget the diet center; send yourself a candygram.
+Forgive your enemies...but REMEMBER THEIR NAMES!
+Four minus two is one and the same.
+Fraud(n): A telephone number starting with '1-900'
+Free Nelson Mandela, while stocks last!
+Free advice is worth what you pay for it
+Free your mind ... the rest will follow!
+Freedom is just chaos with better lighting.
+Friction can be a drag sometimes.
+Friendly fire - ISN'T !
+Friends are Friends, regardless of their baud rate!
+Friends come and go, enemies accumulate.
+Friends don't let friends drive naked.
+Friends encourage friends to use Windows - under Linux!
+Friendship is one soul in two bodies.
+Frost
+Funny, only sensible people agree with me.
+GURU: One who knows more jargon than you.
+Gambling: The sure way of getting nothing for something.
+Gargle twice daily - see if your neck leaks.
+Geez if you belive in honkus.
+Genealogy = A DNA square-dance in the Thighlight Zone
+General Failure reading John Dvorak
+General stupidity error reading drive C:
+Geoff, Brett and Todd...the BO-DYNASTY!!!
+George Orwell was an optimist.
+Get behind early so you have plenty of time to catch up.
+Get the facts first - you can distort them later!
+Get your filthy hands off my dessert!
+Gimme back my face! You're getting it ugly.
+Give a woman an inch and she'll park a car in it.
+Give a woman an inch and she thinks she's a ruler.
+Give your child mental blocks for Christmas.
+Go Lemmings, Go!!!
+Go shopping. Buy Stuff. Sweat in it. Return it the next day.
+God created cats so that men could learn to understand women
+God does not play dice.
+God heals and the doctor takes the fee.
+Going out of my mind, back in 5 minutes.
+Going the speed of light is bad for your age.
+Good day to let down old friends who need help.
+Good girls go to heaven...but bad girls go EVERYWHERE!!
+Goodness has NOTHING to do with it.....
+Gotta love me!
+Grab your helmet, get your bike, it's SHOWTIME!
+Graduate Of The Uncle Fester & Keith Moon School of hair styling
+Gravity brings me down
+Gravity doesn't exist. The Earth sucks.
+Great minds travel in the same sewers.
+Greed is good! Greed is right! Greed works!
+Grow your own dope... plant a man
+Growing old is mandatory; growing up is optional!!
+Grub first, then ethics.
+Gun control is being able to hit your target!
+Guns don't kill people... death does.
+Guns don't kill people..., I kill people!
+H lp! S m b d st l ll th v w ls fr m m k yb rd!
+HAL 9000: Dave. Put down those Windows disks, Dave. DAVE!
+Hackito ergo sum.
+Hailing frequencies open, Captain.
+Hand me that crowbar... I must pry out this bullet.
+Happiness is Earth in your rear view mirror.
+Happiness is a warm gun.
+Happiness is a warm modem
+Happiness is finding special characters \ 1\ 2\ 1\ 2
+Happiness is not a destination. It's the trip.
+Happiness is seeing your mother-in-law's face on the back of a milk carton.
+Happiness is...receiving YOUR posts!!!!
+Hard work has a future payoff. Laziness pays off now.
+Hard work must have killed someone!
+Has it ever rained cats and dogs?
+Hasta la vista, Baby!
+Have Tardis, will travel.
+Have an adequate day.
+Have cursor, will curse.
+Have it OUR way. Yours is IRRELEVANT. At BORGerKing.
+Have you ever talked into an acoustic modem?
+Have you seen Quasimoto? I have a hunch he's back!
+Having Windows problems? Dial 1-800-3-IBM-OS2 for fast relief!
+Having two bathrooms ruins the capacity to co-operate.
+He does the work of 3 Men...Moe, Larry & Curly
+He has Van Gogh's ear for music.
+He who Laughs, Lasts.
+He who always plows a straight furrow is in a rut.
+He who asks timidly makes denial easy.
+He who dies with the most access, wins.
+He who dies with the most toys... is *still* DEAD!
+He who eats too many prunes, sits on toilet many moons.
+He who hesitates is constipated.
+He who laughs last is S-L-O-W.
+He who laughs last probably made a backup.
+He who lives by the sword laughs last.
+He who places head in sand, will get kicked in the end!
+He who shouts the loudest has the floor.
+He who sitteth on an upturned tack shall surely rise.
+He's dead Jim. Grab his tricorder. I'll get his wallet.
+He's dim, Jed
+He's not dead, Jim, he's just metabolically challenged.
+Heads I win... DITTO tails
+Health food makes me sick.
+Heisenberg slept here, I think.
+Help endangered species - adopt a KGB operative.
+Help fight continental drift.
+Help stamp out mental illness, or I'll kill you!
+Help stamp out, eliminate and abolish redundancy!
+Help! I'm lost somewhere in the Generation Gap.
+Help! I've been stuck in here for years and years...
+Help! Police! That guy stole my .sig! STOP!!! THIEF!!!
+Help!!! I'm falling and I can't click out!!!
+Help, I'm slipping into the Twilight Zone!
+Here today, gaunt tomorrow.
+Hey! Hacker! Leave those lists alone!
+Hey! This is a morgue, not an amusement park!
+Hey! Who took the cork off my lunch??!
+Hey, CServe/Unisys! Stick it where the sun don't shine!
+Hey, Worf...I hooked Data up to a Modem...Wanna see?
+Hi! I can't remember your name either.
+Hi, I'm from Corporate. I'm here to help you.
+Hi. I'll be your tagline for this evening.
+High message: 9434567. Message last read: 9.
+Hills weed out the weak. Darwin would argue this is good.
+Hindsight is always 20:20.
+Hindsight is an exact science.
+Hm..what's this red button fo:=/07<NO CARRIER
+Hmm...Nice tagline. <SWIPE!> SUCKER!!! AH, HAHAHAHAHAHAHAHA!
+Hollow chocolate has no calories
+Hollywood is like Picasso's bathroom.
+Honey, PLEASE don't pick up the PH$@#*&$^(#@&$^%(*NO CARRIER
+Honeymoon Salad: Lettuce alone, with no dressing.
+Honeymoon: time between 'I do' and 'you'd better'
+Honk if you love cheeses.
+Honk if you love peace and quiet.
+Honk, if you have slept with Clinton.
+Hors d'oeuvres--a ham sandwich cut into forty pieces.
+Housework done properly, can kill you
+Houston! do you read.
+How come the AT&T logo looks like the Death Star?
+How come there's only one Monopolies Commission?
+How come wrong numbers are never busy?
+How do I set my laser printer for stun?
+How do you know it's summer in Seattle? Rain's warm!
+How do you make Windows faster ? Throw it harder
+How do you pronounce my name? With reverence.
+How do you write zero in Roman numerals?
+How does Michael Jackson pick his nose? From a catalog!
+How does one expect the unexpected?
+How long is a short story?
+How long will a floating point operation float?
+How many consultants will fit onto the head of a pin?
+How many of you believe in telekinesis? Raise MY hand!
+How many weeks are there in a light year?
+How much can I get away with and still go to heaven?
+How much deeper would the ocean be without sponges?
+Humpty dumpty was pushed.
+Hydrate or Die.
+Hypochondria is the only disease I haven't got.
+I *LOVE* it when a plan comes together!
+I BBS because no one can read my handwriting.
+I Cayman went.
+I Have To Stop Now, My Fingers Are Getting Hoarse!
+I M a tru beleever in hour edukashun sistum.
+I Still miss my ex-wife.....BUT, My aim is improving!
+I Think....therefore I'm OVER QUALIFIED!!!!!!!!!
+I love it when a plan comes together!
+I admit it's offbeat, but lets not get hysterical.
+I always lie. In fact, I'm lying to you right now!
+I always like to try the one I've never tried before.
+I am Clinton of Borg. Your income will be assimilated.
+I am Homer of Borg! Prepare to be...OOooooo! Donuts!!!
+I am Lancelot of Borg. Resistance is feudal.
+I am both of us & so are you.
+I am built for comfort, not speed!
+I am free of all prejudice. I hate everyone equally.
+I am functioning within established parameters.
+I am in total control, but don't tell my wife.
+I am not an animal! I am ... well, not an animal.
+I am serious. And don't call me Shirley.
+I am sweet and lovable at all times.
+I am the girl-next-door's imaginary boyfriend.
+I am what I am and that's all that I am.
+I am. Therefore, I think. I think.
+I apologize to the deaf for the loss of subtitles.
+I bet you I could stop gambling.
+I bought a cordless extension cord.
+I came, I saw, I did a little shopping.
+I came, I saw, I took LOTS of PICTURES!
+I came... I saw... I stole your tagline.
+I can do without essentials but I must have my luxuries
+I can quit anytime I want; I just don't want to!
+I can resist anything but temptation.
+I can tell you are lying. Your lips are moving.
+I can walk on water, but I stagger on alcohol.
+I can't be overdrawn, I still have checks left!
+I can't believe my computer's on fire.
+I can't hear you. There's a banana republic in my ear.
+I cna ytpe 300 wrods pre mniuet!!!
+I could be arguing in my spare time.
+I could have stuck with DOS, but NO.
+I couldn't care less about apathy.
+I didn't cheat, I just changed the Rules!
+I didn't know it was impossible when I did it.
+I distinctly remember forgetting that.
+I do not fear computers. I fear the lack of them.
+I do this kind of stuff to him all through the picture.
+I don't care if I'm apathetic.
+I don't care who you are, Fatso. Get the reindeer off my roof!
+I don't care who you are, what you are driving, or where you would rather be.
+I don't eat snails... I prefer FAST food!
+I don't hate Windows - it runs great under Linux!
+I don't have a solution but I admire the problem.
+I don't lie, cheat or steal unnecessarily.
+I don't need a disclaimer. I OWN the company.
+I don't think, therefore I am not.
+I don't want the world, I just want your half.
+I drink to make other people interesting.
+I eat Swiss cheese from the inside out.
+I feel like a fugitive from the law of averages.
+I feel so inar-inar-inar tic-u-late
+I feel the need......the need for speed!
+I finally washed the mud off of mud.
+I find myself beside a stream of empty thought
+I float like an anchor and sting like a moth.
+I get mail........ I exist.
+I give advice worth the price....free!
+I got arrested in LA and boy am I beat!
+I guess a cynic smells different.
+I had a life once... now I have a computer and a modem.
+I had amnesia once or twice.
+I had my coat hangers spayed.
+I hate quotations. Tell me what you know.
+I hate to repeat gossip, so I'll only say this once.
+I have a 9600bps modem and 1.5bps fingers
+I have a rock garden. 3 of them died last week.
+I have a speech impediment... my foot.
+I have already not made that point
+I have seen the evidence. I want DIFFERENT evidence!
+I have seen the truth and it makes no sense.
+I have the mars observer and I'm not returning it until I get an 'A' in astronomy
+I haven't lost my mind -- it's backed up on tape somewhere.
+I haven't lost my mind, I know exactly where I left it.
+I hear what you're saying but I just don't care.
+I is a college student.
+I is knot dain bramaged!
+I just bought a cured ham. Wonder what it had?
+I keep my .BAT files in D:\BELFRY
+I know Karate, Kung Fu, and 47 other dangerous words
+I know everything about everything, except that.
+I know it all. I just can't remember it all at once.
+I like candy, especially the gooey kind with nougat!
+I like kids, but I don't think I could eat a whole one.
+I like to leave messages *before* the beep.
+I like to reminisce with people I don't know.
+I like to think of myself as a divide overflow.
+I like your approach, now let's see your departure.
+I lost a button hole today.
+I lost my knickers at Niagara.
+I made it foolproof. They are making better fools!
+I may be fat but you're ugly, and I can lose weight.
+I may be getting older, but I refuse to grow up
+I may not always be perfect, but I'm always me.
+I may not be perfect, but parts of me are excellent.
+I mustanottagottalotta sleep last night.
+I need someone really bad. Are you really bad?
+I never deny, I never contradict. I sometimes forget.
+I never met a chocolate I didn't like!
+I only counted 100 dalmatians...!!!
+I owe, I owe, it's off to work I go.
+I parked my hard disk and now I can't find it!
+I planted some bird seed. A bird came up.
+I post.......... I am
+I promise results, not promises.
+I refuse a battle of wits with an unarmed person!
+I remember when Saturns were rockets, not cars.
+I saw, I came, I cleaned it up.
+I smashed a Window and saw... Linux!
+I spilled spot remover on my dog, and now he's gone.
+I think I strained a muscle I didn't know I had!
+I think, therefore I am. I think.
+I think. Therefore I am DANGEROUS.
+I thought I was wrong but I was mistaken.
+I tried being reasonable once. I didn't like it.
+I tried switching to gum but I couldn't keep it lit.
+I tried to daydream, but my mind kept wandering.
+I tried to drown my problems but they can swim!
+I try to make everyone's day a little more surreal.
+I used to be disgusted, but now I'm just amused.
+I used to be indecisive, now I'm not so sure.
+I used to be schizophrenic, but we're all right now.
+I used to have a handle on life, then it broke.
+I used to spell badlie, but now I got worser.
+I used to watch TV, then I bought a modem.
+I wake near the end of the day.
+I want .50 cal machine guns as a factory option.
+I warn you not to underestimate my powers.
+I was arrested for selling illegal sized paper.
+I was arrested for walking in someone else's sleep.
+I was going to procrastinate, but I put it off....
+I went on a 30-day diet - and lost 30 days!
+I will defend to your death my right to my opinion.
+I wish life had a scroll-back buffer.
+I wouldn't touch the Metric System with a 3.048m pole!
+I wrote a few children's books, but not on purpose.
+I xeroxed my watch. Now I have time to spare.
+I'd give my left arm to be ambidextrous
+I'd like to live like a poor person with lots of money.
+I'd like to, but last time I went I never came back..
+I'd love to, but I have to fulfill my potential.
+I'd love to, but I have to rotate my crops.
+I'd love to, but I have to stay home and see if I snore
+I'd love to, but I prefer to remain an enigma.
+I'd love to, but I think you want the OTHER Phillip.
+I'd love to, but I'm trying to be less popular.
+I'd love to, but I've dedicated my life to linguini.
+I'd love to, but my crayons all melted together.
+I'd love to, but my favorite commercial is on TV.
+I'd love to, but my patent is pending.
+I'd love to, but none of my socks match.
+I'd love to, but there's a disturbance in the Force.
+I'd love to, but you know how we psychos are.
+I'd rather be bicycling!
+I'll eat anything that's BRIGHT BLUE!!
+I'll get you my pretty, and your little dog too!
+I'll get you yet, you kwazy wabbit!
+I'll jump off that bridge when I come to it.
+I'll tell you what's the matter! This parrot is dead!
+I'm Not Schizophrenic, And Neither Am I.
+I'm Serfectly Pober.
+I'm a Bum...a BEACH Bum!
+I'm a cowboy ... on a steel horse I ride!
+I'm a lumberjack, and I'm okay!
+I'm a nobody, nobody is perfect, therefore I'm perfect.
+I'm an Debian developer...I don't NEED a life!
+I'm an absolute, off-the-wall fanatical moderate.
+I'm an incorrigible punster, so don't corrige me!
+I'm an influential person, gravitationally speaking.
+I'm as bored as a pacifist's pistol.
+I'm at the corner of Walk and Don't Walk.
+I'm dangerous when I know what I'm doing.
+I'm easy to please as long as I get my way.
+I'm fallin' down a spiral, destination unknown!
+I'm fascinated by the way memory diffuses fact.
+I'm in shape ... Rounds a shape isn't it?
+I'm leaving my body to science fiction.
+I'm moving to Mars next week, so if you have any boxes.
+I'm new and what's all this then?
+I'm no stranger, just a friend you haven't met...
+I'm not a complete idiot - several parts are missing.
+I'm not as dumb as you look.
+I'm not broke, I'm just badly bent.
+I'm not dead. I'm electroencephelographically challenged.
+I'm not even going to ignore that.
+I'm not fat just horizontally disproportionate.
+I'm not loafing. I work so fast I'm always finished
+I'm not lost, I'm 'locationally challenged.'
+I'm not nearly as think as you confused I am.
+I'm not opinionated, I'm just always right!
+I'm not paranoid! Which of my enemies told you this?
+I'm not real smart, but I can lift heavy things.
+I'm not rude, I'm 'attitudinally challenged'.
+I'm not schizophrenic. It's this guy beside me!
+I'm not tense, just terribly alert.
+I'm on the crest of a slump.
+I'm out of sick days, so I'm calling in dead!
+I'm pink, therefore I'm Spam.
+I'm schizophrenic, What are you?
+I'm so broke, I can't even pay attention.
+I'm spending a year dead for tax purposes.
+I'm sure it's clearly explained in the Zmodem DOC's
+I'm sure it's in the manual somewhere...
+I'm the person your mother warned you about.
+I'm too smart to let my intelligence go to my head.
+I'm turning you in to the SPCA!
+I've been seduced by the chocolate side of the force.
+I've got Parkinson's disease. And he's got mine.
+I've got a mind like a.. a.. what's that thing called?
+I've got to sit down and work out where I stand.
+I've had fun before. This isn't it.
+I've run out of sick leave so I'm calling in dead.
+I've seen the future. I can't afford it.
+IBM: I've Been Misled
+IBM: It may be slow, but at least it's expensive.
+IBM: you can buy better, but you can't pay more
+IF numcooks > .maxcooks THEN;SET V broth = 'spoiled';END
+INTERLACE: To tie two boots together.
+Ideas are not responsible for their followers!
+If At First You Don't Succeed Ignore The Docs...
+If Clinton's the answer, it must have been a really stupid question.
+If I can't fix it, it's probably dead.
+If I can't win, I don't wanna play!
+If I had anything witty to say, I wouldn't put it here.
+If I had been using Windoze, I'd still be writing this.
+If I save the whales, where do I keep them?
+If I save time, when do I get it back ?
+If I want your stupid opinion, I'll beat it out of you.
+If I were here more often, I wouldn't be gone so much.
+If I were two faced, would I wear this one?
+If I were you, who'd be me?
+If Murphy's Law can go wrong, it will.
+If The Shoe Fits - The Sock Fits !
+If a fly has no wings would you call him a walk?
+If a tree falls on a florist, would he make a sound?
+If all goes well, you've overlooked something!
+If all you have is a hammer, everything looks like a nail
+If at first we don't succeed, we run the risk of failure.
+If at first you don't succeed, call it v1.0!
+If at first you don't succeed, hide your astonishment.
+If at first you don't succeed, put it out for beta test.
+If at first you don't succeed, redefine success.
+If at first you don't succeed, skydiving isn't for you.
+If at first you don't succeed, work for Microsoft.
+If at first you don't succeed, you must be using Windows.
+If brains were dynamite you couldn't blow your nose!
+If cows could fly, everyone would carry an umbrella.
+If evolution is outlawed, only outlaws will evolve.
+If idiots could fly, this would be an airport.
+If in doubt, make it sound convincing.
+If it glows don't touch it!
+If it has feelings, its not cooked enough!
+If it isn't broken, don't fix it.
+If it jams, force it. If it breaks, it needed replacing
+If it walks out of your refrigerator, LET IT GO !!
+If it works, tear it apart and find out why!
+If it's not broke, let me take a crack at it.
+If it's not going to plan, maybe there never was a plan.
+If it's not on fire, it's a software problem.
+If it's not worth doing well, it's not worth doing.
+If it's stupid and works, then it ain't stupid
+If it's too loud, you're too old.
+If life gives you lemons, make lemonade.
+If little else, the brain is an educational toy.
+If marriage is outlawed, only outlaws will have inlaws.
+If money could talk, it would say goodbye.
+If nobody measures up, check your yardstick.
+If rabbits feet are so lucky, what happened to the rabbit?
+If speed scares you, try Windows...
+If the shoe fits, put it in your mouth.
+If there are epigrams, there must be meta-epigrams.
+If there's one thing I can't stand, it's intolerance.
+If this were an actual tagline, it would be funny.
+If truth is stranger than fiction, you must be truth!
+If voting changed anything, they'd make it illegal.
+If winning isn't important then why keep score?
+If you associate with the wise, you will become wise.
+If you believe in telekinesis, raise my hand.
+If you can't run with the big dogs, stay on the porch.
+If you cannot convince them, confuse them.
+If you choke a smurf, what color does it turn?
+If you didn't get caught, did you really do it?
+If you don't care where you are, then you ain't lost.
+If you don't like my opinion of you - improve yourself!
+If you don't like the news, go out and make some of your own.
+If you have nothing to do, don't do it here.
+If you have to ask what jazz is, you'll never know.
+If you hear an onion ring please answer it.
+If you mess with something long enough it'll break.
+If you must drink and drive, drive a Yugo!
+If you saw a heat wave, would you wave back?
+If you say nothing, no one will repeat it.
+If you see an onion ring, ANSWER IT!
+If you think education is expensive, try ignorance.
+If you try to fail, and succeed, which have you done?
+If you want your name spelt wrong, die.
+If you wish work poorly done, pay in advance.
+If you're not confused, you're not paying attention.
+If you're not the solution, you're the precipitate.
+If your attack is going well, then it's an ambush..
+If your ship doesn't come in, swim out to it!
+Ifyoucanreadthis,youspendtoomuchtimefiguringouttaglines!
+Ignorance is temporary; stupid is forever.
+Illiterate? Write for free help.
+Imagery is All In The Mind.
+Imagination is the only weapon in the war against reality
+Impropriety is the soul of wit.
+In God we trust, all others pay cash.
+In a fight between you and the world, back the world.
+In case of emergency, break glass. Scream. Bleed to death
+In case of fire, yell 'FIRE!'
+In politics stupidity is not a handicap.
+In the land of the witless, the halfwit is king.
+In war there is no substitute for victory.
+Include this in your CONFIG.SYS File: BUGS=OFF
+Incompetence plus incompetence equals incompetence.
+Individualists of the world, UNITE!
+Inertia makes the world go round.
+Inferiority complex: conviction by a jury of your fears.
+Innovate or Die.
+Insanity is hereditary. You get it from your kids.
+Insanity is just a state of mind.
+Insert New Disk for Drive C: Press ENTER when ready.
+Insert inevitable trivial witticism of your choice.
+Interchangeable parts won't.
+Internal combustion engines are the dinosaurs' revenge
+International Brotherhood of Tagline Thieves.
+Interstellar Matter is a Gas
+Invisible Systems, Inc. If you don't see it, we made it.
+Iron Law of Distribution: Them that has, gets.
+Is 'tired old cliche' one?
+Is it OK to yell 'MOVIE' in a crowded firehouse?
+Is it in my head...or in my heart?
+Is it ok to use my AM radio after NOON?
+Is it possible to feel gruntled?
+Is that a flying saucer or a pie in the sky?
+Is there life before coffee?
+Is this a machine? I don't talk to machines! [Click]
+Is this the right room for an argument?
+It all looks the same if you're not the lead dog.
+It can't be full...I STILL HAVE SUBDIRECTORIES!
+It compiled, first screen came up?? Ship it! --Bill Gates
+It did what? Well, it's not supposed to do that.
+It doesn't work, but it looks pretty.
+It has many other uses as well. Allow me. - Worf
+It is always better to sacrifice your opponent's men
+It is bad luck to be superstitious.
+It is better to be brief than boring.
+It is better to wear out than to rust out.
+It is broke. It will not work. It does not go.
+It is fatal to live too long.
+It is incumbent on us to avoid archaisms.
+It is morally wrong to allow suckers to keep their money.
+It is much easier to be critical than to be correct
+It is not enough to succeed. Others must fail.
+It is, after all, only a moment in the infinity of time.
+It really bothers me when people cut me o...
+It said 'Insert disk #3', but only two will fit!
+It works better if you plug it in.
+It's 10:00 PM...do YOU know where YOUR tagline is?
+It's Ensign Flintstone - he's Fred, Jim.
+It's a Tough Job! ..... So I'd Rather YOU do it.
+It's a fine line between fishing & standing still
+It's a fine night to have an evening.
+It's a good thing we don't get all the government we pay for.
+It's a tough job! ..... So I'd Rather YOU do it.
+It's an ill wind that gathers no moss.
+It's as bad as you think and they are out to get you.
+It's bad luck to be superstitious.
+It's been a business doing pleasure with you.
+It's been lovely, but I have to scream now.
+It's best to leave quickly when you make noises like that...
+It's better to burn out than to fade away.
+It's clever, but is it art?
+It's de\ 2ja\ 5 vu all over again.
+It's easier to get older than it is to get wiser.
+It's easier to obtain forgiveness than permission.
+It's easy to apply yourself, just use crazy glue!
+It's easy to be brave from a safe distance.
+It's hard to RTFM when you can't find the FM..
+It's hard to be serious when you're naked.
+It's life Jim, but not as we know it.
+It's like Deja Vu all over again...
+It's lonely at the top, but you eat better.
+It's more than a reader. It's a message base manager!
+It's never too late to have a happy childhood
+It's not easy having an overbearing parent! - Troi
+It's not hard to meet expenses, they're everywhere!
+It's not in the manual!
+It's not just a hobby, it's an obsession!
+It's not pretty being easy.
+It's not the bullet that kills you, it's the hole.
+It's not the money I want, it's the stuff.
+It's not the principle of the thing, it's the money
+It's okay to be ugly...but aren't you overdoing it?
+It's only a hobby ... only a hobby ... only a hobby ... only
+It's only ones and zeros.
+It's raining, it's pouring, the old man is...dead, Jim.
+It's smart to pick your friends, but not your nose.
+It's starting to rain, .SQZ the animals into the .ARC !
+It's true, forgiveness IS easier to get than permission
+Its a JOKE, like the funny kind but different.
+Itsdifficulttobeverycreativewithonlyfiftysevencharacters!
+JFK: I need this motorcade like a hole in my head!
+James Bond rules. 00K.
+Jealousy is all the fun you think they have.
+Jet Engine Theory -Suck, Squeeze, Bang, Blow!
+Join the Group Mind - become a Borg
+Joseph Stalin's grave was a Communist Plot.
+Jumbo shrimp = oxymoron.
+Junk: stuff we throw away. Stuff: junk we keep.
+Just because you're STUPID ain't no excuse.
+Just because I'm paranoid doesn't mean they aren't out to get me!
+Just do it.
+Just don't tell the asylum you saw me here
+Just how much leg have I got
+Just my 78,000 lira worth.
+Just what part of 'NO' didn't you understand...?
+Just when you think you've won the rat race along come faster rats.
+Justice is incidental to law and order.
+Justice: A decision in your favor.
+Kamikaze Pilot Wanted: Experienced only need apply.
+Keep America beautiful.. properly dispose of your lawyer.
+Keep a clear head and always carry a lightbulb.
+Keep emotionally active. Cater to your favorite neurosis.
+Keyboard Not Found - Press [F1] to Continue
+Kicked wide of the goal with such precision.
+Kids-They're not sleeping, they're recharging!
+Kill them all! .... Let God sort them out.
+Killer Rabbit's Motto: 'Lettuce Prey.'
+Kilroy occupied these coordinates.
+Kleptomania: take something for it
+Know what I hate? I hate rhetorical questions!
+Knowing Murphy's Law won't help either.
+LISP: To call a spade a thpade.
+LISTEN HERE! I HAVE FIRST AMENDENT RIGH(@#$!9*&^ NO CARRIER
+LOTUS - Let Only The Users Suffer
+Laddie, ya think ya might like ta ... rephrase that?
+Land of the Single Entendre...
+Last week I forgot how to ride a bicycle.
+Laugh and the world thinks you're an idiot.
+Laughter: The shortest distance between two people.
+Lead me not into temptation, I can find it myself.
+Lesser artists borrow. Great artists steal.
+Let he who takes the plunge remember to return it!
+Let's organize this thing and take all the fun out of it.
+Let's split up, we can do more damage that way.
+Liberal - a power worshiper without power.
+Libraries: There are no answers, only cross references.
+Life - brief interlude between nothingness and eternity.
+Life can be great if you live it to the fullest!
+Life is a sandwich, and it's always lunchtime
+Life is a series of very rude awakenings.
+Life is like a Car-wash and I'm on a bicycle.
+Life is only as long as you live it.
+Life is serious, but ART is fun!
+Life is tough. It's tougher when you're stupid.
+Life is uncertain...eat dessert first!
+Life sucks, but Death swallows!
+Life would be easier if I had the source code.
+Life's too short to dance with ugly men.
+Life's too short to dance with ugly women.
+Life, loathe it or ignore it, you can't like it.
+Likelihoods, however, are 90% against you.
+Likes and dislikes are among my favorites
+Linux, the choice of a GNU generation.
+Liposuction will destroy your FAT
+Lisp programmers have to stop and collect garbage.
+Live before you die.
+Living poor is best left to those with no money.
+Locked coathanger in car. Good thing I had a key.
+Looks like I picked the wrong week to stop sniffing glue.
+Love is blind, marriage is the eye-opener.
+Luxuriantly hand-crafted from only the finest ASCII.
+M.A.D.D.: Midgets Against Desk Drawers.
+MOPAR = Move Over Plymouth Approaching Rapidly!
+MS Windows -- From the people who brought you EDLIN!
+MS-DOS: celebrating ten years of obsolescence
+Macho does not prove Mucho.
+Madness takes its toll; please have exact change.
+Make Headlines..use a corduroy pillow....
+Make it as simple as possible, but no simpler.
+Make it do ... Or do without.
+Make like a Tom and Cruise.
+Make like a baby and head out.
+Make like a banana and split.
+Make like a drum and beat it!
+Make like a tree and leave.
+Make somebody happy. Mind your own business.
+Make up a language and ask people for directions.
+Man has his will. Woman has her won't!
+Man invented language to satisfy his need to complain.
+Man who get hit by car, get that run down feeling
+Man who jumps through screen door likely to strain himself
+Man who put head on railroad track get splitting headache
+Man who run behind car get exhausted.
+Man who speaks with forked tongue should not kiss balloon
+Marching to a different kettle of fish.
+Mary had a little RAM -- only about a MEG or so.
+Math is the language God used to write the universe.
+May I please be excused? My Brain is full.
+May the Porsche be with you.
+May you live in interesting times.
+May your life be filled with experiences.
+Me know gammar. Me cood use it gud.
+Mediocrity requires aloofness to preserve it's dignity
+Meditation is not what you Think.
+Meet the new Boss--same as the old Boss...
+Megabyte: A nine course dinner.
+Member: International Brotherhood of Tagline Thieves!
+Memory is a thing we forget with.
+Mental Floss prevents Moral Decay.
+Mercifully free of the ravages of intelligence
+Microfiche: Sardines.
+Microsoft Windows... a virus with mouse support.
+Microsoft gives you Windows... Linux gives you the whole house.
+Migratory lifeform with a tropism for parties
+Minds are like parachutes, they only work when open.
+Misfortune: The kind of fortune that never misses.
+Misspelled? Impossible. My modem is error correcting!
+Mistakes are often the stepping stones to utter failure.
+Modem: What landscapers do to dem lawns.
+Money is the root of all wealth.
+Monogamy leaves a lot to be desired.
+Monopoly? No, we just don't want competition.
+Most of us have been at work for several hours now.
+Mother is the invention of necessity.
+Multitasking = 3 PCs and a chair with wheels!
+Multitasking causes schizophrenia..
+Murphy is out there... waiting...
+Murphy was an optimist.
+Murphy's law needs to be repealed.
+Must Go - My Rotweiler needs its teeth sharpened.
+My *taglines* are original. *I* am a copy.
+My RAM's not what it used to be, so don't quote me.
+My attention isn't hard to get. It IS hard to keep...
+My best friend is a social worker.
+My computer has a terminal illness
+My computer's sick, I think my modem's a carrier
+My couch potato routine honed to perfection
+My fallacies are more logical than your fallacies.
+My foolish parents taught me to read and write.
+My hat covers my head... Just like hair used to!
+My haystack had no needle!
+My head is sore, and there's a hole in the brick wall!
+My inferiority complexes aren't as good as yours.
+My karma ran over your dogma.
+My life may be strange, but at least it's not boring
+My message above. Your response here ____________.
+My other computer is a Cray Y/MP-4!
+My other computer is a HAL 9000.
+My other computer is an abacus.
+My other vehicle is a Galaxy Class Starship ...
+My reality check just bounced.
+My tagline can beat up your tagline!
+My weight is perfect for my height... which varies.
+NAVY: Never Again Volunteer Yourself
+NETWORK: What fishermen do when not fishing.
+NEWS! Drunk gets nine months in violin case
+NEWS! Enraged cow injures farmer with ax
+NEWS! Iraqi head seeks arms
+NEWS! Police begin campaign to run down jaywalkers
+NEWS! Stolen painting found by tree
+NEWS! Survivor of siamese twins joins parents
+NO! Taco Bell is NOT the Mexican Phone Company!
+NUMBER CRUNCHING: Jumping on a Computer.
+Naaah, real men don't read docs.
+Nanosecond: Mork's stunt man.
+Neil Armstrong tripped.
+Neither rain, nor snow, nor l?ne n*oi*se
+Neurotic: Self-taut person.
+Never argue with a woman when she's tired, or rested.
+Never assume. It makes an 'ass' out of 'u' and 'me'.
+Never count your chickens before they rip your lips off.
+Never draw fire, it irritates everyone around you
+Never eat anything bigger than your head.
+Never eat more than you can lift.
+Never enter a battle of wits unarmed.
+Never go with the odds
+Never hit a man with glasses. Use your fist!
+Never judge a man by his taglines.
+Never let your feet run faster than your shoes.
+Never mind the facts - I know what I know.
+Never park your hard disk in a tow-away zone.
+Never say, 'Oops!'; always say, 'Ah, interesting!'
+Never test for an error you don't know how to handle.
+Never trust a man who can count to 1,023 on his fingers
+Never trust a skinny cook.
+Never underestimate the power of human stupidity.
+Never use a preposition to end a sentence with.
+New Highway gets Railroaded.
+Newsbytes - Microsoft announce EDLIN for Windows.
+Nihilism should commence with oneself.
+Ninety per cent of everything is crap.
+Nitpicking: Not just a hobby, it's a way of life!
+Nitrate: Lower than the day rate.
+No .sig is a good .sig
+No free lunch in an ecosystem.
+No one EXPECTS the Spanish Inquisition!!!
+No one ever said 'if I'd only spent more time in the office'
+No radio. Already stolen.
+No sense being pessimistic. It wouldn't work anyway.
+No wanna work. Wanna bang on keyboard.
+No, I'm from Iowa. I only work in Outer Space.
+Nobody roots for Goliath.
+Nobody shoots at Santa Claus.
+Nodding the head does not row the boat.
+None of you exist, my Sysop types all this in.
+Nostalgia isn't what it used to be.
+Not a computer nerd; merely a techno-weenie.
+Not a real tagline, but an incredible soy substitute.
+Not many people realize just how well known I am.
+Not now, John, we gotta get on with the game show...
+Not quite human any longer.
+Nothing is 100% certain, bug free or IBM compatible.
+Nothing is as inevitable as a mistake whose time has come
+Nothing is ever so bad that it can't get worse.
+Nothing is foolproof because fools are so ingenious
+Nothing is impossible for anyone impervious to reason
+Nothing recedes like success.
+Nothing succeeds like excess.
+Now entering Iowa. Please set your clocks back 20 years.
+Now go away or I shall taunt you a second time.
+Now is not a good time to annoy me
+Now is the time for all good men to come to.
+Now that I've given up hope I feel much better...
+Nudge, nudge, wink, wink, know what I mean?
+O Oysters come and walk with us, the Walrus did beseech.
+OK Scotty, detonate and energize NOW! No, wait, I mean.......
+OK, I'm weird! But I'm saving up to become eccentric.
+OPERATOR! Trace this call and tell me where I am.
+OUT TO LUNCH - If not back at five, OUT TO DINNER!
+Obe Wan Kenobi at the dinner table: 'Use the FORKS, Luke!'
+Objection, your Honor! My client is an idiot!
+Objectivity is in the eye of the beholder
+Objects in taglines are closer than they appear.
+Of all the people I've met you're certainly one of them
+Of all the things I've lost, I miss my mind the most.
+Of course I'm running Windows[kVxB NO CARRIER
+Oh goody! Another Muranium Explosive Space Modulator!
+Oh no you don't! You're not stealing this one!
+Oh no, not another learning experience!
+Oh, Bullwinkle, that trick NEVER works!
+Ok, I pulled the pin. Now what? Where are you going?
+Okay - right after this one we're BACK to the TOPIC
+Old MacDonald had a computer with an EIE I/O
+Old age is better than the alternative.
+On a clear disk you can seek forever.
+On a scale of 1 to 10, 4 is about 7.
+On an electrician's truck: Let Us Remove Your Shorts
+One atom bomb can really ruin your day.
+One good turn gets most of the blanket.
+One is never as happy or unhappy as one imagines.
+One man's Windows are another man's walls...
+One man's upload is another man's download
+One night I came home very late. It was the next night
+One tactical thermonuclear weapon can ruin your whole day.
+One way to better your lot is to do a lot better...
+One way to stop a run away horse is to bet on him.
+Only 19,999 lines of C++ to my next ski trip...
+Only cosmetologists give make-up exams.
+Only the winners decide what were war crimes.
+Open Mouth. Insert Foot. Chew Carefully.
+Optimization hinders evolution.
+Originality is the art of concealing your sources.
+Our houseplants have a good sense of humous.
+Our necessities are few but our wants are endless...
+Out here in the fields...I fight for my meals...!
+Out of Memory!? But I fed you 6 Megs this morning!
+Out of the mouths of babes does often come cereal.
+Outlaw junk mail, and save the trees!
+Overload--core meltdown sequence initiated.
+Oxymoron - Definite possibility
+Oxymoron - Military Intelligence
+Oxymoron: Bosnian Cease-Fire
+Oxymoron: Soviet Union.
+PC! Politically Correct (or) Pure Crap!
+PCBackup: 1 of 1362 disks.
+PI seconds is a nanocentury. - Tom Duff, Bell Labs
+PKZip - it's not just for downloads anymore
+Pain is inevitable, suffering is optional.
+Palindrome isn't one.
+Pandemonium doesn't reign here... It pours!
+Paranoia is heightened awareness.
+Paranoia is simply an optimistic outlook on life.
+Pardon my driving, I'm trying to reload.
+Pascal: What's it Wirth?
+Passwords are implemented as a result of insecurity.
+Patience is a virtue that carries a lot of WAIT!
+Pay your electric bill in pennies.
+Peace through superior firepower.
+People are always available for work in the past tense.
+People say I'm apathetic, but I don't care.
+People who live in glass houses shouldn't!
+People who live in stone houses shouldn't throw glasses.
+Perot/Bush/Quayle: The Millionaire, Skipper & Gilligan.
+Pet Store: 'Buy one, get one flea.'
+Petroleum and coffee had no value a few centuries ago.
+Pi R squared. Nooo! Pie R round, cornbread R square!
+Pizza IS the four food groups!
+Plagiarism is the sincerest form of flattery.
+Plagiarism prohibited, derive carefully.
+Plankton lobbyist: 'NUKE THE WHALES!'
+Plasma is another matter.
+Please Tell Me if you Don't Get This Message
+Please call the windows police. I've caught another gpf.
+Please don't drink and post.
+Please don't take my sunshine away.
+Please recycle this tagline. Once is not enough.
+Pobody's Nerfect!
+Poets go from bad to verse
+Point not found. A)bort, R)eread, I)gnore.
+Politeness, n: The most acceptable hypocrisy.
+Political panjandrums prologize pedantic paronomasia.
+Political power grows out of the barrel of a gun.
+Politics is the entertainment branch of industry.
+Positive: Mistaken at the top of one's voice.
+Pound forehead on keyboard to continue.
+Power corrupts, but we need electricity.
+Power corrupts. Absolute power is kind of neat.
+Predestination was doomed from the start.
+Predicting the future of technology is fraud with peril!
+Prejudice is the reason of fools. - Voltaire.
+Preserve wildlife... pickle a rat.
+Press <CTRL>-<ALT>-<DEL> to continue...
+Press any key to continue or any other key to quit
+Press any key...NO, NO, NO, NOT THAT ONE!!!!!!
+Procrastination means never having to say you're sorry.
+Procrastination: The art of keeping up with yesterday.
+Program too small to fit into memory.
+Programming is an art form that fights back.
+Progress is made on alternate Fridays.
+Prosecutors will be violated
+Psychiatrists stay on your mind.
+Psychoceramics: The study of crackpots.
+Push the limit, and the limit will move away!
+Put on your seatbelt. I wanna try something.
+Put people on hold when possible.
+Quantum mechanics do it in leaps.
+Quasimodo is a dead ringer.
+Question Authority, ask me anything
+RAID Antivirus - Kills Virus's DEAD!!!
+Racial prejudice is a pigment of the imagination.
+Radioactive halibut will make fission chips.
+Random order = oxymoron
+Rap music = oxymoron
+Read the dictionary backwards and look for secret messages.
+Real Programmers aren't afraid to use GOTO's.
+Real Trekkers work out at the He's Dead Gym.
+Real men don't set for stun.
+Real men write self-modifying code.
+Reality is a crutch for people who can't handle buttons
+Reality is an obstacle to hallucination.
+Reality is for people who can't handle Star Trek.
+Reality is nothing but a collective hunch.
+Really ?? What a coincidence, I'm shallow too!!
+Recursive, adj.; see Recursive
+Red ship crashes into blue ship - sailors marooned.
+Reduce Carbon Dioxide emmissions - STOP Breathing
+Redundancy: A Politician with an airbag in his car.
+Refuse Novocain...Transcend Dental Medication!
+Remember that you are unique. Just like everyone else.
+Remember, If you're not in bed by 10:30..... go home!
+Remember, Subaru spelled backwards is U-R-A-BUS.
+Reputation: what others are not thinking about you.
+Resistance Is Useless! (If < 1 ohm)
+Return((usBirdInHand = 2 * InTheBush()));
+Reverse the polarity of the neutron flow.
+Revolution is the opiate of the intellectuals.
+Road Kill Cafe: You kill 'em, we grill 'em.
+Roses are red, Violet's are blue, And mine are white.
+Rotisserie: a ferris wheel for chickens
+Round up the usual suspects!
+Rubber bands have snappy endings!
+Russian Express Card motto: Don't leave home!
+S met ing's hap ening t my k ybo rd . .
+SCUD : Sure Could Use Directions
+STICK: A boomerang that doesn't work.
+STUPIDITY is NOT a HANDICAP! Park elsewhere!
+SYNTAX? Why not--they tax everything else!
+SYSTEM ERROR: press F13 to continue...
+Santa's elves are just a bunch of subordinate Clauses.
+Sarcasm: barbed ire.
+Save California; when you leave take someone with you.
+Save energy: be apathetic.
+Save the whales! Trade them for valuable prizes!
+Save the whales. Collect the whole set.
+Save your money for a rainy day, or a new computer!
+Say yer prayers, y' flea-bitten' varmint.
+Schizophrenia beats being alone.
+Science asks why. I ask why not.
+Science: preconception meeting verification.
+Scientists discover life causes cancer.
+Scotty! Hurry! Beam me uragg^*z~% NO CARRIER
+Scrute the inscrutable, eff the ineffable.
+See how you can be?
+Seeing is deceiving. It's eating that's believing.
+Send lawyers, guns, & money...
+Send more tourists..... the last ones were delicious!
+Sentient plasmoids are a gas.
+Serving the scum of Paris for over 300 years
+Set mode=Extremely verbose
+Shareware author dies: .GIF at eleven!
+Shareware: forget the manual...phone the author at home!
+ShelfDoze is a registered Trademark of M$.
+Shell to DOS... come in DOS... Do you copy?
+Shh! Be vewy quiet, I'm hunting wuntime errors!
+Shin - a device for finding furniture in the dark..
+Shoot your program and put it out of its memory!
+Shoplifters with the runs take Clepto Bismol
+Short people are vertically challenged.
+Should I or shouldn't I?... Too late, I did!
+Should I weed the lawn or say it's a garden?
+Show me a sane man. I'll cure him for you.
+Sign here please:_______________________Thanks
+Sign on Closed Nuclear Power Plant... 'Gone Fission'
+Sign on a clothing store - Come inside and have a fit.
+Signito ergo sum - I sign therefore I am.
+Simon says: don't be so suggestible.
+Sit down, you're rocking the boat!
+Six of one, 110 (base 2) of another.
+Skating away on the thin ice of a new day.
+Slower Traffic Keep Right - Is that so difficult?
+Slug Sautee: a hors of a different d'oeuvre.
+Small changes pick up the reins from nowhere.
+Smash forehead on keyboard to continue...
+Smile. It's the second best thing you can do with your lips.
+Smile... people will wonder what you've been up to.
+Smiley faces were meant to be annoying.
+Smokey the Bear says, 'Strip mining prevents forest fires!'
+Smoking cures weight problems...eventually.
+Smoking is a leading cause of statistics.
+Smurf exterminator.
+So many bytes, so few cps.
+So many lawyers, so few bullets.
+So many pedestrians, so little time.
+So many toys, so little time...
+So much time, and so little to do.
+Socialism is the equal distribution of poverty.
+Software Independent: Won't work with ANY software.
+Software means never having to say you're finished
+Some Do, Some Don't, Some Will and Some Won't.
+Some People....
+Some days you're a bug, other days a windshield.
+Some days, nothing goes left.
+Some little dipstick stole all my good taglines...
+Some minds should be cultivated, others plowed under...
+Some people are so nice to be nasty to.
+Some people are, through no fault of their own, sane.
+Some things have got to be believed to be seen.
+Someone is unenthusiastic about your work.
+Something is rotten in the state of confusion.
+Sometimes a cigar is just a cigar.
+Sorry about your Rectal-Cranial Inversion.
+Sorry, I don't date outside my species.
+Sorry... my mind has a few bad sectors.
+Southern DOS: Y'all reckon? (yep/Nope)
+Space is an illusion, disk space doubly so.
+Space is big. Really big.
+Spaceman Spiff, Interplanetary Explorer!
+Speaking only for myself, one of my many tricks.
+Spell chequers dew knot work write.
+Spice is the variety of life.
+Stamp out philately!
+Standing there making a sitting target of himself.
+Stay Alert. Stay Awake. Stay Alive.
+Steal my cash, car and TV - but leave the computer!
+Sterility is hereditary.
+Stop tagline theft! Copyright your tagline ©
+Strike any user when ready.
+Stupidity got us into this mess, why can't it get us out?
+Subvert the dominant paradigm!
+Suicide is the most sincere form of self criticism.
+Sumo Wrestling: survival of the fattest.
+Supercalifragilisticexpialidocius
+Supernovae are a Blast
+Support bacteria - it's the only culture some people have!
+Support the helpless victims of computers.
+Surprise your boss. Get to work on time.
+Swish, two, three, four! Swish, two, three, four!
+Sylvester Stallone: father of the RISC concept.
+THE GOLDEN RULE: He who has the gold makes the rules
+TV is chewing gum for the eyes.
+Tact: knowing how far to go too far.
+Tact: making a point without making an enemy.
+Tagline Lotto: 2222222222<- Scratch here for prize.
+Tagline theft is a compliment.
+Taglines \'tag-l\ 4inz \ The bumperstickers of the internet
+Take a bite out of crime .. Abolish the IRS!
+Take my advice, I don't use it anyway.
+Take two crows and caw me in the morning
+Talk is cheap because Supply exceeds Demand.
+Taxes are not levied for the benefit of the taxed.
+Teamwork is essential. It gives them another target.
+Ten weeks from Friday will be a pretty good day.
+Thank you very little.
+That ain't so good English!
+That must be wonderful! I don't understand it at all.
+That that is is not that that is not.
+That was ZEN -- this is TAO
+That'll be $67.50 CCCHHHHHIIIIINNNNGGGG!!!!
+That's inches away from being millimeter perfect.
+The Borg assimilated me & all I got was this stupid T-Shirt!
+The Czech's in the mail. Sending Frenchman by FAX.
+The French defense isn't...
+The Hubbell works fine; all that stuff IS blurry!
+The Lab called,..... Your brain is ready!
+The Magic of Windows: Turns a 486 back into a PC/XT.
+The Microsoft Motto: 'We're the leaders, wait for us!'
+The PARITY CHECK is in the E-MAIL...
+The Tour de France!
+The UARTs won't take this speed, Captain
+The Universe is a big place... perhaps the biggest
+The Vatican Express Card. Don't leave Rome without it.
+The backup's not over 'til the FAT table sings!
+The ballot is stronger than the bullet.
+The best cure for insomnia is to get a lot of sleep.
+The best defense against logic is stupidity.
+The best defense is to stay out of range.
+The best substitute for experience is being sixteen.
+The best way to keep friends is not to give them away.
+The best way to win an argument is to be right.
+The buck doesn't even slow down here!
+The cause of problems are solutions!
+The cost of feathers has risen... Now even DOWN is up!
+The cost of living hasn't affected its popularity.
+The cream rises to the top. So does the scum...
+The days of the digital watch are numbered
+The dentist said my wisdom teeth were retarded.
+The dreadful burden of having nothing to do.
+The evidence before the court is...INCONTROVERTIBLE!
+The eyes are the mirror of the soul.
+The first duty of a revolutionary is to get away with it
+The first myth of management is that it exists.
+The first rule of intelligent tinkering is save all parts!
+The fish that escaped is the big one.
+The further I go, the behinder I get.
+The future isn't what it used to be.
+The game's a little bit wide open again.
+The gene pool has no lifeguard.
+The hand that turneth the knob, opens the door.
+The hangman let us down.
+The hardest thing about time travel is the grammar.
+The heart is wiser than the intellect...
+The irony of life is that no one gets out alive...
+The large print giveth and the small print taketh away.
+The little engineer that could
+The longer the title, the less important the job.
+The man who begins many things finishes few.
+The margin is very marginal.
+The meek shall inherit the earth, if that's OK with you
+The mind is like a parachute - it works only when open.
+The moving cat sheds, and having shed, moves on...
+The next thing to do is hang all the consultants.
+The only thing shorter than a weekend is a vacation.
+The option to override self-destruct expir@^%i@&$#NO CARRIER
+The pen is mightier than the pencil.
+The penalty for bigamy is having two mothers-in-law.
+The pendulum has gone full circle.
+The purpose of computing is insight, not numbers.
+The rich get richer; the poor get babies.
+The road to success is always under construction.
+The score didn't really reflect the outcome.
+The secret of the universe is~~*#~** FF * NO CARRIER
+The shortest distance between two points is off the wall
+The simple explanation always follows the complex solution
+The sixth sheikh's sixth sheep's sick.
+The soul would have no heart had the eyes no tears...
+The superfluous is very necessary.
+The thrill is gone, the thrill is gone baby
+The universe is a spheroid region 705 meters in diameter...
+The unnatural, that too is natural.
+The way to a man's heart is through the left ventricle.
+The weather is here, wish you were beautiful.
+The whole world is about three drinks behind
+The world is coming to an end. Please log off.
+The worst thing about censorship is **************************.
+The young know the rules, the old know the exceptions.
+Then somebody spoke, and I went into a dream....
+There are 2 ways to handle women and I know neither.
+There are many things I could say...
+There are no atheists in the foxholes.
+There is always a way, and it usually doesn't work.
+There is an exception to every rule, except this one.
+There is much Obiwan did not tell you.
+There is no dark side of the moon. Really.
+There is no finish line.
+There is no remedy for fun but more fun!
+There is no vaccine against stupidity.
+There is something to be said about me: 'Wow!!'
+There will be no last bus tonight.
+There's a hot place with pitchforks waiting.
+There's no future in time travel
+There's no such thing as a free lunch, but you can always find someone willing to treat.
+There's one in every car... You'll see.
+There's one in every crowd and they always find me.
+There's safety in numbers/When you learn to divide.
+Thesaurus: ancient reptile with an excellent vocabulary.
+They told me I was gullible ... and I believed them!
+Things are not what they seem.
+Think 'HONK' if you're a telepath.
+Think hard now! Which one is Shinola?
+This Charlie Brown must have been a very wise man.
+This Country Needs Group Therapy.
+This ain't no party...this ain't no disco...
+This door is baroque; please call Bach later.
+This is a Tagline mirror ][ rorrim enilgaT a si sihT
+This is abuse. Arguments are down the hall.
+This is just a hobby. Perfection is not required. Fun is.
+This is not a fairing, it's a force field.
+This is only a test.
+This is our only tag line.
+This isn't right. This isn't even wrong.
+This line intentionally left unjustified.
+This login session: $13.99, but for you $11.88
+This message has been UNIXized for your protection.
+This message is SHAREWARE! To Register, send $5.
+This message was typed on recycled phosphorous.
+This mind intentionally left blank.
+This program makes me look like a genius.
+This sentence is false.
+This tagline does not require Micro$oft Windows.
+This tagline intentionally left blank.
+This tagline is umop apisdn
+This tagline only to be removed by the consumer.
+This tagline was created from many little letters.
+This tagline was reclaimed and is not yet stolen.
+This tagline was written before a live studio audience.
+Those who can't write, write manuals.
+Those who can, do. Those who can't, simulate.
+Those who can, do. Those who can't, supervise!
+Those who live by the nit, die by the nit
+Those without heads do not need hats.
+Three can keep a secret, if two are dead.
+Tilt your chair back, your breath is effecting my RAM!
+Tilting at windmills hurts you more than the windmills.
+Time flies like an arrow - Fruit flies like a banana
+Time flies when you don't know what you're doing.
+Time is an illusion, lunchtime doubly so.
+Tis better to be hunter than hunted.
+Tis better to have loved a short than to never have loved a tall.
+Tis better to have loved and lost than just to have lost.
+To be, or not to be, those are the parameters.
+To boldly go and watch Star Trek re-runs.
+To do nothing is also a good remedy.
+To eat is human, to digest, divine.
+To err is human, to eat Jello, is messy.
+To err is human, to forgive is against company policy.
+To err is human. To really screw up it takes a computer.
+To err is human. To blame someone else is politics.
+To err is human. To moo bovine
+To every rule there is an exception, and vice versa.
+To iterate is human, to recurse, divine.
+To live in the hearts we leave behind, is not to die.
+To live well, know the difference between good and evil.
+To me personally, it's nothing personal to me.
+To shoot a mime, do you use a silencer?
+Today is Monday, cleverly disguised as Tuesday.
+Today is National Existential Ennui Awareness Day.
+Today is the first day of the rest of this mess.
+Today is the tomorrow you worried about yesterday
+Todays subliminal message is ' '
+Tolkien is hobbit-forming.
+Tongue tied & twisted, just an earthbound misfit I.
+Too bad stupidity isn't painful.
+Too much is never enough.
+Too much month at the end of the money.
+Too much of a good thing is WONDERFUL.
+Toto, I don't think we're in DOS anymore...
+Touch if you must, Pay up if you bust.
+Toys are made in heaven, batteries are made in hell.
+Trees hit cars only in self-defence.
+Trespassers will be shot, survivors will be shot again!
+Tried to play my shoehorn... all I got was footnotes!
+Trig..a..name...o...tree!!!
+Truck Pulls: for people who cannot understand the WWF
+Trust me -- I'm a Lawyer.
+Truth is just another misconception.
+Truthful: Dumb and illiterate.
+Try to get back on topic, he said moderately.
+Try to look unimportant, they may be low on ammo
+Try? Try not. Do, or do not. There is no try.
+Trying to think of a good tagline...
+Tubby or not tubby, fat is the question!
+Turn right here. No! NO! The OTHER right!
+Turning floppies into hard drives.
+Two Wrongs Don't Make A Right, But Three Lefts Do.
+Two heads are more numerous than one.
+Two most common elements: hydrogen, stupidity.
+Tyre Shop sign - We Skid You Not.
+UART what UEAT!
+UNNAMED LAW: If it happens, it must be possible.
+Uh, yeah...I MEANT to do that!
+Ultimate Question Research Team
+Unable to locate Coffee -- Operator Halted!
+Unburdened by the rigors of coherent thought.
+Unix and the world Unix with you; VAX and you VAX alone.
+Unless you're the lead dog, the view never changes.
+Unqualified superlatives are the worst of all.
+Until people grow up, they have no idea what's cool
+Use your MasterCard to pay your Visa bill.
+Users, losers -- what's the difference?
+Using yesterday's technology to solve today's problems, tomorrow
+VLSI: 'Getting High On Low Voltage'
+Vampires Against Mundane Poetry.
+Variables won't; constants aren't.
+Veni Vidi Visa: I came, I saw, I did a little shopping.
+Verbosity leads to unclear, inarticulate things.
+Volcano -- a mountain with hiccups.
+Vote Democratic... It's easier than getting a job.
+Vuja De - The Feeling You've Never Been Here
+Vulcans have less fun.
+Vultures only fly with carrion luggage.
+W.A.R.P.: We Are Real Programmers.
+WAITER! there's soup in my fly!
+WARNING ... drinking tap water can kill your thirst!
+WARNING: my messages are offensive to morons!
+WINDOWS ERROR #004: Operator fell asleep while waiting.
+WWhhaatt ddooeess dduupplleexx mmeeaann??
+WYGIWYD -What you got is what you deserved.
+WYTYSYDG-What you thought you saw, you didn't get.
+Waiter, there's no fly in my soup! - Kermit
+Walk softly and carry a megawatt laser.
+Walls impede my progress
+Wanna flirt with disaster? Become a SysOp!
+Want a LAUGH run a spell check on DSZ docs.
+Want a jelly baby?
+Want a stupid answer? Ask me anything!
+Wanted: Volcano. Average size. Must be active.
+War News: Saddam's army blown away by Thai hookers.
+Warning: Whimsical when bored
+Warning: Politicians can damage your wealth.
+Warranty void if tagline removed.
+Was today really Necessary?
+Wash your face in the morning, neck at night.
+Wasting time is an important part of living.
+We all live in a yellow subroutine.
+We are not a clone.
+We are the people our parents warned us about
+We don't care. We don't have to. We're Telecom...
+We have here the latest in primitive technology.
+We seem to have juxtaposed an impasse here
+We should limit congressmen to two terms: one in Congress, one in prison
+We take drugs very seriously at my house...
+We were unanimous - in fact everyone was unanimous.
+We'll give you piece de resistance and a tour de force
+We're as similar as two dissimilar things in a pod.
+We're lost, but we're making good time.
+We're staying together for the sake of the cats.
+Weeping, I wake; waking, I weep, I weep.
+Welcome to Texas, now go home.
+Welcome to the Church of the Holy Cabbage. Lettuce pray
+Well cover me in egg & flour and bake me for 14 minutes
+What are you doing?!? The message is over,GO AWAY!
+What can you do for me?
+What color is a chameleon on a mirror?
+What could possibly go wrong.
+What do batteries run on?
+What do you mean that 2 years have passed??
+What do you think?
+What does Santa do at a house with no chimney?
+What does ignorant mean?
+What does this red button do?
+What else can you do at 3:00 am?
+What garlic is to salad, insanity is to art.
+What goes around usually gets dizzy and falls over.
+What goes up has probably been doused with petrol.
+What has four legs and an arm? A happy pitbull.
+What's Irish and stays out all night? Paddy O'Furniture.
+What's another word for 'thesaurus?'
+What's brown and sticky? A stick!
+When 911 won't work .357 will!
+When in doubt, think.
+When their numbers dwindled from 50 to 8, the dwarfs began to suspect 'Hungry'
+When your opponent is down, kick him.
+Where does weight go when you lose it?
+Where in the world is Carmen San Diego?
+Who cares how it plays in Peoria?
+Who cares who's on board?
+Who glued the cup to the table?
+Who is 'they' anyway?
+Whosoever diggeth a pit shall falleth therein.
+Why am I asking all these things?
+Why are Chinese fortune cookies written in English?
+Why are you looking down here? The joke is above!
+Why are you wasting time reading taglines?
+Why aren't there many Hannukah specials on tv?
+Why can't we just spell it orderves?
+Why did you read this?
+Why do people cry when they're sad?
+Why do they tell us to watch 'The Today Show' tomorrow?
+Why do we elect people and then become afraid of them?
+Why do we read left to right yet turn pages right to left?
+Why do you think they call it 'find'?
+Why does it matter if we all put our pants on one leg at a time?
+Why does the beginning of your sentence end up in the middle of mine?
+Why don't ease, lease, and please sound alike?
+Why don't tomb, comb, and bomb sound alike?
+Why get even, when you can get odd?
+Why is 'abbreviated' such a long word?
+Why isn't 'palindrome' spelled 'palindromeemordnilap'?
+Will Rogers never met a lawyer.
+Will the sound of one hand clapping still turn off my TV?
+Win if you can, lose if you must, but always cheat
+Windows Error #F99 - CPU too tired to continue...
+Windows N'T: as in Wouldn't, Couldn't, and Didn't.
+Windows NT: Only 16 megs needed to play Minesweeper!
+Windows NT: The world's only 80 megabyte Solitaire game!
+Windows NT: Vapourware of the desperate and scared.
+Windows error 000 : No errors found! [CLOSE]
+Windows is *NOT* a virus. Viruses *DO* something!
+Windows is for fun, Linux is for getting things done.
+Windows is the best GUI - It always sticks!
+Windows isn't CrippleWare -- it's 'Functionally Challenged'.
+Windows only crashes itself under Linux. Not the whole machine.
+Windows would look better with curtains.
+Windows: The answer to a question nobody has ever asked.
+Windows: an Unrecoverable Acquisition Error!
+WindowsNT: From the makers of Doublespace
+Wisdom is knowing what to do with what you know.
+Wit is cultured insolence.
+Without Time, everything would happen at once.
+Without music, life would be a mistake.
+Women - can't live with 'em and no resale value...
+Women do come with instructions; ask them.
+Women get minks the same way minks get minks.
+Women who seek to be equal to men lack ambition.
+Women! Can't live with 'em and no resale value.
+Work off excess energy. Steal something heavy
+World ends today at 9:30 pm! Film at 11:00...
+Worry : The interest paid on trouble before it's due
+Worst-dressed sentient being in the known universe
+Would I ask you a rhetorical question?
+Yes my son, long ago mail was read 1 packet at a time.
+You buttered your bread, now lie in it.
+You can name your salary here. I call mine Fred.
+You can tune a guitar, but you cant tuna fish.
+You can't have everything...where would you put it?
+You hit the nail right between the eyes.
+You're it.
+You've got to be trusted by the people that you lie to.
+Young gorillas are friendly, but they soon learn.
+Your E-Mail has been returned due to insufficient voltage!
+Youth is a gift of nature. Age is a work of art.
+Yuk, what kind of dumb menu system is that? Oh, so that is Windows!
+Zen T-Shirt: Enlightenment Available - Enquire Within
+[DISCLAIMER: my fingers are epileptic]
+[If you can't hear me, it's because I'm in parentheses]
+hAS ANYONE SEEN MY cAPSLOCK KEY?
+Serenity through viciousness.
+FUN is never having to say you're SUSHI!!
+Include me out.
+YOW!! I'm in a very clever and adorable INSANE ASYLUM!!
+'That boy's about as sharp as a pound of wet liver' -- Foghorn Leghorn
+Pardon me while I laugh.
+Vegeterians beware! You are what you eat.
+Marriage is the sole cause of divorce.
+'From there to here, from here to there, funny things are everywhere.' -- Dr. Seuss
+You'll be sorry...
+The world is coming to an end. Please log off.
+UH-OH!! We're out of AUTOMOBILE PARTS and RUBBER GOODS!
+I used to get high on life but lately I've built up a resistance.
+Paranoia is heightened awareness.
+The things that interest people most are usually none of their business.
--- /dev/null
+#v1.5.0: infobot
+
+#botpark
+ -OnJoin
+ +RootWarn
+ +autojoin
+
+#debian-bots
+ +News
+ +RootWarn
+ +chanlimitcheck
+ chanlimitcheckInterval 10
+ chanlimitcheckPlus 10
+ factoidDeleteDelay 7
+ ircTextCounters heh hah :) ? hi lol
+ +joinfloodCheck
+ limitcheckInterval 10
+ limitcheckPlus 10
+ newsDefaultExpire 7
+ +newsKeepRead
+ +newsNotifyAll
+ rootWarnMode aggressive
+
+_default
+ +BZFlag
+ +Debian
+ +DebianExtra
+ +Dict
+ +Exchange
+ +Factoids
+ +HTTPDtype
+ +Kernel
+ +Math
+ +OnJoin
+ +Plug
+ +Quote
+ +Rss
+ +Search
+ +Topic
+ +Units
+ +UserInfo
+ +W3Search
+ +Weather
+ +Zippy
+ addressCharacter ~
+ +allowConv
+ +allowTelling
+ +babelfish
+ +botmail
+ +case
+ +cookie
+ +countdown
+ debianRefreshInterval 7
+ +dice
+ +dns
+ +factoidArguments
+ factoidSearch $chan _default
+ floodMessages 10:30
+ floodRepeat 2:10
+ +freshmeat
+ freshmeatRefreshInterval 24
+ +insult
+ +karma
+ +lart
+ +limitcheck
+ +log
+ maxListReplyCount 15
+ maxListReplyLength 400
+ +md5
+ minVolunteerLength 50
+ +nickometer
+ +pager
+ +piglatin
+ randomFactoidInterval 60
+ randomQuoteInterval 60
+ +reverse
+ +scramble
+ +sed
+ +seen
+ seenFlushInterval 60
+ seenMaxDays 90
+ +seenStats
+ +seenStoreAll
+ sendNoticeLimitBytes 1000
+ sendNoticeLimitLines 3
+ sendPrivateLimitBytes 1000
+ sendPrivateLimitLines 3
+ sendPublicLimitBytes 1000
+ sendPublicLimitLines 3
+ +slashdot
+ +spell
+ +tell
+ +wtf
+ +zfi
+ +zsi
--- /dev/null
+# infobot configuration file, modify it to your own taste. infobot reads
+# this file from files/infobot.config so it should be moved there.
+
+#####
+# Basic IRC info
+#####
+set ircNick infobot
+set ircUser infobot
+set ircName infobot experimental bot
+# if your irc network requires a password to get on the servers
+#set ircPasswd SomePassword
+set ircUMode +iw
+
+# if not using a virtualhost set to 0.0.0.0
+# otherwise IRC::Connection might try localhost which will NOT work
+###set ircHost vh.virtualhost.org
+set ircHost 0.0.0.0
+
+set owner OWNER
+
+# nickserv/chanserv support.
+###set nickServ_pass PASSWORD
+###set chanServ_ops #chan1 #chan2
+
+# default quit message.
+set quitMsg adios amigos
+
+# path to a temporary directory which infobot can use.
+set tempDir /tmp
+
+#####
+# Factoid database configuration
+#####
+
+# [str] Ability to remember/tell factoids
+# none -- disable.
+# mysql -- ...
+# SQLite -- SQLite (libdbd-sqlite-perl) (might be version 2 or 3)
+# SQLite2 -- SQLite (libdbd-sqlite-perl) (force version 2)
+# pgsql -- postgresql (SUPPORTED and TESTED!!!)
+### REQUIRED by factoids,freshmeat,karma,seen,...
+set DBType mysql
+
+# [str] SQLite filename prefix // MYSQL/PGSQL database.
+# eg: infobot-factoids, infobot-seen
+# eg: /var/db/mysql/infobot/factoids.*
+set DBName infobot
+
+# [str] Hostname of database server (unset for SQLite)
+set SQLHost localhost
+
+# [str] SQL user allowed to insert,update,delete stuff from tables. (unset for SQLite)
+set SQLUser infobot
+
+# [str] SQL password. (unset for SQLite)
+set SQLPass PASSWORD
+
+# [str] SQL debug file. "-" for stdout may work on some platforms
+###set SQLDebug SQL_debug.log
+
+#####
+# Logfile configuration
+#####
+
+# [file] where to put logging info. comment out to disable.
+#set logfile log/$ircUser.log
+set logfile log/
+
+# [str] Type of logging.
+# DAILY -- Create a new log each day.
+# DEFAULT -- One continuous log file.
+set logType DAILY
+
+# [int] Maximum log size, if logfile is defined, in bytes.
+set maxLogSize 10000000
+
+#####
+# Factoid-related configuration
+#####
+
+# [bool] Factoid support.
+set factoids true
+
+# [days] if not 0, number of days until factoid is deleted for good.
+set factoidDeleteDelay 0
+
+# [int] maximum length of factoid key.
+set maxKeySize 32
+
+# [int] maximum length of factoid value.
+set maxDataSize 450
+
+# [str] when should the bot bother learning new factoids.
+# ADDRESSED -- only learn when addressed.
+# HUNGRY -- learn irrelevent of addressing. this will catch
+# _everything_, use at your own risk.
+set learn ADDRESSED
+
+# [str] different behaviour with URLs.
+# REQUIRE -- means it will need to be a url type (e.g. file:, http:)
+# OPTIONAL -- will take anything
+# REJECT -- will not accept any urls. this makes it easy to
+# run 2 with different nicks and styles.
+# ^^^ what's the point of this???
+set acceptUrl OPTIONAL
+
+# [bool] profanity checking.
+set profanityCheck false
+
+# [0/1] tell so-and-so about such-and-such of a factoid.
+set allowTelling 1
+
+# [str] other bots to ask for factoids which they may have.
+#set friendlyBots url purl script mrapi
+
+#####
+# Factoid related and unrelated features, mainly Extras.
+#####
+
+# [str] addressing is when you name the bot. FIXME:
+# REQUIRE -- the bot only does something if addressed.
+# OPTIONAL -- the bot responds (does not learn) irrelevent of
+# addressing.
+set addressing REQUIRE
+
+# [str] how the bot should send messages.
+# PRIVATE -- reply to private messages only, rejecting public msgs.
+# DEFAULT -- reply to public _and_ private queries.
+set talkMethod DEFAULT
+
+# [str] how long the output string should be before it is changed from
+# public to private.
+# "+" before bot commands overrides this option temporarily.
+###set minLengthBeforePrivate 192
+
+# [0/1] allow people outside any channels the bot is on to use the bot
+# for factoids and commands.
+set disallowOutsiders 1
+
+# [int] Amount of time for auto-ignore (flooding) to expire.
+set ignoreAutoExpire 5
+
+# [int] Amount of time for forced-online ignore to expire. minutes.
+set ignoreTempExpire 60
+
+#####
+# Internal (simple) bot commands
+#####
+
+# [0/1] Forking... disable for non-nix OS or to reduce mem usage.
+# Disabling should make the bot work on Win32 and MacOS.
+set forking 1
+
+# [int] Backlog... ideal to see what happened to the bot on console.
+# maximum number of lines to backlog.
+set backlog 24
+
+#####
+# Extra features
+#####
+
+# [str] anything which requires LWP + http proxy.
+###set httpProxy http://HOSTNAME:PORT/
+
+# [0/1] countdown to specific dates
+set countdown true
+
+# [0/1] Debian file and package search.
+# FIXME: should be a channel option
+set Debian true
+
+# [0/1] Freshmeat
+set freshmeat false
+# [int] how often to update the freshmeat table, in hours.
+set freshmeatRefreshInterval 24
+
+# [bool] if factoid does not exist, check freshmeat for it.
+set freshmeatForFactoid false
+
+# [0/1] Uptime logs
+set Uptime true
+
+#####
+# Miscellaneous configuration options
+#####
+
+# [int] Display a bit too much info about stuff.
+# 0 -- disable.
+# 1 -- standard.
+# 2 -- extra.
+set VERBOSITY 1
+
+# [0/1] Warn messages.
+set WARN 1
+
+# [0/1] Debugging messages.
+set DEBUG 0
+
+# [0/1] Work In Progress...
+set WIP 0
+
+# strict perl?
+set useStrict 1
+
+# debugging...
+###set DumpVars 1
+###set dumpvarsAtExit 1
+# log to specific file or global log file.
+###set dumpvarsLogFile dumpvars.log
+# more debugging
+###set DumpVars2 1
+###set symdumpLogFile log/dumpvars2.log
+
+# [str] Interface: [IRC/CLI]
+# IRC -- Internet Relay Chat
+# CLI -- Command Line Interface
+set Interface IRC
+
+# [0/1] Show topic author (troubled)
+# If 1, topics managed with !topic add foo will show the nick in ()'s
+# If 0, the nick of the creator will be recorded for !topic list, but not shown in the topic itself
+set topicAuthor 1
+
+####
+# Now modify infobot.chan for per-channel specific configuration see
+# sample.chans for info.
+####
--- /dev/null
+# countdown file.
+20001225 christmas Christmas
+20000914 olympics Opening ceremony of Olympics in Sydney, Australia
+20000704 america Independence Day
+20000501 potato Proposed release of Debian GNU/Linux Potato 2.2
+20000420 2.4 Hopeful debut of 2.4.0 kernel
+20000315 xfree4.0 XFree86 4.0 core release
+20000217 win2k Evil Empire's Release of deadly OS
+20000126 australia Australia Day
+20000119 crusoe Transmeta comes out of hiding
+20000115 freeze Debian (GNU/Linux) Potato version 2.2 stabilization begins
+20000101 y2k Year 2000
--- /dev/null
+###
+# infobot.servers: line separated list of servers to connect to
+###
+
+irc.freenode.net
+irc.home.org
+irc.linux.com
--- /dev/null
+#v1.5.0: infobot -- written Mon Feb 28 23:46:48 2005
+# Please edit to your needs.
+# "local" is used for CLI mode
+# Passwords can be generated with mkpasswd in linux
+
+_default
+--FLAGS amrt
+--HOSTS *!*@*
+
+local
+--FLAGS Aemnorst
+--HOSTS local!local@local
+--PASS xxfxfIfoJHdYg
+
+timriker
+--FLAGS Aemnorst
+--HOSTS *!~timr@TimRiker.active.supporter.pdpc
+--PASS xxfxfIfoJHdYg
+
+xk
+--FLAGS emnorst
+--HOSTS *!xk@example.com
+--HOSTS *!xk@superbox.home.org
+--PASS 5K/rmJPzwxJhU
+
--- /dev/null
+#
+# Unit defintions
+# 18 May 2001 M-J. Dominus <mjd-perl-units+@plover.com>.
+# This file is in the PUBLIC DOMAIN.
+# All rights abandoned.
+#
+# If you discover definitions of units that do not appear in this
+# file, you are invited to mail them to mjd-perl-units+@plover.com, so
+# that I can include them in a future version. Please include the
+# date of this file, 18 May 2001, with all such submissions.
+
+# If a unit is defined as `***', that means
+# it has no definition because it is a fundamental unit.
+
+# http://perl.plover.com/units/unittab
+
+# Fundamental units:
+# Seven instrinsic SI units:
+gram ***
+meter ***
+# Tim Riker <Tim@Rikers.org> adds metre alias
+metre meter
+second ***
+ampere ***
+candela ***
+Kelvin ***
+mole ***
+# Two supplementary units
+radian ***
+steradian ***
+# Some miscellany
+dollar ***
+bit ***
+sheet *** # Of paper
+turn *** # Of coiled wire
+
+# DIMENSIONLESS
+pi 3.1415926535897932386
+two 2
+half 1|2
+e 2.718281828459045 # Why did I put this in? Oh, I don't know.
+Neper 1 # Unit of logarithmic ratio
+Np Neper
+# Would it be better to make this a fundamental unit?
+bel .868588963 Np # 2/ln(10) actually
+B bel
+dB decibel
+
+# LENGTH
+m meter
+km kilometer
+cm centimeter
+mm millimeter
+micron micrometer
+inch 2.54 cm # This is the official definition and is exact
+mil milliinch
+in inch
+barleycorn 1/3 inch # Tim Riker <Tim@Rikers.org
+inches inch # plural
+foot 12 inch
+ft foot
+feet foot
+yard 3 feet
+yd yard
+mile 5280 feet
+mi mile
+#nautical 1.151 # For `nautical mile'
+nautical 1.150779447892
+statute 1
+# pilots need this :)
+nm 1 nautical mile
+sm 1 statute mile
+parsec 1.91615e13 mi
+#parsec 3.08568025e16 m # better?
+# light year will be implied by `year' and `light' below
+fathom 6 ft
+cable 120 fathoms
+league 3 mi
+bolt 25 yd # Of cloth; bolt length varies from bolt to bolt
+ # 25 yd is typical
+cubit 18 in
+ell 45 in # More or less standard, although other ells
+ # have also been used.
+hand 4 in
+palm 3 in
+span 9 in
+pace 2.5ft
+astronomicalunit 92.9 megamiles # Is this exact?
+au astronomicalunit
+rope 20 ft
+skein 360 feet
+
+# Surveyor's
+furlong 1|8 mi
+chain 1|10 furlong
+rod 1|4 chain
+link 1|100 chain
+
+# Typographic
+point .013837 in
+pt point
+bigpoint 1|72 in
+pica 12 pt
+didot 1238|1157 pt
+dd didot
+cicero 12dd # TeX likes to abbreviate this to cc, but cc is cubic centimeter
+scaledpoint 1|65536 pt # Internal to TeX
+sp scaledpoint
+
+
+
+# AREA
+are (10 m)2 # Implies `hectare'
+acre chain furlong # Now you know why an acre is the size it is
+rood 1|4 acre
+township 36 mi2 # Who uses these?
+barn (1.0E-12 centimeter)2 # Particle physics
+board 144 in3/ft # Implies `board feet'
+
+# VOLUME
+cc cm3
+liter (decimeter)3
+ml milliliter
+stere m3
+floz 29.573 ml # `floz' means `fluid ounce', which is different
+ # from `ounce', which is a measurement of mass.
+ # See `pound' below for more details.
+fldram 1|8 floz
+minim 1|60 fldram
+cup 8 floz
+cu cup
+gill 1|2 cup
+pint two cups
+quart two pints
+pottle two quarts # Yup!
+gallon two pottles
+qt quart
+gal gallon
+tablespoon 1|2 floz
+tbsp tablespoon
+teaspoon 1|3 tbsp
+tsp teaspoon
+cordfoot 16 ft2 # NOT the same as `cord foot'.
+cordfeet cordfoot
+cord 8 cordfeet
+# Barrels are complicated. `Barrel' here means `U.S. liquid barrel'.
+barrel 31.5 gal
+bbl barrel
+hogshead two barrels
+butt two hogsheads
+tun two butts
+firkin 9 gal # American firkin, not British firkin
+perch 24.75 ft3 # Masonry
+puncheon 84 gal
+# Following units contributed 20011217 Thomas R Wyant III
+fifth 1|5 gallon
+magnum 2.5 fifth
+jeroboam 4 fifth
+rehoboam 7.5 fifth
+methuselah 10 fifth
+shalmanazar 14 fifth
+balthazar 20 fifth
+nebuchadnezzar 25 fifth
+
+# Delightful British liquid volumes; they all begin with `brit'.
+britfloz 28.41225 ml
+britminim 1|480 britfloz
+britdrachm 1|8 britfloz
+drachm britdrachm # U.S. drachm is spelled `dram'.
+britgill 5 britfloz # five, NOT four.
+britnoggin britgill
+noggin britnoggin # Yeah, as though anyone else would have a `noggin.'
+britpint 4 britgill
+britpt britpint
+britquart 2 britpint
+britqt britquart
+britgallon 4 britquart
+britgal britgallon
+britpeck 2 britgal
+britfirkin 9 britgal
+britkilderkin two britfirkins
+kilderkin britkilderkin # kilderkin is British only
+britbucket 4 britgal # That's `britbucket,' not `bit bucket'.
+bucket britbucket # Buckets are brit only.
+britlast 2909.414 liters
+last britlast
+
+# Dry volume
+dry 1.164904862579 # For `dry pint,' `dry quart,' etc.
+peck 8 dry quarts
+bushel 4 pecks
+bu bushel
+seam 8bu
+bag 3bu
+
+imperial 1.201 # For `imperial pint,' etc.
+
+# MASS (also WEIGHT)
+#
+# To avoid confusing the end user, we will pretend that `pound' is
+# a unit of mass, interconvertible with `grams'. If you want
+# pounds of force, see `lbf,' below. In this section, `pound'
+# really means `mass of an object that weighs one-pound at the surface
+# of the Earth.' That is, in this program, `slug' has its usual
+# meaning, and `pound' is synonymous aith `slug'.
+g gram
+kg kilogram
+metricton kilokilogram
+tonne metricton
+mg milligram
+grain 64.79891 mg
+ounce 437.5 grains
+oz ounce
+pound 16 oz
+lb pound
+slug lb
+hundredweight 112 lb # This is the `long' hundredweight, analagous to
+ # the long ton. There is also a `short' hundredwight,
+ # but it's just a hectlb, so I put this one in instead.
+cwt hundredweight
+quarter 5 cwts
+longton 20 cwt
+#ton longton # use shortton my default Tim Riker <Tim@Rikers.org>
+short 100|112 # Convert long tons, cwts, and quarters to short.
+shortton short longton
+ton short longton # the american ton, see metriton and longton
+stone 14 lb
+cental 100 lb
+wey 252 lb
+# Obscure apothecaries' measures
+scruple 20 grains
+dram 3 scruples
+apothounce 480 grains
+apothoz apothounce
+apothpound 12 apothoz
+apothlb apothpound
+# Troy measures (for gold and precious stones)
+pennyweight 24 grains
+troyoz 480 grains # We can't define `troy' as a constant,
+ # because there are 16 oz in a lb, but only
+ # 12 troyoz in a troylb, so at least one of
+ # `troy oz' or `troy lb' would be wrong.
+troylb 12 troyoz
+carat 3.08647 grain # Metric version. Is this useful?
+atomicmassunit 1.6605402e-27 kg # NIST 19990301 (+/- 0.10e-33 kg)
+amu atomicmassunit
+quintal 100kg # Metric quintal. Wasn't there another quintal?
+elvis 255lb # At the time of his death, the King weighed 255 lb.
+
+# TIME
+sec second
+s second
+minute 60 sec
+min minute
+hour 60 min
+hr hour
+day 24 hrs
+dy day # This will denote mean solar days
+siderealday 0.99726957 dys
+week 7 days
+wk week
+month 30 days
+lunarmonth 29.530588 days # Mean solar days
+meanmonth 730 hours
+mo month
+tropicalyear 365.24219 dys # Mean solar days
+siderealyear 365.25636 dys # Mean solar days
+leapyear 366 dys # Mean solar days
+calendaryear 365 dys # Mean solar days
+gregorianyear 365.2425 dys
+year tropicalyear # Correct on average for most calculations
+yr years
+fortnight two weeks
+decade 10 years
+century 100 years
+millennium 1000 years
+millennia millennium
+centuries century
+beat 1|1000 day # Swatch Internet Time (``Fuck the Sun'')
+# Velocity
+knot 1 nautical mi/hour
+mph 1 mi/hr
+
+# SCIENTIFIC
+#
+# Electromagnetic items, work, force, energy.
+#
+# Velocity
+c 299792458 m/s # NIST 19990301 EXACT
+light c # Implies `light year'
+
+
+# Absolute temperature
+kelvin Kelvin
+K Kelvin
+Rankine 5|9 K # This is a very funny unit
+Ra Rankine
+
+# Amount of substance
+mol mole
+Avogadro 6.0221367e23
+avogadro Avogadro
+molecule 1 mole per Avogadro # 1 mole is an Avogagro-number of molecules
+
+# Current
+# The Ampere is fundamental here, defined as the constant current
+# which, if maintained in two straight parallel conductors of infinite
+# length, of negligible circular cross-section, and placed 1m apart in
+# vacuum, would produce between these conductors a force equal to 2e-7
+# newtons per meter of length.
+Ampere ampere
+amp ampere
+abampere 10 amps
+abamp abampere
+statampere 3.335635e-11 abamperes
+statamp statampere
+
+# What is this called? Is it capitalized? Is there an abbreviation?
+gilbert 0.79577472 ampere turns
+
+# Electrostatic charge
+Coulomb ampere sec
+coulomb Coulomb
+coul Coulomb
+C Coulomb
+electron 1.60217733e-19 C # Charge on the electron; implies electron-volts
+e electron
+abcoulomb 10C
+statcoulomb 3.335635e-11 abcoulomb
+
+
+# Force
+Newton kg m/s2
+newton Newton
+N newton
+dyne g cm/s2
+grav 9.8 m/s2 # Acceleration due to gravity
+gee grav
+# Actually the accleration varies with altitude and latitude,
+# from 9.78039 m/s2 at the equator to 9.83217 m/s2 at the poles.
+# This mean value corresponds to a latitude of about 38 degrees.
+lbf lb grav
+
+# Pressure
+Pascal N/m2
+pascal Pascal
+Pa pascal
+atmosphere 101325 N/m2 # NIST 20010518 EXACT
+atm atmosphere
+bar megadyne/cm2 # Implies `millibars'
+mercury 1|760 atm/mm # Implies `mm mercury' and `inches mercury'
+hg mercury
+torricelli mm hg
+torr torricelli
+water .0295 atm/ft # Implies `feet water'
+barye dyne/cm2
+air 6.6083e-5 atm/foot # At 60 deg.F; Implies `feet air'
+
+# Work and energy
+Joule newton-meter
+joule Joule
+J joule
+footpound ft-lbf # foot-pound won't work, because `pound' is a mass
+calorie 4.186 J
+cal calorie
+kcal kilocalorie
+britishthermalunit 1054.8 J
+btu britishthermalunit
+erg dyne-cm
+# Kilowatt-hour (kWh) will be implied by `Watt'.
+
+
+# Power
+Watt J/sec
+watt Watt
+W Watt
+horsepower 550 ft-lbf/s
+
+# Electric potential
+Volt W/amp
+volt Volt
+V Volt
+abvolt 1|100 microvolt
+statvolt 2.997930e10 V
+
+# Frequency
+cycle 1 # For `cycles per second'
+Hertz cycles per second
+Hz Hertz
+hz Hz
+
+# Inductance
+Henry volt s/amp
+henry Henry
+H Henry
+abhenry 1.0e-9 henry
+Henries Henry # For plural
+henries Henry
+stathenry 8.987584e11 henries
+stathenries stathenry
+
+# Etc.
+Weber volt s
+weber Weber
+Wb weber
+Tesla Wb/m2
+tesla Tesla
+T tesla
+Oersted 1|4 pi kiloamp/m
+oersted Oersted
+Oe oersted
+Maxwell 1.0e-8 Wb
+maxwell Maxwell
+Mx Maxwell
+Gauss 1.0e-4 T
+gauss Gauss
+# We won't use G for Gauss because it is more important to
+# use it for the universal gravitational constant
+
+# Capacitance
+# `farad' is *not* an abbreviation for `Faraday' as far as I can tell.
+farad amp sec / volt
+F farad
+abfarad 1.0e9 farad
+statfarad 1.112646e-13 farad
+
+# Resistance
+Ohm volt/amp
+ohm Ohm
+abohm 1.0e-9 ohm
+statohm 8.987584e11 Ohms
+
+# Conductance
+mho 1/ohm
+abmho 1/abohm
+Siemens mho
+siemens Siemens
+
+# Misc
+Angstrom 1.0e-10 m
+angstrom Angstrom
+G 6.67259e-11 N m2/kg2 # Newton gravitational constant NIST19990301
+lightyear light year # Common abbreviation
+eV e V # Electron volts
+ev eV
+kev kiloeV
+Mev megaeV
+Gev gigaeV
+Tev teraeV
+energy c2 # You can ask for `1 gram energy' and get
+ # the amount of energy equivalent to
+ # 1 gram according to e=mc2.
+ # Check: 1amu energy == 931.16 Mev?
+Franklin (10/c) C cm/sec
+Fr Franklin
+franklin Franklin
+Biot 10 amp
+Bi Biot
+biot Biot
+
+# Viscosity - Maybe someone who understands this better can check.
+poise g/(cm s) # Named after M. Poiseuille
+rhe 1/poise
+reyn (lbf s)/in2
+# Kinematic viscosity = viscosity per unit density
+stoke cm2/s
+
+# Refrigeration - Maybe someone who understands this better can check.
+refrigeration 288000 btu/ton
+ice tons refrigeration / 2009.1 lb
+
+# Light
+# The candela is fundamental here. Prior to 1979, it was defined as
+# the luminous intensity of a black body at the temperature of
+# solidification of platinum, whose radiating surface is 1/60 cm2. It
+# is now the luminous intensity, in a given direction, of a source
+# that emits monochromatic radiation of frequency 540e12 Hz and that
+# has a radiant intensity in that direction of 1|683 W/sr
+cd candela
+sr steradian
+lumen candela sr
+lm lumen
+lux lm/m2
+lx lux
+candlepower 12.566370 lumens
+candle candela # ``International standard candle''
+Hefner 0.90 candles # This was the German standard in early C20.
+hefner Hefner
+Lambert lm/cm2
+lambert Lambert
+footcandle lm/ft2 # NOT the same as foot-candle.
+phot 1.0e4 lx
+stilb candle/m2 # Same as a pi lambert
+
+# Various important physical constants
+# I got this stuff from physics.nist.gov on 19990301.
+h 6.6260755e-27 erg-sec # Planck's constant
+hbar h/(2 pi)
+plancklength 1.61605e-35 m
+planckmass 2.17671e-8 kg
+plancktime 5.39056e-44 sec
+# Let's reserve `Planck' for a while longer until I can decide if
+# they'd be useful in `planck time' etc.
+permeability 4*pi*1.0e-7 H/m # Magnetic permeability of vacuum constant
+permittivity 8.854187817e-12 F/m # Electric permittivity of vacuum constant
+protonmass 1.6726231e-27 kg
+neutronmass 1.6749286e-27 kg
+electronmass 9.1093897e-31 kg
+finestructure 7.29735308e-3 # Rl
+# Electron charge is up above under `electrostatic'.
+# There's no reason to get too obscure here because if someone wants
+# they can make up an `obscure physical constants' file that
+# physiscists could load in if they wanted to. So I've omitted stuff
+# like the magnetic moment of the muon.
+
+# ANGULAR
+rad radian
+circle 2 pi radians
+revolution circle # For revolutions / sec
+rev revolution
+rpm revolutions per minute
+quadrant 1|4 circle
+degree 1|360 circle
+arcminute 1|60 degree
+arcsecond 1|60 arcminute
+arcmin arcminute
+arcsec arcsecond
+sphere 4 pi steradians
+grade 1|100 quadrant
+grad grade
+
+# PAPER
+quire 50 sheets
+ream 10 quires
+
+# INFORMATION
+byte 8 bits
+nybble half byte
+kbyte 1024 bytes # `kilobyte' means 1000 bytes
+# Don't use `K'; that's for Kelvins.
+kb kbyte
+Kb kbyte
+KB kbyte
+mbyte 1024 kbytes # `megabyte' means 1000000 bytes
+meg mbyte
+kbit 1024 bits
+Kbit kbit
+mbit 1024 kbits
+Mbit mbit
+baud bit/sec # Not strictly correct
+
+# MONEY
+#
+# Conversions accurate only as of 25 November 1996.
+#
+$ dollar
+usdollar $
+usd $
+us$ $
+$us $
+US$ $
+$US $
+cent 1|100 $
+Australia.dollar 0.8123$
+AUS$ Australia.dollar
+Austria.schilling 0.09438$
+Belgium.franc 0.03223$
+Brazil.real 0.9709$
+British.pound 1.681$
+pound.sterling British.pound
+sterling British.pound
+Canada.dollar 0.7468$
+Can$ Canada.dollar
+Cayman.currency 1.22$
+Denmark.krone 0.173$
+krone Denmark.krone
+EuropeanCommunityUnit.ECU 1.278$
+ECU EuropeanCommunityUnit.ECU
+ecu ECU
+Finland.markka 0.2203$
+markka Finland.markka
+France.franc 0.1963$
+franc France.franc
+Germany.mark 0.6647$
+DM Germany.mark
+Deutschmark DM
+mark DM
+Greece.drachma 0.004216$
+drachma Greece.drachma
+HongKong.dollar 0.1294$
+HK$ HongKong.dollar
+India.rupee 0.02797$
+rupee India.rupee
+Ireland.punt 1.684$
+punt Ireland.punt
+Israel.shekel 0.3623$
+shekel Israel.shekel
+Italy.lira 0.0006655$
+Japan.yen 0.008976$
+yen Japan.yen
+Kenya.shilling 0.02376$
+Malaysia.dollar 0.397$
+Mexico.peso 0.1269$
+peso Mexico.peso
+Morocco.dirham 0.1248$
+dirham Morocco.dirham
+Netherlands.guilder 0.5924$
+guilder Netherlands.guilder
+NewZealand.dollar 0.7153$
+NZ$ NewZealand.dollar
+Norway.krone 0.1576$
+krone Norway.krone
+Portugal.escudo 0.006577$
+escudo Portugal.escudo
+Senegal.CFAfranc 0.002019$
+SouthAfrica.rand 0.2169$
+rand SouthAfrica.rand
+Spain.peseta 0.007896$
+peseta Spain.peseta
+Sweden.krona 0.1513$
+krona Sweden.krona
+Switzerland.franc 0.788$
+swissfranc Switzerland.franc
+Swissfranc Switzerland.franc
+Turkey.lira 1.3e-05$
+# Old-style Brit money. Did I omit anything interesting?
+sovereign sterling
+shilling 1|20 sterling
+penny 1|12 shilling
+pence penny
+farthing 1|4 penny
+hapenny half penny
+twopence two pence
+tuppence two pence
+thruppence 3 pence
+threepence 3 pence
+sixpence 6 pence
+crown 5 shillings # Implies `half crown'
+guinea 21 shillings
+florin 2 shillings
+
+
+# 18th century French coinage. References:
+# http://home.nordnet.fr/~jlmorel/mesures.html and reverse-engineered
+# from The Three Musketeers
+# 20011227 Thomas R Wyant III
+livre franc ### 3 Musketeers has francs!
+ ### Now, you too can convert Louis d'Or to U.S. Dollars!
+sou 1|20 livre
+crown 3 livres # It's ecu in French, not to be confused with ECU.
+pistole 10 livres
+double 2 # 3 Musketeers refers to double pistoles, so ...
+louis 24 livres
+### Now if only I had good definitions for reals and doubloons ...
+
+
+# For `register tons'
+register 100 ft3/ton
+registerton register ton
+
+# What's missing?
+# bequerel (nucleotide radioactivity): Bq = k/s k=1??
+# gray (absorbed dose): Gy = k J/kg k=1??
+# sievert (dose equivalent): Sv = k J/kg k=1??
+# curie: Ci = 3.3e10 Bq
+# roentgen: R = 2.58e-4 C/kg
+# rad: rad = centigray
+# rem: rem = centisievert
--- /dev/null
+#!/usr/bin/perl
+
+# infobot -- copyright kevin lenzo (c) 1997-1999
+# blootbot -- copyright david sobon (c) 1999-infinity
+
+use strict;
+use vars qw($bot_base_dir $bot_src_dir $bot_misc_dir $bot_state_dir
+ $bot_data_dir $bot_config_dir $bot_log_dir $bot_run_dir
+ $bot_pid $memusage %param
+);
+
+BEGIN {
+ if (@ARGV and -f $ARGV[0]) {
+ # source passed config to allow $bot_*_dir to be set.
+ do $ARGV[0];
+ }
+
+ # set any $bot_*_dir var's that aren't already set
+ $bot_base_dir ||= '.';
+ $bot_config_dir ||= 'files/';
+ $bot_data_dir ||= 'files/';
+ $bot_state_dir ||= 'files/';
+ $bot_run_dir ||= '.';
+ $bot_src_dir ||= "$bot_base_dir/src";
+ $bot_log_dir ||= "$bot_base_dir/log";
+ $bot_misc_dir ||= "$bot_base_dir/files";
+
+ $bot_pid = $$;
+
+ require "$bot_src_dir/logger.pl";
+ require "$bot_src_dir/core.pl";
+ require "$bot_src_dir/modules.pl";
+
+ # load the configuration (params) file.
+ &setupConfig();
+
+ &showProc(); # to get the first value.
+ &status("Initial memory usage: $memusage kB");
+ &loadCoreModules();
+ &loadDBModules();
+ &loadFactoidsModules();
+ &loadIRCModules();
+
+ &status("Memory usage after loading modules: $memusage kB");
+}
+
+# prevent duplicate processes of the same bot
+&duperuncheck();
+
+# initialize everything
+&startup(); # first time initialization.
+&setup();
+
+if (!&IsParam("Interface") or $param{'Interface'} =~ /IRC/) {
+ # launch the irc event loop
+ &ircloop();
+} else {
+ &cliloop();
+}
+
+exit 0; # just so you don't look farther down in this file :)
+
+# --- support routines
+
+# FIXME: add arguments, basically '-h' and '--help', heh.
+
+# added by the xk
+sub duperuncheck {
+ my $pid = $$;
+ my $file = $file{PID};
+
+ if ( -f $file) {
+ open(PIDFILE,$file) or die "error: cannot open $file.";
+ my $thispid = <PIDFILE> || "NULL\n";
+ close PIDFILE;
+ chop $thispid;
+
+ if ($thispid =~ /^\D$/) {
+ &staus("warning: pidfile is invalid; wiping out.");
+ } else {
+ if ( -d "/proc/$thispid/") {
+ &ERROR("bot is already running from this directory.");
+ &ERROR("if this is incorrect, erase '*.pid'.");
+ &ERROR("verify with 'ps -axu | grep $thispid'.");
+ exit 1;
+ } else {
+ &status("warning: stale $file found; wiping.");
+ }
+ }
+ }
+
+ open(PIDFILE,">$file") or die "error: cannot write to $file.";
+ print PIDFILE "$pid\n";
+ close PIDFILE;
+
+ return 0;
+}
+
+1;
--- /dev/null
+##########################################################
+# Google.pm
+# by Jim Smyser
+# Copyright (C) 1996-1999 by Jim Smyser & USC/ISI
+# $Id: Google.pm,v 2.20 2000/07/09 14:29:22 jims Exp $
+##########################################################
+
+
+package WWW::Search::Google;
+
+
+=head1 NAME
+
+WWW::Search::Google - class for searching Google
+
+
+=head1 SYNOPSIS
+
+use WWW::Search;
+my $Search = new WWW::Search('Google'); # cAsE matters
+my $Query = WWW::Search::escape_query("Where is Jimbo");
+$Search->native_query($Query);
+while (my $Result = $Search->next_result()) {
+print $Result->url, "\n";
+}
+
+=head1 DESCRIPTION
+
+This class is a Google specialization of WWW::Search.
+It handles making and interpreting Google searches.
+F<http://www.google.com>.
+
+This class exports no public interface; all interaction should
+be done through L<WWW::Search> objects.
+
+=head1 LINUX SEARCH
+
+For LINUX lovers like me, you can put Googles in a LINUX only search
+mode by changing search URL from:
+
+ 'search_url' => 'http://www.google.com/search',
+
+to:
+
+ 'search_url' => 'http://www.google.com/linux',
+
+=head1 SEE ALSO
+
+To make new back-ends, see L<WWW::Search>.
+
+=head1 HOW DOES IT WORK?
+
+C<native_setup_search> is called (from C<WWW::Search::setup_search>)
+before we do anything. It initializes our private variables (which
+all begin with underscore) and sets up a URL to the first results
+page in C<{_next_url}>.
+
+C<native_retrieve_some> is called (from C<WWW::Search::retrieve_some>)
+whenever more hits are needed. It calls C<WWW::Search::http_request>
+to fetch the page specified by C<{_next_url}>.
+It then parses this page, appending any search hits it finds to
+C<{cache}>. If it finds a ``next'' button in the text,
+it sets C<{_next_url}> to point to the page for the next
+set of results, otherwise it sets it to undef to indicate we''re done.
+
+
+=head1 TESTING
+
+This module adheres to the C<WWW::Search> test suite mechanism.
+
+=head1 AUTHOR
+
+This backend is written and maintained/supported by Jim Smyser.
+<jsmyser@bigfoot.com>
+
+=head1 BUGS
+
+Google is not an easy search engine to parse in that it is capable
+of altering it's output ever so slightly on different search terms.
+There may be new slight results output the author has not yet seen that
+will pop at any given time for certain searches. So, if you think you see
+a bug keep the above in mind and send me the search words you used so I
+may code for any new variations.
+
+=head1 CHANGES
+
+2.21.1
+Parsing update from Tim Riker <Tim@Rikers.org>
+
+2.21
+Minor code correction for empty returned titles
+
+2.20
+Forgot to add new next url regex in 2.19!
+
+2.19
+Regex work on some search results url's that has changed. Number found
+return should be right now.
+
+2.17
+Insert url as a title when no title is found.
+
+2.13
+New regexp to parse newly found results format with certain search terms.
+
+2.10
+removed warning on absence of description; new test case
+
+2.09
+Google NOW returning url and title on one line.
+
+2.07
+Added a new parsing routine for yet another found result line.
+Added a substitute for whacky url links some queries can produce.
+Added Kingpin's new hash_to_cgi_string() 10/12/99
+
+2.06
+Fixed missing links / regexp crap.
+
+2.05
+Matching overhaul to get the code parsing right due to multiple
+tags being used by google on the hit lines. 9/25/99
+
+2.02
+Last Minute description changes 7/13/99
+
+2.01
+New test mechanism 7/13/99
+
+1.00
+First release 7/11/99
+
+=head1 LEGALESE
+
+THIS SOFTWARE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
+WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+
+
+=cut
+#'
+
+
+#####################################################################
+
+require Exporter;
+@EXPORT = qw();
+@EXPORT_OK = qw();
+@ISA = qw(WWW::Search Exporter);
+$VERSION = '2.21.1';
+
+$MAINTAINER = 'Jim Smyser <jsmyser@bigfoot.com>';
+$TEST_CASES = <<"ENDTESTCASES";
+# Google looks for partial words it can find results for so it will end up finding "Bogus" pages.
+&test('Google', '$MAINTAINER', 'zero', '4036e7757s5', \$TEST_EXACTLY);
+&test('Google', '$MAINTAINER', 'one_page', '+LS'.'AM +rep'.'lication', \$TEST_RANGE, 2,99);
+&test('Google', '$MAINTAINER', 'multi', 'dir'.'ty ha'.'rr'.'y bimbo', \$TEST_GREATER_THAN, 101);
+ENDTESTCASES
+
+use Carp ();
+use WWW::Search(qw(generic_option strip_tags));
+require WWW::SearchResult;
+
+
+sub undef_to_emptystring {
+return defined($_[0]) ? $_[0] : "";
+}
+# private
+sub native_setup_search
+ {
+ my($self, $native_query, $native_options_ref) = @_;
+ $self->user_agent('user');
+ $self->{_next_to_retrieve} = 0;
+ $self->{'_num_hits'} = 100;
+ if (!defined($self->{_options})) {
+ $self->{_options} = {
+ 'search_url' => 'http://www.google.com/search',
+ 'num' => $self->{'_num_hits'},
+ };
+ };
+ my($options_ref) = $self->{_options};
+ if (defined($native_options_ref)) {
+ # Copy in new options.
+ foreach (keys %$native_options_ref) {
+ $options_ref->{$_} = $native_options_ref->{$_};
+ };
+ };
+ # Process the options.
+ my($options) = '';
+ foreach (keys %$options_ref) {
+ # printf STDERR "option: $_ is " . $options_ref->{$_} . "\n";
+ next if (generic_option($_));
+ $options .= $_ . '=' . $options_ref->{$_} . '&';
+ };
+ $self->{_debug} = $options_ref->{'search_debug'};
+ $self->{_debug} = 2 if ($options_ref->{'search_parse_debug'});
+ $self->{_debug} = 0 if (!defined($self->{_debug}));
+
+ # Finally figure out the url.
+ $self->{_base_url} =
+ $self->{_next_url} =
+ $self->{_options}{'search_url'} .
+ "?" . $options .
+ "q=" . $native_query;
+ }
+
+# private
+sub begin_new_hit {
+ my($self) = shift;
+ my($old_hit) = shift;
+ my($old_raw) = shift;
+ if (defined($old_hit)) {
+ $old_hit->raw($old_raw) if (defined($old_raw));
+ push(@{$self->{cache}}, $old_hit);
+ };
+ return (new WWW::SearchResult, '');
+ }
+sub native_retrieve_some {
+ my ($self) = @_;
+ # fast exit if already done
+ return undef if (!defined($self->{_next_url}));
+ # get some
+ print STDERR "Fetching " . $self->{_next_url} . "\n" if ($self->{_debug});
+ my($response) = $self->http_request('GET', $self->{_next_url});
+ $self->{response} = $response;
+ if (!$response->is_success) {
+ return undef;
+ };
+
+ # parse the output
+ my($HEADER, $HITS, $TRAILER, $POST_NEXT) = (1..10);
+ my($hits_found) = 0;
+ my($state) = ($HEADER);
+ my($hit) = undef;
+ my($raw) = '';
+ foreach ($self->split_lines($response->content())) {
+ next if m@^$@; # short circuit for blank lines
+
+ if ($state == $HEADER && m/about <b>([\d,]+)<\/b>/)
+ {
+ my($n) = $1;
+ $self->approximate_result_count($n);
+ print STDERR "Found Total: $n\n" ;
+ $state = $HITS;
+ }
+ if ($state == $HITS &&
+ m|<p><a href=([^\>]*)\>(.*?)</a\><br\>|i) {
+ my ($url, $title) = ($1,$2);
+ ($hit, $raw) = $self->begin_new_hit($hit, $raw);
+ print STDERR "**Found HIT0 Line** $url - $title\n" if ($self->{_debug});
+ $raw .= $_;
+ $url =~ s/(>.*)//g;
+ $hit->add_url(strip_tags($url));
+ $hits_found++;
+ $title = "No Title" if ($title =~ /^\s+/);
+ $hit->title(strip_tags($title));
+ $state = $HITS;
+ }
+ elsif ($state == $HITS &&
+ m|<a href=(.*)\>(.*?)</a><font size=-1><br><font color=green><.*?>|i) {
+ my ($url, $title) = ($1,$2);
+ ($hit, $raw) = $self->begin_new_hit($hit, $raw);
+ print STDERR "**Found HIT1 Line**\n" if ($self->{_debug});
+ $raw .= $_;
+ $url =~ s/(>.*)//g;
+ $hit->add_url(strip_tags($url));
+ $hits_found++;
+ $title = "No Title" if ($title =~ /^\s+/);
+ $hit->title(strip_tags($title));
+ $state = $HITS;
+ }
+ elsif ($state == $HITS &&
+ m@^<p><a href=/url\?sa=U&start=\d+&q=([^<]+)\&.*?>(.*)</a><font size=-1><br>(.*)@i ||
+ m@^<p><a href=([^<]+)>(.*)</a>.*?<font size=-1><br>(.*)@i)
+ {
+ ($hit, $raw) = $self->begin_new_hit($hit, $raw);
+ print STDERR "**Found HIT2 Line**\n" if ($self->{_debug});
+ my ($url, $title) = ($1,$2);
+ $mDesc = $3;
+ $url =~ s/\/url\?sa=\w&start=\d+&q=//g;
+ $url =~ s/&(.*)//g;
+ $url =~ s/(>.*)//g;
+ $raw .= $_;
+ $hit->add_url(strip_tags($url));
+ $hits_found++;
+ $title = "No Title" if ($title =~ /^\s+/);
+ $hit->title(strip_tags($title));
+ $mDesc =~ s/<.*?>//g;
+ $mDesc = $mDesc . '<br>' if not $mDesc =~ m@<br>@;
+ $hit->description($mDesc) if (defined($hit));
+ $state = $HITS;
+ }
+ elsif ($state == $HITS && m@^(\.\.(.+))@i)
+ {
+ print STDERR "**Parsing Description Line**\n" if ($self->{_debug});
+ $raw .= $_;
+ $sDesc = $1;
+ $sDesc ||= '';
+ $sDesc =~ s/<.*?>//g;
+ $sDesc = $mDesc . $sDesc;
+ $hit->description($sDesc) if $sDesc =~ m@^\.@;
+ $sDesc = '';
+ $state = $HITS;
+ }
+ elsif ($state == $HITS && m@<div class=nav>@i)
+ {
+ ($hit, $raw) = $self->begin_new_hit($hit, $raw);
+ print STDERR "**Found Last Line**\n" if ($self->{_debug});
+ # end of hits
+ $state = $TRAILER;
+ }
+ elsif ($state == $TRAILER &&
+ m|<a href=([^<]+)><IMG SRC=/nav_next.gif.*?>.*?|i)
+ {
+ my($relative_url) = $1;
+ print STDERR "**Fetching >>Next<< Page**\n" if ($self->{_debug});
+ $self->{_next_url} = 'http://www.google.com' . $relative_url;
+ $state = $POST_NEXT;
+ } else {
+ };
+ };
+ if ($state != $POST_NEXT) {
+ # No "Next" Tag
+ $self->{_next_url} = undef;
+ if ($state == $HITS) {
+ $self->begin_new_hit($hit, $raw);
+ };
+ $self->{_next_url} = undef;
+ };
+ # ZZZzzzzZZZZzzzzzzZZZZZZzzz
+ $self->user_agent_delay if (defined($self->{_next_url}));
+ return $hits_found;
+ }
+1;
+
--- /dev/null
+--- Connection.pm.orig Fri Nov 1 00:20:36 2002
++++ Connection.pm Sat Nov 2 18:00:42 2002
+@@ -1300,14 +1300,13 @@
+ # the line from the server.
+ sub parse_ctcp {
+ my ($self, $type, $from, $stuff, $line) = @_;
+-
+ my ($one, $two);
+ my ($odd, @foo) = (&dequote($line));
+
+ while (($one, $two) = (splice @foo, 0, 2)) {
+
+ ($one, $two) = ($two, $one) if $odd;
+-
++
+ my ($ctype) = $one =~ /^(\w+)\b/;
+ my $prefix = undef;
+ if ($type eq 'notice') {
+@@ -1326,10 +1325,10 @@
+ # -- #perl was here! --
+ # fimmtiu: Words cannot describe my joy. Sil, you kick ass.
+ # fimmtiu: I was passing the wrong arg to Event::new()
+-
+- $one =~ s/^$ctype //i; # strip the CTCP type off the args
++
++ # this is what it used to be in version 0.63 or so.
+ $self->handler(Net::IRC::Event->new( $handler, $from, $stuff,
+- $handler, $one ));
++ $handler, (split /\s/, $one)));
+ }
+
+ $self->handler(Net::IRC::Event->new($type, $from, $stuff, $type, $two))
--- /dev/null
+--- Google.pm.orig Wed May 24 16:55:47 2000
++++ Google.pm Wed Jan 16 22:02:53 2002
+@@ -2,7 +2,7 @@
+ # Google.pm
+ # by Jim Smyser
+ # Copyright (C) 1996-1999 by Jim Smyser & USC/ISI
+-# $Id$
++# $Id$
+ ##########################################################
+
+
+@@ -30,8 +30,6 @@
+ It handles making and interpreting Google searches.
+ F<http://www.google.com>.
+
+-Googles returns 100 Hits per page. Custom Linux Only search capable.
+-
+ This class exports no public interface; all interaction should
+ be done through L<WWW::Search> objects.
+
+@@ -70,33 +68,41 @@
+
+ This module adheres to the C<WWW::Search> test suite mechanism.
+
+-=head1 BUGS
+-
+-2.07 now parses for most of what Google produces, but not all.
+-Because Google does not produce universial formatting for all
+-results it produces, there are undoublty a few line formats yet
+-uncovered by the author. Different search terms creates various
+-differing format out puts for each line of results. Example,
+-searching for "visual basic" will create whacky url links,
+-whereas searching for "Visual C++" does not. It is a parsing
+-nitemare really! If you think you uncovered a BUG just remember
+-the above comments!
+-
+-With the above said, this back-end will produce proper formated
+-results for 96+% of what it is asked to produce. Your milage
+-will vary.
+-
+ =head1 AUTHOR
+
+-This backend is maintained and supported by Jim Smyser.
++This backend is written and maintained/supported by Jim Smyser.
+ <jsmyser@bigfoot.com>
+
+ =head1 BUGS
+
+-2.09 seems now to parse all hits with the new format change so there really shouldn't be
+-any like there were with 2.08.
++Google is not an easy search engine to parse in that it is capable
++of altering it's output ever so slightly on different search terms.
++There may be new slight results output the author has not yet seen that
++will pop at any given time for certain searches. So, if you think you see
++a bug keep the above in mind and send me the search words you used so I
++may code for any new variations.
++
++=head1 CHANGES
++
++2.22
++Fixed up changed format from google
++reformatted code
++
++2.21
++Minor code correction for empty returned titles
++
++2.20
++Forgot to add new next url regex in 2.19!
++
++2.19
++Regex work on some search results url's that has changed. Number found
++return should be right now.
++
++2.17
++Insert url as a title when no title is found.
+
+-=head1 VERSION HISTORY
++2.13
++New regexp to parse newly found results format with certain search terms.
+
+ 2.10
+ removed warning on absence of description; new test case
+@@ -131,15 +137,18 @@
+ WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
+ MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+
++
+ =cut
+ #'
+-
++
++
+ #####################################################################
++
+ require Exporter;
+ @EXPORT = qw();
+ @EXPORT_OK = qw();
+ @ISA = qw(WWW::Search Exporter);
+-$VERSION = '2.10';
++$VERSION = '2.22';
+
+ $MAINTAINER = 'Jim Smyser <jsmyser@bigfoot.com>';
+ $TEST_CASES = <<"ENDTESTCASES";
+@@ -148,160 +157,187 @@
+ &test('Google', '$MAINTAINER', 'one_page', '+LS'.'AM +rep'.'lication', \$TEST_RANGE, 2,99);
+ &test('Google', '$MAINTAINER', 'multi', 'dir'.'ty ha'.'rr'.'y bimbo', \$TEST_GREATER_THAN, 101);
+ ENDTESTCASES
+-
++
+ use Carp ();
+-use WWW::Search(generic_option);
++use WWW::Search(qw(generic_option strip_tags));
+ require WWW::SearchResult;
+-
++
++
++sub undef_to_emptystring {
++return defined($_[0]) ? $_[0] : "";
++}
++# private
+ sub native_setup_search {
+- my($self, $native_query, $native_options_ref) = @_;
+- $self->{_debug} = $native_options_ref->{'search_debug'};
+- $self->{_debug} = 2 if ($native_options_ref->{'search_parse_debug'});
+- $self->{_debug} = 0 if (!defined($self->{_debug}));
+- $self->{agent_e_mail} = 'jsmyser@bigfoot.com';
+- $self->user_agent('user');
+- $self->{_next_to_retrieve} = 1;
+- $self->{'_num_hits'} = 0;
+- if (!defined($self->{_options})) {
+- $self->{'search_base_url'} = 'http://www.google.com';
+- $self->{_options} = {
+- 'search_url' => 'http://www.google.com/search',
+- 'num' => '100',
+- 'q' => $native_query,
+- };
+- }
+- my $options_ref = $self->{_options};
+- if (defined($native_options_ref))
+- {
+- # Copy in new options.
+- foreach (keys %$native_options_ref)
+- {
+- $options_ref->{$_} = $native_options_ref->{$_};
+- } # foreach
+- } # if
+- # Process the options.
+- my($options) = '';
+- foreach (sort keys %$options_ref)
+- {
+- # printf STDERR "option: $_ is " . $options_ref->{$_} . "\n";
+- next if (generic_option($_));
+- $options .= $_ . '=' . $options_ref->{$_} . '&';
+- }
+- chop $options;
+- # Finally figure out the url.
+- $self->{_next_url} = $self->{_options}{'search_url'} .'?'. $self->hash_to_cgi_string($self->{_options});
+- } # native_setup_search
+-
++ my($self, $native_query, $native_options_ref) = @_;
++ $self->user_agent('user');
++ $self->{_next_to_retrieve} = 0;
++ $self->{'_num_hits'} = 100;
++
++ if (!defined $self->{_options}) {
++ $self->{_options} = {
++ 'search_url' => 'http://www.google.com/search',
++ 'num' => $self->{'_num_hits'},
++ };
++ }
++
++ my($options_ref) = $self->{_options};
++
++ if (defined $native_options_ref) {
++ # Copy in new options.
++ foreach (keys %$native_options_ref) {
++ $options_ref->{$_} = $native_options_ref->{$_};
++ }
++ }
++
++ # Process the options.
++ my($options) = '';
++ foreach (keys %$options_ref) {
++ # printf STDERR "option: $_ is " . $options_ref->{$_} . "\n";
++ next if (generic_option($_));
++ $options .= $_ . '=' . $options_ref->{$_} . '&';
++ }
++
++ $self->{_debug} = $options_ref->{'search_debug'};
++ $self->{_debug} = 2 if ($options_ref->{'search_parse_debug'});
++ $self->{_debug} = 0 if (!defined $self->{_debug});
++
++ # Finally figure out the url.
++ $self->{_base_url} =
++ $self->{_next_url} =
++ $self->{_options}{'search_url'} .
++ "?" . $options .
++ "q=" . $native_query;
++}
++
+ # private
+-sub native_retrieve_some
+- {
+- my ($self) = @_;
+- print STDERR "**Google::native_retrieve_some()**\n" if $self->{_debug};
+- # Fast exit if already done:
+- return undef if (!defined($self->{_next_url}));
+-
+- # If this is not the first page of results, sleep so as to not
+- # overload the server:
+- $self->user_agent_delay if 1 < $self->{'_next_to_retrieve'};
+-
+- # Get some if were not already scoring somewhere else:
+- print STDERR "*Sending request (",$self->{_next_url},")\n" if $self->{_debug};
+- my($response) = $self->http_request('GET', $self->{_next_url});
+- $self->{response} = $response;
+- if (!$response->is_success)
+- {
+- return undef;
+- }
+- $self->{'_next_url'} = undef;
+- print STDERR "**Response\n" if $self->{_debug};
+-
+- # parse the output
+- my ($HEADER, $START, $HITS, $NEXT) = qw(HE HI ST NX);
+- my $hits_found = 0;
+- my $state = $HEADER;
+- my $hit = ();
+- foreach ($self->split_lines($response->content()))
+- {
+- next if m@^$@; # short circuit for blank lines
+- print STDERR " $state ===$_=== " if 2 <= $self->{'_debug'};
+- if (m|<b>(\d+)</b></font> matches|i) {
+- print STDERR "**Found Header Count**\n" if ($self->{_debug});
+- $self->approximate_result_count($1);
+- $state = $START;
+- # set-up attempting the tricky task of
+- # fetching the very first HIT line
+- }
+- elsif ($state eq $START && m|Search took|i)
+- {
+- print STDERR "**Found Start Line**\n" if ($self->{_debug});
+- $state = $HITS;
+- # Attempt to pull the very first hit line
+- }
+- if ($state eq $HITS) {
+- print "\n**state == HITS**\n" if 2 <= $self->{_debug};
+- }
+- if ($state eq $HITS && m@^<p><a href=([^<]+)>(.*)</a>$@i)
+- {
+- print "**Found HIT**\n" if 2 <= $self->{_debug};
+- my ($url, $title) = ($1,$2);
+- if (defined($hit))
+- {
+- push(@{$self->{cache}}, $hit);
+- };
+- $hit = new WWW::SearchResult;
+- # some queries *can* create internal junk in the url link
+- # remove them!
+- $url =~ s/\/url\?sa=U&start=\d+&q=//g;
+- $hits_found++;
+- $hit->add_url($url);
+- $hit->title($title);
+- $state = $HITS;
+- }
+- if ($state eq $HITS && m@^<font size=-1><br>(.*)@i)
+- {
+- print "**Found First Description**\n" if 2 <= $self->{_debug};
+- $mDesc = $1;
+- if (not $mDesc =~ m@ @)
+- {
+- $mDesc =~ s/<.*?>//g;
+- $mDesc = $mDesc . '<br>' if not $mDesc =~ m@<br>@;
+- $hit->description($mDesc);
+- $state = $HITS;
+- }
+- }
+- elsif ($state eq $HITS &&
+- m@^(\.(.+))@i ||
+- m@^<br><font color=green>(.*)\s@i) {
+- print "**Found Second Description**\n" if 2 <= $self->{_debug};
+- $sDesc = $1;
+- $sDesc ||= '';
+- $sDesc =~ s/<.*?>//g;
+- $sDesc = $mDesc . $sDesc;
+- $hit->description($sDesc);
+- $sDesc ='';
+- $state = $HITS;
+- }
+- elsif ($state eq $HITS &&
+- m|<a href=([^<]+)><IMG SRC=/nav_next.gif.*?><br><.*?>.*?</A>|i) {
+- my $nexturl = $self->{'_next_url'};
+- if (defined $nexturl) {
+- print STDERR "**Fetching Next URL-> ", $nexturl, "\n" if 2 <= $self->{_debug};
+- } else {
+- print STDERR "**Fetching Next URL-> UNDEF\n" if 2 <= $self->{_debug};
+- }
+-
+- my $iURL = $1;
+- $self->{'_next_url'} = $self->{'search_base_url'} . $iURL;
+- }
+- else
+- {
+- print STDERR "**Nothing matched.**\n" if 2 <= $self->{_debug};
+- }
+- }
+- if (defined($hit))
+- {
+- push(@{$self->{cache}}, $hit);
+- }
+- return $hits_found;
+- } # native_retrieve_some
+-1;
++sub begin_new_hit {
++ my($self) = shift;
++ my($old_hit) = shift;
++ my($old_raw) = shift;
++
++ if (defined $old_hit) {
++ $old_hit->raw($old_raw) if (defined $old_raw);
++ push(@{$self->{cache}}, $old_hit);
++ }
++
++ return (new WWW::SearchResult, '');
++}
++
++sub native_retrieve_some {
++ my ($self) = @_;
++ # fast exit if already done
++ return undef if (!defined $self->{_next_url});
++
++ # get some
++ print STDERR "Fetching " . $self->{_next_url} . "\n" if ($self->{_debug});
++ my($response) = $self->http_request('GET', $self->{_next_url});
++ $self->{response} = $response;
++
++ return undef if (!$response->is_success);
++
++ # parse the output
++ my($HEADER, $HITS, $TRAILER, $POST_NEXT) = (1..10);
++ my($hits_found) = 0;
++ my($state) = ($HEADER);
++ my($hit) = undef;
++ my($raw) = '';
++
++ foreach ($self->split_lines($response->content())) {
++ next if m@^$@; # short circuit for blank lines
++
++ if ($state == $HEADER && m/about <b>([\d,]+)<\/b>/) {
++ my($n) = $1;
++ $self->approximate_result_count($n);
++ print STDERR "Found Total: $n\n" if ($self->{_debug});
++ $state = $HITS;
++
++ } elsif ($state == $HITS &&
++ m|<a href=(\S+)\>(.*?)</a><br><font size=-1><font color=\"#008000\"><.*?>|i
++ ) {
++
++ my ($url, $title) = ($1,$2);
++ ($hit, $raw) = $self->begin_new_hit($hit, $raw);
++ print STDERR "**Found HIT1 Line**\n" if ($self->{_debug});
++ $raw .= $_;
++ $url =~ s/(>.*)//g;
++ $hit->add_url(strip_tags($url));
++ $hits_found++;
++ $title = "No Title" if ($title =~ /^\s+/);
++ $hit->title(strip_tags($title));
++ $state = $HITS;
++
++ } elsif ($state == $HITS &&
++ m@^<p><a href=/url\?sa=U&start=\d+&q=([^<]+)\&.*?>(.*)</a><font size=-1><br>(.*)@i ||
++ m@^<p><a href=(\S+)>(.*)</a>.*?<font size=-1>(.*)@i
++ ) {
++ print STDERR "**Found HIT2 Line**\n" if ($self->{_debug});
++
++ ($hit, $raw) = $self->begin_new_hit($hit, $raw);
++
++ my ($url, $title) = ($1,$2);
++ $mDesc = $3;
++
++ $url =~ s/\/url\?sa=\w&start=\d+&q=//g;
++ $url =~ s/\?lang=(\S+)$//g;
++ $url =~ s/&(.*)//g;
++ $url =~ s/(>.*)//g;
++ $url =~ s/\/$//g; # kill trailing slash.
++
++ $raw .= $_;
++ $hit->add_url(strip_tags($url));
++ $hits_found++;
++
++ $title = "No Title" if ($title =~ /^\s+/);
++ $hit->title(strip_tags($title));
++
++ $mDesc =~ s/<.*?>//g;
++### $mDesc = $mDesc . '<br>' if not $mDesc =~ m@<br>@;
++ $hit->description($mDesc) if (defined $hit);
++ $state = $HITS;
++
++# description parsing
++ } elsif ($state == $HITS && m@<b>(\.\.(.+))</b> @i
++ ) {
++ print STDERR "**Parsing Description Line**\n" if ($self->{_debug});
++ $raw .= $_;
++ # uhm...
++ $sDesc = $1 || "";
++
++ $sDesc =~ s/<.*?>//g;
++ $mDesc ||= "";
++ $sDesc = $mDesc . $sDesc;
++# $hit->description($sDesc) if $sDesc =~ m@^\.@;
++ $sDesc = '';
++ $state = $HITS;
++
++ } elsif ($state == $HITS && m@<div>@i
++ ) {
++ ($hit, $raw) = $self->begin_new_hit($hit, $raw);
++ print STDERR "**Found Last Line**\n" if ($self->{_debug});
++ # end of hits
++ $state = $TRAILER;
++
++ } elsif ($state == $TRAILER &&
++ m|<a href=([^<]+)><img src=/nav_next.gif.*?>.*?|i
++ ) {
++ my($relative_url) = $1;
++ print STDERR "**Fetching >>Next<< Page**\n" if ($self->{_debug});
++ $self->{_next_url} = 'http://www.google.com' . $relative_url;
++ $state = $POST_NEXT;
++ }
++ }
++
++ if ($state != $POST_NEXT) {
++ # No "Next" Tag
++ $self->{_next_url} = undef;
++ $self->begin_new_hit($hit, $raw) if ($state == $HITS);
++ $self->{_next_url} = undef;
++ }
++
++ # ZZZzzzzZZZZzzzzzzZZZZZZzzz
++ $self->user_agent_delay if (defined($self->{_next_url}));
++ return $hits_found;
++}
++
++1;
++
--- /dev/null
+--- WWW/Search/Google.pm.orig Wed May 24 16:55:47 2000
++++ WWW/Search/Google.pm Wed May 24 16:56:19 2000
+@@ -240,7 +240,7 @@
+ if ($state eq $HITS) {
+ print "\n**state == HITS**\n" if 2 <= $self->{_debug};
+ }
+- if ($state eq $HITS && m@^<p><a href=([^<]+)>(.*)</a>$@i)
++ if ($state eq $HITS && m@^<p><a href=([^<]+)>(.*)</a>@i)
+ {
+ print "**Found HIT**\n" if 2 <= $self->{_debug};
+ my ($url, $title) = ($1,$2);
+@@ -252,6 +252,7 @@
+ # some queries *can* create internal junk in the url link
+ # remove them!
+ $url =~ s/\/url\?sa=U&start=\d+&q=//g;
++ $url =~ s/\&exp\=OneBoxNews\s//g; # new junk.
+ $hits_found++;
+ $hit->add_url($url);
+ $hit->title($title);
+@@ -275,9 +276,8 @@
+ print "**Found Second Description**\n" if 2 <= $self->{_debug};
+ $sDesc = $1;
+ $sDesc ||= '';
+- $sDesc =~ s/<.*?>//g;
+- $sDesc = $mDesc . $sDesc;
+- $hit->description($sDesc);
++ $sDesc = $mDesc . $sDesc if (defined $mDesc);
++ $hit->description($sDesc) if (defined $hit and $sDesc ne '');
+ $sDesc ='';
+ $state = $HITS;
+ }
--- /dev/null
+#!/bin/bash
+
+BACKUP_SRCDIR="/var/lib/mysql/"
+BACKUP_TDIR="infobot/"
+BACKUP_FILE="/home/a/apt/public_html/tables.tar.bz2"
+
+pwd
+echo "Copying... $BACKUP_SRCDIR/$BACKUP_TDIR"
+cp -R $BACKUP_SRCDIR/$BACKUP_TDIR ~
+
+if [ -d $BACKUP_TDIR ]; then
+ echo "Tarring... $BACKUP_FILE $BACKUP_TDIR"
+ tar -Icvf $BACKUP_FILE $BACKUP_TDIR
+ echo "Removing..."
+ rm -rf $BACKUP_TDIR
+else
+ echo "ERROR: $BACKUP_TDIR doesn't exist."
+fi
+
+exit 0;
--- /dev/null
+#!/usr/bin/perl -w
+#
+# backup_table-slave.pl: Backup mysql tables
+# Author: dms
+# Version: v0.1b (20000223)
+# Created: 20000210
+#
+
+
+use strict;
+use LWP;
+use POSIX qw(strftime);
+
+my $backup_interval = 1; # every: 1,7,14,30.
+my $backup_count = 7;
+my $backup_url = "http://achilles.nyip.net/~apt/tables.tar.bz2";
+my $backup_file = "tables-##DATE.tar.bz2";
+my $backup_destdir = "/home/xk/public_html/";
+my $backup_indexfile = "tables-index.txt";
+
+my %index;
+
+# Usage: &getURL($url);
+sub getURL {
+ my ($url) = @_;
+ my ($ua,$res,$req);
+
+ $ua = new LWP::UserAgent;
+ $ua->proxy('http', $ENV{'http_proxy'}) if (exists $ENV{'http_proxy'});
+ $ua->proxy('http', $ENV{'HTTP_PROXY'}) if (exists $ENV{'HTTP_PROXY'});
+
+ $req = new HTTP::Request('GET',$url);
+ $res = $ua->request($req);
+
+ # return NULL upon error.
+ if ($res->is_success) {
+ return $res->content;
+ } else {
+ print "error: failure.\n";
+ exit 1;
+ }
+}
+
+#...
+if ( -f "$backup_destdir/$backup_indexfile") {
+ if (open(INDEX, "$backup_destdir/$backup_indexfile")) {
+ while (<INDEX>) {
+ chop;
+
+ # days since 1970, file.
+ if (/^(\d+) (\S+)$/) {
+ $index{$1} = $2;
+ }
+ }
+ close INDEX;
+ } else {
+ print "WARNING: can't open $backup_indexfile.\n";
+ }
+}
+my $now_days = (localtime)[7] + (((localtime)[5] - 70) * 365);
+my $now_date = strftime("%Y%m%d", localtime);
+
+if (scalar keys %index) {
+ my $last_days = (sort {$b <=> $a} keys %index)[0];
+
+ if ($now_days - $last_days < $backup_interval) {
+ print "error: shouldn't run today.\n";
+ goto recycle;
+ }
+}
+
+$backup_file =~ s/##DATE/$now_date/;
+print "backup_file => '$backup_file'.\n";
+if ( -f $backup_file) {
+ print "error: $backup_file already exists.\n";
+ exit 1;
+}
+
+my $file = &getURL($backup_url);
+open(OUT,">$backup_destdir/$backup_file");
+print OUT $file;
+close OUT;
+
+$index{$now_days} = $backup_file;
+recycle:;
+my @index = sort {$b <=> $a} keys %index;
+
+open(OUT,">$backup_destdir/$backup_indexfile");
+for(my $i=0; $i<scalar(@index); $i++) {
+ my $day = $index[$i];
+ print "fe: day => '$day'.\n";
+
+ if ($backup_count - 1 >= $i) {
+ print "DEBUG: $day $index{$day}\n";
+ print OUT "$day $index{$day}\n";
+ } else {
+ print "Deleting $backup_destdir/$index{$day}\n";
+ unlink "$backup_destdir/$index{$day}";
+ }
+}
+close OUT;
+
+print "Done.\n";
--- /dev/null
+#!/bin/sh
+
+BOTDIR=/home/apt/bot
+BOTNICK=infobot
+PIDFILE=$BOTDIR/$BOTNICK.pid
+
+if [ -f $PIDFILE ]; then # exists.
+ PID=`cat $PIDFILE`
+ if [ -d /proc/$PID ]; then # already running.
+ exit 0
+ fi
+
+ # infobot removes the pid file.
+ echo "stale pid file; removing."
+# rm -f $PIDFILE
+fi
+
+cd $BOTDIR
+./infobot
--- /dev/null
+#!/usr/bin/perl
+# by the xk.
+###
+
+require "src/core.pl";
+require "src/logger.pl";
+require "src/modules.pl";
+
+require "src/Misc.pl";
+require "src/Files.pl";
+&loadDBModules();
+require "src/dbi.pl";
+package main;
+
+# todo: main()
+
+if (!scalar @ARGV) {
+ print "Usage: dbm2mysql <whatever dbm>\n";
+ print "Example: dbm2mysql.pl apt\n";
+ print "NOTE: suffix '-is' and '-extra' are used.\n";
+ exit 0;
+}
+
+my $dbfile = shift;
+my $key;
+my %db;
+
+# open dbm.
+if (!dbmopen(%db, $dbfile, 0666)) {
+ &ERROR("Failed open to dbm file ($dbfile).");
+ exit 1;
+}
+&status("::: opening dbm file: $dbfile");
+
+# open all the data...
+&loadConfig("files/infobot.config");
+$dbname = $param{'DBName'};
+my $dbh_mysql = sqlOpenDB($param{'DBName'},
+ $param{'DBType'}, $param{'SQLUser'}, $param{'SQLPass'});
+print "DEBUG: scalar db == '". scalar(keys %db) ."'.\n";
+
+my $factoid;
+my $ndef = 1;
+my $i = 1;
+foreach $factoid (keys %db) {
+ &sqlReplace("factoids", {
+ factoid_key => $_,
+ factoid_value => $db{$_},
+ } );
+
+ $i++;
+ print "i=$i... " if ($i % 100 == 0);
+ print "ndef=$ndef... " if ($ndef % 1000 == 0);
+}
+
+print "Done.\n";
+&closeDB();
+dbmclose(%db);
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use DB_File;
+if (!scalar @ARGV) {
+ print "Usage: dbm2txt <whatever dbm>\n";
+ print "Example: dbm2txt.pl factoids\n";
+ exit 0;
+}
+
+my $dbfile = shift;
+my %db;
+if (0) {
+ require "src/Factoids/db_dbm.pl";
+ openDB();
+}
+
+dbmopen(%db, $dbfile, 0644) or die "error: cannot open db. $dbfile\n";
+my ($key, $val);
+while (($key, $val) = each %db) {
+ chomp $val;
+ print "$key => $val\n";
+}
+dbmclose %db;
--- /dev/null
+#! /usr/bin/perl -w
+
+# debchange: update the debian changelog using your favorite visual editor
+# For options, see the usage message below.
+#
+# When creating a new changelog section, if either of the environment
+# variables DEBEMAIL or EMAIL is set, debchange will use this as the
+# uploader's email address (with the former taking precedence), and if
+# DEBFULLNAME or NAME is set, it will use this as the uploader's full name.
+# Otherwise, it will take the standard values for the current user or,
+# failing that, just copy the values from the previous changelog entry.
+#
+# Originally by Christoph Lameter <clameter@debian.org>
+# Modified extensively by Julian Gilbey <jdg@debian.org>
+#
+# Copyright 1999-2005 by Julian Gilbey
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+use 5.008; # We're using PerlIO layers
+use strict;
+use open ':utf8'; # changelogs are written with UTF-8 encoding
+use filetest 'access'; # use access rather than stat for -w
+use Encode 'decode_utf8'; # for checking whether user names are valid
+use Getopt::Long;
+use File::Copy;
+use File::Basename;
+use Cwd;
+
+BEGIN {
+ # Load the URI::Escape module safely
+ eval { require URI::Escape; };
+ if ($@) {
+ my $progname = basename $0;
+ if ($@ =~ /^Can\'t locate URI\/Escape\.pm/) {
+ die "$progname: you must have the liburi-perl package installed\nto use this script\n";
+ }
+ die "$progname: problem loading the URI::Escape module:\n $@\nHave you installed the liburi-perl package?\n";
+ }
+ import URI::Escape;
+}
+
+# Predeclare functions
+sub fatal($);
+my $warnings = 0;
+
+# And global variables
+my $progname = basename($0);
+my $modified_conf_msg;
+my %env;
+my $CHGLINE; # used by the format O section at the end
+
+sub usage () {
+ print <<"EOF";
+Usage: $progname [options] [changelog entry]
+Options:
+ -a, --append
+ Append a new entry to the current changelog
+ -i, --increment
+ Increase the Infobot release number, adding a new changelog entry
+ -v <version>, --newversion=<version>
+ Add a new changelog entry with version number specified
+ -e, --edit
+ Don't change version number or add a new changelog entry, just
+ update the changelog's stamp and open up an editor
+ -r, --release
+ Update the changelog timestamp.
+ -d, --fromdirname
+ Add a new changelog entry with version taken from the directory name
+ -p, --preserve
+ Preserve the directory name
+ --no-preserve
+ Do not preserve the directory name (default)
+ --help, -h
+ Display this help message and exit
+ --version
+ Display version information
+ At most one of -a, -i, -e, -r, -v, -d (or their long equivalents)
+ may be used.
+ With no options, one of -i or -a is chosen by looking for a .upload
+ file in the parent directory and checking its contents.
+
+Default settings modified by devscripts configuration files:
+$modified_conf_msg
+EOF
+}
+
+sub version () {
+ print <<"EOF";
+This is $progname, ripped from the Debian devscripts package, version 2.10.9
+This code is copyright 1999-2003 by Julian Gilbey, all rights reserved.
+Based on code by Christoph Lameter.
+This program comes with ABSOLUTELY NO WARRANTY.
+You are free to redistribute this code under the terms of the
+GNU General Public License, version 2 or later.
+EOF
+}
+
+# Start by setting default values
+my $check_dirname_level = 1;
+my $check_dirname_regex = 'PACKAGE(-.*)?';
+my $opt_p = 0;
+my $opt_query = 1;
+my $opt_release_heuristic = 'log';
+my $opt_multimaint = 1;
+my $opt_multimaint_merge = 0;
+my $opt_tz = undef;
+my $opt_mainttrailer = 0;
+
+# Next, read configuration files and then command line
+# The next stuff is boilerplate
+
+if (@ARGV and $ARGV[0] =~ /^--no-?conf$/) {
+ $modified_conf_msg = " (no configuration files read)";
+ shift;
+} else {
+ my @config_files = ('~/.infobot-dev.conf');
+ my %config_vars = (
+ 'CHANGE_PRESERVE' => 'no',
+ 'CHANGE_TZ' => $ENV{TZ}, # undef if TZ unset
+ );
+ $config_vars{'CHANGE_TZ'} ||= '';
+ my %config_default = %config_vars;
+
+ my $shell_cmd;
+ # Set defaults
+ foreach my $var (keys %config_vars) {
+ $shell_cmd .= qq[$var="$config_vars{$var}";\n];
+ }
+ $shell_cmd .= 'for file in ' . join(" ",@config_files) . "; do\n";
+ $shell_cmd .= '[ -f $file ] && . $file; done;' . "\n";
+ # Read back values
+ foreach my $var (keys %config_vars) { $shell_cmd .= "echo \$$var;\n" }
+ my $shell_out = `/bin/bash -c '$shell_cmd'`;
+ @config_vars{keys %config_vars} = split /\n/, $shell_out, -1;
+
+ # Check validity
+ $config_vars{'CHANGE_PRESERVE'} =~ /^(yes|no)$/
+ or $config_vars{'CHANGE_PRESERVE'}='no';
+
+ foreach my $var (sort keys %config_vars) {
+ if ($config_vars{$var} ne $config_default{$var}) {
+ $modified_conf_msg .= " $var=$config_vars{$var}\n";
+ }
+ }
+ $modified_conf_msg ||= " (none)\n";
+ chomp $modified_conf_msg;
+
+ $opt_p = $config_vars{'CHANGE_PRESERVE'} eq 'yes' ? 1 : 0;
+ $opt_tz = $config_vars{'CHANGE_TZ'};
+}
+
+# We use bundling so that the short option behaviour is the same as
+# with older debchange versions.
+my ($opt_help, $opt_version);
+my ($opt_i, $opt_a, $opt_e, $opt_r, $opt_v, $opt_b, $opt_d, $opt_D, $opt_u, $opt_t);
+my ($opt_n, $opt_qa, $opt_bpo, $opt_c, $opt_m, $opt_create, $opt_package, @closes);
+my ($opt_news);
+my ($opt_ignore, $opt_level, $opt_regex, $opt_noconf);
+
+Getopt::Long::Configure('bundling');
+GetOptions("help|h" => \$opt_help,
+ "version" => \$opt_version,
+ "i|increment" => \$opt_i,
+ "a|append" => \$opt_a,
+ "e|edit" => \$opt_e,
+ "r|release" => \$opt_r,
+ "v|newversion=s" => \$opt_v,
+ "p" => \$opt_p,
+ "preserve!" => \$opt_p,
+ "release-heuristic=s" => \$opt_release_heuristic,
+ )
+ or die "Usage: $progname [options] [changelog entry]\nRun $progname --help for more details\n";
+
+if ($opt_noconf) {
+ fatal "--no-conf is only acceptable as the first command-line option!";
+}
+if ($opt_help) { usage; exit 0; }
+if ($opt_version) { version; exit 0; }
+
+# dirname stuff
+if ($opt_ignore) {
+ fatal "--ignore-dirname has been replaced by --check-dirname-level and\n--check-dirname-regex; run $progname --help for more details";
+}
+
+if (defined $opt_level) {
+ if ($opt_level =~ /^[012]$/) { $check_dirname_level = $opt_level; }
+ else {
+ fatal "Unrecognised --check-dirname-level value (allowed are 0,1,2)";
+ }
+}
+
+if (defined $opt_regex) { $check_dirname_regex = $opt_regex; }
+
+# Only allow at most one non-help option
+fatal "Only one of -a, -i, -e, -r, -v, -d is allowed;\ntry $progname --help for more help"
+ if ($opt_i?1:0) + ($opt_a?1:0) + ($opt_e?1:0) + ($opt_r?1:0) + ($opt_v?1:0) + ($opt_d?1:0) + ($opt_n?1:0) + ($opt_qa?1:0) + ($opt_bpo?1:0) > 1;
+
+my $changelog_path = $opt_c || $ENV{'CHANGELOG'} || 'Changelog';
+my $real_changelog_path = $changelog_path;
+if ($changelog_path ne 'Changelog') {
+ $check_dirname_level = 0;
+}
+
+if ($opt_create) {
+ if ($opt_a || $opt_i || $opt_e || $opt_r || $opt_b || $opt_n || $opt_qa || $opt_bpo) {
+ warn "$progname warning: ignoring -a/-i/-e/-r/-b/-n/--qa/--bpo options with --create\n";
+ $warnings++;
+ }
+ if ($opt_package && $opt_d) {
+ fatal "Can only use one of --package and -d";
+ }
+}
+
+
+@closes = split(/,/, join(',', @closes));
+map { s/^\#//; } @closes; # remove any leading # from bug numbers
+
+# We'll process the rest of the command line later.
+
+# Look for the changelog
+my $chdir = 0;
+if (! $opt_create) {
+ if ($changelog_path eq 'Changelog' or $opt_news) {
+ until (-f $changelog_path) {
+ $chdir = 1;
+ chdir '..' or fatal "Can't chdir ..: $!";
+ if (cwd() eq '/') {
+ fatal "Cannot find $changelog_path anywhere!\nAre you in the source code tree?\n(You could use --create if you wish to create this file.)";
+ }
+ }
+
+ # Can't write, so stop now.
+ if (! -w $changelog_path) {
+ fatal "$changelog_path is not writable!";
+ }
+ }
+ else {
+ unless (-f $changelog_path) {
+ fatal "Cannot find $changelog_path!\nAre you in the correct directory?\n(You could use --create if you wish to create this file.)";
+ }
+
+ # Can't write, so stop now.
+ if (! -w $changelog_path) {
+ fatal "$changelog_path is not writable!";
+ }
+ }
+}
+else { # $opt_create
+ unless (-d dirname $changelog_path) {
+ fatal "Cannot find " . (dirname $changelog_path) . " directory!\nAre you in the correct directory?";
+ }
+ if (-f $changelog_path) {
+ fatal "File $changelog_path already exists!";
+ }
+ unless (-w dirname $changelog_path) {
+ fatal "Cannot find " . (dirname $changelog_path) . " directory!\nAre you in the correct directory?";
+ }
+ if ($opt_news && ! -f 'debian/changelog') {
+ fatal "I can't create $opt_news without debian/changelog present";
+ }
+}
+
+#####
+
+# Find the current version number etc.
+my %changelog;
+my $PACKAGE = 'PACKAGE';
+my $VERSION = 'VERSION';
+my $MAINTAINER = 'MAINTAINER';
+my $EMAIL = 'EMAIL';
+my $DISTRIBUTION = 'UNRELEASED';
+my $CHANGES = '';
+
+# Clean up after old versions of debchange
+if (-f "debian/RELEASED") {
+ unlink("debian/RELEASED");
+}
+
+if ( -e "$changelog_path.clg" ) {
+ fatal "The backup file $changelog_path.clg already exists --\n" .
+ "please move it before trying again";
+}
+
+
+# Is this a native Debian package, i.e., does it have a - in the
+# version number?
+(my $EPOCH) = ($VERSION =~ /^(\d+):/);
+(my $SVERSION=$VERSION) =~ s/^\d+://;
+(my $UVERSION=$SVERSION) =~ s/-[^-]*$//;
+
+# Check, sanitise and decode these environment variables
+check_env_utf8('FULLNAME');
+check_env_utf8('NAME');
+check_env_utf8('EMAIL');
+
+if (exists $env{'EMAIL'} and $env{'EMAIL'} =~ /^(.*)\s+<(.*)>$/) {
+ $env{'FULLNAME'} = $1 unless exists $env{'FULLNAME'};
+ $env{'EMAIL'} = $2;
+}
+if (! exists $env{'EMAIL'} or ! exists $env{'FULLNAME'}) {
+ if (exists $env{'EMAIL'} and $env{'EMAIL'} =~ /^(.*)\s+<(.*)>$/) {
+ $env{'FULLNAME'} = $1 unless exists $env{'FULLNAME'};
+ $env{'EMAIL'} = $2;
+ }
+}
+
+# Now use the gleaned values to detemine our MAINTAINER and EMAIL values
+if (! $opt_m) {
+ if (exists $env{'FULLNAME'}) {
+ $MAINTAINER = $env{'FULLNAME'};
+ } elsif (exists $env{'NAME'}) {
+ $MAINTAINER = $env{'NAME'};
+ } else {
+ my @pw = getpwuid $<;
+ if (defined($pw[6])) {
+ if (my $pw = decode_utf8($pw[6])) {
+ $pw =~ s/,.*//;
+ $MAINTAINER = $pw;
+ } else {
+ warn "$progname warning: passwd full name field for uid $<\nis not UTF-8 encoded; ignoring\n";
+ $warnings++;
+ }
+ }
+ }
+ # Otherwise, $MAINTAINER retains its default value of the last
+ # changelog entry
+
+ # Email is easier
+ if (exists $env{'EMAIL'}) { $EMAIL = $env{'EMAIL'}; }
+ elsif (exists $env{'EMAIL'}) { $EMAIL = $env{'EMAIL'}; }
+ else {
+ my $addr;
+ if (open MAILNAME, '/etc/mailname') {
+ chomp($addr = <MAILNAME>);
+ close MAILNAME;
+ }
+ if (!$addr) {
+ chomp($addr = `hostname --fqdn 2>/dev/null`);
+ $addr = undef if $?;
+ }
+ if ($addr) {
+ my $user = getpwuid $<;
+ if (!$user) {
+ $addr = undef;
+ }
+ else {
+ $addr = "$user\@$addr";
+ }
+ }
+ $EMAIL = $addr if $addr;
+ }
+ # Otherwise, $EMAIL retains its default value of the last changelog entry
+} # if (! $opt_m)
+
+#####
+
+# Get a possible changelog entry from the command line
+my $ARGS=join(' ', @ARGV);
+my $TEXT=decode_utf8($ARGS);
+my $EMPTY_TEXT=0;
+
+if (@ARGV and ! $TEXT) {
+ if ($ARGS) {
+ warn "$progname warning: command-line changelog entry not UTF-8 encoded; ignoring\n";
+ $TEXT='';
+ } else {
+ $EMPTY_TEXT = 1;
+ }
+}
+
+# Get the date
+my $date_cmd = ($opt_tz ? "TZ=$opt_tz " : "") . "date -R";
+chomp(my $DATE=`$date_cmd`);
+
+# Are we going to have to figure things out for ourselves?
+if (! $opt_i && ! $opt_v && ! $opt_d && ! $opt_a && ! $opt_e && ! $opt_r &&
+ ! $opt_create) {
+ # Yes, we are
+ if ($opt_release_heuristic eq 'log') {
+ my @UPFILES = glob("../$PACKAGE\_$SVERSION\_*.upload");
+ if (@UPFILES > 1) {
+ fatal "Found more than one appropriate .upload file!\n" .
+ "Please use an explicit -a, -i or -v option instead.";
+ }
+ elsif (@UPFILES == 0) { $opt_a = 1 }
+ else {
+ open UPFILE, "<${UPFILES[0]}"
+ or fatal "Couldn't open .upload file for reading: $!\n" .
+ "Please use an explicit -a, -i or -v option instead.";
+ while (<UPFILE>) {
+ if (m%^(s|Successfully uploaded) (/.*/)?\Q$PACKAGE\E\_\Q$SVERSION\E\_[\w\-\+]+\.changes %) {
+ $opt_i = 1;
+ last;
+ }
+ }
+ close UPFILE
+ or fatal "Problems experienced reading .upload file: $!\n" .
+ "Please use an explicit -a, -i or -v option instead.";
+ if (! $opt_i) {
+ warn "$progname warning: A successful upload of the current version was not logged\n" .
+ "in the upload log file; adding log entry to current version.";
+ $opt_a = 1;
+ }
+ }
+ }
+}
+
+# Open in anticipation....
+unless ($opt_create) {
+ open S, $changelog_path or fatal "Cannot open existing $changelog_path: $!";
+}
+open O, ">$changelog_path.clg"
+ or fatal "Cannot write to temporary file: $!";
+# Turn off form feeds; taken from perlform
+select((select(O), $^L = "")[0]);
+
+# Note that we now have to remove it
+my $tmpchk=1;
+my ($NEW_VERSION, $NEW_SVERSION, $NEW_UVERSION);
+my $line;
+
+if (($opt_i || $opt_n || $opt_qa || $opt_bpo || $opt_v || $opt_d ||
+ ($opt_news && $VERSION ne $changelog{'Version'})) && ! $opt_create) {
+
+ # Check that a given explicit version number is sensible.
+ if ($opt_v || $opt_d) {
+ if($opt_v) {
+ $NEW_VERSION=$opt_v;
+ } else {
+ my $pwd = basename(cwd());
+ # The directory name should be <package>-<version>
+ my $version_chars = '0-9a-zA-Z+\.~';
+ $version_chars .= ':' if defined $EPOCH;
+ $version_chars .= '\-' if $UVERSION ne $SVERSION;
+ if ($pwd =~ m/^\Q$PACKAGE\E-([0-9][$version_chars]*)$/) {
+ $NEW_VERSION=$1;
+ if ($NEW_VERSION eq $UVERSION) {
+ # So it's a Debian-native package
+ if ($SVERSION eq $UVERSION) {
+ fatal "New version taken from directory ($NEW_VERSION) is equal to\n" .
+ "the current version number ($UVERSION)!";
+ }
+ # So we just increment the Debian revision
+ warn "$progname warning: Incrementing Infobot revision without altering\n version number.\n";
+ $VERSION =~ /^(.*?)([a-yA-Y][a-zA-Z]*|\d*)$/;
+ my $end = $2;
+ if ($end eq '') {
+ fatal "Cannot determine new revision; please use -v option!";
+ }
+ $end++;
+ $NEW_VERSION="$1$end";
+ } else {
+ $NEW_VERSION = "$EPOCH:$NEW_VERSION" if defined $EPOCH;
+ $NEW_VERSION .= "-1";
+ }
+ } else {
+ fatal "The directory name must be <package>-<version> for -d to work!\n" .
+ "No underscores allowed!";
+ }
+ # Don't try renaming the directory in this case!
+ $opt_p=1;
+ }
+
+ if (system("dpkg --compare-versions $VERSION lt $NEW_VERSION" .
+ " 2>/dev/null 1>&2")) {
+ if ($opt_b) {
+ warn "$progname warning: new version ($NEW_VERSION) is less than\n" .
+ "the current version number ($VERSION).\n";
+ } else {
+ fatal "New version specified ($NEW_VERSION) is less than\n" .
+ "the current version number ($VERSION)! Use -b to force.";
+ }
+ }
+
+ ($NEW_SVERSION=$NEW_VERSION) =~ s/^\d+://;
+ ($NEW_UVERSION=$NEW_SVERSION) =~ s/-[^-]*$//;
+ }
+
+ # We use the following criteria for the version and release number:
+ # the last component of the version number is used as the
+ # release number. If this is not a Debian native package, then the
+ # upstream version number is everything up to the final '-', not
+ # including epochs.
+
+ if (! $NEW_VERSION) {
+ if ($VERSION =~ /(.*?)([a-yA-Y][a-zA-Z]*|\d+)$/i) {
+ my $end=$2;
+ my $start=$1;
+ # If it's not already an NMU make it so
+ # otherwise we can be safe if we behave like dch -i
+ if ($opt_n and (not $start =~ /\.$/ or $VERSION eq $UVERSION)) {
+ if ($VERSION eq $UVERSION) {
+ # First NMU of a Debian native package
+ $end .= "-0.1";
+ } else {
+ $end += 0.1;
+ }
+ } elsif ($opt_qa and $start =~/(.*?)-(\d+)\.$/) {
+ # Drop NMU revision when doing a QA upload
+ my $upstream_version = $1;
+ my $debian_revision = $2;
+ $debian_revision++;
+ $start = "$upstream_version-$debian_revision";
+ $end = "";
+ } elsif ($opt_bpo and not $start =~ /~bpo\.$/) {
+ # If it's not already a backport make it so
+ # otherwise we can be safe if we behave like dch -i
+ $end .= "~bpo40+1";
+ } elsif (!$opt_news) {
+ # Don't bump the version of a NEWS file in this case as we're
+ # using the version from the changelog
+ $end++;
+ }
+ $NEW_VERSION = "$start$end";
+ ($NEW_SVERSION=$NEW_VERSION) =~ s/^\d+://;
+ ($NEW_UVERSION=$NEW_SVERSION) =~ s/-[^-]*$//;
+ } else {
+ fatal "Error parsing version number: $VERSION";
+ }
+ }
+
+ $line += 3;
+ print O "\n -- $MAINTAINER <$EMAIL> $DATE\n\n";
+
+ # Copy the old changelog file to the new one
+ local $/ = undef;
+ print O <S>;
+}
+elsif (($opt_r || $opt_a) && ! $opt_create) {
+ # This means we just have to generate a new * entry in changelog
+ # and if a multi-developer changelog is detected, add developer names.
+
+ $NEW_VERSION=$VERSION;
+ $NEW_SVERSION=$SVERSION;
+ $NEW_UVERSION=$UVERSION;
+
+ # Read and discard maintainer line, see who made the
+ # last entry, and determine whether there are existing
+ # multi-developer changes by the current maintainer.
+ $line=-1;
+ my ($lastmaint, $nextmaint, $maintline, $count, $lastheader, $lastdist);
+ my $savedline = $line;;
+ while (<S>) {
+ $line++;
+ # Start of existing changes by the current maintainer
+ if (/^ \[ $MAINTAINER \]$/) {
+ # If there's more than one such block,
+ # we only care about the first
+ $maintline ||= $line;
+ }
+ elsif (defined $lastmaint) {
+ if (m/^\w[-+0-9a-z.]* \([^\(\) \t]+\)((?:\s+[-+0-9a-z.]+)+)\;/i) {
+ $lastheader = $_;
+ $lastdist = $1;
+ $lastdist =~ s/^\s+//;
+ undef $lastdist if $lastdist eq "UNRELEASED";
+ # Revert to our previously saved position
+ $line = $savedline;
+ last;
+ }
+ }
+ elsif (/^ --\s+([^<]+)\s+/) {
+ $lastmaint=$1;
+ # Remember where we are so we can skip back afterwards
+ $savedline = $line;
+ }
+
+ if (defined $maintline && !defined $nextmaint) {
+ $maintline++;
+ }
+ }
+
+ if (defined $maintline && defined $nextmaint) {
+ # Output the lines up to the end of the current maintainer block
+ $count=1;
+ $line=$maintline;
+ foreach (split /\n/, $CHANGES) {
+ print O $_ . "\n";
+ $count++;
+ last if $count==$maintline;
+ }
+ } else {
+ # The first lines are as we have already found
+ print O $CHANGES;
+ };
+
+ if (defined $count) {
+ # Output the remainder of the changes
+ $count=1;
+ foreach (split /\n/, $CHANGES) {
+ $count++;
+ next unless $count>$maintline;
+ print O $_ . "\n";
+ }
+ }
+
+ if ($opt_t && $opt_a) {
+ print O "\n -- $changelog{'Maintainer'} $changelog{'Date'}\n";
+ } else {
+ print O "\n -- $MAINTAINER <$EMAIL> $DATE\n";
+ }
+
+ if ($lastheader) {
+ print O "\n$lastheader";
+ }
+
+ # Copy the rest of the changelog file to new one
+ # Slurp the rest....
+ local $/ = undef;
+ print O <S>;
+}
+elsif ($opt_e && ! $opt_create) {
+ # We don't do any fancy stuff with respect to versions or adding
+ # entries, we just update the timestamp and open the editor
+
+ print O $CHANGES;
+
+ if ($opt_t) {
+ print O "\n -- $changelog{'Maintainer'} $changelog{'Date'}\n";
+ } else {
+ print O "\n -- $MAINTAINER <$EMAIL> $DATE\n";
+ }
+
+ # Copy the rest of the changelog file to the new one
+ $line=-1;
+ while (<S>) { $line++; last if /^ --/; }
+ # Slurp the rest...
+ local $/ = undef;
+ print O <S>;
+
+ # Set the start-line to 0, as we don't know what they want to edit
+ $line=0;
+}
+
+if ($warnings) {
+ if ($warnings>1) {
+ warn "$progname: Did you see those $warnings warnings? Press RETURN to continue...\n";
+ } else {
+ warn "$progname: Did you see that warning? Press RETURN to continue...\n";
+ }
+ my $garbage = <STDIN>;
+}
+
+# Now Run the Editor; always run if doing "closes" to give a chance to check
+if (!$TEXT and !$EMPTY_TEXT) {
+ my $mtime = (stat("$changelog_path.clg"))[9];
+ defined $mtime or fatal
+ "Error getting modification time of temporary $changelog_path: $!";
+
+ system("sensible-editor +$line $changelog_path.clg") == 0 or
+ fatal "Error editing $changelog_path";
+}
+
+copy("$changelog_path.clg","$changelog_path") or
+ fatal "Couldn't replace $changelog_path with new version: $!";
+
+exit 0;
+
+
+# Format for standard Debian changelogs
+format CHANGELOG =
+ * ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ $CHGLINE
+ ~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ $CHGLINE
+.
+# Format for NEWS files.
+format NEWS =
+ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ $CHGLINE
+~~^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ $CHGLINE
+.
+
+my $linecount=0;
+sub format_line {
+ $CHGLINE=shift;
+ my $newentry=shift;
+
+ print O "\n" if $opt_news && ! ($newentry || $linecount);
+ $linecount++;
+ my $f=select(O);
+ if ($opt_news) {
+ $~='NEWS';
+ }
+ else {
+ $~='CHANGELOG';
+ }
+ write O;
+ select $f;
+}
+
+BEGIN {
+ # Initialise the variable
+ $tmpchk=0;
+}
+
+END {
+ if ($tmpchk) {
+ unlink "$changelog_path.clg" or
+ warn "$progname warning: Could not remove $changelog_path.clg";
+ unlink "$changelog_path.clg~"; # emacs backup file
+ }
+}
+
+sub fatal($) {
+ my ($pack,$file,$line);
+ ($pack,$file,$line) = caller();
+ (my $msg = "$progname: fatal error at line $line:\n@_\n") =~ tr/\0//d;
+ $msg =~ s/\n\n$/\n/;
+ die $msg;
+}
+
+# Is the environment variable valid or not?
+sub check_env_utf8 {
+ my $envvar = $_[0];
+
+ if (exists $ENV{$envvar} and $ENV{$envvar} ne '') {
+ if (! decode_utf8($ENV{$envvar})) {
+ warn "$progname warning: environment variable $envvar not UTF-8 encoded; ignoring\n";
+ } else {
+ $env{$envvar} = decode_utf8($ENV{$envvar});
+ }
+ }
+}
+
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+
+my(%param, %conf, %both);
+
+foreach (`find -name "*.pl"`) {
+ chop;
+ my $file = $_;
+ my $debug = 0;
+
+ open(IN, $file);
+ while (<IN>) {
+ chop;
+
+ if (/IsParam\(['"](\S+?)['"]\)/) {
+ print "File: $file: IsParam: $1\n" if $debug;
+ $param{$1}++;
+ next;
+ }
+
+ if (/IsChanConfOrWarn\(['"](\S+?)['"]\)/) {
+ print "File: $file: IsChanConfOrWarn: $1\n" if $debug;
+ $both{$1}++;
+ next;
+ }
+
+ if (/getChanConfDefault\(['"](\S+?)['"]/) {
+ print "File: $file: gCCD: $1\n" if $debug;
+ $both{$1}++;
+ next;
+ }
+
+ if (/getChanConf\(['"](\S+?)['"]/) {
+ print "File: $file: gCC: $1\n" if $debug;
+ $conf{$1}++;
+ next;
+ }
+
+ if (/IsChanConf\(['"](\S+?)['"]\)/) {
+ print "File: $file: ICC: $1\n" if $debug;
+ $conf{$1}++;
+ next;
+ }
+
+ # command hooks => IsChanConfOrWarn => both.
+ # note: this does not support multiple lines.
+ if (/\'Identifier\'[\s\t]=>[\s\t]+\'(\S+?)\'/) {
+ print "File: $file: command hook: $1\n" if $debug;
+ $both{$1}++;
+ next;
+ }
+ }
+ close IN;
+}
+
+print "Conf AND/OR Params:\n";
+foreach (sort keys %both) {
+ print " $_\n";
+}
+print "\n";
+
+print "Params:\n";
+foreach (sort keys %param) {
+ print " $_\n";
+}
+print "\n";
+
+print "Conf:\n";
+foreach (sort keys %conf) {
+ print " $_\n";
+}
--- /dev/null
+#!/usr/bin/perl -w
+
+use DBI;
+
+my $dsn = "DBI:mysql:infobot:localhost";
+my $dbh = DBI->connect($dsn, "USERNAME", "PASSWORD");
+
+my @factkey;
+my %factval;
+my $query;
+my $regex = '\\\\([\_\%])';
+
+$query = "SELECT factoid_key,factoid_value from factoids";
+my $sth = $dbh->prepare($query);
+$sth->execute;
+while (my @row = $sth->fetchrow_array) {
+ if ($row[0] =~ /$regex/) {
+ push(@factkey,$row[0]);
+ } else {
+ $factval{$row[0]} = $row[1] if ($row[1] =~ /$regex/);
+ }
+}
+$sth->finish;
+
+print "scalar factkey => '". scalar(@factkey) ."'\n";
+foreach (@factkey) {
+ print "factkey => '$_'.\n";
+ my $new = $_;
+ $new =~ s/$regex/$1/g;
+
+ next if ($new eq $_);
+
+ $query = "SELECT factoid_key FROM factoids where factoid_key=".
+ $dbh->quote($new);
+ my $sth = $dbh->prepare($query);
+ $sth->execute;
+ if (scalar $sth->fetchrow_array) { # exist.
+ print "please remove $new or $_.\n";
+ } else { # ! exist.
+ $sth->finish;
+
+ $query = "UPDATE factoids SET factoid_key=".$dbh->quote($new).
+ " WHERE factoid_key=".$dbh->quote($_);
+ my $sth = $dbh->prepare($query);
+ $sth->execute;
+ $sth->finish;
+ }
+}
+
+print "scalar factval => '". scalar(keys %factval) ."\n";
+foreach (keys %factval) {
+ print "factval => '$_'.\n";
+ my $fact = $_;
+ my $old = $factval{$_};
+ my $new = $old;
+ $new =~ s/$regex/$1/g;
+
+ next if ($new eq $old);
+
+ $query = "UPDATE factoids SET factoid_value=".$dbh->quote($new).
+ " WHERE factoid_key=".$dbh->quote($fact);
+ my $sth = $dbh->prepare($query);
+ $sth->execute;
+ $sth->finish;
+}
+
+$dbh->disconnect();
--- /dev/null
+#!/usr/bin/perl -w
+
+$| = 1;
+
+use strict;
+
+require "src/core.pl";
+require "src/logger.pl";
+require "src/modules.pl";
+require "src/Factoids/DBCommon.pl";
+
+&loadConfig($bot_config_dir."/infobot.config");
+&loadDBModules();
+
+unless (@_) {
+ print "hrm.. usage\n";
+ exit 0;
+}
+
+foreach (@_) {
+ next unless ( -f $_);
+
+ open(IN, $_) or die "error: cannot open $_\n";
+ print "Opened $_ for input...\n";
+
+ print "inserting... ";
+ while (<IN>) {
+ next unless (/^(.*?) => (.*)$/);
+
+ ### TODO: check if it already exists. if so, don't add.
+ &setFactInfo($1, "factoid_value", $2);
+ print ":: $1 ";
+ }
+
+ close IN;
+}
--- /dev/null
+#!/usr/bin/perl -w
+
+# irclog2html.pl Version 1.5 - 11th May 2000
+# Copyright (C) 2000, Jeffrey W. Waugh
+
+# Author:
+# Jeff Waugh <jdub@aphid.net>
+
+# Contributors:
+# Rick Welykochy <rick@praxis.com.au>
+# Alexander Else <aelse@uu.net>
+
+# Released under the terms of the GNU GPL
+# http://www.gnu.org/copyleft/gpl.html
+
+# Modified by Tim Riker <Tim@Rikers.org>
+# to work with infobot logs
+# then modified again for infobot
+
+# Usage: irclog2html <date> < logfile
+
+# irclog2html will write out a colourised irc log, appending a .html
+# extension to the output file.
+
+
+####################################################################################
+# Perl Configuration
+
+use strict;
+$^W = 1; #RW# turn on warnings
+use POSIX qw(strftime);
+
+
+####################################################################################
+# Preferences
+
+# Comment out the "table" assignment to use the plain version
+
+#my $STYLE = "tt";
+#my $STYLE = "simplett";
+#my $STYLE = "table";
+my $STYLE = "simpletable";
+
+my $colour_left = "#000099"; # nick leaving channel
+my $colour_joined = "#009900"; # nick joining channel
+my $colour_server = "#009900"; # server message (***)
+my $colour_nickchange = "#009900"; # nick change
+my $colour_action = "#CC00CC"; # nick action (/me waves)
+
+my %prefs_colour_nick = (
+ "jdub" => "#993333",
+ "cantanker" => "#006600",
+ "chuckd" => "#339999",
+);
+
+
+####################################################################################
+# Utility Functions
+
+sub header {
+ my ($channel, $date) = @_;
+ my $return = '';
+
+ $return .= qq{<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
+<html>
+<head>
+ <title>irclog2html for $channel on $date</title>
+ <meta name="generator" content="irclog2html.pl by Jeff Waugh">
+ <meta name="version" content="Version 1.5 - 11th May 2000">
+ <meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
+</head>
+<body text="#000000" bgcolor="#ffffff">
+<h1>irclog2html for $channel on $date</h1>
+};
+
+ if ($STYLE =~ /table/) {
+ $return .= "<table cellspacing=3 cellpadding=2 border=0>\n";
+ }
+ return $return;
+}
+
+sub footer {
+ my $return = '';
+ if ($STYLE =~ /table/) {
+ $return .= "</table>\n";
+ }
+
+ $return .= qq{
+<br>Generated by irclog2html.pl by
+<a href="mailto:jdub\@NOSPAMaphid.net">Jeff Waugh</a> - find it at
+<a href="http://freshmeat.net/appindex/2000/03/28/954251322.html">freshmeat.net</a>!
+Modified by <a href="http://www.Rikers.org">Tim Riker</a> to work with
+<a href="http://infobot.sourceforge.net/">infobot</a> logs, split per channel, etc.
+</body></html>
+};
+ return $return;
+}
+
+my $lastdate = '';
+
+sub add_footers {
+ my $filename;
+
+ return if not $lastdate;
+
+ my @files=`ls $lastdate.html */$lastdate.html`;
+ foreach $filename (@files) {
+ chomp $filename;
+ if (!open(OUTPUT, ">>$filename")) {
+ print "Cannot open $filename for writing!\n\n";
+ return;
+ }
+ print OUTPUT footer();
+ close OUTPUT;
+ }
+}
+
+sub output_line {
+ my ($date, $time, $channel, $lineout) = @_;
+
+ add_footers() if $lastdate ne $date;
+
+ $lastdate = $date;
+ my $filename = "";
+ $filename .= "$channel/" if $channel;
+ $filename .= "$date.html";
+
+ mkdir($channel,oct('755')) if ($channel && ! -d $channel);
+ if (!open(OUTPUT, ">>$filename")) {
+ #print "Cannot open $filename for writing!\n\n";
+ return;
+ }
+ # Begin output #
+ print OUTPUT header($channel, $date) if -z $filename;
+
+ print OUTPUT $lineout;
+
+ close OUTPUT;
+}
+
+sub output_timenicktext {
+ my ($date, $time, $channel, $nick, $text, $htmlcolour) = @_;
+ my $lineout = '';
+
+ if ($STYLE eq "table") {
+ $lineout .= "<tr>";
+ $lineout .= "<td bgcolor=\"$htmlcolour\"><font color=\"#ffffff\"><tt>$time</tt></font></td>" if $time;
+ $lineout .= "<td bgcolor=\"$htmlcolour\"><font color=\"#ffffff\"><tt>$nick</tt></font></td>";
+ $lineout .= "<td width=\"100%\" bgcolor=\"#eeeeee\"><tt><font color=\"$htmlcolour\">$text<\/font></tt></td></tr>\n";
+ }
+ elsif ($STYLE eq "simpletable") {
+ $lineout .= "<tr bgcolor=\"#eeeeee\">";
+ $lineout .= "<td><tt>$time</tt></td>" if $time;
+ $lineout .= "<td><font color=\"$htmlcolour\"><tt>$nick</tt></font></td>";
+ $lineout .= "<td width=\"100%\"><tt>$text</tt></td></tr>\n";
+ }
+ elsif ($STYLE eq "simplett") {
+ $lineout .= "$time " if $time;
+ $lineout .= "<\;$nick>\; $text<br>\n";
+ }
+ else {
+ $lineout .= "$time " if $time;
+ $lineout .= "<font color=\"$htmlcolour\"><\;$nick>\; $text<\/font><br>\n";
+ }
+ output_line($date, $time, $channel, $lineout);
+}
+
+sub output_timeservermsg {
+ my ($date, $time, $channel, $line) = @_;
+ my $lineout = '';
+
+ if ($STYLE =~ /table/) {
+ $lineout .= "<tr>";
+ $lineout .= "<td><tt>$time</tt></td>" if $time;
+ $lineout .= "<td colspan=2><tt>$line</tt></td></tr>\n";
+ }
+ else {
+ $lineout .= "$time " if $time;
+ $lineout .= "$line<br>\n";
+ }
+ output_line($date, $time, $channel, $lineout);
+}
+
+sub html_rgb
+{
+ my ($i,$ncolours) = @_;
+ $ncolours = 1 if $ncolours == 0;
+
+ my $rgbmax = 125; # tune these two for the outmost ranges of colour depth
+ my $rgbmin = 240;
+
+ my $a = 0.95; # tune these for the starting and ending concentrations of R,G,B
+ my $c = 0.5;
+
+ my $rgb = [ [$a,$c,$c], [$c,$a,$c], [$c,$c,$a], [$a,$a,$c], [$a,$c,$a], [$c,$a,$a] ];
+ my $n = $i % @$rgb;
+ my $m = $rgbmin + ($rgbmax - $rgbmin) * ($ncolours - $i) / $ncolours;
+
+ my $r = $rgb->[$n][0] * $m;
+ my $g = $rgb->[$n][1] * $m;
+ my $b = $rgb->[$n][2] * $m;
+ sprintf("#%02x%02x%02x",$r,$g,$b);
+}
+
+####################################################################################
+# Main
+
+sub main {
+ my ($date) = @_;
+ my $files;
+
+ my $line;
+ my $time;
+ my $lastdate = "";
+ my $nick;
+ my $channel;
+ my $text;
+
+ my $htmlcolour;
+ my $nickcount = 0;
+ my $NICKMAX = 30;
+
+ my %colour_nick = %prefs_colour_nick;
+
+ while ($line = <STDIN>) {
+
+ chomp $line;
+
+ if (!$line eq "") {
+ # parse out the time
+ if ($line =~ s/^([0-9:\.]*) (.*)$/$2/) {
+ $time = $1;
+ } else {
+ $time = '';
+ }
+ $channel = '';
+
+ # Replace ampersands, pointies, control characters #
+ $line =~ s/&/&\;/g;
+ $line =~ s/</<\;/g;
+ $line =~ s/>/>\;/g;
+ $line =~ s/\e\[[0-1]*m//g;
+ $line =~ s/[\x00-\x1f]+//g;
+
+ # Replace possible URLs with links #
+ $line =~ s/((http|https|ftp|gopher|news):\/\/\S*)/<a href="$1">$1<\/a>/g;
+
+ # Colourise the comments
+ if ($line =~ /^<\;[^\/]*?\/\#.*?>\; .*$/) {
+ # Split $nick, $channel and $line
+ $nick = $line;
+ $nick =~ s/^<\;([^\/]*?)\/\#.*?>\; .*$/$1/;
+ $channel = $line;
+ $channel =~ s/^<\;[^\/]*?\/(\#.*?)>\; .*$/$1/;
+
+ # $nick =~ tr/[A-Z]/[a-z]/;
+ # <======= move this into another function when getting nick colour
+
+ $text = $line;
+ $text =~ s/^<\;.*?>\; (.*)$/$1/;
+ $text =~ s/^ .*/<\;PROTECTED>\;/g;
+ $text =~ s/ / \; \;/g;
+
+ $htmlcolour = $colour_nick{$nick};
+ if (!defined($htmlcolour)) {
+ # new nick
+ $nickcount++;
+
+ # if we've exceeded our estimate of the number of nicks, double it
+ $NICKMAX *= 2 if $nickcount >= $NICKMAX;
+
+ $htmlcolour = $colour_nick{$nick} = html_rgb($nickcount, $NICKMAX);
+ }
+ output_timenicktext($date, $time, $channel, $nick, $text, $htmlcolour);
+ } elsif ($line =~ /^>\;>\;>\; /) {
+ $line =~ s/^>\;>\;>\; /\*\*\* /;
+
+ # Process changed nick results, and remember colours accordingly #
+ if ($line =~ /\*\*\* (.*?) materializes into (.*)/) {
+ my $nick_old = $1;
+ my $nick_new = $2;
+
+ #$nick_old = $line;
+ #$nick_old =~ s/\*\*\* (.*?) materializes into .*/$1/;
+ #$nick_new = $line;
+ #$nick_new =~ s/\*\*\* (.*?) materializes into (.*)/$2/;
+
+ $colour_nick{$nick_new} = $colour_nick{$nick_old};
+ $colour_nick{$nick_old} = undef;
+
+ $line =~ s/(\*\*\* .*)/<font color=\"$colour_nickchange\">$1<\/font>/
+ } elsif ($line =~ /\*\*\* (join|mode|topic)\/(.*?) .*/) {
+ $channel = lc $2;
+ $line =~ s/(\*\*\* .*)/<font color=\"$colour_joined\">$1<\/font>/;
+ } elsif ($line =~ /\*\*\* (part|kick|banned)\/(.*?) .*/) {
+ $channel = lc $2;
+ $line =~ s/(\*\*\* .*)/<font color=\"$colour_left\">$1<\/font>/;
+ } elsif ($line =~ /\*\*\* .* has signed off IRC .*/) {
+ # Colourise joined/left/server messages #
+ $line =~ s/(\*\*\* .*)/<font color=\"$colour_left\">$1<\/font>/;
+ } elsif ($line =~ /\*\*\* /) {
+ $line =~ s/(\*\*\* .*)$/<font color=\"$colour_server\">$1<\/font>/;
+ } elsif ($line =~ /^\* .*$/) {
+ # Colourise the /me's #
+ $line =~ s/^(\*.*)$/<font color=\"$colour_action\">$1<\/font>/;
+ }
+
+ output_timeservermsg($date, $time, $channel, $line);
+ }
+ }
+ }
+
+ add_footers();
+
+ return 0;
+}
+
+if (!scalar @ARGV) {
+ print "Usage: irclog2html.pl <date> < logfile\n";
+ print "Example: bzcat log/infobot.log-20021104.bz2 | irclog2html.pl 20021104\n";
+ exit 0;
+}
+my $date = shift;
+exit &main($date);
+# vim: ts=2
--- /dev/null
+#!/usr/bin/perl
+
+$| = 1;
+
+print "plaintext> ";
+while (<>) {
+ chomp;
+ $result = &mkpasswd($_);
+ print "\t$result\n";
+ print "plaintext> ";
+}
+
+sub mkpasswd {
+ my $what = $_[0];
+ my $salt = chr(65+rand(27)).chr(65+rand(27));
+ $salt =~ s/\W/x/g;
+
+ return crypt($what, $salt);
+}
+
--- /dev/null
+#!/usr/bin/perl
+# mysql -> txt.
+# written by the xk.
+###
+
+require "src/core.pl";
+require "src/logger.pl";
+require "src/modules.pl";
+require "src/Misc.pl";
+require "src/Files.pl";
+$bot_src_dir = "./src/";
+
+my $dbname = shift;
+if (!defined $dbname) {
+ print "Usage: $0 <db name>\n";
+ print "Example: $0 factoids\n";
+ exit 0;
+}
+
+# open the db.
+&loadConfig("files/infobot.config");
+&loadDBModules();
+
+&openDB($param{'DBName'}, $param{'SQLUser'}, $param{'SQLPass'});
+
+# retrieve a list of db's from the server.
+my %db;
+foreach ($dbh->func('_ListTables')) {
+ $db{$_} = 1;
+}
+
+# factoid db.
+if (!exists $db{$dbname}) {
+ print "error: $dbname does not exist as a table.\n";
+ exit 1;
+}
+
+my $query = "SELECT factoid_key,factoid_value from $param{'DBName'}.$dbname";
+my $sth = $dbh->prepare($query);
+$sth->execute;
+while (my @row = $sth->fetchrow_array) {
+ print "$row[0] => $row[1]\n";
+}
+$sth->finish;
+
+print "Done.\n";
+&closeDB();
--- /dev/null
+package DUMPVAR;
+sub dumpvar {
+ ($packageName) = @_;
+ $rPackage = \%{"${packageName}::"}; # Get a reference to the appropriate symbol table hash.
+ $, = " " ;
+ while (($varName, $globValue) = each %$rPackage) {
+ print "$varName ============================= \n";
+ *var = $globValue;
+ if (defined ($var)) {
+ print "\t \$$varName $var \n";
+ }
+ if (defined (@var)) {
+ print "\t \@$varName @var \n";
+ }
+ if (defined (%var)) {
+ print "\t \%$varName ",%var," \n";
+ }
+ }
+}
+
+
+package Test;
+$x = 10;
+@y = (1,3,4);
+%z = (1,2,3,4, 5, 6, \@y);
+$z = 300;
+DUMPVAR::dumpvar("Test");
--- /dev/null
+@sample = (11.233,{3 => 4, "hello" => [6,7]});
+pretty_print(@sample);
+
+$level = -1; # Level of indentation
+
+sub pretty_print {
+ my $var;
+ foreach $var (@_) {
+ if (ref ($var)) {
+ print_ref($var);
+ } else {
+ print_scalar($var);
+ }
+ }
+}
+
+sub print_scalar {
+ ++$level;
+ print_indented ($_[0]);
+ --$level;
+}
+
+sub print_ref {
+ my $r = $_[0];
+ if (exists ($already_seen{$r})) {
+ print_indented ("$r (Seen earlier)");
+ return;
+ } else {
+ $already_seen{$r}=1;
+ }
+ my $ref_type = ref($r);
+ if ($ref_type eq "ARRAY") {
+ print_array($r);
+ } elsif ($ref_type eq "SCALAR") {
+ print "Ref -> $r";
+ print_scalar($$r);
+ } elsif ($ref_type eq "HASH") {
+ print_hash($r);
+ } elsif ($ref_type eq "REF") {
+ ++$level;
+ print_indented("Ref -> ($r)");
+ print_ref($$r);
+ --$level;
+ } else {
+ print_indented ("$ref_type (not supported)");
+ }
+}
+
+sub print_array {
+ my ($r_array) = @_;
+ ++$level;
+ print_indented ("[ # $r_array");
+ foreach $var (@$r_array) {
+ if (ref ($var)) {
+ print_ref($var);
+ } else {
+ print_scalar($var);
+ }
+ }
+ print_indented ("]");
+ --$level;
+}
+
+sub print_hash {
+ my($r_hash) = @_;
+ my($key, $val);
+ ++$level;
+ print_indented ("{ # $r_hash");
+ while (($key, $val) = each %$r_hash) {
+ $val = ($val ? $val : '""');
+ ++$level;
+ if (ref ($val)) {
+ print_indented ("$key => ");
+ print_ref($val);
+ } else {
+ print_indented ("$key => $val");
+ }
+ --$level;
+ }
+ print_indented ("}");
+ --$level;
+}
+
+sub print_indented {
+ $spaces = ": " x $level;
+ print "${spaces}$_[0]\n";
+}
--- /dev/null
+#!/bin/sh
+echo -n "DEBUG: "; grep DEBUG `find infobot src -type f`| wc -l
+echo -n "WARN: "; grep WARN `find infobot src -type f` | wc -l
+echo -n "FIXME: "; grep FIXME `find infobot src -type f` | wc -l
+echo -n "status: "; grep status `find infobot src -type f` | wc -l
+echo -n "ERROR: "; grep ERROR `find infobot src -type f` | wc -l
+echo -n "TODO: "; grep TODO `find infobot src -type f` | wc -l
--- /dev/null
+#!/usr/bin/perl -w
+
+# leading and trailing context lines.
+my $contextspread = 2;
+
+use strict;
+
+$| = 1;
+
+if (!scalar @ARGV) {
+ print "Usage: parse_warn.pl <files>\n";
+ print "Example: parse_warn.pl log/*\n";
+ exit 0;
+}
+
+my %done;
+my $file;
+
+foreach $file (@ARGV) {
+ if (! -f $file) {
+ print "warning: $file does not exist.\n";
+ next;
+ }
+ my $str = ' at .* line ';
+
+ print "Opening $file... ";
+ if ($file =~ /bz2$/) { # bz2
+ open(FILE, "bzcat $file | egrep '$str' |");
+ } elsif ($file =~ /gz$/) { # gz
+ open(FILE, "zegrep '$str' $file |");
+ } else { # raw
+ open(FILE, "egrep '$str' $file |");
+ }
+
+ print "Parsing... ";
+ while (<FILE>) {
+ if (/ at (\S+) line (\d+)/) {
+ my ($file,$lineno) = ($1,$2+1);
+ $done{$file}{$lineno}++;
+ }
+ }
+ close FILE;
+
+ print "Done.\n";
+}
+
+foreach $file (keys %done) {
+ my $count = scalar(keys %{$done{$file}});
+ print "warn $file: $count unique warnings.\n";
+
+ if (! -f $file) {
+ print "=> error: does not exist.\n\n";
+ next;
+ }
+
+ if (open(IN,$file)) {
+ my @lines = <IN>;
+ close IN;
+
+ my $total = scalar @lines;
+ my $spread = 0;
+ my $done = 0;
+ for(my $i=0; $i<=$total; $i++) {
+ next unless (exists $done{$file}{$i+$contextspread} or $spread);
+
+ if (exists $done{$file}{$i+$contextspread}) {
+ print "@@ $i @@\n" unless ($spread);
+ # max lines between offending lines should be 2*context-1.
+ # coincidence that it is!
+ $spread = 2*$contextspread;
+ } else {
+ $spread--;
+ }
+
+ if (exists $done{$file}{$i}) {
+ print "*** ";
+ } else {
+ print "--- ";
+ }
+
+ if ($i >= $total) {
+ print "EOF\n";
+ } else {
+ print $lines[$i];
+ }
+ }
+ print "\n";
+ } else {
+ print "=> error: could not open file.\n";
+ }
+}
--- /dev/null
+@test = ("test");
+
+sub dumpvar {
+ ($packageName) = @_;
+ $rPackage = \%{"${packageName}::"}; # Get a reference to the appropriate symbol table hash.
+ $, = " " ;
+ while (($varName, $globValue) = each %$rPackage) {
+ last if ($varName eq "main::");
+ print "$varName ============================= \n";
+ *var = $globValue;
+ if (defined ($var)) {
+ print "\t \$$varName = '$var' \n";
+ }
+ if (defined (@var)) {
+ pretty_print(@var);
+### print "\t \@$varName @var \n";
+ }
+ if (defined (%var)) {
+ pretty_print(%var);
+### print "\t \%$varName ",%var," \n";
+ }
+ }
+}
+
+dumpvar("main");
+
+$level = -1; # Level of indentation
+
+sub pretty_print {
+ my $var;
+ foreach $var (@_) {
+ if (ref ($var)) {
+ print_ref($var);
+ } else {
+ print_scalar($var);
+ }
+ }
+}
+
+sub print_scalar {
+ ++$level;
+ print_indented ($_[0]);
+ --$level;
+}
+
+sub print_ref {
+ my $r = $_[0];
+ if (exists ($already_seen{$r})) {
+ print_indented ("$r (Seen earlier)");
+ return;
+ } else {
+ $already_seen{$r}=1;
+ }
+ my $ref_type = ref($r);
+ if ($ref_type eq "ARRAY") {
+ print_array($r);
+ } elsif ($ref_type eq "SCALAR") {
+ print "Ref -> $r";
+ print_scalar($$r);
+ } elsif ($ref_type eq "HASH") {
+ print_hash($r);
+ } elsif ($ref_type eq "REF") {
+ ++$level;
+ print_indented("Ref -> ($r)");
+ print_ref($$r);
+ --$level;
+ } else {
+ print_indented ("$ref_type (not supported)");
+ }
+}
+
+sub print_array {
+ my ($r_array) = @_;
+ ++$level;
+ print_indented ("[ # $r_array");
+ foreach $var (@$r_array) {
+ if (ref ($var)) {
+ print_ref($var);
+ } else {
+ print_scalar($var);
+ }
+ }
+ print_indented ("]");
+ --$level;
+}
+
+sub print_hash {
+ my($r_hash) = @_;
+ my($key, $val);
+ ++$level;
+ print_indented ("{ # $r_hash");
+ while (($key, $val) = each %$r_hash) {
+ $val = ($val ? $val : '""');
+ ++$level;
+ if (ref ($val)) {
+ print_indented ("$key => ");
+ print_ref($val);
+ } else {
+ print_indented ("$key => $val");
+ }
+ --$level;
+ }
+ print_indented ("}");
+ --$level;
+}
+
+sub print_indented {
+ $spaces = ": " x $level;
+ print "${spaces}$_[0]\n";
+}
--- /dev/null
+#!/usr/bin/perl -w
+
+# hrm...
+#use strict;
+
+my @test;
+my @test1;
+my %test;
+
+$test{'hash0r'} = 2;
+$test{'hegdfgsd'} = 'GSDFSDfsd';
+
+push(@test1,"Aeh.");
+push(@test1,"Beh.");
+push(@test1,"Ceh.");
+push(@test1,"Deh.");
+
+push(@test,"heh.");
+push(@test,\%test);
+#push(@test,\%ENV);
+push(@test,\@test1);
+
+print "=============start=================\n";
+#&DumpArray(0, '@test', \@test);
+&DumpPackage(0, 'main::', \%main::);
+
+# SCALAR ARRAY HASH CODE REF GLOB LVALUE
+sub DumpArray {
+ my ($pad, $symname, $arrayref) = @_;
+ my $padding = " " x $pad;
+ my $scalar = 0;
+ my $size = 0;
+
+ print "$padding$symname\n";
+ foreach (@{$arrayref}) {
+ my $ref = ref $_;
+ if ($ref eq 'ARRAY') {
+ $size += &DumpArray($pad+1, "@" . $_, $_);
+ } elsif ($ref eq 'HASH') {
+ $size += &DumpHash($pad+1, "%" . $_, $_);
+ } else {
+ print "$padding $_ $ref\n";
+ $scalar++;
+ $size += length($_);
+ }
+ }
+ print $padding."scalars $scalar, size $size\n";
+ return $size;
+}
+
+sub DumpHash{
+ my ($pad, $symname, $hashref) = @_;
+ my $padding = " " x $pad;
+ my $scalar = 0;
+ my $size = 0;
+
+ my %sym = %{$hashref};
+ my @list = sort keys %sym;
+ print "$padding$symname\n";
+
+ foreach (@list) {
+ my $ref = ref %{$symname}; #FIXME
+ $size += length($_);
+ if ($ref eq 'ARRAY') {
+ $size += &DumpArray($pad+1, "@" . $_, $_);
+ } elsif ($ref eq 'HASH') {
+ $size += &DumpHash($pad+1, "%" . $_, $_);
+ } else {
+ print "$padding $_=$sym{$_} $ref\n";
+ $scalar++;
+ $size += length($sym{$_});
+ }
+ }
+ print $padding."scalars $scalar, size $size\n";
+ return $size;
+}
+
+sub DumpPackage {
+ my ($pad, $packname, $package) = @_;
+ my $padding = " " x $pad;
+ my $scalar = 0;
+ my $size = 0;
+
+ print $padding . "\%$packname\n";
+ my $symname;
+ foreach $symname (sort keys %$package) {
+ local *sym = $$package{$symname};
+ if (defined $sym) {
+ print "$padding \$$symname='$sym'\n";
+ $scalar++;
+ $size += length($sym);
+ } elsif (defined @sym) {
+ $size += &DumpArray($pad+1, $symname, \@sym);
+ } elsif (defined %sym) {
+ $size += &DumpHash($pad+1, $symname, \%sym);
+ } elsif (($symname =~ /::/) and ($symname ne 'main::')) {
+ $size += &DumpPackage($pad+1, \%sym, $symname);
+ } else {
+ print("ERROR $symname" . ref $symname . "\n");
+ }
+ }
+ print $padding."scalars $scalar, size $size\n";
+ return $size;
+}
--- /dev/null
+#!/usr/bin/perl
+# by the xk.
+#
+
+require "src/core.pl";
+require "src/logger.pl";
+require "src/modules.pl";
+require "src/Files.pl";
+require "src/Misc.pl";
+require "src/Factoids/DBCommon.pl";
+
+if (!scalar @ARGV) {
+ print "Usage: txt2mysql.pl <input.txt>\n";
+ exit 0;
+}
+
+# open the txtfile.
+my $txtfile = shift;
+open(IN,$txtfile) or die "error: cannot open txtfile '$txtfile'.\n";
+
+# read the bot config file.
+&loadConfig("files/infobot.config");
+&loadDBModules();
+&openDB($param{'DBName'}, $param{'SQLUser'}, $param{'SQLPass'});
+
+### now pipe all the data to the mysql server...
+my $i = 1;
+print "converting factoid db to mysql...\n";
+while (<IN>) {
+ chop;
+ next if !length;
+ if (/^(.*)\s+=>\s+(.*)$/) {
+ # verify if it already exists?
+ my ($key,$val) = ($1,$2);
+ if ($key =~ /^\s*$/ or $val =~ /^\s*$/) {
+ print "warning: broken => '$_'.\n";
+ next;
+ }
+
+ if (&IsParam("freshmeat") and &dbGet("freshmeat", "name", $key, "name")) {
+ if (&getFactoid($key)) {
+ &delFactoid($key);
+ }
+ } else {
+ &setFactInfo(lc $key, "factoid_value", $val);
+ $i++;
+ }
+
+ print "$i... " if ($i % 100 == 0);
+ } else {
+ print "warning: invalid => '$_'.\n";
+ }
+}
+close IN;
+
+print "Done.\n";
+&closeDB();
--- /dev/null
+#!/usr/bin/perl -w
+# hrm...
+
+# use strict;
+
+local @test;
+local %test;
+
+$test{'hash0r'} = 2;
+$test{'hegdfgsd'} = 'GSDFSDfsd';
+
+push(@test,"heh.");
+push(@test,\%test);
+
+&vartree(\%main::, 'main::');
+
+
+sub tree {
+ my ($pad, $ref, $symname) = @_;
+ my $padded = " " x $pad;
+ my @list;
+ my $scalar = 0;
+ my $size = 0;
+
+ @list = keys %{$symname} if ($ref eq 'HASH');
+ @list = @{$symname} if ($ref eq 'ARRAY');
+
+ foreach (@list) {
+ my $ref = ref $_;
+
+ if ($ref eq 'HASH' or $ref eq 'ARRAY') {
+ print $padded."recursing $ref($_).\n";
+ &tree($pad+2, $ref, $_);
+ } elsif ($ref eq '') {
+ $scalar++;
+ $size += length($_);
+ }
+ }
+ print $padded."scalars $scalar, size $size\n";
+}
+
+sub vartree {
+ my ($package, $packname) = @_;
+ my $symname;
+
+ # scalar.
+ foreach $symname (sort keys %$package) {
+ local *sym = $$package{$symname};
+ next unless (defined $sym);
+ print "scalar => $symname = '$sym'\n";
+ }
+
+ # array.
+ foreach $symname (sort keys %$package) {
+ local *sym = $$package{$symname};
+ next unless (defined @sym);
+ print "\@$symname\n";
+ &tree(2, "ARRAY", $symname);
+ }
+
+ # hash.
+ foreach $symname (sort keys %$package) {
+ local *sym = $$package{$symname};
+ next unless (defined %sym);
+ print "\%$symname\n";
+ &tree(2, "HASH", $symname);
+ }
+
+ foreach $symname (sort keys %$package) {
+ local *sym = $$package{$symname};
+ next unless (defined %sym);
+ next unless ($symname =~ /::/);
+ next if ($symname eq 'main::');
+
+ print "recurse: $symname.\n";
+ &vartree(\%sym, $symname);
+ }
+
+ print "end.\n";
+}
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use LWP;
+use POSIX qw(strftime);
+
+my $backup_interval = 1; # every: 1,7,14,30.
+my $backup_count = 7;
+my $backup_url = "http://core.junker.org/~apt/tables.tar.bz2";
+my $backup_file = "tables-##DATE.tar.bz2";
+my $backup_destdir = "/home/xk/public_html/";
+my $backup_indexfile = "tables-index.txt";
+
+my %index;
+
+# Usage: &getURL($url);
+sub getURL {
+ my ($url) = @_;
+ my ($ua,$res,$req);
+
+ $ua = new LWP::UserAgent;
+### $ua->proxy('http', $proxy);
+
+ $req = new HTTP::Request('GET',$url);
+ $res = $ua->request($req);
+
+ # return NULL upon error.
+ if ($res->is_success) {
+ return $res->content;
+ } else {
+ print "error: failure.\n";
+ exit 1;
+ }
+}
+
+#...
+if ( -f "$backup_destdir/$backup_indexfile") {
+ if (open(INDEX, "$backup_destdir/$backup_indexfile")) {
+ while (<INDEX>) {
+ chop;
+
+ # days since 1970, file.
+ if (/^(\d+) (\S+)$/) {
+ $index{$1} = $2;
+ }
+ }
+ close INDEX;
+ } else {
+ print "WARNING: can't open $backup_indexfile.\n";
+ }
+}
+my $now_days = (localtime)[7] + (((localtime)[5] - 70) * 365);
+my $now_date = strftime("%Y%m%d", localtime);
+
+if (scalar keys %index) {
+ my $last_days = (sort {$b <=> $a} keys %index)[0];
+
+ if ($now_days - $last_days < $backup_interval) {
+ print "error: shouldn't run today.\n";
+ goto cycle;
+ }
+}
+
+$backup_file =~ s/##DATE/$now_date/;
+print "backup_file => '$backup_file'.\n";
+if ( -f $backup_file) {
+ print "error: $backup_file already exists.\n";
+ exit 1;
+}
+
+my $file = &getURL($backup_url);
+open(OUT,">$backup_destdir/$backup_file");
+print OUT $file;
+close OUT;
+
+$index{$now_days} = $backup_file;
+cycle:;
+my @index = sort {$b <=> $a} keys %index;
+
+open(OUT,">$backup_destdir/$backup_indexfile");
+for(my $i=0; $i<scalar(@index); $i++) {
+ my $day = $index[$i];
+ print "fe: day => '$day'.\n";
+
+ if ($backup_count - 1 >= $i) {
+ print "DEBUG: $day $index{$day}\n";
+ print OUT "$day $index{$day}\n";
+ } else {
+ print "Deleting $index{$day}\n";
+ unlink $backup_destdir."/".$index{$day};
+ }
+}
+close OUT;
+
+print "Done.\n";
--- /dev/null
+Welcome,
+
+This directory has changed slightly. The new format allows for
+each type of database to have its own schema. The following
+directories are included:
+
+ mysql/ -- Schema for the popular MySQL
+ sqlite/ -- Schema for v2 or v3 of SQLite
+ sqlite2/ -- Schema for specifically v2 of SQLite
+ pgsql/ -- Schema for PostgreSQL
+
+Also, the included setup.pl has been modified to work with
+all of the above types of databases. (FIXME: actually, only
+MySQL until I actually change it)
+
+To automate the setup of your database and user, type:
+
+ cd ~/infobotdir
+ ./setup/setup.pl
+
+(NOTE: The setup will ask for an account capable of administrating
+the database server!)
--- /dev/null
+CREATE TABLE botmail (
+ srcwho VARCHAR(20) NOT NULL,
+ dstwho VARCHAR(20) NOT NULL,
+ srcuh VARCHAR(80) NOT NULL,
+ time INT UNSIGNED DEFAULT 'UNIX_TIMESTAMP()',
+ msg TEXT NOT NULL,
+ PRIMARY KEY (srcwho,dstwho)
+);
--- /dev/null
+CREATE TABLE connections (
+ server VARCHAR(30) NOT NULL,
+ port INT NOT NULL DEFAULT '6667',
+ nick VARCHAR(20) NOT NULL,
+ nickservpass VARCHAR(8) NOT NULL,
+ ircname VARCHAR (20) NOT NULL DEFAULT 'infobot experimental bot',
+ timeadded INT UNSIGNED DEFAULT 'UNIX_TIMESTAMP()',
+ PRIMARY KEY (server,port,nick)
+);
--- /dev/null
+CREATE TABLE factoids (
+ factoid_key VARCHAR(64) NOT NULL,
+ requested_by VARCHAR(64) NOT NULL DEFAULT 'nobody',
+ requested_time INT NOT NULL DEFAULT '0',
+ requested_count SMALLINT UNSIGNED NOT NULL DEFAULT '0',
+ created_by VARCHAR(64),
+ created_time INT NOT NULL DEFAULT '0',
+ modified_by VARCHAR(192),
+ modified_time INT NOT NULL DEFAULT '0',
+ locked_by VARCHAR(64),
+ locked_time INT NOT NULL DEFAULT '0',
+ factoid_value TEXT NOT NULL,
+ PRIMARY KEY (factoid_key)
+);
--- /dev/null
+CREATE TABLE freshmeat (
+ projectname_short VARCHAR(64) NOT NULL,
+ latest_version VARCHAR(32) DEFAULT 'none' NOT NULL,
+ license VARCHAR(32),
+ url_homepage VARCHAR(128),
+ desc_short VARCHAR(96) NOT NULL,
+ PRIMARY KEY (projectname_short,latest_version)
+);
--- /dev/null
+CREATE TABLE news (
+ channel VARCHAR(16) NOT NULL,
+ id INT UNSIGNED DEFAULT '0',
+ key VARCHAR(16) NOT NULL,
+ value TEXT NOT NULL, # limit to ~450 or so.
+ PRIMARY KEY (channel,id,key)
+);
--- /dev/null
+CREATE TABLE onjoin (
+ nick VARCHAR(20) NOT NULL,
+ channel VARCHAR(16) NOT NULL,
+ message VARCHAR(255) NOT NULL,
+ modified_by VARCHAR(20) NOT NULL DEFAULT 'nobody',
+ modified_time INT NOT NULL DEFAULT '0',
+ PRIMARY KEY (nick, channel)
+);
+
+-- v.2 -> v.3
+-- ALTER TABLE onjoin ADD COLUMN modified_by VARCHAR(20) NOT NULL DEFAULT 'nobody';
+-- ALTER TABLE onjoin ADD COLUMN modified_time INT NOT NULL DEFAULT '0';
+-- ** the following doesn't work for sqlite **
+-- ALTER TABLE onjoin ADD PRIMARY KEY (nick, channel);
--- /dev/null
+CREATE TABLE rootwarn (
+ nick VARCHAR(20) NOT NULL,
+ attempt SMALLINT UNSIGNED,
+ time INT NOT NULL,
+ host VARCHAR(80) NOT NULL,
+ channel VARCHAR(20) NOT NULL,
+ PRIMARY KEY (nick)
+);
--- /dev/null
+CREATE TABLE seen (
+ nick VARCHAR(20) NOT NULL,
+ time INT NOT NULL,
+ channel VARCHAR(20) NOT NULL,
+ host VARCHAR(80) NOT NULL,
+ message TINYTEXT NOT NULL,
+ PRIMARY KEY (nick,channel)
+);
--- /dev/null
+CREATE TABLE stats (
+ nick VARCHAR(20) NOT NULL,
+ type VARCHAR(8) NOT NULL,
+ channel VARCHAR(16) NOT NULL DEFAULT "PRIVATE",
+ time INT UNSIGNED DEFAULT 'UNIX_TIMESTAMP()',
+ counter SMALLINT UNSIGNED DEFAULT '0',
+ PRIMARY KEY (nick,type,channel)
+);
--- /dev/null
+CREATE TABLE uptime (
+ uptime INT UNSIGNED DEFAULT '0', # start.
+ endtime INT UNSIGNED DEFAULT '0', # end.
+ string VARCHAR(128) NOT NULL,
+ PRIMARY KEY (uptime)
+);
--- /dev/null
+CREATE TABLE botmail (
+ srcwho character varying(20) NOT NULL,
+ dstwho character varying(20) NOT NULL,
+ srcuh character varying(80) NOT NULL,
+ "time" numeric DEFAULT 0 NOT NULL,
+ msg text NOT NULL
+) WITHOUT OIDS;
+
+REVOKE ALL ON TABLE botmail FROM PUBLIC;
+
+ALTER TABLE ONLY botmail
+ ADD CONSTRAINT botmail_pkey PRIMARY KEY (srcwho, dstwho);
--- /dev/null
+CREATE TABLE connections (
+ server character varying(30) NOT NULL,
+ port integer DEFAULT 6667 NOT NULL,
+ nick character varying(20) NOT NULL,
+ nickservpass character varying(8) NOT NULL,
+ ircname character varying(20) DEFAULT 'infobot IRC bot'::character varying NOT NULL,
+ timeadded numeric DEFAULT 0
+) WITHOUT OIDS;
+
+REVOKE ALL ON TABLE connections FROM PUBLIC;
+
+ALTER TABLE ONLY connections
+ ADD CONSTRAINT connections_pkey PRIMARY KEY (server, port, nick);
--- /dev/null
+CREATE TABLE factoids (
+ factoid_key VARCHAR(64) NOT NULL,
+ requested_by VARCHAR(80) DEFAULT 'nobody' NOT NULL,
+ requested_time numeric(11) DEFAULT 0 NOT NULL,
+ requested_count numeric(5) DEFAULT 0 NOT NULL,
+ created_by VARCHAR(80),
+ created_time numeric(11) DEFAULT 0 NOT NULL,
+ modified_by VARCHAR(80),
+ modified_time numeric(11) DEFAULT 0 NOT NULL,
+ locked_by VARCHAR(80),
+ locked_time numeric(11) DEFAULT 0 NOT NULL,
+ factoid_value text NOT NULL
+) WITHOUT OIDS;
+
+REVOKE ALL ON TABLE factoids FROM PUBLIC;
+
+CREATE INDEX factoids_idx_fvalue ON factoids USING hash (factoid_value);
+
+ALTER TABLE ONLY factoids
+ ADD CONSTRAINT factoids_pkey_fkey PRIMARY KEY (factoid_key);
--- /dev/null
+CREATE TABLE freshmeat (
+ projectname_short VARCHAR(64) NOT NULL,
+ latest_version VARCHAR(32) DEFAULT 'none'::VARCHAR NOT NULL,
+ license VARCHAR(32),
+ url_homepage VARCHAR(128),
+ desc_short VARCHAR(96) NOT NULL
+) WITHOUT OIDS;
+
+REVOKE ALL ON TABLE freshmeat FROM PUBLIC;
+
+ALTER TABLE ONLY freshmeat
+ ADD CONSTRAINT freshmeat_pkey PRIMARY KEY (projectname_short, latest_version);
--- /dev/null
+CREATE TABLE news (
+ channel VARCHAR(16) NOT NULL,
+ id numeric DEFAULT 0 NOT NULL,
+ "key" VARCHAR(16) NOT NULL,
+ value text NOT NULL
+) WITHOUT OIDS;
+
+REVOKE ALL ON TABLE news FROM PUBLIC;
+
+ALTER TABLE ONLY news
+ ADD CONSTRAINT news_pkey PRIMARY KEY (channel, id, "key");
--- /dev/null
+CREATE TABLE onjoin (
+ nick VARCHAR(20) NOT NULL,
+ channel VARCHAR(16) NOT NULL,
+ message VARCHAR(255) NOT NULL,
+ modified_by VARCHAR(20) DEFAULT 'nobody' NOT NULL,
+ modified_time numeric DEFAULT 0 NOT NULL
+) WITHOUT OIDS;
+
+REVOKE ALL ON TABLE onjoin FROM PUBLIC;
+
+ALTER TABLE ONLY onjoin
+ ADD CONSTRAINT onjoin_pkey PRIMARY KEY (nick, channel);
--- /dev/null
+CREATE TABLE rootwarn (
+ nick VARCHAR(20) NOT NULL,
+ attempt numeric,
+ "time" numeric NOT NULL,
+ host VARCHAR(80) NOT NULL,
+ channel VARCHAR(20) NOT NULL
+) WITHOUT OIDS;
+
+REVOKE ALL ON TABLE rootwarn FROM PUBLIC;
+
+ALTER TABLE ONLY rootwarn
+ ADD CONSTRAINT rootwarn_pkey PRIMARY KEY (nick);
--- /dev/null
+CREATE TABLE seen (
+ nick VARCHAR(20) NOT NULL,
+ "time" numeric NOT NULL,
+ channel VARCHAR(20) NOT NULL,
+ host VARCHAR(80) NOT NULL,
+ message text NOT NULL,
+ hehcount numeric DEFAULT 0 NOT NULL,
+ messagecount numeric DEFAULT 0 NOT NULL
+) WITHOUT OIDS;
+
+REVOKE ALL ON TABLE seen FROM PUBLIC;
+
+ALTER TABLE ONLY seen
+ ADD CONSTRAINT seen_pkey PRIMARY KEY (nick, channel);
--- /dev/null
+CREATE TABLE stats (
+ nick VARCHAR(20) NOT NULL,
+ "type" VARCHAR(8) NOT NULL,
+ channel VARCHAR(16) DEFAULT 'PRIVATE' NOT NULL,
+ "time" numeric DEFAULT 0 NOT NULL,
+ counter numeric DEFAULT 0
+) WITHOUT OIDS;
+
+REVOKE ALL ON TABLE stats FROM PUBLIC;
+
+ALTER TABLE ONLY stats
+ ADD CONSTRAINT stats_pkey PRIMARY KEY (nick, "type", channel);
--- /dev/null
+CREATE TABLE uptime (
+ uptime numeric DEFAULT 0,
+ endtime numeric DEFAULT 0,
+ string VARCHAR(128) NOT NULL
+) WITHOUT OIDS;
+
+REVOKE ALL ON TABLE uptime FROM PUBLIC;
+
+ALTER TABLE ONLY uptime
+ ADD CONSTRAINT uptime_pkey PRIMARY KEY (uptime);
--- /dev/null
+#!/usr/bin/perl
+# setup_tables: setup MYSQL/PGSQL side of things for infobot.
+# written by the xk.
+###
+
+require "src/logger.pl";
+require "src/core.pl";
+require "src/modules.pl";
+require "src/Misc.pl";
+require "src/CLI/Support.pl";
+
+$bot_src_dir = "src/";
+
+# read param stuff from infobot.config.
+&loadConfig("files/infobot.config");
+
+&loadDBModules();
+my $dbname = $param{'DBName'};
+my $query;
+
+if ($dbname eq "") {
+ print "error: appears that the config file was not loaded properly.\n";
+ exit 1;
+}
+
+if ($param{'DBType'} =~ /mysql/i) {
+ use DBI;
+
+ print "Enter root information...\n";
+ # username.
+ print "Username: ";
+ chop (my $adminuser = <STDIN>);
+
+ # passwd.
+ system "stty -echo";
+ print "Password: ";
+ chop(my $adminpass = <STDIN>);
+ print "\n";
+ system "stty echo";
+
+ if ($adminuser eq "" or $adminpass eq "") {
+ &ERROR("error: adminuser || adminpass is NULL.");
+ exit 1;
+ }
+
+ &sqlOpenDB("mysql", "mysql", $adminuser, $adminpass);
+
+ my $database_exists = 0;
+ foreach $database (&sqlRawReturn("SHOW DATABASES")) {
+ $database_exists++ if $database eq $param{DBName};
+ }
+ if ($database_exists) {
+ &status("Database '$param{DBName}' already exists. Continuing...");
+ } else {
+ &status("Creating db ...");
+ &sqlRaw("create(database)", "CREATE DATABASE $param{DBName}");
+ }
+
+ &status("--- Adding user information for user '$param{'SQLUser'}'");
+
+ if (!&sqlSelect("user", "user", { 'user' => &sqlQuote($param{'SQLUser'}) })) {
+ &status("--- Adding user '$param{'SQLUser'}' $dbname/user table...");
+
+ $query = "INSERT INTO user VALUES ".
+ "('localhost', '$param{'SQLUser'}', ".
+ "password('$param{'SQLPass'}'), ";
+
+ $query .= "'Y','Y','Y','Y','Y','Y','N','N','N','N','N','N','N','N')";
+
+ &sqlRaw("create(user)", $query);
+ } else {
+ &status("... user information already present.");
+ }
+
+ if (!&sqlSelect("db", "db", { 'db' => &sqlQuote($param{'SQLUser'}) })) {
+ &status("--- Adding database information for database '$dbname'.");
+
+ $query = "INSERT INTO db VALUES ".
+ "('localhost', '$dbname', ".
+ "'$param{'SQLUser'}', ";
+
+ $query .= "'Y','Y','Y','Y','Y','Y','Y','N','N','N')";
+
+ &sqlRaw("create(db)", $query);
+ } else {
+ &status("... db info already present.");
+ }
+
+ # flush.
+ &status("Flushing privileges...");
+ $query = "FLUSH PRIVILEGES";
+ &sqlRaw("mysql(flush)", $query);
+}
+
+&status("Done.");
+
+&sqlCloseDB();
--- /dev/null
+CREATE TABLE botmail (
+ srcwho VARCHAR(20) NOT NULL,
+ dstwho VARCHAR(20) NOT NULL,
+ srcuh VARCHAR(80) NOT NULL,
+ time INT UNSIGNED DEFAULT 'UNIX_TIMESTAMP()',
+ msg TEXT NOT NULL,
+ PRIMARY KEY (srcwho,dstwho)
+);
--- /dev/null
+CREATE TABLE connections (
+ server VARCHAR(30) NOT NULL,
+ port INT NOT NULL DEFAULT '6667',
+ nick VARCHAR(20) NOT NULL,
+ nickservpass VARCHAR(8) NOT NULL,
+ ircname VARCHAR (20) NOT NULL DEFAULT 'infobot experimental bot',
+ timeadded INT UNSIGNED DEFAULT 'UNIX_TIMESTAMP()',
+ PRIMARY KEY (server,port,nick)
+);
--- /dev/null
+CREATE TABLE factoids (
+ factoid_key VARCHAR(64) NOT NULL,
+ requested_by VARCHAR(64) NOT NULL DEFAULT 'nobody',
+ requested_time INT NOT NULL DEFAULT '0',
+ requested_count SMALLINT UNSIGNED NOT NULL DEFAULT '0',
+ created_by VARCHAR(64),
+ created_time INT NOT NULL DEFAULT '0',
+ modified_by VARCHAR(192),
+ modified_time INT NOT NULL DEFAULT '0',
+ locked_by VARCHAR(64),
+ locked_time INT NOT NULL DEFAULT '0',
+ factoid_value TEXT NOT NULL,
+ PRIMARY KEY (factoid_key)
+);
--- /dev/null
+CREATE TABLE freshmeat (
+ projectname_short VARCHAR(64) NOT NULL,
+ latest_version VARCHAR(32) DEFAULT 'none' NOT NULL,
+ license VARCHAR(32),
+ url_homepage VARCHAR(128),
+ desc_short VARCHAR(96) NOT NULL,
+ PRIMARY KEY (projectname_short,latest_version)
+);
--- /dev/null
+CREATE TABLE news (
+ channel VARCHAR(16) NOT NULL,
+ id INT UNSIGNED DEFAULT '0',
+ key VARCHAR(16) NOT NULL,
+ value TEXT NOT NULL, # limit to ~450 or so.
+ PRIMARY KEY (channel,id,key)
+);
--- /dev/null
+CREATE TABLE onjoin (
+ nick VARCHAR(20) NOT NULL,
+ channel VARCHAR(16) NOT NULL,
+ message VARCHAR(255) NOT NULL,
+ modified_by VARCHAR(20) NOT NULL DEFAULT 'nobody',
+ modified_time INT NOT NULL DEFAULT '0',
+ PRIMARY KEY (nick, channel)
+);
+
+-- v.2 -> v.3
+-- ALTER TABLE onjoin ADD COLUMN modified_by VARCHAR(20) NOT NULL DEFAULT 'nobody';
+-- ALTER TABLE onjoin ADD COLUMN modified_time INT NOT NULL DEFAULT '0';
+-- ** the following doesn't work for sqlite **
+-- ALTER TABLE onjoin ADD PRIMARY KEY (nick, channel);
--- /dev/null
+CREATE TABLE rootwarn (
+ nick VARCHAR(20) NOT NULL,
+ attempt SMALLINT UNSIGNED,
+ time INT NOT NULL,
+ host VARCHAR(80) NOT NULL,
+ channel VARCHAR(20) NOT NULL,
+ PRIMARY KEY (nick)
+);
--- /dev/null
+CREATE TABLE seen (
+ nick VARCHAR(20) NOT NULL,
+ time INT NOT NULL,
+ channel VARCHAR(20) NOT NULL,
+ host VARCHAR(80) NOT NULL,
+ message TINYTEXT NOT NULL,
+ PRIMARY KEY (nick,channel)
+);
--- /dev/null
+CREATE TABLE stats (
+ nick VARCHAR(20) NOT NULL,
+ type VARCHAR(8) NOT NULL,
+ channel VARCHAR(16) NOT NULL DEFAULT "PRIVATE",
+ time INT UNSIGNED DEFAULT 'UNIX_TIMESTAMP()',
+ counter SMALLINT UNSIGNED DEFAULT '0',
+ PRIMARY KEY (nick,type,channel)
+);
--- /dev/null
+CREATE TABLE uptime (
+ uptime INT UNSIGNED DEFAULT '0', # start.
+ endtime INT UNSIGNED DEFAULT '0', # end.
+ string VARCHAR(128) NOT NULL,
+ PRIMARY KEY (uptime)
+);
--- /dev/null
+CREATE TABLE botmail (
+ srcwho VARCHAR(20) NOT NULL,
+ dstwho VARCHAR(20) NOT NULL,
+ srcuh VARCHAR(80) NOT NULL,
+ time INT UNSIGNED DEFAULT 'UNIX_TIMESTAMP()',
+ msg TEXT NOT NULL,
+ PRIMARY KEY (srcwho,dstwho)
+);
--- /dev/null
+CREATE TABLE connections (
+ server VARCHAR(30) NOT NULL,
+ port INT NOT NULL DEFAULT '6667',
+ nick VARCHAR(20) NOT NULL,
+ nickservpass VARCHAR(8) NOT NULL,
+ ircname VARCHAR (20) NOT NULL DEFAULT 'infobot experimental bot',
+ timeadded INT UNSIGNED DEFAULT 'UNIX_TIMESTAMP()',
+ PRIMARY KEY (server,port,nick)
+);
--- /dev/null
+CREATE TABLE factoids (
+ factoid_key VARCHAR(64) NOT NULL,
+ requested_by VARCHAR(64) NOT NULL DEFAULT 'nobody',
+ requested_time INT NOT NULL DEFAULT '0',
+ requested_count SMALLINT UNSIGNED NOT NULL DEFAULT '0',
+ created_by VARCHAR(64),
+ created_time INT NOT NULL DEFAULT '0',
+ modified_by VARCHAR(192),
+ modified_time INT NOT NULL DEFAULT '0',
+ locked_by VARCHAR(64),
+ locked_time INT NOT NULL DEFAULT '0',
+ factoid_value TEXT NOT NULL,
+ PRIMARY KEY (factoid_key)
+);
--- /dev/null
+CREATE TABLE freshmeat (
+ projectname_short VARCHAR(64) NOT NULL,
+ latest_version VARCHAR(32) DEFAULT 'none' NOT NULL,
+ license VARCHAR(32),
+ url_homepage VARCHAR(128),
+ desc_short VARCHAR(96) NOT NULL,
+ PRIMARY KEY (projectname_short,latest_version)
+);
--- /dev/null
+CREATE TABLE news (
+ channel VARCHAR(16) NOT NULL,
+ id INT UNSIGNED DEFAULT '0',
+ key VARCHAR(16) NOT NULL,
+ value TEXT NOT NULL, # limit to ~450 or so.
+ PRIMARY KEY (channel,id,key)
+);
--- /dev/null
+CREATE TABLE onjoin (
+ nick VARCHAR(20) NOT NULL,
+ channel VARCHAR(16) NOT NULL,
+ message VARCHAR(255) NOT NULL,
+ modified_by VARCHAR(20) NOT NULL DEFAULT 'nobody',
+ modified_time INT NOT NULL DEFAULT '0',
+ PRIMARY KEY (nick, channel)
+);
+
+-- v.2 -> v.3
+-- ALTER TABLE onjoin ADD COLUMN modified_by VARCHAR(20) NOT NULL DEFAULT 'nobody';
+-- ALTER TABLE onjoin ADD COLUMN modified_time INT NOT NULL DEFAULT '0';
+-- ** the following doesn't work for sqlite **
+-- ALTER TABLE onjoin ADD PRIMARY KEY (nick, channel);
--- /dev/null
+CREATE TABLE rootwarn (
+ nick VARCHAR(20) NOT NULL,
+ attempt SMALLINT UNSIGNED,
+ time INT NOT NULL,
+ host VARCHAR(80) NOT NULL,
+ channel VARCHAR(20) NOT NULL,
+ PRIMARY KEY (nick)
+);
--- /dev/null
+CREATE TABLE seen (
+ nick VARCHAR(20) NOT NULL,
+ time INT NOT NULL,
+ channel VARCHAR(20) NOT NULL,
+ host VARCHAR(80) NOT NULL,
+ message TINYTEXT NOT NULL,
+ PRIMARY KEY (nick,channel)
+);
--- /dev/null
+CREATE TABLE stats (
+ nick VARCHAR(20) NOT NULL,
+ type VARCHAR(8) NOT NULL,
+ channel VARCHAR(16) NOT NULL DEFAULT "PRIVATE",
+ time INT UNSIGNED DEFAULT 'UNIX_TIMESTAMP()',
+ counter SMALLINT UNSIGNED DEFAULT '0',
+ PRIMARY KEY (nick,type,channel)
+);
--- /dev/null
+CREATE TABLE uptime (
+ uptime INT UNSIGNED DEFAULT '0', # start.
+ endtime INT UNSIGNED DEFAULT '0', # end.
+ string VARCHAR(128) NOT NULL,
+ PRIMARY KEY (uptime)
+);
--- /dev/null
+#
+# CLI/Support.pl: Stubs for functions that are from IRC/*
+# Author: Tim Riker <Tim@Rikers.org>
+# Version: v0.1 (20021028)
+# Created: 20021028
+#
+use strict;
+
+my $postprocess;
+
+use vars qw($uh $message);
+
+sub cliloop {
+ &status("Using CLI...");
+ &status("Now type what you want.");
+
+ $nuh = "local!local\@local";
+ $uh = "local\@local";
+ $who = 'local';
+ $orig{who} = 'local';
+ $ident = $param{'ircUser'};
+ $chan = $talkchannel = "_local";
+ $addressed = 1;
+ $msgType = 'private';
+ $host = 'local';
+
+ # install libterm-readline-gnu-perl to get history support
+ use Term::ReadLine;
+ my $term = new Term::ReadLine 'infobot';
+ my $prompt = "$who> ";
+ #$OUT = $term->OUT || STDOUT;
+ while ( defined ($_ = $term->readline($prompt)) ) {
+ $orig{message} = $_;
+ $message = $_;
+ chomp $message;
+ last if ($message =~ m/^quit$/);
+ $_ = &process() if $message;
+ }
+ &doExit();
+}
+
+sub msg {
+ my ($nick, $msg) = @_;
+ if (!defined $nick) {
+ &ERROR("msg: nick == NULL.");
+ return;
+ }
+
+ if (!defined $msg) {
+ $msg ||= 'NULL';
+ &WARN("msg: msg == $msg.");
+ return;
+ }
+
+ if ( $postprocess ) {
+ undef $postprocess;
+ } elsif ($postprocess = &getChanConf('postprocess', $talkchannel)) {
+ &DEBUG("say: $postprocess $msg");
+ &parseCmdHook($postprocess . ' ' . $msg);
+ undef $postprocess;
+ return;
+ }
+
+ &status(">$nick< $msg");
+
+ print("$nick: $msg\n");
+}
+
+# Usage: &action(nick || chan, txt);
+sub action {
+ my ($target, $txt) = @_;
+ if (!defined $txt) {
+ &WARN("action: txt == NULL.");
+ return;
+ }
+
+ if (length $txt > 480) {
+ &status("action: txt too long; truncating.");
+ chop($txt) while (length $txt > 480);
+ }
+
+ &status("* $ident/$target $txt");
+}
+
+sub IsNickInChan {
+ my ($nick,$chan) = @_;
+ return 1;
+}
+
+sub performStrictReply {
+ &msg($who, @_);
+}
+
+sub performReply {
+ &msg($who, @_);
+}
+
+sub performAddressedReply {
+ return unless ($addressed);
+ &msg($who, @_);
+}
+
+1;
--- /dev/null
+#
+# User Command Extension Stubs
+# WARN: this file does not reload on HUP.
+#
+
+#use strict; # TODO: sub { \&{ $hash{'CODEREF'} }($flatarg) };
+
+use vars qw($who $msgType $conn $chan $message $ident $talkchannel
+ $bot_version $bot_data_dir);
+use vars qw(@vernick @vernicktodo);
+use vars qw(%channels %cache %mask %userstats %myModules %cmdstats
+ %cmdhooks %lang %ver);
+# TODO: FIX THE FOLLOWING:
+use vars qw($total $x $type $i $good %wingateToDo);
+
+### COMMAND HOOK IMPLEMENTATION.
+# addCmdHook('TEXT_HOOK',
+# (CODEREF => 'Blah',
+# Forker => 1,
+# Module => 'blah.pl' # preload module.
+# Identifier => 'config_label', # change to Config?
+# Help => 'help_label',
+# Cmdstats => 'text_label',)
+#}
+###
+
+sub addCmdHook {
+ my ($ident, %hash) = @_;
+
+ if (exists $cmdhooks{$ident}) {
+ &WARN("aCH: \$cmdhooks{$ident} already exists.");
+ return;
+ }
+
+ &VERB("aCH: added $ident",2); # use $hash{'Identifier'}?
+ ### hrm... prevent warnings?
+ $cmdhooks{$ident} = \%hash;
+}
+
+# RUN IF ADDRESSED.
+sub parseCmdHook {
+ my ($line) = @_;
+ $line =~ s/^\s+|\s+$//g; # again.
+ $line =~ /^(\S+)(\s+(.*))?$/;
+ my $cmd = $1; # command name is whitespaceless.
+ my $flatarg = $3;
+ my @args = split(/\s+/, $flatarg || '');
+ my $done = 0;
+
+ &shmFlush();
+
+ if (!defined %cmdhooks) {
+ &WARN('%cmdhooks does not exist.');
+ return 0;
+ }
+
+ if (!defined $cmd) {
+ &WARN('cstubs: cmd == NULL.');
+ return 0;
+ }
+
+ foreach (keys %cmdhooks) {
+ # rename to something else! like $id or $label?
+ my $ident = $_;
+
+ next unless ($cmd =~ /^$ident$/i);
+
+ if ($done) {
+ &WARN("pCH: Multiple hook match: $ident");
+ next;
+ }
+
+ &status("cmdhooks: $cmd matched '$ident' '$flatarg'");
+ my %hash = %{ $cmdhooks{$ident} };
+
+ if (!scalar keys %hash) {
+ &WARN('CmdHook: hash is NULL?');
+ return 1;
+ }
+
+ if ($hash{NoArgs} and $flatarg) {
+ &DEBUG("cmd $ident does not take args ('$flatarg'); skipping.");
+ next;
+ }
+
+ if (!exists $hash{CODEREF}) {
+ &ERROR("CODEREF undefined for $cmd or $ident.");
+ return 1;
+ }
+
+ ### DEBUG.
+ foreach (keys %hash) {
+ &VERB(" $cmd->$_ => '$hash{$_}'.",2);
+ }
+
+ ### HELP.
+ if (exists $hash{'Help'} and !scalar(@args)) {
+ &help( $hash{'Help'} );
+ return 1;
+ }
+
+ ### IDENTIFIER.
+ if (exists $hash{'Identifier'}) {
+ return 1 unless (&IsChanConfOrWarn($hash{'Identifier'}));
+ }
+
+ ### USER FLAGS.
+ if (exists $hash{'UserFlag'}) {
+ return 1 unless (&hasFlag($hash{'UserFlag'}));
+ }
+
+ ### FORKER,IDENTIFIER,CODEREF.
+ if (($$ == $bot_pid) && exists $hash{'Forker'}) {
+ if (exists $hash{'ArrayArgs'}) {
+ &Forker($hash{'Identifier'}, sub { \&{ $hash{'CODEREF'} }(@args) } );
+ } else {
+ &Forker($hash{'Identifier'}, sub { \&{ $hash{'CODEREF'} }($flatarg) } );
+ }
+
+ } else {
+ if (exists $hash{'Module'}) {
+ &loadMyModule($hash{'Module'});
+ }
+
+ # check if CODEREF exists.
+ if (!defined &{ $hash{'CODEREF'} }) {
+ &WARN("coderef $hash{'CODEREF'} does not exist.");
+ if (defined $who) {
+ &msg($who, "coderef does not exist for $ident.");
+ }
+
+ return 1;
+ }
+
+ if (exists $hash{'ArrayArgs'}) {
+ &{ $hash{'CODEREF'} }(@args);
+ } else {
+ &{ $hash{'CODEREF'} }($flatarg);
+ }
+ }
+
+ ### CMDSTATS.
+ if (exists $hash{'Cmdstats'}) {
+ $cmdstats{ $hash{'Cmdstats'} }++;
+ }
+
+ &VERB('hooks: End of command.',2);
+
+ $done = 1;
+ }
+
+ return 1 if ($done);
+ return 0;
+}
+
+sub Modules {
+ if (!defined $message) {
+ &WARN('Modules: message is undefined. should never happen.');
+ return;
+ }
+
+ my $debiancmd = 'conflicts?|depends?|desc|file|(?:d)?info|provides?';
+ $debiancmd .= '|recommends?|suggests?|maint|maintainer';
+
+ if ($message =~ /^($debiancmd)(\s+(.*))?$/i) {
+ return unless (&IsChanConfOrWarn('Debian'));
+ my $package = lc $3;
+
+ if (defined $package) {
+ &Forker('Debian', sub { &Debian::infoPackages($1, $package); } );
+ } else {
+ &help($1);
+ }
+
+ return;
+ }
+
+ # google searching. Simon++
+ my $w3search_regex = 'google';
+ if ($message =~ /^(?:search\s+)?($w3search_regex)\s+(?:for\s+)?['"]?(.*?)["']?\s*\?*$/i) {
+ return unless (&IsChanConfOrWarn('W3Search'));
+
+ &Forker('W3Search', sub { &W3Search::W3Search($1,$2); } );
+
+ $cmdstats{'W3Search'}++;
+ return;
+ }
+
+ # text counters. (eg: hehstats)
+ my $itc;
+ $itc = &getChanConf('ircTextCounters');
+ $itc = &findChanConf('ircTextCounters') unless ($itc);
+ return if ($itc && &do_text_counters($itc) == 1);
+ # end of text counters.
+
+ # list{keys|values}. xk++. Idea taken from #linuxwarez@EFNET
+ if ($message =~ /^list(\S+)(\s+(.*))?$/i) {
+ return unless (&IsChanConfOrWarn('Search'));
+
+ my $thiscmd = lc $1;
+ my $args = $3 || '';
+
+ $thiscmd =~ s/^vals$/values/;
+ return if ($thiscmd ne 'keys' && $thiscmd ne 'values');
+
+ # Usage:
+ if (!defined $args or $args =~ /^\s*$/) {
+ &help('list'. $thiscmd);
+ return;
+ }
+
+ # suggested by asuffield and \broken.
+ if ($args =~ /^["']/ and $args =~ /["']$/) {
+ &DEBUG('list*: removed quotes.');
+ $args =~ s/^["']|["']$//g;
+ }
+
+ if (length $args < 2 && &IsFlag('o') ne 'o') {
+ &msg($who, 'search string is too short.');
+ return;
+ }
+
+ &Forker('Search', sub { &Search::Search($thiscmd, $args); } );
+
+ $cmdstats{'Factoid Search'}++;
+ return;
+ }
+
+ # Topic management. xk++
+ # may want to add a userflags for topic. -xk
+ if ($message =~ /^topic(\s+(.*))?$/i) {
+ return unless (&IsChanConfOrWarn('Topic'));
+
+ my $chan = $talkchannel;
+ my @args = split / /, $2 || '';
+
+ if (!scalar @args) {
+ &msg($who,"Try 'help topic'");
+ return;
+ }
+
+ $chan = lc(shift @args) if ($msgType eq 'private');
+ my $thiscmd = shift @args;
+
+ # topic over public:
+ if ($msgType eq 'public' && $thiscmd =~ /^#/) {
+ &msg($who, 'error: channel argument is not required.');
+ &msg($who, "\002Usage\002: topic <CMD>");
+ return;
+ }
+
+ # topic over private:
+ if ($msgType eq 'private' && $chan !~ /^#/) {
+ &msg($who, 'error: channel argument is required.');
+ &msg($who, "\002Usage\002: topic #channel <CMD>");
+ return;
+ }
+
+ if (&validChan($chan) == 0) {
+ &msg($who,"error: invalid channel \002$chan\002");
+ return;
+ }
+
+ # for semi-outsiders.
+ if (!&IsNickInChan($who,$chan)) {
+ &msg($who, "Failed. You ($who) are not in $chan, hey?");
+ return;
+ }
+
+ # now lets do it.
+ &loadMyModule('Topic');
+ &Topic($chan, $thiscmd, join(' ', @args));
+ $cmdstats{'Topic'}++;
+ return;
+ }
+
+ # wingate.
+ if ($message =~ /^wingate$/i) {
+ return unless (&IsChanConfOrWarn('Wingate'));
+
+ my $reply = "Wingate statistics: scanned \002"
+ .scalar(keys %wingateToDo)."\002 hosts";
+ my $queue = scalar(keys %wingateToDo);
+ if ($queue) {
+ $reply .= ". I have \002$queue\002 hosts in the queue";
+ $reply .= '. Started the scan '.&Time2String(time() - $wingaterun).' ago';
+ }
+
+ &performStrictReply("$reply.");
+
+ return;
+ }
+
+ # do nothing and let the other routines have a go
+ return 'CONTINUE';
+}
+
+# Uptime. xk++
+sub uptime {
+ my $count = 1;
+ &msg($who, "- Uptime for $ident -");
+ &msg($who, "Now: ". &Time2String(&uptimeNow()) ." running $bot_version");
+
+ foreach (&uptimeGetInfo()) {
+ /^(\d+)\.\d+ (.*)/;
+ my $time = &Time2String($1);
+ my $info = $2;
+
+ &msg($who, "$count: $time $2");
+ $count++;
+ }
+}
+
+# seen.
+sub seen {
+ my($person) = lc shift;
+ $person =~ s/\?*$//;
+
+ if (!defined $person or $person =~ /^$/) {
+ &help('seen');
+
+ my $i = &countKeys('seen');
+ &msg($who,'there '. &fixPlural('is',$i) ." \002$i\002 ".
+ 'seen '. &fixPlural('entry',$i) .' that I know of.');
+
+ return;
+ }
+
+ my @seen;
+
+ &seenFlush(); # very evil hack. oh well, better safe than sorry.
+
+ # TODO: convert to &sqlSelectRowHash();
+ my $select = 'nick,time,channel,host,message';
+ if ($person eq 'random') {
+ @seen = &randKey('seen', $select);
+ } else {
+ @seen = &sqlSelect('seen', $select, { nick => $person } );
+ }
+
+ if (scalar @seen < 2) {
+ foreach (@seen) {
+ &DEBUG("seen: _ => '$_'.");
+ }
+ &performReply("i haven't seen '$person'");
+ return;
+ }
+
+ # valid seen.
+ my $reply;
+ ### TODO: multi channel support. may require &IsNick() to return
+ ### all channels or something.
+
+ my @chans = &getNickInChans($seen[0]);
+ if (scalar @chans) {
+ $reply = "$seen[0] is currently on";
+
+ foreach (@chans) {
+ $reply .= ' '.$_;
+ next unless (exists $userstats{lc $seen[0]}{'Join'});
+ $reply .= ' ('.&Time2String(time() - $userstats{lc $seen[0]}{'Join'}).')';
+ }
+
+ if (&IsChanConf('seenStats') > 0) {
+ my $i;
+ $i = $userstats{lc $seen[0]}{'Count'};
+ $reply .= ". Has said a total of \002$i\002 messages" if (defined $i);
+ $i = $userstats{lc $seen[0]}{'Time'};
+ $reply .= '. Is idling for '.&Time2String(time() - $i) if (defined $i);
+ }
+ $reply .= ", last said\002:\002 '$seen[4]'.";
+ } else {
+ my $howlong = &Time2String(time() - $seen[1]);
+ $reply = "$seen[0] <$seen[3]> was last seen on IRC ".
+ "in channel $seen[2], $howlong ago, ".
+ "saying\002:\002 '$seen[4]'.";
+ }
+
+ &performStrictReply($reply);
+ return;
+}
+
+# User Information Services. requested by Flugh.
+sub userinfo {
+ my ($arg) = join(' ',@_);
+
+ if ($arg =~ /^set(\s+(.*))?$/i) {
+ $arg = $2;
+ if (!defined $arg) {
+ &help('userinfo set');
+ return;
+ }
+
+ &UserInfoSet(split /\s+/, $arg, 2);
+ } elsif ($arg =~ /^unset(\s+(.*))?$/i) {
+ $arg = $2;
+ if (!defined $arg) {
+ &help('userinfo unset');
+ return;
+ }
+
+ &UserInfoSet($arg, '');
+ } else {
+ &UserInfoGet($arg);
+ }
+}
+
+# cookie (random). xk++
+sub cookie {
+ my ($arg) = @_;
+
+ # lets find that secret cookie.
+ my $target = ($msgType ne 'public') ? $who : $talkchannel;
+ my $cookiemsg = &getRandom(keys %{ $lang{'cookie'} });
+ my ($key,$value);
+
+ ### WILL CHEW TONS OF MEM.
+ ### TODO: convert this to a Forker function!
+ if ($arg) {
+ my @list = &searchTable('factoids', 'factoid_key', 'factoid_value', $arg);
+ $key = &getRandom(@list);
+ $value = &getFactInfo($key, 'factoid_value');
+ } else {
+ ($key,$value) = &randKey('factoids','factoid_key,factoid_value');
+ }
+
+ for ($cookiemsg) {
+ s/##KEY/\002$key\002/;
+ s/##VALUE/$value/;
+ s/##WHO/$who/;
+ s/\$who/$who/; # cheap fix.
+ s/(\S+)?\s*<\S+>/$1 /;
+ s/\s+/ /g;
+ }
+
+ if ($cookiemsg =~ s/^ACTION //i) {
+ &action($target, $cookiemsg);
+ } else {
+ &msg($target, $cookiemsg);
+ }
+}
+
+sub convert {
+ my $arg = join(' ',@_);
+ my ($from,$to) = ('','');
+
+ ($from,$to) = ($1,$2) if ($arg =~ /^(.*?) to (.*)$/i);
+ ($from,$to) = ($2,$1) if ($arg =~ /^(.*?) from (.*)$/i);
+
+ if (!$to or !$from) {
+ &msg($who, 'Invalid format!');
+ &help('convert');
+ return;
+ }
+
+ &Units::convertUnits($from, $to);
+
+ return;
+}
+
+sub lart {
+ my ($target) = &fixString($_[0]);
+ my $extra = 0;
+ my $chan = $talkchannel;
+ my ($for);
+ my $mynick = $conn->nick();
+
+ if ($msgType eq 'private') {
+ if ($target =~ /^($mask{chan})\s+(.*)$/) {
+ $chan = $1;
+ $target = $2;
+ $extra = 1;
+ } else {
+ &msg($who, 'error: invalid format or missing arguments.');
+ &help('lart');
+ return;
+ }
+ }
+ if ($target =~ /^(.*)(\s+for\s+.*)$/) {
+ $target = $1;
+ $for = $2;
+ }
+
+ my $line = &getRandomLineFromFile($bot_data_dir. '/infobot.lart');
+ if (defined $line) {
+ if ($target =~ /^(me|you|itself|\Q$mynick\E)$/i) {
+ $line =~ s/WHO/$who/g;
+ } else {
+ $line =~ s/WHO/$target/g;
+ }
+ $line .= $for if ($for);
+ $line .= ", courtesy of $who" if ($extra);
+
+ &action($chan, $line);
+ } else {
+ &status('lart: error reading file?');
+ }
+}
+
+sub DebianNew {
+ my $idx = 'debian/Packages-sid.idx';
+ my $error = 0;
+ my %pkg;
+ my @new;
+
+ $error++ unless ( -e $idx);
+ $error++ unless ( -e "$idx-old");
+
+ if ($error) {
+ $error = 'no sid/sid-old index file found.';
+ &ERROR("Debian: $error");
+ &msg($who, $error);
+ return;
+ }
+
+ open(IDX1, $idx);
+ open(IDX2, "$idx-old");
+
+ while (<IDX2>) {
+ chop;
+ next if (/^\*/);
+
+ $pkg{$_} = 1;
+ }
+ close IDX2;
+
+ open(IDX1,$idx);
+ while (<IDX1>) {
+ chop;
+ next if (/^\*/);
+ next if (exists $pkg{$_});
+
+ push(@new, $_);
+ }
+ close IDX1;
+
+ &::performStrictReply( &::formListReply(0, 'New debian packages:', @new) );
+}
+
+sub do_verstats {
+ my ($chan) = @_;
+
+ if (!defined $chan) {
+ &help('verstats');
+ return;
+ }
+
+ if (!&validChan($chan)) {
+ &msg($who, "chan $chan is invalid.");
+ return;
+ }
+
+ if (scalar @vernick > scalar(keys %{ $channels{lc $chan}{''} })/4) {
+ &msg($who, 'verstats already in progress for someone else.');
+ return;
+ }
+
+ &msg($who, "Sending CTCP VERSION to $chan; results in 60s.");
+ $conn->ctcp('VERSION', $chan);
+ $cache{verstats}{chan} = $chan;
+ $cache{verstats}{who} = $who;
+ $cache{verstats}{msgType} = $msgType;
+
+ $conn->schedule(30, sub {
+ my $c = lc $cache{verstats}{chan};
+ @vernicktodo = ();
+
+ foreach (keys %{ $channels{$c}{''} } ) {
+ next if (grep /^\Q$_\E$/i, @vernick);
+ push(@vernicktodo, $_);
+ }
+
+ &verstats_flush();
+ } );
+
+ $conn->schedule(60, sub {
+ my $vtotal = 0;
+ my $c = lc $cache{verstats}{chan};
+ my $total = keys %{ $channels{$c}{''} };
+ $chan = $c;
+ $who = $cache{verstats}{who};
+ $msgType = $cache{verstats}{msgType};
+ delete $cache{verstats}; # sufficient?
+
+ foreach (keys %ver) {
+ $vtotal += scalar keys %{ $ver{$_} };
+ }
+
+ my %sorted;
+ my $unknown = $total - $vtotal;
+ my $perc = sprintf("%.1f", $unknown * 100 / $total);
+ $perc =~ s/.0$//;
+ $sorted{$perc}{'unknown/cloak'} = "$unknown ($perc%)" if ($unknown);
+
+ foreach (keys %ver) {
+ my $count = scalar keys %{ $ver{$_} };
+ $perc = sprintf("%.01f", $count * 100 / $total);
+ $perc =~ s/.0$//; # lame compression.
+
+ $sorted{$perc}{$_} = "$count ($perc%)";
+ }
+
+ ### can be compressed to a map?
+ my @list;
+ foreach ( sort { $b <=> $a } keys %sorted ) {
+ my $perc = $_;
+ foreach (sort keys %{ $sorted{$perc} }) {
+ push(@list, "$_ - $sorted{$perc}{$_}");
+ }
+ }
+
+ # hack. this is one major downside to scheduling.
+ $chan = $c;
+ &performStrictReply( &formListReply(0, "IRC Client versions for $c ", @list) );
+
+ # clean up not-needed data structures.
+ undef %ver;
+ undef @vernick;
+ } );
+
+ return;
+}
+
+sub verstats_flush {
+ for (1..5) {
+ last unless (scalar @vernicktodo);
+
+ my $n = shift(@vernicktodo);
+ $conn->ctcp('VERSION', $n);
+ }
+
+ return unless (scalar @vernicktodo);
+
+ $conn->schedule(3, \&verstats_flush() );
+}
+
+sub do_text_counters {
+ my ($itc) = @_;
+ $itc =~ s/([^\w\s])/\\$1/g;
+ my $z = join '|', split ' ', $itc;
+
+ if ($msgType eq 'privmsg' and $message =~ / ($mask{chan})$/) {
+ &DEBUG("ircTC: privmsg detected; chan = $1");
+ $chan = $1;
+ }
+
+ if ($message =~ /^_stats(\s+(\S+))$/i) {
+ &textstats_main($2);
+ return 1;
+ }
+
+ my ($type,$arg);
+ if ($message =~ /^($z)stats(\s+(\S+))?$/i) {
+ $type = $1;
+ $arg = $3;
+ } else {
+ return 0;
+ }
+
+ # even more uglier with channel/time arguments.
+ my $c = $chan;
+# my $c = $chan || 'PRIVATE';
+ my $where = 'type='.&sqlQuote($type);
+ if (defined $c) {
+ &DEBUG("c => $c");
+ $where .= ' AND channel='.&sqlQuote($c) if (defined $c);
+ } else {
+ &DEBUG('not using chan arg');
+ }
+
+ my $sum = (&sqlRawReturn('SELECT SUM(counter) FROM stats'
+ .' WHERE '.$where ))[0];
+
+ if (!defined $arg or $arg =~ /^\s*$/) {
+ # this is way ugly.
+
+ # TODO: convert $where to hash
+ my %hash = &sqlSelectColHash('stats', 'nick,counter',
+ { },
+ $where.' ORDER BY counter DESC LIMIT 3', 1
+ );
+ my $i;
+ my @top;
+
+ # unfortunately we have to sort it again!
+ 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 = '';
+ if (scalar @top) {
+ $topstr = '. Top '.scalar(@top).': '.join(', ', @top);
+ }
+
+ if (defined $sum) {
+ &performStrictReply("total count of \037$type\037 on \002$c\002: $sum$topstr");
+ } else {
+ &performStrictReply("zero counter for \037$type\037.");
+ }
+ } else {
+ # TODO: convert $where to hash and use a sqlSelect
+ my $x = (&sqlRawReturn('SELECT SUM(counter) FROM stats'.
+ " WHERE $where AND nick=".&sqlQuote($arg) ))[0];
+
+ if (!defined $x) { # !defined.
+ &performStrictReply("$arg has not said $type yet.");
+ return 1;
+ }
+
+ # defined.
+ # TODO: convert $where to hash
+ my @array = &sqlSelect('stats', 'nick', undef,
+ $where.' ORDER BY counter', 1
+ );
+ my $good = 0;
+ my $i = 0;
+ for ($i=0; $i<scalar @array; $i++) {
+ next unless ($array[0] =~ /^\Q$who\E$/);
+ $good++;
+ last;
+ }
+ $i++;
+
+ my $total = scalar(@array);
+ 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);
+ &performStrictReply("\002$arg\002 has said \037$type\037 \002$x\002 times (\002$pct1\002 %)$xtra");
+ }
+
+ return 1;
+}
+
+sub textstats_main {
+ my($arg) = @_;
+
+ # even more uglier with channel/time arguments.
+ my $c = $chan;
+# my $c = $chan || 'PRIVATE';
+ &DEBUG('not using chan arg') if (!defined $c);
+
+ # example of converting from RawReturn to sqlSelect.
+ my $where_href = (defined $c) ? { channel => $c } : '';
+ my $sum = &sqlSelect('stats', 'SUM(counter)', $where_href);
+
+ if (!defined $arg or $arg =~ /^\s*$/) {
+ # this is way ugly.
+ &DEBUG('_stats: !arg');
+
+ my %hash = &sqlSelectColHash('stats', 'nick,counter',
+ $where_href,
+ ' ORDER BY counter DESC LIMIT 3', 1
+ );
+ my $i;
+ my @top;
+
+ # unfortunately we have to sort it again!
+ 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 = '';
+ if (scalar @top) {
+ $topstr = '. Top '.scalar(@top).': '.join(', ', @top);
+ }
+
+ if (defined $sum) {
+ &performStrictReply("total count of \037$type\037 on \002$c\002: $sum$topstr");
+ } else {
+ &performStrictReply("zero counter for \037$type\037.");
+ }
+
+ return;
+ }
+
+ # TODO: add nick to where_href
+ my %hash = &sqlSelectColHash('stats', 'type,counter',
+ $where_href, ' AND nick='.&sqlQuote($arg)
+ );
+
+ # this is totally messed up... needs to be fixed... and cleaned up.
+ my $total;
+ my $good;
+ my $ii;
+ my $x;
+
+ foreach (keys %hash) {
+ &DEBUG("_stats: hash{$_} => $hash{$_}");
+ # ranking.
+ # TODO: convert $where to hash
+ my $where = '';
+ my @array = &sqlSelect('stats', 'nick', undef, $where.' ORDER BY counter', 1);
+ $good = 0;
+ $ii = 0;
+ for(my $i=0; $i<scalar @array; $i++) {
+ next unless ($array[0] =~ /^\Q$who\E$/);
+ $good++;
+ last;
+ }
+ $ii++;
+
+ $total = scalar(@array);
+ &DEBUG(" i => $i, good => $good, total => $total");
+ $x .= ' '.$total.'blah blah';
+ }
+
+# return;
+
+ if (!defined $x) { # !defined.
+ &performStrictReply("$arg has not said $type yet.");
+ return;
+ }
+
+ my $xtra = '';
+ if ($total and $good) {
+ my $pct = sprintf("%.01f", 100*(1+$total-$ii)/$total);
+ $xtra = ", ranked $ii\002/\002$total (percentile: \002$pct\002 %)";
+ }
+
+ my $pct1 = sprintf("%.01f", 100*$x/$sum);
+ &performStrictReply("\002$arg\002 has said \037$type\037 \002$x\002 times (\002$pct1\002 %)$xtra");
+}
+
+sub nullski {
+ my ($arg) = @_;
+ return unless (defined $arg);
+ # big security hole
+ #foreach (`$arg`) { &msg($who,$_); }
+}
+
+%cmdhooks=();
+###
+### START ADDING HOOKS.
+###
+&addCmdHook('(babel(fish)?|x|xlate|translate)', ('CODEREF' => 'babelfish::babelfish', 'Identifier' => 'babelfish', 'Cmdstats' => 'babelfish', 'Forker' => 1, 'Help' => 'babelfish', 'Module' => 'babelfish') );
+&addCmdHook('(botmail|message)', ('CODEREF' => 'botmail::parse', 'Identifier' => 'botmail', 'Cmdstats' => 'botmail') );
+&addCmdHook('bzflist17', ('CODEREF' => 'BZFlag::list17', 'Identifier' => 'BZFlag', 'Cmdstats' => 'BZFlag', 'Forker' => 1, 'Module' => 'BZFlag') );
+&addCmdHook('bzflist', ('CODEREF' => 'BZFlag::list', 'Identifier' => 'BZFlag', 'Cmdstats' => 'BZFlag', 'Forker' => 1, 'Module' => 'BZFlag') );
+&addCmdHook('bzfquery', ('CODEREF' => 'BZFlag::query', 'Identifier' => 'BZFlag', 'Cmdstats' => 'BZFlag', 'Forker' => 1, 'Module' => 'BZFlag') );
+&addCmdHook('chan(stats|info)', ('CODEREF' => 'chaninfo', ) );
+&addCmdHook('cmd(stats|info)', ('CODEREF' => 'cmdstats', ) );
+&addCmdHook('convert', ('CODEREF' => 'convert', 'Forker' => 1, 'Identifier' => 'Units', 'Help' => 'convert') );
+&addCmdHook('(cookie|random)', ('CODEREF' => 'cookie', 'Forker' => 1, 'Identifier' => 'Factoids') );
+&addCmdHook('countdown', ('CODEREF' => 'countdown', 'Module' => 'countdown', 'Identifier' => 'countdown', 'Cmdstats' => 'countdown') );
+&addCmdHook('countrystats', ('CODEREF' => 'countryStats') );
+&addCmdHook('dauthor', ('CODEREF' => 'Debian::searchAuthor', 'Forker' => 1, 'Identifier' => 'Debian', 'Cmdstats' => 'Debian Author Search', 'Help' => 'dauthor' ) );
+&addCmdHook('d?bugs', ('CODEREF' => 'DebianExtra::Parse', 'Forker' => 1, 'Identifier' => 'DebianExtra', 'Cmdstats' => 'Debian Bugs') );
+&addCmdHook('d?contents', ('CODEREF' => 'Debian::searchContents', 'Forker' => 1, 'Identifier' => 'Debian', 'Cmdstats' => 'Debian Contents Search', 'Help' => 'contents' ) );
+&addCmdHook('d?find', ('CODEREF' => 'Debian::DebianFind', 'Forker' => 1, 'Identifier' => 'Debian', 'Cmdstats' => 'Debian Search', 'Help' => 'find' ) );
+&addCmdHook('dice', ('CODEREF' => 'dice::dice', 'Identifier' => 'dice', 'Cmdstats' => 'dice', 'Forker' => 1, 'Module' => 'dice') );
+&addCmdHook('Dict', ('CODEREF' => 'Dict::Dict', 'Identifier' => 'Dict', 'Help' => 'dict', 'Forker' => 1, 'Cmdstats' => 'Dict') );
+&addCmdHook('dincoming', ('CODEREF' => 'Debian::generateIncoming', 'Forker' => 1, 'Identifier' => 'Debian' ) );
+&addCmdHook('dnew', ('CODEREF' => 'DebianNew', 'Identifier' => 'Debian' ) );
+&addCmdHook('dns|d?nslookup', ('CODEREF' => 'dns::query', 'Identifier' => 'dns', 'Cmdstats' => 'dns', 'Forker' => 1, 'Help' => 'dns') );
+&addCmdHook('(d|search)desc', ('CODEREF' => 'Debian::searchDescFE', 'Forker' => 1, 'Identifier' => 'Debian', 'Cmdstats' => 'Debian Desc Search', 'Help' => 'ddesc' ) );
+&addCmdHook('dstats', ('CODEREF' => 'Debian::infoStats', 'Forker' => 1, 'Identifier' => 'Debian', 'Cmdstats' => 'Debian Statistics' ) );
+&addCmdHook('(ex)?change', ('CODEREF' => 'Exchange::query', 'Identifier' => 'Exchange', 'Cmdstats' => 'Exchange', 'Forker' => 1) );
+&addCmdHook('factinfo', ('CODEREF' => 'factinfo', 'Cmdstats' => 'Factoid Info', Module => 'Factoids', ) );
+&addCmdHook('factstats?', ('CODEREF' => 'factstats', 'Cmdstats' => 'Factoid Stats', Help => 'factstats', Forker => 1, 'Identifier' => 'Factoids', ) );
+&addCmdHook('help', ('CODEREF' => 'help', 'Cmdstats' => 'Help', ) );
+&addCmdHook('HTTPDtype', ('CODEREF' => 'HTTPDtype::HTTPDtype', 'Identifier' => 'HTTPDtype', 'Cmdstats' => 'HTTPDtype', 'Forker' => 1) );
+&addCmdHook('[ia]?spell', ('CODEREF' => 'spell::query', 'Identifier' => 'spell', 'Cmdstats' => 'spell', 'Forker' => 1, 'Help' => 'spell') );
+&addCmdHook('insult', ('CODEREF' => 'Insult::Insult', 'Forker' => 1, 'Identifier' => 'insult', 'Help' => 'insult' ) );
+&addCmdHook('karma', ('CODEREF' => 'karma', ) );
+&addCmdHook('kernel', ('CODEREF' => 'Kernel::Kernel', 'Forker' => 1, 'Identifier' => 'Kernel', 'Cmdstats' => 'Kernel', 'NoArgs' => 1) );
+&addCmdHook('lart', ('CODEREF' => 'lart', 'Identifier' => 'lart', 'Help' => 'lart') );
+&addCmdHook('lc', ('CODEREF' => 'case::lower', 'Identifier' => 'case', 'Cmdstats' => 'case', 'Forker' => 1, 'Module' => 'case') );
+&addCmdHook('listauth', ('CODEREF' => 'CmdListAuth', 'Identifier' => 'Search', Module => 'Factoids', 'Help' => 'listauth') );
+&addCmdHook('md5(sum)?', ('CODEREF' => 'md5::md5', 'Identifier' => 'md5', 'Cmdstats' => 'md5', 'Forker' => 1, 'Module' => 'md5') );
+&addCmdHook('metar', ('CODEREF' => 'Weather::Metar', 'Identifier' => 'Weather', 'Help' => 'weather', 'Cmdstats' => 'Weather', 'Forker' => 1) );
+&addCmdHook('News', ('CODEREF' => 'News::Parse', Module => 'News', 'Cmdstats' => 'News' ) );
+&addCmdHook('(?:nick|lame)ometer(?: for)?', ('CODEREF' => 'nickometer::query', 'Identifier' => 'nickometer', 'Cmdstats' => 'nickometer', 'Forker' => 1) );
+&addCmdHook('nullski', ('CODEREF' => 'nullski', ) );
+&addCmdHook('page', ('CODEREF' => 'pager::page', 'Identifier' => 'pager', 'Cmdstats' => 'pager', 'Forker' => 1, 'Help' => 'page') );
+&addCmdHook('piglatin', ('CODEREF' => 'piglatin::piglatin', 'Identifier' => 'piglatin', 'Cmdstats' => 'piglatin', 'Forker' => 1) );
+&addCmdHook('Plug', ('CODEREF' => 'Plug::Plug', 'Identifier' => 'Plug', 'Forker' => 1, 'Cmdstats' => 'Plug') );
+&addCmdHook('quote', ('CODEREF' => 'Quote::Quote', 'Forker' => 1, 'Identifier' => 'Quote', 'Help' => 'quote', 'Cmdstats' => 'Quote') );
+&addCmdHook('reverse', ('CODEREF' => 'reverse::reverse', 'Identifier' => 'reverse', 'Cmdstats' => 'reverse', 'Forker' => 1, 'Module' => 'reverse') );
+&addCmdHook('RootWarn', ('CODEREF' => 'CmdrootWarn', 'Identifier' => 'RootWarn', 'Module' => 'RootWarn') );
+&addCmdHook('OnJoin', ('CODEREF' => 'Cmdonjoin', 'Identifier' => 'OnJoin', 'Module' => 'OnJoin') );
+&addCmdHook('Rss', ('CODEREF' => 'Rss::Rss', 'Identifier' => 'Rss', 'Cmdstats' => 'Rss', 'Forker' => 1, 'Help' => 'rss') );
+&addCmdHook('sched(stats|info)', ('CODEREF' => 'scheduleList', ) );
+&addCmdHook('scramble', ('CODEREF' => 'scramble::scramble', 'Identifier' => 'scramble', 'Cmdstats' => 'scramble', 'Forker' => 1, 'Module' => 'scramble') );
+&addCmdHook('seen', ('CODEREF' => 'seen', 'Identifier' => 'seen') );
+&addCmdHook('slashdot', ('CODEREF' => 'Slashdot::Slashdot', 'Identifier' => 'slashdot', 'Forker' => 1, 'Cmdstats' => 'slashdot') );
+&addCmdHook('tell|explain', ('CODEREF' => 'tell', Help => 'tell', Identifier => 'allowTelling', Cmdstats => 'Tell') );
+&addCmdHook('uc', ('CODEREF' => 'case::upper', 'Identifier' => 'case', 'Cmdstats' => 'case', 'Forker' => 1, 'Module' => 'case') );
+&addCmdHook('Uptime', ('CODEREF' => 'uptime', 'Identifier' => 'Uptime', 'Cmdstats' => 'Uptime') );
+&addCmdHook('u(ser)?info', ('CODEREF' => 'userinfo', 'Identifier' => 'UserInfo', 'Help' => 'userinfo', 'Module' => 'UserInfo') );
+&addCmdHook('verstats', ('CODEREF' => 'do_verstats' ) );
+&addCmdHook('Weather', ('CODEREF' => 'Weather::Weather', 'Identifier' => 'Weather', 'Help' => 'weather', 'Cmdstats' => 'Weather', 'Forker' => 1, 'Module' => 'Weather') );
+&addCmdHook('wiki(pedia)?', ('CODEREF' => 'wikipedia::wikipedia', 'Identifier' => 'wikipedia', 'Cmdstats' => 'wikipedia', 'Forker' => 1, 'Help' => 'wikipedia', 'Module' => 'wikipedia') );
+&addCmdHook('wtf', ('CODEREF' => 'wtf::query', 'Identifier' => 'wtf', 'Cmdstats' => 'wtf', 'Forker' => 1, 'Help' => 'wtf', 'Module' => 'wtf') );
+&addCmdHook('zfi', ('CODEREF' => 'zfi::query', 'Identifier' => 'zfi', 'Cmdstats' => 'zfi', 'Forker' => 1, 'Module' => 'zfi') );
+&addCmdHook('(zippy|yow)', ('CODEREF' => 'zippy::get', 'Identifier' => 'Zippy', 'Cmdstats' => 'Zippy', 'Forker' => 1, 'Module' => 'Zippy') );
+&addCmdHook('zsi', ('CODEREF' => 'zsi::query', 'Identifier' => 'zsi', 'Cmdstats' => 'zsi', 'Forker' => 1, 'Module' => 'zsi') );
+###
+### END OF ADDING HOOKS.
+###
+
+&status('loaded '.scalar(keys %cmdhooks).' command hooks.');
+
+1;
--- /dev/null
+#
+# DynaConfig.pl: Read/Write configuration files dynamically.
+# Author: dms
+# Version: v0.1 (20010120)
+# Created: 20010119
+# NOTE: Merged from User.pl
+#
+
+use strict;
+
+use vars qw(%chanconf %cache %bans %channels %nuh %users %ignore
+ %talkWho %dcc %mask);
+use vars qw($utime_userfile $ucount_userfile $utime_chanfile $who
+ $ucount_chanfile $userHandle $chan $msgType $talkchannel
+ $ident $bot_state_dir $talkWho $flag_quit $wtime_userfile
+ $wcount_userfile $wtime_chanfile $nuh $message);
+
+#####
+##### USERFILE CONFIGURATION READER/WRITER
+#####
+
+sub readUserFile {
+ my $f = "$bot_state_dir/infobot.users";
+
+ if (! -f $f) {
+ &DEBUG("userfile not found; new fresh run detected.");
+ return;
+ }
+
+ if ( -f $f and -f "$f~") {
+ my $s1 = -s $f;
+ my $s2 = -s "$f~";
+
+ if ($s2 > $s1*3) {
+ &FIXME("rUF: backup file bigger than current file.");
+ }
+ }
+
+ if (!open IN, $f) {
+ &ERROR("Cannot read userfile ($f): $!");
+ &closeLog();
+ exit 1;
+ }
+
+ undef %users; # clear on reload.
+ undef %bans; # reset.
+ undef %ignore; # reset.
+
+ my $ver = <IN>;
+ if ($ver !~ /^#v1/) {
+ &ERROR("old or invalid user file found.");
+ &closeLog();
+ exit 1; # correct?
+ }
+
+ my $nick;
+ my $type;
+ while (<IN>) {
+ chop;
+
+ next if /^$/;
+ next if /^#/;
+
+ if (/^--(\S+)[\s\t]+(.*)$/) { # user: middle entry.
+ my ($what,$val) = ($1,$2);
+
+ if (!defined $val or $val eq '') {
+ &WARN("$what: val == NULL.");
+ next;
+ }
+
+ if (!defined $nick) {
+ &WARN("DynaConfig: invalid line: $_");
+ next;
+ }
+
+ # nice little hack.
+ if ($what eq 'HOSTS') {
+ $users{$nick}{$what}{$val} = 1;
+ } else {
+ $users{$nick}{$what} = $val;
+ }
+
+ } elsif (/^(\S+)$/) { # user: start entry.
+ $nick = $1;
+
+ } elsif (/^::(\S+) ignore$/) { # ignore: start entry.
+ $chan = $1;
+ $type = 'ignore';
+
+ } elsif (/^- (\S+):\+(\d+):\+(\d+):(\S+):(.*)$/ and $type eq 'ignore') {
+ ### ignore: middle entry.
+ my $mask = $1;
+ my(@array) = ($2,$3,$4,$5);
+ ### DEBUG purposes only!
+ if ($mask !~ /^$mask{nuh}$/) {
+ &WARN("ignore: mask $mask is invalid.");
+ next;
+ }
+ $ignore{$chan}{$mask} = \@array;
+
+ } elsif (/^::(\S+) bans$/) { # bans: start entry.
+ $chan = $1;
+ $type = 'bans';
+
+ } elsif (/^- (\S+):\+(\d+):\+(\d+):(\d+):(\S+):(.*)$/ and $type eq 'bans') {
+ ### bans: middle entry.
+ # $btime, $atime, $count, $whoby, $reason.
+ my(@array) = ($2,$3,$4,$5,$6);
+ $bans{$chan}{$1} = \@array;
+
+ } else { # unknown.
+ &WARN("unknown line: $_");
+ }
+ }
+ close IN;
+
+ &status( sprintf("USERFILE: Loaded: %d users, %d bans, %d ignore",
+ scalar(keys %users)-1,
+ scalar(keys %bans), # ??
+ scalar(keys %ignore), # ??
+ )
+ );
+}
+
+sub writeUserFile {
+ if (!scalar keys %users) {
+ &DEBUG("wUF: nothing to write.");
+ return;
+ }
+
+ if (!open OUT,">$bot_state_dir/infobot.users") {
+ &ERROR("Cannot write userfile ($bot_state_dir/infobot.users): $!");
+ return;
+ }
+
+ my $time = scalar(gmtime);
+
+ print OUT "#v1: infobot -- $ident -- written $time\n\n";
+
+ ### USER LIST.
+ my $cusers = 0;
+ foreach (sort keys %users) {
+ my $user = $_;
+ $cusers++;
+ my $count = scalar keys %{ $users{$user} };
+ if (!$count) {
+ &WARN("user $user has no other attributes; skipping.");
+ next;
+ }
+
+ print OUT "$user\n";
+
+ foreach (sort keys %{ $users{$user} }) {
+ my $what = $_;
+ my $val = $users{$user}{$_};
+
+ if (ref($val) eq 'HASH') {
+ foreach (sort keys %{ $users{$user}{$_} }) {
+ print OUT "--$what\t\t$_\n";
+ }
+
+ } elsif ($_ eq 'FLAGS') {
+ print OUT "--$_\t\t" . join('', sort split('', $val)) . "\n";
+ } else {
+ print OUT "--$_\t\t$val\n";
+ }
+ }
+ print OUT "\n";
+ }
+
+ ### BAN LIST.
+ my $cbans = 0;
+ foreach (keys %bans) {
+ my $chan = $_;
+ $cbans++;
+
+ my $count = scalar keys %{ $bans{$chan} };
+ if (!$count) {
+ &WARN("bans: chan $chan has no other attributes; skipping.");
+ next;
+ }
+
+ print OUT "::$chan bans\n";
+ foreach (keys %{ $bans{$chan} }) {
+# format: bans: mask expire time-added count who-added reason
+ my @array = @{ $bans{$chan}{$_} };
+ if (scalar @array != 5) {
+ &WARN("bans: $chan/$_ is corrupted.");
+ next;
+ }
+
+ printf OUT "- %s:+%d:+%d:%d:%s:%s\n", $_, @array;
+ }
+ }
+ print OUT "\n" if ($cbans);
+
+ ### IGNORE LIST.
+ my $cignore = 0;
+ foreach (keys %ignore) {
+ my $chan = $_;
+ $cignore++;
+
+ my $count = scalar keys %{ $ignore{$chan} };
+ if (!$count) {
+ &WARN("ignore: chan $chan has no other attributes; skipping.");
+ next;
+ }
+
+ ### TODO: use hash instead of array for flexibility?
+ print OUT "::$chan ignore\n";
+ foreach (keys %{ $ignore{$chan} }) {
+# format: ignore: mask expire time-added who-added reason
+ my @array = @{ $ignore{$chan}{$_} };
+ if (scalar @array != 4) {
+ &WARN("ignore: $chan/$_ is corrupted.");
+ next;
+ }
+
+ printf OUT "- %s:+%d:+%d:%s:%s\n", $_, @array;
+ }
+ }
+
+ close OUT;
+
+ $wtime_userfile = time();
+ &status("--- Saved USERFILE ($cusers users; $cbans bans; $cignore ignore) at $time");
+ if (defined $msgType and $msgType =~ /^chat$/) {
+ &performStrictReply("--- Writing user file...");
+ }
+}
+
+#####
+##### CHANNEL CONFIGURATION READER/WRITER
+#####
+
+sub readChanFile {
+ my $f = "$bot_state_dir/infobot.chan";
+ if ( -f $f and -f "$f~") {
+ my $s1 = -s $f;
+ my $s2 = -s "$f~";
+
+ if ($s2 > $s1*3) {
+ &FIXME("rCF: backup file bigger than current file.");
+ }
+ }
+
+ if (!open IN, $f) {
+ &ERROR("Cannot read chanfile ($f): $!");
+ return;
+ }
+
+ undef %chanconf; # reset.
+
+ $_ = <IN>; # version string.
+
+ my $chan;
+ while (<IN>) {
+ chop;
+
+ next if /^\s*$/;
+ next if /^\// or /^\;/; # / or ; are comment lines.
+
+ if (/^(\S+)\s*$/) {
+ $chan = $1;
+ next;
+ }
+ next unless (defined $chan);
+
+ if (/^[\s\t]+\+(\S+)$/) { # bool, true.
+ $chanconf{$chan}{$1} = 1;
+
+ } elsif (/^[\s\t]+\-(\S+)$/) { # bool, false.
+ # although this is supported in run-time configuration.
+ $chanconf{$chan}{$1} = 0;
+
+ } elsif (/^[\s\t]+(\S+)[\s\t]+(.*)$/) {# what = val.
+ $chanconf{$chan}{$1} = $2;
+
+ } else {
+ &WARN("unknown line: $_") unless (/^#/);
+ }
+ }
+ close IN;
+
+ # verify configuration
+ ### TODO: check against valid params.
+ foreach $chan (keys %chanconf) {
+ foreach (keys %{ $chanconf{$chan} }) {
+ next unless /^[+-]/;
+
+ &WARN("invalid param: chanconf{$chan}{$_}; removing.");
+ delete $chanconf{$chan}{$_};
+ undef $chanconf{$chan}{$_};
+ }
+ }
+
+ &status("CHANFILE: Loaded: ".(scalar(keys %chanconf)-1)." chans");
+}
+
+sub writeChanFile {
+ if (!scalar keys %chanconf) {
+ &DEBUG("wCF: nothing to write.");
+ return;
+ }
+
+ if (!open OUT,">$bot_state_dir/infobot.chan") {
+ &ERROR("Cannot write chanfile ($bot_state_dir/infobot.chan): $!");
+ return;
+ }
+
+ my $time = scalar(gmtime);
+ print OUT "#v1: infobot -- $ident -- written $time\n\n";
+
+ if ($flag_quit) {
+
+ ### Process 1: if defined in _default, remove same definition
+ ### from non-default channels.
+ foreach (keys %{ $chanconf{_default} }) {
+ my $opt = $_;
+ my $val = $chanconf{_default}{$opt};
+ my @chans;
+
+ foreach (keys %chanconf) {
+ $chan = $_;
+
+ next if ($chan eq "_default");
+ next unless (exists $chanconf{$chan}{$opt});
+ next unless ($val eq $chanconf{$chan}{$opt});
+
+ push(@chans,$chan);
+ delete $chanconf{$chan}{$opt};
+ }
+
+ if (scalar @chans) {
+ &DEBUG("Removed config $opt to @chans since it's defiend in '_default'");
+ }
+ }
+
+ ### Process 2: if defined in all chans but _default, set in
+ ### _default and remove all others.
+ my (%optsval, %opts);
+ foreach (keys %chanconf) {
+ $chan = $_;
+ next if ($chan eq "_default");
+ my $opt;
+
+ foreach (keys %{ $chanconf{$chan} }) {
+ $opt = $_;
+ if (exists $optsval{$opt} and $optsval{$opt} eq $chanconf{$chan}{$opt}) {
+ $opts{$opt}++;
+ next;
+ }
+ $optsval{$opt} = $chanconf{$chan}{$opt};
+ $opts{$opt} = 1;
+ }
+ }
+
+ foreach (keys %opts) {
+ next unless ($opts{$_} > 2);
+ &DEBUG(" opts{$_} => $opts{$_}");
+ }
+
+ ### other optimizations are in UserDCC.pl
+ }
+
+ ### lets do it...
+ foreach (sort keys %chanconf) {
+ $chan = $_;
+
+ print OUT "$chan\n";
+
+ foreach (sort keys %{ $chanconf{$chan} }) {
+ my $val = $chanconf{$chan}{$_};
+
+ if ($val =~ /^0$/) { # bool, false.
+ print OUT " -$_\n";
+
+ } elsif ($val =~ /^1$/) { # bool, true.
+ print OUT " +$_\n";
+
+ } else { # what = val.
+ print OUT " $_ $val\n";
+
+ }
+
+ }
+ print OUT "\n";
+ }
+
+ close OUT;
+
+ $wtime_chanfile = time();
+ &status("--- Saved CHANFILE (".scalar(keys %chanconf).
+ " chans) at $time");
+
+ if (defined $msgType and $msgType =~ /^chat$/) {
+ &performStrictReply("--- Writing chan file...");
+ }
+}
+
+#####
+##### USER COMMANDS.
+#####
+
+# TODO: support multiple flags.
+# TODO: return all flags for opers
+sub IsFlag {
+ my $flags = shift;
+ my ($ret, $f, $o) = '';
+
+ &verifyUser($who, $nuh);
+
+ foreach $f (split //, $users{$userHandle}{FLAGS}) {
+ foreach $o ( split //, $flags ) {
+ next unless ($f eq $o);
+
+ $ret = $f;
+ last;
+ }
+ }
+
+ $ret;
+}
+
+sub verifyUser {
+ my ($nick, $lnuh) = @_;
+ my ($user, $m);
+
+ if ($userHandle = $dcc{'CHATvrfy'}{$who}) {
+ &VERB("vUser: cached auth for $who.",2);
+ return $userHandle;
+ }
+
+ $userHandle = '';
+
+ foreach $user (keys %users) {
+ next if ($user eq "_default");
+
+ foreach $m (keys %{ $users{$user}{HOSTS} }) {
+ $m =~ s/\?/./g;
+ $m =~ s/\*/.*?/g;
+ $m =~ s/([\@\(\)\[\]])/\\$1/g;
+
+ next unless ($lnuh =~ /^$m$/i);
+
+ if ($user !~ /^\Q$nick\E$/i and !exists $cache{VUSERWARN}{$user}) {
+ &status("vU: host matched but diff nick ($nick != $user).");
+ $cache{VUSERWARN}{$user} = 1;
+ }
+
+ $userHandle = $user;
+ last;
+ }
+
+ last if ($userHandle ne '');
+
+ if ($user =~ /^\Q$nick\E$/i and !exists $cache{VUSERWARN}{$user}) {
+ &status("vU: nick matched but host is not in list ($lnuh).");
+ $cache{VUSERWARN}{$user} = 1;
+ }
+ }
+
+ $userHandle ||= "_default";
+ # what's talkchannel for?
+ $talkWho{$talkchannel} = $who if (defined $talkchannel);
+ $talkWho = $who;
+
+ return $userHandle;
+}
+
+sub ckpasswd {
+ # returns true if arg1 encrypts to arg2
+ my ($plain, $encrypted) = @_;
+ if ($encrypted eq '') {
+ ($plain, $encrypted) = split(/\s+/, $plain, 2);
+ }
+ return 0 unless ($plain ne '' and $encrypted ne '');
+
+ # MD5 // DES. Bobby Billingsley++.
+ my $salt;
+ if ($encrypted =~ /^(\S{2})/ and length $encrypted == 13) {
+ $salt = $1;
+ } elsif ($encrypted =~ /^\$\d\$(\w\w)\$/) {
+ $salt = $1;
+ } else {
+ &DEBUG("unknown salt from $encrypted.");
+ return 0;
+ }
+
+ return ($encrypted eq crypt($plain, $salt));
+}
+
+# mainly for dcc chat... hrm.
+sub hasFlag {
+ my ($flag) = @_;
+
+ if (&IsFlag($flag) eq $flag) {
+ return 1;
+ } else {
+ &status("DCC CHAT: <$who> $message -- not enough flags.");
+ &performStrictReply("error: you do not have enough flags for that. ($flag required)");
+ return 0;
+ }
+}
+
+# expire is time in minutes
+sub ignoreAdd {
+ my($mask,$chan,$expire,$comment) = @_;
+
+ $chan ||= '*'; # global if undefined.
+ $comment ||= ''; # optional.
+ $expire ||= 0; # permament.
+ my $count ||= 0;
+
+ if ($expire > 0) {
+ $expire = ($expire*60) + time();
+ } else {
+ $expire = 0;
+ }
+
+ my $exist = 0;
+ $exist++ if (exists $ignore{$chan}{$mask});
+
+ $ignore{$chan}{$mask} = [$expire, time(), $who, $comment];
+
+ # TODO: improve this.
+ if ($expire == 0) {
+ &status("ignore: Added $mask for $chan to NEVER expire, by $who, for $comment");
+ } else {
+ &status("ignore: Added $mask for $chan to expire $expire mins, by $who, for $comment");
+ }
+
+ if ($exist) {
+ $utime_userfile = time();
+ $ucount_userfile++;
+
+ return 2;
+ } else {
+ return 1;
+ }
+}
+
+sub ignoreDel {
+ my($mask) = @_;
+ my @match;
+
+ ### TODO: support wildcards.
+ foreach (keys %ignore) {
+ my $chan = $_;
+
+ foreach (grep /^\Q$mask\E$/i, keys %{ $ignore{$chan} }) {
+ delete $ignore{$chan}{$mask};
+ push(@match,$chan);
+ }
+
+ &DEBUG("iD: scalar => ".scalar(keys %{ $ignore{$chan} }) );
+ }
+
+ if (scalar @match) {
+ $utime_userfile = time();
+ $ucount_userfile++;
+ }
+
+ return @match;
+}
+
+sub userAdd {
+ my($nick,$mask) = @_;
+
+ if (exists $users{$nick}) {
+ return 0;
+ }
+
+ $utime_userfile = time();
+ $ucount_userfile++;
+
+ if (defined $mask and $mask !~ /^\s*$/) {
+ &DEBUG("userAdd: mask => $mask");
+ $users{$nick}{HOSTS}{$mask} = 1;
+ }
+
+ $users{$nick}{FLAGS} ||= $users{_default}{FLAGS};
+
+ return 1;
+}
+
+sub userDel {
+ my($nick) = @_;
+
+ if (!exists $users{$nick}) {
+ return 0;
+ }
+
+ $utime_userfile = time();
+ $ucount_userfile++;
+
+ delete $users{$nick};
+
+ return 1;
+}
+
+sub banAdd {
+ my($mask,$chan,$expire,$reason) = @_;
+
+ $chan ||= '*';
+ $expire ||= 0;
+
+ if ($expire > 0) {
+ $expire = $expire*60 + time();
+ }
+
+ my $exist = 1;
+ $exist++ if (exists $bans{$chan}{$mask} or
+ exists $bans{'*'}{$mask});
+ $bans{$chan}{$mask} = [$expire, time(), 0, $who, $reason];
+
+ my @chans = ($chan eq '*') ? keys %channels : $chan;
+ my $m = $mask;
+ $m =~ s/\?/\\./g;
+ $m =~ s/\*/\\S*/g;
+ foreach (@chans) {
+ my $chan = $_;
+ foreach (keys %{ $channels{$chan}{''} }) {
+ next unless (exists $nuh{lc $_});
+ next unless ($nuh{lc $_} =~ /^$m$/i);
+ &FIXME("nuh{$_} =~ /$m/");
+ }
+ }
+
+ if ($exist == 1) {
+ $utime_userfile = time();
+ $ucount_userfile++;
+ }
+
+ return $exist;
+}
+
+sub banDel {
+ my($mask) = @_;
+ my @match;
+
+ foreach (keys %bans) {
+ my $chan = $_;
+
+ foreach (grep /^\Q$mask\E$/i, keys %{ $bans{$chan} }) {
+ delete $bans{$chan}{$_};
+ push(@match, $chan);
+ }
+
+ &DEBUG("bans: scalar => ".scalar(keys %{ $bans{$chan} }) );
+ }
+
+ if (scalar @match) {
+ $utime_userfile = time();
+ $ucount_userfile++;
+ }
+
+ return @match;
+}
+
+sub IsUser {
+ my($user) = @_;
+
+ if ( &getUser($user) ) {
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+sub getUser {
+ my($user) = @_;
+
+ if (!defined $user) {
+ &WARN("getUser: user == NULL.");
+ return;
+ }
+
+ if (my @retval = grep /^\Q$user\E$/i, keys %users) {
+ if ($retval[0] ne $user) {
+ &WARN("getUser: retval[0] ne user ($retval[0] ne $user)");
+ }
+ my $count = scalar keys %{ $users{$retval[0]} };
+ &DEBUG("count => $count.");
+
+ return $retval[0];
+ } else {
+ return;
+ }
+}
+
+sub chanSet {
+ my($cmd, $chan, $what, $val) = @_;
+
+ if ($cmd eq "+chan") {
+ if (exists $chanconf{$chan}) {
+ &performStrictReply("chan $chan already exists.");
+ return;
+ }
+ $chanconf{$chan}{_time_added} = time();
+ $chanconf{$chan}{autojoin} = $conn->nick();
+
+ &performStrictReply("Joining $chan...");
+ &joinchan($chan);
+
+ return;
+ }
+
+ if (!exists $chanconf{$chan}) {
+ &performStrictReply("no such channel $chan");
+ return;
+ }
+
+ my $update = 0;
+
+ if (defined $what and $what =~ s/^([+-])(\S+)/$2/) {
+ ### ".chanset +blah"
+ ### ".chanset +blah 10" -- error.
+
+ my $set = ($1 eq "+") ? 1 : 0;
+ my $was = $chanconf{$chan}{$what};
+
+ if ($set) { # add/set.
+ if (defined $was and $was eq '1') {
+ &performStrictReply("setting $what for $chan already 1.");
+ return;
+ }
+
+ $val = 1;
+
+ } else { # delete/unset.
+ if (!defined $was) {
+ &performStrictReply("setting $what for $chan is not set.");
+ return;
+ }
+
+ $val = 0;
+ }
+
+ # alter for cosmetic (print out) reasons only.
+ $was = (defined $was) ? "; was '$was'" : '';
+
+ if ($val eq '0') {
+ &performStrictReply("Unsetting $what for $chan$was.");
+ delete $chanconf{$chan}{$what};
+ } else {
+ &performStrictReply("Setting $what for $chan to '$val'$was.");
+ $chanconf{$chan}{$what} = $val;
+ }
+
+ $update++;
+
+ } elsif (defined $val) {
+ ### ".chanset blah testing"
+
+ my $was = $chanconf{$chan}{$what};
+ if (defined $was and $was eq $val) {
+ &performStrictReply("setting $what for $chan already '$val'.");
+ return;
+ }
+ $was = ($was) ? "; was '$was'" : '';
+ &performStrictReply("Setting $what for $chan to '$val'$was.");
+
+ $chanconf{$chan}{$what} = $val;
+
+ $update++;
+
+ } else { # read only.
+ ### ".chanset"
+ ### ".chanset blah"
+
+ if (!defined $what) {
+ &WARN("chanset/DC: what == undefine.");
+ return;
+ }
+
+ if (exists $chanconf{$chan}{$what}) {
+ &performStrictReply("$what for $chan is '$chanconf{$chan}{$what}'");
+ } else {
+ &performStrictReply("$what for $chan is not set.");
+ }
+ }
+
+ if ($update) {
+ $utime_chanfile = time();
+ $ucount_chanfile++;
+ }
+
+ return;
+}
+
+sub rehashConfVars {
+ # this is an attempt to fix where an option is enabled but the module
+ # has been not loaded. it also can be used for other things.
+
+ foreach (keys %{ $cache{confvars} }) {
+ my $i = $cache{confvars}{$_};
+ &DEBUG("rehashConfVars: _ => $_");
+
+ if (/^news$/ and $i) {
+ &loadMyModule('News');
+ delete $cache{confvars}{$_};
+ }
+
+ if (/^uptime$/ and $i) {
+ &loadMyModule('Uptime');
+ delete $cache{confvars}{$_};
+ }
+
+ if (/^rootwarn$/i and $i) {
+ &loadMyModule('RootWarn');
+ delete $cache{confvars}{$_};
+ }
+
+ if (/^onjoin$/i and $i) {
+ &loadMyModule('OnJoin');
+ delete $cache{confvars}{$_};
+ }
+ }
+
+ &DEBUG("end of rehashConfVars");
+
+ delete $cache{confvars};
+}
+
+my @regFlagsUser = (
+ # possible chars to include in FLAG
+ 'A', # bot administration over /msg
+ # default is only via DCC CHAT
+ 'O', # dynamic ops (as on channel). (automatic +o)
+ 'T', # add topics.
+ 'a', # ask/request factoid.
+ 'm', # modify factoid. (includes renaming)
+ 'n', # bot owner, can 'reload'
+ 'o', # master of bot (automatic +amrt)
+ # can search on factoid strings shorter than 2 chars
+ # can tell bot to join new channels
+ # can [un]lock factoids
+ 'r', # remove factoid.
+ 't', # teach/add factoid.
+);
+
+1;
--- /dev/null
+#
+# Misc.pl: Miscellaneous stuff.
+# Author: dms
+# Version: v0.1 (20010906)
+# Created: 20010906
+#
+
+# use strict; # TODO
+
+use vars qw(%param %cache %lang %cmdstats %bots);
+use vars qw($message $who $addressed $chan $h $nuh $ident $msgType
+ $correction_plausable);
+
+# 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 !~ /^</) {
+ / \Q$ident$/i and last; # someone said i'm something.
+ /^i('m)? / and last;
+ /^(it|that|there|what)('s)?(\s+|$)/ and last;
+ /^you('re)?(\s+|$)/ and last;
+
+ /^(where|who|why|when|how)(\s+|$)/ and last;
+ /^(this|that|these|those|they)(\s+|$)/ and last;
+ /^(every(one|body)|we) / and last;
+
+ /^say / and last;
+ }
+
+ # uncaught commands.
+ /^add topic / and last; # topic management.
+ /( add$| add |^add )/ and last; # borked teach statement.
+ /^learn / and last; # teach. damn morons.
+ /^tell (\S+) about / and last; # tell.
+ /\=\~/ and last; # substituition.
+
+ /^\=/ and last; # botnick = heh is.
+ /wants you to know/ and last;
+
+ # symbols.
+ /(\"\*)/ and last;
+ /, / and last;
+ (/^'/ and /'$/) and last;
+ (/^"/ and /"$/) and last;
+
+ # delimiters.
+ /\=\>/ 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 = "<REPLY> 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 it doesn't exist, well... it doesn't!
+ if (!defined $result) {
+ &performReply("i didn't have anything called '$faqtoid' to forget");
+ return;
+ }
+
+ # TODO: squeeze 3 getFactInfo calls into one?
+ my $author = &getFactInfo($faqtoid, 'created_by');
+ my $count = &getFactInfo($faqtoid, 'requested_count') || 0;
+ # don't delete if requested $limit times
+ my $limit = &getChanConfDefault('factoidPreventForgetLimit', 100, $chan);
+ # don't delete if older than $limitage seconds (modified by requests below)
+ my $limitage = &getChanConfDefault('factoidPreventForgetLimitTime', 7 * 24 * 60 * 60, $chan);
+ my $t = &getFactInfo($faqtoid, 'created_time') || 0;
+ my $age = time() - $t;
+
+ # lets scale limitage from 1 (nearly 0) to $limit (full time).
+ $limitage = $limitage*($count+1)/$limit if ($count < $limit);
+ # isauthor and isop.
+ my $isau = (defined $author and &IsHostMatch($author) == 2) ? 1 : 0;
+ my $isop = (&IsFlag('o') eq 'o') ? 1 : 0;
+
+ if (IsFlag('r') ne 'r' && !$isop) {
+ &msg($who, "you don't have access to remove factoids");
+ return;
+ }
+
+ return 'locked factoid' if (&IsLocked($faqtoid) == 1);
+
+ ###
+ ### lets go do some checking.
+ ###
+
+ # factoidPreventForgetLimitTime:
+ if (!($isop or $isau) and $age/(60*60*24) > $limitage) {
+ &msg($who, "cannot remove factoid '$faqtoid', too old. (" .
+ $age/(60*60*24) . ">$limitage) use 'no,' instead");
+ return;
+ }
+
+ # factoidPreventForgetLimit:
+ if (!($isop or $isau) and $limit and $count > $limit) {
+ &msg($who, "will not delete '$faqtoid', count > limit ($count > $limit) use 'no, ' instead.");
+ return;
+ }
+
+ # this may eat some memory.
+ # prevent deletion if other factoids redirect to it.
+ # TODO: use hash instead of array.
+ my @list;
+ if (&getChanConf('factoidPreventForgetRedirect')) {
+ &status("Factoids/Core: forget: checking for redirect factoids");
+ @list = &searchTable('factoids', 'factoid_key',
+ 'factoid_value', "^<REPLY> see ");
+ }
+
+ my $match = 0;
+ for (@list) {
+ my $f = $_;
+ my $v = &getFactInfo($f, 'factoid_value');
+ my $fsafe = quotemeta($faqtoid);
+ next unless ($v =~ /^<REPLY> ?see( also)? $fsafe\.?$/i);
+
+ &DEBUG("Factoids/Core: match! ($f || $faqtoid)");
+
+ $match++;
+ }
+ # TODO: warn for op aswell, but allow force delete.
+ if (!$isop and $match) {
+ &msg($who, "uhm, other (redirection) factoids depend on this one.");
+ return;
+ }
+
+ # minimize abuse.
+ if (!$isop and &IsHostMatch($author) != 2) {
+ $cache{forget}{$h}++;
+
+ # warn.
+ if ($cache{forget}{$h} > 3) {
+ &msg($who, "Stop abusing forget!");
+ }
+
+ # ignore.
+ # TODO: make forget limit configurable.
+ # TODO: make forget ignore time configurable.
+ if ($cache{forget}{$h} > 5) {
+ &ignoreAdd(&makeHostMask($nuh), '*', 3*24*60, "abuse of forget");
+ &msg($who, "forget: Ignoring you for abuse!");
+ }
+ }
+
+ # lets do it!
+
+ if (&IsParam('factoidDeleteDelay') or &IsChanConf('factoidDeleteDelay') > 0) {
+ if (!($isop or $isau) and $faqtoid =~ / #DEL#$/) {
+ &msg($who, "cannot delete it ($faqtoid).");
+ return;
+ }
+
+ &status("forgot (safe delete): '$faqtoid' - ". scalar(gmtime));
+ ### 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($new);
+ 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!");
+ }
+ }
+
+ &status("forget: <$who> '$faqtoid' =is=> '$result'");
+ &delFactoid($faqtoid);
+
+ &performReply("i forgot $faqtoid");
+
+ $count{'Update'}++;
+
+ 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') > 0);
+ if (!$i) {
+ &performReply("safe delete has been disable so what is there to undelete?");
+ return;
+ }
+
+ my $faqtoid = $message;
+ if ($faqtoid eq '') {
+ &help('unforget');
+ return;
+ }
+
+ $faqtoid =~ tr/A-Z/a-z/;
+ my $result = &getFactoid($faqtoid." #DEL#");
+ my $check = &getFactoid($faqtoid);
+
+ if (defined $check) {
+ &performReply("cannot undeleted '$faqtoid' because it already exists!");
+ return;
+ }
+
+ if (!defined $result) {
+ &performReply("that factoid was not backedup :/");
+ return;
+ }
+
+ &setFactInfo($faqtoid." #DEL#", 'factoid_key', $faqtoid);
+# &setFactInfo($faqtoid, 'modified_by', '');
+# &setFactInfo($faqtoid, 'modified_time', 0);
+
+ $check = &getFactoid($faqtoid);
+ # TODO: check if $faqtoid." #DEL#" exists?
+ if (defined $check) {
+ &performReply("Successfully recovered '$faqtoid'. Have fun now.");
+ $count{'Undelete'}++;
+ } else {
+ &performReply("did not recover '$faqtoid'. What happened?");
+ }
+
+ 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) {
+ &performReply("i didn't have anything called '$from' to rename");
+ return;
+ }
+
+ # who == nick!user@host.
+ if (&IsFlag('m') ne 'm' and $author !~ /^\Q$who\E\!/i) {
+ &msg($who, "factoid '$from' is 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 {
+ &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) {
+ # excessive length.
+ if (length $result > $param{'maxDataSize'}) {
+ &performReply("that's too long");
+ return;
+ }
+ # empty
+ if (length $result == 0) {
+ &performReply("factoid would be empty. use forget?");
+ return;
+ }
+ # min length.
+ my $faqauth = &getFactInfo($faqtoid, 'created_by');
+ if ((length $result)*2 < length $was and
+ &IsFlag('o') ne 'o' and
+ &IsHostMatch($faqauth) != 2
+ ) {
+ &performReply("too drastic change of factoid.");
+ }
+
+ &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' to modify");
+ }
+
+ 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 /i; # Must match ^, else factoids with "whois" anywhere break
+ 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('Math') > 0 and $addressed) { # perl math.
+ &loadMyModule('Math');
+ 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 and !$addrchar);
+
+ 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;
--- /dev/null
+#
+# DBStubs.pl: DB independent (I hope, heh) factoid support
+# Author: dms
+# Version: v0.6d (20000223)
+# Created: 19991020
+#
+
+# use strict; # TODO
+
+#####
+# Usage: &setFactInfo($faqtoid, $key, $val);
+sub setFactInfo {
+ &sqlSet('factoids',
+ { factoid_key => $_[0] },
+ { $_[1] => $_[2] }
+ );
+}
+
+#####
+# Usage: &getFactInfo($faqtoid, [$what]);
+sub getFactInfo {
+ return &sqlSelect('factoids', $_[1], { factoid_key => $_[0] } );
+}
+
+#####
+# Usage: &getFactoid($faqtoid);
+sub getFactoid {
+ return &getFactInfo($_[0], 'factoid_value');
+}
+
+#####
+# Usage: &delFactoid($faqtoid);
+sub delFactoid {
+ my ($faqtoid) = @_;
+
+ &sqlDelete('factoids', { factoid_key => $faqtoid } );
+ &status("DELETED $faqtoid");
+
+ return 1;
+}
+
+#####
+# Usage: &IsLocked($faqtoid);
+sub IsLocked {
+ my ($faqtoid) = @_;
+ my $thisnuh = &getFactInfo($faqtoid, 'locked_by');
+
+ if (defined $thisnuh and $thisnuh ne '') {
+ if (!&IsHostMatch($thisnuh) and &IsFlag('o') ne 'o') {
+ &performReply("cannot alter locked factoids");
+ return 1;
+ }
+ }
+
+ return 0;
+}
+
+#####
+# Usage: &AddModified($faqtoid,$nuh);
+sub AddModified {
+ my ($faqtoid,$nuh) = @_;
+ my $modified_by = &getFactInfo($faqtoid, 'modified_by');
+ my (@modifiedlist, @modified, %modified);
+
+ if (defined $modified_by) {
+ push(@modifiedlist, split(/\,/, $modified_by));
+ }
+ push(@modifiedlist,$nuh);
+
+ foreach (reverse @modifiedlist) {
+ /^(\S+)!(\S+)@(\S+)$/;
+ my $nick = lc $1;
+ next if (exists $modified{$nick});
+
+ $modified{$nick} = $_;
+ push(@modified,$nick);
+ }
+
+ undef @modifiedlist;
+
+ foreach (reverse @modified) {
+ push(@modifiedlist, $modified{$_});
+ }
+ shift(@modifiedlist) while (scalar @modifiedlist > 3);
+
+ &setFactInfo($faqtoid, 'modified_by', join(",",@modifiedlist));
+ &setFactInfo($faqtoid, 'modified_time', time());
+
+ return 1;
+}
+
+#####
+### Commands which use the fundamental functions... Helpers?
+#####
+
+#####
+# Usage: &CmdLock($function,$faqtoid);
+sub CmdLock {
+ my ($faqtoid) = @_;
+
+ my $thisnuh = &getFactInfo($faqtoid,'locked_by');
+
+ if (defined $thisnuh and $thisnuh ne '') {
+ my $locked_by = (split(/\!/,$thisnuh))[0];
+ &msg($who,"factoid \002$faqtoid\002 has already been locked by $locked_by.");
+ return 0;
+ }
+
+ $thisnuh ||= &getFactInfo($faqtoid,'created_by');
+
+ # fixes bug found on 19991103.
+ # code needs to be reorganised though.
+ if ($thisnuh ne '') {
+ if (!&IsHostMatch($thisnuh) && IsFlag('o') ne 'o') {
+ &msg($who, "sorry, you are not allowed to lock '$faqtoid'.");
+ return 0;
+ }
+ }
+
+ &performReply("locking factoid \002$faqtoid\002");
+ &setFactInfo($faqtoid,'locked_by',$nuh);
+ &setFactInfo($faqtoid,'locked_time', time());
+
+ return 1;
+}
+
+#####
+# Usage: &CmdUnLock($faqtoid);
+sub CmdUnLock {
+ my ($faqtoid) = @_;
+
+ my $thisnuh = &getFactInfo($faqtoid,'locked_by');
+
+ if (!defined $thisnuh) {
+ &msg($who, "factoid \002$faqtoid\002 is not locked.");
+ return 0;
+ }
+
+ if ($thisnuh ne '' and !&IsHostMatch($thisnuh) and &IsFlag('o') ne 'o') {
+ &msg($who, "sorry, you are not allowed to unlock factoid '$faqtoid'.");
+ return 0;
+ }
+
+ &performReply("unlocking factoid \002$faqtoid\002");
+ &setFactInfo($faqtoid,'locked_by', '');
+ &setFactInfo($faqtoid,'locked_time', '0'); # pgsql complains if NOT NULL set. So set 0 which is the default
+
+ return 1;
+}
+
+1;
--- /dev/null
+#
+# Norm.pl: Norm.
+# Author: Kevin Lenzo
+# Version: 1997
+#
+
+# TODO:
+# use strict;
+
+sub normquery {
+ my ($in) = @_;
+
+ $in = " $in ";
+
+ for ($in) {
+ # where blah is -> where is blah
+ s/ (where|what|who)\s+(\S+)\s+(is|are) / $1 $3 $2 /i;
+
+ # where blah is -> where is blah
+ s/ (where|what|who)\s+(.*)\s+(is|are) / $1 $3 $2 /i;
+
+ s/^\s*(.*?)\s*/$1/;
+
+ s/be tellin\'?g?/tell/i;
+ s/ \'?bout/ about/i;
+
+ s/,? any(hoo?w?|ways?)/ /ig;
+ s/,?\s*(pretty )*please\??\s*$/\?/i;
+
+ # what country is ...
+ if ($in =~
+ s/wh(at|ich)\s+(add?res?s|country|place|net (suffix|domain))/wh$1 /ig) {
+ if ((length($in) == 2) && ($in !~ /^\./)) {
+ $in = '.'.$in;
+ }
+ $in .= '?';
+ }
+
+ # profanity filters. just delete it
+ s/th(e|at|is) (((m(o|u)th(a|er) ?)?fuck(in\'?g?)?|hell|heck|(god-?)?damn?(ed)?) ?)+//ig;
+ s/wtf/where/gi;
+ s/this (.*) thingy?/ $1/gi;
+ s/this thingy? (called )?//gi;
+ s/ha(s|ve) (an?y?|some|ne) (idea|clue|guess|seen) /know /ig;
+ s/does (any|ne|some) ?(1|one|body) know //ig;
+ s/do you know //ig;
+ s/can (you|u|((any|ne|some) ?(1|one|body)))( please)? tell (me|us|him|her)//ig;
+ s/where (\S+) can \S+ (a|an|the)?//ig;
+ s/(can|do) (i|you|one|we|he|she) (find|get)( this)?/is/i; # where can i find
+ s/(i|one|we|he|she) can (find|get)/is/gi; # where i can find
+ s/(the )?(address|url) (for|to) //i; # this should be more specific
+ s/(where is )+/where is /ig;
+ s/\s+/ /g;
+ s/^\s+//;
+ if ($in =~ s/\s*[\/?!]*\?+\s*$//) {
+ $finalQMark = 1;
+ }
+
+ s/\s+/ /g;
+ s/^\s*(.*?)\s*$/$1/;
+ s/^\s+|\s+$//g; # why twice, see Question.pl
+ }
+
+ return $in;
+}
+
+# for be-verbs
+sub switchPerson {
+ my ($in) = @_;
+
+ for ($in) {
+ # # fix genitives
+ s/(^|\W)\Q$who\Es\s+/$1${who}\'s /ig;
+ s/(^|\W)\Q$who\Es$/$1${who}\'s/ig;
+ s/(^|\W)\Q$who\E\'(\s|$)/$1${who}\'s$2/ig;
+
+ s/(^|\s)i\'m(\W|$)/$1$who is$2/ig;
+ s/(^|\s)i\'ve(\W|$)/$1$who has$2/ig;
+ s/(^|\s)i have(\W|$)/$1$who has$2/ig;
+ s/(^|\s)i haven\'?t(\W|$)/$1$who has not$2/ig;
+ s/(^|\s)i(\W|$)/$1$who$2/ig;
+ s/ am\b/ is/i;
+ s/\bam /is/i;
+ s/(^|\s)(me|myself)(\W|$)/$1$who$3/ig;
+ s/(^|\s)my(\W|$)/$1${who}\'s$2/ig; # turn 'my' into name's
+ s/(^|\W)you\'?re(\W|$)/$1you are$2/ig;
+
+ if ($addressed) {
+ my $mynick = 'UNDEF';
+ $mynick = $conn->nick() if ($conn);
+ # is it safe to remove $in from here, too?
+ $in =~ s/yourself/$mynick/i;
+ $in =~ s/(^|\W)are you(\W|$)/$1is $mynick$2/ig;
+ $in =~ s/(^|\W)you are(\W|$)/$1$mynick is$2/ig;
+ $in =~ s/(^|\W)you(\W|$)/$1$mynick$2/ig;
+ $in =~ s/(^|\W)your(\W|$)/$1$mynick\'s$2/ig;
+ }
+ }
+
+ return $in;
+}
+
+1;
--- /dev/null
+###
+### Question.pl: Kevin Lenzo (c) 1997
+###
+
+## doQuestion --
+## if ($query == query) {
+## return $value;
+## } else {
+## return NULL;
+## }
+##
+##
+
+# use strict; # TODO
+
+use vars qw($query $reply $finalQMark $nuh $result $talkok $who $nuh);
+use vars qw(%bots %forked);
+
+sub doQuestion {
+ # my doesn't allow variables to be inherinted, local does.
+ # following is used in math()...
+ local($query) = @_;
+ local($reply) = '';
+ local $finalQMark = $query =~ s/\?+\s*$//;
+ $finalQMark += $query =~ s/\?\s*$//;
+ $query =~ s/^\s+|\s+$//g;
+
+ if (!defined $query or $query =~ /^\s*$/) {
+ return '';
+ }
+
+ my $questionWord = '';
+
+ if (!$addressed) {
+ return '' unless ($finalQMark);
+ return '' unless &IsChanConf('minVolunteerLength') > 0;
+ return '' if (length $query < &::getChanConf('minVolunteerLength'));
+ } else {
+ ### TODO: this should be caught in Process.pl?
+ return '' unless ($talkok);
+
+ # there is no flag to disable/enable asking factoids...
+ # so it was added... thanks zyxep! :)
+ if (&IsFlag('a') ne 'a' && &IsFlag('o') ne 'o') {
+ &status("$who tried to ask us when not allowed.");
+ return;
+ }
+ }
+
+ # dangerous; common preambles should be stripped before here
+ if ($query =~ /^forget /i or $query =~ /^no, /) {
+ return if (exists $bots{$nuh});
+ }
+
+ if ($query =~ s/^literal\s+//i) {
+ &status("literal ask of '$query'.");
+ $literal = 1;
+ }
+
+ # convert to canonical reference form
+ my $x;
+ my @query;
+
+ push(@query, $query); # 1: push original.
+
+ # valid factoid.
+ if ($query =~ s/[!.]$//) {
+ push(@query, $query);
+ }
+
+ $x = &normquery($query);
+ push(@query, $x) if ($x ne $query);
+ $query = $x;
+
+ $x = &switchPerson($query);
+ push(@query, $x) if ($x ne $query);
+ $query = $x;
+
+ $query =~ s/\s+at\s*(\?*)$/$1/; # where is x at?
+ $query =~ s/^explain\s*(\?*)/$1/i; # explain x
+ $query = " $query "; # side whitespaces.
+
+ my $qregex = join '|', keys %{ $lang{'qWord'} };
+
+ # purge prefix question string.
+ if ($query =~ s/^ ($qregex)//i) {
+ $questionWord = lc($1);
+ }
+
+ if ($questionWord eq '' and $finalQMark and $addressed) {
+ $questionWord = 'where';
+ }
+ $query =~ s/^\s+|\s+$//g; # bleh. hacked.
+ push(@query, $query) if ($query ne $x);
+
+ if (&IsChanConf('factoidArguments') > 0) {
+ $result = &factoidArgs($query[0]);
+
+ return $result if (defined $result);
+ }
+
+ my @link;
+ for (my$i=0; $i<scalar @query; $i++) {
+ $query = $query[$i];
+ $result = &getReply($query);
+ next if (!defined $result or $result eq '');
+
+ # 'see also' factoid redirection support.
+
+ while ($result =~ /^see( also)? (.*?)\.?$/) {
+ my $link = $2;
+
+ # #debian@OPN was having problems with libstdc++ factoid
+ # redirection :) 20021116. -xk.
+ # hrm... allow recursive loops... next if statement handles
+ # that.
+ if (grep /^\Q$link\E$/i, @link) {
+ &status("recursive link found; bailing out.");
+ last;
+ }
+
+ if (scalar @link >= 5) {
+ &status("recursive link limit (5) reached.");
+ last;
+ }
+
+ push(@link, $link);
+ my $newr = &getReply($link);
+
+ # no such factoid. try commands
+ if (!defined $newr || $newr =~ /^0?$/) {
+ # support command redirection.
+ # recursive cmdHooks aswell :)
+ my $done = 0;
+ $done++ if &parseCmdHook($link);
+ $message = $link;
+ $done++ unless (&Modules());
+
+ return;
+ }
+ last if (!defined $newr or $newr eq '');
+ $result = $newr;
+ }
+
+ if (@link) {
+ &status("'$query' linked to: ".join(" => ", @link) );
+ }
+
+ if ($i != 0) {
+ &VERB("Question.pl: '$query[0]' did not exist; '$query[$i]' ($i) did",2);
+ }
+
+ return $result;
+ }
+
+ ### TODO: Use &Forker(); move function to Debian.pl
+ if (&IsChanConf('debianForFactoid') > 0) {
+ &loadMyModule('Debian');
+ $result = &Debian::DebianFind($query); # ???
+ ### TODO: debian module should tell, through shm, that it went
+ ### ok or not.
+### return $result if (defined $result);
+ }
+
+ if ($questionWord ne '' or $finalQMark) {
+ # if it has not been explicitly marked as a question
+ if ($addressed and $reply eq '') {
+ &status("notfound: <$who> ".join(' :: ', @query))
+ if ($finalQMark);
+
+ return '' unless (&IsParam('friendlyBots'));
+
+ foreach (split /\s+/, $param{'friendlyBots'}) {
+ &msg($_, ":INFOBOT:QUERY <$who> $query");
+ }
+ }
+ }
+
+ return $reply;
+}
+
+sub factoidArgs {
+ my($str) = @_;
+ my $result;
+
+ # to make it eleeter, split each arg and use "blah OR blah or BLAH"
+ # which will make it less than linear => quicker!
+ # TODO: cache this, update cache when altered. !!! !!! !!!
+# my $t = &timeget();
+ my ($first) = split(/\s+/, $str);
+
+ # ignore split to commands [dumb commands vs. factoids] (editing commands?)
+ return undef if $str =~ /\s+\=\~\s+s[\#\/\:]/;
+ my @list = &searchTable('factoids', 'factoid_key', 'factoid_key', "^cmd: $first ");
+# my $delta_time = &timedelta($t);
+# &DEBUG("factArgs: delta_time = $delta_time s");
+# &DEBUG("factArgs: list => ".scalar(@list) );
+
+ # from a design perspective, it's better to have the regex in
+ # the factoid key to reduce repetitive processing.
+
+ # it does not matter if it's not alphabetically sorted.
+ foreach (sort { length($b) <=> length($a) } @list) {
+ next if (/#DEL#/); # deleted.
+
+ s/^cmd: //i;
+# &DEBUG("factarg: '$str' =~ /^$_\$/");
+ my $arg = $_;
+
+ # eval (evil!) code. cleaned up courtesy of lear.
+ my @vals;
+ eval {
+ @vals = ($str =~ /^$arg$/i);
+ };
+
+ if ($@) {
+ &WARN("factargs: regex failed! '$str' =~ /^$_\$/");
+ next;
+ }
+
+ next unless (@vals);
+
+ if (defined $result) {
+ &WARN("factargs: '$_' matches aswell.");
+ next;
+ }
+
+# &DEBUG("vals => @vals");
+
+ &status("Question: factoid Arguments for '$str'");
+ # TODO: use getReply() - need to modify it :(
+ my $i = 0;
+ my $q = "cmd: $_";
+ my $r = &getFactoid($q);
+ if (!defined $r) {
+ &DEBUG("question: !result... should this happen?");
+ return;
+ }
+
+ # update stats. old mysql/sqlite don't do +1
+ my ($count) = &sqlSelect('factoids', 'requested_count', { factoid_key => $q });
+ $count++;
+ &sqlSet('factoids', {'factoid_key' => $q}, {
+ requested_by => $nuh,
+ requested_time => time(),
+ requested_count => $count
+ } );
+
+ # end of update stats.
+
+ $result = $r;
+
+ $result =~ s/^\((.*?)\): //;
+ my $vars = $1;
+
+ # start nasty hack to get partial &getReply() functionality.
+ $result = &SARit($result);
+
+ foreach ( split(',', $vars) ) {
+ my $val = $vals[$i];
+# &DEBUG("val => $val");
+
+ if (!defined $val) {
+ &status("factArgs: vals[$i] == undef; not SARing '$_' for '$str'");
+ next;
+ }
+
+ my $done = 0;
+ my $old = $result;
+ while (1) {
+# &DEBUG("Q: result => $result (1before)");
+ $result = &substVars($result,1);
+# &DEBUG("Q: result => $result (1after)");
+
+ last if ($old eq $result);
+ $old = $result;
+ $done++;
+ }
+
+ # hack.
+ $vals[$i] =~ s/^me$/$who/gi;
+
+# if (!$done) {
+ &status("factArgs: SARing '$_' to '$vals[$i]'.");
+ $result =~ s/\Q$_\E/$vals[$i]/g;
+# }
+ $i++;
+ }
+
+ # rest of nasty hack to get partial &getReply() functionality.
+ $result =~ s/^\s*<action>\s*(.*)/\cAACTION $1\cA/i;
+ $result =~ s/^\s*<reply>\s*//i;
+
+# well... lets go through all of them. not advisable if we have like
+# 1000 commands, heh.
+# return $result;
+ $cmdstats{'Factoid Commands'}++;
+ }
+
+ return $result;
+}
+
+1;
--- /dev/null
+###
+### Reply.pl: Kevin Lenzo (c) 1997
+###
+
+##
+# x is y === $lhs $mhs $rhs
+#
+# lhs - factoid.
+# mhs - verb.
+# rhs - factoid message.
+##
+
+# use strict; # TODO
+use POSIX qw(strftime);
+
+use vars qw($msgType $uh $lastWho $ident);
+use vars qw(%lang %lastWho);
+
+sub getReply {
+ my($message) = @_;
+ my($lhs,$mhs,$rhs);
+ my($reply, $count, $fauthor, $result, $factoid, $search, @searches);
+ $orig{message} = $message;
+
+ if (!defined $message or $message =~ /^\s*$/) {
+ &WARN("getR: message == NULL.");
+ return '';
+ }
+
+ $message =~ tr/A-Z/a-z/;
+
+ @searches = split(/\s+/, &getChanConfDefault('factoidSearch', '_default', $chan));
+ &::DEBUG("factoidSearch: $chan is: " . join(':', @searches));
+ # requesting the _default one, ignore factoidSearch
+ if ($message =~ /^_default\s+/) {
+ @searches = ('_default');
+ $message =~ s/^_default\s+//;
+ }
+
+ # check for factoids with each prefix
+ foreach $search (@searches) {
+ if ($search eq '$chan') {
+ $factoid = "$chan $message";
+ } elsif ($search eq '_default') {
+ $factoid = $message;
+ } else {
+ $factoid = "$search $message";
+ }
+ ($count, $fauthor, $result) = &sqlSelect('factoids',
+ "requested_count,created_by,factoid_value",
+ { factoid_key => $factoid }
+ );
+ last if ($result);
+ }
+
+ if ($result) {
+ $lhs = $message;
+ $mhs = 'is';
+ $rhs = $result;
+
+ return "\"$factoid\" $mhs \"$rhs\"" if ($literal);
+ } else {
+ return '';
+ }
+
+ # if there was a head...
+ my(@poss) = split '\|\|', $result;
+ $poss[0] =~ s/^\s//;
+ $poss[$#poss] =~ s/\s$//;
+
+ if (@poss > 1) {
+ $result = &getRandom(@poss);
+ $result =~ s/^\s*//;
+ }
+
+ $result = &SARit($result);
+
+ $reply = $result;
+ if ($result ne '') {
+ ### AT LAST, REPEAT PREVENTION CODE REMOVED IN FAVOUR OF GLOBAL
+ ### FLOOD REPETION AND PROTECTION. -20000124
+
+ # stats code.
+ ### FIXME: old mysql/sqlite doesn't support
+ ### "requested_count=requested_count+1".
+ $count++;
+ &sqlSet('factoids', {'factoid_key' => $factoid}, {
+ requested_by => $nuh,
+ requested_time => time(),
+ requested_count => $count
+ } );
+
+ # TODO: rename $real to something else!
+ my $real = 0;
+# my $author = &getFactInfo($lhs,'created_by') || '';
+# $real++ if ($author =~ /^\Q$who\E\!/);
+# $real++ if (&IsFlag('n'));
+ $real = 0 if ($msgType =~ /public/);
+
+ ### fix up the reply.
+ # only remove '<reply>'
+ if (!$real and $reply =~ s/^\s*<reply>\s*//i) {
+ # 'are' fix.
+ if ($reply =~ s/^are /$lhs are /i) {
+ &VERB("Reply.pl: el-cheapo 'are' fix executed.",2);
+ }
+
+ } elsif (!$real and $reply =~ s/^\s*<action>\s*(.*)/\cAACTION $1\cA/i) {
+ # only remove '<action>' and make it an action.
+ } else { # not a short reply
+
+ ### bot->bot reply.
+ if (exists $bots{$nuh} and $rhs !~ /^\s*$/) {
+ return "$lhs $mhs $rhs";
+ }
+
+ ### bot->person reply.
+ # result is random if separated by '||'.
+ # rhs is full factoid with '||'.
+ if ($mhs eq 'is') {
+ $reply = &getRandom(keys %{ $lang{'factoid'} });
+ $reply =~ s/##KEY/$lhs/;
+ $reply =~ s/##VALUE/$result/;
+ } else {
+ $reply = "$lhs $mhs $result";
+ }
+
+ if ($reply =~ s/^\Q$who\E is/you are/i) {
+ # fix the person.
+ } else {
+ if ($reply =~ /^you are / or $reply =~ / you are /) {
+ return if ($addressed);
+ }
+ }
+ }
+ }
+
+ # remove excessive beginning and end whitespaces.
+ $reply =~ s/^\s+|\s+$//g;
+
+ if ($reply =~ /^\s+$/) {
+ &DEBUG("Reply: Null factoid ($message)");
+ return '';
+ }
+
+ return $reply unless ($reply =~ /\$/);
+
+ ###
+ ### $ SUBSTITUTION.
+ ###
+
+ # don't evaluate if it has factoid arguments.
+# if ($message =~ /^cmd:/i) {
+# &status("Reply: not doing substVars (eval dollar vars)");
+# } else {
+ $reply = &substVars($reply,1);
+# }
+
+ $reply;
+}
+
+sub smart_replace {
+ my ($string) = @_;
+ my ($l,$r) = (0,0); # l = left, r = right.
+ my ($s,$t) = (0,0); # s = start, t = marker.
+ my $i = 0;
+ my $old = $string;
+ my @rand;
+
+ foreach (split //, $string) {
+
+ if ($_ eq "(") {
+ if (!$l and !$r) {
+ $s = $i;
+ $t = $i;
+ }
+
+ $l++;
+ $r--;
+ }
+
+ if ($_ eq ")") {
+ $r++;
+ $l--;
+
+ if (!$l and !$r) {
+ my $substr = substr($old,$s,$i-$s+1);
+ push(@rand, substr($old,$t+1,$i-$t-1) );
+
+ my $rand = $rand[rand @rand];
+# &status("SARing '$substr' to '$rand'.");
+ $string =~ s/\Q$substr\E/$rand/;
+ undef @rand;
+ }
+ }
+
+ if ($_ eq "|" and $l+$r== 0 and $l==1) {
+ push(@rand, substr($old,$t+1,$i-$t-1) );
+ $t = $i;
+ }
+
+ $i++;
+ }
+
+ if ($old eq $string) {
+ &WARN("smart_replace: no subst made. (string => $string)");
+ }
+
+ return $string;
+}
+
+sub SARit {
+ my($txt) = @_;
+ my $done = 0;
+
+ # (blah1|blah2)?
+ while ($txt =~ /\((.*?)\)\?/) {
+ my $str = $1;
+ if (rand() > 0.5) { # fix.
+ &status("Factoid transform: keeping '$str'.");
+ $txt =~ s/\(\Q$str\E\)\?/$str/;
+ } else { # remove
+ &status("Factoid transform: removing '$str'.");
+ $txt =~ s/\(\Q$str\E\)\?\s?//;
+ }
+ $done++;
+ last if ($done >= 10); # just in case.
+ }
+ $done = 0;
+
+ # EG: (0-32768) => 6325
+ ### TODO: (1-10,20-30,40) => 24
+ while ($txt =~ /\((\d+)-(\d+)\)/) {
+ my ($lower,$upper) = ($1,$2);
+ my $new = int(rand $upper-$lower) + $lower;
+
+ &status("SARing '$&' to '$new' (2).");
+ $txt =~ s/$&/$new/;
+ $done++;
+ last if ($done >= 10); # just in case.
+ }
+ $done = 0;
+
+ # EG: (blah1|blah2|blah3|) => blah1
+ while ($txt =~ /.*\((.*\|.*?)\).*/) {
+ $txt = &smart_replace($txt);
+
+ $done++;
+ last if ($done >= 10); # just in case.
+ }
+ &status("Reply.pl: $done SARs done.") if ($done);
+
+ # <URL></URL> type
+ #
+ while ($txt =~ /<URL>(.*)<\/URL>/){
+ &status("we have to norm this <URL></URL> stuff, SARing");
+ my $foobar = $1;
+ if ($foobar =~ m/(http:\/\/[^?]+)\?(.*)/){
+ my ($pig1,$pig2) = ($1,$2);
+ &status("SARing using URLencode");
+ $pig2=~s/([^\w])/sprintf("%%%02x",ord($1))/gie;
+ $foobar=$pig1."?".$pig2;
+ }
+ $txt =~ s/<URL>(.*)<\/URL>/$foobar/;
+ }
+ return $txt;
+}
+
+sub substVars {
+ my($reply,$flag) = @_;
+
+ # $date, $time, $day.
+ # TODO: support localtime.
+ my $date = strftime("%Y.%m.%d", gmtime());
+ $reply =~ s/\$date/$date/gi;
+ my $time = strftime("%k:%M:%S", gmtime());
+ $reply =~ s/\$time/$time/gi;
+ my $day = strftime("%A", gmtime());
+ $reply =~ s/\$day/$day/gi;
+
+ # support $ident when I have multiple nicks
+ my $mynick = $conn->nick() if $conn;
+
+ # dollar variables.
+ if ($flag) {
+ $reply =~ s/\$nick/$who/g;
+ $reply =~ s/\$who/$who/g; # backward compat.
+ }
+
+ if ($reply =~ /\$(user(name)?|host)/) {
+ my ($username, $hostname) = split /\@/, $uh;
+ $reply =~ s/\$user(name)?/$username/g;
+ $reply =~ s/\$host(name)?/$hostname/g;
+ }
+ $reply =~ s/\$chan(nel)?/$talkchannel/g;
+ if ($msgType =~ /public/) {
+ $reply =~ s/\$lastspeaker/$lastWho{$talkchannel}/g;
+ } else {
+ $reply =~ s/\$lastspeaker/$lastWho/g;
+ }
+
+ if ($reply =~ /\$rand/) {
+ my $rand = rand();
+
+ # $randnick.
+ if ($reply =~ /\$randnick/) {
+ my @nicks = keys %{ $channels{$chan}{''} };
+ my $randnick = $nicks[ int($rand*$#nicks) ];
+ $reply =~ s/\$randnick/$randnick/g;
+ }
+
+ # eg: $rand100.3
+ if ($reply =~ /\$rand(\d+)(\.(\d+))?/) {
+ my $max = $1;
+ my $dot = $3 || 0;
+ my $orig = $&;
+ #&DEBUG("dot => $dot, max => $max, rand=>$rand");
+ $rand = sprintf("%.*f", $dot, $rand*$max);
+
+ &DEBUG("swapping $orig to $rand");
+ $reply =~ s/\Q$orig\E/$rand/eg;
+ } else {
+ $reply =~ s/\$rand/$rand/g;
+ }
+ }
+
+ $reply =~ s/\$ident/$mynick/g;
+
+ if ($reply =~ /\$startTime/) {
+ my $time = scalar(gmtime $^T);
+ $reply =~ s/\$startTime/$time/;
+ }
+
+ if ($reply =~ /\$uptime/) {
+ my $uptime = &Time2String(time() - $^T);
+ $reply =~ s/\$uptime/$uptime/;
+ }
+
+ if ($reply =~ /\$factoids/) {
+ my $factoids = &countKeys('factoids');
+ $reply =~ s/\$factoids/$factoids/;
+ }
+
+ if ($reply =~ /\$Fupdate/) {
+ my $x = "\002$count{'Update'}\002 ".
+ &fixPlural('modification', $count{'Update'});
+ $reply =~ s/\$Fupdate/$x/;
+ }
+
+ if ($reply =~ /\$Fquestion/) {
+ my $x = "\002$count{'Question'}\002 ".
+ &fixPlural('question', $count{'Question'});
+ $reply =~ s/\$Fquestion/$x/;
+ }
+
+ if ($reply =~ /\$Fdunno/) {
+ my $x = "\002$count{'Dunno'}\002 ".
+ &fixPlural('dunno', $count{'Dunno'});
+ $reply =~ s/\$Fdunno/$x/;
+ }
+
+ $reply =~ s/\$memusage/$memusage/;
+
+ return $reply;
+}
+
+1;
--- /dev/null
+###
+### Statement.pl: Kevin Lenzo (c) 1997
+###
+
+##
+## doStatement --
+##
+## decide if $in is a statement, and if so,
+## - update the db
+## - return feedback statement
+##
+## otherwise return
+## - null for confused.
+##
+
+# use strict; # TODO
+
+sub doStatement {
+ my($in) = @_;
+
+ $in =~ s/\\(\S+)/\#$1\#/g; # fix the backslash.
+ $in =~ s/^no([, ]+)//i; # 'no, '.
+
+ # check if we need to be addressed and if we are
+ return unless ($learnok);
+
+ my($urlType) = '';
+
+ # prefix www with http:// and ftp with ftp://
+ $in =~ s/ www\./ http:\/\/www\./ig;
+ $in =~ s/ ftp\./ ftp:\/\/ftp\./ig;
+
+ $urlType = 'about' if ($in =~ /\babout:/i);
+ $urlType = 'afp' if ($in =~ /\bafp:/);
+ $urlType = 'file' if ($in =~ /\bfile:/);
+ $urlType = 'palace' if ($in =~ /\bpalace:/);
+ $urlType = 'phoneto' if ($in =~ /\bphone(to)?:/);
+ if ($in =~ /\b(news|http|ftp|gopher|telnet):\s*\/\/[\-\w]+(\.[\-\w]+)+/) {
+ $urlType = $1;
+ }
+
+ # acceptUrl.
+ if (&IsParam('acceptUrl')) {
+ if ($param{'acceptUrl'} eq 'REQUIRE') { # require url type.
+ return if ($urlType eq '');
+ } elsif ($param{'acceptUrl'} eq 'REJECT') {
+ &status("REJECTED URL entry") if (&IsParam('VERBOSITY'));
+ return unless ($urlType eq '');
+ } else {
+ # OPTIONAL
+ }
+ }
+
+ # learn statement. '$lhs is|are $rhs'
+ if ($in =~ /(^|\s)(is|are)(\s|$)/i) {
+ my($lhs, $mhs, $rhs) = ($`, $&, $');
+
+ # allows factoid arguments to be updated. -lear.
+ $lhs =~ s/^(cmd: )?(.*)/$1||'' . lc $2/e;
+
+ # discard article.
+ $lhs =~ s/^(the|da|an?)\s+//i;
+
+ # remove excessive initial and final whitespaces.
+ $lhs =~ s/^\s+|\s+$//g;
+ $mhs =~ s/^\s+|\s+$//g;
+ $rhs =~ s/^\s+|\s+$//g;
+
+ # break if either lhs or rhs is NULL.
+ if ($lhs eq '' or $rhs eq '') {
+ return "NOT-A-STATEMENT";
+ }
+
+ # lets check if it failed.
+ if (&validFactoid($lhs,$rhs) == 0) {
+ if ($addressed) {
+ &status("IGNORE statement: <$who> $message");
+ &performReply( &getRandom(keys %{ $lang{'confused'} }) );
+ }
+ return;
+ }
+
+ # uncomment to prevent HUNGRY learning of rhs with whitespace
+ #return if (!$addressed and $lhs =~ /\s+/);
+ &::DEBUG("doStatement: $in:$lhs:$mhs:$rhs");
+
+ &status("statement: <$who> $message");
+
+ # change "#*#" back to '*' because of '\' sar to '#blah#'.
+ $lhs =~ s/\#(\S+)\#/$1/g;
+ $rhs =~ s/\#(\S+)\#/$1/g;
+
+ $lhs =~ s/\?+\s*$//; # strip off '?'.
+
+ # verify the update statement whether there are any weird
+ # characters.
+ ### this can be simplified.
+ foreach (split //, $lhs.$rhs) {
+ my $ord = ord $_;
+ if ($ord > 170 and $ord < 220) {
+ &status("statement: illegal character '$_' $ord.");
+ &performAddressedReply("i'm not going to learn illegal characters");
+ return;
+ }
+ }
+
+ # success.
+ return if (&update($lhs, $mhs, $rhs));
+ }
+
+ return 'CONTINUE';
+}
+
+1;
--- /dev/null
+#
+# Update.pl: Add or modify factoids in the db.
+# Author: Kevin Lenzo
+# dms
+# Version: 19991209
+# Created: 1997
+#
+
+# use strict; # TODO
+
+sub update {
+ my($lhs, $mhs, $rhs) = @_;
+
+ for ($lhs) {
+ s/^i (heard|think) //i;
+ s/^some(one|1|body) said //i;
+ s/\s+/ /g;
+ }
+
+ # locked.
+ return if (&IsLocked($lhs) == 1);
+
+ # profanity.
+ if (&IsParam('profanityCheck') and &hasProfanity($rhs)) {
+ &performReply("please, watch your language.");
+ return 1;
+ }
+
+ # teaching.
+ if (&IsFlag('t') ne 't' && &IsFlag('o') ne 'o') {
+ &msg($who, "permission denied.");
+ &status("alert: $who wanted to teach me.");
+ return 1;
+ }
+
+ # invalid verb.
+ if ($mhs !~ /^(is|are)$/i) {
+ &ERROR("UNKNOWN verb: $mhs.");
+ return;
+ }
+
+ # check if the arguments are too long to be stored in our table.
+ my $toolong = 0;
+ $toolong++ if (length $lhs > $param{'maxKeySize'});
+ $toolong++ if (length $rhs > $param{'maxDataSize'});
+ if ($toolong) {
+ &performAddressedReply("that's too long");
+ return 1;
+ }
+
+ # also checking.
+ my $also = ($rhs =~ s/^-?also //i);
+ my $also_or = ($also and $rhs =~ s/\s+(or|\|\|)\s+//);
+
+ # factoid arguments handler.
+ # must start with a non-variable
+ if (&IsChanConf('factoidArguments') > 0 and $lhs =~ /^[^\$]+.*\$/) {
+ &status("Update: Factoid Arguments found.");
+ &status("Update: orig lhs => '$lhs'.");
+ &status("Update: orig rhs => '$rhs'.");
+
+ my @list;
+ my $count = 0;
+ $lhs =~ s/^/cmd: /;
+ while ($lhs =~ s/\$(\S+)/(.*?)/) {
+ push(@list, "\$$1");
+ $count++;
+ last if ($count >= 10);
+ }
+
+ if ($count >= 10) {
+ &msg($who, "error: could not SAR properly.");
+ &DEBUG("error: lhs => '$lhs' rhs => '$rhs'.");
+ return;
+ }
+
+ my $z = join(',',@list);
+ $rhs =~ s/^/($z): /;
+
+ &status("Update: new lhs => '$lhs' rhs => '$rhs'.");
+ }
+
+ # the fun begins.
+ my $exists = &getFactoid($lhs);
+
+ if (!$exists) {
+ # nice 'are' hack (or work-around).
+ if ($mhs =~ /^are$/i and $rhs !~ /<\S+>/) {
+ &status("Update: 'are' hack detected.");
+ $mhs = 'is';
+ $rhs = "<REPLY> are ". $rhs;
+ }
+
+ &status("enter: <$who> \'$lhs\' =$mhs=> \'$rhs\'");
+ $count{'Update'}++;
+
+ &performAddressedReply('okay');
+
+ &sqlInsert('factoids', {
+ created_by => $nuh,
+ created_time => time(), # modified time.
+ factoid_key => $lhs,
+ factoid_value => $rhs,
+ } );
+
+ if (!defined $rhs or $rhs eq '') {
+ &ERROR("Update: rhs1 == NULL.");
+ }
+
+ return 1;
+ }
+
+ # factoid exists.
+ if ($exists eq $rhs) {
+ # this catches the following situation: (right or wrong?)
+ # "test is test"
+ # "test is also test"
+ &performAddressedReply("i already had it that way");
+ return 1;
+ }
+
+ if ($also) { # 'is also'.
+ if ($exists =~ /^<REPLY> see /i) {
+ &TODO("Update.pl: append to linked factoid.");
+ }
+
+ if ($also_or) { # 'is also ||'.
+ $rhs = $exists.' || '.$rhs;
+ } else {
+# if ($exists =~ s/\,\s*$/, /) {
+ if ($exists =~ /\,\s*$/) {
+ &DEBUG("current has trailing comma, just append as is");
+ &DEBUG("Up: exists => $exists");
+ &DEBUG("Up: rhs => $rhs");
+ # $rhs =~ s/^\s+//;
+ # $rhs = $exists." ".$rhs; # keep comma.
+ }
+
+ if ($exists =~ /\.\s*$/) {
+ &DEBUG("current has trailing period, just append as is with 2 WS");
+ &DEBUG("Up: exists => $exists");
+ &DEBUG("Up: rhs => $rhs");
+ # $rhs =~ s/^\s+//;
+ # use ucfirst();?
+ # $rhs = $exists." ".$rhs; # keep comma.
+ }
+
+ if ($rhs =~ /^[A-Z]/) {
+ if ($rhs =~ /\w+\s*$/) {
+ &status("auto insert period to factoid.");
+ $rhs = $exists.". ".$rhs;
+ } else { # '?' or '.' assumed at end.
+ &status("orig factoid already had trailing symbol; not adding period.");
+ $rhs = $exists." ".$rhs;
+ }
+ } elsif ($exists =~ /[\,\.\-]\s*$/) {
+ &VERB("U: current has trailing symbols; inserting whitespace + new.",2);
+ $rhs = $exists." ".$rhs;
+ } elsif ($rhs =~ /^\./) {
+ &VERB("U: new text has ^.; appending directly",2);
+ $rhs = $exists.$rhs;
+ } else {
+ $rhs = $exists.', or '.$rhs;
+ }
+ }
+
+ # max length check again.
+ if (length $rhs > $param{'maxDataSize'}) {
+ if (length $rhs > length $exists) {
+ &performAddressedReply("that's too long");
+ return 1;
+ } else {
+ &status("Update: new length is still longer than maxDataSize but less than before, we'll let it go.");
+ }
+ }
+
+ &performAddressedReply('okay');
+
+ $count{'Update'}++;
+ &status("update: <$who> \'$lhs\' =$mhs=> \'$rhs\'; was \'$exists\'");
+ &sqlSet('factoids', {'factoid_key' => $lhs}, {
+ modified_by => $nuh,
+ modified_time => time(),
+ factoid_value => $rhs,
+ } );
+
+ if (!defined $rhs or $rhs eq '') {
+ &ERROR("Update: rhs1 == NULL.");
+ }
+ } else { # not 'also'
+
+ if (!$correction_plausible) { # "no, blah is ..."
+ if ($addressed) {
+ &performStrictReply("...but \002$lhs\002 is already something else...");
+ &status("FAILED update: <$who> \'$lhs\' =$mhs=> \'$rhs\'");
+ }
+ return 1;
+ }
+
+ my $author = &getFactInfo($lhs, 'created_by') || '';
+
+ if (IsFlag('m') ne 'm' && IsFlag('o') ne 'o' &&
+ $author !~ /^\Q$who\E\!/i
+ ) {
+ &msg($who, "you can't change that factoid.");
+ return 1;
+ }
+
+ &performAddressedReply('okay');
+
+ $count{'Update'}++;
+ &status("update: <$who> \'$lhs\' =$mhs=> \'$rhs\'; was \'$exists\'");
+
+ &sqlSet('factoids', {'factoid_key' => $lhs}, {
+ modified_by => $nuh,
+ modified_time => time(),
+ factoid_value => $rhs,
+ } );
+
+ if (!defined $rhs or $rhs eq '') {
+ &ERROR("Update: rhs1 == NULL.");
+ }
+ }
+
+ return 1;
+}
+
+1;
--- /dev/null
+#
+# Files.pl: Open and close, read and probably write files.
+# Author: dms
+# Version: v0.3 (20010120)
+# Created: 19991221
+#
+
+use strict;
+
+use vars qw(%lang %ircPort);
+use vars qw(@ircServers);
+use vars qw($bot_config_dir);
+
+# File: Language support.
+sub loadLang {
+ my ($file) = @_;
+ my $langCount = 0;
+ my $replyName;
+
+ if (!open(FILE, $file)) {
+ &ERROR("Failed reading lang file ($file): $!");
+ exit 0;
+ }
+
+ undef %lang; # for rehash.
+
+ while (<FILE>) {
+ chop;
+ if ($_ eq '' || /^#/) {
+ undef $replyName;
+ next;
+ }
+
+ if (!/^\s/) {
+ $replyName = $_;
+ next;
+ }
+
+ s/^[\s\t]+//g;
+ if (!$replyName) {
+ &status("loadLang: bad line ('$_')");
+ next;
+ }
+
+ $lang{$replyName}{$_} = 1;
+ $langCount++;
+ }
+ close FILE;
+
+ $file =~ s/^.*\///;
+ &status("Loaded $file ($langCount items)");
+}
+
+# File: Irc Servers list.
+sub loadIRCServers {
+ my ($file) = $bot_config_dir."/infobot.servers";
+ @ircServers = ();
+ %ircPort = ();
+
+ if (!open(FILE, $file)) {
+ &ERROR("Failed reading server list ($file): $!");
+ exit 0;
+ }
+
+ while (<FILE>) {
+ chop;
+ next if /^\s*$/;
+ next if /^[\#\[ ]/;
+
+ if (/^(\S+)(:(\d+))?$/) {
+ push(@ircServers,$1);
+ $ircPort{$1} = ($3 || 6667);
+ } else {
+ &status("loadIRCServers: invalid line => '$_'.");
+ }
+ }
+ close FILE;
+
+ $file =~ s/^.*\///;
+ &status("Loaded $file (". scalar(@ircServers) ." servers)");
+}
+
+1;
--- /dev/null
+#
+# Irc.pl: IRC core stuff.
+# Author: dms
+# Version: 20000126
+# NOTE: Based on code by Kevin Lenzo & Patrick Cole (c) 1997
+#
+
+use strict;
+
+no strict 'refs';
+no strict 'subs'; # IN/STDIN
+
+use vars qw(%floodjoin %nuh %dcc %cache %conns %channels %param %mask
+ %chanconf %orig %ircPort %ircstats %last %netsplit);
+use vars qw($irc $nickserv $conn $msgType $who $talkchannel
+ $addressed $postprocess);
+use vars qw($notcount $nottime $notsize $msgcount $msgtime $msgsize
+ $pubcount $pubtime $pubsize);
+use vars qw($b_blue $ob);
+use vars qw(@ircServers);
+
+#use open ':utf8';
+#use open ':std';
+
+$nickserv = 0;
+my $maxlinelen = 400;
+
+sub ircloop {
+ my $error = 0;
+ my $lastrun = 0;
+
+loop:;
+ while (my $host = shift @ircServers) {
+ # JUST IN CASE. irq was complaining about this.
+ if ($lastrun == time()) {
+ &DEBUG("ircloop: hrm... lastrun == time()");
+ $error++;
+ sleep 10;
+ next;
+ }
+
+ if (!defined $host) {
+ &DEBUG("ircloop: ircServers[x] = NULL.");
+ $lastrun = time();
+ next;
+ }
+ next unless (exists $ircPort{$host});
+
+ my $retval = &irc($host, $ircPort{$host});
+ next unless (defined $retval and $retval == 0);
+ $error++;
+
+ if ($error % 3 == 0 and $error != 0) {
+ &status("IRC: Could not connect.");
+ &status("IRC: ");
+ next;
+ }
+
+ if ($error >= 3*2) {
+ &status("IRC: cannot connect to any IRC servers; stopping.");
+ &shutdown();
+ exit 1;
+ }
+ }
+
+ &status("IRC: ok, done one cycle of IRC servers; trying again.");
+
+ &loadIRCServers();
+ goto loop;
+}
+
+sub irc {
+ my ($server,$port) = @_;
+
+ $irc = new Net::IRC;
+
+ # TODO: move all this to an sql table
+ my $iaddr = inet_aton($server);
+ my $paddr = sockaddr_in($port, $iaddr);
+ my $proto = getprotobyname('tcp');
+
+ # why was this here?
+ #select STDOUT;
+
+ # host->ip.
+ my $resolve;
+ if ($server =~ /\D$/) {
+ my $packed = scalar(gethostbyname($server));
+
+ if (!defined $packed) {
+ &status(" cannot resolve $server.");
+ return 0;
+ }
+
+ $resolve = inet_ntoa($packed);
+ ### warning in Sys/Hostname line 78???
+ ### caused inside Net::IRC?
+ }
+
+ my %args = (
+ Nick => $param{'ircNick'},
+ Server => $server,
+ Port => $port,
+ Ircname => $param{'ircName'},
+ );
+ $args{'LocalAddr'} = $param{'ircHost'} if ($param{'ircHost'});
+ $args{'Password'} = $param{'ircPasswd'} if ($param{'ircPasswd'});
+
+ foreach my $mynick (split ',', $param{'ircNick'}) {
+ &status("Connecting to port $port of server $server ($resolve) as $mynick ...");
+ $args{'Nick'} = $mynick;
+ $conns{$mynick} = $irc->newconn(%args);
+ if (!defined $conns{$mynick}) {
+ &ERROR("IRC: connection failed.");
+ &ERROR("add \"set ircHost 0.0.0.0\" to your config. If that does not work");
+ &ERROR("Please check /etc/hosts to see if you have a localhost line like:");
+ &ERROR("127.0.0.1 localhost localhost");
+ &ERROR("If this is still a problem, please contact the maintainer.");
+ }
+ $conns{$mynick}->maxlinelen($maxlinelen);
+ # handler stuff.
+ $conns{$mynick}->add_global_handler('caction', \&on_action);
+ $conns{$mynick}->add_global_handler('cdcc', \&on_dcc);
+ $conns{$mynick}->add_global_handler('cping', \&on_ping);
+ $conns{$mynick}->add_global_handler('crping', \&on_ping_reply);
+ $conns{$mynick}->add_global_handler('cversion', \&on_version);
+ $conns{$mynick}->add_global_handler('crversion', \&on_crversion);
+ $conns{$mynick}->add_global_handler('dcc_open', \&on_dcc_open);
+ $conns{$mynick}->add_global_handler('dcc_close', \&on_dcc_close);
+ $conns{$mynick}->add_global_handler('chat', \&on_chat);
+ $conns{$mynick}->add_global_handler('msg', \&on_msg);
+ $conns{$mynick}->add_global_handler('public', \&on_public);
+ $conns{$mynick}->add_global_handler('join', \&on_join);
+ $conns{$mynick}->add_global_handler('part', \&on_part);
+ $conns{$mynick}->add_global_handler('topic', \&on_topic);
+ $conns{$mynick}->add_global_handler('invite', \&on_invite);
+ $conns{$mynick}->add_global_handler('kick', \&on_kick);
+ $conns{$mynick}->add_global_handler('mode', \&on_mode);
+ $conns{$mynick}->add_global_handler('nick', \&on_nick);
+ $conns{$mynick}->add_global_handler('quit', \&on_quit);
+ $conns{$mynick}->add_global_handler('notice', \&on_notice);
+ $conns{$mynick}->add_global_handler('whoischannels', \&on_whoischannels);
+ $conns{$mynick}->add_global_handler('useronchannel', \&on_useronchannel);
+ $conns{$mynick}->add_global_handler('whois', \&on_whois);
+ $conns{$mynick}->add_global_handler('other', \&on_other);
+ $conns{$mynick}->add_global_handler('disconnect', \&on_disconnect);
+ $conns{$mynick}->add_global_handler([251,252,253,254,255], \&on_init);
+# $conns{$mynick}->add_global_handler(302, \&on_init); # userhost
+ $conns{$mynick}->add_global_handler(303, \&on_ison); # notify.
+ $conns{$mynick}->add_global_handler(315, \&on_endofwho);
+ $conns{$mynick}->add_global_handler(422, \&on_endofwho); # nomotd.
+ $conns{$mynick}->add_global_handler(324, \&on_modeis);
+ $conns{$mynick}->add_global_handler(333, \&on_topicinfo);
+ $conns{$mynick}->add_global_handler(352, \&on_who);
+ $conns{$mynick}->add_global_handler(353, \&on_names);
+ $conns{$mynick}->add_global_handler(366, \&on_endofnames);
+ $conns{$mynick}->add_global_handler(376, \&on_endofmotd); # on_connect.
+ $conns{$mynick}->add_global_handler(433, \&on_nick_taken);
+ $conns{$mynick}->add_global_handler(439, \&on_targettoofast);
+ # for proper joinnextChan behaviour
+ $conns{$mynick}->add_global_handler(471, \&on_chanfull);
+ $conns{$mynick}->add_global_handler(473, \&on_inviteonly);
+ $conns{$mynick}->add_global_handler(474, \&on_banned);
+ $conns{$mynick}->add_global_handler(475, \&on_badchankey);
+ $conns{$mynick}->add_global_handler(443, \&on_useronchan);
+ # end of handler stuff.
+ }
+
+ &clearIRCVars();
+
+ # change internal timeout value for scheduler.
+ $irc->{_timeout} = 10; # how about 60?
+ # Net::IRC debugging.
+ $irc->{_debug} = 1;
+
+ $ircstats{'Server'} = "$server:$port";
+
+ # works? needs to actually do something
+ # should likely listen on a tcp port instead
+ #$irc->addfh(STDIN, \&on_stdin, 'r');
+
+ &status("starting main loop");
+
+ $irc->start;
+}
+
+######################################################################
+######## IRC ALIASES IRC ALIASES IRC ALIASES IRC ALIASES #######
+######################################################################
+
+sub rawout {
+ my ($buf) = @_;
+ $buf =~ s/\n//gi;
+
+ # slow down a bit if traffic is 'high'.
+ # need to take into account time of last message sent.
+ if ($last{buflen} > 256 and length($buf) > 256) {
+ sleep 1;
+ }
+
+ $conn->sl($buf) if (&whatInterface() =~ /IRC/);
+
+ $last{buflen} = length($buf);
+}
+
+sub say {
+ my ($msg) = @_;
+ my $mynick = $conn->nick();
+ if (!defined $msg) {
+ $msg ||= 'NULL';
+ &WARN("say: msg == $msg.");
+ return;
+ }
+
+ if (&getChanConf('silent', $talkchannel)) {
+ &DEBUG("say: silent in $talkchannel, not saying $msg");
+ return;
+ }
+
+ if ( $postprocess ) {
+ undef $postprocess;
+ } elsif ($postprocess = &getChanConf('postprocess', $talkchannel)) {
+ &DEBUG("say: $postprocess $msg");
+ &parseCmdHook($postprocess . ' ' . $msg);
+ undef $postprocess;
+ return;
+ }
+
+ &status("<$mynick/$talkchannel> $msg");
+
+ return unless (&whatInterface() =~ /IRC/);
+
+ $msg = 'zero' if ($msg =~ /^0+$/);
+
+ my $t = time();
+
+ if ($t == $pubtime) {
+ $pubcount++;
+ $pubsize += length $msg;
+
+ my $i = &getChanConfDefault('sendPublicLimitLines', 3, $chan);
+ my $j = &getChanConfDefault('sendPublicLimitBytes', 1000, $chan);
+
+ if ( ($pubcount % $i) == 0 and $pubcount) {
+ sleep 1;
+ } elsif ($pubsize > $j) {
+ sleep 1;
+ $pubsize -= $j;
+ }
+
+ } else {
+ $pubcount = 0;
+ $pubtime = $t;
+ $pubsize = length $msg;
+ }
+
+ $conn->privmsg($talkchannel, $msg);
+}
+
+sub msg {
+ my ($nick, $msg) = @_;
+ if (!defined $nick) {
+ &ERROR("msg: nick == NULL.");
+ return;
+ }
+
+ if (!defined $msg) {
+ $msg ||= 'NULL';
+ &WARN("msg: msg == $msg.");
+ return;
+ }
+
+ # some say() end up here (eg +help)
+ if (&getChanConf('silent', $nick)) {
+ &DEBUG("msg: silent in $nick, not saying $msg");
+ return;
+ }
+
+ &status(">$nick< $msg");
+
+ return unless (&whatInterface() =~ /IRC/);
+ my $t = time();
+
+ if ($t == $msgtime) {
+ $msgcount++;
+ $msgsize += length $msg;
+
+ my $i = &getChanConfDefault('sendPrivateLimitLines', 3, $chan);
+ my $j = &getChanConfDefault('sendPrivateLimitBytes', 1000, $chan);
+ if ( ($msgcount % $i) == 0 and $msgcount) {
+ sleep 1;
+ } elsif ($msgsize > $j) {
+ sleep 1;
+ $msgsize -= $j;
+ }
+
+ } else {
+ $msgcount = 0;
+ $msgtime = $t;
+ $msgsize = length $msg;
+ }
+
+ $conn->privmsg($nick, $msg);
+}
+
+# Usage: &action(nick || chan, txt);
+sub action {
+ my $mynick = $conn->nick();
+ my ($target, $txt) = @_;
+ if (!defined $txt) {
+ &WARN("action: txt == NULL.");
+ return;
+ }
+
+ if (&getChanConf('silent', $target)) {
+ &DEBUG("action: silent in $target, not doing $txt");
+ return;
+ }
+
+ if (length $txt > 480) {
+ &status("action: txt too long; truncating.");
+ chop($txt) while (length $txt > 480);
+ }
+
+ &status("* $mynick/$target $txt");
+ $conn->me($target, $txt);
+}
+
+# Usage: ¬ice(nick || chan, txt);
+sub notice {
+ my ($target, $txt) = @_;
+ if (!defined $txt) {
+ &WARN("notice: txt == NULL.");
+ return;
+ }
+
+ &status("-$target- $txt");
+
+ my $t = time();
+
+ if ($t == $nottime) {
+ $notcount++;
+ $notsize += length $txt;
+
+ my $i = &getChanConfDefault('sendNoticeLimitLines', 3, $chan);
+ my $j = &getChanConfDefault('sendNoticeLimitBytes', 1000, $chan);
+
+ if ( ($notcount % $i) == 0 and $notcount) {
+ sleep 1;
+ } elsif ($notsize > $j) {
+ sleep 1;
+ $notsize -= $j;
+ }
+
+ } else {
+ $notcount = 0;
+ $nottime = $t;
+ $notsize = length $txt;
+ }
+
+ $conn->notice($target, $txt);
+}
+
+sub DCCBroadcast {
+ my ($txt,$flag) = @_;
+
+ ### FIXME: flag not supported yet.
+
+ foreach (keys %{ $dcc{'CHAT'} }) {
+ $conn->privmsg($dcc{'CHAT'}{$_}, $txt);
+ }
+}
+
+##########
+### perform commands.
+###
+
+# Usage: &performReply($reply);
+sub performReply {
+ my ($reply) = @_;
+
+ if (!defined $reply or $reply =~ /^\s*$/) {
+ &DEBUG("performReply: reply == NULL.");
+ return;
+ }
+
+ $reply =~ /([\.\?\s]+)$/;
+
+ # FIXME need real throttling....
+ if (length($reply) > $maxlinelen - 30) {
+ $reply = substr($reply, 0, $maxlinelen - 33);
+ $reply =~ s/ [^ ]*?$/ .../;
+ }
+ &checkMsgType($reply);
+
+ if ($msgType eq 'public') {
+ if (rand() < 0.5 or $reply =~ /[\.\?]$/) {
+ $reply = "$orig{who}: ".$reply;
+ } else {
+ $reply = "$reply, ".$orig{who};
+ }
+ &say($reply);
+
+ } elsif ($msgType eq 'private') {
+ if (rand() > 0.5) {
+ $reply = "$reply, ".$orig{who};
+ }
+ &msg($who, $reply);
+
+ } elsif ($msgType eq 'chat') {
+ if (!exists $dcc{'CHAT'}{$who}) {
+ &VERB("pSR: dcc{'CHAT'}{$who} does not exist.",2);
+ return;
+ }
+ $conn->privmsg($dcc{'CHAT'}{$who}, $reply);
+
+ } else {
+ &ERROR("PR: msgType invalid? ($msgType).");
+ }
+}
+
+# ...
+sub performAddressedReply {
+ return unless ($addressed);
+ &performReply(@_);
+}
+
+# Usage: &performStrictReply($reply);
+sub performStrictReply {
+ my ($reply) = @_;
+
+ # FIXME need real throttling....
+ if (length($reply) > $maxlinelen - 30) {
+ $reply = substr($reply, 0, $maxlinelen - 33);
+ $reply =~ s/ [^ ]*?$/ .../;
+ }
+ &checkMsgType($reply);
+
+ if ($msgType eq 'private') {
+ &msg($who, $reply);
+ } elsif ($msgType eq 'public') {
+ &say($reply);
+ } elsif ($msgType eq 'chat') {
+ &dccsay(lc $who, $reply);
+ } else {
+ &ERROR("pSR: msgType invalid? ($msgType).");
+ }
+}
+
+sub dccsay {
+ my($who, $reply) = @_;
+
+ if (!defined $reply or $reply =~ /^\s*$/) {
+ &WARN("dccsay: reply == NULL.");
+ return;
+ }
+
+ if (!exists $dcc{'CHAT'}{$who}) {
+ &VERB("pSR: dcc{'CHAT'}{$who} does not exist. (2)",2);
+ return;
+ }
+
+ &status("=>$who<= $reply"); # dcc chat.
+ $conn->privmsg($dcc{'CHAT'}{$who}, $reply);
+}
+
+sub dcc_close {
+ my($who) = @_;
+ my $type;
+
+ foreach $type (keys %dcc) {
+ &FIXME("dcc_close: $who");
+ my @who = grep /^\Q$who\E$/i, keys %{ $dcc{$type} };
+ next unless (scalar @who);
+ $who = $who[0];
+ &DEBUG("dcc_close... close $who!");
+ }
+}
+
+sub joinchan {
+ my ($chan, $key) = @_;
+ $key ||= &getChanConf('chankey', $chan);
+ $key ||= '';
+
+ # forgot for about 2 years to implement channel keys when moving
+ # over to Net::IRC...
+
+ # hopefully validChan is right.
+ if (&validChan($chan)) {
+ &status("join: already on $chan?");
+ }
+ #} else {
+ &status("joining $b_blue$chan $key$ob");
+
+ return if ($conn->join($chan, $key));
+ return if (&validChan($chan));
+
+ &DEBUG("joinchan: join failed. trying connect!");
+ &clearIRCVars();
+ $conn->connect();
+ #}
+}
+
+sub part {
+ my $chan;
+
+ foreach $chan (@_) {
+ next if ($chan eq '');
+ $chan =~ tr/A-Z/a-z/; # lowercase.
+
+ if ($chan !~ /^$mask{chan}$/) {
+ &WARN("part: chan is invalid ($chan)");
+ next;
+ }
+
+ &status("parting $chan");
+ if (!&validChan($chan)) {
+ &WARN("part: not on $chan; doing anyway");
+# next;
+ }
+
+ $conn->part($chan);
+ # deletion of $channels{chan} is done in &entryEvt().
+ }
+}
+
+sub mode {
+ my ($chan, @modes) = @_;
+ my $modes = join(" ", @modes);
+
+ if (&validChan($chan) == 0) {
+ &ERROR("mode: invalid chan => '$chan'.");
+ return;
+ }
+
+ &DEBUG("mode: MODE $chan $modes");
+
+ # should move to use Net::IRC's $conn->mode()... but too lazy.
+ rawout("MODE $chan $modes");
+}
+
+sub op {
+ my ($chan, @who) = @_;
+ my $os = 'o' x scalar(@who);
+
+ &mode($chan, "+$os @who");
+}
+
+sub deop {
+ my ($chan, @who) = @_;
+ my $os = 'o' x scalar(@who);
+
+ &mode($chan, "-$os ".@who);
+}
+
+sub kick {
+ my ($nick,$chan,$msg) = @_;
+ my (@chans) = ($chan eq '') ? (keys %channels) : lc($chan);
+ my $mynick = $conn->nick();
+
+ if ($chan ne '' and &validChan($chan) == 0) {
+ &ERROR("kick: invalid channel $chan.");
+ return;
+ }
+
+ $nick =~ tr/A-Z/a-z/;
+
+ foreach $chan (@chans) {
+ if (!&IsNickInChan($nick,$chan)) {
+ &status("kick: $nick is not on $chan.") if (scalar @chans == 1);
+ next;
+ }
+
+ if (!exists $channels{$chan}{o}{$mynick}) {
+ &status("kick: do not have ops on $chan :(");
+ next;
+ }
+
+ &status("Kicking $nick from $chan.");
+ $conn->kick($chan, $nick, $msg);
+ }
+}
+
+sub ban {
+ my ($mask,$chan) = @_;
+ my (@chans) = ($chan =~ /^\*?$/) ? (keys %channels) : lc($chan);
+ my $mynick = $conn->nick();
+ my $ban = 0;
+
+ if ($chan !~ /^\*?$/ and &validChan($chan) == 0) {
+ &ERROR("ban: invalid channel $chan.");
+ return;
+ }
+
+ foreach $chan (@chans) {
+ if (!exists $channels{$chan}{o}{$mynick}) {
+ &status("ban: do not have ops on $chan :(");
+ next;
+ }
+
+ &status("Banning $mask from $chan.");
+ &rawout("MODE $chan +b $mask");
+ $ban++;
+ }
+
+ return $ban;
+}
+
+sub unban {
+ my ($mask,$chan) = @_;
+ my (@chans) = ($chan =~ /^\*?$/) ? (keys %channels) : lc($chan);
+ my $mynick = $conn->nick();
+ my $ban = 0;
+
+ &DEBUG("unban: mask = $mask, chan = @chans");
+
+ foreach $chan (@chans) {
+ if (!exists $channels{$chan}{o}{$mynick}) {
+ &status("unBan: do not have ops on $chan :(");
+ next;
+ }
+
+ &status("Removed ban $mask from $chan.");
+ &rawout("MODE $chan -b $mask");
+ $ban++;
+ }
+
+ return $ban;
+}
+
+sub quit {
+ my ($quitmsg) = @_;
+ if (defined $conn) {
+ &status("QUIT " . $conn->nick() . " has quit IRC ($quitmsg)");
+ $conn->quit($quitmsg);
+ } else {
+ &WARN("quit: could not quit!");
+ }
+}
+
+sub nick {
+ my ($newnick) = @_;
+ my $mynick = $conn->nick();
+
+ if (!defined $newnick) {
+ &ERROR("nick: nick == NULL.");
+ return;
+ }
+
+ if (!defined $mynick) {
+ &WARN("nick: mynick == NULL.");
+ return;
+ }
+
+ my $bad = 0;
+ $bad++ if (exists $nuh{$newnick});
+ $bad++ if (&IsNickInAnyChan($newnick));
+
+ if ($bad) {
+ &WARN("Nick: not going to try to change from $mynick to $newnick. [". scalar(gmtime). "]");
+ # hrm... over time we lose track of our own nick.
+ #return;
+ }
+
+ if ($newnick =~ /^$mask{nick}$/) {
+ &status("nick: Changing nick from $mynick to $newnick");
+ # ->nick() will NOT change cause we are using rawout?
+ &rawout("NICK $newnick");
+ return 1;
+ }
+ &DEBUG("nick: failed... why oh why (mynick=$mynick, newnick=$newnick)");
+ return 0;
+}
+
+sub invite {
+ my($who, $chan) = @_;
+ # TODO: check if $who or $chan are invalid.
+
+ $conn->invite($who, $chan);
+}
+
+##########
+# Channel related functions...
+#
+
+# Usage: &joinNextChan();
+sub joinNextChan {
+ my $joined = 0;
+ foreach (sort keys %conns) {
+ $conn = $conns{$_};
+ my $mynick = $conn->nick();
+ my @join = getJoinChans(1);
+
+ if (scalar @join) {
+ my $chan = shift @join;
+ &joinchan($chan);
+
+ if (my $i = scalar @join) {
+ &status("joinNextChan: $mynick $i chans to join.");
+ }
+ $joined = 1;
+ }
+ }
+ return if $joined;
+
+ if (exists $cache{joinTime}) {
+ my $delta = time() - $cache{joinTime} - 5;
+ my $timestr = &Time2String($delta);
+ # FIXME: @join should be @in instead (hacked to 10)
+ #my $rate = sprintf("%.1f", $delta / @in);
+ my $rate = sprintf("%.1f", $delta / 10);
+ delete $cache{joinTime};
+
+ &status("time taken to join all chans: $timestr; rate: $rate sec/join");
+ }
+
+ # chanserv check: global channels, in case we missed one.
+ foreach ( &ChanConfList('chanServ_ops') ) {
+ &chanServCheck($_);
+ }
+}
+
+# Usage: &getNickInChans($nick);
+sub getNickInChans {
+ my ($nick) = @_;
+ my @array;
+
+ foreach (keys %channels) {
+ next unless (grep /^\Q$nick\E$/i, keys %{ $channels{$_}{''} });
+ push(@array, $_);
+ }
+
+ return @array;
+}
+
+# Usage: &getNicksInChan($chan);
+sub getNicksInChan {
+ my ($chan) = @_;
+ my @array;
+
+ return keys %{ $channels{$chan}{''} };
+}
+
+sub IsNickInChan {
+ my ($nick,$chan) = @_;
+
+ $chan =~ tr/A-Z/a-z/; # not lowercase unfortunately.
+
+ if ($chan =~ /^$/) {
+ &DEBUG("INIC: chan == NULL.");
+ return 0;
+ }
+
+ if (&validChan($chan) == 0) {
+ &ERROR("INIC: invalid channel $chan.");
+ return 0;
+ }
+
+ if (grep /^\Q$nick\E$/i, keys %{ $channels{$chan}{''} }) {
+ return 1;
+ } else {
+ foreach (keys %channels) {
+ next unless (/[A-Z]/);
+ &DEBUG("iNIC: hash channels contains mixed cased chan!!!");
+ }
+ return 0;
+ }
+}
+
+sub IsNickInAnyChan {
+ my ($nick) = @_;
+ my $chan;
+
+ foreach $chan (keys %channels) {
+ next unless (grep /^\Q$nick\E$/i, keys %{ $channels{$chan}{''} });
+ return 1;
+ }
+ return 0;
+}
+
+# Usage: &validChan($chan);
+sub validChan {
+ # TODO: use $c instead?
+ my ($chan) = @_;
+
+ if (!defined $chan or $chan =~ /^\s*$/) {
+ return 0;
+ }
+
+ if (lc $chan ne $chan) {
+ &WARN("validChan: lc chan != chan. ($chan); fixing.");
+ $chan =~ tr/A-Z/a-z/;
+ }
+
+ # it's possible that this check creates the hash if empty.
+ if (defined $channels{$chan} or exists $channels{$chan}) {
+ if ($chan =~ /^_?default$/) {
+# &WARN("validC: chan cannot be _default! returning 0!");
+ return 0;
+ }
+
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+###
+# Usage: &delUserInfo($nick,@chans);
+sub delUserInfo {
+ my ($nick,@chans) = @_;
+ my ($mode,$chan);
+
+ foreach $chan (@chans) {
+ foreach $mode (keys %{ $channels{$chan} }) {
+ # use grep here?
+ next unless (exists $channels{$chan}{$mode}{$nick});
+
+ delete $channels{$chan}{$mode}{$nick};
+ }
+ }
+}
+
+sub clearChanVars {
+ my ($chan) = @_;
+
+ delete $channels{$chan};
+}
+
+sub clearIRCVars {
+ undef %channels;
+ undef %floodjoin;
+
+ $cache{joinTime} = time();
+}
+
+sub getJoinChans {
+ my($show) = @_;
+
+ my @in;
+ my @skip;
+ my @join;
+
+ # can't join any if not connected
+ return @join if (!$conn);
+
+ my $nick = $conn->nick();
+
+ foreach (keys %chanconf) {
+ next if ($_ eq '_default');
+
+ my $skip = 0;
+ my $val = $chanconf{$_}{autojoin};
+
+ if (defined $val) {
+ $skip++ if ($val eq '0');
+ if ($val eq '1') {
+ # convert old +autojoin to autojoin <nick>
+ $val = lc $nick;
+ $chanconf{$_}{autojoin} = $val;
+ }
+ $skip++ if (lc $val ne lc $nick);
+ } else {
+ $skip++;
+ }
+
+ if ($skip) {
+ push(@skip, $_);
+ } else {
+ if (defined $channels{$_} or exists $channels{$_}) {
+ push(@in, $_);
+ } else {
+ push(@join, $_);
+ }
+ }
+ }
+
+ my $str;
+ #$str .= ' in:' . join(',', sort @in) if scalar @in;
+ #$str .= ' skip:' . join(',', sort @skip) if scalar @skip;
+ $str .= ' join:' . join(',', sort @join) if scalar @join;
+
+ &status("Chans: ($nick)$str") if ($show);
+
+ return sort @join;
+}
+
+sub closeDCC {
+# &DEBUG("closeDCC called.");
+ my $type;
+
+ foreach $type (keys %dcc) {
+ next if ($type ne uc($type));
+
+ my $nick;
+ foreach $nick (keys %{ $dcc{$type} }) {
+ next unless (defined $nick);
+ &status("DCC CHAT: closing DCC $type to $nick.");
+ next unless (defined $dcc{$type}{$nick});
+
+ my $ref = $dcc{$type}{$nick};
+ &dccsay($nick, "bye bye, $nick") if ($type =~ /^chat$/i);
+ $dcc{$type}{$nick}->close();
+ delete $dcc{$type}{$nick};
+ &DEBUG("after close for $nick");
+ }
+ delete $dcc{$type};
+ }
+}
+
+sub joinfloodCheck {
+ my($who,$chan,$userhost) = @_;
+
+ return unless (&IsChanConf('joinfloodCheck') > 0);
+
+ if (exists $netsplit{lc $who}) { # netsplit join.
+ &DEBUG("joinfloodCheck: $who was in netsplit; not checking.");
+ }
+
+ if (exists $floodjoin{$chan}{$who}{Time}) {
+ &WARN("floodjoin{$chan}{$who} already exists?");
+ }
+
+ $floodjoin{$chan}{$who}{Time} = time();
+ $floodjoin{$chan}{$who}{Host} = $userhost;
+
+ ### Check...
+ foreach (keys %floodjoin) {
+ my $c = $_;
+ my $count = scalar keys %{ $floodjoin{$c} };
+ next unless ($count > 5);
+ &DEBUG("joinflood: count => $count");
+
+ my $time;
+ foreach (keys %{ $floodjoin{$c} }) {
+ my $t = $floodjoin{$c}{$_}{Time};
+ next unless (defined $t);
+
+ $time += $t;
+ }
+ &DEBUG("joinflood: time => $time");
+ $time /= $count;
+
+ &DEBUG("joinflood: new time => $time");
+ }
+
+ ### Clean it up.
+ my $delete = 0;
+ my $time = time();
+ foreach $chan (keys %floodjoin) {
+ foreach $who (keys %{ $floodjoin{$chan} }) {
+ my $t = $floodjoin{$chan}{$who}{Time};
+ next unless (defined $t);
+
+ my $delta = $time - $t;
+ next unless ($delta > 10);
+
+ delete $floodjoin{$chan}{$who};
+ $delete++;
+ }
+ }
+
+ &DEBUG("joinfloodCheck: $delete deleted.") if ($delete);
+}
+
+sub getHostMask {
+ my($n) = @_;
+
+ if (exists $nuh{$n}) {
+ return &makeHostMask($nuh{$n});
+ } else {
+ $cache{on_who_Hack} = 1;
+ $conn->who($n);
+ }
+}
+
+1;
--- /dev/null
+#
+# IrcHooks.pl: IRC Hooks stuff.
+# Author: dms
+# Version: 20010413
+# Created: 20010413
+# NOTE: Based on code by Kevin Lenzo & Patrick Cole (c) 1997
+#
+
+#######################################################################
+####### IRC HOOK HELPERS IRC HOOK HELPERS IRC HOOK HELPERS ########
+#######################################################################
+
+#####
+# Usage: &hookMode($nick, $modes, @targets);
+sub hookMode {
+ my ($nick, $modes, @targets) = @_;
+ my $parity = 0;
+
+ if ($chan =~ tr/A-Z/a-z/) {
+ &VERB("hookMode: cased $chan.",2);
+ }
+
+ my $mode;
+ foreach $mode (split(//, $modes)) {
+ # sign.
+ if ($mode =~ /[-+]/) {
+ $parity = 1 if ($mode eq "+");
+ $parity = 0 if ($mode eq "-");
+ next;
+ }
+
+ # mode with target.
+ if ($mode =~ /[bklov]/) {
+ my $target = shift @targets;
+
+ if ($parity) {
+ $chanstats{$chan}{'Op'}++ if ($mode eq 'o');
+ $chanstats{$chan}{'Ban'}++ if ($mode eq 'b');
+ } else {
+ $chanstats{$chan}{'Deop'}++ if ($mode eq 'o');
+ $chanstats{$chan}{'Unban'}++ if ($mode eq 'b');
+ }
+
+ # modes w/ target affecting nick => cache it.
+ if ($mode =~ /[bov]/) {
+ $channels{$chan}{$mode}{$target}++ if $parity;
+ delete $channels{$chan}{$mode}{$target} if !$parity;
+
+ # lets do some custom stuff.
+ if ($mode eq 'o' and $parity) {
+ if ($nick eq 'ChanServ' and $target =~ /^\Q$ident\E$/i) {
+ &VERB("hookmode: chanserv deopped us! asking",2);
+ &chanServCheck($chan);
+ }
+
+ &chanLimitVerify($chan);
+ }
+ }
+
+ if ($mode =~ /[l]/) {
+ $channels{$chan}{$mode} = $target if $parity;
+ delete $channels{$chan}{$mode} if !$parity;
+ }
+ }
+
+ # important channel modes, targetless.
+ if ($mode =~ /[mt]/) {
+ $channels{$chan}{$mode}++ if $parity;
+ delete $channels{$chan}{$mode} if !$parity;
+ }
+ }
+}
+
+sub hookMsg {
+ ($msgType, $chan, $who, $message) = @_;
+ my $skipmessage = 0;
+ $addressed = 0;
+ $addressedother = 0;
+ $orig{message} = $message;
+ $orig{who} = $who;
+ $addrchar = 0;
+
+ $message =~ s/[\cA-\c_]//ig; # strip control characters
+ $message =~ s/^\s+//; # initial whitespaces.
+ $who =~ tr/A-Z/a-z/; # lowercase.
+ my $mynick = $conn->nick();
+
+ &showProc();
+
+ # addressing.
+ if ($msgType =~ /private/) {
+ # private messages.
+ $addressed = 1;
+ if (&IsChanConf('addressCharacter') > 0) {
+ $addressCharacter = getChanConf('addressCharacter');
+ if ($message =~ s/^\Q$addressCharacter\E//) {
+ &msg($who, "The addressCharacter \"$addressCharacter\" is to get my attention in a normal channel. Please leave it off when messaging me directly.");
+ }
+ }
+ } else {
+ # public messages.
+ # addressing revamped by the xk.
+ ### below needs to be fixed...
+ if (&IsChanConf('addressCharacter') > 0) {
+ $addressCharacter = getChanConf('addressCharacter');
+ if ($message =~ s/^\Q$addressCharacter\E//) {
+ $addrchar = 1;
+ $addressed = 1;
+ }
+ }
+
+ if ($message =~ /^($mask{nick})([\;\:\>\, ]+) */) {
+ my $newmessage = $';
+ if ($1 =~ /^\Q$mynick\E$/i) {
+ $message = $newmessage;
+ $addressed = 1;
+ } else {
+ # ignore messages addressed to other people or unaddressed.
+ $skipmessage++ if ($2 ne '' and $2 !~ /^ /);
+ }
+ }
+ }
+
+ # Determine floodwho.
+ my $c = '_default';
+ if ($msgType =~ /public/i) {
+ # public.
+ $floodwho = $c = lc $chan;
+ } elsif ($msgType =~ /private/i) {
+ # private.
+ $floodwho = lc $who;
+ } else {
+ # dcc?
+ &FIXME("floodwho = ???");
+ }
+
+ my $val = &getChanConfDefault('floodRepeat', "2:5", $c);
+ my ($count, $interval) = split /:/, $val;
+
+ # flood repeat protection.
+ if ($addressed) {
+ my $time = $flood{$floodwho}{$message} || 0;
+
+ if (!&IsFlag('o') and $msgType eq 'public' and (time() - $time < $interval)) {
+ ### public != personal who so the below is kind of pointless.
+ my @who;
+ foreach (keys %flood) {
+ next if (/^\Q$floodwho\E$/);
+ next if (defined $chan and /^\Q$chan\E$/);
+
+ push(@who, grep /^\Q$message\E$/i, keys %{ $flood{$_} });
+ }
+
+ return if ($lobotomized);
+
+ if (!scalar @who) {
+ push(@who,'Someone');
+ }
+ &msg($who,join(' ', @who)." already said that ". (time - $time) ." seconds ago" );
+
+ ### TODO: delete old floodwarn{} keys.
+ my $floodwarn = 0;
+ if (!exists $floodwarn{$floodwho}) {
+ $floodwarn++;
+ } else {
+ $floodwarn++ if (time() - $floodwarn{$floodwho} > $interval);
+ }
+
+ if ($floodwarn) {
+ &status("FLOOD repetition detected from $floodwho.");
+ $floodwarn{$floodwho} = time();
+ }
+
+ return;
+ }
+
+ if ($addrchar) {
+ &status("$b_cyan$who$ob is short-addressing $mynick");
+ } elsif ($msgType eq 'private') { # private.
+ &status("$b_cyan$who$ob is /msg'ing $mynick");
+ } else { # public?
+ &status("$b_cyan$who$ob is addressing $mynick");
+ }
+
+ $flood{$floodwho}{$message} = time();
+ } elsif ($msgType eq 'public' and &IsChanConf('kickOnRepeat') > 0) {
+ # unaddressed, public only.
+
+ ### TODO: use a separate "short-time" hash.
+ my @data;
+ @data = keys %{ $flood{$floodwho} } if (exists $flood{$floodwho});
+ }
+
+ $val = &getChanConfDefault('floodMessages', "5:30", $c);
+ ($count, $interval) = split /:/, $val;
+
+ # flood overflow protection.
+ if ($addressed) {
+ foreach (keys %{ $flood{$floodwho} }) {
+ next unless (time() - $flood{$floodwho}{$_} > $interval);
+ delete $flood{$floodwho}{$_};
+ }
+
+ my $i = scalar keys %{ $flood{$floodwho} };
+ if ($i > $count) {
+ my $expire = $param{'ignoreAutoExpire'} || 5;
+
+# &msg($who,"overflow of messages ($i > $count)");
+ &msg($who,"Too many queries from you, ignoring for $expire minutes.");
+ &status("FLOOD overflow detected from $floodwho; ignoring");
+
+ &ignoreAdd("*!$uh", $chan, $expire, "flood overflow auto-detected.");
+ return;
+ }
+
+ $flood{$floodwho}{$message} = time();
+ }
+
+ my @ignore;
+ if ($msgType =~ /public/i) { # public.
+ $talkchannel = $chan;
+ &status("<$orig{who}/$chan> $orig{message}");
+ push(@ignore, keys %{ $ignore{$chan} }) if (exists $ignore{$chan});
+ } elsif ($msgType =~ /private/i) { # private.
+ &status("[$orig{who}] $orig{message}");
+ $talkchannel = undef;
+ $chan = '_default';
+ } else {
+ &DEBUG("unknown msgType => $msgType.");
+ }
+ push(@ignore, keys %{ $ignore{'*'} }) if (exists $ignore{'*'});
+
+ if ((!$skipmessage or &IsChanConf('seenStoreAll') > 0) and
+ &IsChanConf('sed') > 0 and &IsChanConf('seen') > 0 and
+ $msgType =~ /public/ and
+ $orig{message} =~ /^s\/([^;\/]*)\/([^;\/]*)\/([g]*)$/) {
+ my $sedmsg = $seencache{$who}{'msg'};
+ eval "\$sedmsg =~ s/\Q$1\E/\Q$2\E/$3;";
+ $sedmsg =~ s/^(.{255}).*$/$1.../; # 255 char max to prevent flood
+
+ if ($sedmsg ne $seencache{$who}{'msg'}) {
+ &DEBUG("sed \"" . $orig{message} . "\" \"" .
+ $seencache{$who}{'msg'} . "\" \"" . $sedmsg. "\"");
+ &msg($talkchannel, "$orig{who} meant: $sedmsg");
+ }
+ } elsif ((!$skipmessage or &IsChanConf('seenStoreAll') > 0) and
+ &IsChanConf('seen') > 0 and $msgType =~ /public/) {
+ $seencache{$who}{'time'} = time();
+ $seencache{$who}{'nick'} = $orig{who};
+ $seencache{$who}{'host'} = $uh;
+ $seencache{$who}{'chan'} = $talkchannel;
+ $seencache{$who}{'msg'} = $orig{message};
+ $seencache{$who}{'msgcount'}++;
+ }
+ if (&IsChanConf('minVolunteerLength') > 0) {
+ # FIXME hack to treat unaddressed as if using addrchar
+ $addrchar = 1;
+ }
+ return if ($skipmessage);
+ return unless ($addrchar or $addressed);
+
+ foreach (@ignore) {
+ s/\*/\\S*/g;
+
+ next unless (eval { $nuh =~ /^$_$/i } );
+
+ # better to ignore an extra message than to allow one to get
+ # through, although it would be better to go through ignore
+ # checking again.
+ if (time() - ($cache{ignoreCheckTime} || 0) > 60) {
+ &ignoreCheck();
+ }
+
+ &status("IGNORE <$who> $message");
+ return;
+ }
+
+ if (defined $nuh) {
+ if (!defined $userHandle) {
+ &DEBUG("line 1074: need verifyUser?");
+ &verifyUser($who, $nuh);
+ }
+ } else {
+ &DEBUG("hookMsg: 'nuh' not defined?");
+ }
+
+### For extra debugging purposes...
+ if ($_ = &process()) {
+# &DEBUG("IrcHooks: process returned '$_'.");
+ }
+
+ # hack to remove +o from ppl with +O flag.
+ if (exists $users{$userHandle} && exists $users{$userHandle}{FLAGS} &&
+ $users{$userHandle}{FLAGS} =~ /O/
+ ) {
+ $users{$userHandle}{FLAGS} =~ s/o//g;
+ }
+
+ return;
+}
+
+# this is basically run on on_join or on_quit
+sub chanLimitVerify {
+ my($c) = @_;
+ $chan = $c;
+ my $l = $channels{$chan}{'l'};
+
+ return unless (&IsChanConf('chanlimitcheck') > 0);
+
+ if (scalar keys %netsplit) {
+ &WARN("clV: netsplit active (1, chan = $chan); skipping.");
+ return;
+ }
+
+ if (!defined $l) {
+ &DEBUG("$chan: running chanlimitCheck from chanLimitVerify.");
+ &chanlimitCheck();
+ return;
+ }
+
+ # only change it if it's not set.
+ my $plus = &getChanConfDefault('chanlimitcheckPlus', 5, $chan);
+ my $count = scalar(keys %{ $channels{$chan}{''} });
+ my $int = &getChanConfDefault('chanlimitcheckInterval', 10, $chan);
+
+ my $delta = $count + $plus - $l;
+# $delta =~ s/^\-//;
+
+ if ($plus <= 3) {
+ &WARN("clc: stupid to have plus at $plus, fix it!");
+ }
+
+ if (exists $cache{chanlimitChange}{$chan}) {
+ if (time() - $cache{chanlimitChange}{$chan} < $int*60) {
+ return;
+ }
+ }
+
+ &chanServCheck($chan);
+
+ ### TODO: unify code with chanlimitcheck()
+ return if ($delta > 5);
+
+ &status("clc: big change in limit for $chan ($delta);".
+ "going for it. (was: $l; now: ".($count+$plus).")");
+
+ $conn->mode($chan, "+l", $count+$plus);
+ $cache{chanlimitChange}{$chan} = time();
+}
+
+sub chanServCheck {
+ ($chan) = @_;
+
+ if (!defined $chan or $chan =~ /^\s*$/) {
+ &WARN("chanServCheck: chan == NULL.");
+ return 0;
+ }
+
+ if ($chan =~ tr/A-Z/a-z/) {
+ &DEBUG("chanServCheck: lowercased chan ($chan)");
+ }
+
+ if (! &IsChanConf('chanServ_ops') > 0) {
+ return 0;
+ }
+
+ &VERB("chanServCheck($chan) called.",2);
+
+ if ( &IsParam('nickServ_pass') and !$nickserv) {
+ $conn->who('NickServ');
+ return 0;
+ }
+
+ # check for first hash then for next hash.
+ # TODO: a function for &ischanop()? &isvoice()?
+ if (exists $channels{$chan} and exists $channels{$chan}{'o'}{$ident}) {
+ return 0;
+ }
+
+ &status("ChanServ ==> Requesting ops for $chan. (chanServCheck)");
+ &rawout("PRIVMSG ChanServ :OP $chan $ident");
+ return 1;
+}
+
+1;
--- /dev/null
+#
+# IrcHooks.pl: IRC Hooks stuff.
+# Author: dms
+# Version: 20000126
+# NOTE: Based on code by Kevin Lenzo & Patrick Cole (c) 1997
+#
+use vars qw(%chanconf);
+
+# GENERIC. TO COPY.
+sub on_generic {
+ $conn = shift(@_);
+ my ($event) = @_;
+ my $nick = $event->nick();
+ my $chan = ($event->to)[0];
+
+ &DEBUG("on_generic: nick => '$nick'.");
+ &DEBUG("on_generic: chan => '$chan'.");
+
+ foreach ($event->args) {
+ &DEBUG("on_generic: args => '$_'.");
+ }
+}
+
+sub on_action {
+ $conn = shift(@_);
+ my ($event) = @_;
+ my ($nick, @args) = ($event->nick, $event->args);
+ my $chan = ($event->to)[0];
+
+ shift @args;
+
+ if ($chan eq $ident) {
+ &status("* [$nick] @args");
+ } else {
+ &status("* $nick/$chan @args");
+ }
+}
+
+sub on_chat {
+ $conn = shift(@_);
+ my ($event) = @_;
+ my $msg = ($event->args)[0];
+ my $sock = ($event->to)[0];
+ my $nick = lc $event->nick();
+
+ if (!exists $nuh{$nick}) {
+ &DEBUG("chat: nuh{$nick} doesn't exist; trying WHOIS .");
+ $conn->whois($nick);
+ return;
+ }
+
+ ### set vars that would have been set in hookMsg.
+ $userHandle = ''; # reset.
+ $who = lc $nick;
+ $message = $msg;
+ $orig{who} = $nick;
+ $orig{message} = $msg;
+ $nuh = $nuh{$who};
+ $uh = (split /\!/, $nuh)[1];
+ $h = (split /\@/, $uh)[1];
+ $addressed = 1;
+ $msgType = 'chat';
+
+ if (!exists $dcc{'CHATvrfy'}{$nick}) {
+ $userHandle = &verifyUser($who, $nuh);
+ my $crypto = $users{$userHandle}{PASS};
+ my $success = 0;
+
+ if ($userHandle eq '_default') {
+ &WARN("DCC CHAT: _default/guest not allowed.");
+ return;
+ }
+
+ ### TODO: prevent users without CRYPT chatting.
+ if (!defined $crypto) {
+ &TODO("dcc close chat");
+ &msg($who, "nope, no guest logins allowed...");
+ return;
+ }
+
+ if (&ckpasswd($msg, $crypto)) {
+ # stolen from eggdrop.
+ $conn->privmsg($sock, "Connected to $ident");
+ $conn->privmsg($sock, "Commands start with '.' (like '.quit' or '.help')");
+ $conn->privmsg($sock, "Everything else goes out to the party line.");
+
+ &dccStatus(2) unless (exists $sched{'dccStatus'}{RUNNING});
+
+ $success++;
+
+ } else {
+ &status("DCC CHAT: incorrect pass; closing connection.");
+ &DEBUG("chat: sock => '$sock'.");
+### $sock->close();
+ delete $dcc{'CHAT'}{$nick};
+ &FIXME("chat: after closing sock.");
+ ### BUG: close seizes bot. why?
+ }
+
+ if ($success) {
+ &status("DCC CHAT: user $nick is here!");
+ &DCCBroadcast("*** $nick ($uh) joined the party line.");
+
+ $dcc{'CHATvrfy'}{$nick} = $userHandle;
+
+ return if ($userHandle eq '_default');
+
+ &dccsay($nick,"Flags: $users{$userHandle}{FLAGS}");
+ }
+
+ return;
+ }
+
+ &status("$b_red=$b_cyan$who$b_red=$ob $message");
+
+ if ($message =~ s/^\.//) { # dcc chat commands.
+ ### TODO: make use of &Forker(); here?
+ &loadMyModule('UserDCC');
+
+ &DCCBroadcast("#$who# $message",'m');
+
+ my $retval = &userDCC();
+ return unless (defined $retval);
+ return if ($retval eq $noreply);
+
+ $conn->privmsg($dcc{'CHAT'}{$who}, "Invalid command.");
+
+ } else { # dcc chat arena.
+
+ foreach (keys %{ $dcc{'CHAT'} }) {
+ $conn->privmsg($dcc{'CHAT'}{$_}, "<$who> $orig{message}");
+ }
+ }
+
+ return 'DCC CHAT MESSAGE';
+}
+
+# is there isoff? how do we know if someone signs off?
+sub on_ison {
+ $conn = shift(@_);
+ my ($event) = @_;
+ my $x1 = ($event->args)[0];
+ my $x2 = ($event->args)[1];
+ $x2 =~ s/\s$//;
+
+ &DEBUG("on_ison: x1 = '$x1', x2 => '$x2'");
+}
+
+sub on_endofmotd {
+ $conn = shift(@_);
+
+ # update IRCStats.
+ $ident = $conn->nick();
+ $ircstats{'ConnectTime'} = time();
+ $ircstats{'ConnectCount'}++;
+ if (defined $ircstats{'DisconnectTime'}) {
+ $ircstats{'OffTime'} += time() - $ircstats{'DisconnectTime'};
+ }
+
+ # first time run.
+ if (!exists $users{_default}) {
+ &status("!!! First time run... adding _default user.");
+ $users{_default}{FLAGS} = 'amrt';
+ $users{_default}{HOSTS}{"*!*@*"} = 1;
+ }
+
+ if (scalar keys %users < 2) {
+ &status("!"x40);
+ &status("!!! Ok. Now type '/msg $ident PASS <pass>' to get master access through DCC CHAT.");
+ &status("!"x40);
+ }
+ # end of first time run.
+
+ if (&IsChanConf('Wingate') > 0) {
+ my $file = "$bot_base_dir/$param{'ircUser'}.wingate";
+ open(IN, $file);
+ while (<IN>) {
+ chop;
+ next unless (/^(\S+)\*$/);
+ push(@wingateBad, $_);
+ }
+ close IN;
+ }
+
+ if ($firsttime) {
+ &ScheduleThis(1, 'setupSchedulers');
+ $firsttime = 0;
+ }
+
+ if (&IsParam('ircUMode')) {
+ &VERB("Attempting change of user modes to $param{'ircUMode'}.", 2);
+ if ($param{'ircUMode'} !~ /^[-+]/) {
+ &WARN("ircUMode had no +- prefix; adding +");
+ $param{'ircUMode'} = "+".$param{'ircUMode'};
+ }
+
+ &rawout("MODE $ident $param{'ircUMode'}");
+ }
+
+ # ok, we're free to do whatever we want now. go for it!
+ $running = 1;
+
+ # add ourself to notify.
+ $conn->ison($conn->nick());
+
+ # Q, as on quakenet.org.
+ if (&IsParam('Q_pass')) {
+ &status("Authing to Q...");
+ &rawout("PRIVMSG Q\@CServe.quakenet.org :AUTH $param{'Q_user'} $param{'Q_pass'}");
+ }
+
+ &status("End of motd. Now lets join some channels...");
+ #&joinNextChan();
+}
+
+sub on_endofwho {
+ $conn = shift(@_);
+ my ($event) = @_;
+# &DEBUG("endofwho: chan => $chan");
+ $chan ||= ($event->args)[1];
+# &DEBUG("endofwho: chan => $chan");
+
+ if (exists $cache{countryStats}) {
+ &do_countrystats();
+ }
+}
+
+sub on_dcc {
+ $conn = shift(@_);
+ my ($event) = @_;
+ my $type = uc( ($event->args)[1] );
+ my $nick = lc $event->nick();
+
+ &status("on_dcc type=$type nick=$nick sock=$sock");
+
+ # pity Net::IRC doesn't store nuh. Here's a hack :)
+ if (!exists $nuh{lc $nick}) {
+ $conn->whois($nick);
+ $nuh{$nick} = "GETTING-NOW"; # trying.
+ }
+ $type ||= "???";
+
+ if ($type eq 'SEND') { # GET for us.
+ # incoming DCC SEND. we're receiving a file.
+ my $get = ($event->args)[2];
+ &status("DCC: not Initializing GET from $nick to '$param{tempDir}/$get'");
+ # FIXME: do we want to get anything?
+ return;
+ #open(DCCGET,">$param{tempDir}/$get");
+ #$conn->new_get($event, \*DCCGET);
+
+ } elsif ($type eq 'GET') { # SEND for us?
+ &status("DCC: not Initializing SEND for $nick.");
+ # FIXME: do we want to do anything?
+ return;
+ $conn->new_send($event->args);
+
+ } elsif ($type eq 'CHAT') {
+ &status("DCC: Initializing CHAT for $nick.");
+ $conn->new_chat($event);
+# $conn->new_chat(1, $nick, $event->host);
+
+ } else {
+ &WARN("${b_green}DCC $type$ob (1)");
+ }
+}
+
+sub on_dcc_close {
+ $conn = shift(@_);
+ my ($event) = @_;
+ my $nick = $event->nick();
+ my $sock = ($event->to)[0];
+
+ # DCC CHAT close on fork exit workaround.
+ if ($bot_pid != $$) {
+ &WARN("run-away fork; exiting.");
+ &delForked($forker);
+ }
+
+ if (exists $dcc{'SEND'}{$nick} and -f "$param{tempDir}/$nick.txt") {
+ &status("${b_green}DCC SEND$ob close from $b_cyan$nick$ob");
+
+ &status("dcc_close: purging DCC send $nick.txt");
+ unlink "$param{tempDir}/$nick.txt";
+
+ delete $dcc{'SEND'}{$nick};
+ } elsif (exists $dcc{'CHAT'}{$nick} and $dcc{'CHAT'}{$nick} eq $sock) {
+ &status("${b_green}DCC CHAT$ob close from $b_cyan$nick$ob");
+ delete $dcc{'CHAT'}{$nick};
+ delete $dcc{'CHATvrfy'}{$nick};
+ } else {
+ &status("${b_green}DCC$ob UNKNOWN close from $b_cyan$nick$ob (2)");
+ }
+}
+
+sub on_dcc_open {
+ $conn = shift(@_);
+ my ($event) = @_;
+ my $type = uc( ($event->args)[0] );
+ my $nick = lc $event->nick();
+ my $sock = ($event->to)[0];
+
+ &status("on_dcc_open type=$type nick=$nick sock=$sock");
+
+ $msgType = 'chat';
+ $type ||= "???";
+ ### BUG: who is set to bot's nick?
+
+ # lets do it.
+ if ($type eq 'SEND') {
+ &status("${b_green}DCC lGET$ob established with $b_cyan$nick$ob");
+
+ } elsif ($type eq 'CHAT') {
+ # very cheap hack.
+ ### TODO: run ScheduleThis inside on_dcc_open_chat recursively
+ ### 1,3,5,10 seconds then fail.
+ if ($nuh{$nick} eq "GETTING-NOW") {
+ &ScheduleThis(3/60, 'on_dcc_open_chat', $nick, $sock);
+ } else {
+ on_dcc_open_chat(undef, $nick, $sock);
+ }
+
+ } elsif ($type eq 'SEND') {
+ &status("Starting DCC receive.");
+ foreach ($event->args) {
+ &status(" => '$_'.");
+ }
+
+ } else {
+ &WARN("${b_green}DCC $type$ob (3)");
+ }
+}
+
+# really custom sub to get NUH since Net::IRC doesn't appear to support
+# it.
+sub on_dcc_open_chat {
+ my(undef, $nick, $sock) = @_;
+
+ if ($nuh{$nick} eq "GETTING-NOW") {
+ &FIXME("getting nuh for $nick failed.");
+ return;
+ }
+
+ &status("${b_green}DCC CHAT$ob established with $b_cyan$nick$ob $b_yellow($ob$nuh{$nick}$b_yellow)$ob");
+
+ &verifyUser($nick, $nuh{lc $nick});
+
+ if (!exists $users{$userHandle}{HOSTS}) {
+ &performStrictReply("you have no hosts defined in my user file; rejecting.");
+ $sock->close();
+ return;
+ }
+
+ my $crypto = $users{$userHandle}{PASS};
+ $dcc{'CHAT'}{$nick} = $sock;
+
+ # TODO: don't make DCC CHAT established in the first place.
+ if ($userHandle eq '_default') {
+ &dccsay($nick, "_default/guest not allowed");
+ $sock->close();
+ return;
+ }
+
+ if (defined $crypto) {
+ &status("DCC CHAT: going to use ".$nick."'s crypt.");
+ &dccsay($nick,"Enter your password.");
+ } else {
+# &dccsay($nick,"Welcome to infobot DCC CHAT interface, $userHandle.");
+ }
+}
+
+sub on_disconnect {
+ $conn = shift(@_);
+ my ($event) = @_;
+ my $from = $event->from();
+ my $what = ($event->args)[0];
+ my $mynick=$conn->nick();
+
+ &status("$mynick disconnect from $from ($what).");
+ $ircstats{'DisconnectTime'} = time();
+ $ircstats{'DisconnectReason'} = $what;
+ $ircstats{'DisconnectCount'}++;
+ $ircstats{'TotalTime'} += time() - $ircstats{'ConnectTime'}
+ if ($ircstats{'ConnectTime'});
+
+ # clear any variables on reconnection.
+ $nickserv = 0;
+
+ &clearIRCVars();
+
+ if (!defined $conn) {
+ &WARN("on_disconnect: self is undefined! WTF");
+ &DEBUG("running function irc... lets hope this works.");
+ &irc();
+ return;
+ }
+
+ &WARN("scheduling call ircCheck() in 60s");
+ &clearIRCVars();
+ &ScheduleThis(1, 'ircCheck');
+}
+
+sub on_endofnames {
+ $conn = shift(@_);
+ my ($event) = @_;
+ my $chan = ($event->args)[1];
+
+ # sync time should be done in on_endofwho like in BitchX
+ if (exists $cache{jointime}{$chan}) {
+ my $delta_time = sprintf("%.03f", &timedelta($cache{jointime}{$chan}) );
+ $delta_time = 0 if ($delta_time <= 0);
+ if ($delta_time > 100) {
+ &WARN("endofnames: delta_time > 100 ($delta_time)");
+ }
+
+ &status("$b_blue$chan$ob: sync in ${delta_time}s.");
+ }
+
+ $conn->mode($chan);
+
+ my $txt;
+ my @array;
+ foreach ('o','v','') {
+ my $count = scalar(keys %{ $channels{$chan}{$_} });
+ next unless ($count);
+
+ $txt = 'total' if ($_ eq '');
+ $txt = 'voice' if ($_ eq 'v');
+ $txt = 'ops' if ($_ eq 'o');
+
+ push(@array, "$count $txt");
+ }
+ my $chanstats = join(' || ', @array);
+ &status("$b_blue$chan$ob: [$chanstats]");
+
+ &chanServCheck($chan);
+ # schedule used to solve ircu (OPN) "target too fast" problems.
+ $conn->schedule(5, sub { &joinNextChan(); } );
+}
+
+sub on_init {
+ $conn = shift(@_);
+ my ($event) = @_;
+ my (@args) = ($event->args);
+ shift @args;
+
+ &status("@args");
+}
+
+sub on_invite {
+ $conn = shift(@_);
+ my ($event) = @_;
+ my $chan = lc( ($event->args)[0] );
+ my $nick = $event->nick;
+
+ if ($nick =~ /^\Q$ident\E$/) {
+ &DEBUG("on_invite: self invite.");
+ return;
+ }
+
+ ### TODO: join key.
+ if (exists $chanconf{$chan}) {
+ # it's still buggy :/
+ if (&validChan($chan)) {
+ &msg($who, "i'm already in \002$chan\002.");
+# return;
+ }
+
+ &status("invited to $b_blue$chan$ob by $b_cyan$nick$ob");
+ &joinchan($chan);
+ }
+}
+
+sub on_join {
+ $conn = shift(@_);
+ my ($event) = @_;
+ my ($user,$host) = split(/\@/, $event->userhost);
+ $chan = lc( ($event->to)[0] ); # CASING!!!!
+ $who = $event->nick();
+ $msgType = 'public';
+ my $i = scalar(keys %{ $channels{$chan} });
+ my $j = $cache{maxpeeps}{$chan} || 0;
+
+ if (!&IsParam('noSHM') && time() > ($sched{shmFlush}{TIME} || time()) + 3600) {
+ &DEBUG("looks like schedulers died somewhere... restarting...");
+ &setupSchedulers();
+ }
+
+ $chanstats{$chan}{'Join'}++;
+ $userstats{lc $who}{'Join'} = time() if (&IsChanConf('seenStats') > 0);
+ $cache{maxpeeps}{$chan} = $i if ($i > $j);
+
+ &joinfloodCheck($who, $chan, $event->userhost);
+
+ # netjoin detection.
+ my $netsplit = 0;
+ if (exists $netsplit{lc $who}) {
+ delete $netsplit{lc $who};
+ $netsplit = 1;
+
+ if (!scalar keys %netsplit) {
+ &DEBUG("on_join: netsplit hash is now empty!");
+ undef %netsplitservers;
+ &netsplitCheck(); # any point in running this?
+ &chanlimitCheck();
+ }
+ }
+
+ if ($netsplit and !exists $cache{netsplit}) {
+ &VERB("on_join: ok.... re-running chanlimitCheck in 60.",2);
+ $conn->schedule(60, sub {
+ &chanlimitCheck();
+ delete $cache{netsplit};
+ } );
+
+ $cache{netsplit} = time();
+ }
+
+ # how to tell if there's a netjoin???
+
+ my $netsplitstr = '';
+ $netsplitstr = " $b_yellow\[${ob}NETSPLIT VICTIM$b_yellow]$ob" if ($netsplit);
+ &status(">>> join/$b_blue$chan$ob $b_cyan$who$ob $b_yellow($ob$user\@$host$b_yellow)$ob$netsplitstr");
+
+ $channels{$chan}{''}{$who}++;
+ $nuh = $who."!".$user."\@".$host;
+ $nuh{lc $who} = $nuh unless (exists $nuh{lc $who});
+
+ ### on-join bans.
+ my @bans;
+ push(@bans, keys %{ $bans{$chan} }) if (exists $bans{$chan});
+ push(@bans, keys %{ $bans{'*'} }) if (exists $bans{'*'});
+
+ foreach (@bans) {
+ my $ban = $_;
+ s/\?/./g;
+ s/\*/\\S*/g;
+ my $mask = $_;
+ next unless ($nuh =~ /^$mask$/i);
+
+ ### TODO: check $channels{$chan}{'b'} if ban already exists.
+ foreach (keys %{ $channels{$chan}{'b'} }) {
+ &DEBUG(" bans_on_chan($chan) => $_");
+ }
+
+ my $reason = "no reason";
+ foreach ($chan, '*') {
+ next unless (exists $bans{$_});
+ next unless (exists $bans{$_}{$ban});
+
+ my @array = @{ $bans{$_}{$ban} };
+
+ $reason = $array[4] if ($array[4]);
+ last;
+ }
+
+ &ban($ban, $chan);
+ &kick($who, $chan, $reason);
+
+ last;
+ }
+
+ # no need to go further.
+ return if ($netsplit);
+
+ # who == bot.
+ if ($who =~ /^\Q$ident\E$/i) {
+ if (defined( my $whojoin = $cache{join}{$chan} )) {
+ &msg($chan, "Okay, I'm here. (courtesy of $whojoin)");
+ delete $cache{join}{$chan};
+ &joinNextChan(); # hack.
+ }
+
+ ### TODO: move this to &joinchan()?
+ $cache{jointime}{$chan} = &timeget();
+ $conn->who($chan);
+
+ return;
+ }
+
+ ### ROOTWARN:
+ &rootWarn($who,$user,$host,$chan) if (
+ &IsChanConf('RootWarn') > 0 &&
+ $user =~ /^~?r(oo|ew|00)t$/i
+ );
+
+ ### emit a message based on who just joined
+ &onjoin($who,$user,$host,$chan) if (&IsChanConf('OnJoin') > 0);
+
+ ### NEWS:
+ if (&IsChanConf('News') > 0 && &IsChanConf('newsKeepRead') > 0) {
+ if (!&loadMyModule('News')) { # just in case.
+ &DEBUG('could not load news.');
+ } else {
+ &News::latest($chan);
+ }
+ }
+
+ ### botmail:
+ if (&IsChanConf('botmail') > 0) {
+ &botmail::check(lc $who);
+ }
+
+ ### wingate:
+ &wingateCheck();
+}
+
+sub on_kick {
+ $conn = shift(@_);
+ my ($event) = @_;
+ my ($chan,$reason) = $event->args;
+ my $kicker = $event->nick;
+ my $kickee = ($event->to)[0];
+ my $uh = $event->userhost();
+
+ &status(">>> kick/$b_blue$chan$ob [$b$kickee!$uh$ob] by $b_cyan$kicker$ob $b_yellow($ob$reason$b_yellow)$ob");
+
+ $chan = lc $chan; # forgot about this, found by xsdg, 20001229.
+ $chanstats{$chan}{'Kick'}++;
+
+ if ($kickee eq $ident) {
+ &clearChanVars($chan);
+
+ &status("SELF attempting to rejoin lost channel $chan");
+ &joinchan($chan);
+ } else {
+ &delUserInfo($kickee,$chan);
+ }
+}
+
+sub on_mode {
+ $conn = shift(@_);
+ my ($event) = @_;
+ my ($user, $host) = split(/\@/, $event->userhost);
+ my @args = $event->args();
+ my $nick = $event->nick();
+ $chan = ($event->to)[0];
+
+ # last element is empty... so nuke it.
+ pop @args while ($args[$#args] eq '');
+
+ if ($nick eq $chan) { # UMODE
+ &status(">>> mode $b_yellow\[$ob$b@args$b_yellow\]$ob by $b_cyan$nick$ob");
+ } else { # MODE
+ &status(">>> mode/$b_blue$chan$ob $b_yellow\[$ob$b@args$b_yellow\]$ob by $b_cyan$nick$ob");
+ &hookMode($nick, @args);
+ }
+}
+
+sub on_modeis {
+ $conn = shift(@_);
+ my ($event) = @_;
+ my ($myself, undef,@args) = $event->args();
+ my $nick = $event->nick();
+ $chan = ($event->args())[1];
+
+ &hookMode($nick, @args);
+}
+
+sub on_msg {
+ $conn = shift(@_);
+ my ($event) = @_;
+ my $nick = $event->nick;
+ my $msg = ($event->args)[0];
+
+ ($user,$host) = split(/\@/, $event->userhost);
+ $uh = $event->userhost();
+ $nuh = $nick."!".$uh;
+ $msgtime = time();
+ $h = $host;
+
+ if ($nick eq $ident) { # hopefully ourselves.
+ if ($msg eq 'TEST') {
+ &status("IRCTEST: Yes, we're alive.");
+ delete $cache{connect};
+ return;
+ }
+ }
+
+ &hookMsg('private', undef, $nick, $msg);
+ $who = '';
+ $chan = '';
+ $msgType = '';
+}
+
+sub on_names {
+ $conn = shift(@_);
+ my ($event) = @_;
+ my @args = $event->args;
+ my $chan = lc $args[2]; # CASING, the last of them!
+
+ foreach (split / /, @args[3..$#args]) {
+ $channels{$chan}{'o'}{$_}++ if s/\@//;
+ $channels{$chan}{'v'}{$_}++ if s/\+//;
+ $channels{$chan}{''}{$_}++;
+ }
+}
+
+sub on_nick {
+ $conn = shift(@_);
+ my ($event) = @_;
+ my $nick = $event->nick();
+ my $newnick = ($event->args)[0];
+
+ if (exists $netsplit{lc $newnick}) {
+ &status("Netsplit: $newnick/$nick came back from netsplit and changed to original nick! removing from hash.");
+ delete $netsplit{lc $newnick};
+ &netsplitCheck() if (time() != $sched{netsplitCheck}{TIME});
+ }
+
+ my ($chan,$mode);
+ foreach $chan (keys %channels) {
+ foreach $mode (keys %{ $channels{$chan} }) {
+ next unless (exists $channels{$chan}{$mode}{$nick});
+
+ $channels{$chan}{$mode}{$newnick} = $channels{$chan}{$mode}{$nick};
+ }
+ }
+ # TODO: do %flood* aswell.
+
+ &delUserInfo($nick, keys %channels);
+ $nuh{lc $newnick} = $nuh{lc $nick};
+ delete $nuh{lc $nick};
+
+ if ($nick eq $conn->nick()) {
+ &status(">>> I materialized into $b_green$newnick$ob from $nick");
+ $ident = $newnick;
+ $conn->nick($newnick);
+ } else {
+ &status(">>> $b_cyan$nick$ob materializes into $b_green$newnick$ob");
+ my $mynick=$conn->nick();
+ if ($nick =~ /^\Q$mynick\E$/i) {
+ &getNickInUse();
+ }
+ }
+}
+
+sub on_nick_taken {
+ $conn = shift(@_);
+ my $nick = $conn->nick();
+ #my $newnick = $nick . int(rand 10);
+ my $newnick = $nick . '_';
+
+ &DEBUG("on_nick_taken: nick => $nick");
+
+ &status("nick taken ($nick); preparing nick change.");
+
+ $conn->whois($nick);
+ #$conn->schedule(5, sub {
+ &status("nick taken; changing to temporary nick ($nick -> $newnick).");
+ &nick($newnick);
+ #} );
+}
+
+sub on_notice {
+ $conn = shift(@_);
+ my ($event) = @_;
+ my $nick = $event->nick();
+ my $chan = ($event->to)[0];
+ my $args = ($event->args)[0];
+
+ if ($nick =~ /^NickServ$/i) { # nickserv.
+ &status("NickServ: <== '$args'");
+
+ my $check = 0;
+ $check++ if ($args =~ /^This nickname is registered/i);
+ $check++ if ($args =~ /nickname.*owned/i);
+
+ if ($check) {
+ &status("nickserv told us to register; doing it.");
+
+ if (&IsParam('nickServ_pass')) {
+ &status("NickServ: ==> Identifying.");
+ &rawout("PRIVMSG NickServ :IDENTIFY $param{'nickServ_pass'}");
+ return;
+ } else {
+ &status("We can't tell nickserv a passwd ;(");
+ }
+ }
+
+ # password accepted.
+ if ($args =~ /^Password a/i) {
+ my $done = 0;
+
+ foreach ( &ChanConfList('chanServ_ops') ) {
+ next unless &chanServCheck($_);
+ next if ($done);
+ &DEBUG("nickserv activated or restarted; doing chanserv check.");
+ $done++;
+ }
+
+ $nickserv++;
+ }
+
+ } elsif ($nick =~ /^ChanServ$/i) { # chanserv.
+ &status("ChanServ: <== '$args'.");
+
+ } else {
+ if ($chan =~ /^$mask{chan}$/) { # channel notice.
+ &status("-$nick/$chan- $args");
+ } else {
+ $server = $nick unless (defined $server);
+ &status("-$nick- $args"); # private or server notice.
+ }
+ }
+}
+
+sub on_other {
+ $conn = shift(@_);
+ my ($event) = @_;
+ my $chan = ($event->to)[0];
+ my $nick = $event->nick;
+
+ &status("!!! other called.");
+ &status("!!! $event->args");
+}
+
+sub on_part {
+ $conn = shift(@_);
+ my ($event) = @_;
+ $chan = lc( ($event->to)[0] ); # CASING!!!
+ my $mynick = $conn->nick();
+ my $nick = $event->nick;
+ my $userhost = $event->userhost;
+ $who = $nick;
+ $msgType = 'public';
+
+ if (!exists $channels{$chan}) {
+ &DEBUG("on_part: found out $mynick is on $chan!");
+ $channels{$chan} = 1;
+ }
+
+ if (exists $floodjoin{$chan}{$nick}{Time}) {
+ delete $floodjoin{$chan}{$nick};
+ }
+
+ $chanstats{$chan}{'Part'}++;
+ &delUserInfo($nick,$chan);
+ if ($nick eq $ident) {
+ &clearChanVars($chan);
+ }
+
+ if (!&IsNickInAnyChan($nick) and &IsChanConf('seenStats') > 0) {
+ delete $userstats{lc $nick};
+ }
+
+ &status(">>> part/$b_blue$chan$ob $b_cyan$nick$ob $b_yellow($ob$userhost$b_yellow)$ob");
+}
+
+sub on_ping {
+ $conn = shift(@_);
+ my ($event) = @_;
+ my $nick = $event->nick;
+
+ $conn->ctcp_reply($nick, join(' ', ($event->args)));
+ &status(">>> ${b_green}CTCP PING$ob request from $b_cyan$nick$ob received.");
+}
+
+sub on_ping_reply {
+ $conn = shift(@_);
+ my ($event) = @_;
+ my $nick = $event->nick;
+ my $t = ($event->args)[1];
+ if (!defined $t) {
+ &WARN("on_ping_reply: t == undefined.");
+ return;
+ }
+
+ my $lag = time() - $t;
+
+ &status(">>> ${b_green}CTCP PING$ob reply from $b_cyan$nick$ob: $lag sec.");
+}
+
+sub on_public {
+ $conn = shift(@_);
+ my ($event) = @_;
+ my $msg = ($event->args)[0];
+ $chan = lc( ($event->to)[0] ); # CASING.
+ my $nick = $event->nick;
+ $who = $nick;
+ $uh = $event->userhost();
+ $nuh = $nick."!".$uh;
+ $msgType = 'public';
+ # TODO: move this out of hookMsg to here?
+ ($user,$host) = split(/\@/, $uh);
+ $h = $host;
+
+ # rare case should this happen - catch it just in case.
+ if ($bot_pid != $$) {
+ &ERROR("run-away fork; exiting.");
+ &delForked($forker);
+ }
+
+ $msgtime = time();
+ $lastWho{$chan} = $nick;
+ ### TODO: use $nick or lc $nick?
+ if (&IsChanConf('seenStats') > 0) {
+ $userstats{lc $nick}{'Count'}++;
+ $userstats{lc $nick}{'Time'} = time();
+ }
+
+ # cache it.
+ my $time = time();
+ if (!$cache{ircTextCounters}) {
+ &DEBUG("caching ircTextCounters for first time.");
+ my @str = split(/\s+/, &getChanConf('ircTextCounters'));
+ for (@str) { $_ = quotemeta($_); }
+ $cache{ircTextCounters} = join('|', @str);
+ }
+
+ my $str = $cache{ircTextCounters};
+ if ($str && $msg =~ /^($str)[\s!\.]?$/i) {
+ my $x = $1;
+
+ &VERB("textcounters: $x matched for $who",2);
+ my $c = $chan || 'PRIVATE';
+
+ # better to do "counter=counter+1".
+ # but that will avoid time check.
+ my ($v,$t) = &sqlSelect('stats', "counter,time", {
+ nick => $who,
+ type => $x,
+ channel => $c,
+ } );
+ $v++;
+
+ # don't allow ppl to cheat the stats :-)
+ if (defined $t && $time - $t > 60) {
+ &sqlSet('stats', {'nick' => $who}, {
+ type => $x,
+ channel => $c,
+ time => $time,
+ counter => $v,
+ } );
+ }
+ }
+
+ &hookMsg('public', $chan, $nick, $msg);
+ $chanstats{$chan}{'PublicMsg'}++;
+ $who = '';
+ $chan = '';
+ $msgType = '';
+}
+
+sub on_quit {
+ $conn = shift(@_);
+ my ($event) = @_;
+ my $nick = $event->nick();
+ my $reason = ($event->args)[0];
+
+ # hack for ICC.
+ $msgType = 'public';
+ $who = $nick;
+### $chan = $reason; # no.
+
+ my $count = 0;
+ foreach (grep !/^_default$/, keys %channels) {
+ # fixes inconsistent chanstats bug #1.
+ if (!&IsNickInChan($nick,$_)) {
+ $count++;
+ next;
+ }
+ $chanstats{$_}{'SignOff'}++;
+ }
+
+ if ($count == scalar keys %channels) {
+ &DEBUG("on_quit: nick $nick was not found in any chan.");
+ }
+
+ # should fix chanstats inconsistencies bug #2.
+ if ($reason =~ /^($mask{host})\s($mask{host})$/) { # netsplit.
+ $reason = "NETSPLIT: $1 <=> $2";
+
+ # chanlimit code.
+ foreach $chan ( &getNickInChans($nick) ) {
+ next unless ( &IsChanConf('chanlimitcheck') > 0);
+ next unless ( exists $channels{$_}{'l'} );
+
+ &DEBUG("on_quit: netsplit detected on $_; disabling chan limit.");
+ $conn->mode($_, "-l");
+ }
+
+ $netsplit{lc $nick} = time();
+ if (!exists $netsplitservers{$1}{$2}) {
+ &status("netsplit detected between $1 and $2 at [".scalar(gmtime)."]");
+ $netsplitservers{$1}{$2} = time();
+ }
+ }
+
+ my $chans = join(' ', &getNickInChans($nick) );
+ &status(">>> $b_cyan$nick$ob has signed off IRC $b_red($ob$reason$b_red)$ob [$chans]");
+
+ ###
+ ### ok... lets clear out the cache
+ ###
+ &delUserInfo($nick, keys %channels);
+ if (exists $nuh{lc $nick}) {
+ delete $nuh{lc $nick};
+ } else {
+ # well.. it's good but weird that this has happened - lets just
+ # be quiet about it.
+ }
+ delete $userstats{lc $nick} if (&IsChanConf('seenStats') > 0);
+ delete $chanstats{lc $nick};
+ ###
+
+ # if we have a temp nick, and whoever is camping on our main nick leaves
+ # revert to main nick. Note that Net::IRC only knows our main nick
+ if ($nick eq $conn->nick()) {
+ &status("nickchange: own nick \"$nick\" became free; changing.");
+ &nick($mynick);
+ }
+}
+
+sub on_targettoofast {
+ $conn = shift(@_);
+ my ($event) = @_;
+ my $nick = $event->nick();
+ my($me,$chan,$why) = $event->args();
+
+ ### TODO: incomplete.
+ if ($why =~ /.* wait (\d+) second/) {
+ my $sleep = $1;
+ my $max = 10;
+
+ if ($sleep > $max) {
+ &status("targettoofast: going to sleep for $max ($sleep)...");
+ $sleep = $max;
+ } else {
+ &status("targettoofast: going to sleep for $sleep");
+ }
+
+ my $delta = time() - ($cache{sleepTime} || 0);
+ if ($delta > $max+2) {
+ sleep $sleep;
+ $cache{sleepTime} = time();
+ }
+
+ return;
+ }
+
+ if (!exists $cache{TargetTooFast}) {
+ &DEBUG("on_ttf: failed: $why");
+ $cache{TargetTooFast}++;
+ }
+}
+
+sub on_topic {
+ $conn = shift(@_);
+ my ($event) = @_;
+
+ if (scalar($event->args) == 1) { # change.
+ my $topic = ($event->args)[0];
+ my $chan = ($event->to)[0];
+ my $nick = $event->nick();
+
+ ###
+ # WARNING:
+ # race condition here. To fix, change '1' to '0'.
+ # This will keep track of topics set by bot only.
+ ###
+ # UPDATE:
+ # this may be fixed at a later date with topic queueing.
+ ###
+
+ $topic{$chan}{'Current'} = $topic if (1);
+ $chanstats{$chan}{'Topic'}++;
+
+ &status(">>> topic/$b_blue$chan$ob by $b_cyan$nick$ob -> $topic");
+ } else { # join.
+ my ($nick, $chan, $topic) = $event->args;
+ if (&IsChanConf('Topic') > 0) {
+ $topic{$chan}{'Current'} = $topic;
+ &topicAddHistory($chan,$topic);
+ }
+
+ $topic = &fixString($topic, 1);
+ &status(">>> topic/$b_blue$chan$ob is $topic");
+ }
+}
+
+sub on_topicinfo {
+ $conn = shift(@_);
+ my ($event) = @_;
+ my ($myself,$chan,$setby,$time) = $event->args();
+
+ my $timestr;
+ if (time() - $time > 60*60*24) {
+ $timestr = "at ". gmtime $time;
+ } else {
+ $timestr = &Time2String(time() - $time) ." ago";
+ }
+
+ &status(">>> set by $b_cyan$setby$ob $timestr");
+}
+
+sub on_crversion {
+ $conn = shift(@_);
+ my ($event) = @_;
+ my $nick = $event->nick();
+ my $ver;
+
+ if (scalar $event->args() != 1) { # old.
+ $ver = join ' ', $event->args();
+ $ver =~ s/^VERSION //;
+ } else { # new.
+ $ver = ($event->args())[0];
+ }
+
+ if (grep /^\Q$nick\E$/i, @vernick) {
+ &WARN("nick $nick found in vernick ($ver); skipping.");
+ return;
+ }
+ push(@vernick, $nick);
+
+ if ($ver =~ /bitchx/i) {
+ $ver{bitchx}{$nick} = $ver;
+
+ } elsif ($ver =~ /xc\!|xchat/i) {
+ $ver{xchat}{$nick} = $ver;
+
+ } elsif ($ver =~ /irssi/i) {
+ $ver{irssi}{$nick} = $ver;
+
+ } elsif ($ver =~ /epic|(Third Eye)/i) {
+ $ver{epic}{$nick} = $ver;
+
+ } elsif ($ver =~ /ircII|PhoEniX/i) {
+ $ver{ircII}{$nick} = $ver;
+
+ } elsif ($ver =~ /mirc/i) {
+# &DEBUG("verstats: mirc: $nick => '$ver'.");
+ $ver{mirc}{$nick} = $ver;
+
+# ok... then we get to the lesser known/used clients.
+ } elsif ($ver =~ /ircle/i) {
+ $ver{ircle}{$nick} = $ver;
+
+ } elsif ($ver =~ /chatzilla/i) {
+ $ver{chatzilla}{$nick} = $ver;
+
+ } elsif ($ver =~ /pirch/i) {
+ $ver{pirch}{$nick} = $ver;
+
+ } elsif ($ver =~ /sirc /i) {
+ $ver{sirc}{$nick} = $ver;
+
+ } elsif ($ver =~ /kvirc/i) {
+ $ver{kvirc}{$nick} = $ver;
+
+ } elsif ($ver =~ /eggdrop/i) {
+ $ver{eggdrop}{$nick} = $ver;
+
+ } elsif ($ver =~ /xircon/i) {
+ $ver{xircon}{$nick} = $ver;
+
+ } else {
+ &DEBUG("verstats: other: $nick => '$ver'.");
+ $ver{other}{$nick} = $ver;
+ }
+}
+
+sub on_version {
+ $conn = shift(@_);
+ my ($event) = @_;
+ my $nick = $event->nick;
+
+ &status(">>> ${b_green}CTCP VERSION$ob request from $b_cyan$nick$ob");
+ $conn->ctcp_reply($nick, "VERSION $bot_version");
+}
+
+sub on_who {
+ $conn = shift(@_);
+ my ($event) = @_;
+ my @args = $event->args;
+ my $str = $args[5]."!".$args[2]."\@".$args[3];
+
+ if ($cache{on_who_Hack}) {
+ $cache{nuhInfo}{lc $args[5]}{Nick} = $args[5];
+ $cache{nuhInfo}{lc $args[5]}{User} = $args[2];
+ $cache{nuhInfo}{lc $args[5]}{Host} = $args[3];
+ $cache{nuhInfo}{lc $args[5]}{NUH} = "$args[5]!$args[2]\@$args[3]";
+ return;
+ }
+
+ if ($args[5] =~ /^nickserv$/i and !$nickserv) {
+ &DEBUG("ok... we did a who for nickserv.");
+ &rawout("PRIVMSG NickServ :IDENTIFY $param{'nickServ_pass'}");
+ }
+
+ $nuh{lc $args[5]} = $args[5]."!".$args[2]."\@".$args[3];
+}
+
+sub on_whois {
+ $conn = shift(@_);
+ my ($event) = @_;
+ my @args = $event->args;
+
+ $nuh{lc $args[1]} = $args[1]."!".$args[2]."\@".$args[3];
+}
+
+sub on_whoischannels {
+ $conn = shift(@_);
+ my ($event) = @_;
+ my @args = $event->args;
+
+ &DEBUG("on_whoischannels: @args");
+}
+
+sub on_useronchannel {
+ $conn = shift(@_);
+ my ($event) = @_;
+ my @args = $event->args;
+
+ &DEBUG("on_useronchannel: @args");
+ &joinNextChan();
+}
+
+###
+### since joinnextchan is hooked onto on_endofnames, these are needed.
+###
+
+sub on_chanfull {
+ $conn = shift(@_);
+ my ($event) = @_;
+ my @args = $event->args;
+
+ &status(">>> chanfull/$b_blue$args[1]$ob");
+
+ &joinNextChan();
+}
+
+sub on_inviteonly {
+ $conn = shift(@_);
+ my ($event) = @_;
+ my @args = $event->args;
+
+ &status(">>> inviteonly/$b_cyan$args[1]$ob");
+
+ &joinNextChan();
+}
+
+sub on_banned {
+ $conn = shift(@_);
+ my ($event) = @_;
+ my @args = $event->args;
+ my $chan = $args[1];
+
+ &status(">>> banned/$b_blue$chan$ob $b_cyan$args[0]$ob, removing autojoin for $chan");
+ delete $chanconf{$chan}{autojoin};
+ &joinNextChan();
+}
+
+sub on_badchankey {
+ $conn = shift(@_);
+ my ($event) = @_;
+ my @args = $event->args;
+ my $chan = $args[1];
+
+ &DEBUG("on_badchankey: args => @args, removing autojoin for $chan");
+ delete $chanconf{$chan}{autojoin};
+ &joinNextChan();
+}
+
+sub on_useronchan {
+ $conn = shift(@_);
+ my ($event) = @_;
+ my @args = $event->args;
+
+ &DEBUG("on_useronchan: args => @args");
+ &joinNextChan();
+}
+
+# TODO not used yet
+sub on_stdin {
+ my $line = <STDIN>;
+ chomp($line);
+ &FIXME("on_stdin: line => \"$line\"");
+}
+
+1;
--- /dev/null
+#
+# ProcessExtra.pl: Extensions to Process.pl
+# Author: dms
+# Version: v0.5 (20010124)
+# Created: 20000117
+#
+
+# use strict; # TODO
+
+use POSIX qw(strftime);
+use vars qw(%sched %schedule);
+
+# format: function name = (
+# str chanconfdefault,
+# int internaldefault,
+# bool deferred,
+# int next run, (optional)
+# )
+
+#%schedule = {
+# uptimeLoop => ('', 60, 1),
+#};
+
+sub setupSchedulersII {
+ foreach (keys %schedule) {
+ &queueTask($_, @{ $schedule{$_} });
+ }
+}
+
+sub queueTask {
+ my($codename, $chanconfdef, $intervaldef, $defer) = @_;
+ my $t = &getChanConfDefault($chanconfdef, $intervaldef, $chan);
+ my $waittime = &getRandomInt($t);
+
+ if (!defined $waittime) {
+ &WARN("interval == waittime == UNDEF for $codename.");
+ return;
+ }
+
+ my $time = $schedule{$codename}[3];
+ if (defined $time and $time > time()) {
+ &WARN("Sched for $codename already exists in " . &Time2String(time() - $time) . ".");
+ return;
+ }
+
+ #&VERB("Scheduling \&$codename() for " . &Time2String($waittime),3);
+
+ my $retval = $conn->schedule($waittime, sub {
+ \&$codename;
+ }, @args );
+}
+
+sub setupSchedulers {
+ &VERB("Starting schedulers...",2);
+
+ # ONCE OFF.
+
+ # REPETITIVE.
+ # 2 for on next-run.
+ &randomQuote(2);
+ &randomFactoid(2);
+ &seenFlush(2);
+ &leakCheck(2); # mandatory
+ &seenFlushOld(2);
+ &miscCheck2(2); # mandatory
+ &slashdotLoop(2);
+ &plugLoop(2);
+ &kernelLoop(2);
+ &wingateWriteFile(2);
+ &factoidCheck(2); # takes a couple of seconds on a 486. defer it
+# TODO: convert to new format... or nuke altogether.
+ &newsFlush(2);
+
+ # 1 for run straight away
+ &uptimeLoop(1);
+ &logLoop(1);
+ &chanlimitCheck(1);
+ &netsplitCheck(1); # mandatory
+ &floodLoop(1); # mandatory
+ &ignoreCheck(1); # mandatory
+ &miscCheck(1); # mandatory
+ &shmFlush(1); # mandatory
+ sleep 1;
+ &ircCheck(1); # mandatory
+
+ # TODO: squeeze this into a one-liner.
+# my $count = map { exists $sched{$_}{TIME} } keys %sched;
+ my $count = 0;
+ foreach (keys %sched) {
+ my $time = $sched{$_}{TIME};
+ next unless (defined $time and $time > time());
+
+ $count++;
+ }
+
+ &status("Schedulers: $count will be running.");
+ &scheduleList();
+}
+
+sub ScheduleThis {
+ my ($interval, $codename, @args) = @_;
+ my $waittime = &getRandomInt($interval);
+
+ if (!defined $waittime) {
+ &WARN("interval == waittime == UNDEF for $codename.");
+ return;
+ }
+
+ my $time = $sched{$codename}{TIME};
+ if (defined $time and $time > time()) {
+ &WARN("Sched for $codename already exists in " . &Time2String(time() - $time) . ".");
+ return;
+ }
+
+ &DEBUG("Scheduling \&$codename() " . \&$codename . " for " . &Time2String($waittime),3);
+
+ my $retval = $conn->schedule($waittime, \&$codename, @args);
+ $sched{$codename}{LABEL} = $retval;
+ $sched{$codename}{TIME} = time()+$waittime;
+ $sched{$codename}{LOOP} = 1;
+}
+
+####
+#### LET THE FUN BEGIN.
+####
+
+sub randomQuote {
+ my $interval = &getChanConfDefault('randomQuoteInterval', 60, $chan);
+ if (@_) {
+ &ScheduleThis($interval, 'randomQuote');
+ return if ($_[0] eq '2'); # defer.
+ }
+
+ foreach ( &ChanConfList('randomQuote') ) {
+ next unless (&validChan($_));
+
+ my $line = &getRandomLineFromFile($bot_data_dir. "/infobot.randtext");
+ if (!defined $line) {
+ &ERROR("random Quote: weird error?");
+ return;
+ }
+
+ &status("sending random Quote to $_.");
+ &action($_, "Ponders: ".$line);
+ }
+ ### TODO: if there were no channels, don't reschedule until channel
+ ### configuration is modified.
+}
+
+sub randomFactoid {
+ my ($key,$val);
+ my $error = 0;
+
+ my $interval = &getChanConfDefault('randomFactoidInterval', 60, $chan);
+ if (@_) {
+ &ScheduleThis($interval, 'randomFactoid');
+ return if ($_[0] eq '2'); # defer.
+ }
+
+ foreach ( &ChanConfList('randomFactoid') ) {
+ next unless (&validChan($_));
+
+ &status("sending random Factoid to $_.");
+ while (1) {
+ ($key,$val) = &randKey('factoids',"factoid_key,factoid_value");
+ &DEBUG("rF: $key, $val");
+### $val =~ tr/^[A-Z]/[a-z]/; # blah is Good => blah is good.
+ last if ((defined $val) and ($val !~ /^</) and ($key !~ /\#DEL\#/) and ($key !~ /^cmd:/));
+
+ $error++;
+ if ($error == 5) {
+ &ERROR("rF: tried 5 times but failed.");
+ return;
+ }
+ }
+ &action($_, "Thinks: \037$key\037 is $val");
+ ### FIXME: Use &getReply() on above to format factoid properly?
+ $good++;
+ }
+}
+
+sub logLoop {
+ if (@_) {
+ &ScheduleThis(60, 'logLoop');
+ return if ($_[0] eq '2'); # defer.
+ }
+
+ return unless (defined fileno LOG);
+ return unless (&IsParam('logfile'));
+ return unless (&IsParam('maxLogSize'));
+
+ ### check if current size is too large.
+ if ( -s $file{log} > $param{'maxLogSize'}) {
+ my $date = sprintf("%04d%02d%02d", (gmtime)[5,4,3]);
+ $file{log} = $param{'logfile'} ."-". $date;
+ &status("cycling log file.");
+
+ if ( -e $file{log}) {
+ my $i = 1;
+ my $newlog;
+ while () {
+ $newlog = $file{log}."-".$i;
+ last if (! -e $newlog);
+ $i++;
+ }
+ $file{log} = $newlog;
+ }
+
+ &closeLog();
+ CORE::system("/bin/mv '$param{'logfile'}' '$file{log}'");
+ &compress($file{log});
+ &openLog();
+ &status("cycling log file.");
+ }
+
+ ### check if all the logs exceed size.
+ if (!opendir(LOGS, $bot_log_dir)) {
+ &WARN("logLoop: could not open dir '$bot_log_dir'");
+ return;
+ }
+
+ my $tsize = 0;
+ my (%age, %size);
+ while (defined($_ = readdir LOGS)) {
+ my $logfile = "$bot_log_dir/$_";
+
+ next unless ( -f $logfile);
+
+ my $size = -s $logfile;
+ my $age = (stat $logfile)[9];
+ $age{$age} = $logfile;
+ $size{$logfile} = $size;
+ $tsize += $size;
+ }
+ closedir LOGS;
+
+ my $delete = 0;
+ while ($tsize > $param{'maxLogSize'}) {
+ &status("LOG: current size > max ($tsize > $param{'maxLogSize'})");
+ my $oldest = (sort {$a <=> $b} keys %age)[0];
+ &status("LOG: unlinking $age{$oldest}.");
+ unlink $age{$oldest};
+ $tsize -= $oldest;
+ $delete++;
+ }
+
+ ### TODO: add how many b,kb,mb removed?
+ &status("LOG: removed $delete logs.") if ($delete);
+}
+
+sub seenFlushOld {
+ if (@_) {
+ &ScheduleThis(1440, 'seenFlushOld');
+ return if ($_[0] eq '2'); # defer.
+ }
+
+ # is this global-only?
+ return unless (&IsChanConf('seen') > 0);
+ return unless (&IsChanConf('seenFlushInterval') > 0);
+
+ # global setting. does not make sense for per-channel.
+ my $max_time = &getChanConfDefault('seenMaxDays', 30, $chan) *60*60*24;
+ my $delete = 0;
+
+ if ($param{'DBType'} =~ /^(pgsql|mysql|sqlite(2)?)$/i) {
+ my $query;
+
+ if ($param{'DBType'} =~ /^(mysql|sqlite(2)?)$/i) {
+ $query = "SELECT nick,time FROM seen GROUP BY nick HAVING ".
+ "UNIX_TIMESTAMP() - time > $max_time";
+ } else { # pgsql.
+ $query = "SELECT nick,time FROM seen WHERE ".
+ "extract(epoch from timestamp 'now') - time > $max_time";
+ }
+
+ my $sth = $dbh->prepare($query);
+ if ($sth->execute) {
+ while (my @row = $sth->fetchrow_array) {
+ my ($nick,$time) = @row;
+
+ &sqlDelete('seen', { nick => $nick } );
+ $delete++;
+ }
+ $sth->finish;
+ }
+ } else {
+ &FIXME("seenFlushOld: for bad DBType:" . $param{'DBType'} . ".");
+ }
+ &VERB("SEEN deleted $delete seen entries.",2);
+
+}
+
+sub newsFlush {
+ if (@_) {
+ &ScheduleThis(60, 'newsFlush');
+ return if ($_[0] eq '2'); # defer.
+ }
+
+ if (!&ChanConfList('News')) {
+ &DEBUG("newsFlush: news disabled? (chan => $chan)");
+ return;
+ }
+
+ my $delete = 0;
+ my $oldest = time();
+ my %none;
+ foreach $chan (keys %::news) {
+ my $i = 0;
+ my $total = scalar(keys %{ $::news{$chan} });
+
+ if (!$total) {
+ delete $::news{$chan};
+ next;
+ }
+
+ foreach $item (keys %{ $::news{$chan} }) {
+ my $t = $::news{$chan}{$item}{Expire};
+
+ my $tadd = $::news{$chan}{$item}{Time};
+ $oldest = $tadd if ($oldest > $tadd);
+
+ next if ($t == 0 or $t == -1);
+ if ($t < 1000) {
+ &status("newsFlush: Fixed Expire time for $chan/$item, should not happen anyway.");
+ $::news{$chan}{$item}{Expire} = time() + $t*60*60*24;
+ next;
+ }
+
+ my $delta = $t - time();
+
+ next unless (time() > $t);
+
+ # TODO: show how old it was.
+ delete $::news{$chan}{$item};
+ &status("NEWS: (newsflush) deleted '$item'");
+ $delete++;
+ $i++;
+ }
+
+ &status("NEWS (newsflush) {$chan}: deleted [$i/$total] news entries.") if ($i);
+ $none{$chan} = 1 if ($total == $i);
+ }
+
+ # TODO: flush users aswell.
+ my $duser = 0;
+ foreach $chan (keys %::newsuser) {
+ next if (exists $none{$chan});
+
+ foreach (keys %{ $::newsuser{$chan} }) {
+ my $t = $::newsuser{$chan}{$_};
+ if (!defined $t or ($t > 2 and $t < 1000)) {
+ &DEBUG("something wrong with newsuser{$chan}{$_} => $t");
+ next;
+ }
+
+ next unless ($oldest > $t);
+
+ delete $::newsuser{$chan}{$_};
+ $duser++;
+ }
+
+ my $i = scalar(keys %{ $::newsuser{$chan} });
+ delete $::newsuser{$chan} unless ($i);
+ }
+
+ if ($delete or $duser) {
+ &status("NewsFlush: deleted: $delete news entries; $duser user cache.");
+ }
+}
+
+sub chanlimitCheck {
+ my $interval = &getChanConfDefault('chanlimitcheckInterval', 10, $chan);
+ my $mynick=$conn->nick();
+
+ if (@_) {
+ &ScheduleThis($interval, 'chanlimitCheck');
+ return if ($_[0] eq '2');
+ }
+
+ my $str = join(' ', &ChanConfList('chanlimitcheck') );
+
+ 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'};
+
+ if (scalar keys %netsplitservers) {
+ if (defined $limit) {
+ &status("chanlimit: netsplit; removing it for $chan.");
+ $conn->mode($chan, "-l");
+ $cache{chanlimitChange}{$chan} = time();
+ &status("chanlimit: netsplit; removed.");
+ }
+
+ next;
+ }
+
+ if (defined $limit and scalar keys %{ $channels{$chan}{''} } > $limit) {
+ &FIXME("LIMIT: set too low!!!");
+ ### run NAMES again and flush it.
+ }
+
+ if (defined $limit and $limit == $newlimit) {
+ $cache{chanlimitChange}{$chan} = time();
+ next;
+ }
+
+ if (!exists $channels{$chan}{'o'}{$mynick}) {
+ &status("chanlimit: dont have ops on $chan.") unless (exists $cache{warn}{chanlimit}{$chan});
+ $cache{warn}{chanlimit}{$chan} = 1;
+ &chanServCheck($chan);
+ next;
+ }
+ delete $cache{warn}{chanlimit}{$chan};
+
+ if (!defined $limit) {
+ &status("chanlimit: $chan: setting for first time or from netsplit.");
+ }
+
+ if (exists $cache{chanlimitChange}{$chan}) {
+ my $delta = time() - $cache{chanlimitChange}{$chan};
+ if ($delta < $interval*60) {
+ &DEBUG("chanlimit: not going to change chanlimit! ($delta<$interval*60)");
+ return;
+ }
+ }
+
+ $conn->mode($chan, "+l", $newlimit);
+ $cache{chanlimitChange}{$chan} = time();
+ }
+}
+
+sub netsplitCheck {
+ my ($s1,$s2);
+
+ if (@_) {
+ &ScheduleThis(15, 'netsplitCheck');
+ return if ($_[0] eq '2');
+ }
+
+ $cache{'netsplitCache'}++;
+# &DEBUG("running netsplitCheck... $cache{netsplitCache}");
+
+ if (!scalar %netsplit and scalar %netsplitservers) {
+ &DEBUG("nsC: !hash netsplit but hash netsplitservers <- removing!");
+ undef %netsplitservers;
+ return;
+ }
+
+ # well... this shouldn't happen since %netsplit code does it anyway.
+ foreach $s1 (keys %netsplitservers) {
+
+ foreach $s2 (keys %{ $netsplitservers{$s1} }) {
+ my $delta = time() - $netsplitservers{$s1}{$s2};
+
+ if ($delta > 60*30) {
+ &status("netsplit between $s1 and $s2 appears to be stale.");
+ delete $netsplitservers{$s1}{$s2};
+ &chanlimitCheck();
+ }
+ }
+
+ my $i = scalar(keys %{ $netsplitservers{$s1} });
+ delete $netsplitservers{$s1} unless ($i);
+ }
+
+ # %netsplit hash checker.
+ my $count = scalar keys %netsplit;
+ my $delete = 0;
+ foreach (keys %netsplit) {
+ if (&IsNickInAnyChan($_)) { # why would this happen?
+# &DEBUG("nsC: $_ is in some chan; removing from netsplit list.");
+ delete $netsplit{$_};
+ $delete++;
+ next;
+ }
+
+ next unless (time() - $netsplit{$_} > 60*15);
+
+ $delete++;
+ 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);
+ &status("nsC: removed from netsplit list: (before: $count; after: $j)");
+ }
+
+ if (!scalar %netsplit and scalar %netsplitservers) {
+ &DEBUG("nsC: ok hash netsplit is NULL; purging hash netsplitservers");
+ undef %netsplitservers;
+ }
+
+ if ($count and !scalar keys %netsplit) {
+ &DEBUG("nsC: netsplit is hopefully gone. reinstating chanlimit check.");
+ &chanlimitCheck();
+ }
+}
+
+sub floodLoop {
+ my $delete = 0;
+ my $who;
+
+ if (@_) {
+ &ScheduleThis(60, 'floodLoop'); # minutes.
+ return if ($_[0] eq '2');
+ }
+
+ my $time = time();
+ my $interval = &getChanConfDefault('floodCycle',60, $chan);
+
+ foreach $who (keys %flood) {
+ foreach (keys %{ $flood{$who} }) {
+ if (!exists $flood{$who}{$_}) {
+ &WARN("flood{$who}{$_} undefined?");
+ next;
+ }
+
+ if ($time - $flood{$who}{$_} > $interval) {
+ delete $flood{$who}{$_};
+ $delete++;
+ }
+ }
+ }
+ &VERB("floodLoop: deleted $delete items.",2);
+}
+
+sub seenFlush {
+ if (@_) {
+ my $interval = &getChanConfDefault('seenFlushInterval', 60, $chan);
+ &ScheduleThis($interval, 'seenFlush');
+ return if ($_[0] eq '2');
+ }
+
+ my %stats;
+ my $nick;
+ my $flushed = 0;
+ $stats{'count_old'} = &countKeys('seen') || 0;
+ $stats{'new'} = 0;
+ $stats{'old'} = 0;
+
+ if ($param{'DBType'} =~ /^(mysql|pgsql|sqlite(2)?)$/i) {
+ foreach $nick (keys %seencache) {
+ my $retval = &sqlSet('seen', {'nick' => lc $seencache{$nick}{'nick'}}, {
+ time => $seencache{$nick}{'time'},
+ host => $seencache{$nick}{'host'},
+ channel => $seencache{$nick}{'chan'},
+ message => $seencache{$nick}{'msg'},
+ } );
+
+ delete $seencache{$nick};
+ $flushed++;
+ }
+ } else {
+ &DEBUG("seenFlush: NO VALID FACTOID SUPPORT?");
+ }
+
+ &status("Seen: Flushed $flushed entries.") if ($flushed);
+ &VERB(sprintf(" new seen: %03.01f%% (%d/%d)",
+ $stats{'new'}*100/($stats{'count_old'} || 1),
+ $stats{'new'}, ( $stats{'count_old'} || 1) ), 2) if ($stats{'new'});
+ &VERB(sprintf(" now seen: %3.1f%% (%d/%d)",
+ $stats{'old'}*100 / ( &countKeys('seen') || 1),
+ $stats{'old'}, &countKeys('seen') ), 2) if ($stats{'old'});
+
+ &WARN("scalar keys seenflush != 0!") if (scalar keys %seenflush);
+}
+
+sub leakCheck {
+ my ($blah1,$blah2);
+ my $count = 0;
+
+ if (@_) {
+ &ScheduleThis(240, 'leakCheck');
+ return if ($_[0] eq '2');
+ }
+
+ # flood. this is dealt with in floodLoop()
+ foreach $blah1 (keys %flood) {
+ foreach $blah2 (keys %{ $flood{$blah1} }) {
+ $count += scalar(keys %{ $flood{$blah1}{$blah2} });
+ }
+ }
+ &VERB("leak: hash flood has $count total keys.",2);
+
+ # floodjoin.
+ $count = 0;
+ foreach $blah1 (keys %floodjoin) {
+ foreach $blah2 (keys %{ $floodjoin{$blah1} }) {
+ $count += scalar(keys %{ $floodjoin{$blah1}{$blah2} });
+ }
+ }
+ &VERB("leak: hash floodjoin has $count total keys.",2);
+
+ # floodwarn.
+ $count = scalar(keys %floodwarn);
+ &VERB("leak: hash floodwarn has $count total keys.",2);
+
+ my $chan;
+ foreach $chan (grep /[A-Z]/, keys %channels) {
+ &DEBUG("leak: chan => '$chan'.");
+ my ($i,$j);
+ foreach $i (keys %{ $channels{$chan} }) {
+ foreach (keys %{ $channels{$chan}{$i} }) {
+ &DEBUG("leak: \$channels{$chan}{$i}{$_} ...");
+ }
+ }
+ }
+
+ # chanstats
+ $count = scalar(keys %chanstats);
+ &VERB("leak: hash chanstats has $count total keys.",2);
+
+ # nuh.
+ my $delete = 0;
+ foreach (keys %nuh) {
+ next if (&IsNickInAnyChan($_));
+ next if (exists $dcc{CHAT}{$_});
+
+ delete $nuh{$_};
+ $delete++;
+ }
+
+ &status("leak: $delete nuh{} items deleted; now have ".
+ scalar(keys %nuh) ) if ($delete);
+}
+
+sub ignoreCheck {
+ if (@_) {
+ &ScheduleThis(60, 'ignoreCheck');
+ return if ($_[0] eq '2'); # defer.
+ }
+
+ my $time = time();
+ my $count = 0;
+
+ foreach (keys %ignore) {
+ my $chan = $_;
+
+ foreach (keys %{ $ignore{$chan} }) {
+ my @array = @{ $ignore{$chan}{$_} };
+
+ next unless ($array[0] and $time > $array[0]);
+
+ delete $ignore{$chan}{$_};
+ &status("ignore: $_/$chan has expired.");
+ $count++;
+ }
+ }
+
+ $cache{ignoreCheckTime} = time();
+
+ &VERB("ignore: $count items deleted.",2);
+}
+
+sub ircCheck {
+ if (@_) {
+ &ScheduleThis(15, 'ircCheck');
+ return if ($_[0] eq '2'); # defer.
+ }
+
+ $cache{statusSafe} = 1;
+ foreach (sort keys %conns) {
+ $conn=$conns{$_};
+ my $mynick=$conn->nick();
+ &DEBUG("ircCheck for $_");
+ my @join = &getJoinChans(1);
+ if (scalar @join) {
+ &FIXME('ircCheck: found channels to join! ' . join(',',@join));
+ &joinNextChan();
+ }
+
+ # TODO: fix on_disconnect()
+
+ if (time() - $msgtime > 3600) {
+ # TODO: shouldn't we use cache{connect} somewhere?
+ if (exists $cache{connect}) {
+ &WARN("ircCheck: no msg for 3600 and disco'd! reconnecting!");
+ $msgtime = time(); # just in case.
+ &ircloop();
+ delete $cache{connect};
+ } else {
+ &status('ircCheck: possible lost in space; checking.'.
+ scalar(gmtime) );
+ &msg($mynick, 'TEST');
+ $cache{connect} = time();
+ }
+ }
+
+ if (grep /^\s*$/, keys %channels) {
+ &WARN('ircCheck: we have a NULL chan in hash channels? removing!');
+ if (!exists $channels{''}) {
+ &DEBUG('ircCheck: this should never happen!');
+ }
+
+ delete $channels{''};
+ }
+ }
+
+ $cache{statusSafe} = 0;
+
+ ### USER FILE.
+ if ($utime_userfile > $wtime_userfile and time() - $wtime_userfile > 3600) {
+ &writeUserFile();
+ $wtime_userfile = time();
+ }
+ ### CHAN FILE.
+ if ($utime_chanfile > $wtime_chanfile and time() - $wtime_chanfile > 3600) {
+ &writeChanFile();
+ $wtime_chanfile = time();
+ }
+}
+
+sub miscCheck {
+ if (@_) {
+ &ScheduleThis(120, 'miscCheck');
+ return if ($_[0] eq '2'); # defer.
+ }
+
+ # SHM check.
+ my @ipcs;
+ if ( -x "/usr/bin/ipcs") {
+ @ipcs = `/usr/bin/ipcs`;
+ } else {
+ &WARN("ircCheck: no 'ipcs' binary.");
+ return;
+ }
+
+ # make backup of important files.
+ &mkBackup( $bot_state_dir."/infobot.chan", 60*60*24*3);
+ &mkBackup( $bot_state_dir."/infobot.users", 60*60*24*3);
+ &mkBackup( $bot_base_dir."/infobot-news.txt", 60*60*24*1);
+
+ # flush cache{lobotomy}
+ foreach (keys %{ $cache{lobotomy} }) {
+ next unless (time() - $cache{lobotomy}{$_} > 60*60);
+ delete $cache{lobotomy}{$_};
+ }
+
+ ### check modules if they've been modified. might be evil.
+ &reloadAllModules();
+
+ # shmid stale remove.
+ foreach (@ipcs) {
+ chop;
+
+ # key, shmid, owner, perms, bytes, nattch
+ next unless (/^(0x\d+) (\d+)\s+(\S+)\s+(\d+)\s+(\d+)\s+/);
+
+ my ($shmid, $size) = ($2,$5);
+ next unless ($shmid != $shm and $size == 2000);
+ my $z = &shmRead($shmid);
+ if ($z =~ /^(\S+):(\d+):(\d+): /) {
+ my $n = $1;
+ my $pid = $2;
+ my $time = $3;
+ next if (time() - $time < 60*60);
+ # FIXME remove not-pid shm if parent process dead
+ next if ($pid == $bot_pid);
+ # don't touch other bots, if they're running.
+ next unless ($param{ircUser} =~ /^\Q$n\E$/);
+ } else {
+ &DEBUG("shm: $shmid is not ours or old infobot => ($z)");
+ next;
+ }
+
+ &status("SHM: nuking shmid $shmid");
+ CORE::system("/usr/bin/ipcrm shm $shmid >/dev/null");
+ }
+}
+
+sub miscCheck2 {
+ if (@_) {
+ &ScheduleThis(240, 'miscCheck2');
+ return if ($_[0] eq '2'); # defer.
+ }
+
+ # debian check.
+ opendir(DEBIAN, "$bot_state_dir/debian");
+ foreach ( grep /gz$/, readdir(DEBIAN) ) {
+ my $exit = CORE::system("gzip -t $bot_state_dir/debian/$_");
+ next unless ($exit);
+
+ &status("debian: unlinking file => $_");
+ unlink "$bot_state_dir/debian/$_";
+ }
+ closedir DEBIAN;
+
+ # compress logs that should have been compressed.
+ # TODO: use strftime?
+ my ($day,$month,$year) = (gmtime(time()))[3,4,5];
+ my $date = sprintf("%04d%02d%02d",$year+1900,$month+1,$day);
+
+ if (!opendir(DIR,"$bot_log_dir")) {
+ &ERROR("misccheck2: log dir $bot_log_dir does not exist.");
+ closedir DIR;
+ return -1;
+ }
+
+ while (my $f = readdir(DIR)) {
+ next unless ( -f "$bot_log_dir/$f");
+ next if ($f =~ /gz|bz2/);
+ next unless ($f =~ /(\d{8})/);
+ next if ($date eq $1);
+
+ &compress("$bot_log_dir/$f");
+ }
+ closedir DIR;
+}
+
+### this is semi-scheduled
+sub getNickInUse {
+# FIXME: broken for multiple connects
+# if ($ident eq $param{'ircNick'}) {
+# &status("okay, got my nick back.");
+# return;
+# }
+#
+# if (@_) {
+# &ScheduleThis(30, 'getNickInUse');
+# return if ($_[0] eq '2'); # defer.
+# }
+#
+# &nick( $param{'ircNick'} );
+}
+
+sub uptimeLoop {
+ return if (!defined &uptimeWriteFile);
+# return unless &IsParam('Uptime');
+
+ if (@_) {
+ &ScheduleThis(60, 'uptimeLoop');
+ return if ($_[0] eq '2'); # defer.
+ }
+
+ &uptimeWriteFile();
+}
+
+sub slashdotLoop {
+
+ if (@_) {
+ &ScheduleThis(60, 'slashdotLoop');
+ return if ($_[0] eq '2');
+ }
+
+ my @chans = &ChanConfList('slashdotAnnounce');
+ return unless (scalar @chans);
+
+ &Forker('slashdot', sub {
+ my $line = &Slashdot::slashdotAnnounce();
+ return unless (defined $line);
+
+ foreach (@chans) {
+ next unless (&::validChan($_));
+
+ &::status("sending slashdot update to $_.");
+ ¬ice($_, "Slashdot: $line");
+ }
+ } );
+}
+
+sub plugLoop {
+
+ if (@_) {
+ &ScheduleThis(60, 'plugLoop');
+ return if ($_[0] eq '2');
+ }
+
+ my @chans = &ChanConfList('plugAnnounce');
+ return unless (scalar @chans);
+
+ &Forker('Plug', sub {
+ my $line = &Plug::plugAnnounce();
+ return unless (defined $line);
+
+ foreach (@chans) {
+ next unless (&::validChan($_));
+
+ &::status("sending plug update to $_.");
+ ¬ice($_, "Plug: $line");
+ }
+ } );
+}
+
+sub kernelLoop {
+ if (@_) {
+ &ScheduleThis(240, 'kernelLoop');
+ return if ($_[0] eq '2');
+ }
+
+ my @chans = &ChanConfList('kernelAnnounce');
+ return unless (scalar @chans);
+
+ &Forker('Kernel', sub {
+ my @data = &Kernel::kernelAnnounce();
+
+ foreach (@chans) {
+ next unless (&::validChan($_));
+
+ &::status("sending kernel update to $_.");
+ my $c = $_;
+ foreach (@data) {
+ ¬ice($c, "Kernel: $_");
+ }
+ }
+ } );
+}
+
+sub wingateCheck {
+ return unless &IsChanConf('Wingate') > 0;
+
+ ### FILE CACHE OF OFFENDING WINGATES.
+ foreach (grep /^$host$/, @wingateBad) {
+ &status("Wingate: RUNNING ON $host BY $who");
+ &ban("*!*\@$host", '') if &IsChanConf('wingateBan') > 0;
+
+ my $reason = &getChanConf('wingateKick');
+
+ next unless ($reason);
+ &kick($who, '', $reason)
+ }
+
+ ### RUN CACHE OF TRIED WINGATES.
+ if (grep /^$host$/, @wingateCache) {
+ push(@wingateNow, $host); # per run.
+ push(@wingateCache, $host); # cache per run.
+ } else {
+ &DEBUG("Already scanned $host. good.");
+ }
+
+ my $interval = &getChanConfDefault('wingateInterval', 60, $chan); # seconds.
+ return if (defined $forked{'Wingate'});
+ return if (time() - $wingaterun <= $interval);
+ return unless (scalar(keys %wingateToDo));
+
+ $wingaterun = time();
+
+ &Forker('Wingate', sub { &Wingate::Wingates(keys %wingateToDo); } );
+ undef @wingateNow;
+}
+
+### TODO: ??
+sub wingateWriteFile {
+ if (@_) {
+ &ScheduleThis(60, 'wingateWriteFile');
+ return if ($_[0] eq '2'); # defer.
+ }
+
+ return unless (scalar @wingateCache);
+
+ my $file = "$bot_base_dir/$param{'ircUser'}.wingate";
+ if ($bot_pid != $$) {
+ &DEBUG('wingateWriteFile: Reorganising!');
+
+ open(IN, $file);
+ while (<IN>) {
+ chop;
+ push(@wingateNow, $_);
+ }
+ close IN;
+
+ # very lame hack.
+ my %hash = map { $_ => 1 } @wingateNow;
+ @wingateNow = sort keys %hash;
+ }
+
+ &DEBUG('wingateWF: writing...');
+ open(OUT, ">$file");
+ foreach (@wingateNow) {
+ print OUT "$_\n";
+ }
+ close OUT;
+}
+
+sub factoidCheck {
+ if (@_) {
+ &ScheduleThis(720, 'factoidCheck');
+ return if ($_[0] eq '2'); # defer.
+ }
+
+ my @list = &searchTable('factoids', 'factoid_key', 'factoid_key', " #DEL#");
+ my $stale = &getChanConfDefault('factoidDeleteDelay', 14, $chan) *60*60*24;
+ if ($stale < 1) {
+ # disable it since it's 'illegal'.
+ return;
+ }
+
+ my $time = time();
+
+ foreach (@list) {
+ my $age = &getFactInfo($_, 'modified_time');
+
+ if (!defined $age or $age !~ /^\d+$/) {
+ if (scalar @list > 50) {
+ if (!$cache{warnDel}) {
+ &WARN("list is over 50 (".scalar(@list)."... giving it a miss.");
+ $cache{warnDel} = 1;
+ last;
+ }
+ }
+
+ &WARN("del factoid: old cruft (no time): $_");
+ &delFactoid($_);
+ next;
+ }
+
+ next unless ($time - $age > $stale);
+
+ my $fix = $_;
+ $fix =~ s/ #DEL#$//g;
+ my $agestr = &Time2String($time - $age);
+ &status("safedel: Removing '$_' for good. [$agestr old]");
+
+ &delFactoid($_);
+ }
+}
+
+sub dccStatus {
+ return unless (scalar keys %{ $dcc{CHAT} });
+
+ if (@_) {
+ &ScheduleThis(10, 'dccStatus');
+ return if ($_[0] eq '2'); # defer.
+ }
+
+ my $time = strftime("%H:%M", gmtime(time()) );
+
+ my $c;
+ foreach (keys %channels) {
+ my $c = $_;
+ my $users = keys %{ $channels{$c}{''} };
+ my $chops = keys %{ $channels{$c}{o} };
+ my $bans = keys %{ $channels{$c}{b} };
+
+ my $txt = "[$time] $c: $users members ($chops chops), $bans bans";
+ foreach (keys %{ $dcc{'CHAT'} }) {
+ next unless (exists $channels{$c}{''}{lc $_});
+ $conn->privmsg($dcc{'CHAT'}{$_}, $txt);
+ }
+ }
+}
+
+sub scheduleList {
+ ###
+ # custom:
+ # a - time == now.
+ # b - weird time.
+ ###
+
+ my $reply = "sched:";
+ foreach (keys %{ $irc->{_queue}}) {
+ my $q = $_;
+ my $coderef = $irc->{_queue}->{$q}->[1];
+ my $sched;
+ foreach (keys %sched) {
+ my $schedname = $_;
+ next unless defined(\&$schedname);
+ next unless ($coderef eq \&$schedname);
+ $sched = $schedname;
+ last;
+ }
+
+ my $time = $irc->{_queue}->{$q}->[0] - time();
+
+ if (defined $sched) {
+ $reply = "$reply, $sched($q):" . &Time2String($time);
+ } else {
+ $reply = "$reply, NULL($q):" . &Time2String($time);
+ }
+ }
+
+ &DEBUG("$reply");
+}
+
+sub mkBackup {
+ my($file, $time) = @_;
+ my $backup = 0;
+
+ if (! -f $file) {
+ &VERB("mkB: file '$file' does not exist.",2);
+ return;
+ }
+
+ my $age = 'New';
+ if ( -e "$file~" ) {
+ $backup++ if ((stat $file)[9] - (stat "$file~")[9] > $time);
+ my $delta = time() - (stat "$file~")[9];
+ $age = &Time2String($delta);
+ } else {
+ $backup++;
+ }
+
+ return unless ($backup);
+
+ ### TODO: do internal copying.
+ &status("Backup: $file ($age)");
+ CORE::system("/bin/cp $file $file~");
+}
+
+1;
--- /dev/null
+#
+# Misc.pl: Miscellaneous stuff.
+# Author: dms
+# Version: 20000124
+# NOTE: Based on code by Kevin Lenzo & Patrick Cole (c) 1997
+#
+
+use strict;
+
+use vars qw(%file %mask %param %cmdstats %myModules);
+use vars qw($msgType $who $bot_pid $nuh $shm $force_public_reply
+ $no_timehires $bot_data_dir $addrchar);
+
+sub help {
+ my $topic = shift;
+ my $file = $bot_data_dir."/infobot.help";
+ my %help = ();
+
+ # crude hack for performStrictReply() to work as expected.
+ $msgType = 'private' if ($msgType eq 'public');
+
+ if (!open(FILE, $file)) {
+ &ERROR("Failed reading help file ($file): $!");
+ return;
+ }
+
+ while (defined(my $help = <FILE>)) {
+ $help =~ s/^[\# ].*//;
+ chomp $help;
+ next unless $help;
+ my ($key, $val) = split(/:/, $help, 2);
+
+ $val =~ s/^\s+//;
+ $val =~ s/^D:/\002 Desc\002:/;
+ $val =~ s/^E:/\002Example\002:/;
+ $val =~ s/^N:/\002 NOTE\002:/;
+ $val =~ s/^U:/\002 Usage\002:/;
+ $val =~ s/##/$key/;
+ $val =~ s/__/\037/g;
+ $val =~ s/==/ /;
+
+ $help{$key} = '' if (!exists $help{$key});
+ $help{$key} .= $val."\n";
+ }
+ close FILE;
+
+ if (!defined $topic or $topic eq '') {
+ &msg($who, $help{'main'});
+
+ my $i = 0;
+ my @array;
+ my $count = scalar(keys %help);
+ my $reply;
+ foreach (sort keys %help) {
+ push(@array,$_);
+ $reply = scalar(@array) ." topics: ".
+ join("\002,\002 ", @array);
+ $i++;
+
+ if (length $reply > 400 or $count == $i) {
+ &msg($who,$reply);
+ undef @array;
+ }
+ }
+
+ return '';
+ }
+
+ $topic = &fixString(lc $topic);
+
+ if (exists $help{$topic}) {
+ foreach (split /\n/, $help{$topic}) {
+ &performStrictReply($_);
+ }
+ } else {
+ &performStrictReply("no help on $topic. Use 'help' without arguments.");
+ }
+
+ return '';
+}
+
+sub getPath {
+ my ($pathnfile) = @_;
+
+ ### TODO: gotta hate an if statement.
+ if ($pathnfile =~ /(.*)\/(.*?)$/) {
+ return $1;
+ } else {
+ return ".";
+ }
+}
+
+sub timeget {
+ if ($no_timehires) { # fallback.
+ return time();
+ } else { # the real thing.
+ return [gettimeofday()];
+ }
+}
+
+sub timedelta {
+ my($start_time) = shift;
+
+ if ($no_timehires) { # fallback.
+ return time() - $start_time;
+ } else { # the real thing.
+ return tv_interval ($start_time);
+ }
+}
+
+###
+### FORM Functions.
+###
+
+###
+# Usage; &formListReply($rand, $prefix, @list);
+sub formListReply {
+ my($rand, $prefix, @list) = @_;
+ my $total = scalar @list;
+ my $maxshow = &getChanConfDefault('maxListReplyCount', 15, $chan);
+ my $maxlen = &getChanConfDefault('maxListReplyLength', 400, $chan);
+ my $reply;
+
+ # remove irc overhead
+ $maxlen -= 30;
+
+ # no results.
+ return $prefix ."returned no results." unless ($total);
+
+ # random.
+ if ($rand) {
+ my @rand;
+ foreach (&makeRandom($total)) {
+ push(@rand, $list[$_]);
+ last if (scalar @rand == $maxshow);
+ }
+ if ($total > $maxshow) {
+ @list = sort @rand;
+ } else {
+ @list = @rand;
+ }
+ } elsif ($total > $maxshow) {
+ &status("formListReply: truncating list.");
+
+ @list = @list[0..$maxshow-1];
+ }
+
+ # form the reply.
+ # FIXME: should grow and exit when full, not discard any that are oversize
+ while () {
+ $reply = $prefix ."(\002". scalar(@list). "\002";
+ $reply .= " of \002$total\002" if ($total != scalar @list);
+ $reply .= "): " . join(" \002;;\002 ", @list) .".";
+
+ last if (length($reply) < $maxlen and scalar(@list) <= $maxshow);
+ last if (scalar(@list) == 1);
+
+ pop @list;
+ }
+
+ return $reply;
+}
+
+### Intelligence joining of arrays.
+# Usage: &IJoin(@array);
+sub IJoin {
+ if (!scalar @_) {
+ return 'NULL';
+ } elsif (scalar @_ == 1) {
+ return $_[0];
+ } else {
+ return join(', ',@{_}[0..$#_-1]) . " and $_[$#_]";
+ }
+}
+
+#####
+# Usage: &Time2String(seconds);
+sub Time2String {
+ my ($time) = @_;
+ my $prefix = '';
+ my (@s, @t);
+
+ return 'NULL' if (!defined $time);
+ return $time if ($time !~ /\d+/);
+
+ if ($time < 0) {
+ $time = - $time;
+ $prefix = "- ";
+ }
+
+ $t[0] = int($time) % 60;
+ $t[1] = int($time / 60) % 60;
+ $t[2] = int($time / 3600) % 24;
+ $t[3] = int($time / 86400);
+
+ push(@s, "$t[3]d") if ($t[3] != 0);
+ push(@s, "$t[2]h") if ($t[2] != 0);
+ push(@s, "$t[1]m") if ($t[1] != 0);
+ push(@s, "$t[0]s") if ($t[0] != 0 or !@s);
+
+ my $retval = $prefix.join(' ', @s);
+ $retval =~ s/(\d+)/\002$1\002/g;
+ return $retval;
+}
+
+###
+### FIX Functions.
+###
+
+# Usage: &fixFileList(@files);
+sub fixFileList {
+ my @files = @_;
+ my %files;
+
+ # generate a hash list.
+ foreach (@files) {
+ next unless /^(.*\/)(.*?)$/;
+
+ $files{$1}{$2} = 1;
+ }
+ @files = (); # reuse the array.
+
+ # sort the hash list appropriately.
+ foreach (sort keys %files) {
+ my $file = $_;
+ my @keys = sort keys %{ $files{$file} };
+ my $i = scalar(@keys);
+
+ if (scalar @keys > 3) {
+ pop @keys while (scalar @keys > 3);
+ push(@keys, "...");
+ }
+
+ if ($i > 1) {
+ $file .= "\002{\002". join("\002|\002", @keys) ."\002}\002";
+ } else {
+ $file .= $keys[0];
+ }
+
+ push(@files,$file);
+ }
+
+ return @files;
+}
+
+# Usage: &fixString($str);
+sub fixString {
+ my ($str, $level) = @_;
+ if (!defined $str) {
+ &WARN("fixString: str == NULL.");
+ return '';
+ }
+
+ for ($str) {
+ s/^\s+//; # remove start whitespaces.
+ s/\s+$//; # remove end whitespaces.
+ s/\s+/ /g; # remove excessive whitespaces.
+
+ next unless (defined $level);
+ if (s/[\cA-\c_]//ig) { # remove control characters.
+ &DEBUG("stripped control chars");
+ }
+ }
+
+ return $str;
+}
+
+# Usage: &fixPlural($str,$int);
+sub fixPlural {
+ my ($str,$int) = @_;
+
+ if (!defined $str) {
+ &WARN("fixPlural: str == NULL.");
+ return;
+ }
+
+ if (!defined $int or $int =~ /^\D+$/) {
+ &WARN("fixPlural: int != defined or int");
+ return $str;
+ }
+
+ if ($str eq 'has') {
+ $str = 'have' if ($int > 1);
+ } elsif ($str eq 'is') {
+ $str = 'are' if ($int > 1);
+ } elsif ($str eq 'was') {
+ $str = 'were' if ($int > 1);
+ } elsif ($str eq 'this') {
+ $str = 'these' if ($int > 1);
+ } elsif ($str =~ /y$/) {
+ if ($int > 1) {
+ if ($str =~ /ey$/) {
+ $str .= 's'; # eg: 'money' => 'moneys'.
+ } else {
+ $str =~ s/y$/ies/;
+ }
+ }
+ } else {
+ $str .= 's' if ($int != 1);
+ }
+
+ return $str;
+}
+
+##########
+### get commands.
+###
+
+sub getRandomLineFromFile {
+ my($file) = @_;
+
+ if (!open(IN, $file)) {
+ &WARN("gRLfF: could not open ($file): $!");
+ return;
+ }
+
+ my @lines = <IN>;
+ close IN;
+
+ if (!scalar @lines) {
+ &ERROR("GRLF: nothing loaded?");
+ return;
+ }
+
+ # could we use the filehandler instead and put it through getRandom?
+ while (my $line = &getRandom(@lines)) {
+ chop $line;
+
+ next if ($line =~ /^\#/);
+ next if ($line =~ /^\s*$/);
+
+ return $line;
+ }
+}
+
+sub getLineFromFile {
+ my($file,$lineno) = @_;
+
+ if (! -f $file) {
+ &ERROR("getLineFromFile: file '$file' does not exist.");
+ return 0;
+ }
+
+ if (open(IN,$file)) {
+ my @lines = <IN>;
+ close IN;
+
+ if ($lineno > scalar @lines) {
+ &ERROR("getLineFromFile: lineno exceeds line count from file.");
+ return 0;
+ }
+
+ my $line = $lines[$lineno-1];
+ chop $line;
+ return $line;
+ } else {
+ &ERROR("gLFF: Could not open file ($file): $!");
+ return 0;
+ }
+}
+
+# Usage: &getRandom(@array);
+sub getRandom {
+ my @array = @_;
+
+ srand();
+ return $array[int(rand(scalar @array))];
+}
+
+# Usage: &getRandomInt("30-60");
+sub getRandomInt {
+ my $str = $_[0];
+
+ if (!defined $str) {
+ &WARN("gRI: str == NULL.");
+ return;
+ }
+
+ srand();
+
+ if ($str =~ /^(\d+(\.\d+)?)$/) {
+ my $i = $1;
+ my $fuzzy = int(rand 5);
+ if ($i < 10) {
+ return $i;
+ }
+ if (rand > 0.5) {
+ return ($i - $fuzzy)*60;
+ } else {
+ return ($i + $fuzzy)*60;
+ }
+ } elsif ($str =~ /^(\d+)-(\d+)$/) {
+ return ($2 - $1)*int(rand $1)*60;
+ } else {
+ return $str; # hope we're safe.
+ }
+
+ &ERROR("getRandomInt: invalid arg '$str'.");
+ return 1800;
+}
+
+##########
+### Is commands.
+###
+
+sub iseq {
+ my ($left,$right) = @_;
+ return 0 unless defined $right;
+ return 0 unless defined $left;
+ return 1 if ($left =~ /^\Q$right$/i);
+}
+
+sub isne {
+ my $retval = &iseq(@_);
+ return 1 unless ($retval);
+ return 0;
+}
+
+# Usage: &IsHostMatch($nuh);
+sub IsHostMatch {
+ my ($thisnuh) = @_;
+ my (%this,%local);
+
+ if ($nuh =~ /^(\S+)!(\S+)@(\S+)/) {
+ $local{'nick'} = lc $1;
+ $local{'user'} = lc $2;
+ $local{'host'} = &makeHostMask(lc $3);
+ }
+
+ if (!defined $thisnuh) {
+ &WARN("IHM: thisnuh == NULL.");
+ return 0;
+ } elsif ($thisnuh =~ /^(\S+)!(\S+)@(\S+)/) {
+ $this{'nick'} = lc $1;
+ $this{'user'} = lc $2;
+ $this{'host'} = &makeHostMask(lc $3);
+ } else {
+ &WARN("IHM: thisnuh is invalid '$thisnuh'.");
+ return 1 if ($thisnuh eq '');
+ return 0;
+ }
+
+ # auth if 1) user and host match 2) user and nick match.
+ # this may change in the future.
+
+ if ($this{'user'} =~ /^\Q$local{'user'}\E$/i) {
+ return 2 if ($this{'host'} eq $local{'host'});
+ return 1 if ($this{'nick'} eq $local{'nick'});
+ }
+ return 0;
+}
+
+####
+# Usage: &isStale($file, $age);
+sub isStale {
+ my ($file, $age) = @_;
+
+ if (!defined $age) {
+ &WARN("isStale: age == NULL.");
+ return 1;
+ }
+
+ if (!defined $file) {
+ &WARN("isStale: file == NULL.");
+ return 1;
+ }
+
+ &DEBUG("!exist $file") if (! -f $file);
+
+ return 1 unless ( -f $file);
+ if ($file =~ /idx/) {
+ my $age2 = time() - (stat($file))[9];
+ &VERB("stale: $age2. (". &Time2String($age2) .")",2);
+ }
+ $age *= 60*60*24 if ($age >= 0 and $age < 30);
+
+ return 1 if (time() - (stat($file))[9] > $age);
+ return 0;
+}
+
+sub isFileUpdated {
+ my ($file, $time) = @_;
+
+ if (! -f $file) {
+ return 1;
+ }
+
+ my $time_file = (stat $file)[9];
+
+ if ($time <= $time_file) {
+ return 0;
+ } else {
+ return 1;
+ }
+}
+
+##########
+### make commands.
+###
+
+# Usage: &makeHostMask($host);
+sub makeHostMask {
+ my ($host) = @_;
+ my $nu = '';
+
+ if ($host =~ s/^(\S+!\S+\@)//) {
+ &DEBUG("mHM: detected nick!user\@ for host arg; fixing");
+ &DEBUG("nu => $nu");
+ $nu = $1;
+ }
+
+ if ($host =~ /^$mask{ip}$/) {
+ return $nu."$1.$2.$3.*";
+ }
+
+ my @array = split(/\./, $host);
+ return $nu.$host if (scalar @array <= 3);
+ return $nu."*.".join('.',@{array}[1..$#array]);
+}
+
+# Usage: &makeRandom(int);
+sub makeRandom {
+ my ($max) = @_;
+ my @retval;
+ my %done;
+
+ if ($max =~ /^\D+$/) {
+ &ERROR("makeRandom: arg ($max) is not integer.");
+ return 0;
+ }
+
+ if ($max < 1) {
+ &ERROR("makeRandom: arg ($max) is not positive.");
+ return 0;
+ }
+
+ srand();
+ while (scalar keys %done < $max) {
+ my $rand = int(rand $max);
+ next if (exists $done{$rand});
+
+ push(@retval,$rand);
+ $done{$rand} = 1;
+ }
+
+ return @retval;
+}
+
+sub checkMsgType {
+ my ($reply) = @_;
+ return unless (&IsParam('minLengthBeforePrivate'));
+ return if ($force_public_reply);
+
+ if (length $reply > $param{'minLengthBeforePrivate'}) {
+ &status("Reply: len reply > minLBP ($param{'minLengthBeforePrivate'}); msgType now private.");
+ $msgType = 'private';
+ }
+}
+
+###
+### Valid.
+###
+
+# Usage: &validExec($string);
+sub validExec {
+ my ($str) = @_;
+
+ if ($str =~ /[\`\'\"\|]/) { # invalid.
+ return 0;
+ } else { # valid.
+ return 1;
+ }
+}
+
+# Usage: &hasProfanity($string);
+sub hasProfanity {
+ my ($string) = @_;
+ my $profanity = 1;
+
+ for (lc $string) {
+ /fuck/ and last;
+ /dick|dildo/ and last;
+ /shit/ and last;
+ /pussy|[ck]unt/ and last;
+ /wh[0o]re|bitch|slut/ and last;
+
+ $profanity = 0;
+ }
+
+ return $profanity;
+}
+
+sub IsChanConfOrWarn {
+ my ($param) = @_;
+
+ if (&IsChanConf($param) > 0) {
+ return 1;
+ } else {
+ ### TODO: specific reason why it failed.
+ &msg($who, "unfortunately, \002$param\002 is disabled in my configuration") unless ($addrchar);
+ return 0;
+ }
+}
+
+sub Forker {
+ my ($label, $code) = @_;
+ my $pid;
+
+ &shmFlush();
+ &VERB("double fork detected; not forking.",2) if ($$ != $bot_pid);
+
+ if (&IsParam('forking') and $$ == $bot_pid) {
+ return unless &addForked($label);
+
+ $SIG{CHLD} = 'IGNORE';
+ $pid = eval { fork() };
+ return if $pid; # parent does nothing
+
+ select(undef, undef, undef, 0.2);
+# &status("fork starting for '$label', PID == $$.");
+ &status("--- fork starting for '$label', PID == $$, bot_pid == $bot_pid ---");
+ &shmWrite($shm,"SET FORKPID $label $$");
+
+ sleep 1;
+ }
+
+ ### TODO: use AUTOLOAD
+ ### very lame hack.
+ if ($label !~ /-/ and !&loadMyModule($label)) {
+ &DEBUG("Forker: failed?");
+ &delForked($label);
+ }
+
+ if (defined $code) {
+ $code->(); # weird, hey?
+ } else {
+ &WARN("Forker: code not defined!");
+ }
+
+ &delForked($label);
+}
+
+sub closePID {
+ return 1 unless (exists $file{PID});
+ return 1 unless ( -f $file{PID});
+ return 1 if (unlink $file{PID});
+ return 0 if ( -f $file{PID});
+}
+
+sub mkcrypt {
+ my($str) = @_;
+ my $salt = join '',('.','/',0..9,'A'..'Z','a'..'z')[rand 64, rand 64];
+
+ return crypt($str, $salt);
+}
+
+sub closeStats {
+ return unless (&getChanConfList('ircTextCounters'));
+
+ foreach (keys %cmdstats) {
+ my $type = $_;
+ my $i = &sqlSelect('stats', 'counter', {
+ nick => $type,
+ type => 'cmdstats',
+ } );
+ my $z = 0;
+ $z++ unless ($i);
+
+ $i += $cmdstats{$type};
+
+
+ &sqlSet('stats', {'nick' => $type}, {
+ type => 'cmdstats',
+ 'time' => time(),
+ counter => $i,
+ } );
+ }
+}
+
+1;
--- /dev/null
+#!/usr/bin/perl
+#
+# BZFlag
+# Copyright (c) 1993 - 2002 Tim Riker
+#
+# This package is free software; you can redistribute it and/or
+# modify it under the terms of the license found in the file
+# named LICENSE that should have accompanied this file.
+#
+# THIS PACKAGE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
+# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
+# WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+
+package BZFlag;
+use strict;
+use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);
+
+my $no_BZFlag;
+
+BEGIN {
+ $no_BZFlag = 0;
+ eval "use Socket";
+ eval "use LWP::UserAgent";
+ $no_BZFlag++ if ($@);
+}
+
+sub BZFlag {
+ my ($message) = @_;
+ my ($retval);
+ if ($no_BZFlag) {
+ &::status("BZFlag module requires Socket.");
+ return 'BZFlag module not active';
+ }
+ if ($message =~ /^bzfquery\s+([^:]*)(?::([0-9]*))?$/xi) {
+ $retval = &query($1,$2);
+ } elsif ($message =~ /^bzflist$/xi) {
+ $retval = &list();
+ } else {
+ $retval = "BZFlag: unhandled command \"$message\"";
+ }
+ &::performStrictReply($retval);
+}
+
+sub list {
+ my ($response);
+ my $ua = new LWP::UserAgent;
+ $ua->proxy('http', $::param{'httpProxy'}) if (&::IsParam('httpProxy'));
+
+ $ua->timeout(5);
+
+ my $req = HTTP::Request->new('GET', 'http://db.bzflag.org/db/?action=LIST');
+ my $res = $ua->request($req);
+ my %servers;
+ my $totalServers = 0;
+ for my $line (split("\n",$res->content)) {
+ my ($serverport, $version, $flags, $ip, $comments) = split(" ",$line,5);
+ # not "(A4)18" to handle old dumb perl
+ my ($style, $maxShots, $shakeWins, $shakeTimeout, $maxPlayerScore, $maxTeamScore, $maxTime,
+ $maxPlayers, $rogueSize, $rogueMax, $redSize, $redMax, $greenSize, $greenMax,
+ $blueSize, $blueMax, $purpleSize, $purpleMax, $observerSize, $observerMax) =
+ unpack('A4A4A4A4A4A4A4A2A2A2A2A2A2A2A2A2A2A2A2A2', $flags);
+ my $playerSize = hex($rogueSize) + hex($redSize) + hex($greenSize)
+ + hex($blueSize) + hex($purpleSize) + hex($observerSize);
+ $servers{$serverport} = $playerSize;
+ $servers{$version} += $playerSize;
+ $servers{'PLAYERS'} += $playerSize;
+ $totalServers += 1;
+ }
+ $response .= "s=$totalServers";
+ foreach my $key (sort {$servers{$b} <=> $servers{$a}} (keys(%servers))) {
+ if ($servers{$key} > 0) {
+ $response .= " $key($servers{$key})";
+ }
+ }
+ &::performStrictReply($response);
+ return;
+}
+
+sub list17 {
+ my ($response);
+ my $ua = new LWP::UserAgent;
+ $ua->proxy('http', $::param{'httpProxy'}) if (&::IsParam('httpProxy'));
+
+ $ua->timeout(5);
+
+ my $req = HTTP::Request->new('GET', 'http://list.bzflag.org:5156/');
+ my $res = $ua->request($req);
+ my %servers;
+ my $totalServers = 0;
+ my $totalPlayers = 0;
+ for my $line (split("\n",$res->content)) {
+ my ($serverport, $version, $flags, $ip, $comments) = split(" ",$line,5);
+ # not "(A4)18" to handle old dumb perl
+ my ($style,$maxPlayers,$maxShots,
+ $rogueSize,$redSize,$greenSize,$blueSize,$purpleSize,
+ $rogueMax,$redMax,$greenMax,$blueMax,$purpleMax,
+ $shakeWins,$shakeTimeout,
+ $maxPlayerScore,$maxTeamScore,$maxTime) =
+ unpack('A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4', $flags);
+ my $playerSize = hex($rogueSize) + hex($redSize) + hex($greenSize)
+ + hex($blueSize) + hex($purpleSize);
+ $servers{$serverport} = $playerSize;
+ $totalServers += 1;
+ $totalPlayers += $playerSize;
+ }
+ $response .= "s=$totalServers p=$totalPlayers";
+ foreach my $key (sort {$servers{$b} <=> $servers{$a}} (keys(%servers))) {
+ if ($servers{$key} > 0) {
+ $response .= " $key($servers{$key})";
+ }
+ }
+ &::performStrictReply($response);
+ return;
+}
+
+sub querytext {
+ my ($servernameport) = @_;
+ my ($servername,$port) = split(":",$servernameport);
+ if ($no_BZFlag) {
+ &::status("BZFlag module requires Socket.");
+ return 'BZFlag module not active';
+ }
+ #my @teamName = ('Rogue', 'Red', 'Green', 'Blue', 'Purple', 'Observer', 'Rabbit');
+ my @teamName = ('X', 'R', 'G', 'B', 'P', 'O', 'K');
+ my ($message, $server, $response);
+ $port = 5154 unless $port;
+
+ # socket define
+ my $sockaddr = 'S n a4 x8';
+
+ # port to port number
+ my ($name,$aliases,$proto) = getprotobyname('tcp');
+ ($name,$aliases,$port) = getservbyname($port,'tcp') unless $port =~ /^\d+$/;
+
+ # get server address
+ my ($type,$len,$serveraddr);
+ ($name,$aliases,$type,$len,$serveraddr) = gethostbyname($servername);
+ $server = pack($sockaddr, AF_INET, $port, $serveraddr);
+
+ # connect
+ # TODO wrap this with a 5 second alarm()
+ return 'socket() error' unless socket(S1, AF_INET, SOCK_STREAM, $proto);
+ return "could not connect to $servername:$port" unless connect(S1, $server);
+
+ # don't buffer
+ select(S1); $| = 1; select(STDOUT);
+
+ # get hello
+ my $buffer;
+ return 'read error' unless read(S1, $buffer, 8) == 8;
+
+ # parse reply
+ my ($magic,$major,$minor,$something,$revision) = unpack("a4 a1 a1 a1 a1", $buffer);
+ my ($version) = $magic . $major . $minor . $something . $revision;
+
+ # quit if version isn't valid
+ return 'not a bzflag server' if ($magic ne 'BZFS');
+ $response .= "$major$minor$something$revision ";
+ # check version
+ if ($version eq 'BZFS0026') {
+ # 1.11.x handled here
+ return 'read error' unless read(S1, $buffer, 1) == 1;
+ my ($id) = unpack('C', $buffer);
+ return "rejected by server" if ($id == 255);
+
+ # send game request
+ print S1 pack('n2', 0, 0x7167);
+
+ # get reply
+ my $nbytes = read(S1, $buffer, 4);
+ my ($infolen, $infocode) = unpack('n2', $buffer);
+ if ($infocode == 0x6774) {
+ # read and ignore MsgGameTime from new servers
+ $nbytes = read(S1, $buffer, 8);
+ $nbytes = read(S1, $buffer, 4);
+ ($infolen, $infocode) = unpack('n2', $buffer);
+ }
+ $nbytes = read(S1, $buffer, 42);
+ if ($nbytes != 42) {
+ return "Error: read $nbytes bytes, expecting 46: $^E\n";
+ }
+
+ my ($style,$maxPlayers,$maxShots,
+ $rogueSize,$redSize,$greenSize,$blueSize,$purpleSize,$observerSize,
+ $rogueMax,$redMax,$greenMax,$blueMax,$purpleMax,$observerMax,
+ $shakeWins,$shakeTimeout,
+ $maxPlayerScore,$maxTeamScore,$maxTime,$timeElapsed) = unpack('n23', $buffer);
+ return "bad server data $infocode" unless $infocode == 0x7167;
+
+ # send players request
+ print S1 pack('n2', 0, 0x7170);
+
+ # get number of teams and players we'll be receiving
+ return 'count read error' unless read(S1, $buffer, 8) == 8;
+ my ($countlen,$countcode,$numTeams,$numPlayers) = unpack('n4', $buffer);
+
+ # get the teams
+ return 'bad count data' unless $countcode == 0x7170;
+ return 'count read error' unless read(S1, $buffer, 5) == 5;
+ ($countlen,$countcode,$numTeams) = unpack("n n C", $buffer);
+ for (1..$numTeams) {
+ return 'team read error' unless read(S1, $buffer, 8) == 8;
+ my ($team,$size,$won,$lost) = unpack('n4', $buffer);
+ if ($size > 0) {
+ my $score = $won - $lost;
+ $response .= "$teamName[$team]:$score($won-$lost) ";
+ }
+ }
+
+ # get the players
+ for (1..$numPlayers) {
+ last unless read(S1, $buffer, 175) == 175;
+ my ($playerlen,$playercode,$pID,$type,$team,$won,$lost,$tks,$sign,$email) =
+ unpack('n2Cn5A32A128', $buffer);
+ #my ($playerlen,$playercode,$pAddr,$pPort,$pNum,$type,$team,$won,$lost,$sign,$email) =
+ # unpack("n2Nn2 n4A32A128", $buffer);
+ return 'bad player data' unless $playercode == 0x6170;
+ my $score = $won - $lost;
+ $response .= " $sign($teamName[$team]";
+ $response .= ":$email" if ($email);
+ $response .= ")$score($won-$lost)";
+ }
+ $response .= "No Players" if ($numPlayers < 1);
+
+ # close socket
+ } elsif ($major == 1 && $minor == 9) {
+ # 1.10.x handled here
+ $revision = $something * 10 + $revision;
+ return 'read error' unless read(S1, $buffer, 1) == 1;
+ my ($id) = unpack('C', $buffer);
+
+ # send game request
+ print S1 pack('n2', 0, 0x7167);
+
+ # FIXME the packets are wrong from here down
+ # get reply
+ return 'server read error' unless read(S1, $buffer, 40) == 40;
+ my ($infolen,$infocode,$style,$maxPlayers,$maxShots,
+ $rogueSize,$redSize,$greenSize,$blueSize,$purpleSize,
+ $rogueMax,$redMax,$greenMax,$blueMax,$purpleMax,
+ $shakeWins,$shakeTimeout,
+ $maxPlayerScore,$maxTeamScore,$maxTime) = unpack('n20', $buffer);
+ return 'bad server data' unless $infocode == 0x7167;
+
+ # send players request
+ print S1 pack('n2', 0, 0x7170);
+
+ # get number of teams and players we'll be receiving
+ return 'count read error' unless read(S1, $buffer, 8) == 8;
+ my ($countlen,$countcode,$numTeams,$numPlayers) = unpack('n4', $buffer);
+
+ # get the teams
+ return 'bad count data' unless $countcode == 0x7170;
+ return 'count read error' unless read(S1, $buffer, 5) == 5;
+ ($countlen,$countcode,$numTeams) = unpack("n n C", $buffer);
+ for (1..$numTeams) {
+ return 'team read error' unless read(S1, $buffer, 8) == 8;
+ my ($team,$size,$won,$lost) = unpack('n4', $buffer);
+ if ($size > 0) {
+ my $score = $won - $lost;
+ $response .= "$teamName[$team]:$score($won-$lost) ";
+ }
+ }
+
+ # get the players
+ for (1..$numPlayers) {
+ last unless read(S1, $buffer, 175) == 175;
+ my ($playerlen,$playercode,$pID,$type,$team,$won,$lost,$tks,$sign,$email) =
+ unpack('n2Cn5A32A128', $buffer);
+ #my ($playerlen,$playercode,$pAddr,$pPort,$pNum,$type,$team,$won,$lost,$sign,$email) =
+ # unpack("n2Nn2 n4A32A128", $buffer);
+ return 'bad player data' unless $playercode == 0x6170;
+ my $score = $won - $lost;
+ $response .= " $sign($teamName[$team]";
+ $response .= ":$email" if ($email);
+ $response .= ")$score($won-$lost)";
+ }
+ $response .= "No Players" if ($numPlayers < 1);
+
+ # close socket
+ close(S1);
+ } elsif ($major == 1 && $minor == 0 && $something == 7) {
+ # 1.7* versions handled here
+ # old servers send a reconnect port number
+ return 'read error' unless read(S1, $buffer, 2) == 2;
+ my ($reconnect) = unpack('n', $buffer);
+ $minor = $minor * 10 + $something;
+ # quit if rejected
+ return 'rejected by server' if ($reconnect == 0);
+
+ # reconnect on new port
+ $server = pack($sockaddr, AF_INET, $reconnect, $serveraddr);
+ return 'socket() error on reconnect' unless socket(S, AF_INET, SOCK_STREAM, $proto);
+ return "could not reconnect to $servername:$reconnect" unless connect(S, $server);
+ select(S); $| = 1; select(STDOUT);
+
+ # close first socket
+ close(S1);
+
+ # send game request
+ print S pack('n2', 0, 0x7167);
+
+ # get reply
+ return 'server read error' unless read(S, $buffer, 40) == 40;
+ my ($infolen,$infocode,$style,$maxPlayers,$maxShots,
+ $rogueSize,$redSize,$greenSize,$blueSize,$purpleSize,
+ $rogueMax,$redMax,$greenMax,$blueMax,$purpleMax,
+ $shakeWins,$shakeTimeout,
+ $maxPlayerScore,$maxTeamScore,$maxTime) = unpack('n20', $buffer);
+ return 'bad server data' unless $infocode == 0x7167;
+
+ # send players request
+ print S pack('n2', 0, 0x7170);
+
+ # get number of teams and players we'll be receiving
+ return 'count read error' unless read(S, $buffer, 8) == 8;
+ my ($countlen,$countcode,$numTeams,$numPlayers) = unpack('n4', $buffer);
+ return 'bad count data' unless $countcode == 0x7170;
+
+ # get the teams
+ for (1..$numTeams) {
+ return 'team read error' unless read(S, $buffer, 14) == 14;
+ my ($teamlen,$teamcode,$team,$size,$aSize,$won,$lost) = unpack('n7', $buffer);
+ return 'bad team data' unless $teamcode == 0x7475;
+ if ($size > 0) {
+ my $score = $won - $lost;
+ $response .= "$teamName[$team]:$score($won-$lost) ";
+ }
+ }
+
+ # get the players
+ for (1..$numPlayers) {
+ last unless read(S, $buffer, 180) == 180;
+ my ($playerlen,$playercode,$pAddr,$pPort,$pNum,$type,$team,$won,$lost,$sign,$email) =
+ unpack("n2Nn2 n4A32A128", $buffer);
+ return 'bad player data' unless $playercode == 0x6170;
+ my $score = $won - $lost;
+ $response .= " $sign($teamName[$team]";
+ $response .= ":$email" if ($email);
+ $response .= ")$score($won-$lost)";
+ }
+ $response .= "No Players" if ($numPlayers <= 1);
+
+ # close socket
+ close(S);
+ } else {
+ $response = "incompatible version: $version";
+ }
+
+ return $response;
+}
+
+sub query {
+ my ($servernameport) = @_;
+ &::performStrictReply(&querytext($servernameport));
+ return;
+}
+
+1;
+# vim: ts=2 sw=2
--- /dev/null
+#
+# Debian.pl: Frontend to debian contents and packages files
+# Author: dms
+# Version: v0.8 (20000918)
+# Created: 20000106
+#
+
+package Debian;
+
+use strict;
+no strict 'refs'; # FIXME: dstats aborts if set
+
+my $announce = 0;
+my $defaultdist = 'sid';
+my $refresh = &::getChanConfDefault('debianRefreshInterval', 7, $::chan) * 60 * 60 * 24;
+my $debug = 0;
+my $debian_dir = $::bot_state_dir . '/debian';
+my $country = 'nl'; # well .config it yourself then. ;-)
+my $protocol = 'http';
+# EDIT THIS (i386, amd64, powerpc, [etc.]):
+my $arch = "$arch";
+
+# format: "alias=real".
+my %dists = (
+ 'unstable' => 'sid',
+ 'testing' => 'lenny',
+ 'stable' => 'etch',
+ 'oldstable' => 'sarge',
+ 'incoming' => 'incoming',
+);
+
+my %urlcontents = (
+ "Contents-##DIST-$arch.gz" =>
+ "$protocol://ftp.$country.debian.org".
+ "/debian/dists/##DIST/Contents-$arch.gz",
+ "Contents-##DIST-$arch-non-US.gz" =>
+ "$protocol://non-us.debian.org".
+ "/debian-non-US/dists/##DIST/non-US/Contents-$arch.gz",
+);
+
+my %urlpackages = (
+ "Packages-##DIST-main-$arch.gz" =>
+ "$protocol://ftp.$country.debian.org".
+ "/debian/dists/##DIST/main/binary-$arch/Packages.gz",
+ "Packages-##DIST-contrib-$arch.gz" =>
+ "$protocol://ftp.$country.debian.org".
+ "/debian/dists/##DIST/contrib/binary-$arch/Packages.gz",
+ "Packages-##DIST-non-free-$arch.gz" =>
+ "$protocol://ftp.$country.debian.org".
+ "/debian/dists/##DIST/non-free/binary-$arch/Packages.gz",
+);
+
+#####################
+### COMMON FUNCTION....
+#######################
+
+####
+# Usage: &DebianDownload($dist, %hash);
+sub DebianDownload {
+ my ($dist, %urls) = @_;
+ my $bad = 0;
+ my $good = 0;
+
+ if (! -d $debian_dir) {
+ &::status("Debian: creating debian dir.");
+ mkdir($debian_dir, 0755);
+ }
+
+ # fe dists.
+ # Download the files.
+ my $file;
+ foreach $file (keys %urls) {
+ my $url = $urls{$file};
+ $url =~ s/##DIST/$dist/g;
+ $file =~ s/##DIST/$dist/g;
+ my $update = 0;
+
+ if ( -f $file ) {
+ my $last_refresh = (stat $file)[9];
+ $update++ if (time() - $last_refresh > $refresh);
+ } else {
+ $update++;
+ }
+
+ next unless ($update);
+
+ &::DEBUG("announce == $announce.") if ($debug);
+ if ($good + $bad == 0 and !$announce) {
+ &::status("Debian: Downloading files for '$dist'.");
+ &::msg($::who, "Updating debian files... please wait.");
+ $announce++;
+ }
+
+ if (exists $::debian{$url}) {
+ &::DEBUG("2: ".(time - $::debian{$url})." <= $refresh") if ($debug);
+ next if (time() - $::debian{$url} <= $refresh);
+ &::DEBUG("stale for url $url; updating!") if ($debug);
+ }
+
+ if ($url =~ /^ftp:\/\/(.*?)\/(\S+)\/(\S+)$/) {
+ my ($host,$path,$thisfile) = ($1,$2,$3);
+
+ if (!&::ftpGet($host,$path,$thisfile,$file)) {
+ &::WARN("deb: down: $file == BAD.");
+ $bad++;
+ next;
+ }
+
+ } elsif ($url =~ /^http:\/\/\S+\/\S+$/) {
+
+ if (!&::getURLAsFile($url,$file)) {
+ &::WARN("deb: down: http: $file == BAD.");
+ $bad++;
+ next;
+ }
+
+ } else {
+ &::ERROR("Debian: invalid format of url => ($url).");
+ $bad++;
+ next;
+ }
+
+ if (! -f $file) {
+ &::WARN("deb: down: http: !file");
+ $bad++;
+ next;
+ }
+
+# my $exit = system("/bin/gzip -t $file");
+# if ($exit) {
+# &::WARN("deb: $file is corrupted ($exit) :/");
+# unlink $file;
+# next;
+# }
+
+ &::DEBUG("deb: download: good.") if ($debug);
+ $good++;
+ }
+
+ # ok... lets just run this.
+ &::miscCheck() if (&::whatInterface() =~ /IRC/);
+
+ if ($good) {
+ &generateIndex($dist);
+ return 1;
+ } else {
+ return -1 unless ($bad); # no download.
+ &::DEBUG("DD: !good and bad($bad). :(");
+ return 0;
+ }
+}
+
+###########################
+# DEBIAN CONTENTS SEARCH FUNCTIONS.
+########
+
+####
+# Usage: &searchContents($query);
+sub searchContents {
+ my ($dist, $query) = &getDistroFromStr($_[0]);
+ &::status("Debian: Contents search for '$query' in '$dist'.");
+ my $dccsend = 0;
+
+ $dccsend++ if ($query =~ s/^dcc\s+//i);
+
+ $query =~ s/\\([\^\$])/$1/g; # hrm?
+ $query =~ s/^\s+|\s+$//g;
+
+ if (!&::validExec($query)) {
+ &::msg($::who, 'search string looks fuzzy.');
+ return;
+ }
+
+ if ($dist eq 'incoming') { # nothing yet.
+ &::DEBUG('sC: dist = "incoming". no contents yet.');
+ return;
+ } else {
+ my %urls = &fixDist($dist, %urlcontents);
+ # download contents file.
+ &::DEBUG('deb: download 1.') if ($debug);
+ if (!&DebianDownload($dist, %urls)) {
+ &::WARN('Debian: could not download files.');
+ }
+ }
+
+ # start of search.
+ my $start_time = &::timeget();
+
+ my $found = 0;
+ my $front = 0;
+ my %contents;
+ my $grepRE;
+ ### TODO: search properly if /usr/bin/blah is done.
+ if ($query =~ s/\$$//) {
+ &::DEBUG("deb: search-regex found.") if ($debug);
+ $grepRE = "$query\[ \t]";
+ } elsif ($query =~ s/^\^//) {
+ &::DEBUG("deb: front marker regex found.") if ($debug);
+ $front = 1;
+ $grepRE = $query;
+ } else {
+ $grepRE = "$query*\[ \t]";
+ }
+
+ # fix up grepRE for "*".
+ $grepRE =~ s/\*/.*/g;
+
+ my @files;
+ foreach (keys %urlcontents) {
+ s/##DIST/$dist/g;
+
+ next unless ( -f "$debian_dir/$_" );
+ push(@files, "$debian_dir/$_");
+ }
+
+ if (!scalar @files) {
+ &::ERROR("sC: no files?");
+ &::msg($::who, "failed.");
+ return;
+ }
+
+ my $files = join(' ', @files);
+
+ my $regex = $query;
+ $regex =~ s/\./\\./g;
+ $regex =~ s/\*/\\S*/g;
+ $regex =~ s/\?/./g;
+
+ open(IN,"zegrep -h '$grepRE' $files |");
+ # wonderful abuse of if, last, next, return, and, unless ;)
+ while (<IN>) {
+ last if ($found > 100);
+
+ next unless (/^\.?\/?(.*?)[\t\s]+(\S+)\n$/);
+ my ($file,$package) = ("/".$1,$2);
+
+ if ($query =~ /[\/\*\\]/) {
+ next unless (eval { $file =~ /$regex/ });
+ return unless &checkEval($@);
+ } else {
+ my ($basename) = $file =~ /^.*\/(.*)$/;
+ next unless (eval { $basename =~ /$regex/ });
+ return unless &checkEval($@);
+ }
+ next if ($query !~ /\.\d\.gz/ and $file =~ /\/man\//);
+ next if ($front and eval { $file !~ /^\/$query/ });
+ return unless &checkEval($@);
+
+ $contents{$package}{$file} = 1;
+ $found++;
+ }
+ close IN;
+
+ my $pkg;
+
+ ### send results with dcc.
+ if ($dccsend) {
+ if (exists $::dcc{'SEND'}{$::who}) {
+ &::msg($::who, "DCC already active!");
+ return;
+ }
+
+ if (!scalar %contents) {
+ &::msg($::who,"search returned no results.");
+ return;
+ }
+
+ my $file = "$::param{tempDir}/$::who.txt";
+ if (!open OUT, ">$file") {
+ &::ERROR("Debian: cannot write file for dcc send.");
+ return;
+ }
+
+ foreach $pkg (keys %contents) {
+ foreach (keys %{ $contents{$pkg} }) {
+ # TODO: correct padding.
+ print OUT "$_\t\t\t$pkg\n";
+ }
+ }
+ close OUT;
+
+ &::shmWrite($::shm, "DCC SEND $::who $file");
+
+ return;
+ }
+
+ &::status("Debian: $found contents results found.");
+
+ my @list;
+ foreach $pkg (keys %contents) {
+ my @tmplist = &::fixFileList(keys %{ $contents{$pkg} });
+ my @sublist = sort { length $a <=> length $b } @tmplist;
+
+ pop @sublist while (scalar @sublist > 3);
+
+ $pkg =~ s/\,/\037\,\037/g; # underline ','.
+ push(@list, "(". join(', ',@sublist) .") in $pkg");
+ }
+ # sort the total list from shortest to longest...
+ @list = sort { length $a <=> length $b } @list;
+
+ # show how long it took.
+ my $delta_time = &::timedelta($start_time);
+ &::status(sprintf("Debian: %.02f sec to complete query.", $delta_time)) if ($delta_time > 0);
+
+ my $prefix = "Debian Search of '$query' ";
+ if (scalar @list) { # @list.
+ &::performStrictReply( &::formListReply(0, $prefix, @list) );
+ return;
+ }
+
+ # !@list.
+ &::DEBUG("deb: ok, !\@list, searching desc for '$query'.") if ($debug);
+ @list = &searchDesc($query);
+
+ if (!scalar @list) {
+ my $prefix = "Debian Package/File/Desc Search of '$query' ";
+ &::performStrictReply( &::formListReply(0, $prefix, ) );
+
+ } elsif (scalar @list == 1) { # list = 1.
+ &::DEBUG("deb: list == 1; showing package info of '$list[0]'.");
+ &infoPackages("info", $list[0]);
+
+ } else { # list > 1.
+ my $prefix = "Debian Desc Search of '$query' ";
+ &::performStrictReply( &::formListReply(0, $prefix, @list) );
+ }
+}
+
+####
+# Usage: &searchAuthor($query);
+sub searchAuthor {
+ my ($dist, $query) = &getDistroFromStr($_[0]);
+ &::DEBUG("deb: searchAuthor: dist => '$dist', query => '$query'.") if ($debug);
+ $query =~ s/^\s+|\s+$//g;
+
+ # start of search.
+ my $start_time = &::timeget();
+ &::status("Debian: starting author search.");
+
+ my $files;
+ my ($bad,$good) = (0,0);
+ my %urls = %urlpackages;
+
+ foreach (keys %urlpackages) {
+ s/##DIST/$dist/g;
+
+ if (! -f "$debian_dir/$_" ) {
+ $bad++;
+ next;
+ }
+
+ $good++;
+ $files .= " ".$_;
+ }
+
+ &::DEBUG("deb: good = $good, bad = $bad...") if ($debug);
+
+ if ($good == 0 and $bad != 0) {
+ my %urls = &fixDist($dist, %urlpackages);
+ &::DEBUG("deb: download 2.");
+
+ if (!&DebianDownload($dist, %urls)) {
+ &::ERROR("Debian(sA): could not download files.");
+ return;
+ }
+ }
+
+ my (%maint, %pkg, $package);
+ open(IN,"zegrep -h '^Package|^Maintainer' $files |");
+ while (<IN>) {
+ if (/^Package: (\S+)$/) {
+ $package = $1;
+
+ } elsif (/^Maintainer: (.*) \<(\S+)\>$/) {
+ my($name,$email) = ($1,$2);
+ if ($package eq "") {
+ &::DEBUG("deb: sA: package == NULL.");
+ next;
+ }
+ $maint{$name}{$email} = 1;
+ $pkg{$name}{$package} = 1;
+ $package = "";
+
+ } else {
+ chop;
+ &::WARN("debian: invalid line: '$_' (1).");
+ }
+ }
+ close IN;
+
+ my %hash;
+ # TODO: can we use 'map' here?
+ foreach (grep /\Q$query\E/i, keys %maint) {
+ $hash{$_} = 1;
+ }
+
+ # TODO: should we only search email if '@' is used?
+ if (scalar keys %hash < 15) {
+ my $name;
+
+ foreach $name (keys %maint) {
+ my $email;
+
+ foreach $email (keys %{ $maint{$name} }) {
+ next unless ($email =~ /\Q$query\E/i);
+ next if (exists $hash{$name});
+ $hash{$name} = 1;
+ }
+ }
+ }
+
+ my @list = keys %hash;
+ if (scalar @list != 1) {
+ my $prefix = "Debian Author Search of '$query' ";
+ &::performStrictReply( &::formListReply(0, $prefix, @list) );
+ return 1;
+ }
+
+ &::DEBUG("deb: showing all packages by '$list[0]'...") if ($debug);
+
+ my @pkg = sort keys %{ $pkg{$list[0]} };
+
+ # show how long it took.
+ my $delta_time = &::timedelta($start_time);
+ &::status(sprintf("Debian: %.02f sec to complete query.", $delta_time)) if ($delta_time > 0);
+
+ my $email = join(', ', keys %{ $maint{$list[0]} });
+ my $prefix = "Debian Packages by $list[0] \002<\002$email\002>\002 ";
+ &::performStrictReply( &::formListReply(0, $prefix, @pkg) );
+}
+
+####
+# Usage: &searchDesc($query);
+sub searchDesc {
+ my ($dist, $query) = &getDistroFromStr($_[0]);
+ &::DEBUG("deb: searchDesc: dist => '$dist', query => '$query'.") if ($debug);
+ $query =~ s/^\s+|\s+$//g;
+
+ # start of search.
+ my $start_time = &::timeget();
+ &::status("Debian: starting desc search.");
+
+ my $files;
+ my ($bad,$good) = (0,0);
+ my %urls = %urlpackages;
+
+ foreach (keys %urlpackages) {
+ s/##DIST/$dist/g;
+
+ if (! -f "$debian_dir/$_" ) {
+ $bad++;
+ next;
+ }
+
+ $good++;
+ $files .= " $debian_dir/$_";
+ }
+
+ &::DEBUG("deb(2): good = $good, bad = $bad...") if ($debug);
+
+ if ($good == 0 and $bad != 0) {
+ my %urls = &fixDist($dist, %urlpackages);
+ &::DEBUG("deb: download 2c.") if ($debug);
+
+ if (!&DebianDownload($dist, %urls)) {
+ &::ERROR("deb: sD: could not download files.");
+ return;
+ }
+ }
+
+ my $regex = $query;
+ $regex =~ s/\./\\./g;
+ $regex =~ s/\*/\\S*/g;
+ $regex =~ s/\?/./g;
+
+ my (%desc, $package);
+ open(IN,"zegrep -h '^Package|^Description' $files |");
+ while (<IN>) {
+ if (/^Package: (\S+)$/) {
+ $package = $1;
+ } elsif (/^Description: (.*)$/) {
+ my $desc = $1;
+ next unless (eval { $desc =~ /$regex/i });
+ return unless &checkEval($@);
+
+ if ($package eq "") {
+ &::WARN("sD: package == NULL?");
+ next;
+ }
+
+ $desc{$package} = $desc;
+ $package = "";
+
+ } else {
+ chop;
+ &::WARN("debian: invalid line: '$_'. (2)");
+ }
+ }
+ close IN;
+
+ # show how long it took.
+ my $delta_time = &::timedelta($start_time);
+ &::status(sprintf("Debian: %.02f sec to complete query.", $delta_time)) if ($delta_time > 0);
+
+ return keys %desc;
+}
+
+####
+# Usage: &generateIncoming();
+sub generateIncoming {
+ my $pkgfile = $debian_dir."/Packages-incoming";
+ my $idxfile = $pkgfile.".idx";
+ my $stale = 0;
+ $stale++ if (&::isStale($pkgfile.".gz", $refresh));
+ $stale++ if (&::isStale($idxfile, $refresh));
+ &::DEBUG("deb: gI: stale => '$stale'.") if ($debug);
+ return 0 unless ($stale);
+
+ ### STATIC URL.
+ my %ftp = &::ftpList("llug.sep.bnl.gov", "/pub/debian/Incoming/");
+
+ if (!open PKG, ">$pkgfile") {
+ &::ERROR("cannot write to pkg $pkgfile.");
+ return 0;
+ }
+ if (!open IDX, ">$idxfile") {
+ &::ERROR("cannot write to idx $idxfile.");
+ return 0;
+ }
+
+ print IDX "*$pkgfile.gz\n";
+ my $file;
+ foreach $file (sort keys %ftp) {
+ next unless ($file =~ /deb$/);
+
+ if ($file =~ /^(\S+)\_(\S+)\_(\S+)\.deb$/) {
+ print IDX "$1\n";
+ print PKG "Package: $1\n";
+ print PKG "Version: $2\n";
+ print PKG "Architecture: ", (defined $4) ? $4 : "all", "\n";
+ }
+ print PKG "Filename: $file\n";
+ print PKG "Size: $ftp{$file}\n";
+ print PKG "\n";
+ }
+ close IDX;
+ close PKG;
+
+ system("gzip -9fv $pkgfile"); # lame fix.
+
+ &::status("Debian: generateIncoming() complete.");
+}
+
+
+##############################
+# DEBIAN PACKAGE INFO FUNCTIONS.
+#########
+
+# Usage: &getPackageInfo($query,$file);
+sub getPackageInfo {
+ my ($package, $file) = @_;
+
+ if (! -f $file) {
+ &::status("gPI: file $file does not exist?");
+ return 'NULL';
+ }
+
+ my $found = 0;
+ my (%pkg, $pkg);
+
+ open(IN, "/bin/zcat $file 2>&1 |");
+
+ my $done = 0;
+ while (!eof IN) {
+ $_ = <IN>;
+
+ next if (/^ \S+/); # package long description.
+
+ # package line.
+ if (/^Package: (.*)\n$/) {
+ $pkg = $1;
+ if ($pkg =~ /^\Q$package\E$/i) {
+ $found++; # we can use pkg{'package'} instead.
+ $pkg{'package'} = $pkg;
+ }
+
+ next;
+ }
+
+ if ($found) {
+ chop;
+
+ if (/^Version: (.*)$/) {
+ $pkg{'version'} = $1;
+ } elsif (/^Priority: (.*)$/) {
+ $pkg{'priority'} = $1;
+ } elsif (/^Section: (.*)$/) {
+ $pkg{'section'} = $1;
+ } elsif (/^Size: (.*)$/) {
+ $pkg{'size'} = $1;
+ } elsif (/^Installed-Size: (.*)$/i) {
+ $pkg{'installed'} = $1;
+ } elsif (/^Description: (.*)$/) {
+ $pkg{'desc'} = $1;
+ } elsif (/^Filename: (.*)$/) {
+ $pkg{'find'} = $1;
+ } elsif (/^Pre-Depends: (.*)$/) {
+ $pkg{'depends'} = "pre-depends on $1";
+ } elsif (/^Depends: (.*)$/) {
+ if (exists $pkg{'depends'}) {
+ $pkg{'depends'} .= "; depends on $1";
+ } else {
+ $pkg{'depends'} = "depends on $1";
+ }
+ } elsif (/^Maintainer: (.*)$/) {
+ $pkg{'maint'} = $1;
+ } elsif (/^Provides: (.*)$/) {
+ $pkg{'provides'} = $1;
+ } elsif (/^Suggests: (.*)$/) {
+ $pkg{'suggests'} = $1;
+ } elsif (/^Conflicts: (.*)$/) {
+ $pkg{'conflicts'} = $1;
+ }
+
+### &::DEBUG("=> '$_'.");
+ }
+
+ # blank line.
+ if (/^$/) {
+ undef $pkg;
+ last if ($found);
+ next;
+ }
+
+ next if (defined $pkg);
+ }
+
+ close IN;
+
+ %pkg;
+}
+
+# Usage: &infoPackages($query,$package);
+sub infoPackages {
+ my ($query,$dist,$package) = ($_[0], &getDistroFromStr($_[1]));
+
+ &::status("Debian: Searching for package '$package' in '$dist'.");
+
+ # download packages file.
+ # hrm...
+ my %urls = &fixDist($dist, %urlpackages);
+ if ($dist ne "incoming") {
+ &::DEBUG("deb: download 3.") if ($debug);
+
+ if (!&DebianDownload($dist, %urls)) { # no good download.
+ &::WARN("Debian(iP): could not download ANY files.");
+ }
+ }
+
+ # check if the package is valid.
+ my $incoming = 0;
+ my @files = &validPackage($package, $dist);
+ if (!scalar @files) {
+ &::status("Debian: no valid package found; checking incoming.");
+ @files = &validPackage($package, "incoming");
+
+ if (scalar @files) {
+ &::status("Debian: cool, it exists in incoming.");
+ $incoming++;
+ } else {
+ &::msg($::who, "Package '$package' does not exist.");
+ return 0;
+ }
+ }
+
+ if (scalar @files > 1) {
+ &::WARN("same package in more than one file; random.");
+ &::DEBUG("THIS SHOULD BE FIXED SOMEHOW!!!");
+ $files[0] = &::getRandom(@files);
+ }
+
+ if (! -f $files[0]) {
+ &::WARN("files[0] ($files[0]) doesn't exist.");
+ &::msg($::who, "FIXME: $files[0] does not exist?");
+ return 'NULL';
+ }
+
+ ### TODO: if specific package is requested, note down that a version
+ ### exists in incoming.
+
+ my $found = 0;
+ my $file = $files[0];
+ my ($pkg);
+
+ ### TODO: use fe, dump to a hash. if only one version of the package
+ ### exists. do as normal otherwise list all versions.
+ if (! -f $file) {
+ &::ERROR("D:iP: file '$file' DOES NOT EXIST!!! should never happen.");
+ return 0;
+ }
+ my %pkg = &getPackageInfo($package, $file);
+
+ $query = "info" if ($query eq "dinfo");
+
+ # 'fm'-like output.
+ if ($query eq "info") {
+ if (scalar keys %pkg <= 5) {
+ &::DEBUG("deb: running debianCheck() due to problems (".scalar(keys %pkg).").");
+ &debianCheck();
+ &::DEBUG("deb: end of debianCheck()");
+
+ &::msg($::who,"Debian: Package appears to exist but I could not retrieve info about it...");
+ return;
+ }
+
+ $pkg{'info'} = "\002(\002". $pkg{'desc'} ."\002)\002";
+ $pkg{'info'} .= ", section ".$pkg{'section'};
+ $pkg{'info'} .= ", is ".$pkg{'priority'};
+# $pkg{'info'} .= ". Version: \002$pkg{'version'}\002";
+ $pkg{'info'} .= ". Version: \002$pkg{'version'}\002 ($dist)";
+ $pkg{'info'} .= ", Packaged size: \002". int($pkg{'size'}/1024) ."\002 kB";
+ $pkg{'info'} .= ", Installed size: \002$pkg{'installed'}\002 kB";
+
+ if ($incoming) {
+ &::status("iP: info requested and pkg is in incoming, too.");
+ my %incpkg = &getPackageInfo($query, $debian_dir ."/Packages-incoming");
+
+ if (scalar keys %incpkg) {
+ $pkg{'info'} .= ". Is in incoming ($incpkg{'file'}).";
+ } else {
+ &::ERROR("iP: pkg $query is in incoming but we couldn't get any info?");
+ }
+ }
+ }
+
+ if ($dist eq "incoming") {
+ $pkg{'info'} .= "Version: \002$pkg{'version'}\002";
+ $pkg{'info'} .= ", Packaged size: \002". int($pkg{'size'}/1024) ."\002 kB";
+ $pkg{'info'} .= ", is in incoming!!!";
+ }
+
+ if (!exists $pkg{$query}) {
+ if ($query eq "suggests") {
+ $pkg{$query} = "has no suggestions";
+ } elsif ($query eq "conflicts") {
+ $pkg{$query} = "does not conflict with any other package";
+ } elsif ($query eq "depends") {
+ $pkg{$query} = "does not depend on anything";
+ } elsif ($query eq "maint") {
+ $pkg{$query} = "has no maintainer";
+ } else {
+ $pkg{$query} = "has nothing about $query";
+ }
+ }
+
+ &::performStrictReply("$package: $pkg{$query}");
+}
+
+# Usage: &infoStats($dist);
+sub infoStats {
+ my ($dist) = @_;
+ $dist = &getDistro($dist);
+ return unless (defined $dist);
+
+ &::DEBUG("deb: infoS: dist => '$dist'.");
+
+ # download packages file if needed.
+ my %urls = &fixDist($dist, %urlpackages);
+ &::DEBUG("deb: download 4.");
+ if (!&DebianDownload($dist, %urls)) {
+ &::WARN("Debian(iS): could not download ANY files.");
+ &::msg($::who, "Debian(iS): internal error.");
+ return;
+ }
+
+ my %stats;
+ my %total = (count => 0, maint => 0, isize => 0, csize => 0);
+ my $file;
+ foreach $file (keys %urlpackages) {
+ $file =~ s/##DIST/$dist/g; # won't work for incoming.
+ &::DEBUG("deb: file => '$file'.");
+ if (exists $stats{$file}{'count'}) {
+ &::DEBUG("deb: hrm... duplicate open with $file???");
+ next;
+ }
+
+ open(IN, "zcat $debian_dir/$file 2>&1 |");
+
+ if (! -e "$debian_dir/$file") {
+ &::DEBUG("deb: iS: $debian_dir/$file does not exist.");
+ next;
+ }
+
+ while (!eof IN) {
+ $_ = <IN>;
+
+ next if (/^ \S+/); # package long description.
+
+ if (/^Package: (.*)\n$/) { # counter.
+ $stats{$file}{'count'}++;
+ $total{'count'}++;
+ } elsif (/^Maintainer: .* <(\S+)>$/) {
+ $stats{$file}{'maint'}{$1}++;
+ $total{'maint'}{$1}++;
+ } elsif (/^Size: (.*)$/) { # compressed size.
+ $stats{$file}{'csize'} += $1;
+ $total{'csize'} += $1;
+ } elsif (/^i.*size: (.*)$/i) { # installed size.
+ $stats{$file}{'isize'} += $1;
+ $total{'isize'} += $1;
+ }
+
+### &::DEBUG("=> '$_'.");
+ }
+ close IN;
+ }
+
+ ### TODO: don't count ppl with multiple email addresses.
+
+ &::performStrictReply(
+ "Debian Distro Stats on $dist... ".
+ "\002$total{'count'}\002 packages, ".
+ "\002".scalar(keys %{ $total{'maint'} })."\002 maintainers, ".
+ "\002". int($total{'isize'}/1024)."\002 MB installed size, ".
+ "\002". int($total{'csize'}/1024/1024)."\002 MB compressed size."
+ );
+
+### TODO: do individual stats? if so, we need _another_ arg.
+# foreach $file (keys %stats) {
+# foreach (keys %{ $stats{$file} }) {
+# &::DEBUG(" '$file' '$_' '$stats{$file}{$_}'.");
+# }
+# }
+
+ return;
+}
+
+###
+# HELPER FUNCTIONS FOR INFOPACKAGES...
+###
+
+# Usage: &generateIndex();
+sub generateIndex {
+ my (@dists) = @_;
+ &::DEBUG("D: generateIndex($dists[0]) called!");
+ if (!scalar @dists or $dists[0] eq '') {
+ &::ERROR("gI: no dists to generate index.");
+ return 1;
+ }
+
+ foreach (@dists) {
+ my $dist = &getDistro($_); # incase the alias is returned, possible?
+ my $idx = $debian_dir."/Packages-$dist.idx";
+
+ # TODO: check if any of the Packages file have been updated then
+ # regenerate it, even if it's not stale.
+ # TODO: also, regenerate the index if the packages file is newer
+ # than the index.
+ next unless (&::isStale($idx, $refresh));
+
+ if (/^incoming$/i) {
+ &::DEBUG("deb: gIndex: calling generateIncoming()!");
+ &generateIncoming();
+ next;
+ }
+
+ if (/^woody$/i) {
+ &::DEBUG("deb: Copying old index of woody to -old");
+ system("cp $idx $idx-old");
+ }
+
+ &::DEBUG("deb: gIndex: calling DebianDownload($dist, ...).") if ($debug);
+ &DebianDownload($dist, &fixDist($dist, %urlpackages) );
+
+ &::status("Debian: generating index for '$dist'.");
+ if (!open OUT, ">$idx") {
+ &::ERROR("cannot write to $idx.");
+ return 0;
+ }
+
+ my $packages;
+ foreach $packages (keys %urlpackages) {
+ $packages =~ s/##DIST/$dist/;
+ $packages = "$debian_dir/$packages";
+
+ if (! -e $packages) {
+ &::ERROR("gIndex: '$packages' does not exist?");
+ next;
+ }
+
+ print OUT "*$packages\n";
+ open(IN,"zcat $packages |");
+
+ while (<IN>) {
+ next unless (/^Package: (.*)\n$/);
+ print OUT $1."\n";
+ }
+ close IN;
+ }
+ close OUT;
+ }
+
+ return 1;
+}
+
+# Usage: &validPackage($package, $dist);
+sub validPackage {
+ my ($package,$dist) = @_;
+ my @files;
+ my $file;
+
+ ### this majorly sucks, we need some standard in place.
+ # why is this needed... need to investigate later.
+ my $olddist = $dist;
+ $dist = &getDistro($dist);
+
+ &::DEBUG("deb: validPackage($package, $dist) called.") if ($debug);
+
+ my $error = 0;
+ while (!open IN, $debian_dir."/Packages-$dist.idx") {
+ if ($error) {
+ &::ERROR("Packages-$dist.idx does not exist (#1).");
+ return;
+ }
+
+ &generateIndex($dist);
+
+ $error++;
+ }
+
+ my $count = 0;
+ while (<IN>) {
+ if (/^\*(.*)\n$/) {
+ $file = $1;
+ next;
+ }
+
+ if (/^\Q$package\E\n$/) {
+ push(@files,$file);
+ }
+ $count++;
+ }
+ close IN;
+
+ &::VERB("vP: scanned $count items in index.",2);
+
+ return @files;
+}
+
+sub searchPackage {
+ my ($dist, $query) = &getDistroFromStr($_[0]);
+ my $file = $debian_dir."/Packages-$dist.idx";
+ my $warn = ($query =~ tr/A-Z/a-z/) ? 1 : 0;
+ my $error = 0;
+ my @files;
+
+ &::status("Debian: Search package matching '$query' in '$dist'.");
+ unlink $file if ( -z $file );
+
+ while (!open IN, $file) {
+ if ($dist eq "incoming") {
+ &::DEBUG("deb: sP: dist == incoming; calling gI().");
+ &generateIncoming();
+ }
+
+ if ($error) {
+ &::ERROR("could not generate index ($file)!");
+ return;
+ }
+
+ $error++;
+ &::DEBUG("deb: should we be doing this?");
+ &generateIndex(($dist));
+ }
+
+ while (<IN>) {
+ chop;
+
+ if (/^\*(.*)$/) {
+ $file = $1;
+
+ if (&::isStale($file, $refresh)) {
+ &::DEBUG("deb: STALE $file! regen.") if ($debug);
+ &generateIndex(($dist));
+### @files = searchPackage("$query $dist");
+ &::DEBUG("deb: EVIL HACK HACK HACK.") if ($debug);
+ last;
+ }
+
+ next;
+ }
+
+ if (/\Q$query\E/) {
+ push(@files,$_);
+ }
+ }
+ close IN;
+
+ if (scalar @files and $warn) {
+ &::msg($::who, "searching for package name should be fully lowercase!");
+ }
+
+ return @files;
+}
+
+sub getDistro {
+ my $dist = $_[0];
+
+ if (!defined $dist or $dist eq "") {
+ &::DEBUG("deb: gD: dist == NULL; dist = defaultdist.");
+ $dist = $defaultdist;
+ }
+
+ if ($dist =~ /^(slink|hamm|rex|bo)$/i) {
+ &::DEBUG("deb: deprecated version ($dist).");
+ &::msg($::who, "Debian: deprecated distribution version.");
+ return;
+ }
+
+ if (exists $dists{$dist}) {
+ &::VERB("gD: returning dists{$dist} ($dists{$dist})",2);
+ return $dists{$dist};
+
+ } else {
+ if (!grep /^\Q$dist\E$/i, %dists) {
+ &::msg($::who, "invalid dist '$dist'.");
+ return;
+ }
+
+ &::VERB("gD: returning $dist (no change or conversion)",2);
+ return $dist;
+ }
+}
+
+sub getDistroFromStr {
+ my ($str) = @_;
+ my $dists = join '|', %dists;
+ my $dist = $defaultdist;
+
+ if ($str =~ s/\s+($dists)$//i) {
+ $dist = &getDistro(lc $1);
+ $str =~ s/\\+$//;
+ }
+ $str =~ s/\\([\$\^])/$1/g;
+
+ return($dist,$str);
+}
+
+sub fixDist {
+ my ($dist, %urls) = @_;
+ my %new;
+ my ($key,$val);
+
+ while (($key,$val) = each %urls) {
+ $key =~ s/##DIST/$dist/;
+ $val =~ s/##DIST/$dist/;
+ ### TODO: what should we do if the sar wasn't done.
+ $new{$debian_dir."/".$key} = $val;
+ }
+
+ return %new;
+}
+
+sub DebianFind {
+ # HACK! HACK! HACK!
+ my ($str) = @_;
+ my ($dist, $query) = &getDistroFromStr($str);
+ my @results = sort &searchPackage($str);
+
+ if (!scalar @results) {
+ &::Forker("Debian", sub { &searchContents($str); } );
+ } elsif (scalar @results == 1) {
+ &::status("searchPackage returned one result; getting info of package instead!");
+ &::Forker("Debian", sub { &infoPackages("info", "$results[0] $dist"); } );
+ } else {
+ my $prefix = "Debian Package Listing of '$query' ";
+ &::performStrictReply( &::formListReply(0, $prefix, @results) );
+ }
+}
+
+sub debianCheck {
+ my $error = 0;
+
+ &::status("debianCheck() called.");
+
+ ### TODO: remove the following loop (check if dir exists before)
+ while (1) {
+ last if (opendir(DEBIAN, $debian_dir));
+
+ if ($error) {
+ &::ERROR("dC: cannot opendir debian.");
+ return;
+ }
+
+ mkdir $debian_dir, 0755;
+ $error++;
+ }
+
+ my $retval = 0;
+ my $file;
+ while (defined($file = readdir DEBIAN)) {
+ next unless ($file =~ /(gz|bz2)$/);
+
+ # TODO: add bzip2 support (debian doesn't do .bz2 anyway)
+ #my $exit = system("/bin/gzip -t '$debian_dir/$file'");
+ #next unless ($exit);
+ &::DEBUG("deb: hmr... => ".(time() - (stat($file))[8])."'.");
+ next unless (time() - (stat($file))[8] > 3600);
+
+ #&::DEBUG("deb: dC: exit => '$exit'.");
+ &::WARN("dC: '$debian_dir/$file' corrupted? deleting!");
+ unlink $debian_dir."/".$file;
+ $retval++;
+ }
+
+ return $retval;
+}
+
+sub checkEval {
+ my($str) = @_;
+
+ if ($str) {
+ &::WARN("cE: $str");
+ return 0;
+ } else {
+ return 1;
+ }
+}
+
+sub searchDescFE {
+# &::DEBUG("deb: FE called for searchDesc");
+ my ($query) = @_;
+ my @list = &searchDesc($query);
+
+ if (!scalar @list) {
+ my $prefix = "Debian Desc Search of '$query' ";
+ &::performStrictReply( &::formListReply(0, $prefix, ) );
+ } elsif (scalar @list == 1) { # list = 1.
+ &::DEBUG("deb: list == 1; showing package info of '$list[0]'.");
+ &infoPackages("info", $list[0]);
+ } else { # list > 1.
+ my $prefix = "Debian Desc Search of '$query' ";
+ &::performStrictReply( &::formListReply(0, $prefix, @list) );
+ }
+}
+
+1;
--- /dev/null
+#
+# DebianExtra.pl: Extra stuff for debian
+# Author: dms
+# Version: v0.1 (20000520)
+# Created: 20000520
+#
+
+use strict;
+
+package DebianExtra;
+
+sub Parse {
+ my($args) = @_;
+ my($msg) = '';
+
+ #&::DEBUG("DebianExtra: $args\n");
+ if (!defined $args or $args =~ /^$/) {
+ $msg = &debianBugs();
+ } elsif ($args =~ /^(\d+)$/) {
+ # package number:
+ $msg = &do_id($args);
+ } elsif ($args =~ /^(\S+\@\S+)$/) {
+ # package email maintainer.
+ $msg = &do_email($args);
+ } elsif ($args =~ /^(\S+)$/) {
+ # package name.
+ $msg = &do_pkg($args);
+ } else {
+ # invalid.
+ $msg = "error: could not parse $args";
+ }
+ &::performStrictReply($msg);
+}
+
+sub debianBugs {
+ my @results = &::getURL("http://master.debian.org/~wakkerma/bugs");
+ my ($date, $rcbugs, $remove);
+ my ($bugs_closed, $bugs_opened) = (0,0);
+
+ if (scalar @results) {
+ foreach (@results) {
+ s/<.*?>//g;
+ $date = $1 if (/status at (.*)\s*$/);
+ $rcbugs = $1 if (/bugs: (\d+)/);
+ $remove = $1 if (/REMOVE\S+ (\d+)\s*$/);
+ if (/^(\d+) r\S+ b\S+ w\S+ c\S+ a\S+ (\d+)/) {
+ $bugs_closed = $1;
+ $bugs_opened = $2;
+ }
+ }
+ my $xtxt = ($bugs_closed >=$bugs_opened) ?
+ "It's good to see " :
+ "Oh no, the bug count is rising -- ";
+
+ &::performStrictReply(
+ "Debian bugs statistics, last updated on $date... ".
+ "There are \002$rcbugs\002 release-critical bugs; $xtxt".
+ "\002$bugs_closed\002 bugs closed, opening \002$bugs_opened\002 bugs. ".
+ "About \002$remove\002 packages will be removed."
+ );
+ } else {
+ &::msg($::who, "Couldn't retrieve data for debian bug stats.");
+ }
+}
+
+sub do_id($){
+ my ($bug_num) = shift;
+
+ if (not $bug_num =~ /^\#?\d+$/) {
+ return "Bug is not a number!";
+ }
+ $bug_num =~ s/^\#//;
+ my @results = &::getURL("http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=$bug_num");
+ my $report = join("\n", @results);
+
+ # strip down report to relevant header information.
+ $report =~ s/\r//sig;
+ $report =~ /<BODY[^>]*>(.+?)<HR>/si;
+ $report = $1;
+ my $bug = {};
+ ($bug->{num}, $bug->{title}) = $report =~ m#\#(\d+)\<\/A\>\<BR\>(.+?)\<\/H1\>#is;
+ &::DEBUG("Bugnum: $bug->{num}\n");
+ $bug->{title} =~ s/</\</g;
+ $bug->{title} =~ s/>/\>/g;
+ $bug->{title} =~ s/"/\"/g;
+ &::DEBUG("Title: $bug->{title}\n");
+ $bug->{severity} = 'n'; #Default severity is normal
+ my @bug_flags = split /(?<!\&.t);/s, $report;
+ foreach my $bug_flag (@bug_flags) {
+ $bug_flag =~ s/\n//g;
+ &::DEBUG("Bug_flag: $bug_flag\n");
+ if ($bug_flag =~ /Severity:/i) {
+ ($bug->{severity}) = $bug_flag =~ /(wishlist|minor|normal|important|serious|grave)/i;
+ # Just leave the leter instead of the whole thing.
+ $bug->{severity} =~ s/^(.).+$/$1/;
+ }
+ elsif ($bug_flag =~ /Package:/) {
+ ($bug->{package}) = $bug_flag =~ /\"\>\s*([^<>]+?)\s*\<\/a\>/;
+ # take packagename out of title if it's there
+ $bug->{title} =~ s/^$bug->{package}: //;
+ }
+ elsif ($bug_flag =~ /Reported by:/) {
+ ($bug->{reporter}) = $bug_flag =~ /\"\>\s*(.+?)\s*\<\/a\>/;
+ # strip < and >
+ $bug->{reporter} =~ s/</\</g;
+ $bug->{reporter} =~ s/>/\>/g;
+ }
+ elsif ($bug_flag =~ /Date:/) {
+ ($bug->{date}) = $bug_flag =~ /Date:\s*(\w.+?)\s*$/;
+ #ditch extra whitespace
+ $bug->{date} =~ s/\s{2,}/\ /;
+ }
+ elsif ($bug_flag =~ /Tags:/) {
+ ($bug->{tags}) = $bug_flag =~ /strong\>\s*(.+?)\s*\<\/strong\>/;
+ }
+ elsif ($bug_flag =~ /merged with /) {
+ $bug_flag =~ s/merged with\s*//;
+ $bug_flag =~ s/\<[^\>]+\>//g;
+ $bug_flag =~ s/\s//sg;
+ $bug->{merged_with} = $bug_flag;
+
+ }
+ elsif ($bug_flag =~ /\>Done:\</) {
+ $bug->{done} = 1;
+ }
+ }
+
+ # report bug
+
+ $report = '';
+ $report .= 'DONE:' if defined $bug->{done} and $bug->{done};
+ $report .= '#'.$bug->{num}.':'.uc($bug->{severity}).'['.$bug->{package}.'] '.$bug->{title};
+ $report .= ' ('.$bug->{tags}.')' if defined $bug->{tags};
+ $report .= ' ' . $bug->{date};
+ # Avoid reporting so many merged bugs.
+ $report .= ' ['.join(',',splice(@{[split(/,/,$bug->{merged_with})]},0,3)).']' if defined $bug->{merged_with};
+ if ($::DEBUG) {
+ use Data::Dumper;
+ &::DEBUG(Dumper($bug));
+ }
+ return $report;
+}
+
+sub old_do_id {
+ my($num) = @_;
+ my $url = "http://bugs.debian.org/$num";
+
+ # FIXME
+ return "do_id not supported yet.";
+
+ my @results = &::getURL($url);
+ foreach (@results) {
+ &::DEBUG("do_id: $_");
+ }
+}
+
+sub do_email {
+ my($email) = @_;
+ my $url = "http://bugs.debian.org/$email";
+
+ # FIXME
+ return "do_email not supported yet.";
+
+ my @results = &::getURL($url);
+ foreach (@results) {
+ &::DEBUG("do_email: $_");
+ }
+}
+
+sub do_pkg {
+ my($pkg) = @_;
+ my $url = "http://bugs.debian.org/$pkg";
+
+ # FIXME
+ return "do_pkg not supported yet.";
+
+ my @results = &::getURL($url);
+ foreach (@results) {
+ &::DEBUG("do_pkg: $_");
+ }
+}
+
+1;
--- /dev/null
+#
+# Dict.pl: Frontend to dict.org.
+# Author: dms
+# Version: v0.6c (20000924).
+# Created: 19990914.
+# Updates: Copyright (c) 2005 - Tim Riker <Tim@Rikers.org>
+#
+# see http://luetzschena-stahmeln.de/dictd/
+# for a list of dict servers
+
+package Dict;
+
+use IO::Socket;
+use strict;
+
+#use vars qw(PF_INET);
+
+# need a specific host||ip.
+my $server = "dict.org";
+
+sub Dict {
+ my ($query) = @_;
+# return unless &::loadPerlModule("IO::Socket");
+ my $port = 2628;
+ my $proto = getprotobyname('tcp');
+ my @results;
+ my $retval;
+
+ for ($query) {
+ s/^[\s\t]+//;
+ s/[\s\t]+$//;
+ s/[\s\t]+/ /;
+ }
+
+ # connect.
+ # TODO: make strict-safe constants... so we can defer IO::Socket load.
+ my $socket = new IO::Socket;
+ socket($socket, PF_INET, SOCK_STREAM, $proto) or return "error: socket: $!";
+ eval {
+ local $SIG{ALRM} = sub { die 'alarm' };
+ alarm 10;
+ connect($socket, sockaddr_in($port, inet_aton($server))) or die "error: connect: $!";
+ alarm 0;
+ };
+
+ if ($@) {
+ # failure.
+ $retval = "i could not get info from $server '$@'";
+ } else { # success.
+ $socket->autoflush(1); # required.
+
+ my $num;
+ if ($query =~ s/^(\d+)\s+//) {
+ $num = $1;
+ }
+ my $dict = '*';
+ if ($query =~ s/\/(\S+)$//) {
+ $dict = $1;
+ }
+
+ # body.
+ push(@results, &Define($socket,$query,$dict));
+ #push(@results, &Define($socket,$query,'foldoc'));
+ #push(@results, &Define($socket,$query,'web1913'));
+ # end.
+
+ print $socket "QUIT\n";
+ close $socket;
+
+ my $count=0;
+ foreach (@results) {
+ $count++;
+ &::DEBUG("$count: $_");
+ }
+ my $total = scalar @results;
+
+ if ($total == 0) {
+ $num = undef;
+ }
+
+ if (defined $num and ($num > $total or $num < 1)) {
+ &::msg($::who, "error: choice in definition is out of range.");
+ return;
+ }
+
+ # parse the results.
+ if ($total > 1) {
+ if (defined $num) {
+ $retval = sprintf("[%d/%d] %s", $num, $total, $results[$num-1]);
+ } else {
+ # suggested by larne and others.
+ my $prefix = "Dictionary '$query' ";
+ $retval = &::formListReply(1, $prefix, @results);
+ }
+ } elsif ($total == 1) {
+ $retval = "Dictionary '$query' ".$results[0];
+ } else {
+ $retval = "could not find definition for \002$query\002";
+ $retval .= " in $dict" if ($dict ne '*');
+ }
+ }
+
+ &::performStrictReply($retval);
+}
+
+sub Define {
+ my ($socket, $query, $dict) = @_;
+ my @results;
+
+ &::DEBUG("Dict: asking $dict.");
+ print $socket "DEFINE $dict \"$query\"\n";
+
+ my $def = '';
+ my $term = $query;
+
+ while (<$socket>) {
+ chop; # remove \n
+ chop; # remove \r
+
+ &::DEBUG("$term/$dict '$_'");
+ if (/^552 /) {
+ # no match.
+ return;
+ } elsif (/^250 /) {
+ # end w/ optional stats
+ last;
+ } elsif (/^151 "([^"]*)" (\S+) .*/) {
+ # 151 "Good Thing" jargon "Jargon File (4.3.0, 30 APR 2001)"
+ $term=$1;
+ $dict=$2;
+ $def = '';
+ &::DEBUG("term=$term dict=$dict");
+ } else {
+ my $line = $_;
+ # some dicts put part of the definition on the same line ie: jargon
+ $line =~ s/^$term//i;
+ $line =~ s/^\s+/ /;
+ if ($dict eq 'wn') {
+ # special processing for sub defs in wordnet
+ if ($line eq '.') {
+ # end of def.
+ $def =~ s/\s+$//;
+ $def =~ s/\[[^\]]*\]//g;
+ push(@results, $def);
+ } elsif ($line =~ m/^\s+(\S+ )?(\d+)?: (.*)/) {
+ # start of sub def.
+ my $text = $3;
+ $def =~ s/\s+$//;
+ #&::DEBUG("def => '$def'.");
+ $def =~ s/\[[^\]]*\]//g;
+ push(@results, $def) if ($def ne '');
+ $def = $text;
+ } elsif (/^\s+(.*)/) {
+ $def .= $line;
+ } else {
+ &::DEBUG("ignored '$line'");
+ }
+ } else {
+ # would be nice to divide other dicts
+ # but many are not always in a parsable format
+ if ($line eq '.') {
+ # end of def.
+ next if ($def eq '');
+ push(@results, $def);
+ $def = '';
+ } elsif ($line =~ m/^\s+(\S.*\S)\s*$/) {
+ #&::DEBUG("got '$1'");
+ $def .= ' ' if ($def ne '');
+ $def .= $1;
+ } else {
+ &::DEBUG("ignored '$line'");
+ }
+ }
+ }
+ }
+
+ &::DEBUG("Dict: $dict: found ". scalar(@results) ." defs.");
+
+ return if (!scalar @results);
+
+ return @results;
+}
+
+1;
--- /dev/null
+#
+# DumpVars.pl: Perl variables dumper.
+# Maintained: dms
+# Version: v0.1 (20000114)
+# Created: 20000114
+# NOTE: Ripped from ActivePerl "asp sample" example.
+#
+
+# FIXME
+#use strict;
+
+#use vars qw();
+
+my $countlines = 0;
+
+sub dumpvarslog {
+ my ($line) = @_;
+ if (&IsParam('dumpvarsLogFile')) {
+ print DUMPVARS $line."\n";
+ } else {
+ &status("DV: ".$line);
+ }
+}
+
+sub DumpNames(\%$) {
+ my ($package,$packname) = @_;
+ my $symname = 0;
+ my $line;
+
+ if ($packname eq 'main::') {
+ &dumpvarslog('Packages');
+
+ foreach $symname (sort keys %$package) {
+ local *sym = $$package{$symname};
+ next unless (defined %sym);
+ next unless ($symname =~/::/);
+ &dumpvarslog(" $symname");
+ $countlines++;
+ }
+ }
+
+ # Scalars.
+ foreach $symname (sort keys %$package) {
+ local *sym = $$package{$symname};
+ next unless (defined $sym);
+
+ my $line;
+ if (length($sym) > 512) {
+ &dumpvarslog("Scalar '$packname' $symname too long.");
+ } else {
+ &dumpvarslog("Scalar '$packname' \$ $symname => '$sym'");
+ }
+ $countlines++;
+ }
+
+ # Functions.
+ foreach $symname (sort keys %$package) {
+ local *sym = $$package{$symname};
+ next unless (defined &sym);
+
+ &dumpvarslog("Function '$packname' $symname()");
+ $countlines++;
+ }
+
+ # Lists.
+ foreach $symname (sort keys %$package) {
+ local *sym = $$package{$symname};
+ next unless (defined @sym);
+
+ &dumpvarslog("List '$packname' \@$symname (". scalar(@{$symname}) .")");
+ $countlines++;
+
+ next unless ($packname eq 'main::');
+ foreach (@{$symname}) {
+ if (defined $_) {
+ &dumpvarslog(" => '$_'.");
+ } else {
+ &dumpvarslog(" => <NULL>.");
+ }
+ }
+ }
+
+ # Hashes.
+ foreach $symname (sort keys %$package) {
+ local *sym = $$package{$symname};
+ next unless (defined %sym);
+ next if ($symname =~/::/);
+
+ &dumpvarslog("Hash '$packname' \%$symname");
+ $countlines++;
+
+ next unless ($packname eq 'main::');
+ foreach (keys %{$symname}) {
+ my $val = ${$symname}{$_};
+ if (defined $val) {
+ &dumpvarslog(" $_ => '$val'.");
+ } else {
+ &dumpvarslog(" $_ => <NULL>.");
+ }
+ }
+ }
+
+ return unless ($packname eq 'main::');
+
+ foreach $symname (sort keys %$package) {
+ local *sym = $$package{$symname};
+ next unless (defined %sym);
+ next unless ($symname =~/::/);
+ next if ($symname eq 'main::');
+
+ DumpNames(\%sym,$symname)
+ }
+}
+
+sub dumpallvars {
+ if (&IsParam('dumpvarsLogFile')) {
+ my $file = $param{'dumpvarsLogFile'};
+ &status("opening fh to dumpvars ($file)");
+ if (!open(DUMPVARS,">$file")) {
+ &ERROR("cannot open dumpvars.");
+ return;
+ }
+ }
+
+ DumpNames(%main::,'main::');
+
+ if (&IsParam('dumpvarsLogFile')) {
+ &status("closing fh to dumpvars");
+ close DUMPVARS;
+ }
+
+ &status("DV: count == $countlines");
+}
+
+1;
--- /dev/null
+#
+# DumpVars2.pl: Perl variables dumper ][.
+# Maintained: dms
+# Version: v0.1 (20020329)
+# Created: 20020329
+#
+
+# use strict; # TODO
+
+use Devel::Symdump;
+
+sub symdumplog {
+ my ($line) = @_;
+
+ if (fileno SYMDUMP) {
+ print SYMDUMP $line."\n";
+ } else {
+ &status("SD: ".$line);
+ }
+}
+
+sub symdumpAll {
+ my $o = Devel::Symdump->rnew();
+
+ # scalars.
+ foreach ($o->scalars) {
+# &symdumpRecur($_);
+ symdumplog(" scalar($_)");
+ }
+}
+
+sub symdumpRecur {
+ my $x = shift;
+
+ if (ref $x eq 'HASH') {
+ foreach (keys %$x) {
+ &symdumpRecur($_);
+ }
+ } else {
+ symdumplog("unknown: $x");
+ }
+}
+
+sub symdumpAllFile {
+ &DEBUG('before open');
+ if (&IsParam('symdumpLogFile')) {
+ my $file = $param{'symdumpLogFile'};
+ &status("opening fh to symdump ($file)");
+ if (!open(SYMDUMP,">$file")) {
+ &ERROR('cannot open dumpvars.');
+ return;
+ }
+ }
+ &DEBUG('after open');
+
+ symdumpAll();
+
+ if (fileno SYMDUMP) {
+ &status('closing fh to symdump');
+ close SYMDUMP;
+ }
+
+ &status("SD: count == $countlines");
+}
+
+1;
--- /dev/null
+#!/usr/bin/perl
+
+# Exchange.pl - currency exchange 'module'
+#
+# Last update: 990818 08:30:10, bobby@bofh.dk
+# 20021111 Tim Riker <Tim@Rikers.org>
+#
+
+package Exchange;
+use strict;
+
+my $no_exchange;
+
+BEGIN {
+ eval qq{
+ use LWP::UserAgent;
+ use HTTP::Request::Common qw(POST GET);
+ };
+
+ $no_exchange++ if ($@);
+}
+
+sub GetAbb {
+ my($LookFor,%Hash) = @_;
+
+ my $Found = (grep /$LookFor/i, keys %Hash)[0];
+ $Found =~ m/\((\w\w\w)\)/;
+ return $1;
+}
+
+sub GetTlds {
+ my %Hash = (
+ 'AF', 'AFGHANISTAN',
+ 'AL', 'ALBANIA',
+ 'DZ', 'ALGERIA',
+ 'AS', 'AMERICAN SAMOA',
+ 'AD', 'ANDORRA',
+ 'AO', 'ANGOLA',
+ 'AI', 'ANGUILLA',
+ 'AQ', 'ANTARCTICA',
+ 'AG', 'ANTIGUA AND BARBUDA',
+ 'AR', 'ARGENTINA',
+ 'AM', 'ARMENIA',
+ 'AW', 'ARUBA',
+ 'AU', 'AUSTRALIA',
+ 'AT', 'AUSTRIA',
+ 'AZ', 'AZERBAIJAN',
+ 'BS', 'BAHAMAS',
+ 'BH', 'BAHRAIN',
+ 'BD', 'BANGLADESH',
+ 'BB', 'BARBADOS',
+ 'BY', 'BELARUS',
+ 'BE', 'BELGIUM',
+ 'BZ', 'BELIZE',
+ 'BJ', 'BENIN',
+ 'BM', 'BERMUDA',
+ 'BT', 'BHUTAN',
+ 'BO', 'BOLIVIA',
+ 'BA', 'BOSNIA AND HERZEGOWINA',
+ 'BW', 'BOTSWANA',
+ 'BV', 'BOUVET ISLAND',
+ 'BR', 'BRAZIL',
+ 'IO', 'BRITISH INDIAN OCEAN TERRITORY',
+ 'BN', 'BRUNEI DARUSSALAM',
+ 'BG', 'BULGARIA',
+ 'BF', 'BURKINA FASO',
+ 'BI', 'BURUNDI',
+ 'KH', 'CAMBODIA',
+ 'CM', 'CAMEROON',
+ 'CA', 'CANADA',
+ 'CV', 'CAPE VERDE',
+ 'KY', 'CAYMAN ISLANDS',
+ 'CF', 'CENTRAL AFRICAN REPUBLIC',
+ 'TD', 'CHAD',
+ 'CL', 'CHILE',
+ 'CN', 'CHINA',
+ 'CX', 'CHRISTMAS ISLAND',
+ 'CC', 'COCOS (KEELING) ISLANDS',
+ 'CO', 'COLOMBIA',
+ 'KM', 'COMOROS',
+ 'CG', 'CONGO',
+ 'CD', 'CONGO, THE DEMOCRATIC REPUBLIC OF THE',
+ 'CK', 'COOK ISLANDS',
+ 'CR', 'COSTA RICA',
+ 'CI', "COTE D'IVOIRE",
+ 'HR', 'CROATIA (local name: Hrvatska)',
+ 'CU', 'CUBA',
+ 'CY', 'CYPRUS',
+ 'CZ', 'CZECH REPUBLIC',
+ 'DK', 'DENMARK',
+ 'DJ', 'DJIBOUTI',
+ 'DM', 'DOMINICA',
+ 'DO', 'DOMINICAN REPUBLIC',
+ 'TP', 'EAST TIMOR',
+ 'EC', 'ECUADOR',
+ 'EG', 'EGYPT',
+ 'SV', 'EL SALVADOR',
+ 'GQ', 'EQUATORIAL GUINEA',
+ 'ER', 'ERITREA',
+ 'EE', 'ESTONIA',
+ 'ET', 'ETHIOPIA',
+ 'FK', 'FALKLAND ISLANDS (MALVINAS)',
+ 'FO', 'FAROE ISLANDS',
+ 'FJ', 'FIJI',
+ 'FI', 'FINLAND',
+ 'FR', 'FRANCE',
+ 'FX', 'FRANCE, METROPOLITAN',
+ 'GF', 'FRENCH GUIANA',
+ 'PF', 'FRENCH POLYNESIA',
+ 'TF', 'FRENCH SOUTHERN TERRITORIES',
+ 'GA', 'GABON',
+ 'GM', 'GAMBIA',
+ 'GE', 'GEORGIA',
+ 'DE', 'GERMANY',
+ 'GH', 'GHANA',
+ 'GI', 'GIBRALTAR',
+ 'GR', 'GREECE',
+ 'GL', 'GREENLAND',
+ 'GD', 'GRENADA',
+ 'GP', 'GUADELOUPE',
+ 'GU', 'GUAM',
+ 'GT', 'GUATEMALA',
+ 'GN', 'GUINEA',
+ 'GW', 'GUINEA-BISSAU',
+ 'GY', 'GUYANA',
+ 'HT', 'HAITI',
+ 'HM', 'HEARD AND MC DONALD ISLANDS',
+ 'VA', 'HOLY SEE (VATICAN CITY STATE)',
+ 'HN', 'HONDURAS',
+ 'HK', 'HONG KONG',
+ 'HU', 'HUNGARY',
+ 'IS', 'ICELAND',
+ 'IN', 'INDIA',
+ 'ID', 'INDONESIA',
+ 'IR', 'IRAN (ISLAMIC REPUBLIC OF)',
+ 'IQ', 'IRAQ',
+ 'IE', 'IRELAND',
+ 'IL', 'ISRAEL',
+ 'IT', 'ITALY',
+ 'JM', 'JAMAICA',
+ 'JP', 'JAPAN',
+ 'JO', 'JORDAN',
+ 'KZ', 'KAZAKHSTAN',
+ 'KE', 'KENYA',
+ 'KI', 'KIRIBATI',
+ 'KP', "KOREA, DEMOCRATIC PEOPLE'S REPUBLIC OF",
+ 'KR', 'KOREA, REPUBLIC OF',
+ 'KW', 'KUWAIT',
+ 'KG', 'KYRGYZSTAN',
+ 'LA', "LAO PEOPLE'S DEMOCRATIC REPUBLIC",
+ 'LV', 'LATVIA',
+ 'LB', 'LEBANON',
+ 'LS', 'LESOTHO',
+ 'LR', 'LIBERIA',
+ 'LY', 'LIBYAN ARAB JAMAHIRIYA',
+ 'LI', 'LIECHTENSTEIN',
+ 'LT', 'LITHUANIA',
+ 'LU', 'LUXEMBOURG',
+ 'MO', 'MACAU',
+ 'MK', 'MACEDONIA, THE FORMER YUGOSLAV REPUBLIC OF',
+ 'MG', 'MADAGASCAR',
+ 'MW', 'MALAWI',
+ 'MY', 'MALAYSIA',
+ 'MV', 'MALDIVES',
+ 'ML', 'MALI',
+ 'MT', 'MALTA',
+ 'MH', 'MARSHALL ISLANDS',
+ 'MQ', 'MARTINIQUE',
+ 'MR', 'MAURITANIA',
+ 'MU', 'MAURITIUS',
+ 'YT', 'MAYOTTE',
+ 'MX', 'MEXICO',
+ 'FM', 'MICRONESIA, FEDERATED STATES OF',
+ 'MD', 'MOLDOVA, REPUBLIC OF',
+ 'MC', 'MONACO',
+ 'MN', 'MONGOLIA',
+ 'MS', 'MONTSERRAT',
+ 'MA', 'MOROCCO',
+ 'MZ', 'MOZAMBIQUE',
+ 'MM', 'MYANMAR',
+ 'NA', 'NAMIBIA',
+ 'NR', 'NAURU',
+ 'NP', 'NEPAL',
+ 'NL', 'NETHERLANDS',
+ 'AN', 'NETHERLANDS ANTILLES',
+ 'NC', 'NEW CALEDONIA',
+ 'NZ', 'NEW ZEALAND',
+ 'NI', 'NICARAGUA',
+ 'NE', 'NIGER',
+ 'NG', 'NIGERIA',
+ 'NU', 'NIUE',
+ 'NF', 'NORFOLK ISLAND',
+ 'MP', 'NORTHERN MARIANA ISLANDS',
+ 'NO', 'NORWAY',
+ 'OM', 'OMAN',
+ 'PK', 'PAKISTAN',
+ 'PW', 'PALAU',
+ 'PA', 'PANAMA',
+ 'PG', 'PAPUA NEW GUINEA',
+ 'PY', 'PARAGUAY',
+ 'PE', 'PERU',
+ 'PH', 'PHILIPPINES',
+ 'PN', 'PITCAIRN',
+ 'PL', 'POLAND',
+ 'PT', 'PORTUGAL',
+ 'PR', 'PUERTO RICO',
+ 'QA', 'QATAR',
+ 'RE', 'REUNION',
+ 'RO', 'ROMANIA',
+ 'RU', 'RUSSIAN FEDERATION',
+ 'RW', 'RWANDA',
+ 'KN', 'SAINT KITTS AND NEVIS',
+ 'LC', 'SAINT LUCIA',
+ 'VC', 'SAINT VINCENT AND THE GRENADINES',
+ 'WS', 'SAMOA',
+ 'SM', 'SAN MARINO',
+ 'ST', 'SAO TOME AND PRINCIPE',
+ 'SA', 'SAUDI ARABIA',
+ 'SN', 'SENEGAL',
+ 'SC', 'SEYCHELLES',
+ 'SL', 'SIERRA LEONE',
+ 'SG', 'SINGAPORE',
+ 'SK', 'SLOVAKIA (Slovak Republic)',
+ 'SI', 'SLOVENIA',
+ 'SB', 'SOLOMON ISLANDS',
+ 'SO', 'SOMALIA',
+ 'ZA', 'SOUTH AFRICA',
+ 'GS', 'SOUTH GEORGIA AND THE SOUTH SANDWICH ISLANDS',
+ 'ES', 'SPAIN',
+ 'LK', 'SRI LANKA',
+ 'SH', 'ST. HELENA',
+ 'PM', 'ST. PIERRE AND MIQUELON',
+ 'SD', 'SUDAN',
+ 'SR', 'SURINAME',
+ 'SJ', 'SVALBARD AND JAN MAYEN ISLANDS',
+ 'SZ', 'SWAZILAND',
+ 'SE', 'SWEDEN',
+ 'CH', 'SWITZERLAND',
+ 'SY', 'SYRIAN ARAB REPUBLIC',
+ 'TW', 'TAIWAN, PROVINCE OF CHINA',
+ 'TJ', 'TAJIKISTAN',
+ 'TZ', 'TANZANIA, UNITED REPUBLIC OF',
+ 'TH', 'THAILAND',
+ 'TG', 'TOGO',
+ 'TK', 'TOKELAU',
+ 'TO', 'TONGA',
+ 'TT', 'TRINIDAD AND TOBAGO',
+ 'TN', 'TUNISIA',
+ 'TR', 'TURKEY',
+ 'TM', 'TURKMENISTAN',
+ 'TC', 'TURKS AND CAICOS ISLANDS',
+ 'TV', 'TUVALU',
+ 'UG', 'UGANDA',
+ 'UA', 'UKRAINE',
+ 'AE', 'UNITED ARAB EMIRATES',
+ 'GB', 'UNITED KINGDOM',
+ 'US', 'UNITED STATES',
+ 'UM', 'UNITED STATES MINOR OUTLYING ISLANDS',
+ 'UY', 'URUGUAY',
+ 'UZ', 'UZBEKISTAN',
+ 'VU', 'VANUATU',
+ 'VE', 'VENEZUELA',
+ 'VN', 'VIET NAM',
+ 'VG', 'VIRGIN ISLANDS (BRITISH)',
+ 'VI', 'VIRGIN ISLANDS (U.S.)',
+ 'WF', 'WALLIS AND FUTUNA ISLANDS',
+ 'EH', 'WESTERN SAHARA',
+ 'YE', 'YEMEN',
+ 'YU', 'YUGOSLAVIA',
+ 'ZM', 'ZAMBIA',
+ 'ZW', 'ZIMBABWE',
+ );
+ return %Hash;
+}
+
+sub exchange {
+ my ($message) = @_;
+ &::DEBUG("exchange(@_)");
+
+ return 'Exchange.pl needs LWP::UserAgent and HTTP::Request::Common'
+ if ($no_exchange);
+
+ my ($From, $To, $Amount, $Country);
+ my $retval = '';
+ if ($message =~ /^([\d\.\,]+)\s+(\S+)\s+(?:into|to|for)\s+(\S+)/i) {
+ ($Amount,$From,$To) = ($1,$2,$3);
+ $From = uc $From; $To = uc $To;
+ } elsif ($message =~ /^for\s(?:the\s)?([\w\s]+)/i) {
+ # looking up the currency for a country
+ $Country = $1;
+ } else {
+ return "that doesn't look right";
+ }
+
+ my $ua = new LWP::UserAgent;
+ # Let's pretend
+ #$ua->agent('Mozilla/5.0 ' . $ua->agent);
+ $ua->agent('Mozilla/5.0');
+ $ua->proxy('http', $::param{'httpProxy'}) if (&::IsParam('httpProxy'));
+ $ua->timeout(10);
+
+ my $Referer = 'http://www.xe.net/ucc/full.shtml';
+ my $Converter='http://www.xe.net/ucc/convert.cgi';
+
+ # Get a list of currency abbreviations...
+ my $grab = GET $Referer;
+ my $reply = $ua->request($grab);
+ if (!$reply->is_success) {
+ return 'EXCHANGE: '.$reply->status_line;
+ }
+ my $html = $reply->as_string;
+ my %Currencies = (grep /\S+/,
+ ($html =~ /option value="([^"]+)">.*?,\s*([^<]+)</gi)
+ );
+
+ my %CurrLookup = reverse ($html =~ /option value="([^"]+)">([^<]+)</gi);
+
+ if ($Country) {
+ # Country lookup
+ # crysflame++ for the space fix.
+ $retval = '';
+ foreach my $Found (grep /$Country/i, keys %CurrLookup){
+ $Found =~ s/,/ uses/g;
+ $retval .= "$Found, ";
+ }
+ $retval =~ s/(?:, )?\|?$//;
+ return substr($retval, 0, 510);
+ } else {
+ my %tld2country = &GetTlds;
+ if ($From =~ /^\.(\w\w)$/) { # Probably a tld
+ $From = $tld2country{uc $1};
+ }
+ if ($To =~ /^\.(\w\w)$/) { # Probably a tld
+ $To = $tld2country{uc $1};
+ }
+
+ # Make sure that $Amount is of the form \d+(\.\d\d)?
+ $Amount = sprintf("%.2f",$Amount);
+
+ # Get the exact currency abbreviations
+ my $newFrom = &GetAbb($From, %CurrLookup);
+ my $newTo = &GetAbb($To, %CurrLookup);
+
+ $From = $newFrom if $newFrom;
+ $To = $newTo if $newTo;
+
+ if (exists $Currencies{$From} and exists $Currencies{$To}) {
+
+ my $req = POST $Converter,
+ [ timezone => 'UTC',
+ From => $From,
+ To => $To,
+ Amount => $Amount,
+ ];
+
+ # Falsify where we came from
+ $req->referer($Referer);
+
+ # Submit request
+ my $res = $ua->request($req);
+
+ if ($res->is_success) {
+ # Went through ok
+ my $html = $res->as_string;
+ # parse each one to avoid undefined warnings
+ my ($When) = ($html =~ m/ as of (\d{4}\.\d\d.\d\d\s\d\d:\d\d:\d\d\s\S+)/gi);
+ my ($Cfrom) = ($html =~ m/(\d[\d,.]+)\s*$From/gi);
+ my ($Cto) = ($html =~ m/(\d[\d,.]+)\s*$To/gi);
+ #my ($When, $Cfrom, $Cto) =
+ # grep /\S+/, ($html =~ m/ as of (\d{4}\.\d\d.\d\d\s\d\d:\d\d:\d\d\s\S+)|(\d[\d,.]+)\s*$From|(\d[\d,.]+)\s* $To/gi);
+
+ if ($When) {
+ return "$Cfrom $Currencies{$From} makes ".
+ "$Cto $Currencies{$To} (from http://www.xe.com/)"; # ." ($When)\n";
+ } else {
+ return 'i got some error trying that';
+ }
+ } else {
+ # Oh dear.
+ return "EXCHANGE: ". $res->status_line;
+ }
+ } else {
+ return "Don't know about \"$From\" as a currency" if (!exists $Currencies{$From});
+ return "Don't know about \"$To\" as a currency" if (!exists $Currencies{$To});
+ }
+ }
+}
+
+sub query {
+ my ($args) = @_;
+ &::performStrictReply(&exchange($args));
+ return;
+}
+
+#print &exchange('1 usd to eur') . "\n";
+1;
+
+__END__
+
+=head1 NAME
+
+Exchange.pl - Exchange between currencies
+
+=head1 PREREQUISITES
+
+ LWP::UserAgent
+ HTTP::Request::Common
+
+=head1 PARAMETERS
+
+exchange
+
+=head1 PUBLIC INTERFACE
+
+ Exchange <amount> <currency> for|[in]to <currency>
+
+=head1 DESCRIPTION
+
+Contacts C<www.xe.net> and grabs the exchange rates; warning - the
+currency code is a bit cranky.
+
+=head1 AUTHORS
+
+Bobby <bobby@bofh.dk>
--- /dev/null
+#
+# Factoids.pl: Helpers for generating factoids statistics.
+# Author: dms
+# Version: v0.1 (20000514)
+# Splitted: SQLExtras.pl
+#
+
+use strict;
+
+use vars qw($dbh $who);
+use vars qw(%param);
+
+###
+# Usage: &CmdFactInfo($faqtoid, $query);
+sub CmdFactInfo {
+ my ($faqtoid, $query) = (lc $_[0], $_[1]);
+ my @array;
+ my $string = '';
+
+ if ($faqtoid eq '') {
+ &help('factinfo');
+ return;
+ }
+
+ my %factinfo = &sqlSelectRowHash('factoids', '*',
+ { factoid_key => $faqtoid }
+ );
+
+ # factoid does not exist.
+ if (scalar (keys %factinfo) <= 1) {
+ &performReply("there's no such factoid as \002$faqtoid\002");
+ return;
+ }
+
+ # fix for problem observed by asuffield.
+ # why did it happen though?
+ if (!$factinfo{'factoid_value'}) {
+ &performReply("there's no such factoid as \002$faqtoid\002; deleted because we don't have factoid_value!");
+ foreach (keys %factinfo) {
+ &DEBUG("factinfo{$_} => '$factinfo{$_}'.");
+ }
+### &delFactoid($faqtoid);
+ return;
+ }
+
+ # created:
+ if ($factinfo{'created_by'}) {
+
+ $factinfo{'created_by'} =~ s/\!/ </;
+ $factinfo{'created_by'} .= '>';
+ $string = "created by $factinfo{'created_by'}";
+
+ my $time = $factinfo{'created_time'};
+ if ($time) {
+ if (time() - $time > 60*60*24*7) {
+ my $days = int( (time() - $time)/60/60/24 );
+ $string .= " at \037". scalar(gmtime $time). "\037" .
+ " ($days days)";
+ } else {
+ $string .= ' '.&Time2String(time() - $time).' ago';
+ }
+ }
+
+ push(@array,$string);
+ }
+
+ # modified: (TimRiker asks: why do you keep turning this off?)
+ if ($factinfo{'modified_by'}) {
+ $string = 'last modified';
+
+ my $time = $factinfo{'modified_time'};
+ if ($time) {
+ if (time() - $time > 60*60*24*7) {
+ $string .= " at \037". scalar(gmtime $time). "\037";
+ } else {
+ $string .= ' '.&Time2String(time() - $time).' ago ';
+ }
+ }
+
+ $string .= ' by '.(split ',', $factinfo{'modified_by'})[0];
+
+ push(@array,$string);
+ }
+
+ # requested:
+ if ($factinfo{'requested_by'}) {
+ my $requested_count = $factinfo{'requested_count'};
+
+ if ($requested_count) {
+ $string = 'it has been requested ';
+ if ($requested_count == 1) {
+ $string .= "\002once\002";
+ } else {
+ $string .= "\002". $requested_count. "\002 ".
+ &fixPlural('time', $requested_count);
+ }
+
+ my $requested_by = $factinfo{'requested_by'};
+ $requested_by =~ /\!/;
+ $string .= ", last by $`";
+
+ my $requested_time = $factinfo{'requested_time'};
+ if ($requested_time) {
+ if (time() - $requested_time > 60*60*24*7) {
+ $string .= " at \037". scalar(localtime $requested_time). "\037";
+ } else {
+ $string .= ', '.&Time2String(time() - $requested_time).' ago';
+ }
+ }
+ } else {
+ $string = 'has not been requested yet';
+ }
+
+ push(@array, $string);
+ }
+
+ # locked:
+ if ($factinfo{'locked_by'}) {
+ $factinfo{'locked_by'} =~ /\!/;
+ $string = "it has been locked by $`";
+
+ push(@array, $string);
+ }
+
+ # factoid was inserted not through the bot.
+ if (!scalar @array) {
+ &performReply("no extra info on \002$faqtoid\002");
+ return;
+ }
+
+ &performStrictReply("$factinfo{'factoid_key'} -- ". join('; ', @array) .'.');
+ return;
+}
+
+sub CmdFactStats {
+ my ($type) = @_;
+
+ if ($type =~ /^author$/i) {
+ my %hash = &sqlSelectColHash('factoids',
+ 'factoid_key,created_by', undef,
+ 'WHERE created_by IS NOT NULL'
+ );
+ my %author;
+
+ foreach my $factoid (keys %hash) {
+ my $thisnuh = $hash{$factoid};
+
+ $thisnuh =~ /^(\S+)!\S+@\S+$/;
+ $author{lc $1}++;
+ }
+
+ if (!scalar keys %author) {
+ return 'sorry, no factoids with created_by field.';
+ }
+
+ # work-around.
+ my %count;
+ foreach (keys %author) {
+ $count{ $author{$_} }{$_} = 1;
+ }
+ undef %author;
+
+ my $count;
+ my @list;
+ foreach $count (sort { $b <=> $a } keys %count) {
+ my $author = join(', ', sort keys %{ $count{$count} });
+ push(@list, "$count by $author");
+ }
+
+ my $prefix = 'factoid statistics by author: ';
+ return &formListReply(0, $prefix, @list);
+
+ } elsif ($type =~ /^vandalism$/i) {
+ &status('factstats(vandalism): starting...');
+ my $start_time = &timeget();
+ my %data = &sqlSelectColHash('factoids',
+ 'factoid_key,factoid_value', undef,
+ 'WHERE factoid_value IS NOT NULL'
+ );
+ my @list;
+
+ my $delta_time = &timedelta($start_time);
+ &status(sprintf('factstats(vandalism): %.02f sec to retreive all factoids.', $delta_time)) if ($delta_time > 0);
+ $start_time = &timeget();
+
+ # parse the factoids.
+ foreach (keys %data) {
+ if (&validFactoid($_, $data{$_}) == 0) {
+ s/([\,\;]+)/\037$1\037/g; # highlight chars.
+ push(@list, $_); # push it.
+ }
+ }
+
+ $delta_time = &timedelta($start_time);
+ &status(sprintf('factstats(vandalism): %.02f sec to complete.', $delta_time)) if ($delta_time > 0);
+
+ # bail out on no results.
+ if (scalar @list == 0) {
+ return 'no vandalised factoids... wooohoo.';
+ }
+
+ # parse the results.
+ my $prefix = 'Vandalised factoid ';
+ return &formListReply(1, $prefix, @list);
+
+ } elsif ($type =~ /^total$/i) {
+ &status('factstats(total): starting...');
+ my $start_time = &timeget();
+ my @list;
+ my $str;
+ my($i,$j);
+ my %hash;
+
+ ### lets do it.
+ # total factoids requests.
+ $i = &sumKey('factoids', 'requested_count');
+ push(@list, "total requests - $i");
+
+ # total factoids modified.
+ $str = &countKeys('factoids', 'modified_by');
+ push(@list, "total modified - $str");
+
+ # total factoids modified.
+ $j = &countKeys('factoids', 'requested_count');
+ $str = &countKeys('factoids', 'factoid_key');
+ push(@list, 'total non-requested - '.($str - $i));
+
+ # average request/factoid.
+ # i/j == total(requested_count)/count(requested_count)
+ $str = sprintf('%.01f', $i/$j);
+ push(@list, "average requested per factoid - $str");
+
+ # total prepared for deletion.
+ $str = scalar( &searchTable('factoids', 'factoid_key', 'factoid_value', ' #DEL') );
+ push(@list, "total prepared for deletion - $str");
+
+ # total unique authors.
+ # TODO: convert to sqlSelectColHash ? (or ColArray?)
+ foreach ( &sqlRawReturn('SELECT created_by FROM factoids WHERE created_by IS NOT NULL') ) {
+ /^(\S+)!/;
+ my $nick = lc $1;
+ $hash{$nick}++;
+ }
+ push(@list, 'total unique authors - '.(scalar keys %hash) );
+ undef %hash;
+
+ # total unique requesters.
+ foreach ( &sqlRawReturn('SELECT requested_by FROM factoids WHERE requested_by IS NOT NULL') ) {
+ /^(\S+)!/;
+ my $nick = lc $1;
+ $hash{$nick}++;
+ }
+ push(@list, 'total unique requesters - '.(scalar keys %hash) );
+ undef %hash;
+
+ ### end of 'job'.
+
+ my $delta_time = &timedelta($start_time);
+ &status(sprintf('factstats(broken): %.02f sec to retreive all factoids.', $delta_time)) if ($delta_time > 0);
+ $start_time = &timeget();
+
+ # bail out on no results.
+ if (scalar @list == 0) {
+ return 'no broken factoids... wooohoo.';
+ }
+
+ # parse the results.
+ my $prefix = 'General factoid statistics ';
+ return &formListReply(1, $prefix, @list);
+
+ } elsif ($type =~ /^deadredir$/i) {
+ my @list = &searchTable('factoids', 'factoid_key',
+ 'factoid_value', '^<REPLY> see ');
+ my %redir;
+ my $f;
+
+ for (@list) {
+ my $factoid = $_;
+ my $val = &getFactInfo($factoid, 'factoid_value');
+ if ($val =~ /^<REPLY> ?see( also)? (.*?)\.?$/i) {
+ my $redirf = lc $2;
+ my $redir = &getFactInfo($redirf, 'factoid_value');
+ next if (defined $redir);
+ next if (length $val > 50);
+
+ $redir{$redirf}{$factoid} = 1;
+ }
+ }
+
+ my @newlist;
+ foreach $f (keys %redir) {
+ my @sublist = keys %{ $redir{$f} };
+ for (@sublist) {
+ s/([\,\;]+)/\037$1\037/g;
+ }
+
+ push(@newlist, join(', ', @sublist)." => $f");
+ }
+
+ # parse the results.
+ my $prefix = 'Loose link (dead) redirections in factoids ';
+ return &formListReply(1, $prefix, @newlist);
+
+ } elsif ($type =~ /^dup(licate|e)$/i) {
+ &status('factstats(dupe): starting...');
+ my $start_time = &timeget();
+ my %hash = &sqlSelectColHash('factoids',
+ 'factoid_key,factoid_value', undef,
+ 'WHERE factoid_value IS NOT NULL', 1
+ );
+ my $refs = 0;
+ my @list;
+ my $v;
+
+ foreach $v (keys %hash) {
+ my $count = scalar(keys %{ $hash{$v} });
+ next if ($count == 1);
+
+ my @sublist;
+ foreach (keys %{ $hash{$v} }) {
+ if ($v =~ /^<REPLY> see /i) {
+ $refs++;
+ next;
+ }
+
+ s/([\,\;]+)/\037$1\037/g;
+ if ($_ eq '') {
+ &WARN('dupe: _ = NULL. should never happen!.');
+ next;
+ }
+ push(@sublist, $_);
+ }
+
+ next unless (scalar @sublist);
+
+ push(@list, join(', ', @sublist));
+ }
+
+ &status("factstats(dupe): (good) dupe refs: $refs.");
+ my $delta_time = &timedelta($start_time);
+ &status(sprintf('factstats(dupe): %.02f sec to complete', $delta_time)) if ($delta_time > 0);
+
+ # bail out on no results.
+ if (scalar @list == 0) {
+ return 'no duplicate factoids... woohoo.';
+ }
+
+ # parse the results.
+ my $prefix = 'dupe factoid ';
+ return &formListReply(1, $prefix, @list);
+
+ } elsif ($type =~ /^nullfactoids$/i) {
+ my $query = "SELECT factoid_key,factoid_value FROM factoids WHERE factoid_value=''";
+ my $sth = $dbh->prepare($query);
+ &ERROR("factstats(null): => '$query'.") unless $sth->execute;
+
+ my @list;
+ while (my @row = $sth->fetchrow_array) {
+ if ($row[1] ne '') {
+ &DEBUG("row[1] != NULL for $row[0].");
+ next;
+ }
+
+ &DEBUG("row[0] => '$row[0]'.");
+ push(@list, $row[0]);
+ }
+ $sth->finish;
+
+ # parse the results.
+ my $prefix = 'NULL factoids (not deleted yet) ';
+ return &formListReply(1, $prefix, @list);
+
+ } elsif ($type =~ /^(2|too)short$/i) {
+ # Custom select statement.
+ my $query = 'SELECT factoid_key,factoid_value FROM factoids WHERE length(factoid_value) <= 40';
+ my $sth = $dbh->prepare($query);
+ &ERROR("factstats(lame): => '$query'.") unless $sth->execute;
+
+ my @list;
+ while (my @row = $sth->fetchrow_array) {
+ my($key,$val) = ($row[0], $row[1]);
+ my $match = 0;
+ $match++ if ($val =~ /\s{3,}/);
+ next unless ($match);
+
+ my $v = &getFactoid($val);
+ if (defined $v) {
+ &DEBUG("key $key => $val => $v");
+ }
+
+ $key =~ s/\,/\037\,\037/g;
+ push(@list, $key);
+ }
+ $sth->finish;
+
+ # parse the results.
+ my $prefix = 'Lame factoids ';
+ return &formListReply(1, $prefix, @list);
+
+ } elsif ($type =~ /^listfix$/i) {
+ # Custom select statement.
+ my $query = 'SELECT factoid_key,factoid_value FROM factoids';
+ my $sth = $dbh->prepare($query);
+ &ERROR("factstats(listfix): => '$query'.") unless $sth->execute;
+
+ my @list;
+ while (my @row = $sth->fetchrow_array) {
+ my($key,$val) = ($row[0], $row[1]);
+ my $match = 0;
+ $match++ if ($val =~ /\S+,? or \S+,? or \S+,? or \S+,?/);
+ next unless ($match);
+
+ $key =~ s/\,/\037\,\037/g;
+ push(@list, $key);
+ $val =~ s/,? or /, /g;
+ &DEBUG("fixed: => $val.");
+ &setFactInfo($key,'factoid_value', $val);
+ }
+ $sth->finish;
+
+ # parse the results.
+ my $prefix = 'Inefficient lists fixed ';
+ return &formListReply(1, $prefix, @list);
+
+ } elsif ($type =~ /^locked$/i) {
+ my %hash = &sqlSelectColHash('factoids',
+ 'factoid_key,locked_by', undef,
+ 'WHERE locked_by IS NOT NULL'
+ );
+ my @list = keys %hash;
+
+ for (@list) {
+ s/([\,\;]+)/\037$1\037/g;
+ }
+
+ my $prefix = "factoid statistics on $type ";
+ return &formListReply(0, $prefix, @list);
+
+ } elsif ($type =~ /^new$/i) {
+ my %hash = &sqlSelectColHash('factoids',
+ 'factoid_key,created_time', undef,
+ 'WHERE created_time IS NOT NULL'
+ );
+ my %age;
+
+ foreach (keys %hash) {
+ my $created_time = $hash{$_};
+ my $delta_time = time() - $created_time;
+ next if ($delta_time >= 60*60*24);
+
+ $age{$delta_time}{$_} = 1;
+ }
+
+ if (scalar keys %age == 0) {
+ return 'sorry, no new factoids.';
+ }
+
+ my @list;
+ foreach (sort {$a <=> $b} keys %age) {
+ push(@list, join(',', keys %{ $age{$_} }));
+ }
+
+ my $prefix = 'new factoids in the last 24hours ';
+ return &formListReply(0, $prefix, @list);
+
+ } elsif ($type =~ /^part(ial)?dupe$/i) {
+ ### requires 'custom' select statement... oh well...
+ my $start_time = &timeget();
+
+ # form length|key and key=length hash list.
+ &status('factstats(partdupe): forming length hash list.');
+ my $query = 'SELECT factoid_key,factoid_value,length(factoid_value) AS length FROM factoids WHERE length(factoid_value) >= 192 ORDER BY length';
+ my $sth = $dbh->prepare($query);
+ &ERROR("factstats(partdupe): => '$query'.") unless $sth->execute;
+
+ my (@key, @list);
+ my (%key, %length);
+ while (my @row = $sth->fetchrow_array) {
+ $length{$row[2]}{$row[0]} = 1; # length(value)|key.
+ $key{$row[0]} = $row[1]; # key=value.
+ push(@key, $row[0]);
+ }
+ $sth->finish;
+ &status("factstats(partdupe): total keys => '". scalar(@key) ."'.");
+ &status('factstats(partdupe): now deciphering data gathered');
+
+ my @length = sort { $a <=> $b } keys %length;
+ my $key;
+
+ foreach $key (@key) {
+ shift @length if (length $key{$key} == $length[0]);
+
+ my $val = quotemeta $key{$key};
+ my @sublist;
+ my $length;
+ foreach $length (@length) {
+ foreach (keys %{ $length{$length} }) {
+ if ($key{$_} =~ /^$val/i) {
+ s/([\,\;]+)/\037$1\037/g;
+ s/( and|and )/\037$1\037/g;
+ push(@sublist,$key.' and '.$_);
+ }
+ }
+ }
+ push(@list, join(' ,',@sublist)) if (scalar @sublist);
+ }
+
+ my $delta_time = sprintf('%.02fs', &timedelta($start_time) );
+ &status("factstats(partdupe): $delta_time sec to complete.") if ($delta_time > 0);
+
+ # bail out on no results.
+ if (scalar @list == 0) {
+ return 'no initial partial duplicate factoids... woohoo.';
+ }
+
+ # parse the results.
+ my $prefix = 'initial partial dupe factoid ';
+ return &formListReply(1, $prefix, @list);
+
+ } elsif ($type =~ /^profanity$/i) {
+ my %data = &sqlSelectColHash('factoids',
+ 'factoid_key,factoid_value', undef,
+ 'WHERE factoid_value IS NOT NULL'
+ );
+ my @list;
+
+ foreach (keys %data) {
+ push(@list, $_) if (&hasProfanity($_.' '.$data{$_}));
+ }
+
+ # parse the results.
+ my $prefix = 'Profanity in factoids ';
+ return &formListReply(1, $prefix, @list);
+
+ } elsif ($type =~ /^redir(ection)?$/i) {
+ my @list = &searchTable('factoids', 'factoid_key',
+ 'factoid_value', '^<REPLY> see ');
+ my %redir;
+ my $f;
+ my $dangling = 0;
+
+ for (@list) {
+ my $factoid = $_;
+ my $val = &getFactInfo($factoid, 'factoid_value');
+ if ($val =~ /^<REPLY> see( also)? (.*?)\.?$/i) {
+ my $redir = lc $2;
+ my $redirval = &getFactInfo($redir, 'factoid_value');
+ if (defined $redirval) {
+ $redir{$redir}{$factoid} = 1;
+ } else {
+ &DEBUG("factstats(redir): '$factoid' has loose link => '$redir'.");
+ $dangling++;
+ }
+ }
+ }
+
+ my @newlist;
+ foreach $f (keys %redir) {
+ my @sublist = keys %{ $redir{$f} };
+ for (@sublist) {
+ s/([\,\;]+)/\037$1\037/g;
+ }
+
+ push(@newlist, "$f => ". join(', ', @sublist));
+ }
+
+ # parse the results.
+ my $prefix = "Redirections in factoids, $dangling dangling ";
+ return &formListReply(1, $prefix, @newlist);
+
+ } elsif ($type =~ /^request(ed)?$/i) {
+ my %hash = &sqlSelectColHash('factoids',
+ 'factoid_key,requested_count', undef,
+ 'WHERE requested_count IS NOT NULL', 1
+ );
+
+ if (!scalar keys %hash) {
+ return 'sorry, no factoids have been questioned.';
+ }
+
+ my $count;
+ my @list;
+ my $total = 0;
+ foreach $count (sort {$b <=> $a} keys %hash) {
+ my @faqtoids = sort keys %{ $hash{$count} };
+
+ for (@faqtoids) {
+ s/([\,\;]+)/\037$1\037/g;
+ }
+ $total += $count * scalar(@faqtoids);
+
+ push(@list, "$count - ". join(', ', @faqtoids));
+ }
+ unshift(@list, "\037$total - TOTAL\037");
+
+ my $prefix = "factoid statistics on $type ";
+ return &formListReply(0, $prefix, @list);
+
+ } elsif ($type =~ /^reqrate$/i) {
+ my %hash = &sqlSelectColHash('factoids',
+ "factoid_key,(unix_timestamp() - created_time)/requested_count as rate", undef,
+ 'WHERE requested_by IS NOT NULL and created_time IS NOT NULL ORDER BY rate LIMIT 15', 1
+ );
+
+ my $rate;
+ my @list;
+ my $total = 0;
+ my $users = 0;
+ foreach $rate (sort { $b <=> $a } keys %hash) {
+ my $f = join(', ', sort keys %{ $hash{$rate} });
+ my $str = "$f - ".&Time2String($rate);
+ $str =~ s/\002//g;
+ push(@list, $str);
+ }
+
+ my $prefix = "Rank of top factoid rate (time/req): ";
+ return &formListReply(0, $prefix, @list);
+
+ } elsif ($type =~ /^requesters?$/i) {
+ my %hash = &sqlSelectColHash('factoids',
+ 'factoid_key,requested_by', undef,
+ 'WHERE requested_by IS NOT NULL'
+ );
+ my %requester;
+
+ foreach (keys %hash) {
+ my $thisnuh = $hash{$_};
+
+ $thisnuh =~ /^(\S+)!\S+@\S+$/;
+ $requester{lc $1}++;
+ }
+
+ if (!scalar keys %requester) {
+ return 'sorry, no factoids with requested_by field.';
+ }
+
+ # work-around.
+ my %count;
+ foreach (keys %requester) {
+ $count{ $requester{$_} }{$_} = 1;
+ }
+ undef %requester;
+
+ my $count;
+ my @list;
+ my $total = 0;
+ my $users = 0;
+ foreach $count (sort { $b <=> $a } keys %count) {
+ my $requester = join(', ', sort keys %{ $count{$count} });
+ $total += $count * scalar(keys %{ $count{$count} });
+ $users += scalar(keys %{ $count{$count} });
+ push(@list, "$count by $requester");
+ }
+ unshift(@list, "\037$total TOTAL REQUESTS; $users UNIQUE REQUESTERS\037");
+ # should not the above value be the same as collected by
+ # 'requested'? soemthing weird is going on!
+
+ my $prefix = 'rank of top factoid requesters: ';
+ return &formListReply(0, $prefix, @list);
+
+ } elsif ($type =~ /^seefix$/i) {
+ my @list = &searchTable('factoids', 'factoid_key',
+ 'factoid_value', '^see ');
+ my @newlist;
+ my $fixed = 0;
+ my %loop;
+ my $f;
+
+ for (@list) {
+ my $factoid = $_;
+ my $val = &getFactInfo($factoid, 'factoid_value');
+
+ next unless ($val =~ /^see( also)? (.*?)\.?$/i);
+
+ my $redirf = lc $2;
+ my $redir = &getFactInfo($redirf, 'factoid_value');
+
+ if ($redirf =~ /^\Q$factoid\W$/i) {
+ &delFactoid($factoid);
+ $loop{$factoid} = 1;
+ }
+
+ if (defined $redir) { # good.
+ &setFactInfo($factoid,'factoid_value',"<REPLY> see $redir");
+ $fixed++;
+ } else {
+ push(@newlist, $redirf);
+ }
+ }
+
+ # parse the results.
+ &msg($who, "Fixed $fixed factoids.");
+ &msg($who, 'Self looped factoids removed: '. keys %loop ) if (scalar keys %loop);
+
+ my $prefix = "Loose link (dead) redirections in factoids ";
+ return &formListReply(1, $prefix, @newlist);
+
+ } elsif ($type =~ /^(2|too)long$/i) {
+ my @list;
+ my $query;
+
+ # factoid_key.
+ $query = "SELECT factoid_key FROM factoids WHERE length(factoid_key) >= $param{'maxKeySize'}";
+ my $sth = $dbh->prepare($query);
+ $sth->execute;
+ while (my @row = $sth->fetchrow_array) {
+ push(@list,$row[0]);
+ }
+ $sth->finish;
+
+ # factoid_value.
+ $query = "SELECT factoid_key,factoid_value FROM factoids WHERE length(factoid_value) >= $param{'maxDataSize'}";
+ $sth = $dbh->prepare($query);
+ $sth->execute;
+ while (my @row = $sth->fetchrow_array) {
+ push(@list,sprintf("\002%s\002 - %s", length($row[1]), $row[0]));
+ }
+ $sth->finish;
+
+ if (scalar @list == 0) {
+ return 'good. no factoids exceed length.';
+ }
+
+ # parse the results.
+ my $prefix = 'factoid key||value exceeding length ';
+ return &formListReply(1, $prefix, @list);
+
+ } elsif ($type =~ /^unrequest(ed)?$/i) {
+ # TODO: use sqlSelect()
+ my ($count) = &sqlRawReturn("SELECT COUNT(*) FROM factoids WHERE requested_count = '0'");
+
+ return "Unrequested factoids: $count";
+ }
+
+ return "error: invalid type => '$type'.";
+}
+
+sub CmdListAuth {
+ my ($query) = @_;
+ my $maxshow = &::getChanConfDefault('maxListReplyCount', 15, $chan);
+ my @list = &searchTable('factoids','factoid_key', 'created_by', "^$query!");
+ @list=grep(!/\#DEL\#$/,@list) if (scalar(@list) > $maxshow);
+
+ my $prefix = "factoid author list by '$query' ";
+ &performStrictReply( &formListReply(1, $prefix, @list) );
+}
+
+1;
--- /dev/null
+# HTTPDtype.pl: retrieves http server headers
+# Author: Joey Smith <joey@php.net>
+# Licensing: Artistic License
+# Version: v0.1 (20031110)
+#
+use strict;
+
+package HTTPDtype;
+
+sub HTTPDtype {
+ my($HOST) = @_;
+ my($line) = '';
+ my($code, $mess, %h);
+
+ # TODO: remove leading http:// and trailing :port and /foo if found
+ $HOST = 'joeysmith.com' unless length($HOST) > 0;
+ return unless &::loadPerlModule("Net::HTTP::NB");
+ return unless &::loadPerlModule("IO::Select");
+
+ my $s = Net::HTTP::NB->new(Host => $HOST) || return;
+ $s->write_request(HEAD => "/");
+
+ my $sel = IO::Select->new($s);
+ $line = 'Header timeout' unless $sel->can_read(10);
+ ($code, $mess, %h) = $s->read_response_headers;
+
+ $line = (length($h{Server}) > 0) ? $h{Server} :
+ "Couldn't fetch headers from $HOST";
+
+ &::performStrictReply($line||'Unknown Error Condition');
+}
+
+1;
--- /dev/null
+#
+# Kernel.pl: Frontend to linux.kernel.org.
+# Author: dms
+# Version: v0.3 (19990919).
+# Created: 19990729
+#
+
+package Kernel;
+
+sub kernelGetInfo {
+ return &::getURL("http://www.kernel.org/kdist/finger_banner");
+}
+
+sub Kernel {
+ my $retval = 'Linux kernel versions';
+ my @now = &kernelGetInfo();
+ if (!scalar @now) {
+ &::msg($::who, "failed.");
+ return;
+ }
+
+ foreach $line (@now) {
+ $line =~ s/The latest //;
+ $line =~ s/version //;
+ $line =~ s/of //;
+ $line =~ s/the //;
+ $line =~ s/Linux //;
+ $line =~ s/kernel //;
+ $line =~ s/tree //;
+ $line =~ s/ for stable//;
+ $line =~ s/ to stable kernels//;
+ $line =~ s/ for 2.4//;
+ $line =~ s/ for 2.2//;
+ $line =~ s/ is: */: /;
+ $retval .= ', ' . $line;
+ }
+ &::performStrictReply($retval);
+}
+
+sub kernelAnnounce {
+ my $file = "$::param{tempDir}/kernel.txt";
+ my @now = &kernelGetInfo();
+ my @old;
+
+ if (!scalar @now) {
+ &::DEBUG('kA: failure to retrieve.');
+ return;
+ }
+
+ if (! -f $file) {
+ open(OUT, ">$file");
+ foreach (@now) {
+ print OUT "$_\n";
+ }
+ close OUT;
+
+ return;
+ } else {
+ open(IN, $file);
+ while (<IN>) {
+ chop;
+ push(@old,$_);
+ }
+ close IN;
+ }
+
+ my @new;
+ for(my $i=0; $i<scalar(@old); $i++) {
+ next if ($old[$i] eq $now[$i]);
+ push(@new, $now[$i]);
+ }
+
+ if (scalar @now != scalar @old) {
+ &::DEBUG("kA: scalar mismatch; removing and exiting.");
+ unlink $file;
+ return;
+ }
+
+ if (!scalar @new) {
+ &::DEBUG("kA: no new kernels.");
+ return;
+ }
+
+ open(OUT, ">$file");
+ foreach (@now) {
+ print OUT "$_\n";
+ }
+ close OUT;
+
+ return @new;
+}
+
+1;
--- /dev/null
+#
+# infobot copyright (C) kevin lenzo 1997-98
+#
+
+use strict;
+
+use vars qw($message);
+
+my %digits = (
+ 'first', '1',
+ 'second', '2',
+ 'third', '3',
+ 'fourth', '4',
+ 'fifth', '5',
+ 'sixth', '6',
+ 'seventh', '7',
+ 'eighth', '8',
+ 'ninth', '9',
+ 'tenth', '10',
+ 'one', '1',
+ 'two', '2',
+ 'three', '3',
+ 'four', '4',
+ 'five', '5',
+ 'six', '6',
+ 'seven', '7',
+ 'eight', '8',
+ 'nine', '9',
+ 'ten', '10'
+);
+
+sub perlMath {
+ my($locMsg) = $message;
+
+ if ($message =~ /^\s*$/) {
+ return;
+ }
+
+ foreach (keys %digits) {
+ $locMsg =~ s/$_/$digits{$_}/g;
+ }
+
+ while ($locMsg =~ /(exp ([\w\d]+))/) {
+ my($exp, $val) = ($1, exp $2);
+ $locMsg =~ s/$exp/+$val/g;
+ }
+
+ while ($locMsg =~ /(hex2dec\s*([0-9A-Fa-f]+))/) {
+ my($exp, $val) = ($1, hex $2);
+ $locMsg =~ s/$exp/+$val/g;
+ }
+
+ if ($locMsg =~ /^\s*(dec2hex\s*(\d+))\s*\?*/) {
+ my ($exp, $val) = ($1, sprintf("%x", "$2"));
+ $locMsg =~ s/$exp/+$val/g;
+ }
+
+ my $e = exp(1);
+ $locMsg =~ s/\be\b/$e/;
+
+ while ($locMsg =~ /(log\s*((\d+\.?\d*)|\d*\.?\d+))\s*/) {
+ my ($exp, $res) = ($1, $2);
+ my $val = ($res) ? log($res) : 'Infinity';
+ $locMsg =~ s/$exp/+$val/g;
+ }
+
+ while ($locMsg =~ /(bin2dec ([01]+))/) {
+ my $exp = $1;
+ my $val = join ('', unpack('B*',$2)) ;
+ $locMsg =~ s/$exp/+$val/g;
+ }
+
+ while ($locMsg =~ /(dec2bin (\d+))/) {
+ my $exp = $1;
+ my $val = join('', unpack('B*', pack('N',$2)));
+ $val =~ s/^0+//;
+ $locMsg =~ s/$exp/+$val/g;
+ }
+
+ for ($locMsg) {
+ s/\bpi\b/3.14159265/g;
+ s/ to the / ** /g;
+ s/\btimes\b/\*/g;
+ s/\bdiv(ided by)? /\/ /g;
+ s/\bover /\/ /g;
+ s/\bsquared/\*\*2 /g;
+ s/\bcubed/\*\*3 /g;
+ s/\bto\s+(\d+)(r?st|nd|rd|th)?( power)?/\*\*$1 /ig;
+ s/\bpercent of/*0.01*/ig;
+ s/\bpercent/*0.01/ig;
+ s/\% of\b/*0.01*/g;
+ s/\%/*0.01/g;
+ s/\bsquare root of (\d+)/$1 ** 0.5 /ig;
+ s/\bcubed? root of (\d+)/$1 **(1.0\/3.0) /ig;
+ s/ of / * /;
+ s/(bit(-| )?)?xor(\'?e?d( with))?/\^/g;
+ s/(bit(-| )?)?or(\'?e?d( with))?/\|/g;
+ s/bit(-| )?and(\'?e?d( with))?/\& /g;
+ s/(plus|and)/+/ig;
+ }
+
+ # what the hell is this shit?
+ if (($locMsg =~ /^\s*[-\d*+\s()\/^\.\|\&\*\!]+\s*$/)
+ && ($locMsg !~ /^\s*\(?\d+\.?\d*\)?\s*$/)
+ && ($locMsg !~ /^\s*$/)
+ && ($locMsg !~ /^\s*[( )]+\s*$/)
+ && ($locMsg =~ /\d+/)
+ ) {
+ $locMsg =~ s/([0-9]+\.[0-9]+(\.[0-9]+)+)/"$1"/g;
+ $locMsg = eval($locMsg);
+
+ if (defined $locMsg and $locMsg =~ /^[-+\de\.]+$/) {
+ $locMsg = sprintf("%1.12f", $locMsg);
+ $locMsg =~ s/\.?0+$//;
+
+ if (length $locMsg > 30) {
+ $locMsg = "a number with quite a few digits...";
+ }
+ } else {
+ if (defined $locMsg) {
+ &FIXME("math: locMsg => '$locMsg'...");
+ } else {
+ &status("math: could not really compute.");
+ $locMsg = '';
+ }
+ }
+ } else {
+ $locMsg = '';
+ }
+
+ if (defined $locMsg and $locMsg ne $message) {
+ # success.
+ return $locMsg;
+ } else {
+ # no match.
+ return '';
+ }
+}
+
+1;
--- /dev/null
+#
+# News.pl: Advanced news management
+# Author: dms
+# Version: v0.3 (20010412)
+# Created: 20010326
+# Notes: Testing done by greycat, kudos!
+#
+### structure:
+# news{ channel }{ string } { item }
+# newsuser{ channel }{ user } = time()
+### where item is:
+# Time - when it was added (used for sorting)
+# Author - Who by.
+# Expire - Time to expire.
+# Text - Actual text.
+###
+
+package News;
+
+use strict;
+
+use vars qw($who $chan);
+
+sub Parse {
+ my($what) = @_;
+ $chan = undef;
+ $who = lc $::who;
+
+ if (!keys %::news) {
+ if (!exists $::cache{newsFirst}) {
+ &::DEBUG("news: looks like we enabled news option just then; loading up news file just in case.");
+ $::cache{newsFirst} = 1;
+ }
+
+ &readNews();
+ }
+
+ if ($::msgType ne 'private') {
+ $chan = $::chan;
+ }
+
+ if (defined $what and $what =~ s/^($::mask{chan})\s*//) {
+ # TODO: check if the channel exists aswell.
+ $chan = lc $1;
+
+ if (!&::IsNickInChan($who, $chan)) {
+ &::notice($who, "sorry but you're not on $chan.");
+ return;
+ }
+ }
+
+ if (!defined $chan) {
+ my @chans = &::getNickInChans($who);
+
+ if (scalar @chans > 1) {
+ &::notice($who, "error: I dunno which channel you are referring to since you're on more than one. Try 'news #chan ...' instead");
+ return;
+ }
+
+ if (scalar @chans == 0) {
+ &::notice($who, "error: I couldn't find you on any chan. This must be a bug!");
+ return;
+ }
+
+ $chan = $chans[0];
+ &::VERB("Guessed $who being on chan $chan",2);
+ $::chan = $chan; # hack for IsChanConf().
+ }
+
+ if (!defined $what or $what =~ /^\s*$/) {
+ &list();
+ return;
+ }
+
+ if ($what =~ /^add(\s+(.*))?$/i) {
+ &add($2);
+
+ } elsif ($what =~ /^del(\s+(.*))?$/i) {
+ &del($2);
+
+ } elsif ($what =~ /^mod(\s+(.*))?$/i) {
+ &mod($2);
+
+ } elsif ($what =~ /^set(\s+(.*))?$/i) {
+ &set($2);
+
+ } elsif ($what =~ /^(\d+)$/i) {
+ &::VERB("News: read shortcut called.",2);
+ &read($1);
+
+ } elsif ($what =~ /^read(\s+(.*))?$/i) {
+ &read($2);
+
+ } elsif ($what =~ /^(latest|new)(\s+(.*))?$/i) {
+ &latest($3 || $chan, 1);
+# $::cmdstats{'News latest'}++;
+
+ } elsif ($what =~ /^stats?$/i) {
+ &stats();
+
+ } elsif ($what =~ /^list$/i) {
+ &list();
+
+ } elsif ($what =~ /^(expire|text|desc)(\s+(.*))?$/i) {
+ # shortcut/link.
+ # nice hack.
+ my $cmd = $1;
+ my($arg1,$arg2) = split(/\s+/, $3, 2);
+ &set("$arg1 $cmd $arg2");
+
+ } elsif ($what =~ /^help(\s+(.*))?$/i) {
+ &::help("news $2");
+
+ } elsif ($what =~ /^newsflush$/i) {
+ &::msg($who, "newsflush called... check out the logs!");
+ &::newsFlush();
+
+ } elsif ($what =~ /^(un)?notify$/i) {
+ my $state = ($1) ? 0 : 1;
+
+ # TODO: don't notify even if 'News' is called.
+ if (&::IsChanConf('newsNotifyAll') <= 0) {
+ &::DEBUG("news: chan => $chan, ::chan => $::chan.");
+ &::notice($who, "not available for this channel or disabled altogether.");
+ return;
+ }
+
+ my $t = $::newsuser{$chan}{$who};
+ if ($state) { # state = 1
+ if (defined $t and ($t == 0 or $t == -1)) {
+ &::notice($who, "enabled notify.");
+ delete $::newsuser{$chan}{$who};
+ return;
+ }
+ &::notice($who, "already enabled.");
+
+ } else { # state = 0
+ my $x = $::newsuser{$chan}{$who};
+ if (defined $x and ($x == 0 or $x == -1)) {
+ &::notice($who, 'notify already disabled');
+ return;
+ }
+ $::newsuser{$chan}{$who} = -1;
+ &::notice($who, "notify is now disabled.");
+ }
+
+ } else {
+ &::notice($who, "unknown command: $what");
+ }
+}
+
+sub readNews {
+ my $file = "$::bot_base_dir/infobot-news.txt";
+ if (! -f $file or -z $file) {
+ return;
+ }
+
+ if (fileno NEWS) {
+ &::DEBUG("readNews: fileno exists, should never happen.");
+ return;
+ }
+
+ my($item,$chan);
+ my($ci,$cu) = (0,0);
+
+ open(NEWS, $file);
+ while (<NEWS>) {
+ chop;
+
+ # TODO: allow commands.
+
+ if (/^[\s\t]+(\S+):[\s\t]+(.*)$/) {
+ if (!defined $item) {
+ &::DEBUG("news: !defined item, never happen!");
+ next;
+ }
+
+ $::news{$chan}{$item}{$1} = $2;
+ next;
+ }
+
+ # U <chan> <nick> <time>
+ if (/^U\s+(\S+)\s+(\S+)\s+(\d+)$/) {
+ $::newsuser{$1}{$2} = $3;
+ $cu++;
+ next;
+ }
+
+ if (/^(\S+)[\s\t]+(.*)$/) {
+ $chan = $1;
+ $item = $2;
+ $ci++;
+ }
+ }
+ close NEWS;
+
+ my $cn = scalar(keys %::news);
+ return unless ($ci or $cn or $cu);
+
+ &::status("News: read ".
+ $ci. &::fixPlural(' item', $ci). ' for '.
+ $cn. &::fixPlural(' chan', $cn). ', '.
+ $cu. &::fixPlural(' user', $cu), ' cache'
+ );
+}
+
+sub writeNews {
+ if (!scalar keys %::news and !scalar keys %::newsuser) {
+ &::VERB("wN: nothing to write.",2);
+ return;
+ }
+
+ # should define this at the top of file.
+ my $file = "$::bot_base_dir/infobot-news.txt";
+
+ if (fileno NEWS) {
+ &::ERROR("News: write: fileno NEWS exists, should never happen.");
+ return;
+ }
+
+ # TODO: add commands to output file.
+ my $c = 0;
+ my($cc,$ci,$cu) = (0,0,0);
+
+ open(NEWS, ">$file");
+ foreach $chan (sort keys %::news) {
+ $c = scalar keys %{ $::news{$chan} };
+ next unless ($c);
+ $cc++;
+ my $item;
+
+ foreach $item (sort keys %{ $::news{$chan} }) {
+ $c = scalar keys %{ $::news{$chan}{$item} };
+ next unless ($c);
+ $ci++;
+
+ print NEWS "$chan $item\n";
+ my $what;
+ foreach $what (sort keys %{ $::news{$chan}{$item} }) {
+ print NEWS " $what: $::news{$chan}{$item}{$what}\n";
+ }
+ print NEWS "\n";
+ }
+ }
+
+ # TODO: show how many users we wrote down.
+ if (&::getChanConfList('newsKeepRead')) {
+ # old users are removed in newsFlush(), perhaps it should be
+ # done here.
+
+ foreach $chan (sort keys %::newsuser) {
+
+ foreach (sort keys %{ $::newsuser{$chan} }) {
+ print NEWS "U $chan $_ $::newsuser{$chan}{$_}\n";
+ $cu++;
+ }
+ }
+ }
+
+ close NEWS;
+
+ &::status("News: Wrote $ci items for $cc chans, $cu user cache.");
+}
+
+sub add {
+ my($str) = @_;
+
+ if (!defined $chan or !defined $str or $str =~ /^\s*$/) {
+ &::help('news add');
+ return;
+ }
+
+ if (length $str > 64) {
+ &::notice($who, "That's not really an item (>64chars)");
+ return;
+ }
+
+ if (exists $::news{$chan}{$str}{Time}) {
+ &::notice($who, "'$str' for $chan already exists!");
+ return;
+ }
+
+ $::news{$chan}{$str}{Time} = time();
+ my $expire = &::getChanConfDefault('newsDefaultExpire',7, $chan);
+ $::news{$chan}{$str}{Expire} = time() + $expire*60*60*24;
+ $::news{$chan}{$str}{Author} = $::who; # case!
+
+ my $agestr = &::Time2String($::news{$chan}{$str}{Expire} - time() );
+ my $item = &newsS2N($str);
+ &::notice($who, "Added '\037$str\037' at [".gmtime(time).
+ "] by \002$::who\002 for item #\002$item\002.");
+ &::notice($who, "Now do 'news text $item <your_description>'");
+ &::notice($who, "This item will expire at \002".
+ gmtime($::news{$chan}{$str}{Expire})."\002 [$agestr from now] "
+ );
+
+ &writeNews();
+}
+
+sub del {
+ my($what) = @_;
+ my $item = 0;
+
+ if (!defined $what) {
+ &::help('news del');
+ return;
+ }
+
+ if ($what =~ /^\d+$/) {
+ my $count = scalar keys %{ $::news{$chan} };
+ if (!$count) {
+ &::notice($who, "No news for $chan.");
+ return;
+ }
+
+ if ($what > $count or $what < 0) {
+ &::notice($who, "$what is out of range (max $count)");
+ return;
+ }
+
+ $item = &getNewsItem($what);
+ $what = $item; # hack hack hack.
+
+ } else {
+ $_ = &getNewsItem($what); # hack hack hack.
+ $what = $_ if (defined $_);
+
+ if (!exists $::news{$chan}{$what}) {
+ my @found;
+ foreach (keys %{ $::news{$chan} }) {
+ next unless (/\Q$what\E/);
+ push(@found, $_);
+ }
+
+ if (!scalar @found) {
+ &::notice($who, "could not find $what.");
+ return;
+ }
+
+ if (scalar @found > 1) {
+ &::notice($who, "too many matches for $what.");
+ return;
+ }
+
+ $what = $found[0];
+ &::DEBUG("news: del: str: guessed what => $what");
+ }
+ }
+
+ if (exists $::news{$chan}{$what}) {
+ my $auth = 0;
+ $auth++ if ($::who eq $::news{$chan}{$what}{Author});
+ $auth++ if (&::IsFlag('o'));
+
+ if (!$auth) {
+ # TODO: show when it'll expire.
+ &::notice($who, "Sorry, you cannot remove items; just let them expire on their own.");
+ return;
+ }
+
+ &::notice($who, "ok, deleted '$what' from \002$chan\002...");
+ delete $::news{$chan}{$what};
+ } else {
+ &::notice($who, "error: not found $what in news for $chan.");
+ }
+}
+
+sub list {
+ if (!scalar keys %{ $::news{$chan} }) {
+ &::notice($who, "No news for \002$chan\002.");
+ return;
+ }
+
+ if (&::IsChanConf('newsKeepRead') > 0) {
+ my $x = $::newsuser{$chan}{$who};
+
+ if (defined $x and ($x == 0 or $x == -1)) {
+ &::DEBUG("news: not updating time for $who.");
+ } else {
+ if (!scalar keys %{ $::news{$chan} }) {
+ &::DEBUG("news: should not add $chan/$who to cache!");
+ }
+
+ $::newsuser{$chan}{$who} = time();
+ }
+ }
+
+ # ¬ice() breaks OPN :( - using msg() instead!
+ my $count = scalar keys %{ $::news{$chan} };
+ &::msg($who, "|==== News for \002$chan\002: ($count items)");
+ my $newest = 0;
+ my $expire = 0;
+ my $eno = 0;
+ foreach (keys %{ $::news{$chan} }) {
+ my $t = $::news{$chan}{$_}{Time};
+ my $e = $::news{$chan}{$_}{Expire};
+ $newest = $t if ($t > $newest);
+ if ($e > 1 and $e < $expire) {
+ $expire = $e;
+ &::DEBUG("before newsS2N($_)");
+ $eno = &newsS2N($_);
+ &::DEBUG("after newsS2N($_) == $eno");
+ }
+ }
+ my $timestr = &::Time2String(time() - $newest);
+ &::msg($who, "|= Last updated $timestr ago.");
+ &::msg($who, " \037Num\037 \037Item ".(' 'x40)." \037");
+
+# &::DEBUG("news: list: expire = $expire");
+# &::DEBUG("news: list: eno = $eno");
+
+ my $i = 1;
+ foreach ( &getNewsAll() ) {
+ my $subtopic = $_;
+ my $setby = $::news{$chan}{$subtopic}{Author};
+ my $chr = (exists $::News{$chan}{$subtopic}{Text}) ? '' : '*';
+
+ if (!defined $subtopic) {
+ &::DEBUG("news: warn: subtopic == undef.");
+ next;
+ }
+
+ # TODO: show request stats aswell.
+ &::msg($who, sprintf("\002[\002%2d\002]\002%s %s",
+ $i, $chr, $subtopic));
+ $i++;
+ }
+
+ my $z = $::newsuser{$who};
+ if (defined $z) {
+ &::DEBUG("cache $who: $z");
+ } else {
+ &::DEBUG("cache: $who doesn't have newscache set.");
+ }
+
+ &::msg($who, "|= End of News.");
+ &::msg($who, "use 'news read <#>' or 'news read <keyword>'");
+}
+
+sub read {
+ my($str) = @_;
+
+ if (!defined $chan or !defined $str or $str =~ /^\s*$/) {
+ &::help('news read');
+ return;
+ }
+
+ if (!scalar keys %{ $::news{$chan} }) {
+ &::notice($who, "No news for \002$chan\002.");
+ return;
+ }
+
+ my $item = &getNewsItem($str);
+ if (!defined $item or !scalar keys %{ $::news{$chan}{$item} }) {
+ # TODO: numerical check.
+ if ($str =~ /^(\d+)[-, ](\d+)$/ or
+ $str =~ /^-(\d+)$/ or
+ $str =~ /^(\d+)-$/ or 0
+ ) {
+ &::notice($who, "We don't support multiple requests of news items yet. Sorry.");
+ return;
+ }
+
+ &::notice($who, "No news item called '$str'");
+ return;
+ }
+
+ if (!exists $::news{$chan}{$item}{Text}) {
+ &::notice($who, 'Someone forgot to add info to this news item');
+ return;
+ }
+
+ my $t = gmtime( $::news{$chan}{$item}{Time} );
+ my $a = $::news{$chan}{$item}{Author};
+ my $text = $::news{$chan}{$item}{Text};
+ my $num = &newsS2N($item);
+ my $rwho = $::news{$chan}{$item}{Request_By} || $::who;
+ my $rcount = $::news{$chan}{$item}{Request_Count} || 0;
+
+ if (length $text < $::param{maxKeySize}) {
+ &::VERB("NEWS: Possible news->factoid redirection.",2);
+ my $f = &::getFactoid($text);
+
+ if (defined $f) {
+ &::VERB("NEWS: ok, $text is factoid redirection.",2);
+ $f =~ s/^<REPLY>\s*//i; # anything else?
+ $text = $f;
+ }
+ }
+
+ $_ = $::news{$chan}{$item}{'Expire'};
+ my $e;
+ if ($_) {
+ $e = sprintf("\037%s\037 [%s from now]",
+ scalar(gmtime($_)),
+ &::Time2String($_ - time())
+ );
+ }
+
+ &::notice($who, "+- News \002$chan\002 #$num: $item");
+ &::notice($who, "| Added by $a at \037$t\037");
+ &::notice($who, "| Expire: $e") if (defined $e);
+ &::notice($who, $text);
+ &::notice($who, "| Requested \002$rcount\002 times, last by \002$rwho\002") if ($rcount and $rwho);
+
+ $::news{$chan}{$item}{'Request_By'} = $::who;
+ $::news{$chan}{$item}{'Request_Time'} = time();
+ $::news{$chan}{$item}{'Request_Count'}++;
+}
+
+sub mod {
+ my($item, $str) = split /\s+/, $_[0], 2;
+
+ if (!defined $item or $item eq '' or $str =~ /^\s*$/) {
+ &::help('news mod');
+ return;
+ }
+
+ my $news = &getNewsItem($item);
+
+ if (!defined $news) {
+ &::DEBUG("news: error: mod: news == undefined.");
+ return;
+ }
+ my $nnews = $::news{$chan}{$news}{Text};
+ my $mod_news = $news;
+ my $mod_nnews = $nnews;
+
+ # SAR patch. mu++
+ if ($str =~ m|^\s*s([/,#\|])(.+?)\1(.*?)\1([a-z]*);?\s*$|) {
+ my ($delim, $op, $np, $flags) = ($1,$2,$3,$4);
+
+ if ($flags !~ /^(g)?$/) {
+ &::notice($who, "error: Invalid flags to regex.");
+ return;
+ }
+
+ ### TODO: use m### to make code safe!
+ # TODO: make code safer.
+ my $done = 0;
+ # TODO: use eval to deal with flags easily.
+ if ($flags eq '') {
+ $done++ if (!$done and $mod_news =~ s/\Q$op\E/$np/);
+ $done++ if (!$done and $mod_nnews =~ s/\Q$op\E/$np/);
+ } elsif ($flags eq 'g') {
+ $done++ if ($mod_news =~ s/\Q$op\E/$np/g);
+ $done++ if ($mod_nnews =~ s/\Q$op\E/$np/g);
+ }
+
+ if (!$done) {
+ &::notice($who, "warning: regex not found in news.");
+ return;
+ }
+
+ if ($mod_news ne $news) { # news item.
+ if (exists $::news{$chan}{$mod_news}) {
+ &::notice($who, "item '$mod_news' already exists.");
+ return;
+ }
+
+ &::notice($who, "Moving item '$news' to '$mod_news' with SAR s/$op/$np/.");
+ foreach (keys %{ $::news{$chan}{$news} }) {
+ $::news{$chan}{$mod_news}{$_} = $::news{$chan}{$news}{$_};
+ delete $::news{$chan}{$news}{$_};
+ }
+ # needed?
+ delete $::news{$chan}{$news};
+ }
+
+ if ($mod_nnews ne $nnews) { # news Text/Description.
+ &::notice($who, "Changing text for '$news' SAR s/$op/$np/.");
+ if ($mod_news ne $news) {
+ $::news{$chan}{$mod_news}{Text} = $mod_nnews;
+ } else {
+ $::news{$chan}{$news}{Text} = $mod_nnews;
+ }
+ }
+
+ return;
+ } else {
+ &::notice($who, "error: that regex failed ;(");
+ return;
+ }
+
+ &::notice($who, "error: Invalid regex. Try s/1/2/, s#3#4#...");
+}
+
+sub set {
+ my($args) = @_;
+ my($item, $what, $value);
+
+ if (!defined $args) {
+ &::DEBUG("news: set: args == NULL.");
+ return;
+ }
+
+ $item = $1 if ($args =~ s/^(\S+)\s*//);
+ $what = $1 if ($args =~ s/^(\S+)\s*//);
+ $value = $args;
+
+ if ($item eq '') {
+ &::help('news set');
+ return;
+ }
+
+ my $news = &getNewsItem($item);
+
+ if (!defined $news) {
+ &::notice($who, "Could not find item '$item' substring or # in news list.");
+ return;
+ }
+
+ # list all values for chan.
+ if (!defined $what or $what =~ /^\s*$/) {
+ &::msg($who, "set: you didn't fill me on the arguments! (what and values)");
+ return;
+ }
+
+ my $ok = 0;
+ my @elements = ('Expire','Text');
+ foreach (@elements) {
+ next unless ($what =~ /^$_$/i);
+ $what = $_;
+ $ok++;
+ last;
+ }
+
+ if (!$ok) {
+ &::notice($who, "Invalid set. Try: @elements");
+ return;
+ }
+
+ # show (read) what.
+ if (!defined $value or $value =~ /^\s*$/) {
+ &::msg($who, "set: you didn't fill me on the arguments! (value)");
+ return;
+ }
+
+ if (!exists $::news{$chan}{$news}) {
+ &::notice($who, "news '$news' does not exist");
+ return;
+ }
+
+ if ($what eq 'Expire') {
+ # TODO: use do_set().
+
+ my $time = 0;
+ my $plus = ($value =~ s/^\+//g);
+ while ($value =~ s/^(\d+)(\S*)\s*//) {
+ my($int,$unit) = ($1,$2);
+ $time += $int if ($unit =~ /^s(ecs?)?$/i);
+ $time += $int*60 if ($unit =~ /^m(in(utes?)?)?$/i);
+ $time += $int*60*60 if ($unit =~ /^h(ours?)?$/i);
+ $time += $int*60*60*24 if (!$unit or $unit =~ /^d(ays?)?$/i);
+ $time += $int*60*60*24*7 if ($unit =~ /^w(eeks?)?$/i);
+ $time += $int*60*60*24*30 if ($unit =~ /^mon(th)?$/i);
+ }
+
+ if ($value =~ s/^never$//i) {
+ # never.
+ $time = -1;
+ } elsif ($plus) {
+ # from now.
+ $time += time();
+ } else {
+ # from creation of item.
+ $time += $::news{$chan}{$news}{Time};
+ }
+
+ if (!$time or ($value and $value !~ /^never$/i)) {
+ &::DEBUG("news: set: Expire... need to parse.");
+ &::msg($who, "hrm... couldn't parse that.");
+ return;
+ }
+
+ if ($time == -1) {
+ &::notice($who, "Set never expire for \002$item\002." );
+ } elsif ($time < -1) {
+ &::DEBUG("news: time should never be negative ($time).");
+ return;
+ } else {
+ &::notice($who, "Set expire for \002$item\002, to ".
+ gmtime($time) ." [".&::Time2String($time - time())."]" );
+
+ if (time() > $time) {
+ &::DEBUG("news: hrm... time() > $time, should expire.");
+ }
+ }
+
+
+ $::news{$chan}{$news}{Expire} = $time;
+
+ return;
+ }
+
+ my $auth = 0;
+# &::DEBUG("news: who => '$who'");
+ my $author = $::news{$chan}{$news}{Author};
+ $auth++ if ($::who eq $author);
+ $auth++ if (&::IsFlag('o'));
+ if (!defined $author) {
+ &::DEBUG("news: news{$chan}{$news}{Author} is not defined! auth'd anyway");
+ $::news{$chan}{$news}{Author} = $::who;
+ $author = $::who;
+ $auth++;
+ }
+
+ if (!$auth) {
+ # TODO: show when it'll expire.
+ &::notice($who, "Sorry, you cannot set items. (author $author owns it)");
+ return;
+ }
+
+ # TODO: clean this up.
+ my $old = $::news{$chan}{$news}{$what};
+ if (defined $old) {
+ &::DEBUG("news: old => $old.");
+ }
+ $::news{$chan}{$news}{$what} = $value;
+ &::notice($who, "Setting [$chan]/{$news}/<$what> to '$value'.");
+}
+
+sub latest {
+ my ($tchan, $flag) = @_;
+
+ # hack hack hack. fix later.
+ $chan = $tchan;
+ $who = $::who;
+
+ # TODO: if chan = undefined, guess.
+# if (!exists $::news{$chan}) {
+ if (!exists $::channels{$chan}) {
+ &::notice($who, "invalid chan $chan") if ($flag);
+ return;
+ }
+
+ my $t = $::newsuser{$chan}{$who};
+# if (defined $t) {
+# &::DEBUG("newsuser: $chan/$who == $t");
+# } else {
+# &::DEBUG("newsuser: $chan/$who == undefined");
+# }
+
+ if (defined $t and ($t == 0 or $t == -1)) {
+ if ($flag) {
+ &::notice($who, "if you want to read news, try \002/msg $::ident news $chan\002 or \002/msg $::ident news $chan notify\002");
+ } else {
+ &::DEBUG("news: not displaying any new news for $who");
+ return;
+ }
+ }
+
+ $::chan = $chan;
+ return if (&::IsChanConf('newsNotifyAll') <= 0);
+
+ # I don't understand this code ;)
+ $t = 1 if (!defined $t);
+
+ if (!defined $t) {
+# &::msg($who, "News is disabled for $chan");
+ &::DEBUG("news: $chan: something went really wrong.");
+ return;
+ }
+
+ my @new;
+ foreach (keys %{ $::news{$chan} }) {
+ next if (!defined $t);
+ next if ($t > $::news{$chan}{$_}{Time});
+
+ # don't list new items if they don't have Text.
+ if (!exists $::news{$chan}{$_}{Text}) {
+ if (time() - $::news{$chan}{$_}{Time} > 60*60*24*3) {
+ &::DEBUG("deleting news{$chan}{$_} because it was too old and had no text info.");
+ delete $::news{$chan}{$_};
+ }
+
+ next;
+ }
+
+ push(@new, $_);
+ }
+
+ # !scalar @new, $flag
+ if (!scalar @new and $flag) {
+ &::notice($who, "no new news for $chan for $who.");
+ # valid to set this?
+ $::newsuser{$chan}{$who} = time();
+ return;
+ }
+
+ # scalar @new, !$flag
+ my $unread = scalar @new;
+ my $total = scalar keys %{ $::news{$chan} };
+ if (!$flag && &::IsChanConf('newsTellUnread') <= 0) {
+ return;
+ }
+
+ if (!$flag) {
+ return unless ($unread);
+
+ # just a temporary measure not to flood ourself off the
+ # network with news until we get global notice() and msg()
+ # throttling.
+ if (time() - ($::cache{newsTime} || 0) < 5) {
+ &::status("news: not displaying latest notice to $who/$chan.");
+ return;
+ }
+
+ $::cache{newsTime} = time();
+ my $reply = "There are unread news in $chan ($unread unread, $total total). /msg $::ident news $::chan latest";
+ $reply .= " If you don't want further news notification, /msg $::ident news unnotify" if ($unread == $total);
+ &::notice($who, $reply);
+
+ return;
+ }
+
+ # scalar @new, $flag
+ if (scalar @new) {
+ &::notice($who, "+==== New news for \002$chan\002 ($unread new; $total total):");
+
+ my $t = $::newsuser{$chan}{$who};
+ if (defined $t and $t > 1) {
+ my $timestr = &::Time2String( time() - $t );
+ &::notice($who, "|= Last time read $timestr ago");
+ }
+
+ my $i;
+ my @sorted;
+ foreach (@new) {
+ $i = &newsS2N($_);
+ $sorted[$i] = $_;
+ }
+
+ for ($i=0; $i<=scalar(@sorted); $i++) {
+ my $news = $sorted[$i];
+ next unless (defined $news);
+
+# my $age = time() - $::news{$chan}{$news}{Time};
+ my $msg = sprintf("\002[\002%2d\002]\002 %s", $i, $news);
+### $i, $_, &::Time2String($age)
+ $::conn->schedule(int((2+$i)/2), sub {
+ &::notice($who, $msg);
+ } );
+ }
+
+ # TODO: implement throttling via schedule into ¬ice() / &msg().
+ $::conn->schedule(int((2+$i)/2), sub {
+ &::notice($who, "|= to read, do \002news $chan read <#>\002 or \002news $chan read <keyword>\002");
+ } );
+
+ # lame hack to prevent dupes if we just ignore it.
+ my $x = $::newsuser{$chan}{$who};
+ if (defined $x and ($x == 0 or $x == -1)) {
+ &::DEBUG("news: not updating time for $who. (2)");
+ } else {
+ $::newsuser{$chan}{$who} = time();
+ }
+ }
+}
+
+###
+### helpers...
+###
+
+sub getNewsAll {
+ my %time;
+ foreach (keys %{ $::news{$chan} }) {
+ $time{ $::news{$chan}{$_}{Time} } = $_;
+ }
+
+ my @items;
+ foreach (sort { $a <=> $b } keys %time) {
+ push(@items, $time{$_});
+ }
+
+ return @items;
+}
+
+sub newsS2N {
+ my($what) = @_;
+ my $item = 0;
+ my @items;
+ my $no;
+
+ my %time;
+ foreach (keys %{ $::news{$chan} }) {
+ my $t = $::news{$chan}{$_}{Time};
+
+ if (!defined $t or $t !~ /^\d+$/) {
+ &::DEBUG("news: warn: t is undefined for news{$chan}{$_}{Time}; removing item.");
+ delete $::news{$chan}{$_};
+ next;
+ }
+
+ $time{$t} = $_;
+ }
+
+ foreach (sort { $a <=> $b } keys %time) {
+ $item++;
+ return $item if ($time{$_} eq $what);
+ }
+
+ &::DEBUG("newsS2N($what): failed...");
+}
+
+sub getNewsItem {
+ my($what) = @_;
+ my $item = 0;
+
+ $what =~ s/^\#//; # '#1' for example.
+
+ my %time;
+ foreach (keys %{ $::news{$chan} }) {
+ my $t = $::news{$chan}{$_}{Time};
+
+ if (!defined $t or $t !~ /^\d+$/) {
+ &::DEBUG("news: warn: t is undefined for news{$chan}{$_}{Time}; removing item.");
+ delete $::news{$chan}{$_};
+ next;
+ }
+
+ $time{$t} = $_;
+ }
+
+ # number to string resolution.
+ if ($what =~ /^\d+$/) {
+ foreach (sort { $a <=> $b } keys %time) {
+ $item++;
+ return $time{$_} if ($item == $what);
+ }
+
+ } else {
+ # partial string to full string resolution
+ # in some cases, string->number resolution.
+
+ my @items;
+ my $no;
+ foreach (sort { $a <=> $b } keys %time) {
+ $item++;
+# $no = $item if ($time{$_} eq $what);
+## if ($time{$_} eq $what) {
+## $no = $item;
+## next;
+## }
+
+ push(@items, $time{$_}) if ($time{$_} =~ /\Q$what\E/i);
+ }
+
+## if (defined $no and !@items) {
+## &::DEBUG("news: string->number resolution: $what->$no.");
+## return $no;
+## }
+
+ if (scalar @items > 1) {
+ &::DEBUG("news: Multiple matches, not guessing.");
+ &::notice($who, "Multiple matches, not guessing.");
+ return;
+ }
+
+ if (@items) {
+# &::DEBUG("news: gNI: part_string->full_string: $what->$items[0]");
+ return $items[0];
+ } else {
+ &::DEBUG("news: gNI: No match for '$what'");
+ return;
+ }
+ }
+
+ &::ERROR("news: gNI: should not happen (what = $what)");
+ return;
+}
+
+sub do_set {
+ my($what,$value) = @_;
+
+ if (!defined $chan) {
+ &::DEBUG("news: do_set: chan not defined.");
+ return;
+ }
+
+ if (!defined $what or $what =~ /^\s*$/) {
+ &::DEBUG("news: what $what is not defined.");
+ return;
+ }
+
+ if (!defined $value or $value =~ /^\s*$/) {
+ &::DEBUG("news: value $value is not defined.");
+ return;
+ }
+
+ &::TODO("news: do_set:");
+}
+
+sub stats {
+ &::DEBUG("News: stats called.");
+ &::msg($who, "check my logs/console.");
+ my($i,$j) = (0,0);
+
+ # total request count.
+ foreach $chan (keys %::news) {
+ foreach (keys %{ $::news{$chan} }) {
+ $i += $::news{$chan}{$_}{Request_Count};
+ }
+ }
+ &::DEBUG("news: stats: total request count => $i");
+ $i = 0;
+
+ # total user cached.
+ foreach $chan (keys %::newsuser) {
+ $i += $::newsuser{$chan}{$_};
+ }
+ &::DEBUG("news: stats: total user cache => $i");
+ $i = 0;
+
+ # average latest time read.
+ my $t = time();
+ foreach $chan (keys %::newsuser) {
+ $i += $t - $::newsuser{$chan}{$_};
+ &::DEBUG(" i = $i");
+ $j++;
+ }
+ &::DEBUG("news: stats: average latest time read: total time: $i");
+ &::DEBUG("news: ... count: $j");
+ &::DEBUG("news: average: ".sprintf("%.02f", $i/($j||1))." sec/user");
+ $i = $j = 0;
+}
+
+sub AUTOLOAD { &::AUTOLOAD(@_); }
+
+1;
--- /dev/null
+#!/usr/bin/perl
+#
+# OnJoin.pl: emit a message when a user enters the channel
+# Author: Corey Edwards <tensai@zmonkey.org>
+# Version: v0.3.1
+# Created: 20051222
+# Updated: 20060112
+
+use strict;
+
+use vars qw(%channels %param);
+use vars qw($dbh $who $chan);
+
+sub onjoin {
+ my ($nick, $user, $host, $chan) = @_;
+ $nick = lc $nick;
+
+ # look for a channel specific message
+ my $message = &sqlSelect('onjoin', 'message', { nick => $nick, channel => $chan } ) || 0;
+
+ # look for a default message
+ if (!$message){
+ $message = &sqlSelect('onjoin', 'message', { nick => $nick, channel => '_default' } ) || 0;
+ }
+
+ # print the message, if there was one
+ if ($message){
+ $message = substVars($message, 1);
+ if ($message =~ m/^<action>\s*(.*)/){
+ &status("OnJoin: $nick arrived, performing action");
+ &action($chan, $1);
+ }
+ else{
+ $message =~ s/^<reply>\s*//;
+ &status("OnJoin: $nick arrived, printing message");
+ &msg($chan, $message);
+ }
+ }
+
+ return;
+}
+
+# set and get messages
+sub Cmdonjoin {
+ $_ = shift;
+ m/(\S*)(\s*(\S*)(\s*(.*)|)|)/;
+ my $ch = $1;
+ my $nick = $3;
+ my $msg = $5;
+
+ # get options
+ my $strict = &getChanConf('onjoinStrict');
+ my $ops = &getChanConf('onjoinOpsOnly');
+
+ # see if they specified a channel
+ if ($ch !~ m/^\#/ && $ch ne '_default'){
+ $msg = $nick . ($msg ? " $msg" : '');
+ $nick = $ch;
+ $ch = $chan;
+ }
+
+ $nick = lc $nick;
+
+ if ($nick =~ m/^-(.*)/){
+ $nick = $1;
+ if ($ops){
+ if (!$channels{$chan}{o}{$who}){
+ &performReply("sorry, you're not an operator");
+ }
+ }
+ elsif ($strict){
+ # regardless of strict mode, ops can always change
+ if (!$channels{$chan}{o}{$who} and $nick ne $who){
+ &performReply("I can't alter a message for another user (strict mode)");
+ }
+ }
+ else{
+ &sqlDelete('onjoin', { nick => $nick, channel => $ch });
+ &performReply('ok');
+ }
+ return;
+ }
+
+ # if msg not set, show what the message would be
+ if (!$msg){
+ $nick = $who if (!$nick);
+ my %row = &sqlSelectRowHash('onjoin', 'message, modified_by, modified_time', { nick => $nick, channel => $ch } );
+ if ($row{'message'}){
+ &performStrictReply("onjoin for $nick set by $row{modified_by} on " . localtime($row{modified_time}) . ": $row{message}");
+ }
+ return;
+ }
+
+ # only allow changes by ops
+ if ($ops){
+ if (!$channels{$chan}{o}{$who}){
+ &performReply("sorry, you're not an operator");
+ return;
+ }
+ }
+ # only allow people to change their own message (superceded by OpsOnly)
+ elsif ($strict){
+ # regardless of strict mode, ops can always change
+ if (!$channels{$chan}{o}{$who} and $nick ne $who){
+ &performReply("I can't alter a message for another user (strict mode)");
+ return;
+ }
+ }
+
+ # remove old one (if exists) and add new message
+ &sqlDelete('onjoin', { nick => $nick, channel => $ch });
+ my $insert = &sqlInsert('onjoin', { nick => $nick, channel => $ch, message => $msg, modified_by => $who, modified_time => time() });
+ if ($insert){
+ &performReply('ok');
+ }
+ else{
+ &performReply('whoops. database error');
+ }
+ return;
+}
+
+1;
--- /dev/null
+#
+# Plug.pl: hacked for http://Plug.org/ by Tim Riker <Tim@Rikers.org>
+# Slashdot.pl: Slashdot headline retrival
+# Author: Chris Tessone <tessone@imsa.edu>
+# Modified: dms
+# Licensing: Artistic License (as perl itself)
+# Version: v0.4 (19991125)
+#
+
+###
+# fixed up to use XML'd /. backdoor 7/31 by richardh@rahga.com
+# My only request if this gets included in infobot is that the
+# other header gets trimmed to 2 lines, dump the fluff ;) -rah
+#
+# added a status message so people know to install LWP - oznoid
+# also simplified the return code because it wasn't working.
+###
+
+
+package Plug;
+
+use strict;
+
+sub plugParse {
+ my @list;
+
+ foreach (@_) {
+ next unless (/<title>(.*?)<\/title>/);
+ my $title = $1;
+ $title =~ s/&\;/&/g;
+ push(@list, $title);
+ }
+
+ return @list;
+}
+
+sub Plug {
+ my @results = &::getURL("http://www.plug.org/index.xml");
+ my $retval = "i could not get the headlines.";
+
+ if (scalar @results) {
+ my $prefix = 'Plug Headlines ';
+ my @list = &plugParse(@results);
+ $retval = &::formListReply(0, $prefix, @list);
+ }
+
+ &::performStrictReply($retval);
+}
+
+sub plugAnnounce {
+ my $file = "$::param{tempDir}/plug.xml";
+
+ my @Cxml = &::getURL("http://www.plug.org/index.xml");
+ if (!scalar @Cxml) {
+ &::DEBUG("sdA: failure (Cxml == NULL).");
+ return;
+ }
+
+ if (! -e $file) { # first time run.
+ open(OUT, ">$file");
+ foreach (@Cxml) {
+ print OUT "$_\n";
+ }
+ close OUT;
+
+ return;
+ }
+
+ my @Oxml;
+ open(IN, $file);
+ while (<IN>) {
+ chop;
+ push(@Oxml,$_);
+ }
+ close IN;
+
+ my @Chl = &plugParse(@Cxml);
+ my @Ohl = &plugParse(@Oxml);
+
+ my @new;
+ foreach (@Chl) {
+ last if ($_ eq $Ohl[0]);
+ push(@new, $_);
+ }
+
+ if (scalar @new == 0) {
+ &::status("Plug: no new headlines.");
+ return;
+ }
+
+ if (scalar @new == scalar @Chl) {
+ &::DEBUG("sdA: scalar(new) == scalar(Chl). bad?");
+ }
+
+ open(OUT,">$file");
+ foreach (@Cxml) {
+ print OUT "$_\n";
+ }
+ close OUT;
+
+ return "Plug: ".
+ join(" \002::\002 ", @new);
+}
+
+1;
--- /dev/null
+#
+# Quote.pl: retrieve stock quotes from yahoo
+# heavily based on Slashdot.pl
+# Version: v0.1
+# Author: Michael Urman <mu@zen.dhis.org>
+# Licensing: Artistic
+# changes from Morten Brix Pedersen (mbrix) and Tim Riker <Tim@Rikers.org>
+#
+
+package Quote;
+
+use strict;
+
+sub commify {
+ my $input = shift;
+ $input = reverse $input;
+ $input =~ s/(\d\d\d)(?=\d)(?!\d*\.)/$1,/g;
+ return scalar reverse $input;
+}
+
+sub Quote {
+ my $stock = shift;
+ my @results = &::getURL('http://quote.yahoo.com/d/quotes.csv' .
+ "?s=$stock&f=sl1d1t1c1ohgv&e=.csv");
+
+
+ if (!scalar @results) {
+ &::msg($::who, "i could not get a stock quote :(");
+ }
+
+ my ($reply);
+ foreach my $result (@results) {
+ # get rid of the quotes
+ $result =~ s/\"//g;
+
+ my ($ticker, $recent, $date, $time, $change, $open,
+ $high, $low, $volume) = split(',',$result);
+
+ # add some commas
+ # "+ 0" removes trailing cr/lf/etc.
+ my $newvol = commify($volume + 0);
+
+ $reply .= ' ;; ' if $reply;
+ $reply .= "$ticker: $recent ($high/$low), $date $time, " .
+ "Opened $open, Volume $newvol, Change $change";
+ }
+
+ if ($reply eq '') {
+ $reply = "i couldn't get the quote for $stock. sorry. :(";
+ }
+
+ &::performStrictReply($reply);
+}
+
+1;
--- /dev/null
+#
+# RootWarn.pl: Warn people about usage of root on IRC.
+# Author: dms
+# Version: v0.3 (20000923)
+# Created: 19991008
+#
+
+use strict;
+
+use vars qw(%channels %param);
+use vars qw($dbh $found $ident);
+
+sub rootWarn {
+ my ($nick,$user,$host,$chan) = @_;
+ my $n = lc $nick;
+ my $attempt = &sqlSelect('rootwarn', 'attempt', { nick => $n } ) || 0;
+ my $warnmode = &getChanConf('rootWarnMode');
+
+ if ($attempt == 0) { # first timer.
+ if (defined $warnmode and $warnmode =~ /quiet/i) {
+ &status('RootWarn: Detected root user; notifying user');
+ } else {
+ &status('RootWarn: Detected root user; notifying nick and channel.');
+ &msg($chan, 'ROO'.('O' x int(rand 8))."T has landed!");
+ }
+
+ if ($_ = &getFactoid('root')) {
+ &msg($nick, "RootWarn: $attempt : $_");
+ } else {
+ &status('"root" needs to be defined in database.');
+ }
+
+ } elsif ($attempt < 2) { # 2nd/3rd time occurrance.
+ if ($_ = &getFactoid('root again')) {
+ &status("RootWarn: not first time root user; msg'ing $nick.");
+ &msg($nick, "RootWarn: $attempt : $_");
+ } else {
+ &status('"root again" needs to be defined in database.');
+ }
+
+ } else { # >3rd time occurrance.
+ # disable this for the time being.
+ if (0 and $warnmode =~ /aggressive/i) {
+ if ($channels{$chan}{'o'}{$ident}) {
+ &status("RootWarn: $nick... sigh... bye bye.");
+ rawout("MODE $chan +b *!root\@$host"); # ban
+ &kick($chan,$nick,'bye bye');
+ }
+ } elsif ($_ = &getFactoid('root again')) {
+ &status("RootWarn: $attempt times; msg'ing $nick.");
+ &msg($nick, "RootWarn: $attempt : $_");
+ } else {
+ &status("root again needs to be defined in database.");
+ }
+ }
+
+ $attempt++;
+ ### TODO: OPTIMIZE THIS.
+ # ok... don't record the attempt if nick==root.
+ return if ($nick eq 'root');
+
+ &sqlSet('rootwarn', { nick => lc($nick) }, {
+ attempt => $attempt,
+ time => time(),
+ host => $user."\@".$host,
+ channel => $chan,
+ } );
+
+ return;
+}
+
+# Extras function.
+# TODO: support arguments to get info on a particular nick?
+sub CmdrootWarn {
+ my $reply;
+ my $count = &countKeys('rootwarn');
+
+ if ($count == 0) {
+ &performReply("no-one has been warned about root, woohoo");
+ return;
+ }
+
+ # reply #1.
+ $reply = 'there '.&fixPlural('has',$count) ." been \002$count\002 ".
+ &fixPlural('rooter',$count) ." warned about root.";
+
+ if ($param{'DBType'} !~ /^(pg|my)sql$/i) {
+ &FIXME("rootwarn does not yet support non-{my,pg}sql.");
+ return;
+ }
+
+ # reply #2.
+ $found = 0;
+ my $query = "SELECT attempt FROM rootwarn WHERE attempt > 2";
+ my $sth = $dbh->prepare($query);
+ $sth->execute;
+
+ while (my @row = $sth->fetchrow_array) {
+ $found++;
+ }
+
+ $sth->finish;
+
+ if ($found) {
+ $reply .= " Of which, \002$found\002 ".
+ &fixPlural('rooter',$found).' '.
+ &fixPlural('has',$found).
+ " done it at least 3 times.";
+ }
+
+ &performStrictReply($reply);
+}
+
+1;
--- /dev/null
+#
+# Rss.pl: rss handler hacked from Plug.pl
+# Author: Tim Riker <Tim@Rikers.org>
+# Licensing: Artistic License (as perl itself)
+# Version: v0.1
+#
+
+package Rss;
+
+use strict;
+
+sub Rss::Titles {
+ return join(' ',@_)=~m/<title>\s*(.*?)\s*<\/title>/gi;
+}
+
+sub Rss::Rss {
+ my ($message) = @_;
+ my @results = &::getURL($message);
+ my $retval = "i could not get the rss feed.";
+
+ my @list = &Rss::Titles(@results) if (scalar @results);
+ $retval = &::formListReply(0, 'Titles: ', @list) if (scalar @list);
+
+ &::performStrictReply($retval);
+}
+
+1;
+# vim: ts=2 sw=2
--- /dev/null
+#
+# infobot copyright kevin lenzo 1997-1998
+# rewritten by xk 1999
+#
+
+package Search;
+
+use strict;
+
+###
+# Search(keys||vals, str);
+sub Search {
+ my ($type, $str) = @_;
+ my $start_time = &::timeget();
+ my @list;
+ my $maxshow = &::getChanConfDefault('maxListReplyCount', 15, $::chan);
+
+ $type =~ s/s$//; # nice work-around.
+
+ if ($type eq 'value') {
+ # search by value.
+ @list = &::searchTable('factoids', 'factoid_key', 'factoid_value', $str);
+ } else {
+ # search by key.
+ @list = &::searchTable('factoids', 'factoid_key', 'factoid_key', $str);
+ }
+
+ @list=grep(!/\#DEL\#$/,@list) if (scalar(@list) > $maxshow);
+ my $delta_time = sprintf("%.02f", &::timedelta($start_time) );
+ &::status("search: took $delta_time sec for query.") if ($delta_time > 0);
+
+ my $prefix = "Factoid search of '\002$str\002' by $type ";
+
+ &::performStrictReply( &::formListReply(1, $prefix, @list) );
+}
+
+1;
--- /dev/null
+#
+# Topic.pl: Advanced topic management (maxtopiclen>=512)
+# Author: dms
+# Version: v0.8 (19990919).
+# Created: 19990720
+#
+
+use strict;
+use vars qw(%topiccmp %topic %channels %cache %orig);
+use vars qw($who $chan $conn $uh $ident);
+
+###############################
+##### INTERNAL FUNCTIONS
+###############################
+
+###
+# Usage: &topicDecipher(chan);
+sub topicDecipher {
+ my ($chan) = @_;
+ my @results;
+
+ return if (!exists $topic{$chan});
+ return if (!exists $topic{$chan}{'Current'});
+
+ foreach (split /\|\|/, $topic{$chan}{'Current'}) {
+ s/^\s+//;
+ s/\s+$//;
+
+ # very nice fix to solve the null subtopic problem.
+ # if nick contains a space, treat topic as ownerless.
+ if (/^\(.*?\)$/) {
+ next unless ($1 =~ /\s/);
+ }
+
+ my $subtopic = $_;
+ my $owner = 'Unknown';
+
+ if (/(.*)\s+\((.*?)\)$/) {
+ $subtopic = $1;
+ $owner = $2;
+ }
+
+ if (grep /^\Q$subtopic\E\|\|\Q$owner\E$/, @results) {
+ &status("Topic: we have found a dupe ($subtopic) in the topic, not adding.");
+ next;
+ }
+
+ push(@results, "$subtopic||$owner");
+ }
+
+ return @results;
+}
+
+###
+# Usage: &topicCipher(@topics);
+sub topicCipher {
+ return if (!@_);
+
+ my @topic;
+ foreach (@_) {
+ my ($subtopic, $setby) = split /\|\|/;
+
+ if ($param{'topicAuthor'} eq '1' and (!$setby =~ /^(unknown|)$/i)) {
+ push(@topic, "$subtopic ($setby)");
+ } else {
+ push(@topic, "$subtopic");
+ }
+ }
+
+ return join(' || ', @topic);
+}
+
+###
+# Usage: &topicNew($chan, $topic, $updateMsg);
+sub topicNew {
+ my ($chan, $topic, $updateMsg) = @_;
+ my $maxlen = 470;
+
+ if ($channels{$chan}{t} and !$channels{$chan}{o}{$ident}) {
+ &msg($who, "error: cannot change topic without ops. (channel is +t) :(");
+ return 0;
+ }
+
+ if (defined $topiccmp{$chan} and $topiccmp{$chan} eq $topic) {
+ &msg($who, "warning: action had no effect on topic; no change required.");
+ return 0;
+ }
+
+ # bail out if the new topic is too long.
+ my $newlen = length($chan.$topic);
+ if ($newlen > $maxlen) {
+ &msg($who, "new topic will be too long. ($newlen > $maxlen)");
+ return 0;
+ }
+
+ $topic{$chan}{'Current'} = $topic;
+
+ if ($cache{topicNotUpdate}{$chan}) {
+ &msg($who, "done. 'flush' to finalize changes.");
+ delete $cache{topicNotUpdate}{$chan};
+ return 1;
+ }
+
+ if (defined $updateMsg && $updateMsg ne '') {
+ &msg($who, $updateMsg);
+ }
+
+ $topic{$chan}{'Last'} = $topic;
+ $topic{$chan}{'Who'} = $orig{who}."!".$uh;
+ $topic{$chan}{'Time'} = time();
+
+ if ($topic) {
+ $conn->topic($chan, $topic);
+ &topicAddHistory($chan, $topic);
+ } else {
+ $conn->topic($chan, ' ');
+ }
+
+ return 1;
+}
+
+###
+# Usage: &topicAddHistory($chan,$topic);
+sub topicAddHistory {
+ my ($chan, $topic) = @_;
+ my $dupe = 0;
+
+ return 1 if ($topic eq ''); # required fix.
+
+ foreach (@{ $topic{$chan}{'History'} }) {
+ next if ($_ ne '' and $_ ne $topic);
+ # checking length is required.
+
+ # slightly weird to put a return statement in a loop.
+ return 1;
+ }
+
+ # WTF IS THIS FOR?
+
+ my @topics = @{ $topic{$chan}{'History'} };
+ unshift(@topics, $topic);
+ pop(@topics) while (scalar @topics > 6);
+ $topic{$chan}{'History'} = \@topics;
+
+ return $dupe;
+}
+
+###############################
+##### HELPER FUNCTIONS
+###############################
+
+# cmd: add.
+sub do_add {
+ my ($chan, $args) = @_;
+
+ if ($args eq '') {
+ &help('topic add');
+ return;
+ }
+
+ # heh, joeyh. 19990819. -xk
+ if ($who =~ /\|\|/) {
+ &msg($who, 'error: you have an invalid nick, loser!');
+ return;
+ }
+
+ return if ($channels{$chan}{t} and !&hasFlag('T'));
+
+ my @prev = &topicDecipher($chan);
+ my $new;
+ # If bot new to chan and topic is blank, it still got a (owner). This is fix
+ if ($param{'topicAuthor'} eq '1') {
+ $new = "$args ($orig{who})";
+ } else {
+ $new = "$args";
+ }
+ $topic{$chan}{'What'} = "Added '$args'.";
+
+ if (scalar @prev) {
+ my $str = sprintf("%s||%s", $args, $who);
+ $new = &topicCipher(@prev, $str);
+ }
+
+ &topicNew($chan, $new, '');
+}
+
+# cmd: delete.
+sub do_delete {
+ my ($chan, $args) = @_;
+ my @subtopics = &topicDecipher($chan);
+ my $topiccount = scalar @subtopics;
+
+ if ($topiccount == 0) {
+ &msg($who, 'No topic set.');
+ return;
+ }
+
+ if ($args eq '') {
+ &help('topic del');
+ return;
+ }
+
+ for ($args) {
+ $_ = sprintf(",%s,", $args);
+ s/\s+//g;
+ s/(first|1st)/1/i;
+ s/last/$topiccount/i;
+ s/,-(\d+)/,1-$1/;
+ s/(\d+)-,/,$1-$topiccount/;
+ }
+
+ if ($args !~ /[\,\-\d]/) {
+ &msg($who, "error: Invalid argument ($args).");
+ return;
+ }
+
+ my @delete;
+ foreach (split ',', $args) {
+ next if ($_ eq '');
+
+ # change to hash list instead of array?
+ if (/^(\d+)-(\d+)$/) {
+ my ($from,$to) = ($1,$2);
+ ($from,$to) = ($2,$1) if ($from > $to);
+
+ push(@delete, $1..$2);
+ } elsif (/^(\d+)$/) {
+ push(@delete, $1);
+ } else {
+ &msg($who, "error: Invalid sub-argument ($_).");
+ return;
+ }
+
+ $topic{$chan}{'What'} = 'Deleted '.join("/",@delete);
+ }
+
+ foreach (@delete) {
+ if ($_ > $topiccount || $_ < 1) {
+ &msg($who, "error: argument out of range. (max: $topiccount)");
+ return;
+ }
+
+ # skip if already deleted.
+ # only checked if x-y range is given.
+ next unless (defined($subtopics[$_-1]));
+
+ my ($subtopic,$whoby) = split('\|\|', $subtopics[$_-1]);
+
+ $whoby = 'unknown' if ($whoby eq '');
+
+ &msg($who, "Deleting topic: $subtopic ($whoby)");
+ undef $subtopics[$_-1];
+ }
+
+ my @newtopics;
+ foreach (@subtopics) {
+ next unless (defined $_);
+ push(@newtopics, $_);
+ }
+
+ &topicNew($chan, &topicCipher(@newtopics), '');
+}
+
+# cmd: list
+sub do_list {
+ my ($chan, $args) = @_;
+ my @topics = &topicDecipher($chan);
+
+ if (!scalar @topics) {
+ &msg($who, "No topics for \002$chan\002.");
+ return;
+ }
+
+ &msg($who, "Topics for \002$chan\002:");
+ &msg($who, "No \002[\002 Set by \002]\002 Topic");
+
+ my $i = 1;
+ foreach (@topics) {
+ my ($subtopic, $setby) = split /\|\|/;
+
+ my $str = sprintf(" %d. [%-10s] %s", $i, $setby, $subtopic);
+ # is there a better way of doing this?
+ $str =~ s/ (\[)/ \002$1/g;
+ $str =~ s/ (\])/ \002$1/g;
+
+ &msg($who, $str);
+ $i++;
+ }
+
+ &msg($who, "End of Topics.");
+}
+
+# cmd: modify.
+sub do_modify {
+ my ($chan, $args) = @_;
+
+ if ($args eq '') {
+ &help('topic mod');
+ return;
+ }
+
+ # a warning message instead of halting. we kind of trust the user now.
+ if ($args =~ /\|\|/) {
+ &msg($who, "warning: adding double pipes manually == evil. be warned.");
+ }
+
+ $topic{$chan}{'What'} = "SAR $args";
+
+ # SAR patch. mu++
+ if ($args =~ m|^\s*s([/,#])(.+?)\1(.*?)\1([a-z]*);?\s*$|) {
+ my ($delim, $op, $np, $flags) = ($1,$2,$3,$4);
+
+ if ($flags !~ /^(g)?$/) {
+ &msg($who, "error: Invalid flags to regex.");
+ return;
+ }
+
+ my $topic = $topic{$chan}{'Current'};
+
+ ### TODO: use m### to make code safe!
+ if (($flags eq 'g' and $topic =~ s/\Q$op\E/$np/g) ||
+ ($flags eq '' and $topic =~ s/\Q$op\E/$np/)
+ ) {
+
+ $_ = "Modifying topic with sar s/$op/$np/.";
+ &topicNew($chan, $topic, $_);
+ } else {
+ &msg($who, "warning: regex not found in topic.");
+ }
+
+ return;
+ }
+
+ &msg($who, "error: Invalid regex. Try s/1/2/, s#3#4#...");
+}
+
+# cmd: move.
+sub do_move {
+ my ($chan, $args) = @_;
+
+ if ($args eq '') {
+ &help('topic mv');
+ return;
+ }
+
+ my ($from, $action, $to);
+ # better way of doing this?
+ if ($args =~ /^(first|last|\d+)\s+(before|after|swap)\s+(first|last|\d+)$/i) {
+ ($from, $action, $to) = ($1,$2,$3);
+ } else {
+ &msg($who, "Invalid arguments.");
+ return;
+ }
+
+ my @subtopics = &topicDecipher($chan);
+ my @newtopics;
+ my $topiccount = scalar @subtopics;
+
+ if ($topiccount == 1) {
+ &msg($who, "error: impossible to move the only subtopic, dumbass.");
+ return;
+ }
+
+ # Is there an easier way to do this?
+ $from =~ s/first/1/i;
+ $to =~ s/first/1/i;
+ $from =~ s/last/$topiccount/i;
+ $to =~ s/last/$topiccount/i;
+
+ if ($from > $topiccount || $to > $topiccount || $from < 1 || $to < 1) {
+ &msg($who, "error: <from> or <to> is out of range.");
+ return;
+ }
+
+ if ($from == $to) {
+ &msg($who, "error: <from> and <to> are the same.");
+ return;
+ }
+
+ $topic{$chan}{'What'} = "Move $from to $to";
+
+ if ($action =~ /^(swap)$/i) {
+ my $tmp = $subtopics[$to - 1];
+ $subtopics[$to - 1] = $subtopics[$from - 1];
+ $subtopics[$from - 1] = $tmp;
+
+ $_ = "Swapped #\002$from\002 with #\002$to\002.";
+ &topicNew($chan, &topicCipher(@subtopics), $_);
+ return;
+ }
+
+ # action != swap:
+ # Is there a better way to do this? guess not.
+ my $i = 1;
+ my $subtopic = $subtopics[$from - 1];
+ foreach (@subtopics) {
+ my $j = $i*2 - 1;
+ $newtopics[$j] = $_ if ($i != $from);
+ $i++;
+ }
+
+ if ($action =~ /^(before|b4)$/i) {
+ $newtopics[$to*2-2] = $subtopic;
+ } else {
+ # action =~ /after/.
+ $newtopics[$to*2] = $subtopic;
+ }
+
+ undef @subtopics; # lets reuse this array.
+ foreach (@newtopics) {
+ next if (!defined $_ or $_ eq '');
+ push(@subtopics, $_);
+ }
+
+ $_ = "Moved #\002$from\002 $action #\002$to\002.";
+ &topicNew($chan, &topicCipher(@subtopics), $_);
+}
+
+# cmd: shuffle.
+sub do_shuffle {
+ my ($chan, $args) = @_;
+ my @subtopics = &topicDecipher($chan);
+ my @newtopics;
+
+ $topic{$chan}{'What'} = 'shuffled';
+
+ foreach (&makeRandom(scalar @subtopics)) {
+ push(@newtopics, $subtopics[$_]);
+ }
+
+ $_ = "Shuffling the bag of lollies.";
+ &topicNew($chan, &topicCipher(@newtopics), $_);
+}
+
+# cmd: history.
+sub do_history {
+ my ($chan, $args) = @_;
+
+ if (!scalar @{ $topic{$chan}{'History'} }) {
+ &msg($who, "Sorry, no topics in history list.");
+ return;
+ }
+
+ &msg($who, "History of topics on \002$chan\002:");
+ for (1 .. scalar @{ $topic{$chan}{'History'} }) {
+ my $topic = ${ $topic{$chan}{'History'} }[$_-1];
+ &msg($who, " #\002$_\002: $topic");
+
+ # To prevent excess floods.
+ sleep 1 if (length($topic) > 160);
+ }
+
+ &msg($who, "End of list.");
+}
+
+# cmd: restore.
+sub do_restore {
+ my ($chan, $args) = @_;
+
+ if ($args eq '') {
+ &help('topic restore');
+ return;
+ }
+
+ $topic{$chan}{'What'} = "Restore topic $args";
+
+ # following needs to be verified.
+ if ($args =~ /^last$/i) {
+ if (${ $topic{$chan}{'History'} }[0] eq $topic{$chan}{'Current'}) {
+ &msg($who,"error: cannot restore last topic because it's mine.");
+ return;
+ }
+ $args = 1;
+ }
+
+ if ($args !~ /\d+/) {
+ &msg($who, "error: argument is not positive integer.");
+ return;
+ }
+
+ if ($args > $#{ $topic{$chan}{'History'} } || $args < 1) {
+ &msg($who, "error: argument is out of range.");
+ return;
+ }
+
+ $_ = "Changing topic according to request.";
+ &topicNew($chan, ${ $topic{$chan}{'History'} }[$args-1], $_);
+}
+
+# cmd: rehash.
+sub do_rehash {
+ my ($chan) = @_;
+
+ $_ = "Rehashing topic...";
+ $topic{$chan}{'What'} = 'Rehash';
+ &topicNew($chan, $topic{$chan}{'Current'}, $_, 1);
+}
+
+# cmd: info.
+sub do_info {
+ my ($chan) = @_;
+
+ my $reply = "no topic info.";
+ if (exists $topic{$chan}{'Who'} and exists $topic{$chan}{'Time'}) {
+ $reply = "topic on \002$chan\002 was last set by ".
+ $topic{$chan}{'Who'}. ". This was done ".
+ &Time2String(time() - $topic{$chan}{'Time'}) .' ago'.
+ ". Length: ".length($topic{$chan}{'Current'});
+ my $change = $topic{$chan}{'What'};
+ $reply .= ". Change => $change" if (defined $change);
+ }
+
+ &performStrictReply($reply);
+}
+
+###############################
+##### MAIN
+###############################
+
+###
+# Usage: &Topic($cmd, $args);
+sub Topic {
+ my ($chan, $cmd, $args) = @_;
+
+ if ($cmd =~ /^-(\S+)/) {
+ $cache{topicNotUpdate}{$chan} = 1;
+ $cmd = $1;
+ }
+
+ if ($cmd =~ /^(add)$/i) {
+ &do_add($chan, $args);
+
+ } elsif ($cmd =~ /^(del|delete|rm|remove|kill|purge)$/i) {
+ &do_delete($chan, $args);
+
+ } elsif ($cmd =~ /^list$/i) {
+ &do_list($chan, $args);
+
+ } elsif ($cmd =~ /^(mod|modify|change|alter)$/i) {
+ &do_modify($chan, $args);
+
+ } elsif ($cmd =~ /^(mv|move)$/i) {
+ &do_move($chan, $args);
+
+ } elsif ($cmd =~ /^shuffle$/i) {
+ &do_shuffle($chan, $args);
+
+ } elsif ($cmd =~ /^(history)$/i) {
+ &do_history($chan, $args);
+
+ } elsif ($cmd =~ /^restore$/i) {
+ &do_restore($chan, $args);
+
+ } elsif ($cmd =~ /^(flush|rehash)$/i) {
+ &do_rehash($chan);
+
+ } elsif ($cmd =~ /^info$/i) {
+ &do_info($chan);
+
+ } else {
+ ### HELP:
+ if ($cmd ne '' and $cmd !~ /^help/i) {
+ &msg($who, "Invalid command [$cmd].");
+ &msg($who, "Try 'help topic'.");
+ return;
+ }
+
+ &help('topic');
+ }
+
+ return;
+}
+
+1;
--- /dev/null
+# Units.pl: convert units of measurement
+# Author: M-J. Dominus (mjd-perl-units-id-iut+buobvys+@plover.com)
+# License: GPL, Copyright (C) 1996,1999
+# NOTE: Integrated into infobot by xk.
+
+package Units;
+
+# use strict; # TODO
+
+#$DEBUG_p = 1;
+#$DEBUG_o = 1;
+#$DEBUG_l = 1;
+my %unittab; # Definitions loaded here
+
+# Metric prefixes. These must be powers of ten or change the
+# token_value subroutine
+BEGIN {
+ %PREF = (yocto => -24,
+ zepto => -21,
+ atto => -18,
+ femto => -15,
+ pico => -12,
+ nano => -9,
+ micro => -6,
+# u => -6,
+ milli => -3,
+ centi => -2,
+ deci => -1,
+ deca => 1,
+ deka => 1,
+ hecto => 2,
+ hect => 2,
+ kilo => 3,
+ myria => 4,
+ mega => 6,
+ giga => 9,
+ tera => 12,
+ peta => 15,
+ exa => 18,
+ yotta => 21,
+ zetta => 24,
+ );
+ $PREF = join '|', sort { $PREF{$a} <=> $PREF{$b} } (keys %PREF);
+}
+
+
+################################################################
+#
+# Main program here
+#
+################################################################
+
+{ my $defs_read = 0;
+ $defs_read += read_defs("$::bot_data_dir/unittab");
+
+ unless ($defs_read) {
+ &::ERROR('Could not read any of the initialization files UNITTAB');
+ return;
+ }
+}
+
+sub convertUnits {
+ my ($from,$to) = @_;
+
+ # POWER HACK.
+ $from =~ s/\^(\-?\d+)/$1/;
+ $to =~ s/\^(\-?\d+)/$1/;
+ my %powers = (
+ 2 => 'squared?',
+ 3 => 'cubed?',
+ );
+ foreach (keys %powers) {
+ $from =~ s/(\D+) $powers{$_}$/$1\Q$_/;
+ $to =~ s/(\D+) $powers{$_}$/$1\Q$_/;
+ }
+ # END OF POWER HACK.
+
+ ### FROM:
+ trim($from);
+ if ($from =~ s/^\s*\#\s*//) {
+ if (definition_line($from)) {
+ &::DEBUG("Defined.");
+ } else {
+ &::DEBUG("Error: $PARSE_ERROR.");
+ }
+ &::DEBUG("FAILURE 1.");
+ return;
+ }
+ unless ($from =~ /\S/) {
+ &::DEBUG('FAILURE 2');
+ return;
+ }
+
+ my $hu = parse_unit($from);
+ if (is_Zero($hu)) {
+ &::DEBUG($PARSE_ERROR);
+ &::msg($::who, $PARSE_ERROR);
+ return;
+ }
+
+ ### TO:
+ my $wu;
+ trim($to);
+ redo unless $to =~ /\S/;
+ $wu = parse_unit($to);
+ if (is_Zero($wu)) {
+ &::DEBUG($PARSE_ERROR);
+ }
+
+ my $quot = unit_divide($hu, $wu);
+ if (is_dimensionless($quot)) {
+ my $q = $quot->{_};
+ if ($q == 0) {
+ &::performStrictReply("$to is an invalid unit?");
+ return;
+ }
+ # yet another powers hack.
+ $from =~ s/([[:alpha:]]+)(\d)/$1\^$2/g;
+ $to =~ s/([[:alpha:]]+)(\d)/$1\^$2/g;
+
+ &::performStrictReply(sprintf("$from is approximately \002%.6g\002 $to", $q));
+ } else {
+ &::performStrictReply("$from cannot be correctly converted to $to.");
+
+# print
+# "conformability (Not the same dimension)\n",
+# "\t", $from, ' is ', text_unit($hu), "\n",
+# "\t", $to, ' is ', text_unit($wu), "\n",
+# ;
+ }
+}
+
+
+################################################################
+
+sub read_defs {
+ my ($file) = @_;
+ unless (open D, $file) {
+ if ($show_file_loading) {
+ print STDERR "Couldn't open file `$file': $!; skipping.\n";
+ }
+ return 0;
+ }
+ while (<D>) {
+ s/\#.*$//;
+ trim($_);
+ next unless /\S/;
+
+ print ">>> $_\n" if $DEBUG_d;
+ my $r = definition_line($_);
+ unless (defined $r) {
+ warn "Error in line $. of $file: $PARSE_ERROR. Skipping.\n";
+ }
+ }
+ print STDERR "Loaded file `$file'.\n" if $show_file_loading;
+ return 1;
+}
+
+sub definition_line {
+ my ($line) = @_;
+ my ($name, $data) = split /\s+/, $line, 2;
+ my $value = parse_unit($data);
+ if (is_Zero($value)) {
+ return;
+ }
+ if (is_fundamental($value)) {
+ return $unittab{$name} = {_ => 1, $name => 1};
+ } else {
+ return $unittab{$name} = $value;
+ }
+}
+
+sub trim {
+ $_[0] =~ s/\s+$//;
+ $_[0] =~ s/^\s+//;
+}
+
+sub Zero () { +{ _ => 0 } }
+
+sub is_Zero {
+ $_[0]{_} == 0;
+}
+
+sub unit_lookup {
+ my ($name) = @_;
+ print STDERR "Looking up unit `$name'\n" if $DEBUG_l;
+ return $unittab{$name} if exists $unittab{$name};
+ if ($name =~ /s$/) {
+ my $shortname = $name;
+ $shortname =~ s/s$//;
+ return $unittab{$shortname} if exists $unittab{$shortname};
+ }
+ my ($prefix, $rest) = ($name =~ /^($PREF-?)(.*)/o);
+ unless ($prefix) {
+ $PARSE_ERROR = "Unknown unit `$name'";
+ return Zero;
+ }
+ my $base_unit = unit_lookup($rest); # Recursive
+ con_multiply($base_unit, 10**$PREF{$prefix});
+}
+
+sub unit_multiply {
+ my ($a, $b) = @_;
+ print STDERR "Multiplying @{[%$a]} by @{[%$b]}: \n" if $DEBUG_o;
+ my $r = {%$a};
+ $r->{_} *= $b->{_};
+ my $u;
+ for $u (keys %$b) {
+ next if $u eq '_';
+ $r->{$u} += $b->{$u};
+ }
+ print STDERR "\tResult: @{[%$r]}\n" if $DEBUG_o;
+ $r;
+}
+
+sub unit_divide {
+ my ($a, $b) = @_;
+ if ($b->{_} == 0) {
+ &::DEBUG('Division by zero error');
+ return;
+ }
+ my $r = {%$a};
+ $r->{_} /= $b->{_};
+ my $u;
+ for $u (keys %$b) {
+ next if $u eq '_';
+ $r->{$u} -= $b->{$u};
+ }
+ $r;
+}
+
+sub unit_power {
+ my ($p, $u) = @_;
+ print STDERR "Raising unit @{[%$u]} to power $p.\n" if $DEBUG_o;
+ my $r = {%$u};
+ $r->{_} **= $p;
+ my $d;
+ for $d (keys %$r) {
+ next if $d eq '_';
+ $r->{$d} *= $p;
+ }
+ print STDERR "\tResult: @{[%$r]}\n" if $DEBUG_o;
+ $r;
+}
+
+sub unit_dimensionless {
+ print "Turning $_[0] into a dimensionless unit.\n" if $DEBUG_o;
+ return +{_ => $_[0]};
+}
+
+sub con_multiply {
+ my ($u, $c) = @_;
+ print STDERR "Multiplying unit @{[%$u]} by constant $c.\n" if $DEBUG_o;
+ my $r = {%$u};
+ $r->{_} *= $c;
+ print STDERR "\tResult: @{[%$r]}\n" if $DEBUG_o;
+ $r;
+}
+
+sub is_dimensionless {
+ my ($r) = @_;
+ my $u;
+ for $u (keys %$r) {
+ next if $u eq '_';
+ return if $r->{$u} != 0;
+ }
+ return 1;
+}
+
+# Generate bogus unit value that signals that a new fundamental unit
+# is being defined
+sub new_fundamental_unit {
+ return +{__ => 'new', _ => 1};
+}
+
+# Recognize this bogus value when it appears again.
+sub is_fundamental {
+ exists $_[0]{__};
+}
+
+sub text_unit {
+ my ($u) = @_;
+ my (@pos, @neg);
+ my $k;
+ my $c = $u->{_};
+ for $k (sort keys %$u) {
+ next if $k eq '_';
+ push @pos, $k if $u->{$k} > 0;
+ push @neg, $k if $u->{$k} < 0;
+ }
+ my $text = ($c == 1 ? '' : $c);
+ my $d;
+ for $d (@pos) {
+ my $e = $u->{$d};
+ $text .= " $d";
+ $text .= "^$e" if $e > 1;
+ }
+
+ $text .= ' per' if @neg;
+ for $d (@neg) {
+ my $e = - $u->{$d};
+ $text .= " $d";
+ $text .= "^$e" if $e > 1;
+ }
+
+ $text;
+}
+################################################################
+#
+# I'm the parser
+#
+
+BEGIN {
+ sub sh { ['shift', $_[0]] };
+ sub go { ['goto', $_[0]] };
+ @actions =
+ (
+ # Initial state
+ {PREFIX => sh(1),
+ NUMBER => sh(2),
+ NAME => sh(3),
+ FUNDAMENTAL => sh(4),
+ FRACTION => sh(5),
+ '(' => sh(6),
+ 'unit' => go(7),
+ 'topunit' => go(17),
+ 'constant' => go(8),
+ },
+ # State 1: constant -> PREFIX .
+ { _ => ['reduce', 1, 'constant']},
+ # State 2: constant -> NUMBER .
+ { _ => ['reduce', 1, 'constant']},
+ # State 3: unit -> NAME .
+ { _ => ['reduce', 1, 'unit', \&unit_lookup ]},
+ # State 4: unit -> FUNDAMENTAL .
+ { _ => ['reduce', 1, 'unit', \&new_fundamental_unit ]},
+ # State 5: constant -> FRACTION .
+ { _ => ['reduce', 1, 'constant']},
+ # State 6: unit -> '(' . unit ')'
+ {PREFIX => sh(1),
+ NUMBER => sh(2),
+ NAME => sh(3),
+ FUNDAMENTAL => sh(4),
+ FRACTION => sh(5),
+ '(' => sh(6),
+ 'unit' => go(9),
+ 'constant' => go(8),
+ },
+ # State 7: topunit -> unit .
+ # unit -> unit . TIMES unit
+ # unit -> unit . DIVIDE unit
+ # unit -> unit . NUMBER
+ {NUMBER => sh(10),
+ TIMES => sh(11),
+ DIVIDE => sh(12),
+ _ => ['reduce', 1, 'topunit'],
+ },
+ # State 8: unit -> constant . unit
+ # unit -> constant .
+ {PREFIX => sh(1),
+ NUMBER => sh(2), # Shift-reduce conflict resolved in favor of shift
+ NAME => sh(3),
+ FUNDAMENTAL => sh(4),
+ FRACTION => sh(5),
+ '(' => sh(6),
+ _ => ['reduce', 1, 'unit', \&unit_dimensionless],
+ 'unit' => go(13),
+ 'constant' => go(8),
+ },
+ # State 9: unit -> unit . TIMES unit
+ # unit -> unit . DIVIDE unit
+ # unit -> '(' unit . ')'
+ # unit -> unit . NUMBER
+ {NUMBER => sh(10),
+ TIMES => sh(11),
+ DIVIDE => sh(12),
+ ')' => sh(14),
+ },
+ # State 10: unit -> unit NUMBER .
+ { _ => ['reduce', 2, 'unit',
+ sub {
+ unless (int($_[1]) == $_[1]) {
+ ABORT("Nonintegral power $_[1]");
+ return Zero;
+ }
+ unit_power(@_);
+ }
+ ],
+ },
+ # State 11: unit -> unit TIMES . unit
+ {PREFIX => sh(1),
+ NUMBER => sh(2),
+ NAME => sh(3),
+ FUNDAMENTAL => sh(4),
+ FRACTION => sh(5),
+ '(' => sh(6),
+ 'unit' => go(15),
+ 'constant' => go(8),
+ },
+ # State 12: unit -> unit DIVIDE . unit
+ {PREFIX => sh(1),
+ NUMBER => sh(2),
+ NAME => sh(3),
+ FUNDAMENTAL => sh(4),
+ FRACTION => sh(5),
+ '(' => sh(6),
+ 'unit' => go(16),
+ 'constant' => go(8),
+ },
+ # State 13: unit -> unit . TIMES unit
+ # unit -> unit . DIVIDE unit
+ # unit -> constant unit .
+ # unit -> unit . NUMBER
+ {NUMBER => sh(10), # Shift-reduce conflict resolved in favor of shift
+ TIMES => sh(11), # Shift-reduce conflict resolved in favor of shift
+ DIVIDE => sh(12), # Shift-reduce conflict resolved in favor of shift
+ _ => ['reduce', 2, 'unit', \&con_multiply],
+ },
+ # State 14: unit => '(' unit ')' .
+ { _ => ['reduce', 3, 'unit', sub {$_[1]}] },
+ # State 15: unit -> unit . TIMES unit
+ # unit -> unit TIMES unit .
+ # unit -> unit . DIVIDE unit
+ # unit -> unit . NUMBER
+ {NUMBER => sh(10), # Shift-reduce conflict resolved in favor of shift
+ _ => ['reduce', 3, 'unit', sub {unit_multiply($_[0], $_[2])}],
+ },
+ # State 16: unit -> unit . TIMES unit
+ # unit -> unit DIVIDE unit .
+ # unit -> unit . DIVIDE unit
+ # unit -> unit . NUMBER
+ {NUMBER => sh(10), # Shift-reduce conflict resolved in favor of shift
+ _ => ['reduce', 3, 'unit', sub{unit_divide($_[2], $_[0])}],
+ },
+ # State 17: Finishing path
+ {EOF => go(18),},
+ # State 18: Final state
+ {_ => ['accept']},
+ );
+}
+
+sub ABORT {
+ $PARSE_ERROR = shift;
+}
+
+sub parse_unit {
+ my ($s) = @_;
+ my $tokens = lex($s);
+ my $STATE = 0;
+ my (@state_st, @val_st);
+
+ $PARSE_ERROR = undef;
+
+ # Now let's run the parser
+ for (;;) {
+ return Zero if $PARSE_ERROR;
+ my $la = @$tokens ? token_type($tokens->[0]) : 'EOF';
+ print STDERR "Now in state $STATE. Lookahead type is $la.\n" if $DEBUG_p;
+ print STDERR "State stack is (@state_st).\n" if $DEBUG_p;
+ my $actiontab = $actions[$STATE];
+ my $action = $actiontab->{$la} || $actiontab->{_};
+ unless ($action) {
+ $PARSE_ERROR = 'Syntax error';
+ return Zero;
+ }
+
+ my ($primary, @actargs) = @$action;
+ print STDERR " $primary (@actargs)\n" if $DEBUG_p;
+ if ($primary eq 'accept') {
+ return $val_st[0]; # Success!
+ } elsif ($primary eq 'shift') {
+ my $token = shift @$tokens;
+ my $val = token_value($token);
+ push @val_st, $val;
+ push @state_st, $STATE;
+ $STATE = $actargs[0];
+ } elsif ($primary eq 'goto') {
+ $STATE = $actargs[0];
+ } elsif ($primary eq 'reduce') {
+ my ($n_args, $result_type, $semantic) = @actargs;
+ my @arglist;
+# push @state_st, 'FAKE'; # So that we only really remove n-1 states
+ while ($n_args--) {
+ push @arglist, pop @val_st;
+ $STATE = pop @state_st;
+ }
+ my $result = $semantic ? &$semantic(@arglist) : $arglist[0];
+ push @val_st, $result;
+ push @state_st, $STATE;
+# $STATE = $state_st[-1];
+ print STDERR "Post-reduction state is $STATE.\n" if $DEBUG_p;
+
+ # Now look for `goto' actions
+ my $goto = $actions[$STATE]{$result_type};
+ unless ($goto && $goto->[0] eq 'goto') {
+ &::ERROR("No post-reduction goto in state $STATE for $result_type.");
+ return;
+ }
+ print STDERR "goto $goto->[1]\n" if $DEBUG_p;
+ $STATE = $goto->[1];
+ } else {
+ &::ERROR("Bad primary $primary");
+ return;
+ }
+ }
+}
+
+
+sub lex {
+ my ($s) = @_;
+ my @t = split /(
+ \*{3} # Special `new unit' symbol
+ | [()*-] # Symbol
+ | \s*(?:\/|\bper\b)\s* # Division
+ | \d*\.\d+(?:[eE]-?\d+)? # Decimal number
+ | \d+\|\d+ # Fraction
+ | \d+ # Integer
+# | (?:$PREF)-? # Prefix (handle differently)
+ | [A-Za-z_][A-Za-z_.]* # identifier
+ | \s+ # White space
+ )/ox, $s;
+ @t = grep {$_ ne ''} @t; # Discard empty and all-white tokens
+ \@t;
+}
+
+sub token_type {
+ my ($token) = @_;
+ return $token->[0] if ref $token;
+ return $token if $token =~ /[()]/;
+ return TIMES if $token =~ /^\s+$/;
+ return FUNDAMENTAL if $token eq '***';
+ return DIVIDE if $token =~ /^\s*(\/|\bper\b)\s*$/;
+ return TIMES if $token eq '*' || $token eq '-';
+ return FRACTION if $token =~ /^\d+\|\d+$/;
+ return NUMBER if $token =~ /^[.\d]/;
+# return PREFIX if $token =~ /^$PREF/o;
+ return NAME;
+}
+
+sub token_value {
+ my ($token) = @_;
+ return $token if $token =~ /^([()*\/-]|\s*\bper\b\s*)$/;
+ if ($token =~ /(\d+)\|(\d+)/) {
+ if ($2 == 0) {
+ ABORT("Zero denominator in fraction `$token'");
+ return 0;
+ }
+ return $1/$2;
+# } elsif ($token =~ /$PREF/o) {
+# $token =~ s/-$//;
+# return 10**($PREF{$token});
+ }
+ return $token; # Perl takes care of the others.
+}
+
+1;
--- /dev/null
+#
+# Uptime.pl: Uptime daemon.
+# Author: dms
+# Version: v0.3 (19991008)
+# Created: 19990925.
+#
+
+# use strict; # TODO
+
+my $uptimerecords = 3;
+
+sub uptimeNow {
+ return time() - $^T;
+}
+
+sub uptimeStr {
+ my $uptimenow = &uptimeNow();
+
+ if (defined $_[0]) {
+ return "$uptimenow.$$ running $bot_version, ended ". gmtime(time());
+ } else {
+ return "$uptimenow running $bot_version";
+ }
+}
+
+sub uptimeGetInfo {
+ my (%uptime,%done);
+ my ($uptime,$pid);
+ my @results;
+ my $file = $file{utm};
+
+ if (!open(IN, $file)) {
+ &status("Writing uptime file for first time usage (nothing special).");
+ open(OUT,">$file");
+ close OUT;
+ } else {
+ while (<IN>) {
+ chop;
+
+ if (/^(\d+)\.(\d+) (.*)/) {
+ $uptime{$1}{$2} = $3;
+ }
+ }
+ close IN;
+ }
+
+ &uptimeStr(1) =~ /^(\d+)\.(\d+) (.*)/;
+ $uptime{$1}{$2} = $3;
+
+ # fixed up bad implementation :)
+ # should be no problems, even if uptime or pid is duplicated.
+ ## WARN: run away forks may get through here, have to fix.
+ foreach $uptime (sort {$b <=> $a} keys %uptime) {
+ foreach $pid (keys %{ $uptime{$uptime} }) {
+ next if (exists $done{$pid});
+
+ push(@results,"$uptime.$pid $uptime{$uptime}{$pid}");
+ $done{$pid} = 1;
+ last if (scalar @results == $uptimerecords);
+ }
+ last if (scalar @results == $uptimerecords);
+ }
+
+ return @results;
+}
+
+sub uptimeWriteFile {
+ my @results = &uptimeGetInfo();
+ my $file = $file{utm};
+
+ if ($$ != $bot_pid) {
+ &FIXME('uptime: forked process doing weird things!');
+ exit 0;
+ }
+
+ if (!open(OUT,">$file")) {
+ &status("error: cannot write to $file.");
+ return;
+ }
+
+ foreach (@results) {
+ print OUT "$_\n";
+ }
+
+ close OUT;
+ &status('--- Saved uptime records.');
+
+ return unless defined $conn;
+
+ $conn->schedule(&getRandomInt('1800-3600'), \&uptimeWriteFile, '');
+}
+
+1;
--- /dev/null
+#
+# UserDCC.pl: User Commands, DCC CHAT.
+# Author: dms
+# Version: v0.2 (20010119)
+# Created: 20000707 (from UserExtra.pl)
+#
+
+use strict;
+
+use vars qw(%users %ignore %sched %bans %mask %cache %channels %param
+ %chanconf %dcc);
+use vars qw($who $chan $message $msgType $user $chnick $conn $ident
+ $verifyUser $ucount_userfile $utime_userfile $lobotomized
+ $utime_chanfile $ucount_chanfile);
+use vars qw(@backlog);
+
+sub userDCC {
+ # hrm...
+ $message =~ s/\s+$//;
+
+ ### for all users.
+ # quit.
+ if ($message =~ /^(exit|quit)$/i) {
+ # do ircII clients support remote close? if so, cool!
+ &FIXME("userDCC: quit called.");
+ &dcc_close($who);
+ &status("userDCC: after dcc_close!");
+
+ return;
+ }
+
+ # who.
+ if ($message =~ /^who$/) {
+ my $count = scalar(keys %{ $dcc{'CHAT'} });
+ my $dccCHAT = $message;
+
+ &performStrictReply("Start of who ($count users).");
+ foreach (keys %{ $dcc{'CHAT'} }) {
+ &performStrictReply("=> $_");
+ }
+ &performStrictReply("End of who.");
+
+ return;
+ }
+
+ ### for those users with enough flags.
+
+ if ($message =~ /^tellme(\s+(.*))?$/i) {
+ my $args = $2;
+ if ($args =~ /^\s*$/) {
+ &help('tellme');
+ return;
+ }
+
+ my $result = &doQuestion($args);
+ &performStrictReply($result);
+
+ return;
+ }
+
+ # 4op.
+ if ($message =~ /^4op(\s+($mask{chan}))?$/i) {
+ return unless (&hasFlag('o'));
+
+ my $chan = $2;
+
+ if ($chan eq '') {
+ &help('4op');
+ return;
+ }
+
+ if (!$channels{$chan}{'o'}{$ident}) {
+ &msg($who, "i don't have ops on $chan to do that.");
+ return;
+ }
+
+ # on non-4mode(<4) servers, this may be exploited.
+ if ($channels{$chan}{'o'}{$who}) {
+ rawout("MODE $chan -o+o-o+o". (" $who" x 4));
+ } else {
+ rawout("MODE $chan +o-o+o-o". (" $who" x 4));
+ }
+
+ return;
+ }
+
+ # opme.
+ if ($message =~ /^opme(\s+($mask{chan}))?$/i) {
+ return unless (&hasFlag('o'));
+ return unless (&hasFlag('A'));
+
+ my $chan = $2;
+
+ if ($chan eq '') {
+ &help('4op');
+ return;
+ }
+
+ # can this be exploited?
+ rawout("MODE $chan +o $who");
+
+ return;
+ }
+
+ # backlog.
+ if ($message =~ /^backlog(\s+(.*))?$/i) {
+ return unless (&hasFlag('o'));
+ return unless (&IsParam('backlog'));
+ my $num = $2;
+ my $max = $param{'backlog'};
+
+ if (!defined $num) {
+ &help('backlog');
+ return;
+ } elsif ($num !~ /^\d+/) {
+ &msg($who, "error: argument is not positive integer.");
+ return;
+ } elsif ($num > $max or $num < 0) {
+ &msg($who, "error: argument is out of range (max $max).");
+ return;
+ }
+
+ &msg($who, "Start of backlog...");
+ for (0..$num-1) {
+ sleep 1 if ($_ % 4 == 0 and $_ != 0);
+ $conn->privmsg($who, "[".($_+1)."]: $backlog[$max-$num+$_]");
+ }
+ &msg($who, "End of backlog.");
+
+ return;
+ }
+
+ # dump variables.
+ if ($message =~ /^dumpvars$/i) {
+ return unless (&hasFlag('o'));
+ return unless (&IsParam('DumpVars'));
+
+ &status("Dumping all variables...");
+ &dumpallvars();
+
+ return;
+ }
+
+ # dump variables ][.
+ if ($message =~ /^symdump$/i) {
+ return unless (&hasFlag('o'));
+ return unless (&IsParam('DumpVars2'));
+
+ &status("Dumping all variables...");
+ &symdumpAllFile();
+
+ return;
+ }
+
+ # kick.
+ if ($message =~ /^kick(\s+(.*?))$/) {
+ return unless (&hasFlag('o'));
+
+ my $arg = $2;
+
+ if ($arg eq '') {
+ &help('kick');
+ return;
+ }
+ my @args = split(/\s+/, $arg);
+ my ($nick,$chan,$reason) = @args;
+
+ if (&validChan($chan) == 0) {
+ &msg($who,"error: invalid channel \002$chan\002");
+ return;
+ }
+
+ if (&IsNickInChan($nick,$chan) == 0) {
+ &msg($who,"$nick is not in $chan.");
+ return;
+ }
+
+ &kick($nick,$chan,$reason);
+
+ return;
+ }
+
+ # mode.
+ if ($message =~ /^mode(\s+(.*))?$/) {
+ return unless (&hasFlag('n'));
+ my ($chan,$mode) = split /\s+/,$2,2;
+
+ if ($chan eq '') {
+ &help('mode');
+ return;
+ }
+
+ if (&validChan($chan) == 0) {
+ &msg($who,"error: invalid channel \002$chan\002");
+ return;
+ }
+
+ if (!$channels{$chan}{o}{$ident}) {
+ &msg($who,"error: don't have ops on \002$chan\002");
+ return;
+ }
+
+ &mode($chan, $mode);
+
+ return;
+ }
+
+ # part.
+ if ($message =~ /^part(\s+(\S+))?$/i) {
+ return unless (&hasFlag('o'));
+ my $jchan = $2;
+
+ if ($jchan !~ /^$mask{chan}$/) {
+ &msg($who, "error, invalid chan.");
+ &help('part');
+ return;
+ }
+
+ if (!&validChan($jchan)) {
+ &msg($who, "error, I'm not on that chan.");
+ return;
+ }
+
+ &msg($jchan, "Leaving. (courtesy of $who).");
+ &part($jchan);
+ return;
+ }
+
+ # lobotomy. sometimes we want the bot to be _QUIET_.
+ if ($message =~ /^(lobotomy|bequiet)$/i) {
+ return unless (&hasFlag('o'));
+
+ if ($lobotomized) {
+ &performReply("i'm already lobotomized");
+ } else {
+ &performReply('i have been lobotomized');
+ $lobotomized = 1;
+ }
+
+ return;
+ }
+
+ # unlobotomy.
+ if ($message =~ /^(unlobotomy|benoisy)$/i) {
+ return unless (&hasFlag('o'));
+
+ if ($lobotomized) {
+ &performReply('i have been unlobotomized, woohoo');
+ $lobotomized = 0;
+ delete $cache{lobotomy};
+# undef $cache{lobotomy}; # ??
+ } else {
+ &performReply("i'm not lobotomized");
+ }
+
+ return;
+ }
+
+ # op.
+ if ($message =~ /^op(\s+(.*))?$/i) {
+ return unless (&hasFlag('o'));
+ my ($opee) = lc $2;
+ my @chans;
+
+ if ($opee =~ / /) {
+ if ($opee =~ /^(\S+)\s+(\S+)$/) {
+ $opee = $1;
+ @chans = ($2);
+ if (!&validChan($2)) {
+ &msg($who,"error: invalid chan ($2).");
+ return;
+ }
+ } else {
+ &msg($who,"error: invalid params.");
+ return;
+ }
+ } else {
+ @chans = keys %channels;
+ }
+
+ my $found = 0;
+ my $op = 0;
+ foreach (@chans) {
+ next unless (&IsNickInChan($opee,$_));
+ $found++;
+ if ($channels{$_}{'o'}{$opee}) {
+ &performStrictReply("op: $opee already has ops on $_");
+ next;
+ }
+ $op++;
+
+ &performStrictReply("opping $opee on $_");
+ &op($_, $opee);
+ }
+
+ if ($found != $op) {
+ &performStrictReply("op: opped on all possible channels.");
+ } else {
+ &DEBUG("op: found => '$found'.");
+ &DEBUG("op: op => '$op'.");
+ }
+
+ return;
+ }
+
+ # deop.
+ if ($message =~ /^deop(\s+(.*))?$/i) {
+ return unless (&hasFlag('o'));
+ my ($opee) = lc $2;
+ my @chans;
+
+ if ($opee =~ / /) {
+ if ($opee =~ /^(\S+)\s+(\S+)$/) {
+ $opee = $1;
+ @chans = ($2);
+ if (!&validChan($2)) {
+ &msg($who,"error: invalid chan ($2).");
+ return;
+ }
+ } else {
+ &msg($who,"error: invalid params.");
+ return;
+ }
+ } else {
+ @chans = keys %channels;
+ }
+
+ my $found = 0;
+ my $op = 0;
+ foreach (@chans) {
+ next unless (&IsNickInChan($opee,$_));
+ $found++;
+ if (!exists $channels{$_}{'o'}{$opee}) {
+ &status("deop: $opee already has no ops on $_");
+ next;
+ }
+ $op++;
+
+ &status("deopping $opee on $_ at ${who}'s request");
+ &deop($_, $opee);
+ }
+
+ if ($found != $op) {
+ &status("deop: deopped on all possible channels.");
+ } else {
+ &DEBUG("deop: found => '$found'.");
+ &DEBUG("deop: op => '$op'.");
+ }
+
+ return;
+ }
+
+ # say.
+ if ($message =~ s/^say\s+(\S+)\s+(.*)//) {
+ return unless (&hasFlag('o'));
+ my ($chan,$msg) = (lc $1, $2);
+
+ &DEBUG("chan => '$1', msg => '$msg'.");
+
+ &msg($chan, $msg);
+
+ return;
+ }
+
+ # do.
+ if ($message =~ s/^do\s+(\S+)\s+(.*)//) {
+ return unless (&hasFlag('o'));
+ my ($chan,$msg) = (lc $1, $2);
+
+ &DEBUG("chan => '$1', msg => '$msg'.");
+
+ &action($chan, $msg);
+
+ return;
+ }
+
+ # die.
+ if ($message =~ /^die$/) {
+ return unless (&hasFlag('n'));
+
+ &doExit();
+
+ &status("Dying by $who\'s request");
+ exit 0;
+ }
+
+ # global factoid substitution.
+ if ($message =~ m|^\* =~ s([/,#])(.+?)\1(.*?)\1;?\s*$|) {
+ my ($delim,$op,$np) = ($1, $2, $3);
+ return unless (&hasFlag('n'));
+ ### TODO: support flags to do full-on global.
+
+ # incorrect format.
+ if ($np =~ /$delim/) {
+ &performReply("looks like you used the delimiter too many times. You may want to use a different delimiter, like ':' or '#'.");
+ return;
+ }
+
+ ### TODO: fix up $op to support mysql/sqlite/pgsql
+ ### TODO: => add db/sql specific function to fix this.
+ my @list = &searchTable('factoids', 'factoid_key',
+ 'factoid_value', $op);
+
+ if (!scalar @list) {
+ &performReply("Expression didn't match anything.");
+ return;
+ }
+
+ if (scalar @list > 100) {
+ &performReply("regex found more than 100 matches... not doing.");
+ return;
+ }
+
+ &status("gsubst: going to alter ".scalar(@list)." factoids.");
+ &performReply('going to alter '.scalar(@list)." factoids.");
+
+ my $error = 0;
+ foreach (@list) {
+ my $faqtoid = $_;
+
+ next if (&IsLocked($faqtoid) == 1);
+ my $result = &getFactoid($faqtoid);
+ my $was = $result;
+ &DEBUG("was($faqtoid) => '$was'.");
+
+ # global global
+ # we could support global local (once off).
+ if ($result =~ s/\Q$op/$np/gi) {
+ if (length $result > $param{'maxDataSize'}) {
+ &performReply("that's too long (or was long)");
+ return;
+ }
+ &setFactInfo($faqtoid, 'factoid_value', $result);
+ &status("update: '$faqtoid' =is=> '$result'; was '$was'");
+ } else {
+ &WARN("subst: that's weird... thought we found the string ($op) in '$faqtoid'.");
+ $error++;
+ }
+ }
+
+ if ($error) {
+ &ERROR("Some warnings/errors?");
+ }
+
+ &performReply("Ok... did s/$op/$np/ for ".
+ (scalar(@list) - $error).' factoids');
+
+ return;
+ }
+
+ # jump.
+ if ($message =~ /^jump(\s+(\S+))?$/i) {
+ return unless (&hasFlag('n'));
+
+ if ($2 eq '') {
+ &help('jump');
+ return;
+ }
+
+ my ($server,$port);
+ if ($2 =~ /^(\S+)(:(\d+))?$/) {
+ $server = $1;
+ $port = $3 || 6667;
+ } else {
+ &msg($who,"invalid format.");
+ return;
+ }
+
+ &status("jumping servers... $server...");
+ $conn->quit("jumping to $server");
+
+ if (&irc($server,$port) == 0) {
+ &ircloop();
+ }
+ }
+
+ # reload.
+ if ($message =~ /^reload$/i) {
+ return unless (&hasFlag('n'));
+
+ &status("USER reload $who");
+ &performStrictReply("reloading...");
+ &reloadAllModules();
+ &performStrictReply("reloaded.");
+
+ return;
+ }
+
+ # reset.
+ if ($message =~ /^reset$/i) {
+ return unless (&hasFlag('n'));
+
+ &msg($who,"resetting...");
+ my @done;
+ foreach ( keys %channels, keys %chanconf ) {
+ my $c = $_;
+ next if (grep /^\Q$c\E$/i, @done);
+
+ &part($_);
+
+ push(@done, $_);
+ sleep 1;
+ }
+ &DEBUG('before clearircvars');
+ &clearIRCVars();
+ &DEBUG('before joinnextchan');
+ &joinNextChan();
+ &DEBUG('after joinnextchan');
+
+ &status("USER reset $who");
+ &msg($who,'reset complete');
+
+ return;
+ }
+
+ # rehash.
+ if ($message =~ /^rehash$/) {
+ return unless (&hasFlag('n'));
+
+ &msg($who,"rehashing...");
+ &restart('REHASH');
+ &status("USER rehash $who");
+ &msg($who,'rehashed');
+
+ return;
+ }
+
+ #####
+ ##### USER//CHAN SPECIFIC CONFIGURATION COMMANDS
+ #####
+
+ if ($message =~ /^chaninfo(\s+(.*))?$/) {
+ my @args = split /[\s\t]+/, $2; # hrm.
+
+ if (scalar @args != 1) {
+ &help('chaninfo');
+ return;
+ }
+
+ if (!exists $chanconf{$args[0]}) {
+ &performStrictReply("no such channel $args[0]");
+ return;
+ }
+
+ &performStrictReply("showing channel conf.");
+ foreach (sort keys %{ $chanconf{$args[0]} }) {
+ &performStrictReply("$chan: $_ => $chanconf{$args[0]}{$_}");
+ }
+ &performStrictReply("End of chaninfo.");
+
+ return;
+ }
+
+ # +chan.
+ if ($message =~ /^(chanset|\+chan)(\s+(.*?))?$/) {
+ my $cmd = $1;
+ my $args = $3;
+ my $no_chan = 0;
+
+ if (!defined $args) {
+ &help($cmd);
+ return;
+ }
+
+ my @chans;
+ while ($args =~ s/^($mask{chan})\s*//) {
+ push(@chans, lc($1));
+ }
+
+ if (!scalar @chans) {
+ push(@chans, '_default');
+ $no_chan = 1;
+ }
+
+ my($what,$val) = split /[\s\t]+/, $args, 2;
+
+ ### TODO: "cannot set values without +m".
+ return unless (&hasFlag('n'));
+
+ # READ ONLY.
+ if (defined $what and $what !~ /^[-+]/ and !defined $val and $no_chan) {
+ &performStrictReply("Showing $what values on all channels...");
+
+ my %vals;
+ foreach (keys %chanconf) {
+ my $val;
+ if (defined $chanconf{$_}{$what}) {
+ $val = $chanconf{$_}{$what};
+ } else {
+ $val = "NOT-SET";
+ }
+ $vals{$val}{$_} = 1;
+ }
+
+ foreach (keys %vals) {
+ &performStrictReply(" $what = $_(" . scalar(keys %{$vals{$_}}) . "): ".join(' ', sort keys %{ $vals{$_} } ) );
+ }
+
+ &performStrictReply("End of list.");
+
+ return;
+ }
+
+ ### TODO: move to UserDCC again.
+ if ($cmd eq 'chanset' and !defined $what) {
+ &DEBUG("showing channel conf.");
+
+ foreach $chan (@chans) {
+ if ($chan eq '_default') {
+ &performStrictReply('Default channel settings');
+ } else {
+ &performStrictReply("chan: $chan (see _default also)");
+ }
+ my @items;
+ my $str = '';
+ foreach (sort keys %{ $chanconf{$chan} }) {
+ my $newstr = join(', ', @items);
+ ### TODO: make length use channel line limit?
+ if (length $newstr > 370) {
+ &performStrictReply(" $str");
+ @items = ();
+ }
+ $str = $newstr;
+ push(@items, "$_ => $chanconf{$chan}{$_}");
+ }
+ if (@items) {
+ my $str = join(', ', @items);
+ &performStrictReply(" $str");
+ }
+ }
+ return;
+ }
+
+ $cache{confvars}{$what} = $val;
+ &rehashConfVars();
+
+ foreach (@chans) {
+ &chanSet($cmd, $_, $what, $val);
+ }
+
+ return;
+ }
+
+ if ($message =~ /^(chanunset|\-chan)(\s+(.*))?$/) {
+ return unless (&hasFlag('n'));
+ my $args = $3;
+ my $no_chan = 0;
+
+ if (!defined $args) {
+ &help('chanunset');
+ return;
+ }
+
+ my ($chan);
+ my $delete = 0;
+ if ($args =~ s/^(\-)?($mask{chan})\s*//) {
+ $chan = $2;
+ $delete = ($1) ? 1 : 0;
+ } else {
+ &VERB("no chan arg; setting to default.",2);
+ $chan = '_default';
+ $no_chan = 1;
+ }
+
+ if (!exists $chanconf{$chan}) {
+ &performStrictReply("no such channel $chan");
+ return;
+ }
+
+ if ($args ne '') {
+
+ if (!&getChanConf($args,$chan)) {
+ &performStrictReply("$args does not exist for $chan");
+ return;
+ }
+
+ my @chans = &ChanConfList($args);
+ &DEBUG("scalar chans => ".scalar(@chans) );
+ if (scalar @chans == 1 and $chans[0] eq '_default' and !$no_chan) {
+ &performStrictReply("ok, $args was set only for _default; unsetting for _defaul but setting for other chans.");
+
+ my $val = $chanconf{$_}{_default};
+ foreach (keys %chanconf) {
+ $chanconf{$_}{$args} = $val;
+ }
+ delete $chanconf{_default}{$args};
+ $cache{confvars}{$args} = 0;
+ &rehashConfVars();
+
+ return;
+ }
+
+ if ($no_chan and !exists($chanconf{_default}{$args})) {
+ &performStrictReply("ok, $args for _default does not exist, removing from all chans.");
+
+ foreach (keys %chanconf) {
+ next unless (exists $chanconf{$_}{$args});
+ &DEBUG("delete chanconf{$_}{$args};");
+ delete $chanconf{$_}{$args};
+ }
+ $cache{confvars}{$args} = 0;
+ &rehashConfVars();
+
+ return;
+ }
+
+ &performStrictReply("Unsetting channel ($chan) option $args. (was $chanconf{$chan}{$args})");
+ delete $chanconf{$chan}{$args};
+
+ return;
+ }
+
+ if ($delete) {
+ &performStrictReply("Deleting channel $chan for sure!");
+ $utime_chanfile = time();
+ $ucount_chanfile++;
+
+ &part($chan);
+ &performStrictReply("Leaving $chan...");
+
+ delete $chanconf{$chan};
+ } else {
+ &performStrictReply("Prefix channel with '-' to delete for sure.");
+ }
+
+ return;
+ }
+
+ if ($message =~ /^newpass(\s+(.*))?$/) {
+ my(@args) = split /[\s\t]+/, $2 || '';
+
+ if (scalar @args != 1) {
+ &help('newpass');
+ return;
+ }
+
+ my $u = &getUser($who);
+ my $crypt = &mkcrypt($args[0]);
+
+ &performStrictReply("Set your passwd to '$crypt'");
+ $users{$u}{PASS} = $crypt;
+
+ $utime_userfile = time();
+ $ucount_userfile++;
+
+ return;
+ }
+
+ if ($message =~ /^chpass(\s+(.*))?$/) {
+ my(@args) = split /[\s\t]+/, $2 || '';
+
+ if (!scalar @args) {
+ &help('chpass');
+ return;
+ }
+
+ if (!&IsUser($args[0])) {
+ &performStrictReply("user $args[0] is not valid.");
+ return;
+ }
+
+ my $u = &getUser($args[0]);
+ if (!defined $u) {
+ &performStrictReply("Internal error, u = NULL.");
+ return;
+ }
+
+ if (scalar @args == 1) {
+ # del pass.
+ if (!&IsFlag('n') and $who !~ /^\Q$verifyUser\E$/i) {
+ &performStrictReply("cannot remove passwd of others.");
+ return;
+ }
+
+ if (!exists $users{$u}{PASS}) {
+ &performStrictReply("$u does not have pass set anyway.");
+ return;
+ }
+
+ &performStrictReply("Deleted pass from $u.");
+
+ $utime_userfile = time();
+ $ucount_userfile++;
+
+ delete $users{$u}{PASS};
+
+ return;
+ }
+
+ my $crypt = &mkcrypt($args[1]);
+ &performStrictReply("Set $u's passwd to '$crypt'");
+ $users{$u}{PASS} = $crypt;
+
+ $utime_userfile = time();
+ $ucount_userfile++;
+
+ return;
+ }
+
+ if ($message =~ /^chattr(\s+(.*))?$/) {
+ my(@args) = split /[\s\t]+/, $2 || '';
+
+ if (!scalar @args) {
+ &help('chattr');
+ return;
+ }
+
+ my $chflag;
+ my $user;
+ if ($args[0] =~ /^$mask{nick}$/i) {
+ # <nick>
+ $user = &getUser($args[0]);
+ $chflag = $args[1];
+ } else {
+ # <flags>
+ $user = &getUser($who);
+ &DEBUG("user $who... nope.") unless (defined $user);
+ $user = &getUser($verifyUser);
+ $chflag = $args[0];
+ }
+
+ if (!defined $user) {
+ &performStrictReply("user does not exist.");
+ return;
+ }
+
+ my $flags = $users{$user}{FLAGS};
+ if (!defined $chflag) {
+ &performStrictReply("Flags for $user: $flags");
+ return;
+ }
+
+ &DEBUG("who => $who");
+ &DEBUG("verifyUser => $verifyUser");
+ if (!&IsFlag('n') and $who !~ /^\Q$verifyUser\E$/i) {
+ &performStrictReply("cannto change attributes of others.");
+ return 'REPLY';
+ }
+
+ my $state;
+ my $change = 0;
+ foreach (split //, $chflag) {
+ if ($_ eq "+") { $state = 1; next; }
+ if ($_ eq "-") { $state = 0; next; }
+
+ if (!defined $state) {
+ &performStrictReply("no initial + or - was found in attr.");
+ return;
+ }
+
+ if ($state) {
+ next if ($flags =~ /\Q$_\E/);
+ $flags .= $_;
+ } else {
+ if (&IsParam('owner')
+ and $param{owner} =~ /^\Q$user\E$/i
+ and $flags =~ /[nmo]/
+ ) {
+ &performStrictReply("not removing flag $_ for $user.");
+ next;
+ }
+ next unless ($flags =~ s/\Q$_\E//);
+ }
+
+ $change++;
+ }
+
+ if ($change) {
+ $utime_userfile = time();
+ $ucount_userfile++;
+ #$flags.*FLAGS sort
+ $flags = join('', sort split('', $flags));
+ &performStrictReply("Current flags: $flags");
+ $users{$user}{FLAGS} = $flags;
+ } else {
+ &performStrictReply("No flags changed: $flags");
+ }
+
+ return;
+ }
+
+ if ($message =~ /^chnick(\s+(.*))?$/) {
+ my(@args) = split /[\s\t]+/, $2 || '';
+
+ if ($who eq '_default') {
+ &WARN("$who or verifyuser tried to run chnick.");
+ return 'REPLY';
+ }
+
+ if (!scalar @args or scalar @args > 2) {
+ &help('chnick');
+ return;
+ }
+
+ if (scalar @args == 1) { # 1
+ $user = &getUser($who);
+ &DEBUG("nope, not $who.") unless (defined $user);
+ $user ||= &getUser($verifyUser);
+ $chnick = $args[0];
+ } else { # 2
+ $user = &getUser($args[0]);
+ $chnick = $args[1];
+ }
+
+ if (!defined $user) {
+ &performStrictReply("user $who or $args[0] does not exist.");
+ return;
+ }
+
+ if ($user =~ /^\Q$chnick\E$/i) {
+ &performStrictReply("user == chnick. why should I do that?");
+ return;
+ }
+
+ if (&getUser($chnick)) {
+ &performStrictReply("user $chnick is already used!");
+ return;
+ }
+
+ if (!&IsFlag('n') and $who !~ /^\Q$verifyUser\E$/i) {
+ &performStrictReply("cannto change nick of others.");
+ return 'REPLY' if ($who eq '_default');
+ return;
+ }
+
+ foreach (keys %{ $users{$user} }) {
+ $users{$chnick}{$_} = $users{$user}{$_};
+ delete $users{$user}{$_};
+ }
+ undef $users{$user}; # ???
+
+ $utime_userfile = time();
+ $ucount_userfile++;
+
+ &performStrictReply("Changed '$user' to '$chnick' successfully.");
+
+ return;
+ }
+
+ if ($message =~ /^([-+])host(\s+(.*))?$/) {
+ my $cmd = $1.'host';
+ my(@args) = split /[\s\t]+/, $3 || '';
+ my $state = ($1 eq "+") ? 1 : 0;
+
+ if (!scalar @args) {
+ &help($cmd);
+ return;
+ }
+
+ if ($who eq '_default') {
+ &WARN("$who or verifyuser tried to run $cmd.");
+ return 'REPLY';
+ }
+
+ my ($user,$mask);
+ if ($args[0] =~ /^$mask{nick}$/i) { # <nick>
+ return unless (&hasFlag('n'));
+ $user = &getUser($args[0]);
+ $mask = $args[1];
+ } else { # <mask>
+ # FIXME: who or verifyUser. (don't remember why)
+ $user = &getUser($who);
+ $mask = $args[0];
+ }
+
+ if (!defined $user) {
+ &performStrictReply("user $user does not exist.");
+ return;
+ }
+
+ if (!defined $mask) {
+ &performStrictReply("Hostmasks for $user: " . join(' ', keys %{$users{$user}{HOSTS}}));
+ return;
+ }
+
+ if (!&IsFlag('n') and $who !~ /^\Q$verifyUser\E$/i) {
+ &performStrictReply("cannto change masks of others.");
+ return;
+ }
+
+ my $count = scalar keys %{ $users{$user}{HOSTS} };
+
+ if ($state) { # add.
+ if ($mask !~ /^$mask{nuh}$/) {
+ &performStrictReply("error: mask ($mask) is not a real hostmask.");
+ return;
+ }
+
+ if (exists $users{$user}{HOSTS}{$mask}) {
+ &performStrictReply("mask $mask already exists.");
+ return;
+ }
+
+ ### TODO: override support.
+ $users{$user}{HOSTS}{$mask} = 1;
+
+ &performStrictReply("Added $mask to list of masks.");
+
+ } else { # delete.
+
+ if (!exists $users{$user}{HOSTS}{$mask}) {
+ &performStrictReply("mask $mask does not exist.");
+ return;
+ }
+
+ ### TODO: wildcard support. ?
+ delete $users{$user}{HOSTS}{$mask};
+
+ if (scalar keys %{ $users{$user}{HOSTS} } != $count) {
+ &performStrictReply("Removed $mask from list of masks.");
+ } else {
+ &performStrictReply("error: could not find $mask in list of masks.");
+ return;
+ }
+ }
+
+ $utime_userfile = time();
+ $ucount_userfile++;
+
+ return;
+ }
+
+ if ($message =~ /^([-+])ban(\s+(.*))?$/) {
+ my $cmd = $1.'ban';
+ my $flatarg = $3;
+ my(@args) = split /[\s\t]+/, $3 || '';
+ my $state = ($1 eq "+") ? 1 : 0;
+
+ if (!scalar @args) {
+ &help($cmd);
+ return;
+ }
+
+ my($mask,$chan,$time,$reason);
+
+ if ($flatarg =~ s/^($mask{nuh})\s*//) {
+ $mask = $1;
+ } else {
+ &DEBUG("arg does not contain nuh mask?");
+ }
+
+ if ($flatarg =~ s/^($mask{chan})\s*//) {
+ $chan = $1;
+ } else {
+ $chan = '*'; # _default instead?
+ }
+
+ if ($state == 0) { # delete.
+ my @c = &banDel($mask);
+
+ foreach (@c) {
+ &unban($mask, $_);
+ }
+
+ if (@c) {
+ &performStrictReply("Removed $mask from chans: @c");
+ } else {
+ &performStrictReply("$mask was not found in ban list.");
+ }
+
+ return;
+ }
+
+ ###
+ # add ban.
+ ###
+
+ # time.
+ if ($flatarg =~ s/^(\d+)\s*//) {
+ $time = $1;
+ &DEBUG("time = $time.");
+ if ($time < 0) {
+ &performStrictReply("error: time cannot be negatime?");
+ return;
+ }
+ } else {
+ $time = 0;
+ }
+
+ if ($flatarg =~ s/^(.*)$//) { # need length?
+ $reason = $1;
+ }
+
+ if (!&IsFlag('n') and $who !~ /^\Q$verifyUser\E$/i) {
+ &performStrictReply("cannto change masks of others.");
+ return;
+ }
+
+ if ($mask !~ /^$mask{nuh}$/) {
+ &performStrictReply("error: mask ($mask) is not a real hostmask.");
+ return;
+ }
+
+ if ( &banAdd($mask,$chan,$time,$reason) == 2) {
+ &performStrictReply("ban already exists; overwriting.");
+ }
+ &performStrictReply("Added $mask for $chan (time => $time, reason => $reason)");
+
+ return;
+ }
+
+ if ($message =~ /^whois(\s+(.*))?$/) {
+ my $arg = $2;
+
+ if (!defined $arg) {
+ &help('whois');
+ return;
+ }
+
+ my $user = &getUser($arg);
+ if (!defined $user) {
+ &performStrictReply("whois: user $user does not exist.");
+ return;
+ }
+
+ ### TODO: better (eggdrop-like) output.
+ &performStrictReply("user: $user");
+ foreach (keys %{ $users{$user} }) {
+ my $ref = ref $users{$user}{$_};
+
+ if ($ref eq 'HASH') {
+ my $type = $_;
+ ### DOES NOT WORK???
+ foreach (keys %{ $users{$user}{$type} }) {
+ &performStrictReply(" $type => $_");
+ }
+ next;
+ }
+
+ &performStrictReply(" $_ => $users{$user}{$_}");
+ }
+ &performStrictReply("End of USER whois.");
+
+ return;
+ }
+
+ if ($message =~ /^bans(\s+(.*))?$/) {
+ my $arg = $2;
+
+ if (defined $arg) {
+ if ($arg ne '_default' and !&validChan($arg) ) {
+ &performStrictReply("error: chan $chan is invalid.");
+ return;
+ }
+ }
+
+ if (!scalar keys %bans) {
+ &performStrictReply("Ban list is empty.");
+ return;
+ }
+
+ my $c;
+ &performStrictReply(" mask: expire, time-added, count, who-by, reason");
+ foreach $c (keys %bans) {
+ next unless (!defined $arg or $arg =~ /^\Q$c\E$/i);
+ &performStrictReply(" $c:");
+
+ foreach (keys %{ $bans{$c} }) {
+ my $val = $bans{$c}{$_};
+
+ if (ref $val eq 'ARRAY') {
+ my @array = @{ $val };
+ &performStrictReply(" $_: @array");
+ } else {
+ &DEBUG("unknown ban: $val");
+ }
+ }
+ }
+ &performStrictReply("END of bans.");
+
+ return;
+ }
+
+ if ($message =~ /^banlist(\s+(.*))?$/) {
+ my $arg = $2;
+
+ if (defined $arg and $arg !~ /^$mask{chan}$/) {
+ &performStrictReply("error: chan $chan is invalid.");
+ return;
+ }
+
+ &DEBUG("bans for global or arg => $arg.");
+ foreach (keys %bans) { #CHANGE!!!
+ &DEBUG(" $_ => $bans{$_}.");
+ }
+
+ &DEBUG("End of bans.");
+ &performStrictReply("END of bans.");
+
+ return;
+ }
+
+ if ($message =~ /^save$/) {
+ return unless (&hasFlag('o'));
+
+ &writeUserFile();
+ &writeChanFile();
+ &performStrictReply('saved user and chan files');
+
+ return;
+ }
+
+ ### ALIASES.
+ $message =~ s/^addignore/+ignore/;
+ $message =~ s/^(del|un)ignore/-ignore/;
+
+ # ignore.
+ if ($message =~ /^(\+|\-)ignore(\s+(.*))?$/i) {
+ return unless (&hasFlag('o'));
+ my $state = ($1 eq "+") ? 1 : 0;
+ my $str = $1.'ignore';
+ my $args = $3;
+
+ if (!$args) {
+ &help($str);
+ return;
+ }
+
+ my($mask,$chan,$time,$comment);
+
+ # mask.
+ if ($args =~ s/^($mask{nuh})\s*//) {
+ $mask = $1;
+ } else {
+ &ERROR("no NUH mask?");
+ return;
+ }
+
+ if (!$state) { # delignore.
+ if ( &ignoreDel($mask) ) {
+ &performStrictReply("ok, deleted ignores for $mask.");
+ } else {
+ &performStrictReply("could not find $mask in ignore list.");
+ }
+ return;
+ }
+
+ ###
+ # addignore.
+ ###
+
+ # chan.
+ if ($args =~ s/^($mask{chan}|\*)\s*//) {
+ $chan = $1;
+ } else {
+ $chan = '*';
+ }
+
+ # time.
+ if ($args =~ s/^(\d+)\s*//) {
+ $time = $1; # time is in minutes
+ } else {
+ $time = 0;
+ }
+
+ # time.
+ if ($args) {
+ $comment = $args;
+ } else {
+ $comment = "added by $who";
+ }
+
+ if ( &ignoreAdd($mask, $chan, $time, $comment) > 1) {
+ &performStrictReply("FIXME: $mask already in ignore list; written over anyway.");
+ } else {
+ &performStrictReply("added $mask to ignore list.");
+ }
+
+ return;
+ }
+
+ if ($message =~ /^ignore(\s+(.*))?$/) {
+ my $arg = $2;
+
+ if (defined $arg) {
+ if ($arg !~ /^$mask{chan}$/) {
+ &performStrictReply("error: chan $chan is invalid.");
+ return;
+ }
+
+ if (!&validChan($arg)) {
+ &performStrictReply("error: chan $arg is invalid.");
+ return;
+ }
+
+ &performStrictReply("Showing bans for $arg only.");
+ }
+
+ if (!scalar keys %ignore) {
+ &performStrictReply("Ignore list is empty.");
+ return;
+ }
+
+ ### TODO: proper (eggdrop-like) formatting.
+ my $c;
+ &performStrictReply(" mask: expire, time-added, who, comment");
+ foreach $c (keys %ignore) {
+ next unless (!defined $arg or $arg =~ /^\Q$c\E$/i);
+ &performStrictReply(" $c:");
+
+ foreach (keys %{ $ignore{$c} }) {
+ my $ref = ref $ignore{$c}{$_};
+ if ($ref eq 'ARRAY') {
+ my @array = @{ $ignore{$c}{$_} };
+ &performStrictReply(" $_: @array");
+ } else {
+ &DEBUG("unknown ignore line?");
+ }
+ }
+ }
+ &performStrictReply("END of ignore.");
+
+ return;
+ }
+
+ # adduser/deluser.
+ if ($message =~ /^(add|del)user(\s+(.*))?$/i) {
+ my $str = $1;
+ my $strstr = $1.'user';
+ my @args = split /\s+/, $3 || '';
+ my $args = $3;
+ my $state = ($str =~ /^(add)$/) ? 1 : 0;
+
+ if (!scalar @args) {
+ &help($strstr);
+ return;
+ }
+
+ if ($str eq 'add') {
+ if (scalar @args != 2) {
+ &performStrictReply('adduser requires hostmask argument.');
+ return;
+ }
+ } elsif (scalar @args != 1) {
+ &performStrictReply('too many arguments.');
+ return;
+ }
+
+ if ($state) {
+ # adduser.
+ if (scalar @args == 1) {
+ $args[1] = &getHostMask($args[0]);
+ &performStrictReply("Attemping to guess $args[0]'s hostmask...");
+
+ # crude hack... crappy Net::IRC
+ $conn->schedule(5, sub {
+ # hopefully this is right.
+ my $nick = (keys %{ $cache{nuhInfo} })[0];
+ if (!defined $nick) {
+ &performStrictReply("couldn't get nuhinfo... adding user without a hostmask.");
+ &userAdd($nick);
+ return;
+ }
+ my $mask = &makeHostMask( $cache{nuhInfo}{$nick}{NUH} );
+
+ if ( &userAdd($nick, $mask) ) {
+ # success.
+ &performStrictReply("Added $nick with flags $users{$nick}{FLAGS}");
+ my @hosts = keys %{ $users{$nick}{HOSTS} };
+ &performStrictReply("hosts: @hosts");
+ }
+ });
+ return;
+ }
+
+ &DEBUG("args => @args");
+ if ( &userAdd(@args) ) { # success.
+ &performStrictReply("Added $args[0] with flags $users{$args[0]}{FLAGS}");
+ my @hosts = keys %{ $users{$args[0]}{HOSTS} };
+ &performStrictReply("hosts: @hosts");
+
+ } else { # failure.
+ &performStrictReply("User $args[0] already exists");
+ }
+
+ } else { # deluser.
+
+ if ( &userDel($args[0]) ) { # success.
+ &performStrictReply("Deleted $args[0] successfully.");
+
+ } else { # failure.
+ &performStrictReply("User $args[0] does not exist.");
+ }
+
+ }
+ return;
+ }
+
+ if ($message =~ /^sched$/) {
+ my @list;
+ my @run;
+
+ my %time;
+ foreach (keys %sched) {
+ next unless (exists $sched{$_}{TIME});
+ $time{ $sched{$_}{TIME}-time() }{$_} = 1;
+ push(@list,$_);
+
+ next unless (exists $sched{$_}{RUNNING});
+ push(@run,$_);
+ }
+
+ my @time;
+ foreach (sort { $a <=> $b } keys %time) {
+ my $str = join(', ', sort keys %{ $time{$_} });
+ &DEBUG("time => $_, str => $str");
+ push(@time, "$str (".&Time2String($_).")");
+ }
+
+ &performStrictReply( &formListReply(0, "Schedulers: ", @time ) );
+ &performStrictReply( &formListReply(0, "Scheds to run: ", sort @list ) );
+ &performStrictReply( &formListReply(0, "Scheds running(should not happen?) ", sort @run ) );
+
+ return;
+ }
+
+ # quite a cool hack: reply in DCC CHAT.
+ $msgType = 'chat' if (exists $dcc{'CHAT'}{$who});
+
+ my $done = 0;
+ $done++ if &parseCmdHook($message);
+ $done++ unless (&Modules());
+
+ if ($done) {
+ &DEBUG("running non DCC CHAT command inside DCC CHAT!");
+ return;
+ }
+
+ return 'REPLY';
+}
+
+1;
--- /dev/null
+#
+# UserInfo.pl: User Information Services
+# Author: dms
+# Version: v0.1 (20000509).
+# Created: 20000509
+# NOTE: Idea from Flugh. Originally written in tcl for eggdrop by
+# unknown.
+#
+
+use strict;
+
+my $orderOfInfo = 'RN,J,C,W,D';
+my %infoDesc = (
+ 'RN' => 'Real Name',
+ 'J' => 'Occupation',
+ 'C' => 'Contact',
+ 'W' => 'URL',
+ 'D' => 'Description',
+);
+
+sub UserInfo2Hash {
+ my ($text) = @_;
+ my %hash;
+
+ foreach (split /\|/, $text) {
+ if (/^\s*(\S+):\s*(.*)\s*$/) {
+ $hash{$1} = $2;
+ }
+ }
+
+ return %hash;
+}
+
+sub Hash2UserInfo {
+ my (%hash) = @_;
+ my @array;
+
+ foreach (sort keys %hash) {
+ push(@array, "$_: $hash{$_}");
+ }
+
+ join('|', @array);
+}
+
+###
+###
+###
+
+sub UserInfoGet {
+ my ($query) = @_;
+ $query =~ s/^\s+|\s+$//g if (defined $query);
+
+ if (!defined $query or $query =~ /^$/) {
+ &help('userinfo');
+ return;
+ }
+
+ if ($query !~ /^$mask{nick}$/) {
+ &msg($who, "Invalid query of '$query'.");
+ return;
+ }
+
+ my $result;
+ if ($result = &getFactoid($query.' info')) {
+ # good.
+ } else { # bad.
+ &performReply("No User Information on \002$query\002");
+ return;
+ }
+
+ if ($result !~ /\|/) {
+ &msg($who, "Invalid User Information for '$query'.");
+ return;
+ }
+
+ my %userInfo = &UserInfo2Hash($result);
+
+ my @reply;
+ foreach (split ',', $orderOfInfo) {
+ next unless (exists $userInfo{$_});
+ push(@reply, "$infoDesc{$_}: $userInfo{$_}");
+ }
+
+ &performStrictReply("User Information on $userInfo{'N'} -- ".
+ join(', ', @reply));
+}
+
+sub UserInfoSet {
+ my($type, $what) = @_;
+ my %userInfo;
+ my $info;
+
+ if (&IsLocked("$who info")) {
+ &DEBUG("UIS: IsLocked('$who info') == 1.");
+ return;
+ }
+
+ my $new = 0;
+ if (my $result = &getFactoid("$who info")) {
+ %userInfo = &UserInfo2Hash($result);
+ } else {
+ &DEBUG("UIS: new = 1!");
+ $userInfo{'N'} = $who;
+ $new = 1;
+ }
+
+ ### TODO: hash for %infoS2L.
+ if ($type =~ /^(RN|real\s*name)$/i) {
+ $info = 'RN';
+ } elsif ($type =~ /^(J|job|occupation|school|life)$/i) {
+ $info = 'J';
+ } elsif ($type =~ /^(C|contact|email|phone)$/i) {
+ $info = 'C';
+ } elsif ($type =~ /^(W|www|url|web\s*page|home\s*page)$/i) {
+ $info = 'W';
+ } elsif ($type =~ /^(D|desc\S+)$/i) {
+ $info = 'D';
+ } elsif ($type =~ /^(O|opt\S+)$/i) {
+ $info = 'O';
+ } else {
+ &msg($who, "Unknown type '$type'.");
+ return;
+ }
+
+ if (!defined $what) { # !defined.
+ if (exists $userInfo{$info}) {
+ &msg($who, "Current \002$infoDesc{$info}\002 is: '$userInfo{$info}'.");
+ } else {
+ &msg($who, "No current \002$infoDesc{$info}\002.");
+ }
+
+ my @remain;
+ foreach (split ',', $orderOfInfo) {
+ next if (exists $userInfo{$_});
+ push(@remain, $infoDesc{$_});
+ }
+ if (scalar @remain) {
+ ### TODO: show short-cut (identifier) aswell.
+ &msg($who, "Remaining slots to fill: ".join(' ', @remain));
+ } else {
+### &msg($who, "Personal Information completely filled. Good.");
+ }
+
+ return;
+ } elsif ($what =~ /^$/) { # defined but NULL. UNSET
+ if (exists $userInfo{$info}) {
+ &msg($who, "Unsetting \002$infoDesc{$info}\002 ($userInfo{$info}).");
+ delete $userInfo{$info};
+ } else {
+ &msg($who, "\002$infoDesc{$info}\002 is already empty!");
+ return;
+ }
+ } else { # defined.
+ if (exists $userInfo{$info}) {
+ &msg($who, "\002$infoDesc{$info}\002 was '$userInfo{$info}'.");
+ &msg($who, "Now is: '$what'.");
+ } else {
+ &msg($who, "\002$infoDesc{$info}\002 is now '$what'.");
+ }
+ $userInfo{$info} = $what;
+ }
+
+ &setFactInfo($who.' info', 'factoid_value', &Hash2UserInfo(%userInfo));
+ if ($new) {
+ &DEBUG("UIS: locking '$who info'.");
+ &DEBUG("UIS: nuh => '$nuh'.");
+ &setFactInfo("$who info", "locked_by", $nuh);
+ &setFactInfo("$who info", "locked_time", time());
+ }
+}
+
+1;
--- /dev/null
+# WWWSearch backend, with queries updating the is-db (optionally)
+# Uses WWW::Search::Google and WWW::Search
+# originally Google.pl, drastically altered.
+
+package W3Search;
+
+use strict;
+use vars qw(@W3Search_engines $W3Search_regex);
+@W3Search_engines = qw(AltaVista Dejanews Excite Gopher HotBot Infoseek
+ Lycos Magellan PLweb SFgate Simple Verity Google z);
+$W3Search_regex = join '|', @W3Search_engines;
+
+my $maxshow = 5;
+
+sub W3Search {
+ my ($where, $what, $type) = @_;
+ my $retval = "$where can't find \002$what\002";
+ my $Search;
+
+ my @matches = grep { lc($_) eq lc($where) ? $_ : undef } @W3Search_engines;
+ if (@matches) {
+ $where = shift @matches;
+ } else {
+ &::msg($::who, "i don't know how to check '$where'");
+ return;
+ }
+
+ return unless &::loadPerlModule("WWW::Search");
+
+ eval {
+ $Search = new WWW::Search($where, agent_name => 'Mozilla/4.5');
+ };
+
+ if (!defined $Search) {
+ &::msg($::who, "$where is invalid search.");
+ return;
+ }
+
+ my $Query = WWW::Search::escape_query($what);
+ $Search->native_query($Query,
+ {
+ num => 10,
+# search_debug => 2,
+# search_parse_debug => 2,
+ }
+ );
+ $Search->http_proxy($::param{'httpProxy'}) if (&::IsParam('httpProxy'));
+ #my $max = $Search->maximum_to_retrieve(10); # DOES NOT WORK.
+
+ my (@results, $count, $r);
+ $retval = "$where says \002$what\002 is at ";
+ while ($r = $Search->next_result()) {
+ my $url = $r->url();
+ $retval .= ' or ' if ($count > 0);
+ $retval .= $url;
+ last if ++$count >= $maxshow;
+ }
+
+ &::performStrictReply($retval);
+}
+
+1;
--- /dev/null
+#!/usr/bin/perl
+
+package Weather;
+
+# kevin lenzo (C) 1999 -- get the weather forcast NOAA.
+# feel free to use, copy, cut up, and modify, but if
+# you do something cool with it, let me know.
+
+# 16-SEP-99 lenzo@cs.cmu.edu switched to LWP::UA and
+# put in a timeout.
+
+my $no_weather;
+my $cache_time = 60 * 40 ; # 40 minute cache time
+my $default = 'KAGC';
+
+BEGIN {
+ $no_weather = 0;
+ eval "use LWP::UserAgent";
+ $no_weather++ if ($@);
+}
+
+sub Weather {
+ my ($args) = @_;
+ &::performStrictReply(&queryText($args, 'weather'));
+ return;
+}
+
+sub Metar {
+ my ($args) = @_;
+ &::performStrictReply(&queryText($args, 'metar'));
+ return;
+}
+
+sub queryText {
+ my ($station) = shift;
+ my ($wxmode) = shift;
+ my $result;
+
+ $station = uc($station);
+ $station =~ s/for //i;
+
+ if ($no_weather) {
+ return 0;
+ } else {
+
+ if (exists $cache{$station}) {
+ my ($time, $response) = split $; , $cache{$station};
+ if ((time() - $time) < $cache_time) {
+ return $response;
+ }
+ }
+
+ my $ua = new LWP::UserAgent;
+ $ua->proxy('http', $::param{'httpProxy'}) if (&::IsParam('httpProxy'));
+
+ $ua->timeout(10);
+ my $request = new HTTP::Request('GET', "http://weather.noaa.gov/weather/current/$station.html");
+ my $response = $ua->request($request);
+
+ if (!$response->is_success) {
+ if ($response->code == 404) {
+ return "I can't find station code \"$station\""
+ . " (see http://www.nws.noaa.gov/oso/site.shtml"
+ . " or http://www.nws.noaa.gov/tg/siteloc.shtml"
+ . " for ICAO locations codes).";
+ } else {
+ return 'Something failed in connecting to the NOAA web'
+ . " server. Try again later.";
+ }
+ }
+
+ $content = $response->content;
+ $content =~ s|.*?<BODY[^>]*>||is;
+ #$content =~ s|.*?current weather conditions.*?<BR>([^<]*?)\s*<.*?</TR>||is;
+ $content =~ s|.*?current weather conditions[^<]*(<[^>]+>\s*)+||is;
+ $content =~ s|([^<]*?)\s*<.*?</TR>||is;
+ my $place = $1;
+ chomp $place;
+
+ $content =~ s|.*?<TR>(?:\s*<[^>]+>)*\s*([^<]+)\s<.*?</TR>||is;
+ my $id = $1;
+ chomp $id;
+
+ $content =~ s|.*?conditions at.*?</TD>||is;
+
+ #$content =~ s|.*?<OPTION SELECTED>\s+([^<]+)\s<OPTION>.*?</TR>||s; # local time
+ $content =~ s|.*?<BR>\s+([^<]+?)\s*</FORM>.*?</TR>||s; # UTC
+ my $time = $1;
+ $time =~ s/-//g;
+ $time =~ s/\s+/ /g;
+
+ $content =~ s|\s(.*?)<TD COLSPAN=2>||s;
+ my $features = $1;
+
+ while ($features =~ s|.*?<TD ALIGN[^>]*>(?:\s*<[^>]+>)*\s+([^<]+?)\s+<.*?<TD>(?:\s*<[^>]+>)*\s+([^<]+?)\s<.*?/TD>||s) {
+ my ($f,$v) = ($1, $2);
+ chomp $f; chomp $v;
+ $feat{$f} = $v;
+ }
+
+ $content =~ s|.*?>(\d+\S+\s+\(\S+\)).*?</TD>||s; # max temp;
+ $max_temp = $1;
+ $content =~ s|.*?>(\d+\S+\s+\(\S+\)).*?</TD>||s;
+ $min_temp = $1;
+
+ if ($time) {
+ if ($wxmode eq 'metar' && defined($feat{'ob'})) {
+ return ('METAR ' . $place . ": " . $feat{'ob'});
+ }
+
+ $result = "$place; $id; last updated: $time";
+ foreach (sort keys %feat) {
+ next if $_ eq 'ob';
+ $result .= "; $_: $feat{$_}";
+ }
+ my $t = time();
+ $cache{$station} = join $;, $t, $result;
+ } else {
+ $result = "I can't find that station code (see http://weather.noaa.gov/weather/curcond.html for locations and codes)";
+ }
+ return $result;
+ }
+}
+
+if (0) {
+ if (-t STDIN) {
+ my $result = Weather::NOAA::get($default);
+ $result =~ s/; /\n/g;
+ print "\n$result\n\n";
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+NOAA.pl - Get the weather from a NOAA server
+
+=head1 PREREQUISITES
+
+ LWP::UserAgent
+
+=head1 PARAMETERS
+
+weather
+
+=head1 PUBLIC INTERFACE
+
+ weather [for] <station>
+
+=head1 DESCRIPTION
+
+Contacts C<weather.noaa.gov> and gets the weather report for a given
+station.
+
+=head1 AUTHORS
+
+Kevin Lenzo
--- /dev/null
+#
+# Wingate.pl: Wingate checker.
+# Author: dms
+# Version: v0.3 (20000526).
+# Created: 20000116
+# NOTE: based on wingate.pl by fooz.
+#
+
+package Wingate;
+
+use strict;
+my $select = IO::Select->new;
+
+sub Wingates {
+ my $file = "$::infobot_base_dir/$::param{'ircUser'}.wingate";
+ my @hosts;
+
+ open(IN, $file);
+ while (<IN>) {
+ chop;
+ next if (/\*$/); # wingate. or forget about it?
+ push(@hosts,$_);
+ }
+ close IN;
+
+ foreach (@_) {
+ next if (grep /^$_$/, @hosts);
+
+ &::DEBUG("W: _ => '$_'.");
+ &Wingate($_);
+ }
+}
+
+sub Wingate {
+ my ($host) = @_;
+
+ my $sock = IO::Socket::INET->new(
+ PeerAddr => $host,
+ PeerPort => 'telnet(23)',
+ Proto => 'tcp'
+### Timeout => 10, # enough :)
+ );
+
+ if (!defined $sock) {
+ &::status("Wingate: connection refused to $host");
+ return;
+ }
+
+ $sock->timeout(10);
+ $select->add($sock);
+
+ my $errors = 0;
+ my ($luser);
+ foreach $luser ($select->can_read(1)) {
+ my $buf;
+ my $len = 0;
+ if (!defined($len = sysread($luser, $buf, 512))) {
+ &::status("Wingate: connection lost to $luser/$host.");
+ $select->remove($luser);
+ close($luser);
+ next;
+ }
+
+ if ($len == 9) {
+ $len = sysread($luser, $buf, 512);
+ }
+
+ my $wingate = 0;
+ $wingate++ if ($buf =~ /^WinGate\>/);
+ $wingate++ if ($buf =~ /^Too many connected users - try again later$/);
+
+ if ($wingate) {
+ &::status("Wingate: RUNNING ON $host BY $::who.");
+
+ if (&::IsChanConf('wingateBan') > 0) {
+ &::ban("*!*\@$host", '');
+ }
+
+ my $reason = &::getChanConf('wingateKick');
+ if ($reason) {
+ &::kick($::who, '', $reason);
+ }
+
+ push(@::wingateBad, "$host\*");
+ &::wingateWriteFile();
+ } else {
+### &::DEBUG("no wingate.");
+ }
+
+ ### TODO: close telnet connection correctly!
+ $select->remove($luser);
+ close($luser);
+ }
+
+ return;
+}
+
+1;
--- /dev/null
+#
+# zippy -- infobot module for Zippy the Pinhead quotes
+# hacked up by Rich Lafferty (mendel) <rich@vax2.concordia.ca>
+#
+# Data gratuitously swiped from fortune-mod-9708, the 'fortune' program.
+#
+
+package zippy;
+
+use strict;
+
+my $no_zippy; # Can't think of any situation in which this won't work..
+
+sub zippy::get {
+ my @yows;
+ &::DEBUG('Reading zippy data');
+ while (<DATA>) {
+ chomp;
+ push @yows, $_;
+ }
+
+ if ($no_zippy) { # ..but just in case :-)
+ return "YOW! I'm an INFOBOT without ZIPPY!" if $::addressed;
+ }
+
+ srand(); # fork seems to not change rand. force it here
+ my $yow = $yows[rand(@yows)];
+
+ &::performStrictReply($yow);
+}
+
+1;
+
+=pod
+
+=head1 NAME
+
+Zippy.pl - Yow! Am I having fun yet?
+
+=head1 PREREQUISITES
+
+None.
+
+=head1 PARAMETERS
+
+zippy
+
+=head1 PUBLIC INTERFACE
+
+ [yow|be zippy]
+
+=head1 DESCRIPTION
+
+It's OBVIOUS ... The FURS never reached ISTANBUL ... You were an EXTRA
+in the REMAKE of "TOPKAPI" ... Go home to your WIFE ... She's making
+FRENCH TOAST!
+
+Zippy the Pinhead quotations
+(from various comic books and strips by Bill Griffith)
+
+=head1 AUTHORS
+
+Rich Lafferty (mendel) <rich@vax2.concordia.ca>
+
+=cut
+
+__DATA__
+A can of ASPARAGUS, 73 pigeons, some LIVE ammo, and a FROZEN DAQUIRI!!
+A dwarf is passing out somewhere in Detroit!
+A shapely CATHOLIC SCHOOLGIRL is FIDGETING inside my costume..
+A wide-eyed, innocent UNICORN, poised delicately in a MEADOW filled with LILACS, LOLLIPOPS & small CHILDREN at the HUSH of twilight??
+Actually, what I'd like is a little toy spaceship!!
+All I can think of is a platter of organic PRUNE CRISPS being trampled by an army of swarthy, Italian LOUNGE SINGERS ...
+All of a sudden, I want to THROW OVER my promising ACTING CAREER, grow a LONG BLACK BEARD and wear a BASEBALL HAT!! ... Although I don't know WHY!!
+All of life is a blur of Republicans and meat!
+All right, you degenerates! I want this place evacuated in 20 seconds!
+All this time I've been VIEWING a RUSSIAN MIDGET SODOMIZE a HOUSECAT!
+Alright, you!! Imitate a WOUNDED SEAL pleading for a PARKING SPACE!!
+Am I accompanied by a PARENT or GUARDIAN?
+Am I elected yet?
+Am I in GRADUATE SCHOOL yet?
+Am I SHOPLIFTING?
+America!! I saw it all!! Vomiting! Waving! JERRY FALWELLING into your void tube of UHF oblivion!! SAFEWAY of the mind ...
+An air of FRENCH FRIES permeates my nostrils!!
+An INK-LING? Sure -- TAKE one!! Did you BUY any COMMUNIST UNIFORMS??
+An Italian is COMBING his hair in suburban DES MOINES!
+And furthermore, my bowling average is unimpeachable!!!
+ANN JILLIAN'S HAIR makes LONI ANDERSON'S HAIR look like RICARDO MONTALBAN'S HAIR!
+Are the STEWED PRUNES still in the HAIR DRYER?
+Are we live or on tape?
+Are we on STRIKE yet?
+Are we THERE yet?
+Are we THERE yet? My MIND is a SUBMARINE!!
+Are you mentally here at Pizza Hut??
+Are you selling NYLON OIL WELLS?? If so, we can use TWO DOZEN!!
+Are you still an ALCOHOLIC?
+As President I have to go vacuum my coin collection!
+Awright, which one of you hid my PENIS ENVY?
+BARBARA STANWYCK makes me nervous!!
+Barbie says, Take quaaludes in gin and go to a disco right away!
+But Ken says, WOO-WOO!! No credit at "Mr. Liquor"!!
+BARRY ... That was the most HEART-WARMING rendition of "I DID IT MY WAY" I've ever heard!!
+Being a BALD HERO is almost as FESTIVE as a TATTOOED KNOCKWURST.
+BELA LUGOSI is my co-pilot ...
+BI-BI-BI-BI-BI-BI-BI-BI-BI-BI-BI-BI-BI-BI-BI-BI-BI-BI-BI-BI-BI-BI-BI-BI-
+... bleakness ... desolation ... plastic forks ...
+Bo Derek ruined my life!
+Boy, am I glad it's only 1971...
+Boys, you have ALL been selected to LEAVE th' PLANET in 15 minutes!!
+But they went to MARS around 1953!!
+But was he mature enough last night at the lesbian masquerade?
+Can I have an IMPULSE ITEM instead?
+Can you MAIL a BEAN CAKE?
+Catsup and Mustard all over the place! It's the Human Hamburger!
+CHUBBY CHECKER just had a CHICKEN SANDWICH in downtown DULUTH!
+Civilization is fun! Anyway, it keeps me busy!!
+Clear the laundromat!! This whirl-o-matic just had a nuclear meltdown!!
+Concentrate on th'cute, li'l CARTOON GUYS! Remember the SERIAL NUMBERS!! Follow the WHIPPLE AVE. EXIT!! Have a FREE PEPSI!! Turn LEFT at th'HOLIDAY INN!! JOIN the CREDIT WORLD!! MAKE me an OFFER!!!
+CONGRATULATIONS! Now should I make thinly veiled comments about DIGNITY, self-esteem and finding TRUE FUN in your RIGHT VENTRICLE??
+Content: 80% POLYESTER, 20% DACRONi ... The waitress's UNIFORM sheds TARTAR SAUCE like an 8" by 10" GLOSSY ...
+Could I have a drug overdose?
+Did an Italian CRANE OPERATOR just experience uninhibited sensations in a MALIBU HOT TUB?
+Did I do an INCORRECT THING??
+Did I say I was a sardine? Or a bus???
+Did I SELL OUT yet??
+Did YOU find a DIGITAL WATCH in YOUR box of VELVEETA?
+Did you move a lot of KOREAN STEAK KNIVES this trip, Dingy?
+DIDI ... is that a MARTIAN name, or, are we in ISRAEL?
+Didn't I buy a 1951 Packard from you last March in Cairo?
+Disco oil bussing will create a throbbing naugahide pipeline running straight to the tropics from the rug producing regions and devalue the dollar!
+Do I have a lifestyle yet?
+Do you guys know we just passed thru a BLACK HOLE in space?
+Do you have exactly what I want in a plaid poindexter bar bat??
+Do you like "TENDER VITTLES"?
+Do you think the "Monkees" should get gas on odd or even days?
+Does someone from PEORIA have a SHORTER ATTENTION span than me? does your DRESSING ROOM have enough ASPARAGUS?
+DON'T go!! I'm not HOWARD COSELL!! I know POLISH JOKES ... WAIT!!
+Don't go!! I AM Howard Cosell! ... And I DON'T know Polish jokes!!
+Don't hit me!! I'm in the Twilight Zone!!!
+Don't SANFORIZE me!!
+Don't worry, nobody really LISTENS to lectures in MOSCOW, either! ... FRENCH, HISTORY, ADVANCED CALCULUS, COMPUTER PROGRAMMING, BLACK STUDIES, SOCIOBIOLOGY! ... Are there any QUESTIONS??
+Edwin Meese made me wear CORDOVANS!!
+Eisenhower!! Your mimeograph machine upsets my stomach!!
+Either CONFESS now or we go to "PEOPLE'S COURT"!!
+Everybody gets free BORSCHT!
+Everybody is going somewhere!! It's probably a garage sale or a disaster Movie!!
+Everywhere I look I see NEGATIVITY and ASPHALT ...
+Excuse me, but didn't I tell you there's NO HOPE for the survival of OFFSET PRINTING? FEELINGS are cascading over me!!!
+Finally, Zippy drives his 1958 RAMBLER METROPOLITAN into the faculty dining room.
+First, I'm going to give you all the ANSWERS to today's test ... So just plug in your SONY WALKMANS and relax!!
+FOOLED you! Absorb EGO SHATTERING impulse rays, polyester poltroon!! for ARTIFICIAL FLAVORING!!
+Four thousand different MAGNATES, MOGULS & NABOBS are romping in my gothic solarium!!
+FROZEN ENTREES may be flung by members of opposing SWANSON SECTS ...
+FUN is never having to say you're SUSHI!!
+Gee, I feel kind of LIGHT in the head now, knowing I can't make my satellite dish PAYMENTS!
+Gibble, Gobble, we ACCEPT YOU ...
+Give them RADAR-GUIDED SKEE-BALL LANES and VELVEETA BURRITOS!!
+Go on, EMOTE! I was RAISED on thought balloons!!
+GOOD-NIGHT, everybody ... Now I have to go administer FIRST-AID to my pet LEISURE SUIT!!
+HAIR TONICS, please!!
+Half a mind is a terrible thing to waste!
+Hand me a pair of leather pants and a CASIO keyboard -- I'm living for today!
+Has everybody got HALVAH spread all over their ANKLES?? ... Now, it's time to "HAVE A NAGEELA"!! ... he dominates the DECADENT SUBWAY SCENE.
+He is the MELBA-BEING ... the ANGEL CAKE ... XEROX him ... XEROX him -- He probably just wants to take over my CELLS and then EXPLODE inside me like a BARREL of runny CHOPPED LIVER! Or maybe he'd like to PSYCHOLIGICALLY TERRORISE ME until I have no objection to a RIGHT-WING MILITARY TAKEOVER of my apartment!! I guess I should call AL PACINO!
+HELLO KITTY gang terrorizes town, family STICKERED to death!
+HELLO, everybody, I'm a HUMAN!!
+Hello, GORRY-O!! I'm a GENIUS from HARVARD!!
+Hello. I know the divorce rate among unmarried Catholic Alaskan females!!
+Hello. Just walk along and try NOT to think about your INTESTINES being almost FORTY YARDS LONG!!
+Hello... IRON CURTAIN? Send over a SAUSAGE PIZZA! World War III? No thanks!
+Hello? Enema Bondage? I'm calling because I want to be happy, I guess ...
+Here I am at the flea market but nobody is buying my urine sample bottles ...
+Here I am in 53 B.C. and all I want is a dill pickle!!
+Here I am in the POSTERIOR OLFACTORY LOBULE but I don't see CARL SAGAN anywhere!!
+Here we are in America ... when do we collect unemployment?
+Hey, wait a minute!! I want a divorce!! ... you're not Clint Eastwood!!
+Hey, waiter! I want a NEW SHIRT and a PONY TAIL with lemon sauce!
+Hiccuping & trembling into the WASTE DUMPS of New Jersey like some drunken CABBAGE PATCH DOLL, coughing in line at FIORUCCI'S!!
+Hmmm ... a CRIPPLED ACCOUNTANT with a FALAFEL sandwich is HIT by a TROLLEY-CAR ...
+Hmmm ... A hash-singer and a cross-eyed guy were SLEEPING on a deserted island, when ...
+Hmmm ... a PINHEAD, during an EARTHQUAKE, encounters an ALL-MIDGET FIDDLE ORCHESTRA ... ha ... ha ...
+Hmmm ... an arrogant bouquet with a subtle suggestion of POLYVINYL CHLORIDE ...
+Hold the MAYO & pass the COSMIC AWARENESS ...
+HOORAY, Ronald!! Now YOU can marry LINDA RONSTADT too!!
+How do I get HOME?
+How do you explain Wayne Newton's POWER over millions? It's th' MOUSTACHE ... Have you ever noticed th' way it radiates SINCERITY, HONESTY & WARMTH?
+It's a MOUSTACHE you want to take HOME and introduce to NANCY SINATRA!
+How many retured bricklayers from FLORIDA are out purchasing PENCIL
+SHARPENERS right NOW??
+How's it going in those MODULAR LOVE UNITS??
+How's the wife? Is she at home enjoying capitalism?
+hubub, hubub, HUBUB, hubub, hubub, hubub, HUBUB, hubub, hubub, hubub.
+HUGH BEAUMONT died in 1982!!
+HUMAN REPLICAS are inserted into VATS of NUTRITIONAL YEAST ...
+I always have fun because I'm out of my mind!!!
+I am a jelly donut. I am a jelly donut.
+I am a traffic light, and Alan Ginzberg kidnapped my laundry in 1927!
+I am covered with pure vegetable oil and I am writing a best seller!
+I am deeply CONCERNED and I want something GOOD for BREAKFAST!
+I am having FUN... I wonder if it's NET FUN or GROSS FUN?
+I am NOT a nut....
+I appoint you ambassador to Fantasy Island!!!
+I brought my BOWLING BALL -- and some DRUGS!!
+I can't decide which WRONG TURN to make first!! I wonder if BOB GUCCIONE has these problems!
+I can't think about that. It doesn't go with HEDGES in the shape of LITTLE LULU -- or ROBOTS making BRICKS ...
+I demand IMPUNITY!
+I didn't order any WOO-WOO ... Maybe a YUBBA ... But no WOO-WOO!
+I don't believe there really IS a GAS SHORTAGE.. I think it's all just a BIG HOAX on the part of the plastic sign salesmen -- to sell more numbers!!
+... I don't know why but, suddenly, I want to discuss declining I.Q. LEVELS with a blue ribbon SENATE SUB-COMMITTEE!
+I don't know WHY I said that ... I think it came from the FILLINGS in my read molars ...
+... I don't like FRANK SINATRA or his CHILDREN. I don't understand the HUMOUR of the THREE STOOGES!!
+I feel ... JUGULAR ...
+I feel better about world problems now!
+I feel like a wet parking meter on Darvon!
+I feel like I am sharing a ``CORN-DOG'' with NIKITA KHRUSCHEV ...
+I feel like I'm in a Toilet Bowl with a thumbtack in my forehead!!
+I feel partially hydrogenated!
+I fill MY industrial waste containers with old copies of the "WATCHTOWER" and then add HAWAIIAN PUNCH to the top ... They look NICE in the yard ...
+I guess it was all a DREAM ... or an episode of HAWAII FIVE-O ...
+I guess you guys got BIG MUSCLES from doing too much STUDYING!
+I had a lease on an OEDIPUS COMPLEX back in '81 ...
+I had pancake makeup for brunch!
+I have a TINY BOWL in my HEAD
+I have a very good DENTAL PLAN. Thank you.
+I have a VISION! It's a RANCID double-FISHWICH on an ENRICHED BUN!!
+I have accepted Provolone into my life!
+I have many CHARTS and DIAGRAMS..
+... I have read the INSTRUCTIONS ...
+-- I have seen the FUN --
+I have seen these EGG EXTENDERS in my Supermarket ... I have read the INSTRUCTIONS ...
+I have the power to HALT PRODUCTION on all TEENAGE SEX COMEDIES!!
+I HAVE to buy a new "DODGE MISER" and two dozen JORDACHE JEANS because my viewscreen is "USER-FRIENDLY"!!
+I haven't been married in over six years, but we had sexual counseling every day from Oral Roberts!!
+I hope I bought the right relish ... zzzzzzzzz ...
+I hope something GOOD came in the mail today so I have a REASON to live!!
+I hope the ``Eurythmics'' practice birth control ...
+I hope you millionaires are having fun! I just invested half your life savings in yeast!!
+I invented skydiving in 1989!
+I joined scientology at a garage sale!!
+I just forgot my whole philosophy of life!!!
+I just got my PRINCE bumper sticker ... But now I can't remember WHO he is ...
+I just had a NOSE JOB!!
+I just had my entire INTESTINAL TRACT coated with TEFLON!
+I just heard the SEVENTIES were over!! And I was just getting in touch with my LEISURE SUIT!!
+I just remembered something about a TOAD!
+I KAISER ROLL?! What good is a Kaiser Roll without a little COLE SLAW on the SIDE?
+I Know A Joke!!
+I know how to do SPECIAL EFFECTS!!
+I know th'MAMBO!! I have a TWO-TONE CHEMISTRY SET!!
+I know things about TROY DONAHUE that can't even be PRINTED!!
+I left my WALLET in the BATHROOM!!
+I like the way ONLY their mouths move ... They look like DYING OYSTERS
+I like your SNOOPY POSTER!!
+-- I love KATRINKA because she drives a PONTIAC. We're going away now. I fed the cat.
+I love ROCK 'N ROLL! I memorized the all WORDS to "WIPE-OUT" in 1965!!
+I need to discuss BUY-BACK PROVISIONS with at least six studio SLEAZEBALLS!!
+I once decorated my apartment entirely in ten foot salad forks!!
+I own seven-eighths of all the artists in downtown Burbank!
+I put aside my copy of "BOWLING WORLD" and think about GUN CONTROL legislation...
+I represent a sardine!!
+I request a weekend in Havana with Phil Silvers!
+... I see TOILET SEATS ...
+I selected E5 ... but I didn't hear "Sam the Sham and the Pharoahs"!
+I smell a RANCID CORN DOG!
+I smell like a wet reducing clinic on Columbus Day!
+I think I am an overnight sensation right now!!
+... I think I'd better go back to my DESK and toy with a few common MISAPPREHENSIONS ...
+I think I'll KILL myself by leaping out of this 14th STORY WINDOW while reading ERICA JONG'S poetry!!
+I think my career is ruined!
+I used to be a FUNDAMENTALIST, but then I heard about the HIGH RADIATION LEVELS and bought an ENCYCLOPEDIA!!
+... I want a COLOR T.V. and a VIBRATING BED!!!
+I want a VEGETARIAN BURRITO to go ... with EXTRA MSG!!
+I want a WESSON OIL lease!!
+I want another RE-WRITE on my CEASAR SALAD!!
+I want EARS! I want two ROUND BLACK EARS to make me feel warm 'n secure!!
+... I want FORTY-TWO TRYNEL FLOATATION SYSTEMS installed within SIX AND A HALF HOURS!!!
+I want the presidency so bad I can already taste the hors d'oeuvres.
+I want to dress you up as TALLULAH BANKHEAD and cover you with VASELINE and WHEAT THINS ...
+I want to kill everyone here with a cute colorful Hydrogen Bomb!!
+... I want to perform cranial activities with Tuesday Weld!!
+I want to read my new poem about pork brains and outer space ...
+I want to so HAPPY, the VEINS in my neck STAND OUT!!
+I want you to MEMORIZE the collected poems of EDNA ST VINCENT MILLAY ... BACKWARDS!!
+I want you to organize my PASTRY trays ... my TEA-TINS are gleaming in formation like a ROW of DRUM MAJORETTES -- please don't be FURIOUS with me --
+I was born in a Hostess Cupcake factory before the sexual revolution!
+I was making donuts and now I'm on a bus!
+I wish I was a sex-starved manicurist found dead in the Bronx!!
+I wish I was on a Cincinnati street corner holding a clean dog!
+I wonder if I could ever get started in the credit world?
+I wonder if I ought to tell them about my PREVIOUS LIFE as a COMPLETE STRANGER?
+I wonder if I should put myself in ESCROW!!
+I wonder if there's anything GOOD on tonight?
+I would like to urinate in an OVULAR, porcelain pool --
+I'd like MY data-base JULIENNED and stir-fried!
+I'd like some JUNK FOOD ... and then I want to be ALONE --
+I'll eat ANYTHING that's BRIGHT BLUE!!
+I'll show you MY telex number if you show me YOURS ...
+I'm a fuschia bowling ball somewhere in Brittany
+I'm a GENIUS! I want to dispute sentence structure with SUSAN SONTAG!!
+I'm a nuclear submarine under the polar ice cap and I need a Kleenex!
+I'm also against BODY-SURFING!!
+I'm also pre-POURED pre-MEDITATED and pre-RAPHAELITE!!
+I'm ANN LANDERS!! I can SHOPLIFT!!
+I'm changing the CHANNEL ... But all I get is commercials for "RONCO MIRACLE BAMBOO STEAMERS"!
+I'm continually AMAZED at th'breathtaking effects of WIND EROSION!!
+I'm definitely not in Omaha!
+I'm DESPONDENT ... I hope there's something DEEP-FRIED under this miniature DOMED STADIUM ...
+I'm dressing up in an ill-fitting IVY-LEAGUE SUIT!! Too late...
+I'm EMOTIONAL now because I have MERCHANDISING CLOUT!!
+I'm encased in the lining of a pure pork sausage!!
+I'm GLAD I remembered to XEROX all my UNDERSHIRTS!!
+I'm gliding over a NUCLEAR WASTE DUMP near ATLANTA, Georgia!!
+I'm having a BIG BANG THEORY!!
+I'm having a MID-WEEK CRISIS!
+I'm having a RELIGIOUS EXPERIENCE ... and I don't take any DRUGS
+I'm having a tax-deductible experience! I need an energy crunch!!
+I'm having an emotional outburst!!
+I'm having an EMOTIONAL OUTBURST!! But, uh, WHY is there a WAFFLE in my PAJAMA POCKET??
+I'm having BEAUTIFUL THOUGHTS about the INSIPID WIVES of smug and wealthy CORPORATE LAWYERS ...
+I'm having fun HITCHHIKING to CINCINNATI or FAR ROCKAWAY!! ...
+I'm IMAGINING a sensuous GIRAFFE, CAVORTING in the BACK ROOM of a KOSHER DELI
+I'm in direct contact with many advanced fun CONCEPTS.
+I'm into SOFTWARE!
+I'm meditating on the FORMALDEHYDE and the ASBESTOS leaking into my PERSONAL SPACE!!
+I'm mentally OVERDRAWN! What's that SIGNPOST up ahead? Where's ROD STERLING when you really need him?
+I'm not an Iranian!! I voted for Dianne Feinstein!!
+I'm not available for comment..
+I'm pretending I'm pulling in a TROUT! Am I doing it correctly??
+I'm pretending that we're all watching PHIL SILVERS instead of RICARDO MONTALBAN!
+I'm QUIETLY reading the latest issue of "BOWLING WORLD" while my wife and two children stand QUIETLY BY ...
+I'm rated PG-34!!
+I'm receiving a coded message from EUBIE BLAKE!!
+I'm RELIGIOUS!! I love a man with a HAIRPIECE!! Equip me with MISSILES!!
+I'm reporting for duty as a modern person. I want to do the Latin Hustle now!
+I'm shaving!! I'M SHAVING!!
+I'm sitting on my SPEED QUEEN ... To me, it's ENJOYABLE ... I'm WARM ... I'm VIBRATORY ...
+I'm thinking about DIGITAL READ-OUT systems and computer-generated IMAGE FORMATIONS ...
+I'm totally DESPONDENT over the LIBYAN situation and the price of CHICKEN ...
+I'm using my X-RAY VISION to obtain a rare glimpse of the INNER WORKINGS of this POTATO!!
+I'm wearing PAMPERS!!
+I'm wet! I'm wild!
+I'm young ... I'm HEALTHY ... I can HIKE THRU CAPT GROGAN'S LUMBAR REGIONS!
+I'm ZIPPY the PINHEAD and I'm totally committed to the festive mode.
+I've got a COUSIN who works in the GARMENT DISTRICT ...
+I've got an IDEA!! Why don't I STARE at you so HARD, you forget your SOCIAL SECURITY NUMBER!!
+I've read SEVEN MILLION books!! ... ich bin in einem dusenjet ins jahr 53 vor chr ... ich lande im antiken Rom ... einige gladiatoren spielen scrabble ... ich rieche PIZZA ...
+If a person is FAMOUS in this country, they have to go on the ROAD for MONTHS at a time and have their name misspelled on the SIDE of a GREYHOUND SCENICRUISER!!
+If elected, Zippy pledges to each and every American a 55-year-old houseboy ...
+If I am elected no one will ever have to do their laundry again!
+If I am elected, the concrete barriers around the WHITE HOUSE will be replaced by tasteful foam replicas of ANN MARGARET!
+If I felt any more SOPHISTICATED I would DIE of EMBARRASSMENT!
+If I had a Q-TIP, I could prevent th' collapse of NEGOTIATIONS!! ... If I had heart failure right now, I couldn't be a more fortunate man!!
+If I pull this SWITCH I'll be RITA HAYWORTH!! Or a SCIENTOLOGIST!
+if it GLISTENS, gobble it!!
+If our behavior is strict, we do not need fun!
+If Robert Di Niro assassinates Walter Slezak, will Jodie Foster marry Bonzo??
+In 1962, you could buy a pair of SHARKSKIN SLACKS, with a "Continental Belt," for $10.99!!
+In Newark the laundromats are open 24 hours a day!
+INSIDE, I have the same personality disorder as LUCY RICARDO!!
+Inside, I'm already SOBBING!
+Is a tattoo real, like a curb or a battleship? Or are we suffering in Safeway?
+Is he the MAGIC INCA carrying a FROG on his shoulders?? Is the FROG his GUIDELIGHT?? It is curious that a DOG runs already on the ESCALATOR ...
+Is it 1974? What's for SUPPER? Can I spend my COLLEGE FUND in one wild afternoon??
+Is it clean in other dimensions?
+Is it NOUVELLE CUISINE when 3 olives are struggling with a scallop in a plate of SAUCE MORNAY?
+Is something VIOLENT going to happen to a GARBAGE CAN?
+Is this an out-take from the "BRADY BUNCH"?
+Is this going to involve RAW human ecstasy?
+Is this TERMINAL fun?
+Is this the line for the latest whimsical YUGOSLAVIAN drama which also makes you want to CRY and reconsider the VIETNAM WAR?
+Isn't this my STOP?!
+It don't mean a THING if you ain't got that SWING!!
+It was a JOKE!! Get it?? I was receiving messages from DAVID LETTERMAN!! YOW!!
+It's a lot of fun being alive ... I wonder if my bed is made?!?
+It's NO USE ... I've gone to "CLUB MED"!!
+It's OBVIOUS ... The FURS never reached ISTANBUL ... You were an EXTRA in the REMAKE of "TOPKAPI" ... Go home to your WIFE ... She's making FRENCH TOAST!
+It's OKAY -- I'm an INTELLECTUAL, too.
+It's the RINSE CYCLE!! They've ALL IGNORED the RINSE CYCLE!!
+JAPAN is a WONDERFUL planet -- I wonder if we'll ever reach their level of COMPARATIVE SHOPPING ...
+Jesuit priests are DATING CAREER DIPLOMATS!!
+Jesus is my POSTMASTER GENERAL ...
+Kids, don't gross me off ... "Adventures with MENTAL HYGIENE" can be carried too FAR!
+Kids, the seven basic food groups are GUM, PUFF PASTRY, PIZZA, PESTICIDES, ANTIBIOTICS, NUTRA-SWEET and MILK DUDS!!
+Laundry is the fifth dimension!! ... um ... um ... th' washing machine is a black hole and the pink socks are bus drivers who just fell in!!
+LBJ, LBJ, how many JOKES did you tell today??!
+Leona, I want to CONFESS things to you ... I want to WRAP you in a SCARLET ROBE trimmed with POLYVINYL CHLORIDE ... I want to EMPTY your ASHTRAYS ...
+Let me do my TRIBUTE to FISHNET STOCKINGS ...
+Let's all show human CONCERN for REVERAND MOON's legal difficulties!!
+Let's send the Russians defective lifestyle accessories!
+Life is a POPULARITY CONTEST! I'm REFRESHINGLY CANDID!!
+Like I always say -- nothing can beat the BRATWURST here in DUSSELDORF!!
+Loni Anderson's hair should be LEGALIZED!!
+Look DEEP into the OPENINGS!! Do you see any ELVES or EDSELS ... or a HIGHBALL?? ...
+Look into my eyes and try to forget that you have a Macy's charge card!
+Look! A ladder! Maybe it leads to heaven, or a sandwich!
+LOOK!! Sullen American teens wearing MADRAS shorts and "Flock of Seagulls" HAIRCUTS!
+Make me look like LINDA RONSTADT again!!
+Mary Tyler Moore's SEVENTH HUSBAND is wearing my DACRON TANK TOP in a cheap hotel in HONOLULU!
+Maybe we could paint GOLDIE HAWN a rich PRUSSIAN BLUE --
+MERYL STREEP is my obstetrician!
+MMM-MM!! So THIS is BIO-NEBULATION!
+Mmmmmm-MMMMMM!! A plate of STEAMING PIECES of a PIG mixed with the shreds of SEVERAL CHICKENS!! ... Oh BOY!! I'm about to swallow a TORN-OFF section of a COW'S LEFT LEG soaked in COTTONSEED OIL and SUGAR!! ... Let's see ... Next, I'll have the GROUND-UP flesh of CUTE, BABY LAMBS fried in the MELTED, FATTY TISSUES from a warm-blooded animal someone once PETTED!! ... YUM!! That was GOOD!! For DESSERT, I'll have a TOFU BURGER with BEAN SPROUTS on a stone-ground, WHOLE WHEAT BUN!!
+Mr and Mrs PED, can I borrow 26.7% of the RAYON TEXTILE production of the INDONESIAN archipelago?
+My Aunt MAUREEN was a military advisor to IKE & TINA TURNER!!
+My BIOLOGICAL ALARM CLOCK just went off ... It has noiseless DOZE FUNCTION and full kitchen!!
+My CODE of ETHICS is vacationing at famed SCHROON LAKE in upstate New York!!
+My EARS are GONE!!
+My face is new, my license is expired, and I'm under a doctor's care!!!!
+My haircut is totally traditional!
+MY income is ALL disposable!
+My LESLIE GORE record is BROKEN ...
+My life is a patio of fun!
+My mind is a potato field ...
+My mind is making ashtrays in Dayton ...
+My nose feels like a bad Ronald Reagan movie ...
+My NOSE is NUMB!
+... My pants just went on a wild rampage through a Long Island Bowling Alley!!
+My pants just went to high school in the Carlsbad Caverns!!!
+My polyvinyl cowboy wallet was made in Hong Kong by Montgomery Clift!
+My uncle Murray conquered Egypt in 53 B.C. And I can prove it too!!
+My vaseline is RUNNING...
+NANCY!! Why is everything RED?!
+NATHAN ... your PARENTS were in a CARCRASH!! They're VOIDED -- They COLLAPSED They had no CHAINSAWS ... They had no MONEY MACHINES ... They did PILLS in SKIMPY GRASS SKIRTS ... Nathan, I EMULATED them ... but they were OFF-KEY ...
+NEWARK has been REZONED!! DES MOINES has been REZONED!!
+Nipples, dimples, knuckles, NICKLES, wrinkles, pimples!!
+Not SENSUOUS ... only "FROLICSOME" ... and in need of DENTAL WORK ... in PAIN!!!
+Now I am depressed ...
+Now I think I just reached the state of HYPERTENSION that comes JUST BEFORE you see the TOTAL at the SAFEWAY CHECKOUT COUNTER!
+Now I understand the meaning of "THE MOD SQUAD"!
+Now I'm being INVOLUNTARILY shuffled closer to the CLAM DIP with the BROKEN PLASTIC FORKS in it!!
+Now I'm concentrating on a specific tank battle toward the end of World War II!
+Now I'm having INSIPID THOUGHTS about the beatiful, round wives of HOLLYWOOD MOVIE MOGULS encased in PLEXIGLASS CARS and being approached by SMALL BOYS selling FRUIT ...
+Now KEN and BARBIE are PERMANENTLY ADDICTED to MIND-ALTERING DRUGS ...
+Now my EMOTIONAL RESOURCES are heavily committed to 23% of the SMELTING and REFINING industry of the state of NEVADA!!
+Now that I have my "APPLE", I comprehend COST ACCOUNTING!!
+Now, let's SEND OUT for QUICHE!!
+Of course, you UNDERSTAND about the PLAIDS in the SPIN CYCLE --
+Oh my GOD -- the SUN just fell into YANKEE STADIUM!!
+Oh, I get it!! "The BEACH goes on", huh, SONNY??
+Okay ... I'm going home to write the "I HATE RUBIK's CUBE HANDBOOK FOR DEAD CAT LOVERS" ...
+OKAY!! Turn on the sound ONLY for TRYNEL CARPETING, FULLY-EQUIPPED R.V.'S and FLOATATION SYSTEMS!!
+OMNIVERSAL AWARENESS?? Oh, YEH!! First you need four GALLONS of JELL-O and a BIG WRENCH!! ... I think you drop th'WRENCH in the JELL-O as if it was a FLAVOR, or an INGREDIENT ... ... or ... I ... um ... WHERE'S the WASHING MACHINES?
+On SECOND thought, maybe I'll heat up some BAKED BEANS and watch REGIS PHILBIN ... It's GREAT to be ALIVE!!
+On the other hand, life can be an endless parade of TRANSSEXUAL
+QUILTING BEES aboard a cruise ship to DISNEYWORLD if only we let it!!
+On the road, ZIPPY is a pinhead without a purpose, but never without a POINT.
+Once upon a time, four AMPHIBIOUS HOG CALLERS attacked a family of DEFENSELESS, SENSITIVE COIN COLLECTORS and brought DOWN their PROPERTY VALUES!!
+Once, there was NO fun ... This was before MENU planning, FASHION statements or NAUTILUS equipment ... Then, in 1985 ... FUN was completely encoded in this tiny MICROCHIP ... It contain 14,768 vaguely amusing SIT-COM pilots!! We had to wait FOUR BILLION years but we finally got JERRY LEWIS, MTV and a large selection of creme-filled snack cakes!
+One FISHWICH coming up!!
+ONE LIFE TO LIVE for ALL MY CHILDREN in ANOTHER WORLD all THE DAYS OF OUR LIVES.
+ONE: I will donate my entire "BABY HUEY" comic book collection to the downtown PLASMA CENTER ... TWO: I won't START a BAND called "KHADAFY & THE HIT SQUAD" ... THREE: I won't ever TUMBLE DRY my FOX TERRIER again!!
+... or were you driving the PONTIAC that HONKED at me in MIAMI last Tuesday?
+Our father who art in heaven ... I sincerely pray that SOMEBODY at this table will PAY for my SHREDDED WHAT and ENGLISH MUFFIN ... and also leave a GENEROUS TIP ....
+over in west Philadelphia a puppy is vomiting ...
+OVER the underpass! UNDER the overpass! Around the FUTURE and BEYOND REPAIR!!
+PARDON me, am I speaking ENGLISH?
+Pardon me, but do you know what it means to be TRULY ONE with your BOOTH!
+PEGGY FLEMMING is stealing BASKET BALLS to feed the babies in VERMONT.
+People humiliating a salami!
+PIZZA!!
+Place me on a BUFFER counter while you BELITTLE several BELLHOPS in the Trianon Room!! Let me one of your SUBSIDIARIES!
+Please come home with me ... I have Tylenol!!
+Psychoanalysis?? I thought this was a nude rap session!!!
+PUNK ROCK!! DISCO DUCK!! BIRTH CONTROL!!
+Quick, sing me the BUDAPEST NATIONAL ANTHEM!!
+RELATIVES!!
+Remember, in 2039, MOUSSE & PASTA will be available ONLY by prescription!!
+RHAPSODY in Glue!
+SANTA CLAUS comes down a FIRE ESCAPE wearing bright blue LEG WARMERS ... He scrubs the POPE with a mild soap or detergent for 15 minutes, starring JANE FONDA!!
+Send your questions to ``ASK ZIPPY'', Box 40474, San Francisco, CA 94140, USA
+SHHHH!! I hear SIX TATTOOED TRUCK-DRIVERS tossing ENGINE BLOCKS into empty OIL DRUMS ...
+Should I do my BOBBIE VINTON medley?
+Should I get locked in the PRINCICAL'S OFFICE today -- or have a VASECTOMY??
+Should I start with the time I SWITCHED personalities with a BEATNIK hair stylist or my failure to refer five TEENAGERS to a good OCULIST? Sign my PETITION.
+So this is what it feels like to be potato salad
+So, if we convert SUPPLY-SIDE SOYABEAN FUTURES into HIGH-YIELD T-BILL INDICATORS, the PRE-INFLATIONARY risks will DWINDLE to a rate of 2 SHOPPING SPREES per EGGPLANT!!
+Someone in DAYTON, Ohio is selling USED CARPETS to a SERBO-CROATIAN
+Sometime in 1993 NANCY SINATRA will lead a BLOODLESS COUP on GUAM!!
+Somewhere in DOWNTOWN BURBANK a prostitute is OVERCOOKING a LAMB CHOP!!
+Somewhere in suburban Honolulu, an unemployed bellhop is whipping up a batch of illegal psilocybin chop suey!!
+Somewhere in Tenafly, New Jersey, a chiropractor is viewing "Leave it to Beaver"!
+Spreading peanut butter reminds me of opera!! I wonder why?
+TAILFINS!! ... click ...
+Talking Pinhead Blues: Oh, I LOST my ``HELLO KITTY'' DOLL and I get BAD reception on channel TWENTY-SIX!! Th'HOSTESS FACTORY is closin' down and I just heard ZASU PITTS has been DEAD for YEARS.. (sniff) My PLATFORM SHOE collection was CHEWED up by th' dog, ALEXANDER HAIG won't let me take a SHOWER 'til Easter ... (snurf) So I went to the kitchen, but WALNUT PANELING whup me upside mah HAID!! (on no, no, no.. Heh, heh)
+TAPPING? You POLITICIANS! Don't you realize that the END of the "Wash Cycle" is a TREASURED MOMENT for most people?!
+Tex SEX! The HOME of WHEELS! The dripping of COFFEE!! Take me to Minnesota but don't EMBARRASS me!!
+Th' MIND is the Pizza Palace of th' SOUL
+Thank god!! ... It's HENNY YOUNGMAN!!
+The appreciation of the average visual graphisticator alone is worth
+the whole suaveness and decadence which abounds!!
+The entire CHINESE WOMEN'S VOLLEYBALL TEAM all share ONE personality -- and have since BIRTH!!
+The fact that 47 PEOPLE are yelling and sweat is cascading down my SPINAL COLUMN is fairly enjoyable!!
+The FALAFEL SANDWICH lands on my HEAD and I become a VEGETARIAN ...
+... the HIGHWAY is made out of LIME JELLO and my HONDA is a barbequeued OYSTER! Yum!
+The Korean War must have been fun. ... the MYSTERIANS are in here with my CORDUROY SOAP DISH!!
+The Osmonds! You are all Osmonds!! Throwing up on a freeway at dawn!!!
+The PILLSBURY DOUGHBOY is CRYING for an END to BURT REYNOLDS movies!!
+The PINK SOCKS were ORIGINALLY from 1952!! But they went to MARS around 1953!!
+The SAME WAVE keeps coming in and COLLAPSING like a rayon MUU-MUU ...
+There is no TRUTH. There is no REALITY. There is no CONSISTENCY.
+There are no ABSOLUTE STATEMENTS. I'm very probably wrong.
+There's a little picture of ED MCMAHON doing BAD THINGS to JOAN RIVERS in a $200,000 MALIBU BEACH HOUSE!!
+There's enough money here to buy 5000 cans of Noodle-Roni! "These are DARK TIMES for all mankind's HIGHEST VALUES!" "These are DARK TIMES for FREEDOM and PROSPERITY!" "These are GREAT TIMES to put your money on BAD GUY to kick the CRAP out of MEGATON MAN!"
+These PRESERVES should be FORCE-FED to PENTAGON OFFICIALS!!
+They collapsed ... like nuns in the street ... they had no teen appeal!
+This ASEXUAL PIG really BOILS my BLOOD ... He's so ... so ... URGENT!!
+"This is a job for BOB VIOLENCE and SCUM, the INCREDIBLY STUPID MUTANT DOG." -- Bob Violence
+This is a NO-FRILLS flight -- hold th' CANADIAN BACON!!
+This MUST be a good party -- My RIB CAGE is being painfully pressed up against someone's MARTINI!! ... this must be what it's like to be a COLLEGE GRADUATE!!
+This PIZZA symbolizes my COMPLETE EMOTIONAL RECOVERY!!
+This PORCUPINE knows his ZIPCODE ... And he has "VISA"!!
+This TOPS OFF my partygoing experience! Someone I DON'T LIKE is talking to me about a HEART-WARMING European film ...
+Those aren't WINOS -- that's my JUGGLER, my AERIALIST, my SWORD SWALLOWER, and my LATEX NOVELTY SUPPLIER!!
+Thousands of days of civilians ... have produced a ... feeling for the aesthetic modules --
+Today, THREE WINOS from DETROIT sold me a framed photo of TAB HUNTER before his MAKEOVER!
+Toes, knees, NIPPLES. Toes, knees, nipples, KNUCKLES ... Nipples, dimples, knuckles, NICKLES, wrinkles, pimples!! TONY RANDALL! Is YOUR life a PATIO of FUN??
+Uh-oh -- WHY am I suddenly thinking of a VENERABLE religious leader frolicking on a FORT LAUDERDALE weekend?
+Uh-oh!! I forgot to submit to COMPULSORY URINALYSIS!
+UH-OH!! I put on "GREAT HEAD-ON TRAIN COLLISIONS of the 50's" by mistake!!!
+UH-OH!! I think KEN is OVER-DUE on his R.V. PAYMENTS and HE'S having a NERVOUS BREAKDOWN too!! Ha ha.
+Uh-oh!! I'm having TOO MUCH FUN!!
+UH-OH!! We're out of AUTOMOBILE PARTS and RUBBER GOODS!
+Used staples are good with SOY SAUCE!
+VICARIOUSLY experience some reason to LIVE!!
+Vote for ME -- I'm well-tapered, half-cocked, ill-conceived and TAX-DEFERRED!
+Wait ... is this a FUN THING or the END of LIFE in Petticoat Junction??
+Was my SOY LOAF left out in th'RAIN? It tastes REAL GOOD!!
+We are now enjoying total mutual interaction in an imaginary hot tub ...
+We have DIFFERENT amounts of HAIR --
+We just joined the civil hair patrol!
+We place two copies of PEOPLE magazine in a DARK, HUMID mobile home. 45 minutes later CYNDI LAUPER emerges wearing a BIRD CAGE on her head!
+Well, here I am in AMERICA.. I LIKE it. I HATE it. I LIKE it. I HATE it. I LIKE it. I HATE it. I LIKE it. I HATE it. I LIKE ... EMOTIONS are SWEEPING over me!!
+Well, I'm a classic ANAL RETENTIVE!! And I'm looking for a way to VICARIOUSLY experience some reason to LIVE!!
+Well, I'm INVISIBLE AGAIN ... I might as well pay a visit to the LADIES ROOM ...
+Well, O.K. I'll compromise with my principles because of EXISTENTIAL DESPAIR!
+Were these parsnips CORRECTLY MARINATED in TACO SAUCE?
+What a COINCIDENCE! I'm an authorized "SNOOTS OF THE STARS" dealer!!
+What GOOD is a CARDBOARD suitcase ANYWAY?
+What I need is a MATURE RELATIONSHIP with a FLOPPY DISK ...
+What I want to find out is -- do parrots know much about Astro-Turf?
+What PROGRAM are they watching?
+What UNIVERSE is this, please??
+What's the MATTER Sid? ... Is your BEVERAGE unsatisfactory?
+When I met th'POPE back in '58, I scrubbed him with a MILD SOAP or DETERGENT for 15 minutes. He seemed to enjoy it ...
+When this load is DONE I think I'll wash it AGAIN ...
+When you get your PH.D. will you get able to work at BURGER KING?
+When you said "HEAVILY FORESTED" it reminded me of an overdue CLEANING BILL ... Don't you SEE? O'Grogan SWALLOWED a VALUABLE COIN COLLECTION and HAD to murder the ONLY MAN who KNEW!!
+Where do your SOCKS go when you lose them in th' WASHER?
+Where does it go when you flush?
+Where's SANDY DUNCAN?
+Where's th' DAFFY DUCK EXHIBIT??
+Where's the Coke machine? Tell me a joke!!
+While my BRAINPAN is being refused service in BURGER KING, Jesuit priests are DATING CAREER DIPLOMATS!!
+While you're chewing, think of STEVEN SPIELBERG'S bank account ... his will have the same effect as two "STARCH BLOCKERS"!
+WHO sees a BEACH BUNNY sobbing on a SHAG RUG?!
+WHOA!! Ken and Barbie are having TOO MUCH FUN!! It must be the NEGATIVE IONS!!
+Why are these athletic shoe salesmen following me??
+Why don't you ever enter any CONTESTS, Marvin?? Don't you know your own ZIPCODE?
+Why is everything made of Lycra Spandex?
+Why is it that when you DIE, you can't take your HOME ENTERTAINMENT CENTER with you??
+Will it improve my CASH FLOW?
+Will the third world war keep "Bosom Buddies" off the air?
+Will this never-ending series of PLEASURABLE EVENTS never cease?
+With YOU, I can be MYSELF ... We don't NEED Dan Rather ...
+World War III? No thanks!
+World War Three can be averted by adherence to a strictly enforced dress code!
+Wow! Look!! A stray meatball!! Let's interview it!
+Xerox your lunch and file it under "sex offenders"!
+Yes, but will I see the EASTER BUNNY in skintight leather at an IRON MAIDEN concert?
+You can't hurt me!! I have an ASSUMABLE MORTGAGE!!
+You mean now I can SHOOT YOU in the back and further BLUR th' distinction between FANTASY and REALITY?
+You mean you don't want to watch WRESTLING from ATLANTA?
+YOU PICKED KARL MALDEN'S NOSE!!
+You should all JUMP UP AND DOWN for TWO HOURS while I decide on a NEW CAREER!!
+You were s'posed to laugh!
+YOU!! Give me the CUTEST, PINKEST, most charming little VICTORIAN DOLLHOUSE you can find!! An make it SNAPPY!!
+Your CHEEKS sit like twin NECTARINES above a MOUTH that knows no BOUNDS -- Youth of today! Join me in a mass rally for traditional mental attitudes!
+Yow!
+Yow! Am I having fun yet?
+Yow! Am I in Milwaukee?
+Yow! And then we could sit on the hoods of cars at stop lights!
+Yow! Are we laid back yet?
+Yow! Are we wet yet?
+Yow! Are you the self-frying president?
+Yow! Did something bad happen or am I in a drive-in movie??
+Yow! I just went below the poverty line!
+Yow! I threw up on my window!
+Yow! I want my nose in lights!
+Yow! I want to mail a bronzed artichoke to Nicaragua!
+Yow! I'm having a quadrophonic sensation of two winos alone in a steel mill!
+Yow! I'm imagining a surfer van filled with soy sauce!
+Yow! Is my fallout shelter termite proof?
+Yow! Is this sexual intercourse yet?? Is it, huh, is it??
+Yow! It's a hole all the way to downtown Burbank!
+Yow! It's some people inside the wall! This is better than mopping!
+Yow! Maybe I should have asked for my Neutron Bomb in PAISLEY --
+Yow! Now I get to think about all the BAD THINGS I did to a BOWLING BALL when I was in JUNIOR HIGH SCHOOL!
+Yow! Now we can become alcoholics!
+Yow! Those people look exactly like Donnie and Marie Osmond!!
+Yow! We're going to a new disco!
+YOW!! Everybody out of the GENETIC POOL!
+YOW!! I'm in a very clever and adorable INSANE ASYLUM!!
+YOW!! Now I understand advanced MICROBIOLOGY and th' new TAX REFORM laws!!
+YOW!! The land of the rising SONY!!
+YOW!! Up ahead! It's a DONUT HUT!!
+YOW!! What should the entire human race DO?? Consume a fifth of CHIVAS REGAL, ski NUDE down MT. EVEREST, and have a wild SEX WEEKEND!
+YOW!!! I am having fun!!!
+Zippy's brain cells are straining to bridge synapses ...
--- /dev/null
+# This program is copyright Jonathan Feinberg 1999.
+# This program is distributed under the same terms as infobot.
+
+# Jonathan Feinberg
+# jdf@pobox.com
+# http://pobox.com/~jdf/
+
+# Version 1.0
+# First public release.
+
+# hacked by Tim@Rikers.org to handle new URL and layout
+
+package babelfish;
+use strict;
+
+my $no_babelfish;
+my $url = 'http://babelfish.av.com/tr';
+
+BEGIN {
+ eval "use URI::Escape"; # utility functions for encoding the
+ if ($@) { $no_babelfish++}; # babelfish request
+ eval "use LWP::UserAgent";
+ if ($@) { $no_babelfish++};
+}
+
+BEGIN {
+ # Translate some feasible abbreviations into the ones babelfish
+ # expects.
+ use vars qw!%lang_code $lang_regex!;
+ %lang_code = (
+ 'de' => 'de',
+ 'ge' => 'de',
+ 'gr' => 'el',
+ 'el' => 'el',
+ 'sp' => 'es',
+ 'es' => 'es',
+ 'en' => 'en',
+ 'fr' => 'fr',
+ 'it' => 'it',
+ 'ja' => 'ja',
+ 'jp' => 'ja',
+ 'ko' => 'ko',
+ 'kr' => 'ko',
+ 'nl' => 'nl',
+ 'po' => 'pt',
+ 'pt' => 'pt',
+ 'ru' => 'ru',
+ 'zh' => 'zh',
+ 'zt' => 'zt'
+ );
+
+ # Here's how we recognize the language you're asking for. It looks
+ # like RTSL saves you a few keystrokes in #perl, huh?
+ $lang_regex = join '|', keys %lang_code;
+}
+
+sub babelfishParam {
+ return '' if $no_babelfish;
+ my ($from, $to, $phrase) = @_;
+ &::DEBUG("babelfish($from, $to, $phrase)");
+
+ $from = $lang_code{$from};
+ $to = $lang_code{$to};
+
+ my $ua = new LWP::UserAgent;
+ $ua->proxy('http', $::param{'httpProxy'}) if (&::IsParam('httpProxy'));
+ # Let's pretend
+ $ua->agent("Mozilla/5.0 " . $ua->agent);
+ $ua->timeout(5);
+
+ my $req = HTTP::Request->new('POST', $url);
+
+# babelfish ignored this, but it SHOULD work
+# Accept-Charset: iso-8859-1
+# $req->header('Accept-Charset' => 'iso-8859-1');
+# print $req->header('Accept-Charset');
+ $req->header('Accept-Language' => 'en');
+ $req->content_type('application/x-www-form-urlencoded');
+
+ return translate($phrase, "${from}_${to}", $req, $ua);
+}
+
+sub translate {
+ return '' if $no_babelfish;
+ my ($phrase, $languagepair, $req, $ua) = @_;
+ &::DEBUG("translate($phrase, $languagepair, $req, $ua)");
+
+ my $trtext = uri_escape($phrase);
+ $req->content("trtext=$trtext&lp=$languagepair");
+ &::DEBUG("$url??trtext=$trtext&lp=$languagepair");
+
+ my $res = $ua->request($req);
+ my $translated;
+
+ if ($res->is_success) {
+ my $html = $res->content;
+ # This method subject to change with the whims of Altavista's design
+ # staff.
+ ($translated) = $html;
+
+ $translated =~ s/<[^>]*>//sg;
+ $translated =~ s/ / /sg;
+ $translated =~ s/\s+/ /sg;
+ #&::DEBUG("$translated\n===remove <attributes>\n");
+
+ $translated =~ s/\s*Translate again.*//i;
+ &::DEBUG("$translated\n===remove after 'Translate again'\n");
+
+ $translated =~ s/[^:]*?:\s*(Help\s*)?//s;
+ &::DEBUG("len=" . length($translated) . " $translated\n===remove to first ':', optional Help\n");
+
+ $translated =~ s/\n/ /g;
+ # FIXME: should we do unicode->iso (no. use utf8!)
+ } else {
+ $translated = ":("; # failure
+ }
+ $translated = "babelfish.pl: result too long, probably an error" if (length($translated) > 700);
+
+ return $translated
+}
+
+sub babelfish {
+ my ($message) = @_;
+ my $babel_lang_regex = "de|ge|gr|el|sp|es|en|fr|it|ja|jp|ko|kr|nl|po|pt|ru|zh|zt";
+ if ($message =~ m{
+ ($babel_lang_regex)\w* # from language?
+ \s+
+ ($babel_lang_regex)\w* # to language?
+ \s*
+ (.+) # The phrase to be translated
+ }xoi) {
+ &::performStrictReply(&babelfishParam(lc $1, lc $2, lc $3));
+ }
+ return;
+}
+
+if (0) {
+ if (-t STDIN) {
+ #my $result = babelfish::babelfish('en sp hello world');
+ #my $result = babelfish::babelfish('en sp The cheese is old and moldy, where is the bathroom?');
+ my $result = babelfish::babelfish('en gr doesn\'t seem to translate things longer than 40 characters');
+ $result =~ s/; /\n/g;
+ print "Babelfish says: \"$result\"\n";
+ }
+}
+
+1;
--- /dev/null
+#
+# botmail.pl: Botmail (ala in infobot)
+# Author: dms
+# Version: v0.1 (20021122).
+# Created: 20021122
+# NOTE: Motivated by TimRiker.
+# TODO: full-fledged notes services (optional auth, etc)
+#
+
+package botmail;
+
+use strict;
+
+sub parse {
+ my($what) = @_;
+
+ if (!defined $what or $what =~ /^\s*$/) {
+ &::help('botmail');
+ return;
+ }
+
+ if ($what =~ /^(to|for|add)\s+(.*)$/i) {
+ &add( split(/\s+/, $2, 2) );
+
+ } elsif ($what =~ /^stats?$/i) {
+ &stats();
+
+ } elsif ($what =~ /^check?$/i) {
+ &check( $1, 1);
+
+ } elsif ($what =~ /^(read|next)$/i) {
+ # TODO: read specific items? nah, will make this too complex.
+ &next($::who);
+
+ }
+}
+
+sub stats {
+ my $botmail = &::countKeys('botmail');
+ &::msg($::who, "I have \002$botmail\002 ". &::fixPlural('message', $botmail). ".");
+}
+
+#####
+# Usage: botmail::check($recipient, [$always])
+sub check {
+ my($recipient, $always) = @_;
+ $recipient ||= $::who;
+
+ my %from = &::sqlSelectColHash('botmail', "srcwho,time", {
+ dstwho => lc $recipient
+ } );
+ my $t = keys %from;
+ my $from = join(", ", keys %from);
+
+ if ($t == 0) {
+ &::msg($recipient, "You have no botmail.") if ($always);
+ } else {
+ &::msg($recipient, "You have $t messages awaiting, from: $from (botmail read)");
+ }
+}
+
+#####
+# Usage: botmail::next($recipient)
+sub next {
+ my($recipient) = @_;
+
+ my %hash = &::sqlSelectRowHash('botmail', '*', {
+ dstwho => lc $recipient
+ } );
+
+ if (scalar (keys %hash) <= 1) {
+ &::msg($recipient, "You have no botmail.");
+ } else {
+ my $date = scalar(gmtime $hash{'time'});
+ my $ago = &::Time2String(time() - $hash{'time'});
+ &::msg($recipient, "From $hash{srcwho} ($hash{srcuh}) on $date ($ago ago):");
+ &::msg($recipient, $hash{'msg'});
+ &::sqlDelete('botmail', { 'dstwho'=>$hash{dstwho}, 'srcwho'=>$hash{srcwho}});
+ }
+}
+
+#####
+# Usage: botmail::add($recipient, $msg)
+sub add {
+ my($recipient, $msg) = @_;
+ &::DEBUG("botmail::add(@_)");
+
+ # allow optional trailing : ie: botmail for foo[:] hello
+ $recipient =~ s/:$//;
+
+ # only support 1 botmail with unique dstwho/srcwho to have same
+ # functionality as botmail from infobot.
+ # Note: I removed the &::sqlQuote reference. Seems to be working and inserting fine without it here. -- troubled
+ my %hash = &::sqlSelectRowHash('botmail', '*', {
+ srcwho => lc $::who,
+ dstwho => lc $recipient
+ } );
+
+ if (scalar (keys %hash) > 1) {
+ &::msg($::who, "$recipient already has a message queued from you");
+ return;
+ }
+
+ &::sqlInsert('botmail', {
+ 'dstwho' => lc $recipient,
+ 'srcwho' => lc $::who,
+ 'srcuh' => $::nuh,
+ 'time' => time(),
+ 'msg' => $msg,
+ } );
+
+ &::msg($::who, "OK, $::who, I'll let $recipient know.");
+}
+
+1;
--- /dev/null
+# case.pl: upper/lower a string
+# Author: Tim Riker
+# Licensing: Artistic License
+# Version: v0.1
+#
+use strict;
+
+package case;
+
+sub upper {
+ my($message) = @_;
+ # make it green like an old terminal
+ &::performStrictReply("\00303" . uc $message);
+}
+
+sub lower {
+ my($message) = @_;
+ &::performStrictReply(lc $message);
+}
+
+1;
--- /dev/null
+#
+# countdown.pl: Count down to a particular date.
+# Author: dms
+# Version: v0.1 (20000104)
+# Created: 20000104
+#
+
+use strict;
+
+#use vars qw();
+
+sub countdown {
+ my ($query) = @_;
+ my $file = "$bot_base_dir/$param{'ircUser'}.countdown";
+ my (%date, %desc);
+ my $reply;
+
+ if (!open(IN,$file)) {
+ &ERROR("cannot open $file.");
+ return 0;
+ }
+
+ while (<IN>) {
+ chop;
+ s/[\s\t]+/ /g;
+
+ if (/^(\d{8}) (\S+) (.*)$/) {
+ $date{$2} = $1;
+ $desc{$2} = $3;
+ }
+ }
+ close IN;
+
+ if (defined $query) { # argument.
+ if (!exists $date{$query}) {
+ &msg($who,"error: $query is not in my countdown list.");
+ return 0;
+ }
+
+ $date{$query} =~ /^(\d{4})(\d{2})(\d{2})$/;
+ my($year,$month,$day) = ($1,$2,$3);
+ my $sqldate = "$1-$2-$3";
+
+ ### SQL SPECIFIC.
+ my ($to_days,$dayname,$monname);
+
+ if ($param{'DBType'} =~ /^(mysql|sqlite(2)?)$/i) {
+ $to_days = (&sqlRawReturn("SELECT TO_DAYS(NOW()) - TO_DAYS('$sqldate')"))[0];
+ $dayname = (&sqlRawReturn("SELECT DAYNAME('$sqldate')"))[0];
+ $monname = (&sqlRawReturn("SELECT MONTHNAME('$sqldate')"))[0];
+
+ } elsif ($param{'DBType'} =~ /^pgsql$/i) {
+ $to_days = (&sqlRawReturn("SELECT date_trunc('day',
+ 'now'::timestamp - '$sqldate')"))[0];
+ $dayname = qw(Sun Mon Tue Wed Thu Fri Sat)[(&sqlRawReturn("SELECT extract(dow from timestamp '$sqldate')"))[0]];
+ $monname = qw(BAD Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec)[(&sqlRawReturn("SELECT extract(month from timestamp '$sqldate')"))[0]];
+
+ } else {
+ &ERROR("countdown: invalid DBType " . $param{'DBType'} . ".");
+ return 1;
+ }
+
+ if ($to_days =~ /^\D+$/) {
+ my $str = "to_days is not integer.";
+ &msg($who,$str);
+ &ERROR($str);
+
+ return 1;
+ }
+
+ my @gmtime = gmtime(time());
+ my $daysec = ($gmtime[2]*60*60) + ($gmtime[1]*60) + ($gmtime[0]);
+ my $time = ($to_days*24*60*60);
+
+ if ($to_days >= 0) { # already passed.
+ $time += $daysec;
+ $reply = "T plus ". &Time2String($time) ." ago";
+ } else { # time to go.
+ $time = -$time - $daysec;
+ $reply = "T minus ". &Time2String($time);
+ }
+ $reply .= ", \002(\002$desc{$query}\002)\002 at $dayname, $monname $day $year";
+
+ &performStrictReply($reply .".");
+ return 1;
+ } else { # no argument.
+ my $prefix = "countdown list ";
+
+ &performStrictReply( &formListReply(0, $prefix, sort keys %date) );
+
+ return 1;
+ }
+}
+
+1;
--- /dev/null
+#!/usr/bin/perl
+
+# dice rolling
+# hacked up by Tim Riker <Tim@Rikers.org> from Games::Dice
+
+package dice;
+
+use strict;
+use warnings;
+
+sub dice::roll_array ($) {
+ my($line) = shift;
+
+ my(@throws) = ();
+ return @throws unless $line =~ m{
+ ^ # beginning of line
+ (\d+)? # optional count in $1
+ [dD] # 'd' for dice
+ ( # type of dice in $2:
+ \d+ # either one or more digits
+ | # or
+ % # a percent sign for d% = d100
+ )
+ }x; # whitespace allowed
+
+ my($num) = $1 || 1;
+ my($type) = $2;
+
+ return @throws if $num > 100;
+ $type = 100 if $type eq '%';
+ return @throws if $type < 2;
+
+ for( 1 .. $num ) {
+ push @throws, int (rand $type) + 1;
+ }
+
+ return @throws;
+}
+
+sub dice::roll ($) {
+ my($line) = shift;
+
+ $line =~ s/ //g;
+
+ return '' unless $line =~ m{
+ ^ # beginning of line
+ ( # dice string in $1
+ (?:\d+)? # optional count
+ [dD] # 'd' for dice
+ (?: # type of dice:
+ \d+ # either one or more digits
+ | # or
+ % # a percent sign for d% = d100
+ )
+ )
+ (?: # grouping-only parens
+ ([-+xX*/bB]) # a + - * / b(est) in $2
+ (\d+) # an offset in $3
+ )? # both of those last are optional
+ }x; # whitespace allowed in re
+
+ my($dice_string) = $1;
+ my($sign) = $2 || '';
+ my($offset) = $3 || 0;
+
+ $sign = lc $sign;
+
+ my(@throws) = roll_array( $dice_string );
+ return '' unless @throws > 0;
+ my($retval) = "rolled " . join(',', @throws);
+
+ my(@result);
+ if( $sign eq 'b' ) {
+ $offset = 0 if $offset < 0;
+ $offset = @throws if $offset > @throws;
+
+ @throws = sort { $b <=> $a } @throws; # sort numerically, descending
+ @result = @throws[ 0 .. $offset-1 ]; # pick off the $offset first ones
+ $retval .= " best $offset";
+ } else {
+ @result = @throws;
+ $retval .= " $sign $offset" if $sign;
+ }
+
+ my($sum) = 0;
+ $sum += $_ foreach @result;
+ $sum += $offset if $sign eq '+';
+ $sum -= $offset if $sign eq '-';
+ $sum *= $offset if ($sign eq '*' || $sign eq 'x');
+ do { $sum /= $offset; $sum = int $sum; } if $sign eq '/';
+
+ return "$retval = $sum";
+}
+
+sub dice::dice {
+ my ($message) = @_;
+ srand(); # fork seems to not change rand. force it here
+ my $retval = roll($message);
+
+ &::performStrictReply($retval);
+}
+
+#print "(q)uit or die combination, ex. 4d10/4\n";
+#while (my $dice = <STDIN>) {
+# chomp $dice;
+# if (! $dice || $dice =~ m/^q(?:uit)*$/i) {
+# print "done\n";
+# exit;
+# } else {
+# print roll($dice) . "\n";
+# }
+#}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+dice.pl - simulate die rolls
+
+=head1 SYNOPSIS
+
+ 'dice 3d6+1';
+
+=head1 DESCRIPTION
+
+The number and type of dice to roll is given in a style which should be
+familiar to players of popular role-playing games: I<a>dI<b>[+-*/b]I<c>.
+I<a> is optional and defaults to 1; it gives the number of dice to roll.
+I<b> indicates the number of sides to each die; the most common,
+cube-shaped die is thus a d6. % can be used instead of 100 for I<b>;
+hence, rolling 2d% and 2d100 is equivalent. C<roll> simulates I<a> rolls
+of I<b>-sided dice and adds together the results. The optional end,
+consisting of one of +-*/b and a number I<c>, can modify the sum of the
+individual dice. +-*/ are similar in that they take the sum of the rolls
+and add or subtract I<c>, or multiply or divide the sum by I<c>. (x can
+also be used instead of *.) Hence, 1d6+2 gives a number in the range
+3..8, and 2d4*10 gives a number in the range 20..80. (Using / truncates
+the result to an int after dividing.) Using b in this slot is a little
+different: it's short for "best" and indicates "roll a number of dice,
+but add together only the best few". For example, 5d6b3 rolls five six-
+sided dice and adds together the three best rolls. This is sometimes
+used, for example, in roll-playing to give higher averages.
+
+=head1 AUTHOR
+
+Philip Newton, <pne@cpan.org>
+
+Tim Riker <Tim@Rikers.org>
+
+=head1 LICENCE
+
+Copyright (C) 1999, 2002 Philip Newton - All rights reserved.
+
+Copyright (C) 2005 Tim Riker - All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+
+=over 4
+
+=item *
+
+Redistributions of source code must retain the above copyright notice,
+this list of conditions and the following disclaimer.
+
+=item *
+
+Redistributions in binary form must reproduce the above copyright notice,
+this list of conditions and the following disclaimer in the
+documentation and/or other materials provided with the distribution.
+
+=back
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND
+CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE
+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGE.
+
+=cut
--- /dev/null
+#
+# dns.pl: host lookups
+# Author: Tim Riker <Tim@Rikers.org>
+# Source: extracted from UserExtra.pl
+# Licensing: Artistic License (as perl itself)
+# Version: v0.1
+#
+# Copyright (c) 2005 Tim Riker
+#
+
+package dns;
+
+use strict;
+
+sub dns::dns {
+ my $dns = shift;
+ my($match, $x, $y, $result, $pid);
+
+ if ($dns =~ /(\d+\.\d+\.\d+\.\d+)/) {
+ use Socket;
+
+ &::status("DNS query by IP address: $dns");
+
+ $y = pack('C4', split(/\./, $dns));
+ $x = (gethostbyaddr($y, &AF_INET));
+
+ if ($x !~ /^\s*$/) {
+ $result = "$dns is $x" unless ($x =~ /^\s*$/);
+ } else {
+ $result = "I can't find the address $dns in DNS";
+ }
+
+ } else {
+
+ &::status("DNS query by name: $dns");
+ $x = join('.',unpack('C4',(gethostbyname($dns))[4]));
+
+ if ($x !~ /^\s*$/) {
+ $result = "$dns is $x";
+ } else {
+ $result = "I can't find $dns in DNS";
+ }
+ }
+
+ return($result);
+}
+
+sub dns::query {
+ &::performStrictReply(&dns(@_));
+ return;
+}
+
+1;
+# vim: ts=2 sw=2
--- /dev/null
+#
+# insult.pl: insult engine
+#
+# 2004.10.21 Tim Riker <Tim@Rikers.org>
+# colorado server is dead. pull in the words and do it ourself
+#
+
+package Insult;
+
+use strict;
+
+sub Insult {
+ my ($insultwho) = @_;
+ my @adjs;
+ my @amts;
+ my @nouns;
+ &::DEBUG('Reading insult data');
+ while (<DATA>) {
+ chomp;
+ push(@adjs, split(' ', $1)) if /^adj\s*(.*)/;
+ push(@amts, split(' ', $1)) if /^amt\s*(.*)/;
+ push(@nouns, split(' ', $1)) if /^noun\s*(.*)/;
+ }
+ grep(s/\|/ /g, @adjs);
+ grep(s/\|/ /g, @amts);
+ grep(s/\|/ /g, @nouns);
+ srand(); # fork seems to not change rand. force it here
+ my $adj = @adjs[rand(@adjs)];
+ my $n;
+ $n = 'n' if $adj =~ /^[aeiouih]/;
+ my $amt = @amts[rand(@amts)];
+ my $adj2 = @adjs[rand(@adjs)];
+ my $noun = @nouns[rand(@nouns)];
+ my $whois = "$insultwho is";
+ $whois = 'You are' if ($insultwho eq $::who or $insultwho eq 'me');
+
+ &::performStrictReply("$whois nothing but a$n $adj $amt of $adj2 $noun");
+}
+
+1;
+
+__DATA__
+#
+# configuration file for colorado insult server
+#
+# Use the '|' character to include a space in the middle of a noun, adjective
+# or amount (it'll get transmogrified into a space. No, really!).
+#
+# Mon Mar 16 10:49:53 MST 1992 garnett added more colorful insults
+# Fri Dec 6 10:48:43 MST 1991 garnett
+#
+
+##
+# Adjectives
+##
+adj acidic antique contemptible culturally-unsound despicable evil fermented
+adj festering foul fulminating humid impure inept inferior industrial
+adj left-over low-quality malodorous off-color penguin-molesting
+adj petrified pointy-nosed salty sausage-snorfling tastless tempestuous
+adj tepid tofu-nibbling unintelligent unoriginal uninspiring weasel-smelling
+adj wretched spam-sucking egg-sucking decayed halfbaked infected squishy
+adj porous pickled coughed-up thick vapid hacked-up
+adj unmuzzled bawdy vain lumpish churlish fobbing rank craven puking
+adj jarring fly-bitten pox-marked fen-sucked spongy droning gleeking warped
+adj currish milk-livered surly mammering ill-borne beef-witted tickle-brained
+adj half-faced headless wayward rump-fed onion-eyed beslubbering villainous
+adj lewd-minded cockered full-gorged rude-snouted crook-pated pribbling
+adj dread-bolted fool-born puny fawning sheep-biting dankish goatish
+adj weather-bitten knotty-pated malt-wormy saucyspleened motley-mind
+adj it-fowling vassal-willed loggerheaded clapper-clawed frothy ruttish
+adj clouted common-kissing pignutted folly-fallen plume-plucked flap-mouthed
+adj swag-bellied dizzy-eyed gorbellied weedy reeky measled spur-galled mangled
+adj impertinent bootless toad-spotted hasty-witted horn-beat yeasty
+adj imp-bladdereddle-headed boil-brained tottering hedge-born hugger-muggered
+adj elf-skinned
+
+##
+# Amounts
+##
+amt accumulation bucket coagulation enema-bucketful gob half-mouthful
+amt heap mass mound petrification pile puddle stack thimbleful tongueful
+amt ooze quart bag plate ass-full assload
+
+##
+# Objects
+##
+noun bat|toenails bug|spit cat|hair chicken|piss dog|vomit dung
+noun fat-woman's|stomach-bile fish|heads guano gunk pond|scum rat|retch
+noun red|dye|number-9 Sun|IPC|manuals waffle-house|grits yoo-hoo
+noun dog|balls seagull|puke cat|bladders pus urine|samples
+noun squirrel|guts snake|assholes snake|bait buzzard|gizzards
+noun cat-hair-balls rat-farts pods armadillo|snouts entrails
+noun snake|snot eel|ooze slurpee-backwash toxic|waste Stimpy-drool
+noun poopy poop craptacular|carpet|droppings jizzum cold|sores anal|warts
--- /dev/null
+# md5.pl: md5 a string
+# Author: Tim Riker
+# Licensing: Artistic License
+# Version: v0.1 (20041209)
+#
+use strict;
+
+package md5;
+
+sub md5 {
+ my($message) = @_;
+ return unless &::loadPerlModule('Digest::MD5');
+
+ &::performStrictReply(&Digest::MD5::md5_hex($message));
+}
+
+1;
--- /dev/null
+#
+# Lame-o-Nickometer backend
+#
+# (c) 1998 Adam Spiers <adam.spiers@new.ox.ac.uk>
+#
+# You may do whatever you want with this code, but give me credit.
+#
+# $Id$
+#
+
+package nickometer;
+
+use strict;
+
+my $pi = 3.14159265;
+my $score = 0;
+my $verbose = 0;
+
+sub query {
+ my ($message) = @_;
+
+ my $term = (lc $message eq 'me') ? $::who : $message;
+
+ if ($term =~ /^$::mask{chan}$/) {
+ &::status("Doing nickometer for chan $term.");
+
+ if (!&::validChan($term)) {
+ &::msg($::who, "error: channel is invalid.");
+ return;
+ }
+
+ # step 1.
+ my %nickometer;
+ foreach (keys %{ $::channels{lc $term}{''} }) {
+ my $str = $_;
+ if (!defined $str) {
+ &WARN("nickometer: nick in chan $term undefined?");
+ next;
+ }
+
+ my $value = &nickometer($str);
+ $nickometer{$value}{$str} = 1;
+ }
+
+ # step 2.
+ ### TODO: compact with map?
+ my @list;
+ foreach (sort {$b <=> $a} keys %nickometer) {
+ my $str = join(', ', sort keys %{ $nickometer{$_} });
+ push(@list, "$str ($_%)");
+ }
+
+ &::performStrictReply( &::formListReply(0, "Nickometer list for $term ", @list) );
+
+ return;
+ }
+
+ my $percentage = &nickometer($term);
+
+ if ($percentage =~ /NaN/) {
+ $percentage = 'off the scale';
+ } else {
+ $percentage = sprintf("%0.4f", $percentage);
+ $percentage =~ s/(\.\d+)0+$/$1/;
+ $percentage .= '%';
+ }
+
+ if ($::msgType eq 'public') {
+ &::say("'$term' is $percentage lame, $::who");
+ } else {
+ &::msg($::who, "the 'lame nick-o-meter' reading for $term is $percentage, $::who");
+ }
+
+ return;
+}
+
+sub nickometer ($) {
+ my ($text) = @_;
+ $score = 0;
+
+# return unless &loadPerlModule("Getopt::Std");
+ return unless &::loadPerlModule("Math::Trig");
+
+ if (!defined $text) {
+ &::DEBUG("nickometer: arg == NULL. $text");
+ return;
+ }
+
+ # Deal with special cases (precede with \ to prevent de-k3wlt0k)
+ my %special_cost = (
+ '69' => 500,
+ 'dea?th' => 500,
+ 'dark' => 400,
+ 'n[i1]ght' => 300,
+ 'n[i1]te' => 500,
+ 'fuck' => 500,
+ 'sh[i1]t' => 500,
+ 'coo[l1]' => 500,
+ 'kew[l1]' => 500,
+ 'lame' => 500,
+ 'dood' => 500,
+ 'dude' => 500,
+ '[l1](oo?|u)[sz]er' => 500,
+ '[l1]eet' => 500,
+ 'e[l1]ite' => 500,
+ '[l1]ord' => 500,
+ 'pron' => 1000,
+ 'warez' => 1000,
+ 'xx' => 100,
+ '\[rkx]0' => 1000,
+ '\0[rkx]' => 1000,
+ );
+
+ foreach my $special (keys %special_cost) {
+ my $special_pattern = $special;
+ my $raw = ($special_pattern =~ s/^\\//);
+ my $nick = $text;
+ unless (defined $raw) {
+ $nick =~ tr/023457+8/ozeasttb/;
+ }
+ &punish($special_cost{$special}, "matched special case /$special_pattern/")
+ if (defined $nick and $nick =~ /$special_pattern/i);
+ }
+
+ # Allow Perl referencing
+ $text =~ s/^\\([A-Za-z])/$1/;
+
+ # C-- ain't so bad either
+ $text =~ s/^C--$/C/;
+
+ # Punish consecutive non-alphas
+ $text =~ s/([^A-Za-z0-9]{2,})
+ /my $consecutive = length($1);
+ &punish(&slow_pow(10, $consecutive),
+ "$consecutive total consecutive non-alphas")
+ if $consecutive;
+ $1
+ /egx;
+
+ # Remove balanced brackets (and punish a little bit) and punish for unmatched
+ while ($text =~ s/^([^()]*) (\() (.*) (\)) ([^()]*) $/$1$3$5/x ||
+ $text =~ s/^([^{}]*) (\{) (.*) (\}) ([^{}]*) $/$1$3$5/x ||
+ $text =~ s/^([^\[\]]*) (\[) (.*) (\]) ([^\[\]]*) $/$1$3$5/x)
+ {
+ print "Removed $2$4 outside parentheses; nick now $_\n" if $verbose;
+ &punish(15, 'brackets');
+ }
+ my $parentheses = $text =~ tr/(){}[]/(){}[]/;
+ &punish(&slow_pow(10, $parentheses),
+ "$parentheses unmatched " .
+ ($parentheses == 1 ? 'parenthesis' : 'parentheses'))
+ if $parentheses;
+
+ # Punish k3wlt0k
+ my @k3wlt0k_weights = (5, 5, 2, 5, 2, 3, 1, 2, 2, 2);
+ for my $digit (0 .. 9) {
+ my $occurrences = $text =~ s/$digit/$digit/g || 0;
+ &punish($k3wlt0k_weights[$digit] * $occurrences * 30,
+ $occurrences . ' ' .
+ (($occurrences == 1) ? 'occurrence' : 'occurrences') .
+ " of $digit")
+ if $occurrences;
+ }
+
+ # An alpha caps is not lame in middle or at end, provided the first
+ # alpha is caps.
+ my $orig_case = $text;
+ $text =~ s/^([^A-Za-z]*[A-Z].*[a-z].*?)[_-]?([A-Z])/$1\l$2/;
+
+ # A caps first alpha is sometimes not lame
+ $text =~ s/^([^A-Za-z]*)([A-Z])([a-z])/$1\l$2$3/;
+
+ # Punish uppercase to lowercase shifts and vice-versa, modulo
+ # exceptions above
+ my $case_shifts = &case_shifts($orig_case);
+ &punish(&slow_pow(9, $case_shifts),
+ $case_shifts . ' case ' .
+ (($case_shifts == 1) ? 'shift' : 'shifts'))
+ if ($case_shifts > 1 && /[A-Z]/);
+
+ # Punish lame endings (TorgoX, WraithX et al. might kill me for this :-)
+ &punish(50, 'last alpha lame') if $orig_case =~ /[XZ][^a-zA-Z]*$/;
+
+ # Punish letter to numeric shifts and vice-versa
+ my $number_shifts = &number_shifts($_);
+ &punish(&slow_pow(9, $number_shifts),
+ $number_shifts . ' letter/number ' .
+ (($number_shifts == 1) ? 'shift' : 'shifts'))
+ if $number_shifts > 1;
+
+ # Punish extraneous caps
+ my $caps = $text =~ tr/A-Z/A-Z/;
+ &punish(&slow_pow(7, $caps), "$caps extraneous caps") if $caps;
+
+ # One and only one trailing underscore is OK.
+ $text =~ s/\_$//;
+
+ # Now punish anything that's left
+ my $remains = $text;
+ $remains =~ tr/a-zA-Z0-9//d;
+ my $remains_length = length($remains);
+
+ &punish(50 * $remains_length + &slow_pow(9, $remains_length),
+ $remains_length . ' extraneous ' .
+ (($remains_length == 1) ? 'symbol' : 'symbols'))
+ if $remains;
+
+ print "\nRaw lameness score is $score\n" if $verbose;
+
+ # Use an appropriate function to map [0, +inf) to [0, 100)
+ my $percentage = 100 *
+ (1 + &Math::Trig::tanh(($score-400)/400)) *
+ (1 - 1/(1+$score/5)) / 2;
+
+ my $digits = 2 * (2 - &round_up(log(100 - $percentage) / log(10)));
+
+ return sprintf "%.${digits}f", $percentage;
+}
+
+sub case_shifts ($) {
+ # This is a neat trick suggested by freeside. Thanks freeside!
+
+ my $shifts = shift;
+
+ $shifts =~ tr/A-Za-z//cd;
+ $shifts =~ tr/A-Z/U/s;
+ $shifts =~ tr/a-z/l/s;
+
+ return length($shifts) - 1;
+}
+
+sub number_shifts ($) {
+ my $shifts = shift;
+
+ $shifts =~ tr/A-Za-z0-9//cd;
+ $shifts =~ tr/A-Za-z/l/s;
+ $shifts =~ tr/0-9/n/s;
+
+ return length($shifts) - 1;
+}
+
+sub slow_pow ($$) {
+ my ($x, $y) = @_;
+
+ return $x ** &slow_exponent($y);
+}
+
+sub slow_exponent ($) {
+ my $x = shift;
+
+ return 1.3 * $x * (1 - &Math::Trig::atan($x/6) *2/$pi);
+}
+
+sub round_up ($) {
+ my $float = shift;
+
+ return int($float) + ((int($float) == $float) ? 0 : 1);
+}
+
+sub punish ($$) {
+ my ($damage, $reason) = @_;
+
+ return unless $damage;
+
+ $score += $damage;
+ print "$damage lameness points awarded: $reason\n" if $verbose;
+}
+
+1;
--- /dev/null
+# Pager
+#
+# modified from pager.pm in flooterbuck changes are:
+#
+# Copyright (c) 2004 Tim Riker <Tim@Rikers.org>
+#
+# This package is free software; you can redistribute it and/or
+# modify it under the terms of the license found in the file
+# named LICENSE that should have accompanied this file.
+#
+# THIS PACKAGE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
+# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
+# WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+
+package pager;
+use strict;
+
+my $no_page;
+
+BEGIN {
+ eval qq{
+ use Mail::Mailer qw(sendmail);
+ };
+ $no_page++ if ($@);
+}
+
+sub pager::page {
+ my ($message) = @_;
+ my ($retval);
+
+ # TODO only allow registered users?
+
+ if ($no_page) {
+ &::status('page module requires Mail::Mailer.');
+ return 'page module not active';
+ }
+
+ unless ($message =~ /^(\S+)\s+(.*)$/) {
+ return undef;
+ }
+
+ my $from = $::who;
+ my $to = $1;
+ my $msg = $2;
+
+ # allow optional trailing : ie: page foo[:] hello
+ $to =~ s/:$//;
+
+ my $tofactoid = &::getFactoid(lc "${to}'s pager");
+ if ($tofactoid =~ /(\S+@\S+)/) {
+ my $toaddr = $1;
+ $toaddr =~ s/^mailto://;
+ # TODO require sender-locked factoid?
+
+ my $fromfactoid = &::getFactoid(lc "${from}'s pager");
+
+ my $fromaddr;
+ if ($fromfactoid =~ /(\S+@\S+)/) {
+ $fromaddr = $1;
+ $fromaddr =~ s/^mailto://;
+ } else {
+ # TODO require sender to have valid self-locked pager factoid?
+ $fromaddr = 'infobot@example.com';
+ }
+
+ my $channel = $::chan || 'infobot';
+ # TODO disallow use from private message? $chan='_default'
+
+ &::status("pager: from $from <$fromaddr>, to $to <$toaddr>, msg \"$msg\"");
+ my %headers = (
+ To => "$to <$toaddr>",
+ From => "$from <$fromaddr>",
+ Subject => "Message from $channel!",
+ 'X-Mailer' => 'infobot',
+ );
+
+# my $logmsg;
+# for (keys %headers) {
+# $logmsg .= "$_: $headers{$_}\n";
+# }
+# $logmsg .= "\n$msg\n";
+# &::status("pager:\n$logmsg");
+
+ my $failed;
+ my $mailer = new Mail::Mailer 'sendmail';
+ $failed++ unless $mailer->open(\%headers);
+ $failed++ unless print $mailer "$msg\n";
+ $failed++ unless $mailer->close;
+
+ if ($failed) {
+ $retval='Sorry, an error occurred while sending mail.';
+ } else {
+ $retval="$from: I sent mail to $toaddr from $fromaddr.";
+ }
+ } else {
+ $retval="Sorry, I don't know ${to}'s email address.";
+ }
+ &::performStrictReply($retval);
+}
+
+'pager';
+# vim: ts=2 sw=2
--- /dev/null
+# turns english text into piglatin
+# Copyright (c) 2005 Tim Riker <Tim@Rikers.org>
+
+use strict;
+use warnings;
+
+package piglatin;
+
+sub piglatin
+{
+ my ($text) = @_;
+ my $piglatin;
+ my $suffix = 'ay';
+
+ # FIXME: does not handle:
+ # non-trailing punctuation and hyphens
+ # y as vowel 'style' -> 'ylestay'
+ # contractions
+ for my $word (split /\s+/, $text) {
+ my ($pigword, $postfix);
+ #($word,$postfix) = $word =~ s/^([a-z]*)([,.!\?;:'"])?$//i;
+ if ($word =~ s/([,.!\?;:'"])$//i) {
+ $postfix = $1;
+ }
+ if ($word =~ /^(qu)(.*)/ ) {
+ $pigword = "$2$1$suffix";
+ } elsif ($word =~ /^(Qu)(.)(.*)/ ) {
+ $pigword = uc($2) . $3 . lc($1) . $suffix;
+ } elsif ($word =~ /^([bcdfghjklmnpqrstvwxyz]+)(.*)/ ) {
+ $pigword = "$2$1$suffix";
+ } elsif ($word =~ /^([BCDFGHJKLMNPQRSTVWXYZ])([bcdfghjklmnpqrstvwxyz]*)([aeiouy])(.*)/ ) {
+ $pigword = uc($3) . $4 . lc($1) . $2 . $suffix;
+ } else {
+ $pigword = $word . 'w' . $suffix;
+ }
+ $piglatin .= ' ' if $piglatin;
+ $piglatin .= $pigword . $postfix;
+ }
+ &::performStrictReply($piglatin||'failed');
+}
+
+1;
--- /dev/null
+# reverse.pl: reverse a string
+# Author: Tim Riker
+# Licensing: Artistic License
+# Version: v0.1 (20050812)
+#
+use strict;
+
+package reverse;
+
+sub reverse {
+ my($message) = @_;
+ &::performStrictReply(join('',reverse(split('',$message))));
+}
+
+1;
--- /dev/null
+# Copyright (c) 2003 Chris Angell (chris62vw@hotmail.com). All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+# Turns this:
+# Mary had a little lamb and her fleece was white as snow
+# into this:
+# Mray had a liltte lmab and her flecee was whtie as sonw
+
+use strict;
+use warnings;
+
+package scramble;
+
+sub scramble
+{
+ my ($text) = @_;
+ my $scrambled;
+
+ return unless &::loadPerlModule("List::Util");
+ srand(); # fork seems to not change rand. force it here
+ for my $orig_word (split /\s+/, $text)
+ {
+ # skip words that are less than four characters in length
+ $scrambled .= "$orig_word " and next if length($orig_word) < 4;
+
+ # get first and last characters, and middle characters
+ # optional characters are for punctuation, etc.
+ my ($first, $middle, $last) = $orig_word =~ /^['"]?(.)(.+)'?(.)[,.!?;:'"]?$/;
+
+ my ($new_middle, $cnt);
+
+ # shuffle until $new_middle is different from $middle
+ do
+ {
+ # theoretically, this loop could loop forever, so
+ # a counter is used. once $cnt > 10 then use a
+ # simple regex to scramble and call it good
+
+ if (++$cnt > 10)
+ {
+ # non-random shuffle, but good enough
+ ($new_middle = $middle) =~ s/(.)(.)/$2$1/g;
+ }
+
+ # shuffle the middle letters
+ $new_middle = join '', List::Util::shuffle(split //, $middle);
+ }
+ while (($cnt < 10) && ($middle eq $new_middle));
+
+ # add the word to the list...
+ $scrambled .= "$first$new_middle$last ";
+ }
+
+ # remove the single trailing space, and any other space that may have
+ # been included in the original string
+ $scrambled =~ s/\s+$//;
+
+ &::performStrictReply($scrambled||'Unknown Error Condition');
+}
+
+1;
--- /dev/null
+#
+# Slashdot.pl: Slashdot headline retrival
+# Author: Chris Tessone <tessone@imsa.edu>
+# Modified: dms
+# Licensing: Artistic License (as perl itself)
+# Version: v0.4 (19991125)
+#
+
+###
+# fixed up to use XML'd /. backdoor 7/31 by richardh@rahga.com
+# My only request if this gets included in infobot is that the
+# other header gets trimmed to 2 lines, dump the fluff ;) -rah
+#
+# added a status message so people know to install LWP - oznoid
+# also simplified the return code because it wasn't working.
+###
+
+package Slashdot;
+
+use strict;
+
+sub slashdotParse {
+ my @list;
+
+ foreach (@_) {
+ next unless (/<title>(.*?)<\/title>/);
+ my $title = $1;
+ $title =~ s/&\;/&/g;
+ push(@list, $title);
+ }
+
+ return @list;
+}
+
+sub Slashdot {
+ my @results = &::getURL("http://slashdot.org/slashdot.xml");
+ my $retval = "i could not get the headlines.";
+
+ if (scalar @results) {
+ my $prefix = 'Slashdot Headlines ';
+ my @list = &slashdotParse(@results);
+ $retval = &::formListReply(0, $prefix, @list);
+ }
+
+ &::performStrictReply($retval);
+}
+
+sub slashdotAnnounce {
+ my $file = "$::param{tempDir}/slashdot.xml";
+
+ my @Cxml = &::getURL("http://slashdot.org/slashdot.xml");
+ if (!scalar @Cxml) {
+ &::DEBUG("sdA: failure (Cxml == NULL).");
+ return;
+ }
+
+ if (! -e $file) { # first time run.
+ open(OUT, ">$file");
+ foreach (@Cxml) {
+ print OUT "$_\n";
+ }
+ close OUT;
+
+ return;
+ }
+
+ my @Oxml;
+ open(IN, $file);
+ while (<IN>) {
+ chop;
+ push(@Oxml,$_);
+ }
+ close IN;
+
+ my @Chl = &slashdotParse(@Cxml);
+ my @Ohl = &slashdotParse(@Oxml);
+
+ my @new;
+ foreach (@Chl) {
+ last if ($_ eq $Ohl[0]);
+ push(@new, $_);
+ }
+
+ if (scalar @new == 0) {
+ &::status("Slashdot: no new headlines.");
+ return;
+ }
+
+ if (scalar @new == scalar @Chl) {
+ &::DEBUG("sdA: scalar(new) == scalar(Chl). bad?");
+ }
+
+ open(OUT,">$file");
+ foreach (@Cxml) {
+ print OUT "$_\n";
+ }
+ close OUT;
+
+ return "Slashdot: News for nerds, stuff that matters -- ".
+ join(" \002::\002 ", @new);
+}
+
+1;
--- /dev/null
+#
+# spell.pl: interface to aspell/ispell/spell
+# Author: Tim Riker <Tim@Rikers.org>
+# Source: extracted from UserExtra
+# Licensing: Artistic License (as perl itself)
+# Version: v0.1
+#
+# Copyright (c) 2005 Tim Riker
+#
+
+package spell;
+
+use strict;
+
+sub spell::spell {
+ my $query = shift;
+ if ($query =~ m/[^[:alpha:]]/) {
+ return('only one word of alphabetic characters supported');
+ }
+
+ my $binary;
+ my @binaries = (
+ '/usr/bin/aspell',
+ '/usr/bin/ispell',
+ '/usr/bin/spell'
+ );
+
+ foreach (@binaries) {
+ if (-x $_) {
+ $binary=$_;
+ last;
+ }
+ }
+
+ if (!$binary) {
+ return('no binary found.');
+ }
+
+ if (!&::validExec($query)) {
+ return('argument appears to be fuzzy.');
+ }
+
+ my $reply = "I can't find alternate spellings for '$query'";
+
+ foreach (`/bin/echo '$query' | $binary -a -S`) {
+ chop;
+ last if !length; # end of query.
+
+ if (/^\@/) { # intro line.
+ next;
+ } elsif (/^\*/) { # possibly correct.
+ $reply = "'$query' may be spelled correctly";
+ last;
+ } elsif (/^\&/) { # possible correction(s).
+ s/^\& (\S+) \d+ \d+: //;
+ my @array = split(/,? /);
+
+ $reply = "possible spellings for $query: @array";
+ last;
+ } elsif (/^\+/) {
+ &::DEBUG("spell: '+' found => '$_'.");
+ last;
+ } elsif (/^# (.*?) 0$/) {
+ # none found.
+ last;
+ } else {
+ &::DEBUG("spell: unknown: '$_'.");
+ }
+ }
+
+ return($reply);
+}
+
+sub spell::query {
+ &::performStrictReply(&spell(@_));
+ return;
+}
+
+1;
+# vim: ts=2 sw=2
--- /dev/null
+# This program is distributed under the same terms as infobot.
+
+package wikipedia;
+use strict;
+
+my $missing;
+my $wikipedia_base_url = 'http://www.wikipedia.org/wiki/';
+my $wikipedia_search_url = $wikipedia_base_url . 'Special:Search?';
+my $wikipedia_export_url = $wikipedia_base_url . 'Special:Export/';
+
+BEGIN {
+ # utility functions for encoding the wikipedia request
+ eval "use URI::Escape";
+ if ($@) {
+ $missing++;
+ }
+
+ eval "use LWP::UserAgent";
+ if ($@) {
+ $missing++;
+ }
+
+ eval "use HTML::Entities";
+ if ($@) {
+ $missing++;
+ }
+}
+
+sub wikipedia {
+ return '' if $missing;
+ my ($phrase) = @_;
+ my ($reply, $valid_result) = wikipedia_lookup(@_);
+ if ($reply) {
+ &::performStrictReply($reply);
+ } else {
+ &::performStrictReply("'$phrase' not found in Wikipedia. Perhaps try a different spelling or case?");
+ }
+}
+
+sub wikipedia_silent {
+ return '' if $missing;
+ my ($reply, $valid_result) = wikipedia_lookup(@_);
+ if ($valid_result and $reply) {
+ &::performStrictReply($reply);
+ }
+}
+
+sub wikipedia_lookup {
+ my ($phrase) = @_;
+ &::DEBUG("wikipedia($phrase)");
+
+ my $ua = new LWP::UserAgent;
+ $ua->proxy('http', $::param{'httpProxy'}) if (&::IsParam('httpProxy'));
+ # Let's pretend
+ $ua->agent("Mozilla/5.0 " . $ua->agent);
+ $ua->timeout(5);
+
+ # chop ? from the end
+ $phrase =~ s/\?$//;
+ # convert phrase to wikipedia conventions
+# $phrase = uri_escape($phrase);
+# $phrase =~ s/%20/+/g;
+# $phrase =~ s/%25/%/g;
+ $phrase =~ s/ /+/g;
+
+ # using the search form will make the request case-insensitive
+ # HEAD will follow redirects, catching the first mode of redirects
+ # that wikipedia uses
+ my $url = $wikipedia_search_url . 'search=' . $phrase . '&go=Go';
+ my $req = HTTP::Request->new('HEAD', $url);
+ $req->header('Accept-Language' => 'en');
+ &::DEBUG($url);
+
+ my $res = $ua->request($req);
+ &::DEBUG($res->code);
+
+ if (!$res->is_success) {
+ return("Wikipedia might be temporarily unavailable (".$res->code."). Please try again in a few minutes...",
+ 0);
+ } else {
+ # we have been redirected somewhere
+ # (either content or the generic Search form)
+ # let's find the title of the article
+ $url = $res->request->uri;
+ $phrase = $url;
+ $phrase =~ s/.*\/wiki\///;
+
+ if (!$res->code == '200') {
+ return("Wikipedia might be temporarily unavailable or something is broken (".$res->code."). Please try again later...",
+ 0);
+ } else {
+ if ($url =~ m/Special:Search/) {
+ # we were sent to the the search page
+ return("I couldn't find a matching article in wikipedia, look for yerselves: " . $url,
+ 0);
+ } else {
+ # we hit content, let's retrieve it
+ my $text = wikipedia_get_text($phrase);
+
+ # filtering unprintables
+ $text =~ s/[[:cntrl:]]//g;
+ # filtering headings
+ $text =~ s/==+[^=]*=+//g;
+ # filtering wikipedia tables
+ $text =~ s/\{\|[^}]+\|\}//g;
+ # some people cannot live without HTML tags, even in a wiki
+ # $text =~ s/<div.*>//gi;
+ # $text =~ s/<!--.*>//gi;
+ # $text =~ s/<[^>]*>//g;
+ # or HTML entities
+ $text =~ s/&/&/g;
+ decode_entities($text);
+ # or tags, again
+ $text =~ s/<[^>]*>//g;
+ #$text =~ s/[&#]+[0-9a-z]+;//gi;
+ # filter wikipedia tags: [[abc: def]]
+ $text =~ s/\[\[[[:alpha:]]*:[^]]*\]\]//gi;
+ # {{abc}}:tag
+ $text =~ s/\{\{[[:alpha:]]+\}\}:[^\s]+//gi;
+ # {{abc}}
+ $text =~ s/\{\{[[:alpha:]]+\}\}//gi;
+ # unescape quotes
+ $text =~ s/'''/'/g;
+ $text =~ s/''/"/g;
+ # filter wikipedia links: [[tag|link]] -> link
+ $text =~ s/\[\[[^]]+\|([^]]+)\]\]/$1/g;
+ # [[link]] -> link
+ $text =~ s/\[\[([^]]+)\]\]/$1/g;
+ # shrink whitespace
+ $text =~ s/[[:space:]]+/ /g;
+ # chop leading whitespace
+ $text =~ s/^ //g;
+
+ # shorten article to first one or two sentences
+ # new: we rely on the output function to know what to do
+ # with long messages
+ #$text = substr($text, 0, 330);
+ #$text =~ s/(.+)\.([^.]*)$/$1./g;
+
+ return('At ' . $url . " (URL), Wikipedia explains: " . $text,
+ 1);
+ }
+ }
+ }
+}
+
+sub wikipedia_get_text {
+ return '' if $missing;
+ my ($article) = @_;
+ &::DEBUG("wikipedia_get_text($article)");
+
+ my $ua = new LWP::UserAgent;
+ $ua->proxy('http', $::param{'httpProxy'}) if (&::IsParam('httpProxy'));
+ # Let's pretend
+ $ua->agent("Mozilla/5.0 " . $ua->agent);
+ $ua->timeout(5);
+
+ &::DEBUG($wikipedia_export_url . $article);
+ my $req = HTTP::Request->new('GET', $wikipedia_export_url .
+ $article);
+ $req->header('Accept-Language' => 'en');
+ $req->header('Accept-Charset' => 'utf-8');
+
+ my $res = $ua->request($req);
+ my ($title, $redirect, $text);
+ &::DEBUG($res->code);
+
+ if ($res->is_success) {
+ if ($res->code == '200' ) {
+ foreach (split(/\n/, $res->as_string)) {
+ if (/<title>(.*?)<\/title>/) {
+ $title = $1;
+ $title =~ s/&\;/&/g;
+ } elsif (/#REDIRECT\s*\[\[(.*?)\]\]/i) {
+ $redirect = $1;
+ $redirect =~ tr/ /_/;
+ &::DEBUG('wiki redirect to ' . $redirect);
+ last;
+ } elsif (/<text[^>]*>(.*)/) {
+ $text = '"' . $1;
+ } elsif (/(.*)<\/text>/) {
+ $text = $text . ' ' . $1 . '"';
+ last;
+ } elsif ($text) {
+ $text = $text . ' ' . $_;
+ }
+ }
+ &::DEBUG("wikipedia returned text: " . $text .
+ ', redirect ' . $redirect. "\n");
+
+ if (!$redirect and !$text) {
+ return ($res->as_string);
+ }
+ return ($text or wikipedia_get_text($redirect))
+ }
+ }
+
+}
+
+1;
--- /dev/null
+#
+# wtf.pl: interface to bsd wtf
+# Author: Tim Riker <Tim@Rikers.org>
+# Source: modified from jethro's patch
+# Licensing: Artistic License (as perl itself)
+# Version: v0.1
+#
+# Copyright (c) 2005 Tim Riker
+#
+
+package wtf;
+
+use strict;
+
+sub wtf::wtf {
+ my $query = shift;
+ my $binary;
+ my @binaries = (
+ '/usr/games/wtf',
+ '/usr/local/bin/wtf'
+ );
+ foreach (@binaries) {
+ if (-x $_) {
+ $binary=$_;
+ last;
+ }
+ }
+ if (!$binary) {
+ return("no binary found.");
+ }
+ if ($query =~ /^$|[^\w]/){
+ return("usage: wtf <foo>.");
+ }
+ if (!&::validExec($query)) {
+ return("argument appears to be fuzzy.");
+ }
+
+ my $reply ='';
+ foreach (`$binary '$query' 2>&1`){
+ $reply .= $_;
+ }
+ $reply =~ s/\n/ /;
+ chomp($reply);
+ return($reply);
+}
+
+sub wtf::query {
+ &::performStrictReply(&wtf(@_));
+ return;
+}
+
+1;
+# vim: ts=2 sw=2
--- /dev/null
+package zfi;
+
+# Search Zaurus Feeds Index (ZFI)
+# Version 1.0
+# Released 02 Oct 2002
+
+# Based on ZSI package by Darien Kruss <darien@kruss.com>
+# Modified by Jordan Wiens <jordan@d0pe.com> (numatrix on #zaurus) and
+# Eric Lin <anselor@d0pe.com> (anselor on #zaurus) to search ZFI instead of ZSI
+
+# This script relies on the following page returning results
+# http://zaurii.com/zfi/zfibot.php
+# Returns the 5 latest/newest entries
+
+# http://zaurii.com/zfi/zfibot.php?query=XXXX
+# Returns all matches where XXX is in the name, description, etc
+
+# Returned matches are pipe-separated, one record per line
+# name|URL|description
+
+# These are the phrases we get called for:
+
+# 'zfi' or 'zfi <search>'
+
+# We reply publicly or privately, depending how we were called
+
+use strict;
+
+my $no_zfi;
+
+BEGIN {
+ $no_zfi = 0;
+ eval "use LWP::UserAgent";
+ $no_zfi++ if ($@);
+}
+
+sub queryText {
+ my ($query) = @_;
+
+ if ($no_zfi) {
+ &::status("zfi module requires LWP::UserAgent.");
+ return '';
+ }
+
+ my $res_return = 5;
+
+ my $ua = new LWP::UserAgent;
+ $ua->proxy('http', $::param{'httpProxy'}) if (&::IsParam('httpProxy'));
+
+ $ua->timeout(10);
+
+ my $searchpath;
+ if ($query) {
+ $searchpath = "http://zaurii.com/zfi/zfibot.php?query=$query";
+ } else {
+ $searchpath = "http://zaurii.com/zfi/zfibot.php";
+ }
+
+ my $request = new HTTP::Request('GET', "$searchpath");
+ my $response = $ua->request($request);
+
+ if (!$response->is_success) {
+ return "Something failed in connecting to the ZFI web server. Try again later.";
+ }
+
+ my $content = $response->content;
+
+ if ($content =~ /No entries found/im) {
+ return "No results were found searching ZFI for '$query'.";
+ }
+
+ my $res_count = 0; #local counter
+ my $res_display = 0; #results displayed
+
+ my @lines = split(/\n/,$content);
+
+ my $result = '';
+ foreach my $line (@lines) {
+ if (length($line) > 10) {
+ my ($name, $href, $desc) = split(/\|/,$line);
+
+ if ($res_count < $res_return) {
+ $result .= "$name ($desc) $href : ";
+ $res_display ++;
+ }
+ $res_count ++;
+ }
+ }
+
+ if (($query) && ($res_count > $res_display)) {
+ $result .= "$res_display of $res_count shown. All at http://zaurii.com/zfi/index.phtml?p=r&r=$query";
+ }
+
+ return $result;
+}
+
+sub query {
+ my ($args) = @_;
+ &::performStrictReply(&queryText($args));
+ return;
+}
+
+1;
+# vim: shiftwidth=2 tabstop=2
+__END__
--- /dev/null
+package zsi;
+
+# Search Zaurus Software Index (ZSI)
+# Version 1.0
+# Released 26 Aug 2002
+
+# Developed by Darien Kruss <darien@kruss.com>
+# http://zaurus.kruss.com/
+# usually hangs out on #zaurus as 'darienm'
+
+# This script relies on the following page returning results
+# http://killefiz.de/zaurus/zsibot.php
+# Returns the 5 latest/newest entries
+
+# http://killefiz.de/zaurus/zsibot.php?query=XXXX
+# Returns all matches where XXX is in the name, description, etc
+
+# Returned matches are pipe-separated, one record per line
+# name|URL|description
+
+# These are the phrases we get called for:
+
+# 'zsi' or 'zsi <search>'
+
+# We reply publicly or privately, depending how we were called
+
+my $no_zsi;
+
+use strict;
+
+BEGIN {
+ $no_zsi = 0;
+ eval "use LWP::UserAgent";
+ $no_zsi++ if ($@);
+}
+
+sub queryText {
+ my ($query) = @_;
+
+ if ($no_zsi) {
+ &::status("zsi module requires LWP::UserAgent.");
+ return '';
+ }
+
+ my $res_return = 5;
+
+ my $ua = new LWP::UserAgent;
+ $ua->proxy('http', $::param{'httpProxy'}) if (&::IsParam('httpProxy'));
+
+ $ua->timeout(10);
+
+ my $searchpath;
+ if ($query) {
+ $searchpath = "http://killefiz.de/zaurus/zsibot.php?query=$query";
+ } else {
+ $searchpath = "http://killefiz.de/zaurus/zsibot.php";
+ }
+
+ my $request = new HTTP::Request('GET', "$searchpath");
+ my $response = $ua->request($request);
+
+ if (!$response->is_success) {
+ return "Something failed in connecting to the ZSI web server. Try again later.";
+ }
+
+ my $content = $response->content;
+
+ if ($content =~ /No entries found/im) {
+ return "No results were found searching ZSI for '$query'.";
+ }
+
+ my $res_count = 0; #local counter
+ my $res_display = 0; #results displayed
+
+ my @lines = split(/\n/,$content);
+
+ my $result = '';
+ foreach my $line (@lines) {
+ if (length($line) > 10) {
+ my ($name, $href, $desc) = split(/\|/,$line);
+
+ if ($res_count < $res_return) {
+ $result .= "$name ($desc) $href : ";
+ $res_display ++;
+ }
+ $res_count ++;
+ }
+ }
+
+ if (($query) && ($res_count > $res_display)) {
+ $result .= "$res_display of $res_count shown. All at http://killefiz.de/zaurus/search.php?q=$query";
+ }
+
+ return $result;
+}
+
+sub query {
+ my ($args) = @_;
+ &::performStrictReply(&queryText($args));
+ return;
+}
+
+1;
+# vim: shiftwidth=2 tabstop=2
+__END__
--- /dev/null
+#
+# Net.pl: FTP//HTTP helper
+# Author: dms
+# Version: v0.1 (20000309)
+# Created: 20000309
+#
+
+use strict;
+
+use vars qw(%ftp %param);
+
+# Usage: &ftpGet($host,$dir,$file,[$lfile]);
+sub ftpGet {
+ my ($host,$dir,$file,$lfile) = @_;
+ my $verbose_ftp = 1;
+
+ return unless &loadPerlModule("Net::FTP");
+
+ &status("FTP: opening connection to $host.") if ($verbose_ftp);
+ my $ftp = Net::FTP->new($host,
+ 'Timeout' => 1*60,
+### 'BlockSize' => 1024, # ???
+ );
+
+ return if ($@);
+
+ # login.
+ if ($ftp->login()) {
+ &status("FTP: logged in successfully.") if ($verbose_ftp);
+ } else {
+ &status("FTP: login failed.");
+ $ftp->quit();
+ return 0;
+ }
+
+ # change directories.
+ if ($ftp->cwd($dir)) {
+ &status("FTP: changed dirs to $dir.") if ($verbose_ftp);
+ } else {
+ &status("FTP: cwd dir ($dir) does not exist.");
+ $ftp->quit();
+ return 0;
+ }
+
+ # get the size of the file.
+ my ($size, $lsize);
+ if ($size = $ftp->size($file)) {
+ &status("FTP: file size is $size") if ($verbose_ftp);
+ my $thisfile = $file || $lfile;
+
+ if ( -f $thisfile) {
+ $lsize = -s $thisfile;
+ if ($_ != $lsize) {
+ &status("FTP: local size is $lsize; downloading.") if ($verbose_ftp);
+ } else {
+ &status("FTP: same size; skipping.");
+ system("touch $thisfile"); # lame hack.
+ $ftp->quit();
+ return 1;
+ }
+ }
+ } else {
+ &status("FTP: file does not exist.");
+ $ftp->quit();
+ return 0;
+ }
+
+ my $start_time = &timeget();
+ if (defined $lfile) {
+ &status("FTP: getting $file as $lfile.") if ($verbose_ftp);
+ $ftp->get($file,$lfile);
+ } else {
+ &status("FTP: getting $file.") if ($verbose_ftp);
+ $ftp->get($file);
+ }
+
+ if (defined $lsize) {
+ &DEBUG("FTP: locsize => '$lsize'.");
+ if ($size != $lsize) {
+ &FIXME("FTP: downloaded file seems truncated.");
+ }
+ }
+
+ my $delta_time = &timedelta($start_time);
+ if ($delta_time > 0 and $verbose_ftp) {
+ &status(sprintf("FTP: %.02f sec to complete.", $delta_time));
+ my ($rateunit,$rate) = ('B', $size / $delta_time);
+ if ($rate > 1024) {
+ $rate /= 1024;
+ $rateunit = 'kB';
+ }
+ &status(sprintf("FTP: %.01f ${rateunit}/sec.", $rate));
+ }
+
+ $ftp->quit();
+
+ return 1;
+}
+
+# Usage: &ftpList($host,$dir);
+sub ftpList {
+ my ($host,$dir) = @_;
+ my $verbose_ftp = 1;
+
+ return unless &loadPerlModule("Net::FTP");
+
+ &status("FTP: opening connection to $host.") if ($verbose_ftp);
+ my $ftp = Net::FTP->new($host,'Timeout'=>60);
+
+ return if ($@);
+
+ # login.
+ if ($ftp->login()) {
+ &status("FTP: logged in successfully.") if ($verbose_ftp);
+ } else {
+ &status("FTP: login failed.");
+ $ftp->quit();
+ return;
+ }
+
+ # change directories.
+ if ($ftp->cwd($dir)) {
+ &status("FTP: changed dirs to $dir.") if ($verbose_ftp);
+ } else {
+ &status("FTP: cwd dir ($dir) does not exist.");
+ $ftp->quit();
+ return;
+ }
+
+ &status("FTP: doing ls.") if ($verbose_ftp);
+ foreach ($ftp->dir()) {
+ # modes d uid gid size month day time file.
+ if (/^(\S+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+) (\S{3})\s+(\d+) \d+:\d+ (.*)$/) {
+ # name = size.
+ $ftp{$8} = $5;
+ } else {
+ &DEBUG("FTP: UNKNOWN => '$_'.");
+ }
+ }
+ &status("FTP: ls done. ". scalar(keys %ftp) ." entries.");
+ $ftp->quit();
+
+ return %ftp;
+}
+
+### LWP.
+# Usage: &getURL($url, [$post]);
+# TODO: rename this to getHTTP
+sub getURL {
+ my ($url,$post) = @_;
+ my ($ua,$res,$req);
+
+ return unless &loadPerlModule("LWP::UserAgent");
+
+ $ua = new LWP::UserAgent;
+ $ua->proxy('http', $param{'httpProxy'}) if &IsParam('httpProxy');
+
+ if (defined $post) {
+ $req = new HTTP::Request('POST',$url);
+ $req->content_type('application/x-www-form-urlencoded');
+ $req->content($post);
+ } else {
+ $req = new HTTP::Request('GET',$url);
+ }
+
+ &status("getURL: getting '$url'");
+ my $time = time();
+ $res = $ua->request($req);
+ my $size = length($res->content);
+ if ($size and time - $time) {
+ my $rate = int( $size/1000/(time - $time) );
+ &status("getURL: Done (took ".&Time2String(time - $time).", $rate k/sec)");
+ }
+
+ # return NULL upon error.
+ return unless ($res->is_success);
+
+ return(split '\n', $res->content);
+}
+
+sub getURLAsFile {
+ my ($url,$file) = @_;
+ my ($ua,$res,$req);
+ my $time = time();
+
+ unless (&loadPerlModule('LWP::UserAgent')) {
+ &::DEBUG('getURLAsFile: LWP::UserAgent not installed');
+ return;
+ }
+
+ $ua = new LWP::UserAgent;
+ $ua->proxy('http', $param{'httpProxy'}) if &IsParam('httpProxy');
+ $req = HTTP::Request->new('GET', $url);
+ &status("getURLAsFile: getting '$url' as '$file'");
+ $res = $ua->request($req, $file);
+
+ my $delta_time = time() - $time;
+ if ($delta_time) {
+ my $size = -s $file || 0;
+ my $rate = int($size / $delta_time / 1024);
+ &status("getURLAsFile: Done. ($rate kB/sec)");
+ }
+
+ return $res;
+}
+
+1;
--- /dev/null
+###
+### Process.pl: Kevin Lenzo 1997-1999
+###
+
+#
+# process the incoming message
+#
+
+use strict;
+
+use vars qw($who $msgType $addressed $message $ident $user $host $chan
+ $learnok $talkok $force_public_reply $noreply $addrchar
+ $literal $addressedother $userHandle $lobotomized);
+use vars qw(%channels %users %param %cache %chanconf %mask %orig %lang
+ );
+
+sub process {
+ $learnok = 0; # Able to learn?
+ $talkok = 0; # Able to yap?
+ $force_public_reply = 0;
+ $literal = 0;
+
+ return 'X' if $who eq $ident; # self-message.
+ return 'addressedother set' if ($addressedother);
+
+ $talkok = ($param{'addressing'} =~ /^OPTIONAL$/i or $addressed);
+ $learnok = 1 if ($addressed);
+ if ($param{'learn'} =~ /^HUNGRY$/i) {
+ $learnok = 1;
+ $addrchar = 1;
+ $talkok = 1;
+ }
+
+ &shmFlush(); # hack.
+
+ # hack to support channel +o as "+o" in bot user file.
+ # requires +O in user file.
+ # is $who arg lowercase?
+ if (exists $channels{$chan}{o}{ $orig{who} } && &IsFlag('O') eq 'O') {
+ &status("Gave $who/$chan +o (+O)\'ness");
+ $users{$userHandle}{FLAGS} .= 'o';
+ }
+
+ # check if we have our head intact.
+ if ($lobotomized) {
+ if ($addressed and IsFlag('o') eq 'o') {
+ my $delta_time = time() - ($cache{lobotomy}{$who} || 0);
+ &msg($who, "give me an unlobotomy.") if ($delta_time > 60*60);
+ $cache{lobotomy}{$who} = time();
+ }
+ return 'LOBOTOMY' unless IsFlag('A');
+ }
+
+ # talkMethod.
+ if ($param{'talkMethod'} =~ /^PRIVATE$/i) {
+ if ($msgType =~ /public/ and $addressed) {
+ &msg($who, "sorry. i'm in 'PRIVATE' talkMethod mode ".
+ "while you sent a message to me ${msgType}ly.");
+
+ return 'TALKMETHOD';
+ }
+ }
+
+ # join, must be done before outsider checking.
+ if ($message =~ /^join(\s+(.*))?\s*$/i) {
+ return 'join: not addr' unless ($addressed);
+
+ $2 =~ /^($mask{chan})(\s+(\S+))?/;
+ my($joinchan, $key) = (lc $1, $3);
+
+ if ($joinchan eq '') {
+ &help('join');
+ return;
+ }
+
+ if ($joinchan !~ /^$mask{chan}$/) {
+ &msg($who, "$joinchan is not a valid channel name.");
+ return;
+ }
+
+ if (&IsFlag('o') ne 'o') {
+ if (!exists $chanconf{$joinchan}) {
+ &msg($who, "I am not allowed to join $joinchan.");
+ return;
+ }
+
+ if (&validChan($joinchan)) {
+ &msg($who,"warn: I'm already on $joinchan, joining anyway...");
+ }
+ }
+ $cache{join}{$joinchan} = $who; # used for on_join self.
+
+ &status("JOIN $joinchan $key <$who>");
+ &msg($who, "joining $joinchan $key");
+ &joinchan($joinchan, $key);
+ &joinNextChan(); # hack.
+
+ return;
+ }
+
+ # 'identify'
+ if ($msgType =~ /private/ and $message =~ s/^identify//i) {
+ $message =~ s/^\s+|\s+$//g;
+ my @array = split / /, $message;
+
+ if ($who =~ /^_default$/i) {
+ &performStrictReply("you are too eleet.");
+ return;
+ }
+
+ if (!scalar @array or scalar @array > 2) {
+ &help('identify');
+ return;
+ }
+
+ my $do_nick = $array[1] || $who;
+
+ if (!exists $users{$do_nick}) {
+ &performStrictReply("nick $do_nick is not in user list.");
+ return;
+ }
+
+ my $crypt = $users{$do_nick}{PASS};
+ if (!defined $crypt) {
+ &performStrictReply("user $do_nick has no passwd set.");
+ return;
+ }
+
+ if (!&ckpasswd($array[0], $crypt)) {
+ &performStrictReply("invalid passwd for $do_nick.");
+ return;
+ }
+
+ my $mask = "$who!$user@".&makeHostMask($host);
+ ### TODO: prevent adding multiple dupe masks?
+ ### TODO: make &addHostMask() CMD?
+ &performStrictReply("Added $mask for $do_nick...");
+ $users{$do_nick}{HOSTS}{$mask} = 1;
+
+ return;
+ }
+
+ # 'pass'
+ if ($msgType =~ /private/ and $message =~ s/^pass//i) {
+ $message =~ s/^\s+|\s+$//g;
+ my @array = split ' ', $message;
+
+ if ($who =~ /^_default$/i) {
+ &performStrictReply("you are too eleet.");
+ return;
+ }
+
+ if (scalar @array != 1) {
+ &help('pass');
+ return;
+ }
+
+ # TODO: use &getUser()?
+ my $first = 1;
+ foreach (keys %users) {
+ if ($users{$_}{FLAGS} =~ /n/) {
+ $first = 0;
+ last;
+ }
+ }
+
+ if (!exists $users{$who} and !$first) {
+ &performStrictReply("nick $who is not in user list.");
+ return;
+ }
+
+ if ($first) {
+ &performStrictReply("First time user... adding you as Master.");
+ $users{$who}{FLAGS} = 'aemnorst';
+ }
+
+ my $crypt = $users{$who}{PASS};
+ if (defined $crypt) {
+ &performStrictReply("user $who already has pass set.");
+ return;
+ }
+
+ if (!defined $host) {
+ &WARN("pass: host == NULL.");
+ return;
+ }
+
+ if (!scalar keys %{ $users{$who}{HOSTS} }) {
+ my $mask = "*!$user@".&makeHostMask($host);
+ &performStrictReply("Added hostmask '\002$mask\002' to $who");
+ $users{$who}{HOSTS}{$mask} = 1;
+ }
+
+ $crypt = &mkcrypt($array[0]);
+ $users{$who}{PASS} = $crypt;
+ &performStrictReply("new pass for $who, crypt $crypt.");
+
+ return;
+ }
+
+ # allowOutsiders.
+ if (&IsParam('disallowOutsiders') and $msgType =~ /private/i) {
+ my $found = 0;
+
+ foreach (keys %channels) {
+ # don't test for $channel{_default} elsewhere !!!
+ next if (/^\s*$/ || /^_?default$/);
+ next unless (&IsNickInChan($who,$_));
+
+ $found++;
+ last;
+ }
+
+ if (!$found and scalar(keys %channels)) {
+ &status("OUTSIDER <$who> $message");
+ return 'OUTSIDER';
+ }
+ }
+
+ # override msgType.
+ if ($msgType =~ /public/ and $message =~ s/^\+//) {
+ &status("Process: '+' flag detected; changing reply to public");
+ $msgType = 'public';
+ $who = $chan; # major hack to fix &msg().
+ $force_public_reply++;
+ # notice is still NOTICE but to whole channel => good.
+ }
+
+ # User Processing, for all users.
+ if ($addressed) {
+ my $retval;
+ return 'SOMETHING parseCmdHook' if &parseCmdHook($message);
+
+ $retval = &userCommands();
+ return unless (defined $retval);
+ return if ($retval eq $noreply);
+ }
+
+ ###
+ # once useless messages have been parsed out, we match them.
+ ###
+
+ # confused? is this for infobot communications?
+ foreach (keys %{ $lang{'confused'} }) {
+ my $y = $_;
+
+ next unless ($message =~ /^\Q$y\E\s*/);
+ return 'CONFUSO';
+ }
+
+ # hello. [took me a while to fix this. -xk]
+ if ($orig{message} =~ /^(\Q$ident\E\S?[:, ]\S?)?\s*(h(ello|i( there)?|owdy|ey|ola))( \Q$ident\E)?\s*$/i) {
+ return '' unless ($talkok);
+
+ # 'mynick: hi' or 'hi mynick' or 'hi'.
+ &status("somebody said hello");
+
+ # 50% chance of replying to a random greeting when not addressed
+ if (!defined $5 and $addressed == 0 and rand() < 0.5) {
+ &status("not returning unaddressed greeting");
+ return;
+ }
+
+ # customized random message.
+ my $tmp = (rand() < 0.5) ? ", $who" : '';
+ &performStrictReply( &getRandom(keys %{ $lang{'hello'} }) . $tmp );
+ return;
+ }
+
+ # greetings.
+ if ($message =~ /how (the hell )?are (ya|you)( doin\'?g?)?\?*$/) {
+
+ &performReply(&getRandom(keys %{ $lang{'howareyou'} }));
+ return;
+ }
+
+ # praise.
+ if ($message =~ /you (rock|rewl|rule|are so+ coo+l)/ ||
+ $message =~ /(good (bo(t|y)|g([ui]|r+)rl))|(bot( |\-)?snack)/i)
+ {
+ return 'praise: no addr' unless ($addressed);
+
+ &performReply(&getRandom(keys %{ $lang{'praise'} }));
+ return;
+ }
+
+ # thanks.
+ if ($message =~ /^than(ks?|x)( you)?( \S+)?/i) {
+ return 'thank: no addr' unless ($message =~ /$ident/ or $talkok);
+
+ &performReply( &getRandom(keys %{ $lang{'welcome'} }) );
+ return;
+ }
+
+ ###
+ ### bot commands...
+ ###
+
+ # karma. set...
+ if ($msgType =~ /public/i && $message =~ /^(\S+)(--|\+\+)\s*$/ &&
+ $addressed && &IsChanConfOrWarn('karma')
+ ) {
+ # to request factoids such as "g++" or "libstdc++", append "?" to the query.
+ my ($term,$inc) = (lc $1,$2);
+
+ if (lc $term eq lc $who) {
+ &msg($who, "please don't karma yourself");
+ return;
+ }
+
+ my $karma = &sqlSelect('stats', 'counter',
+ { nick => $term, type => 'karma' }) || 0;
+ if ($inc eq '++') {
+ $karma++;
+ } else {
+ $karma--;
+ }
+
+ &sqlSet('stats', {'nick' => $term, type => 'karma', channel => 'PRIVATE'}, {
+ 'time' => time(),
+ counter => $karma,
+ } );
+
+ return;
+ }
+
+ # here's where the external routines get called.
+ # if they return anything but null, that's the 'answer'.
+ if ($addressed) {
+ my $er = &Modules();
+ if (!defined $er) {
+ return 'SOMETHING 1';
+ }
+
+ # allow administration of bot via messages (default is DCC CHAT only)
+ if (&IsFlag('A')) {
+ &loadMyModule('UserDCC');
+ $er = &userDCC();
+ if (!defined $er) {
+ return 'SOMETHING 2';
+ }
+ }
+
+ if (0 and $addrchar) {
+ &msg($who, "I don't trust people to use the core commands while addressing me in a short-cut way.");
+ return;
+ }
+ }
+
+ if (&IsParam('factoids') and $param{'DBType'} =~ /^(mysql|sqlite(2)?|pgsql)$/i) {
+ &FactoidStuff();
+ } elsif ($param{'DBType'} =~ /^none$/i) {
+ return "NO FACTOIDS.";
+ } else {
+ &ERROR("INVALID FACTOID SUPPORT? ($param{'DBType'})");
+ &shutdown();
+ exit 0;
+ }
+}
+
+1;
--- /dev/null
+#
+# Shm.pl: Shared Memory stuff.
+# Author: dms
+# Version: 20000201
+# Created: 20000124
+#
+
+# use strict; # TODO
+
+use POSIX qw(_exit);
+
+sub openSHM {
+ my $IPC_PRIVATE = 0;
+ my $size = 2000;
+
+ if (&IsParam('noSHM')) {
+ &status("Shared memory: Disabled. WARNING: bot may become unreliable");
+ return 0;
+ }
+
+ if (defined( $_ = shmget($IPC_PRIVATE, $size, 0777) )) {
+ &status("Created shared memory (shm) key: [$_]");
+ return $_;
+ } else {
+ &ERROR("openSHM: failed.");
+ &ERROR("Please delete some shared memory with ipcs or ipcrm.");
+ exit 1;
+ }
+}
+
+sub closeSHM {
+ my ($key) = @_;
+ my $IPC_RMID = 0;
+
+ return '' if (!defined $key);
+
+ &shmFlush();
+ &status("Closed shared memory (shm) key: [$key]");
+ return shmctl($key, $IPC_RMID, 0);
+}
+
+sub shmRead {
+ my ($key) = @_;
+ my $position = 0;
+ my $size = 3*80;
+ my $retval = '';
+
+ return '' if (&IsParam('noSHM'));
+
+ if (shmread($key,$retval,$position,$size)) {
+ #&DEBUG("shmRead($key): $retval");
+ return $retval;
+ } else {
+ &ERROR("shmRead: failed: $!");
+ ### TODO: if this fails, never try again.
+ &openSHM();
+ return '';
+ }
+}
+
+sub shmWrite {
+ my ($key, $str) = @_;
+ my $position = 0;
+ my $size = 80*3;
+
+ return if (&IsParam('noSHM'));
+
+ if (length($str) > $size) {
+ &status("ERROR: length(str) (..)>$size...");
+ return;
+ }
+
+ if (length($str) == 0) {
+ # does $size overwrite the whole lot?
+ # if not, set to 2000.
+ if (!shmwrite($key, '', $position, $size)) {
+ &ERROR("shmWrite: failed: $!");
+ }
+ return;
+ }
+
+ my $read = &shmRead($key);
+ $read =~ s/\0+//g;
+ if ($read eq '') {
+ $str = sprintf("%s:%d:%d: ", $param{ircUser}, $bot_pid, time());
+ } else {
+ $str = $read ."||". $str;
+ }
+
+ if (!shmwrite($key, $str, $position, $size)) {
+ &DEBUG("shmWrite($key, $str)");
+ &ERROR("shmWrite: failed: $!");
+ }
+}
+
+##############
+### Helpers
+###
+
+# Usage: &addForked($name);
+# Return: 1 for success, 0 for failure.
+sub addForked {
+ my ($name) = @_;
+ my $forker_timeout = 360; # 6mins, in seconds.
+ $forker = $name;
+
+ if (!defined $name) {
+ &WARN("addForked: name == NULL.");
+ return 0;
+ }
+
+ foreach (keys %forked) {
+ my $n = $_;
+ my $time = time() - $forked{$n}{Time};
+ next unless ($time > $forker_timeout);
+
+ ### TODO: use &time2string()?
+ &WARN("Fork: looks like we lost '$n', executed $time ago");
+
+ my $pid = $forked{$n}{PID};
+ if (!defined $pid) {
+ &WARN("Fork: no pid for $n.");
+ delete $forked{$n};
+ next;
+ }
+
+ if ($pid == $bot_pid) {
+ # don't kill parent, just warn.
+ &status("Fork: pid == \$bot_pid == \$\$ ($bot_pid)");
+
+ } elsif ( -d "/proc/$pid") { # pid != bot_pid.
+ &status("Fork: killing $name ($pid)");
+ kill 9, $pid;
+ }
+
+ delete $forked{$n};
+ }
+
+ my $count = 0;
+ while (scalar keys %forked > 1) { # 2 or more == fail.
+ sleep 1;
+
+ if ($count > 3) { # 3 seconds.
+ my $list = join(', ', keys %forked);
+ if (defined $who) {
+ &msg($who, "exceeded allowed forked count (shm $shm): $list");
+ } else {
+ &status("Fork: I ran too many forked processes :) Giving up $name. Shm: $shm");
+ }
+
+ return 0;
+ }
+
+ $count++;
+ }
+
+ if (exists $forked{$name} and !scalar keys %{ $forked{$name} }) {
+ &WARN("addF: forked{$name} exists but is empty; deleting.");
+ undef $forked{$name};
+ }
+
+ if (exists $forked{$name} and scalar keys %{ $forked{$name} }) {
+ my $time = $forked{$name}{Time};
+ my $continue = 0;
+
+ $continue++ if ($forked{$name}{PID} == $$);
+
+ if ($continue) {
+ &WARN("hrm.. fork pid == mypid == $$; how did this happen?");
+
+ } elsif ( -d "/proc/$forked{$name}{PID}") {
+ &status("fork: still running; good. BAIL OUT.");
+ return 0;
+
+ } else {
+ &WARN("Found dead fork; removing and resetting.");
+ $continue = 1;
+ }
+
+ if ($continue) {
+ # NOTHING.
+
+ } elsif (time() - $time > 900) { # stale fork > 15m.
+ &status("forked: forked{$name} presumably exited without notifying us.");
+
+ } else { # fresh fork.
+ &msg($who, "$name is already running ". &Time2String(time() - $time));
+ return 0;
+ }
+ }
+
+ $forked{$name}{Time} = time();
+ $forked{$name}{PID} = $$;
+ $forkedtime = time();
+ $count{'Fork'}++;
+ return 1;
+}
+
+sub delForked {
+ my ($name) = @_;
+
+ return if ($$ == $bot_pid);
+
+ if (!defined $name) {
+ &WARN("delForked: name == NULL.");
+ POSIX::_exit(0);
+ }
+
+ if ($name =~ /\.pl/) {
+ &WARN("dF: name is name of source file ($name). FIX IT!");
+ }
+
+ &showProc(); # just for informational purposes.
+
+ if (exists $forked{$name}) {
+ my $timestr = &Time2String(time() - $forked{$name}{Time});
+ &status("fork: took $timestr for $name.");
+ &shmWrite($shm,"DELETE FORK $name");
+ } else {
+ &ERROR("delForked: forked{$name} does not exist. should not happen.");
+ }
+
+ &status("--- fork finished for '$name' ---");
+
+ POSIX::_exit(0);
+}
+
+sub shmFlush {
+ return if ($$ != $::bot_pid); # fork protection.
+
+ if (@_) {
+ &ScheduleThis(15, 'shmFlush');
+ return if ($_[0] eq '2');
+ }
+
+ my $time;
+ my $shmmsg = &shmRead($shm);
+ # remove padded \0's.
+ $shmmsg =~ s/\0//g;
+ return if (length($shmmsg) == 0);
+ if ($shmmsg =~ s/^(\S+):(\d+):(\d+): //) {
+ my $n = $1;
+ my $pid = $2;
+ $time = $3;
+ } else {
+ &status("warn: shmmsg='$shmmsg'.");
+ return;
+ }
+
+ foreach (split '\|\|', $shmmsg) {
+ next if (/^$/);
+ &VERB("shm: Processing '$_'.",2);
+
+ if (/^DCC SEND (\S+) (\S+)$/) {
+ my ($nick,$file) = ($1,$2);
+ if (exists $dcc{'SEND'}{$who}) {
+ &msg($nick, "DCC already active.");
+ } else {
+ &DEBUG("shm: dcc sending $2 to $1.");
+ $conn->new_send($1,$2);
+ $dcc{'SEND'}{$who} = time();
+ }
+ } elsif (/^SET FORKPID (\S+) (\S+)/) {
+ $forked{$1}{PID} = $2;
+ } elsif (/^DELETE FORK (\S+)$/) {
+ delete $forked{$1};
+ } elsif (/^EVAL (.*)$/) {
+ &DEBUG("evaling '$1'.");
+ eval $1;
+ } else {
+ &DEBUG("shm: unknown msg. ($_)");
+ }
+ }
+
+ &shmWrite($shm,'') if ($shmmsg ne '');
+}
+
+1;
--- /dev/null
+#
+# UserExtra.pl: User Commands, Public.
+# Author: dms
+#
+
+use strict;
+use vars qw($message $arg $qWord $verb $lobotomized $who $result $chan
+ $conn $msgType $query $talkchannel $ident $memusage);
+use vars qw(%channels %chanstats %cmdstats %count %forked %ircstats %param
+ %cache %mask %userstats);
+
+### hooks get added in CommandHooks.pl.
+
+###
+### Start of commands for hooks.
+###
+
+sub chaninfo {
+ my $chan = lc shift(@_);
+ my $mode;
+
+ if ($chan eq '') { # all channels.
+ my $i = keys %channels;
+ my $reply = "I'm on \002$i\002 ".&fixPlural('channel',$i);
+ my $tucount = 0; # total user count.
+ my $uucount = 0; # unique user count.
+ my %chans;
+ my @array;
+
+ ### line 1.
+ foreach (keys %channels) {
+ if ( /^\s*$/ or / / ) {
+ &status("chanstats: fe channels: chan == NULL.");
+ #&ircCheck();
+ next;
+ }
+ next if (/^_default$/);
+
+ $chans{$_} = scalar(keys %{ $channels{$_}{''} });
+ }
+ foreach $chan (sort {$chans{$b} <=> $chans{$a}} keys %chans) {
+ push(@array, "$chan/" . $chans{$chan});
+ }
+ &performStrictReply($reply.": ".join(', ', @array));
+
+ ### total user count.
+ foreach $chan (keys %channels) {
+ $tucount += scalar(keys %{ $channels{$chan}{''} });
+ }
+
+ ### unique user count.
+ my %nicks = ();
+ foreach $chan (keys %channels) {
+ my $nick;
+ foreach $nick (keys %{ $channels{$chan}{''} }) {
+ $nicks{$nick}++;
+ }
+ }
+ $uucount = scalar(keys %nicks);
+
+ my $chans = scalar(keys %channels);
+ &performStrictReply(
+ "i've cached \002$tucount\002 ". &fixPlural('user',$tucount).
+ ", \002$uucount\002 unique ". &fixPlural('user',$uucount).
+ ", distributed over \002$chans\002 ".
+ &fixPlural('channel', $chans)."."
+ );
+ &ircCheck();
+
+ return;
+ }
+
+ # channel specific.
+
+ if (&validChan($chan) == 0) {
+ &msg($who,"error: invalid channel \002$chan\002");
+ return;
+ }
+
+ # Step 1:
+ my @array;
+ foreach (sort keys %{ $chanstats{$chan} }) {
+ my $int = $chanstats{$chan}{$_};
+ next unless ($int);
+
+ push(@array, "\002$int\002 ". &fixPlural($_,$int));
+ }
+ my $reply = "On \002$chan\002, there ".
+ &fixPlural('has',scalar(@array)). " been ".
+ &IJoin(@array);
+
+ # Step 1b: check channel inconstencies.
+ $chanstats{$chan}{'Join'} ||= 0;
+ $chanstats{$chan}{'SignOff'} ||= 0;
+ $chanstats{$chan}{'Part'} ||= 0;
+
+ my $delta_stats = $chanstats{$chan}{'Join'}
+ - $chanstats{$chan}{'SignOff'}
+ - $chanstats{$chan}{'Part'};
+
+ if ($delta_stats) {
+ my $total = scalar(keys %{ $channels{$chan}{''} });
+ &status("chaninfo: join ~= signoff + part (drift of $delta_stats < $total).");
+
+ if ($delta_stats > $total) {
+ &ERROR("chaninfo: delta_stats exceeds total users.");
+ }
+ }
+
+ # Step 2:
+ undef @array;
+ my $type;
+ foreach ('v','o','') {
+ my $int = scalar(keys %{ $channels{$chan}{$_} });
+ next unless ($int);
+
+ $type = 'Voice' if ($_ eq 'v');
+ $type = 'Opped' if ($_ eq 'o');
+ $type = 'Total' if ($_ eq '');
+
+ push(@array,"\002$int\002 $type");
+ }
+ $reply .= ". At the moment, ". &IJoin(@array);
+
+ # Step 3:
+ my %new;
+ foreach (keys %userstats) {
+ next unless (exists $userstats{$_}{'Count'});
+ if ($userstats{$_}{'Count'} =~ /^\D+$/) {
+ &WARN("userstats{$_}{Count} is non-digit.");
+ next;
+ }
+
+ $new{$_} = $userstats{$_}{'Count'};
+ }
+
+ # TODO: show top 3 with percentages?
+ my($count) = (sort { $new{$b} <=> $new{$a} } keys %new)[0];
+ if ($count) {
+ $reply .= ". \002$count\002 has said the most with a total of \002$new{$count}\002 messages";
+ }
+ &performStrictReply("$reply.");
+}
+
+# Command statistics.
+sub cmdstats {
+ my @array;
+
+ if (!scalar(keys %cmdstats)) {
+ &performReply("no-one has run any commands yet");
+ return;
+ }
+
+ my %countstats;
+ foreach (keys %cmdstats) {
+ $countstats{ $cmdstats{$_} }{$_} = 1;
+ }
+
+ foreach (sort {$b <=> $a} keys %countstats) {
+ my $int = $_;
+ next unless ($int);
+
+ foreach (keys %{ $countstats{$int} }) {
+ push(@array, "\002$int\002 of $_");
+ }
+ }
+ &performStrictReply("command usage include ". &IJoin(@array).".");
+}
+
+# Factoid extension info. xk++
+sub factinfo {
+ my $faqtoid = lc shift(@_);
+ my $query = '';
+
+ if ($faqtoid =~ /^\-(\S+)(\s+(.*))$/) {
+ &msg($who,"error: individual factoid info queries not supported as yet.");
+ &msg($who,"it's possible that the factoid mistakenly begins with '-'.");
+ return;
+
+ $query = lc $1;
+ $faqtoid = lc $3;
+ }
+
+ &CmdFactInfo($faqtoid, $query);
+}
+
+sub factstats {
+ my $type = shift(@_);
+
+ &Forker('Factoids', sub {
+ &performStrictReply( &CmdFactStats($type) );
+ } );
+}
+
+sub karma {
+ my $target = lc( shift || $who );
+ my $karma = &sqlSelect('stats', 'counter',
+ { nick => $target, type => 'karma'}) || 0;
+
+ if ($karma != 0) {
+ &performStrictReply("$target has karma of $karma");
+ } else {
+ &performStrictReply("$target has neutral karma");
+ }
+}
+
+sub tell {
+ my $args = shift;
+ my ($target, $tell_obj) = ('','');
+ my $dont_tell_me = 0;
+ my $reply;
+
+ ### is this fixed elsewhere?
+ $args =~ s/\s+/ /g; # fix up spaces.
+ $args =~ s/^\s+|\s+$//g; # again.
+
+ # this one catches most of them
+ if ($args =~ /^(\S+) (-?)about (.*)$/i) {
+ $target = $1;
+ $tell_obj = $3;
+ $dont_tell_me = ($2) ? 1 : 0;
+
+ $tell_obj = $who if ($tell_obj =~ /^(me|myself)$/i);
+ $query = $tell_obj;
+ } elsif ($args =~ /^(\S+) where (\S+) can (\S+) (.*)$/i) {
+ # i'm sure this could all be nicely collapsed
+ $target = $1;
+ $tell_obj = $4;
+ $query = $tell_obj;
+
+ } elsif ($args =~ /^(\S+) (what|where) (.*?) (is|are)[.?!]*$/i) {
+ $target = $1;
+ $qWord = $2;
+ $tell_obj = $3;
+ $verb = $4;
+ $query = "$qWord $verb $tell_obj";
+
+ } elsif ($args =~ /^(.*?) to (\S+)$/i) {
+ $target = $3;
+ $tell_obj = $2;
+ $query = $tell_obj;
+ }
+
+ # check target type. Deny channel targets.
+ if ($target !~ /^$mask{nick}$/ or $target =~ /^$mask{chan}$/) {
+ &msg($who,"No, $who, I won't. (target invalid?)");
+ return;
+ }
+
+ $target = $talkchannel if ($target =~ /^us$/i);
+ $target = $who if ($target =~ /^(me|myself)$/i);
+
+ &status("tell: target = $target, query = $query");
+
+ # 'intrusive'.
+# if ($target !~ /^$mask{chan}$/ and !&IsNickInAnyChan($target)) {
+# &msg($who, "No, $target is not in any of my chans.");
+# return;
+# }
+
+ # self.
+ if ($target =~ /^\Q$ident\E$/i) {
+ &msg($who, "Isn't that a bit silly?");
+ return;
+ }
+
+ my $oldwho = $who;
+ my $oldmtype = $msgType;
+ $who = $target;
+ my $result = &doQuestion($tell_obj);
+ # ^ returns '0' if nothing was found.
+ $who = $oldwho;
+
+ # no such factoid.
+ if (!defined $result || $result =~ /^0?$/) {
+ $who = $target;
+ $msgType = 'private';
+
+ # support command redirection.
+ # recursive cmdHooks aswell :)
+ my $done = 0;
+ $done++ if &parseCmdHook($tell_obj);
+ $message = $tell_obj;
+ $done++ unless (&Modules());
+
+ &VERB("tell: setting old values of who and msgType.",2);
+ $who = $oldwho;
+ $msgType = $oldmtype;
+
+ if ($done) {
+ &msg($who, "told $target about CMD '$tell_obj'");
+ } else {
+ &msg($who, "i dunno what is '$tell_obj'.");
+ }
+
+ return;
+ }
+
+ # success.
+ &status("tell: <$who> telling $target about $tell_obj.");
+ if ($who ne $target) {
+ if ($dont_tell_me) {
+ &msg($who, "told $target about $tell_obj.");
+ } else {
+ &msg($who, "told $target about $tell_obj ($result)");
+ }
+
+ $reply = "$who wants you to know: $result";
+ } else {
+ $reply = "telling yourself: $result";
+ }
+
+ &msg($target, $reply);
+}
+
+sub countryStats {
+ if (exists $cache{countryStats}) {
+ &msg($who,"countrystats is already running!");
+ return;
+ }
+
+ if ($chan eq '') {
+ $chan = $_[0];
+ }
+
+ if ($chan eq '') {
+ &help('countrystats');
+ return;
+ }
+
+ $conn->who($chan);
+ $cache{countryStats}{chan} = $chan;
+ $cache{countryStats}{mtype} = $msgType;
+ $cache{countryStats}{who} = $who;
+ $cache{on_who_Hack} = 1;
+}
+
+sub do_countrystats {
+ $chan = $cache{countryStats}{chan};
+ $msgType = $cache{countryStats}{mtype};
+ $who = $cache{countryStats}{who};
+
+ my $total = 0;
+ my %cstats;
+ foreach (keys %{ $cache{nuhInfo} }) {
+ my $h = $cache{nuhInfo}{$_}{Host};
+
+ if ($h =~ /^.*\.(\D+)$/) { # host
+ $cstats{$1}++;
+ } else { # ip
+ $cstats{unresolve}++;
+ }
+ $total++;
+ }
+ my %count;
+ foreach (keys %cstats) {
+ $count{ $cstats{$_} }{$_} = 1;
+ }
+
+ my @list;
+ foreach (sort {$b <=> $a} keys %count) {
+ my $str = join(", ", sort keys %{ $count{$_} });
+# push(@list, "$str ($_)");
+ my $perc = sprintf("%.01f", 100 * $_ / $total);
+ $perc =~ s/\.0+$//;
+ push(@list, "$str ($_, $perc %)");
+ }
+
+ # TODO: move this into a scheduler
+ $msgType = 'private';
+ &performStrictReply( &formListReply(0, "Country Stats ", @list) );
+
+ delete $cache{countryStats};
+ delete $cache{on_who_Hack};
+}
+
+###
+### amalgamated commands.
+###
+
+sub userCommands {
+ # conversion: ascii.
+ if ($message =~ /^(asci*|chr) (\d+)$/) {
+ &DEBUG("ascii/chr called ...");
+ return unless (&IsChanConfOrWarn('allowConv'));
+
+ &DEBUG("ascii/chr called");
+
+ $arg = $2;
+ $result = chr($arg);
+ $result = 'NULL' if ($arg == 0);
+
+ &performReply( sprintf("ascii %s is '%s'", $arg, $result) );
+
+ return;
+ }
+
+ # conversion: ord.
+ if ($message =~ /^ord(\s+(.*))$/) {
+ return unless (&IsChanConfOrWarn('allowConv'));
+
+ $arg = $2;
+
+ if (!defined $arg or length $arg != 1) {
+ &help('ord');
+ return;
+ }
+
+ if (ord($arg) < 32) {
+ $arg = chr(ord($arg) + 64);
+ if ($arg eq chr(64)) {
+ $arg = 'NULL';
+ } else {
+ $arg = '^'.$arg;
+ }
+ }
+
+ &performReply( sprintf("'%s' is ascii %s", $arg, ord $arg) );
+ return;
+ }
+
+ # hex.
+ if ($message =~ /^hex(\s+(.*))?$/i) {
+ return unless (&IsChanConfOrWarn('allowConv'));
+ my $arg = $2;
+
+ if (!defined $arg) {
+ &help('hex');
+ return;
+ }
+
+ if (length $arg > 80) {
+ &msg($who, "Too long.");
+ return;
+ }
+
+ my $retval;
+ foreach (split //, $arg) {
+ $retval .= sprintf(" %X", ord($_));
+ }
+
+ &performStrictReply("$arg is$retval");
+
+ return;
+ }
+
+ # crypt.
+ if ($message =~ /^crypt\s+(\S*)?\s*(.*)?$/i) {
+&status("crypt: $1:$2:$3");
+ if ("$2" ne '') {
+ &performStrictReply(crypt($2, $1));
+ } else {
+ &performStrictReply(&mkcrypt($1));
+ }
+ return;
+ }
+
+ # cycle.
+ if ($message =~ /^(cycle)(\s+(\S+))?$/i) {
+ return unless (&hasFlag('o'));
+ my $chan = lc $3;
+
+ if ($chan eq '') {
+ if ($msgType =~ /public/) {
+ $chan = $talkchannel;
+ &DEBUG("cycle: setting chan to '$chan'.");
+ } else {
+ &help('cycle');
+ return;
+ }
+ }
+
+ if (&validChan($chan) == 0) {
+ &msg($who,"error: invalid channel \002$chan\002");
+ return;
+ }
+
+ &msg($chan, "I'm coming back. (courtesy of $who)");
+ &part($chan);
+### &ScheduleThis(5, 'getNickInUse') if (@_);
+ &status("Schedule rejoin in 5secs to $chan by $who.");
+ $conn->schedule(5, sub { &joinchan($chan); });
+
+ return;
+ }
+
+ # reload.
+ if ($message =~ /^reload$/i) {
+ return unless (&hasFlag('n'));
+
+ &status("USER reload $who");
+ &performStrictReply("reloading...");
+ my $modules = &reloadAllModules();
+ &performStrictReply("reloaded:$modules");
+ return;
+ }
+
+ # redir.
+ if ($message =~ /^redir(\s+(.*))?/i) {
+ return unless (&hasFlag('o'));
+ my $factoid = $2;
+
+ if (!defined $factoid) {
+ &help('redir');
+ return;
+ }
+
+ my $val = &getFactInfo($factoid, "factoid_value");
+ if (!defined $val or $val eq '') {
+ &msg($who, "error: '$factoid' does not exist.");
+ return;
+ }
+ &DEBUG("val => '$val'.");
+ my @list = &searchTable('factoids', "factoid_key",
+ "factoid_value", "^$val\$");
+
+ if (scalar @list == 1) {
+ &msg($who, "hrm... '$factoid' is unique.");
+ return;
+ }
+ if (scalar @list > 5) {
+ &msg($who, "A bit too many factoids to be redirected, hey?");
+ return;
+ }
+
+ my @redir;
+ &status("Redirect '$factoid' (". ($#list) .")...");
+ for (@list) {
+ my $x = $_;
+ next if (/^\Q$factoid\E$/i);
+
+ &status(" Redirecting '$_'.");
+ my $was = &getFactoid($_);
+ if ($was =~ /<REPLY> see/i) {
+ &status("warn: not redirecting a redirection.");
+ next;
+ }
+
+ &DEBUG(" was '$was'.");
+ push(@redir,$x);
+ &setFactInfo($x, "factoid_value", "<REPLY> see $factoid");
+ }
+ &status("Done.");
+
+ &msg($who, &formListReply(0, "'$factoid' is redirected to by '", @redir));
+
+ return;
+ }
+
+ # rot13 it.
+ if ($message =~ /^rot([0-9]*)(\s+(.*))?/i) {
+ my $reply = $3;
+
+ if (!defined $reply) {
+ &help('rot13');
+ return;
+ }
+ my $num = $1 % 26;
+ my $upper='ABCDEFGHIJKLMNOPQRSTUVWXYZ';
+ my $lower='abcdefghijklmnopqrstuvwxyz';
+ my $to=substr($upper,$num).substr($upper,0,$num).substr($lower,$num).substr($lower,0,$num);
+ eval "\$reply =~ tr/$upper$lower/$to/;";
+
+ #$reply =~ y/A-Za-z/N-ZA-Mn-za-m/;
+ &performStrictReply($reply);
+
+ return;
+ }
+
+ # cpustats.
+ if ($message =~ /^cpustats$/i) {
+ if ($^O !~ /linux/) {
+ &ERROR("cpustats: your OS is not supported yet.");
+ return;
+ }
+
+ ### poor method to get info out of file, please fix.
+ open(STAT,"/proc/$$/stat");
+ my $line = <STAT>;
+ chop $line;
+ my @data = split(/ /, $line);
+ close STAT;
+
+ # utime(13) + stime(14).
+ my $cpu_usage = sprintf("%.01f", ($data[13]+$data[14]) / 100 );
+ # cutime(15) + cstime (16).
+ my $cpu_usage2 = sprintf("%.01f", ($data[15]+$data[16]) / 100 );
+ my $time = time() - $^T;
+ my $raw_perc = $cpu_usage*100/$time;
+ 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) );
+
+ &performStrictReply("Total CPU usage: \002$cpu_usage\002 s ... ".
+ "Total used: \002$total\002 % ".
+ "(parent/child ratio: $ratio %)"
+ );
+
+ return;
+ }
+
+ # ircstats.
+ if ($message =~ /^ircstats?$/i) {
+ $ircstats{'TotalTime'} ||= 0;
+ $ircstats{'OffTime'} ||= 0;
+
+ my $count = $ircstats{'ConnectCount'};
+ my $format_time = &Time2String(time() - $ircstats{'ConnectTime'});
+ my $total_time = time() - $ircstats{'ConnectTime'} +
+ $ircstats{'TotalTime'};
+ my $reply;
+
+ my $connectivity = 100 * ($total_time - $ircstats{'OffTime'}) /
+ $total_time;
+ my $p = sprintf("%.03f", $connectivity);
+ $p =~ s/(\.\d*)0+$/$1/;
+ if ($p =~ s/\.0$//) {
+ # this should not happen... but why...
+ } else {
+ $p =~ s/\.$//
+ }
+
+ if ($total_time != (time() - $ircstats{'ConnectTime'}) ) {
+ my $tt_format = &Time2String($total_time);
+ &DEBUG("tt_format => $tt_format");
+ }
+
+ ### RECONNECT COUNT.
+ if ($count == 1) { # good.
+ $reply = "I'm connected to $ircstats{'Server'} and have been so".
+ " for $format_time";
+ } else {
+ $reply = "Currently I'm hooked up to $ircstats{'Server'} but only".
+ " for $format_time. ".
+ "I had to reconnect \002$count\002 times.".
+ " Connectivity: $p %";
+ }
+
+ ### REASON.
+ my $reason = $ircstats{'DisconnectReason'};
+ if (defined $reason) {
+ $reply .= ". I was last disconnected for '$reason'.";
+ }
+
+ &performStrictReply($reply);
+
+ return;
+ }
+
+ # status.
+ if ($message =~ /^statu?s$/i) {
+ my $startString = scalar(gmtime $^T);
+ my $upString = &Time2String(time() - $^T);
+ my ($puser,$psystem,$cuser,$csystem) = times;
+ my $factoids = &countKeys('factoids');
+ my $forks = 0;
+ foreach (keys %forked) {
+ $forks += scalar keys %{ $forked{$_} };
+ }
+ $forks /= 2;
+ $count{'Commands'} = 0;
+ foreach (keys %cmdstats) {
+ $count{'Commands'} += $cmdstats{$_};
+ }
+
+ &performStrictReply(
+ "Since $startString, there have been".
+ " \002$count{'Update'}\002 ".
+ &fixPlural('modification', $count{'Update'}).
+ ", \002$count{'Question'}\002 ".
+ &fixPlural('question',$count{'Question'}).
+ ", \002$count{'Dunno'}\002 ".
+ &fixPlural('dunno',$count{'Dunno'}).
+ ", \002$count{'Moron'}\002 ".
+ &fixPlural('moron',$count{'Moron'}).
+ " and \002$count{'Commands'}\002 ".
+ &fixPlural('command',$count{'Commands'}).
+ ". I have been awake for $upString this session, and ".
+ "currently reference \002$factoids\002 factoids. ".
+ "I'm using about \002$memusage\002 ".
+ "kB of memory. With \002$forks\002 active ".
+ &fixPlural('fork',$forks).
+ ". Process time user/system $puser/$psystem child $cuser/$csystem"
+ );
+
+ return;
+ }
+
+ # wantNick. xk++
+ # FIXME does not try to get nick 'back', just switches nicks
+ if ($message =~ /^wantNick\s(.*)?$/i) {
+ return unless (&hasFlag('o'));
+ my $wantnick = lc $1;
+ my $mynick = $conn->nick();
+
+ if ($mynick eq $wantnick) {
+ &msg($who, "I hope you're right. I'll try anyway (mynick=$mynick, wantnick=$wantnick).");
+ }
+
+ # fallback check, I guess. needed?
+ if (! &IsNickInAnyChan( $wantnick ) ) {
+ my $str = "attempting to change nick from $mynick to $wantnick";
+ &status($str);
+ &msg($who, $str);
+ &nick($wantnick);
+ return;
+ }
+
+ # idea from dondelecarlo :)
+ # TODO: use cache{nickserv}
+ if ($param{'nickServ_pass'}) {
+ my $str = "someone is using nick $wantnick; GHOSTing";
+ &status($str);
+ &msg($who, $str);
+ &msg('NickServ', "GHOST $wantnick $param{'nickServ_pass'}");
+
+ $conn->schedule(5, sub {
+ &status("going to change nick from $mynick to $wantnick after GHOST.");
+ &nick($wantnick);
+ } );
+
+ return;
+ }
+
+ return;
+ }
+
+ return 'CONTINUE';
+}
+
+1;
--- /dev/null
+#
+# core.pl: Important functions stuff...
+# Author: dms
+# Version: v0.4 (20000718)
+# Created: 20000322
+#
+
+use strict;
+
+# scalar. MUST BE REDUCED IN SIZE!!!
+### TODO: reorder.
+use vars qw(
+ $bot_misc_dir $bot_pid $bot_base_dir $bot_src_dir
+ $bot_data_dir $bot_config_dir $bot_state_dir $bot_run_dir
+ $answer $correction_plausible $talkchannel $bot_release
+ $statcount $memusage $user $memusageOld $bot_version $dbh
+ $shm $host $msg $noreply $conn $irc $learnok $nick $ident
+ $force_public_reply $addrchar $userHandle $addressedother
+ $floodwho $chan $msgtime $server $firsttime $wingaterun
+ $flag_quit $msgType $no_syscall
+ $utime_userfile $wtime_userfile $ucount_userfile
+ $utime_chanfile $wtime_chanfile $ucount_chanfile
+ $pubsize $pubcount $pubtime
+ $msgsize $msgcount $msgtime
+ $notsize $notcount $nottime
+ $running
+);
+
+# array.
+use vars qw(@ircServers @wingateBad @wingateNow @wingateCache
+);
+
+### hash. MUST BE REDUCED IN SIZE!!!
+#
+use vars qw(%count %netsplit %netsplitservers %flood %dcc %orig
+ %nuh %talkWho %seen %floodwarn %param %dbh %ircPort
+ %topic %moduleAge %last %time %mask %file
+ %forked %chanconf %channels %cache
+);
+
+# Signals.
+$SIG{'HUP'} = 'restart'; # 1.
+$SIG{'INT'} = 'doExit'; # 2.
+$SIG{'KILL'} = 'doExit'; # 9. DOES NOT WORK. 'man perlipc' for details.
+$SIG{'TERM'} = 'doExit'; # 15.
+$SIG{'__WARN__'} = 'doWarn';
+
+# initialize variables.
+$last{buflen} = 0;
+$last{say} = '';
+$last{msg} = '';
+$userHandle = "_default";
+$wingaterun = time();
+$firsttime = 1;
+$utime_userfile = 0;
+$wtime_userfile = 0;
+$ucount_userfile = 0;
+$utime_chanfile = 0;
+$wtime_chanfile = 0;
+$ucount_chanfile = 0;
+$running = 0;
+### more variables...
+# static scalar variables.
+$mask{ip} = '(\d+)\.(\d+)\.(\d+)\.(\d+)';
+$mask{host} = '[\d\w\_\-\/]+\.[\.\d\w\_\-\/]+';
+$mask{chan} = '[\#\&]\S*|_default';
+my $isnick1 = 'a-zA-Z\[\]\{\}\_\`\^\|\\\\';
+my $isnick2 = '0-9\-';
+$mask{nick} = "[$isnick1]{1}[$isnick1$isnick2]*";
+$mask{nuh} = '\S*!\S*\@\S*';
+$msgtime = time();
+$msgsize = 0;
+$msgcount = 0;
+$pubtime = 0;
+$pubsize = 0;
+$pubcount = 0;
+$nottime = 0;
+$notsize = 0;
+$notcount = 0;
+###
+open(VERSION, '<VERSION');
+$bot_release = <VERSION> || "(unknown version)";
+chomp($bot_release);
+close(VERSION);
+$bot_version = "infobot $bot_release -- $^O";
+$noreply = 'NOREPLY';
+
+##########
+### misc commands.
+###
+
+sub whatInterface {
+ if (!&IsParam('Interface') or $param{'Interface'} =~ /IRC/) {
+ return 'IRC';
+ } else {
+ return 'CLI';
+ }
+}
+
+sub doExit {
+ my ($sig) = @_;
+
+ if (defined $flag_quit) {
+ &WARN("doExit: quit already called.");
+ return;
+ }
+ $flag_quit = 1;
+
+ if (!defined $bot_pid) { # independent.
+ exit 0;
+ } elsif ($bot_pid == $$) { # parent.
+ &status("parent caught SIG$sig (pid $$).") if (defined $sig);
+
+ &status("--- Start of quit.");
+ $ident ||= 'infobot'; # lame hack.
+
+ &status("Memory Usage: $memusage KiB");
+
+ &closePID();
+ &closeStats();
+ # shutdown IRC and related components.
+ if (&whatInterface() =~ /IRC/) {
+ &closeDCC();
+ &seenFlush();
+ &quit($param{'quitMsg'});
+ }
+ &writeUserFile();
+ &writeChanFile();
+ &uptimeWriteFile() if (&IsParam('Uptime'));
+ &sqlCloseDB();
+ &closeSHM($shm);
+
+ if (&IsParam('dumpvarsAtExit')) {
+ &loadMyModule('DumpVars');
+ &dumpallvars();
+ }
+ &symdumpAll() if (&IsParam('symdumpAtExit'));
+ &closeLog();
+ &closeSQLDebug() if (&IsParam('SQLDebug'));
+
+ &status("--- QUIT.");
+ } else { # child.
+ &status("child caught SIG$sig (pid $$).");
+ }
+
+ exit 0;
+}
+
+sub doWarn {
+ $SIG{__WARN__} = sub { warn $_[0]; };
+
+ foreach (@_) {
+ &WARN("PERL: $_");
+ }
+
+ $SIG{__WARN__} = 'doWarn'; # ???
+}
+
+# Usage: &IsParam($param);
+# infobot.config specific.
+sub IsParam {
+ my $param = $_[0];
+
+ return 0 unless (defined $param);
+ return 0 unless (exists $param{$param});
+ return 0 unless ($param{$param});
+ return 0 if $param{$param} =~ /^false$/i;
+ return 1;
+}
+
+#####
+# Usage: &ChanConfList($param)
+# About: gets channels with 'param' enabled. (!!!)
+# Return: array of channels
+sub ChanConfList {
+ my $param = $_[0];
+ return unless (defined $param);
+ my %chan = &getChanConfList($param);
+
+ if (exists $chan{_default}) {
+ return keys %chanconf;
+ } else {
+ return keys %chan;
+ }
+}
+
+#####
+# Usage: &getChanConfList($param)
+# About: gets channels with 'param' enabled, internal use only.
+# Return: hash of channels
+sub getChanConfList {
+ my $param = $_[0];
+ my %chan;
+
+ return unless (defined $param);
+
+ foreach (keys %chanconf) {
+ my $chan = $_;
+ my @array = grep /^$param$/, keys %{ $chanconf{$chan} };
+ #&DEBUG("gCCL param => $param, chan => $chan, keys => " . join(':',keys %{ $chanconf{$chan} }) . " array => " . join(':', @array)) if ($param eq 'whatever');
+
+ next unless (scalar @array);
+
+ if (scalar @array > 1) {
+ &WARN("multiple items found?");
+ }
+
+ if ($chanconf{$chan}{$param} eq '0') {
+ $chan{$chan} = -1;
+ } else {
+ $chan{$chan} = 1;
+ }
+ }
+
+ return %chan;
+}
+
+#####
+# Usage: &IsChanConf($param);
+# About: Check for 'param' on the basis of channel config.
+# Return: 1 for enabled, 0 for passive disable, -1 for active disable.
+sub IsChanConf {
+ my($param) = shift;
+
+ # knocked tons of bugs with this! :)
+ my $debug = 0; # 1 if ($param eq 'whatever');
+
+ if (!defined $param) {
+ &WARN("IsChanConf: param == NULL.");
+ return 0;
+ }
+
+ # these should get moved to your .chan file instead of the .config
+ # .config items overide any .chan entries
+ if (&IsParam($param)) {
+ &WARN("ICC: found '$param' option in main config file.");
+ return 1;
+ }
+
+ $chan ||= "_default";
+
+ my $old = $chan;
+ if ($chan =~ tr/A-Z/a-z/) {
+ &WARN("IsChanConf: lowercased chan. ($old)");
+ }
+
+ ### TODO: VERBOSITY on how chanconf returned 1 or 0 or -1.
+ my %chan = &getChanConfList($param);
+ my $nomatch = 0;
+ if (!defined $msgType) {
+ $nomatch++;
+ } else {
+ $nomatch++ if ($msgType eq '');
+ $nomatch++ unless ($msgType =~ /^(public|private)$/i);
+ }
+
+### debug purposes only.
+# if ($debug) {
+# &DEBUG("param => $param, msgType => $msgType.");
+# foreach (keys %chan) {
+# &DEBUG(" $_ => $chan{$_}");
+# }
+# }
+
+ if ($nomatch) {
+ if ($chan{$chan}) {
+ &DEBUG("ICC: other: $chan{$chan} (_default/$param)") if ($debug);
+ } elsif ($chan{_default}) {
+ &DEBUG("ICC: other: $chan{_default} (_default/$param)") if ($debug);
+ } else {
+ &DEBUG("ICC: other: 0 ($param)") if ($debug);
+ }
+ return $chan{$chan} || $chan{_default} || 0;
+ } elsif ($msgType =~ /^(public|private)$/i) {
+ if ($chan{$chan}) {
+ &DEBUG("ICC: $msgType: $chan{$chan} ($chan/$param)") if ($debug);
+ } elsif ($chan{_default}) {
+ &DEBUG("ICC: $msgType: $chan{_default} (_default/$param)") if ($debug);
+ } else {
+ &DEBUG("ICC: $msgType: 0 ($param)") if ($debug);
+ }
+ return $chan{$chan} || $chan{_default} || 0;
+ }
+
+ &DEBUG("ICC: no-match: 0/$param (msgType = $msgType)");
+
+ return 0;
+}
+
+#####
+# Usage: &getChanConf($param);
+# About: Retrieve value for 'param' value in current/default chan.
+# Return: scalar for success, undef for failure.
+sub getChanConf {
+ my($param,$c) = @_;
+
+ if (!defined $param) {
+ &WARN("gCC: param == NULL.");
+ return 0;
+ }
+
+ # this looks evil...
+ if (0 and !defined $chan) {
+ &DEBUG("gCC: ok !chan... doing _default instead.");
+ }
+
+ $c ||= $chan;
+ $c ||= "_default";
+ $c = "_default" if ($c eq "*"); # FIXME
+ my @c = grep /^\Q$c\E$/i, keys %chanconf;
+
+ if (@c) {
+ if (0 and $c[0] ne $c) {
+ &WARN("c ne chan ($c[0] ne $chan)");
+ }
+ if (!defined $chanconf{$c[0]}{$param} and ($c ne '_default')) {
+ return &getChanConf($param, '_default');
+ }
+ &DEBUG("gCC: $param,$c \"" . $chanconf{$c[0]}{$param} . '"');
+ return $chanconf{$c[0]}{$param};
+ }
+
+ #&DEBUG("gCC: returning _default... " . $chanconf{"_default"}{$param});
+ return $chanconf{"_default"}{$param};
+}
+
+sub getChanConfDefault {
+ my($what, $default, $chan) = @_;
+ $chan ||= "_default";
+
+ if (exists $param{$what}) {
+ if (!exists $cache{config}{$what}) {
+ &status("config ($chan): backward-compatible option: found param{$what} ($param{$what}) instead of chan option");
+ $cache{config}{$what} = 1;
+ }
+
+ return $param{$what};
+ }
+ my $val = &getChanConf($what, $chan);
+ return $val if (defined $val);
+
+ $param{$what} = $default;
+ &status("config ($chan): auto-setting param{$what} = $default");
+ $cache{config}{$what} = 1;
+ return $default;
+}
+
+
+#####
+# Usage: &findChanConf($param);
+# About: Retrieve value for 'param' value from any chan.
+# Return: scalar for success, undef for failure.
+sub findChanConf {
+ my($param) = @_;
+
+ if (!defined $param) {
+ &WARN("param == NULL.");
+ return 0;
+ }
+
+ my $c;
+ foreach $c (keys %chanconf) {
+ foreach (keys %{ $chanconf{$c} }) {
+ next unless (/^$param$/);
+
+ return $chanconf{$c}{$_};
+ }
+ }
+
+ return;
+}
+
+sub showProc {
+ my ($prefix) = $_[0] || '';
+
+ if ($^O eq 'linux') {
+ if (!open(IN, "/proc/$$/status")) {
+ &ERROR("cannot open '/proc/$$/status'.");
+ return;
+ }
+
+ while (<IN>) {
+ $memusage = $1 if (/^VmSize:\s+(\d+) kB/);
+ }
+ close IN;
+
+ } elsif ($^O eq 'netbsd') {
+ $memusage = int( (stat "/proc/$$/mem")[7]/1024 );
+
+ } elsif ($^O =~ /^(free|open)bsd$/) {
+ my @info = split /\s+/, `/bin/ps -l -p $$`;
+ $memusage = $info[20];
+
+ } else {
+ $memusage = 'UNKNOWN';
+ return;
+ }
+
+ if (defined $memusageOld and &IsParam('DEBUG')) {
+ # it's always going to be increase.
+ my $delta = $memusage - $memusageOld;
+ my $str;
+ if ($delta == 0) {
+ return;
+ } elsif ($delta > 500) {
+ $str = "MEM:$prefix increased by $delta KiB. (total: $memusage KiB)";
+ } elsif ($delta > 0) {
+ $str = "MEM:$prefix increased by $delta KiB";
+ } else { # delta < 0.
+ $delta = -$delta;
+ # never knew RSS could decrease, probably Size can't?
+ $str = "MEM:$prefix decreased by $delta KiB.";
+ }
+
+ &status($str);
+ }
+ $memusageOld = $memusage;
+}
+
+######
+###### SETUP
+######
+
+sub setup {
+ &showProc(" (\&openLog before)");
+ &openLog(); # write, append.
+ &status("--- Started logging.");
+
+ # read.
+ &loadLang($bot_data_dir. "/infobot.lang");
+ &loadIRCServers();
+ &readUserFile();
+ &readChanFile();
+ &loadMyModulesNow(); # must be after chan file.
+
+ $shm = &openSHM();
+ &openSQLDebug() if (&IsParam('SQLDebug'));
+ &sqlOpenDB($param{'DBName'}, $param{'DBType'}, $param{'SQLUser'},
+ $param{'SQLPass'});
+ &checkTables();
+
+ &status("Setup: ". &countKeys('factoids') ." factoids.");
+ &getChanConfDefault('sendPrivateLimitLines', 3, $chan);
+ &getChanConfDefault('sendPrivateLimitBytes', 1000, $chan);
+ &getChanConfDefault('sendPublicLimitLines', 3, $chan);
+ &getChanConfDefault('sendPublicLimitBytes', 1000, $chan);
+ &getChanConfDefault('sendNoticeLimitLines', 3, $chan);
+ &getChanConfDefault('sendNoticeLimitBytes', 1000, $chan);
+
+ $param{tempDir} =~ s#\~/#$ENV{HOME}/#;
+
+ &status("Initial memory usage: $memusage KiB");
+ &status("-------------------------------------------------------");
+}
+
+sub setupConfig {
+ $param{'VERBOSITY'} = 1;
+ &loadConfig($bot_config_dir."/infobot.config");
+
+ foreach ( qw(ircNick ircUser ircName DBType tempDir) ) {
+ next if &IsParam($_);
+ &ERROR("Parameter $_ has not been defined.");
+ exit 1;
+ }
+
+ if ($param{tempDir} =~ s#\~/#$ENV{HOME}/#) {
+ &VERB("Fixing up tempDir.",2);
+ }
+
+ if ($param{tempDir} =~ /~/) {
+ &ERROR("parameter tempDir still contains tilde.");
+ exit 1;
+ }
+
+ if (! -d $param{tempDir}) {
+ &status("making $param{tempDir}...");
+ mkdir $param{tempDir}, 0755;
+ }
+
+ # static scalar variables.
+ $file{utm} = "$bot_state_dir/$param{'ircUser'}.uptime";
+ $file{PID} = "$bot_run_dir/$param{'ircUser'}.pid";
+}
+
+sub startup {
+ if (&IsParam('DEBUG')) {
+ &status("enabling debug diagnostics.");
+ # I thought disabling this reduced memory usage by 1000 KiB.
+ use diagnostics;
+ }
+
+ $count{'Question'} = 0;
+ $count{'Update'} = 0;
+ $count{'Dunno'} = 0;
+ $count{'Moron'} = 0;
+}
+
+sub shutdown {
+ my ($sig) = @_;
+ # reverse order of &setup().
+ &status("--- shutdown called.");
+
+ # hack.
+ $ident ||= 'infobot';
+
+ if (!&isFileUpdated("$bot_state_dir/infobot.users", $wtime_userfile)) {
+ &writeUserFile()
+ }
+
+ if (!&isFileUpdated("$bot_state_dir/infobot.chan", $wtime_chanfile)) {
+ &writeChanFile();
+ }
+
+ &sqlCloseDB();
+ # aswell. TODO: use this in &doExit?
+ &closeSHM($shm);
+ &closeLog();
+}
+
+sub restart {
+ my ($sig) = @_;
+
+ if ($$ == $bot_pid) {
+ &status("--- $sig called.");
+
+ ### crappy bug in Net::IRC?
+ my $delta = time() - $msgtime;
+ &DEBUG("restart: dtime = $delta");
+ if (!$conn->connected or time() - $msgtime > 900) {
+ &status("reconnecting because of uncaught disconnect \@ ".scalar(gmtime) );
+### $irc->start;
+ &clearIRCVars();
+ $conn->connect();
+### return;
+ }
+
+ &ircCheck(); # heh, evil!
+
+ &DCCBroadcast("-HUP called.",'m');
+ &shutdown($sig);
+ &loadConfig($bot_config_dir."/infobot.config");
+ &reloadAllModules() if (&IsParam('DEBUG'));
+ &setup();
+
+ &status("--- End of $sig.");
+ } else {
+ &status("$sig called; ignoring restart.");
+ }
+}
+
+# File: Configuration.
+sub loadConfig {
+ my ($file) = @_;
+
+ if (!open(FILE, $file)) {
+ &ERROR("Failed to read configuration file ($file): $!");
+ &status("Please read the INSTALL file on how to install and setup this file.");
+ exit 0;
+ }
+
+ my $count = 0;
+ while (<FILE>) {
+ chomp;
+ next if /^\s*\#/;
+ next unless /\S/;
+ my ($set,$key,$val) = split(/\s+/, $_, 3);
+
+ if ($set ne 'set') {
+ &status("loadConfig: invalid line '$_'.");
+ next;
+ }
+
+ # perform variable interpolation
+ $val =~ s/(\$(\w+))/$param{$2}/g;
+
+ $param{$key} = $val;
+
+ ++$count;
+ }
+ close FILE;
+
+ $file =~ s/^.*\///;
+ &status("Loaded config $file ($count items)");
+}
+
+1;
--- /dev/null
+#
+# dbi.pl: DBI (mysql/pgsql/sqlite) database frontend.
+# Author: dms
+# Version: v0.9a (20021124)
+# Created: 19991203
+# Notes: based on db_mysql.pl
+# overhauled to be 31337.
+#
+
+use strict;
+
+use vars qw(%param);
+use vars qw($dbh $shm $bot_data_dir);
+
+package main;
+
+#####
+# &sqlOpenDB($dbname, $dbtype, $sqluser, $sqlpass, $nofail);
+sub sqlOpenDB {
+ my ($db, $type, $user, $pass, $no_fail) = @_;
+ # this is a mess. someone fix it, please.
+ if ($type =~ /^SQLite(2)?$/i) {
+ $db = "dbname=$db.sqlite";
+ } elsif ($type =~ /^pg/i) {
+ $db = "dbname=$db";
+ $type = 'Pg';
+ }
+
+ my $dsn = "DBI:$type:$db";
+ my $hoststr = '';
+ # SQLHost should be unset for SQLite
+ if (exists $param{'SQLHost'} and $param{'SQLHost'}) {
+ # PostgreSQL requires ";" and keyword 'host'. See perldoc Pg -- troubled
+ if ($type eq 'Pg') {
+ $dsn .= ";host=$param{SQLHost}";
+ } else {
+ $dsn .= ":$param{SQLHost}";
+ }
+ $hoststr = " to $param{'SQLHost'}";
+ }
+ # SQLite ignores $user and $pass
+ $dbh = DBI->connect($dsn, $user, $pass);
+
+ if ($dbh && !$dbh->err) {
+ &status("Opened $type connection$hoststr");
+ } else {
+ &ERROR("Cannot connect$hoststr.");
+ &ERROR("Since $type is not available, shutting down bot!");
+ &ERROR( $dbh->errstr ) if ($dbh);
+ &closePID();
+ &closeSHM($shm);
+ &closeLog();
+
+ return 0 if ($no_fail);
+
+ exit 1;
+ }
+}
+
+sub sqlCloseDB {
+ return 0 unless ($dbh);
+
+ my $x = $param{SQLHost};
+ my $hoststr = ($x) ? " to $x" : '';
+
+ &status("Closed DBI connection$hoststr.");
+ $dbh->disconnect();
+
+ return 1;
+}
+
+#####
+# Usage: &sqlQuote($str);
+sub sqlQuote {
+ return $dbh->quote($_[0]);
+}
+
+#####
+# Usage: &sqlSelectMany($table, $select, [$where_href], [$other]);
+# Return: $sth (Statement handle object)
+sub sqlSelectMany {
+ my($table, $select, $where_href, $other) = @_;
+ my $query = "SELECT $select FROM $table";
+ my $sth;
+
+ if (!defined $select or $select =~ /^\s*$/) {
+ &WARN("sqlSelectMany: select == NULL.");
+ return;
+ }
+
+ if (!defined $table or $table =~ /^\s*$/) {
+ &WARN("sqlSelectMany: table == NULL.");
+ return;
+ }
+
+ if ($where_href) {
+ my $where = &hashref2where($where_href);
+ $query .= " WHERE $where" if ($where);
+ }
+ $query .= " $other" if ($other);
+
+ if (!($sth = $dbh->prepare($query))) {
+ &ERROR("sqlSelectMany: prepare: $DBI::errstr");
+ return;
+ }
+
+ &SQLDebug($query);
+
+ return if (!$sth->execute);
+
+ return $sth;
+}
+
+#####
+# Usage: &sqlSelect($table, $select, [$where_href, [$other]);
+# Return: scalar if one element, array if list of elements.
+# Note: Suitable for one column returns, that is, one column in $select.
+# Todo: Always return array?
+sub sqlSelect {
+ my $sth = &sqlSelectMany(@_);
+ if (!defined $sth) {
+ &WARN("sqlSelect failed.");
+ return;
+ }
+ my @retval = $sth->fetchrow_array;
+ $sth->finish;
+
+ if (scalar @retval > 1) {
+ return @retval;
+ } elsif (scalar @retval == 1) {
+ return $retval[0];
+ } else {
+ return;
+ }
+}
+
+#####
+# Usage: &sqlSelectColArray($table, $select, [$where_href], [$other]);
+# Return: array.
+sub sqlSelectColArray {
+ my $sth = &sqlSelectMany(@_);
+ my @retval;
+
+ if (!defined $sth) {
+ &WARN("sqlSelect failed.");
+ return;
+ }
+
+ while (my @row = $sth->fetchrow_array) {
+ push(@retval, $row[0]);
+ }
+ $sth->finish;
+
+ return @retval;
+}
+
+#####
+# Usage: &sqlSelectColHash($table, $select, [$where_href], [$other], [$type]);
+# Return: type = 1: $retval{ col2 }{ col1 } = 1;
+# Return: no type: $retval{ col1 } = col2;
+# Note: does not support $other, yet.
+sub sqlSelectColHash {
+ my ($table, $select, $where_href, $other, $type) = @_;
+ my $sth = &sqlSelectMany($table, $select, $where_href, $other);
+ if (!defined $sth) {
+ &WARN("sqlSelectColhash failed.");
+ return;
+ }
+ my %retval;
+
+ if (defined $type and $type == 2) {
+ &DEBUG("sqlSelectColHash: type 2!");
+ while (my @row = $sth->fetchrow_array) {
+ $retval{$row[0]} = join(':', $row[1..$#row]);
+ }
+ &DEBUG("sqlSelectColHash: count => ".scalar(keys %retval) );
+
+ } elsif (defined $type and $type == 1) {
+ while (my @row = $sth->fetchrow_array) {
+ # reverse it to make it easier to count.
+ 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) {
+ $retval{$row[0]} = $row[1];
+ }
+ }
+
+ $sth->finish;
+
+ return %retval;
+}
+
+#####
+# Usage: &sqlSelectRowHash($table, $select, [$where_href]);
+# Return: $hash{ col } = value;
+# Note: useful for returning only one/first row of data.
+sub sqlSelectRowHash {
+ my $sth = &sqlSelectMany(@_);
+ if (!defined $sth) {
+ &WARN("sqlSelectRowHash failed.");
+ return;
+ }
+ my $retval = $sth->fetchrow_hashref();
+ $sth->finish;
+
+ if ($retval) {
+ return %{ $retval };
+ } else {
+ return;
+ }
+}
+
+#
+# End of SELECT functions.
+#
+
+#####
+# Usage: &sqlSet($table, $where_href, $data_href);
+# Return: 1 for success, undef for failure.
+sub sqlSet {
+ my ($table, $where_href, $data_href) = @_;
+
+ if (!defined $table or $table =~ /^\s*$/) {
+ &WARN("sqlSet: table == NULL.");
+ return;
+ }
+
+ if (!defined $data_href or ref($data_href) ne 'HASH') {
+ &WARN("sqlSet: data_href == NULL.");
+ return;
+ }
+
+ # any column can be NULL... so just get them all.
+ my $k = join(',', keys %{ $where_href } );
+ my $result = &sqlSelect($table, $k, $where_href);
+# &DEBUG("result is not defined :(") if (!defined $result);
+
+ # this was hardwired to use sqlUpdate. sqlite does not do inserts on sqlUpdate.
+ if (defined $result) {
+ &sqlUpdate($table, $data_href, $where_href);
+ } else {
+ # hack.
+ my %hash = %{ $where_href };
+ # add data_href values...
+ foreach (keys %{ $data_href }) {
+ $hash{ $_ } = ${ $data_href }{$_};
+ }
+
+ $data_href = \%hash;
+ &sqlInsert($table, $data_href);
+ }
+
+ return 1;
+}
+
+#####
+# Usage: &sqlUpdate($table, $data_href, $where_href);
+sub sqlUpdate {
+ my ($table, $data_href, $where_href) = @_;
+
+ if (!defined $data_href or ref($data_href) ne 'HASH') {
+ &WARN("sqlSet: data_href == NULL.");
+ return 0;
+ }
+
+ my $where = &hashref2where($where_href) if ($where_href);
+ my $update = &hashref2update($data_href) if ($data_href);
+
+ &sqlRaw('Update', "UPDATE $table SET $update WHERE $where");
+
+ return 1;
+}
+
+#####
+# Usage: &sqlInsert($table, $data_href, $other);
+sub sqlInsert {
+ my ($table, $data_href, $other) = @_;
+ # note: if $other == 1, add 'DELAYED' to function instead.
+ # note: ^^^ doesnt actually do anything lol. Need code to s/1/DELAYED/ below -- troubled
+
+ if (!defined $data_href or ref($data_href) ne 'HASH') {
+ &WARN("sqlInsert: data_href == NULL.");
+ return;
+ }
+
+ my ($k_aref, $v_aref) = &hashref2array($data_href);
+ my @k = @{ $k_aref };
+ my @v = @{ $v_aref };
+
+ if (!@k or !@v) {
+ &WARN("sqlInsert: keys or vals is NULL.");
+ return;
+ }
+
+ return &sqlRaw("Insert($table)", sprintf(
+ "INSERT %s INTO %s (%s) VALUES (%s)",
+ ($other || ''), $table, join(',',@k), join(',',@v)
+ ) );
+}
+
+#####
+# Usage: &sqlReplace($table, $data_href, [$pkey]);
+sub sqlReplace {
+ my ($table, $data_href, $pkey) = @_;
+
+ if (!defined $data_href or ref($data_href) ne 'HASH') {
+ &WARN("sqlReplace: data_href == NULL.");
+ return;
+ }
+
+ my ($k_aref, $v_aref) = &hashref2array($data_href);
+ my @k = @{ $k_aref };
+ my @v = @{ $v_aref };
+
+ if (!@k or !@v) {
+ &WARN("sqlReplace: keys or vals is NULL.");
+ return;
+ }
+
+
+ if ($param{'DBType'} =~ /^pgsql$/i) {
+ # OK, heres the scoop. There is currently no REPLACE INTO in Pgsql.
+ # However, the bot already seems to search for factoids before insert
+ # anyways. Perhaps we could change this to a generic INSERT INTO so
+ # we can skip the seperate sql? -- troubled to: TimRiker
+ # PGSql syntax: UPDATE table SET key = 'value', key2 = 'value2' WHERE key = 'value'
+
+# &sqlRaw("Replace($table)", sprintf(
+# "INSERT INTO %s (%s) VALUES (%s)",
+# $table, join(',',@k), join(',',@v)
+# ));
+ &WARN("DEBUG: ($pkey = ) " . sprintf(
+ "REPLACE INTO %s (%s) VALUES (%s)",
+ $table, join(',',@k), join(',',@v)
+ ));
+
+ } else {
+ &sqlRaw("Replace($table)", sprintf(
+ "REPLACE INTO %s (%s) VALUES (%s)",
+ $table, join(',',@k), join(',',@v)
+ ));
+ }
+
+ return 1;
+}
+
+#####
+# Usage: &sqlDelete($table, $where_href);
+sub sqlDelete {
+ my ($table, $where_href) = @_;
+
+ if (!defined $where_href or ref($where_href) ne 'HASH') {
+ &WARN("sqlDelete: where_href == NULL.");
+ return;
+ }
+
+ my $where = &hashref2where($where_href);
+
+ &sqlRaw('Delete', "DELETE FROM $table WHERE $where");
+
+ return 1;
+}
+
+#####
+# Usage: &sqlRaw($prefix, $query);
+# Return: 1 for success, 0 for failure.
+sub sqlRaw {
+ my ($prefix, $query) = @_;
+ my $sth;
+
+ if (!defined $query or $query =~ /^\s*$/) {
+ &WARN("sqlRaw: query == NULL.");
+ return 0;
+ }
+
+ if (!($sth = $dbh->prepare($query))) {
+ &ERROR("Raw($prefix): !prepare => '$query'");
+ return 0;
+ }
+
+ &SQLDebug($query);
+ if (!$sth->execute) {
+ &ERROR("Raw($prefix): !execute => '$query'");
+ $sth->finish;
+ return 0;
+ }
+
+ $sth->finish;
+
+ return 1;
+}
+
+#####
+# Usage: &sqlRawReturn($query);
+# Return: array.
+sub sqlRawReturn {
+ my ($query) = @_;
+ my @retval;
+ my $sth;
+
+ if (!defined $query or $query =~ /^\s*$/) {
+ &WARN("sqlRawReturn: query == NULL.");
+ return 0;
+ }
+
+ if (!($sth = $dbh->prepare($query))) {
+ &ERROR("RawReturn: !prepare => '$query'");
+ return 0;
+ }
+
+ &SQLDebug($query);
+ if (!$sth->execute) {
+ &ERROR("RawReturn: !execute => '$query'");
+ $sth->finish;
+ return 0;
+ }
+
+ while (my @row = $sth->fetchrow_array) {
+ push(@retval, $row[0]);
+ }
+
+ $sth->finish;
+
+ return @retval;
+}
+
+####################################################################
+##### Misc DBI stuff...
+#####
+
+sub hashref2where {
+ my ($href) = @_;
+
+ if (!defined $href) {
+ &WARN("hashref2where: href == NULL.");
+ return;
+ }
+
+ if (ref($href) ne 'HASH') {
+ &WARN("hashref2where: href is not HASH ref (href => $href)");
+ return;
+ }
+
+ my %hash = %{ $href };
+ foreach (keys %hash) {
+ my $v = $hash{$_};
+
+ if (s/^-//) { # as is.
+ $hash{$_} = $v;
+ delete $hash{'-'.$_};
+ } else {
+ $hash{$_} = &sqlQuote($v);
+ }
+ }
+
+ return join(' AND ', map { $_."=".$hash{$_} } keys %hash );
+}
+
+sub hashref2update {
+ my ($href) = @_;
+
+ if (ref($href) ne 'HASH') {
+ &WARN("hashref2update: href is not HASH ref.");
+ return;
+ }
+
+ my %hash;
+ foreach (keys %{ $href }) {
+ my $k = $_;
+ my $v = ${ $href }{$_};
+
+ # is there a better way to do this?
+ if ($k =~ s/^-//) { # as is.
+ 1;
+ } else {
+ $v = &sqlQuote($v);
+ }
+
+ $hash{$k} = $v;
+ }
+
+ return join(', ', map { $_."=".$hash{$_} } sort keys %hash);
+}
+
+sub hashref2array {
+ my ($href) = @_;
+
+ if (ref($href) ne 'HASH') {
+ &WARN("hashref2update: href is not HASH ref.");
+ return;
+ }
+
+ my(@k, @v);
+ foreach (keys %{ $href }) {
+ my $k = $_;
+ my $v = ${ $href }{$_};
+
+ # is there a better way to do this?
+ if ($k =~ s/^-//) { # as is.
+ 1;
+ } else {
+ $v = &sqlQuote($v);
+ }
+
+ push(@k, $k);
+ push(@v, $v);
+ }
+
+ return (\@k, \@v);
+}
+
+#####
+# Usage: &countKeys($table, [$col]);
+sub countKeys {
+ my ($table, $col) = @_;
+ $col ||= '*';
+
+ return (&sqlRawReturn("SELECT count($col) FROM $table"))[0];
+}
+
+#####
+# Usage: &sumKey($table, $col);
+sub sumKey {
+ my ($table, $col) = @_;
+
+ return (&sqlRawReturn("SELECT sum($col) FROM $table"))[0];
+}
+
+#####
+# Usage: &randKey($table, $select);
+sub randKey {
+ my ($table, $select) = @_;
+ my $rand = int(rand(&countKeys($table)));
+ my $query = "SELECT $select FROM $table LIMIT 1 OFFSET $rand";
+ if ($param{DBType} =~ /^mysql$/i) {
+ # WARN: only newer MySQL supports "LIMIT limit OFFSET offset"
+ $query = "SELECT $select FROM $table LIMIT $rand,1";
+ }
+ my $sth = $dbh->prepare($query);
+ &SQLDebug($query);
+ &WARN("randKey($query)") unless $sth->execute;
+ my @retval = $sth->fetchrow_array;
+ $sth->finish;
+
+ return @retval;
+}
+
+#####
+# Usage: &deleteTable($table);
+sub deleteTable {
+ &sqlRaw("deleteTable($_[0])", "DELETE FROM $_[0]");
+}
+
+#####
+# Usage: &searchTable($table, $select, $key, $str);
+# Note: searchTable does sqlQuote.
+sub searchTable {
+ my($table, $select, $key, $str) = @_;
+ my $origStr = $str;
+ my @results;
+
+ # allow two types of wildcards.
+ if ($str =~ /^\^(.*)\$$/) {
+ &FIXME("searchTable: can't do \"$str\"");
+ $str = $1;
+ } else {
+ $str .= "%" if ($str =~ s/^\^//);
+ $str = "%".$str if ($str =~ s/\$$//);
+ $str = "%".$str."%" if ($str eq $origStr); # el-cheapo fix.
+ }
+
+ $str =~ s/\_/\\_/g;
+ $str =~ s/\?/_/g; # '.' should be supported, too.
+ $str =~ s/\*/%/g;
+ # end of string fix.
+
+ my $query = "SELECT $select FROM $table WHERE $key LIKE ".
+ &sqlQuote($str);
+ my $sth = $dbh->prepare($query);
+
+ &SQLDebug($query);
+ if (!$sth->execute) {
+ &WARN("Search($query)");
+ $sth->finish;
+ return;
+ }
+
+ while (my @row = $sth->fetchrow_array) {
+ push(@results, $row[0]);
+ }
+ $sth->finish;
+
+ return @results;
+}
+
+sub sqlCreateTable {
+ my($table, $dbtype) = @_;
+ my(@path) = ($bot_data_dir, ".","..","../..");
+ my $found = 0;
+ my $data;
+ $dbtype = lc $dbtype;
+
+ foreach (@path) {
+ my $file = "$_/setup/$dbtype/$table.sql";
+ next unless ( -f $file );
+
+ open(IN, $file);
+ while (<IN>) {
+ chop;
+ next if $_ =~ /^--/;
+ $data .= $_;
+ }
+
+ $found++;
+ last;
+ }
+
+ if (!$found) {
+ return 0;
+ } else {
+ &sqlRaw("sqlCreateTable($table)", $data);
+ return 1;
+ }
+}
+
+sub checkTables {
+ my $database_exists = 0;
+ my %db;
+
+ if ($param{DBType} =~ /^mysql$/i) {
+ my $sql = "SHOW DATABASES";
+ foreach ( &sqlRawReturn($sql) ) {
+ $database_exists++ if ($_ eq $param{'DBName'});
+ }
+
+ unless ($database_exists) {
+ &status("Creating database $param{DBName}...");
+ my $query = "CREATE DATABASE $param{DBName}";
+ &sqlRaw("create(db $param{DBName})", $query);
+ }
+
+ # retrieve a list of db's from the server.
+ my @tables = map {s/^\`//; s/\`$//; $_;} $dbh->func('_ListTables');
+ if ($#tables == -1){
+ @tables = $dbh->tables;
+ }
+ &status("Tables: ".join(',',@tables));
+ @db{@tables} = (1) x @tables;
+
+ } elsif ($param{DBType} =~ /^SQLite(2)?$/i) {
+
+ # retrieve a list of db's from the server.
+ foreach ( &sqlRawReturn("SELECT name FROM sqlite_master WHERE type='table'") ) {
+ $db{$_} = 1;
+ }
+
+ # create database not needed for SQLite
+
+ } elsif ($param{DBType} =~ /^pgsql$/i) {
+ # $sql_showDB = SQL to select the DB list
+ # $sql_showTBL = SQL to select all tables for the current connection
+
+ my $sql_showDB = "SELECT datname FROM pg_database";
+ my $sql_showTBL = "SELECT tablename FROM pg_tables \
+ WHERE schemaname = 'public'";
+
+ foreach ( &sqlRawReturn($sql_showDB) ) {
+ $database_exists++ if ($_ eq $param{'DBName'});
+ }
+
+ unless ($database_exists) {
+ &status("Creating PostgreSQL database $param{'DBName'}");
+ &status("(actually, not really, please read the INSTALL file)");
+ }
+
+ # retrieve a list of db's from the server. This code is from mysql above, please check -- troubled
+ my @tables = map {s/^\`//; s/\`$//; $_;} &sqlRawReturn($sql_showTBL);
+ if ($#tables == -1){
+ @tables = $dbh->tables;
+ }
+ &status("Tables: ".join(',',@tables));
+ @db{@tables} = (1) x @tables;
+ }
+
+ foreach ( qw(botmail connections factoids rootwarn seen stats onjoin) ) {
+ if (exists $db{$_}) {
+ $cache{has_table}{$_} = 1;
+ next;
+ }
+
+ &status("checkTables: creating new table $_...");
+
+ $cache{create_table}{$_} = 1;
+
+ &sqlCreateTable($_, $param{DBType});
+ }
+}
+
+1;
--- /dev/null
+#
+# logger.pl: logger functions!
+# Author: dms
+# Version: v0.4 (20000923)
+# FVersion: 19991205
+# NOTE: Based on code by Kevin Lenzo & Patrick Cole (c) 1997
+#
+
+use strict;
+
+use vars qw($statcount $bot_pid $forkedtime $statcountfix $addressed);
+use vars qw($logDate $logold $logcount $logtime $logrepeat $running);
+use vars qw(@backlog);
+use vars qw(%param %file %cache);
+
+$logtime = time();
+$logcount = 0;
+$logrepeat = 0;
+$logold = '';
+
+$param{VEBOSITY} ||= 1; # lame fix for preload
+
+my %attributes = (
+ 'clear' => 0,
+ 'reset' => 0,
+ 'bold' => 1,
+ 'underline' => 4,
+ 'underscore' => 4,
+ 'blink' => 5,
+ 'reverse' => 7,
+ 'concealed' => 8,
+ 'black' => 30, 'on_black' => 40,
+ 'red' => 31, 'on_red' => 41,
+ 'green' => 32, 'on_green' => 42,
+ 'yellow' => 33, 'on_yellow' => 43,
+ 'blue' => 34, 'on_blue' => 44,
+ 'magenta' => 35, 'on_magenta' => 45,
+ 'cyan' => 36, 'on_cyan' => 46,
+ 'white' => 37, 'on_white' => 47
+);
+
+use vars qw($b_black $_black $b_red $_red $b_green $_green
+ $b_yellow $_yellow $b_blue $_blue $b_magenta $_magenta
+ $b_cyan $_cyan $b_white $_white $_reset $_bold $ob $b);
+
+$b_black = cl('bold black'); $_black = cl('black');
+$b_red = cl('bold red'); $_red = cl('red');
+$b_green = cl('bold green'); $_green = cl('green');
+$b_yellow = cl('bold yellow'); $_yellow = cl('yellow');
+$b_blue = cl('bold blue'); $_blue = cl('blue');
+$b_magenta = cl('bold magenta'); $_magenta = cl('magenta');
+$b_cyan = cl('bold cyan'); $_cyan = cl('cyan');
+$b_white = cl('bold white'); $_white = cl('white');
+$_reset = cl('reset'); $_bold = cl('bold');
+$ob = cl('reset'); $b = cl('bold');
+
+############################################################################
+# Implementation (attribute string form)
+############################################################################
+
+# Return the escape code for a given set of color attributes.
+sub cl {
+ my @codes = map { split } @_;
+ my $attribute = '';
+ foreach (@codes) {
+ $_ = lc $_;
+ unless (defined $attributes{$_}) { die "Invalid attribute name $_" }
+ $attribute .= $attributes{$_} . ';';
+ }
+ chop $attribute;
+ ($attribute ne '') ? "\e[${attribute}m" : undef;
+}
+
+# logging support.
+sub openLog {
+ return unless (&IsParam('logfile'));
+ $file{log} = $param{'logfile'};
+
+ my $error = 0;
+ my $path = &getPath($file{log});
+ while (! -d $path) {
+ if ($error) {
+ &ERROR("openLog: failed opening log to $file{log}; disabling.");
+ delete $param{'logfile'};
+ return;
+ }
+
+ &status("openLog: making $path.");
+ last if (mkdir $path, 0755);
+ $error++;
+ }
+
+ if (&IsParam('logType') and $param{'logType'} =~ /DAILY/i) {
+ my ($day,$month,$year) = (gmtime time())[3,4,5];
+ $logDate = sprintf("%04d%02d%02d",$year+1900,$month+1,$day);
+ $file{log} .= $logDate;
+ }
+
+ if (open(LOG, ">>$file{log}")) {
+ &status("Opened logfile $file{log}.");
+ LOG->autoflush(1);
+ } else {
+ &status("Cannot open logfile ($file{log}); not logging: $!");
+ }
+}
+
+sub closeLog {
+ # lame fix for paramlogfile.
+ return unless (&IsParam('logfile'));
+ return unless (defined fileno LOG);
+
+ close LOG;
+ &status("Closed logfile ($file{log}).");
+}
+
+#####
+# Usage: &compress($file);
+sub compress {
+ my ($file) = @_;
+ my @compress = ('/usr/bin/bzip2','/bin/bzip2','/bin/gzip');
+ my $okay = 0;
+
+ if (! -f $file) {
+ &WARN("compress: file ($file) does not exist.");
+ return 0;
+ }
+
+ if ( -f "$file.gz" or -f "$file.bz2" ) {
+ &WARN("compress: file.(gz|bz2) already exists.");
+ return 0;
+ }
+
+ foreach (@compress) {
+ next unless ( -x $_);
+
+ &status("Compressing '$file' with $_.");
+ system("$_ $file &");
+ $okay++;
+ last;
+ }
+
+ if (!$okay) {
+ &ERROR("no compress program found.");
+ return 0;
+ }
+
+ return 1;
+}
+
+sub DEBUG {
+ return unless (&IsParam('DEBUG'));
+
+ &status("${b_green}!DEBUG!$ob $_[0]");
+}
+
+sub ERROR {
+ &status("${b_red}!ERROR!$ob $_[0]");
+}
+
+sub WARN {
+ return unless (&IsParam('WARN'));
+
+ return if ($_[0] =~ /^PERL: Subroutine \S+ redefined at/);
+
+ &status("${b_yellow}!WARN!$ob $_[0]");
+}
+
+sub FIXME {
+ &status("${b_cyan}!FIXME!$ob $_[0]");
+}
+
+sub TODO {
+ &status("${b_cyan}!TODO!$ob $_[0]");
+}
+
+sub VERB {
+ if (!&IsParam('VERBOSITY')) {
+ # NOTHING.
+ } elsif ($param{'VERBOSITY'} eq '1' and $_[1] <= 1) {
+ &status($_[0]);
+ } elsif ($param{'VERBOSITY'} eq '2' and $_[1] <= 2) {
+ &status($_[0]);
+ }
+}
+
+sub status {
+ my($input) = @_;
+ my $status;
+
+ if ($input =~ /PERL: Use of uninitialized/) {
+ &debug_perl($input);
+ return;
+ }
+
+ if ($input eq $logold) {
+ $logrepeat++;
+ return;
+ }
+
+ $logold = $input;
+ # if only I had followed how sysklogd does it, heh. lame me. -xk
+ if ($logrepeat >= 3) {
+ &status("LOG: last message repeated $logrepeat times");
+ $logrepeat = 0;
+ }
+
+ # if it's not a scalar, attempt to warn and fix.
+ my $ref = ref $input;
+ if (defined $ref and $ref ne '') {
+ &WARN("status: 'input' is not scalar ($ref).");
+
+ if ($ref eq 'ARRAY') {
+ foreach (@$input) {
+ &WARN("status: '$_'.");
+ }
+ }
+ }
+
+ # Something is using this w/ NULL.
+ if (!defined $input or $input =~ /^\s*$/) {
+ $input = "ERROR: Blank status call? HELP HELP HELP";
+ }
+
+ for ($input) {
+ s/\n+$//;
+ s/\002|\037//g; # bold,video,underline => remove.
+ }
+
+ # does this work?
+ if ($input =~ /\n/) {
+ foreach (split /\n/, $input) {
+ &status($_);
+ }
+ }
+
+ # pump up the stats.
+ $statcount++;
+
+ # fix style of output if process is child.
+ if (defined $bot_pid and $$ != $bot_pid and !defined $statcountfix) {
+ $statcount = 1;
+ $statcountfix = 1;
+ }
+
+ ### LOG THROTTLING.
+ ### TODO: move this _after_ printing?
+ my $time = time();
+ my $reset = 0;
+
+ # hrm... what is this supposed to achieve? nothing I guess.
+ if ($logtime == $time) {
+ if ($logcount < 25) { # too high?
+ $logcount++;
+ } else {
+ sleep 1;
+ &status("LOG: Throttling.");
+ $reset++;
+ }
+ } else { # $logtime != $time.
+ $reset++;
+ }
+
+ if ($reset) {
+ $logtime = $time;
+ $logcount = 0;
+ }
+
+ # Log differently for forked/non-forked output.
+ if ($statcountfix) {
+ $status = "!$statcount! ".$input;
+ if ($statcount > 1000) {
+ print LOG "ERROR: FORKED PROCESS RAN AWAY; KILLING.\n";
+ print LOG "VERB: ".(&Time2String($time - $forkedtime))."\n";
+ exit 0;
+ }
+ } else {
+ $status = "[$statcount] ".$input;
+ }
+
+ if (&IsParam('backlog')) {
+ push(@backlog, $status); # append to end.
+ shift(@backlog) if (scalar @backlog > $param{'backlog'});
+ }
+
+ if (&IsParam('VERBOSITY')) {
+ if ($statcountfix) {
+ printf $_red."!%6d!".$ob." ", $statcount;
+ } else {
+ printf $_green."[%6d]".$ob." ", $statcount;
+ }
+
+ # three uberstabs to Derek Moeller. I don't remember why but he
+ # deserved it :)
+ my $printable = $input;
+
+ if ($printable =~ s/^(<\/\S+>) //) {
+ # it's me saying something on a channel
+ my $name = $1;
+ print "$b_yellow$name $printable$ob\n";
+ } elsif ($printable =~ s/^(<\S+>) //) {
+ # public message on channel.
+ my $name = $1;
+
+ if ($addressed) {
+ print "$b_red$name $printable$ob\n";
+ } else {
+ print "$b_cyan$name$ob $printable$ob\n";
+ }
+
+ } elsif ($printable =~ s/^\* (\S+)\/(\S+) //) {
+ # public action.
+ print "$b_white*$ob $b_cyan$1$ob/$b_blue$2$ob $printable\n";
+
+ } elsif ($printable =~ s/^(-\S+-) //) {
+ # notice
+ print "$_green$1 $printable$ob\n";
+
+ } elsif ($printable =~ s/^(\* )?(\[\S+\]) //) {
+ # message/private action from someone
+ print "$b_white$1$ob" if (defined $1);
+ print "$b_red$2 $printable$ob\n";
+
+ } elsif ($printable =~ s/^(>\S+<) //) {
+ # i'm messaging someone
+ print "$b_magenta$1 $printable$ob\n";
+
+ } elsif ($printable =~ s/^(enter:|update:|forget:) //) {
+ # something that should be SEEN
+ print "$b_green$1 $printable$ob\n";
+
+ } else {
+ print "$printable\n";
+ }
+
+ } else {
+ #print "VERBOSITY IS OFF?\n";
+ }
+
+ # log the line into a file.
+ return unless (&IsParam('logfile'));
+ return unless (defined fileno LOG);
+
+ # remove control characters from logging to LOGFILE.
+ for ($input) {
+ last if (&IsParam('logColors'));
+ s/\e\[[0-9;]+m//g; # escape codes.
+ s/[\cA-\c_]//g; # control chars.
+ }
+ $input = "FORK($$) ".$input if ($statcountfix);
+
+ my $date;
+ if (&IsParam('logType') and $param{'logType'} =~ /DAILY/i) {
+ $date = sprintf("%02d:%02d.%02d", (gmtime $time)[2,1,0]);
+
+ my ($day,$month,$year) = (gmtime $time)[3,4,5];
+ my $newlogDate = sprintf("%04d%02d%02d",$year+1900,$month+1,$day);
+ if (defined $logDate and $newlogDate != $logDate) {
+ &closeLog();
+ &compress( $file{log} );
+ &openLog();
+ }
+ } else {
+ $date = $time;
+ }
+
+ printf LOG "%s %s\n", $date, $input;
+}
+
+sub debug_perl {
+ my ($str) = @_;
+
+ return unless ($str =~ /^WARN: Use of uninitialized value .* at (\S+) line (\d+)/);
+ my ($file,$line) = ($1,$2);
+ if (!open(IN,$file)) {
+ &status("WARN: cannot open $file: $!");
+ return;
+ }
+
+ # TODO: better filename.
+ open(OUT, ">>debug.log");
+ print OUT "DEBUG: $str\n";
+
+ # note: cannot call external functions because SIG{} does not allow us to.
+ my $i;
+ while (<IN>) {
+ chop;
+ $i++;
+ # bleh. this tries to duplicate status().
+ # TODO: statcountfix
+ # TODO: rename to log_*someshit*
+ if ($i == $line) {
+ my $msg = "$file: $i:!$_";
+ printf "%s[%6d]%s %s\n", $_green, $statcount, $ob, $msg;
+ print OUT "DEBUG: $msg\n";
+ $statcount++;
+ next;
+ }
+ if ($i+3 > $line && $i-3 < $line) {
+ my $msg = "$file: $i: $_";
+ printf "%s[%6d]%s %s\n", $_green, $statcount, $ob, $msg;
+ print OUT "DEBUG: $msg\n";
+ $statcount++;
+ }
+ }
+ close IN;
+ close OUT;
+}
+
+sub openSQLDebug {
+ if (!open(SQLDEBUG, ">>$param{'SQLDebug'}")) {
+ &ERROR("Cannot open ($param{'SQLDebug'}): $!");
+ delete $param{'SQLDebug'};
+ return 0;
+ }
+
+ &status("Opened SQL Debug file: $param{'SQLDebug'}");
+ return 1;
+}
+
+sub closeSQLDebug {
+ close SQLDEBUG;
+
+ &status("Closed SQL Debug file: $param{'SQLDebug'}");
+}
+
+sub SQLDebug {
+ return unless (&IsParam('SQLDebug'));
+
+ return unless (fileno SQLDEBUG);
+
+ print SQLDEBUG $_[0]."\n";
+}
+
+1;
--- /dev/null
+#
+# modules.pl: pseudo-Module handler
+# Author: dms
+# Version: v0.2 (20000629)
+# Created: 20000624
+#
+
+use strict;
+
+use vars qw($AUTOLOAD $no_timehires $bot_version $bot_release);
+
+###
+### REQUIRED MODULES.
+###
+
+eval "use IO::Socket";
+if ($@) {
+ &ERROR("no IO::Socket?");
+ exit 1;
+}
+&showProc(" (IO::Socket)");
+
+### THIS IS NOT LOADED ON RELOAD :(
+my @myModulesLoadNow;
+my @myModulesReloadNot;
+BEGIN {
+ @myModulesLoadNow = ('Topic', 'Uptime', 'News', 'RootWarn', 'DumpVars2', 'botmail', 'OnJoin');
+ @myModulesReloadNot = ('IRC/Irc.pl','IRC/Schedulers.pl');
+}
+
+sub loadCoreModules {
+ my @mods = &getPerlFiles($bot_src_dir);
+
+ &status("Loading CORE modules...");
+
+ foreach (sort @mods) {
+ my $mod = "$bot_src_dir/$_";
+
+ eval "require \"$mod\"";
+ if ($@) {
+ &ERROR("lCM => $@");
+ &shutdown();
+ exit 1;
+ }
+
+ $moduleAge{$mod} = (stat $mod)[9];
+ &showProc(" ($_)") if (&IsParam('DEBUG'));
+ }
+}
+
+sub loadDBModules {
+ my $f;
+ # TODO: use function to load module.
+
+ if ($param{'DBType'} =~ /^(mysql|SQLite(2)?|pgsql)$/i) {
+ eval "use DBI";
+ if ($@) {
+ &ERROR("No support for DBI::" . $param{'DBType'} . ", exiting!");
+ exit 1;
+ }
+ &status("Loading " . $param{'DBType'} . " support.");
+ $f = "$bot_src_dir/dbi.pl";
+ require $f;
+ $moduleAge{$f} = (stat $f)[9];
+
+ &showProc(" (DBI::" . $param{'DBType'} . ")");
+ } else {
+ &WARN("DB support DISABLED.");
+ return;
+ }
+}
+
+sub loadFactoidsModules {
+ if (!&IsParam('factoids')) {
+ &status("Factoid support DISABLED.");
+ return;
+ }
+
+ &status("Loading Factoids modules...");
+
+ foreach ( &getPerlFiles("$bot_src_dir/Factoids") ) {
+ my $mod = "$bot_src_dir/Factoids/$_";
+
+ eval "require \"$mod\"";
+ if ($@) {
+ &ERROR("lFM: $@");
+ exit 1;
+ }
+
+ $moduleAge{$mod} = (stat $mod)[9];
+ &showProc(" ($_)") if (&IsParam('DEBUG'));
+ }
+}
+
+sub loadIRCModules {
+ my ($interface) = &whatInterface();
+ if ($interface =~ /IRC/) {
+ &status("Loading IRC modules...");
+
+ eval "use Net::IRC";
+ if ($@) {
+ &ERROR("libnet-irc-perl is not installed!");
+ exit 1;
+ }
+ &showProc(" (Net::IRC)");
+ } else {
+ &status("IRC support DISABLED.");
+ # disabling forking. Why?
+ #$param{forking} = 0;
+ #$param{noSHM} = 1;
+ }
+
+ foreach ( &getPerlFiles("$bot_src_dir/$interface") ) {
+ my $mod = "$bot_src_dir/$interface/$_";
+
+ # hrm... use another config option besides DEBUG to display
+ # change in memory usage.
+ &status("Loading Modules \"$mod\"") if (!&IsParam('DEBUG'));
+ eval "require \"$mod\"";
+ if ($@) {
+ &ERROR("require \"$mod\" => $@");
+ &shutdown();
+ exit 1;
+ }
+
+ $moduleAge{$mod} = (stat $mod)[9];
+ &showProc(" ($_)") if (&IsParam('DEBUG'));
+ }
+}
+
+sub loadMyModulesNow {
+ my $loaded = 0;
+ my $total = 0;
+
+ &status("Loading MyModules...");
+ foreach (@myModulesLoadNow) {
+ $total++;
+ if (!defined $_) {
+ &WARN("mMLN: null element.");
+ next;
+ }
+
+ if (!&IsParam($_) and &IsChanConf($_) <= 0 and !&getChanConfList($_)) {
+ &DEBUG("loadMyModuleNow: $_ (2) not loaded.");
+ next;
+ }
+
+ &loadMyModule($_);
+ $loaded++;
+ }
+
+ &status("Module: Runtime: Loaded/Total [$loaded/$total]");
+}
+
+### rename to moduleReloadAll?
+sub reloadAllModules {
+ my $retval = '';
+
+ &VERB("Module: reloading all.",2);
+
+ # Reload version and save
+ open(VERSION,"<VERSION");
+ $bot_release = <VERSION> || "(unknown version)";
+ chomp($bot_release);
+ $bot_version = "infobot $bot_release -- $^O";
+ close(VERSION);
+
+ # obscure usage of map and regex :)
+ foreach (map { s/.*?\/?src/src/; $_ } keys %moduleAge) {
+ $retval .= &reloadModule($_);
+ }
+
+ &VERB("Module: reloading done.",2);
+ return $retval;
+}
+
+### rename to modulesReload?
+sub reloadModule {
+ my ($mod) = @_;
+ my $file = (grep /\/$mod/, keys %INC)[0];
+ my $retval = '';
+
+ # don't reload if it's not our module.
+ if ($mod =~ /::/ or $mod !~ /pl$/) {
+ &VERB("Not reloading $mod.",3);
+ return $retval;
+ }
+
+ if (!defined $file) {
+ &WARN("rM: Cannot reload $mod since it was not loaded anyway.");
+ return $retval;
+ }
+
+ if (! -f $file) {
+ &ERROR("rM: file '$file' does not exist?");
+ return $retval;
+ }
+
+ if (grep /$mod/, @myModulesReloadNot) {
+ &DEBUG("rM: should not reload $mod");
+ return $retval;
+ }
+
+ my $age = (stat $file)[9];
+
+ if (!exists $moduleAge{$file}) {
+ &DEBUG("Looks like $file was not loaded; fixing.");
+ } else {
+ return $retval if ($age == $moduleAge{$file});
+
+ if ($age < $moduleAge{$file}) {
+ &WARN("rM: we're not gonna downgrade '$file'; use touch.");
+ &DEBUG("age => $age, mA{$file} => $moduleAge{$file}");
+ return $retval;
+ }
+
+ my $dc = &Time2String($age - $moduleAge{$file});
+ my $ago = &Time2String(time() - $moduleAge{$file});
+
+ &VERB("Module: delta change: $dc",2);
+ &VERB("Module: ago: $ago",2);
+ }
+
+ &status("Module: Loading $mod...");
+
+ delete $INC{$file};
+ eval "require \"$file\""; # require or use?
+ if (@$) {
+ &DEBUG("rM: failure: @$ ");
+ } else {
+ my $basename = $file;
+ $basename =~ s/^.*\///;
+ &status("Module: reloaded $basename");
+ $retval = " $basename";
+ $moduleAge{$file} = $age;
+ }
+ return $retval;
+}
+
+###
+### OPTIONAL MODULES.
+###
+
+my %perlModulesLoaded = ();
+my %perlModulesMissing = ();
+
+sub loadPerlModule {
+ return 0 if (exists $perlModulesMissing{$_[0]});
+ &reloadModule($_[0]);
+ return 1 if (exists $perlModulesLoaded{$_[0]});
+
+ eval "use $_[0]";
+ if ($@) {
+ &WARN("Module: $_[0] is not installed!");
+ $perlModulesMissing{$_[0]} = 1;
+ return 0;
+ } else {
+ $perlModulesLoaded{$_[0]} = 1;
+ &status("Loaded $_[0]");
+ &showProc(" ($_[0])");
+ return 1;
+ }
+}
+
+sub loadMyModule {
+ my ($modulename) = @_;
+ if (!defined $modulename) {
+ &WARN("loadMyModule: module is NULL.");
+ return 0;
+ }
+
+ my $modulefile = "$bot_src_dir/Modules/$modulename.pl";
+
+ # call reloadModule() which checks age of file and reload.
+ if (grep /\/$modulename$/, keys %INC) {
+ &reloadModule($modulename);
+ return 1; # depend on reloadModule?
+ }
+
+ if (! -f $modulefile) {
+ &ERROR("lMM: module ($modulename) does not exist.");
+ if ($$ == $bot_pid) { # parent.
+ &shutdown() if (defined $shm and defined $dbh);
+ } else { # child.
+ &DEBUG("b4 delfork 1");
+ &delForked($modulename);
+ }
+
+ exit 1;
+ }
+
+ eval "require \"$modulefile\"";
+ if ($@) {
+ &ERROR("cannot load my module: $modulename");
+ if ($bot_pid != $$) { # child.
+ &DEBUG("b4 delfork 2");
+ &delForked($modulename);
+ exit 1;
+ }
+
+ return 0;
+ } else {
+ $moduleAge{$modulefile} = (stat $modulefile)[9];
+
+ &status("Loaded $modulename");
+ &showProc(" ($modulename)");
+ return 1;
+ }
+}
+
+$no_timehires = 0;
+eval "use Time::HiRes qw(gettimeofday tv_interval)";
+if ($@) {
+ &WARN("No Time::HiRes?");
+ $no_timehires = 1;
+}
+&showProc(" (Time::HiRes)");
+
+sub AUTOLOAD {
+ if (!defined $AUTOLOAD and defined $::AUTOLOAD) {
+ &DEBUG("AUTOLOAD: hrm.. ::AUTOLOAD defined!");
+ }
+ return unless (defined $AUTOLOAD);
+ return if ($AUTOLOAD =~ /__/); # internal.
+
+ my $str = join(', ', @_);
+ my ($package, $filename, $line) = caller;
+ &ERROR("UNKNOWN FUNCTION CALLED: $AUTOLOAD ($str) $filename line $line");
+
+ $AUTOLOAD =~ s/^(\S+):://g;
+
+ # hopefully this will work.
+ &DEBUG("Trying to load module $AUTOLOAD...");
+ &loadMyModule($AUTOLOAD);
+}
+
+sub getPerlFiles {
+ my($dir) = @_;
+
+ if (!opendir(DIR, $dir)) {
+ &ERROR("Cannot open source directory ($dir): $!");
+ exit 1;
+ }
+
+ my @mods;
+ while (defined(my $file = readdir DIR)) {
+ next unless $file =~ /\.pl$/;
+ next unless $file =~ /^[A-Z]/;
+ push(@mods, $file);
+ }
+ closedir DIR;
+
+ return reverse sort @mods;
+}
+
+1;
projects / infobot.git / commitdiff