XPUB
/
infobot
5
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

gulp

Browse Source
master
Michael Murtaugh 4 years ago
commit ee4f56acf6
75 changed files with 11420 additions and 0 deletions
Show Stats Download Patch File Download Diff File

9
LICENSE
Unescape Escape View File

@ -0,0 +1,9 @@
Copyright (c) Kevin Lenzo, 1996-2000, except where noted
otherwise.
The Infobot is covered under the same terms as Perl itself
(the Artistic License). This software is meant to be freely
available under those terms in perpetuity.

146
README
Unescape Escape View File

@ -0,0 +1,146 @@
You will need to update your infobot.config
and infobot.users. See the example files.
--
This requires perl 5.
You should be able to start up just by running
infobot. If you are using macperl, you will
(currently) have to make one minor change (because
$^O didn't work for me under os8).
The infobot uses parameter files, typically in the
params directory, to set up with. It treats anything
on the command line as a parameter file and tries to
load it.
If you are using macperl, you will want to set
the value of the macperl parameter to 1 in the
two given param files (in the 'files' dir).
By default, the infobot uses the IRC setup. This
may change. NOTE that the irc version has no output
by default; you'll have to turn up the debug level
to get more.
to start up the infobot, just invoke it from the
command line.
infobot
---
A note on forms: you can prepend the tag <reply>
to values in the db to just get a reply with no
extra info.
e.g.
x => <reply> y
then when you ask 'x?' it will just reply 'y' instead
of something like "i think x is y".
---
* extending the bot by adding your own code
try to keep your changes inside src/myRoutines.pl
so that you can easily just replace this file when
there are new revs. this is called just after some
of the normalization stuff in urlProcess.pl. take
a look at the file for details.
basically, if myRoutines returns non-null, it's
taken to have 'caught' the event. you can just
return '' to let the rest of the processing go at
it.
---
* update_db & dump_db
update_db is a little perl script that will take a
flat ascii file and make an infobot-style db out
of it (currently just a couple of dbm files). You'll
want to make 2, even if theye contain only 1 element
each. it will also simply add (and overwrite entries
in) existing dbs. This is especially nice if
you don't allow updates to the databases through IRC
and just want a collection of permanent factoids.
update_db <inputfile> <dbname>
where <inputfile> is an ascii file like (in the case
of an url-style infobot):
infobot => at http://www.cs.cmu.edu/~lenzo/hocus.html
one key => value per line. In the current setup,
you need an is-database and an are-database, mainly
for legacy reasons about representing plurality and
being able to give the proper form. in the infobot-is.txt
file and infobot-are.txt files you have examples. these
are a fine starting point:
1.1 update_db infobot-is.txt infobot-is
update_db infobot-are.txt infobot-are
2. Now you need to edit infobot to set up your bot.
Don't forget to set the path to perl properly at
the top and make it executable.
3. Then try running infobot. At present, there's a
bunch of VERY BAD code in it, so don't use the -w
switch unless you want to fix a bunch of things and
mail me.
Eventually, kill it and then you'll probably
want to crontab it. included is a sample crontab
and the script that you will need to edit.
dump_db <dbname>
will just make a flat ascii file out of the named db,
e.g.
dump_db infobot-is
Both update_db and dump_db take an optional switch, -m, which tells them
what DBM module to use. You'll need to specify this if you set
DBMModule in your config file in order to get the bot to use something
other than Perl's default. Eg,
update_db -m DB_File infobot-is.txt infobot-is
dump_db -m DB_File infobot-is
good luck, and mail me!
kevin
lenzo@cs.cmu.edu
ps - i am just releasing this _now_ instead of waiting
to fix everything. If you use this and like it,
or even if you don't, please mail me!
---
thanks to:
You, for getting this and using this. Especially if
you mail me and let me put you on the mailing list.
lenzo@cs.cmu.edu
special thanks to:
steve orens (sorens) for being a tour-de-force beta bomber
yo for working with script. this is a big one!
amug and everyone there for hosting the undernet url
#macintosh for dealing with url through his troubled childhood
tris for being an early guinea pig
jadin for pointing out the @verb bug... fixed in 0.17b
chucky burnett for tons of stuff

687
REVISIONS
Unescape Escape View File

@ -0,0 +1,687 @@
0.45.3
Really fix the stuff in DBM.pl for the %param hash.
0.45.1,2
Fixed some path names, made a new tarball.
0.45.0
Renamed the miscdir parameter to confdir (in 'infobot')
Renames 'files' directory to 'conf'
Seperated src/ into src/ and extras/
Changed default name to 'i-bot' in the infobot.config file
Rationalized the names of the dbs to use dbname as a prefix
0.44.5
Push ./src onto the path so Util.pm gets in.
New Airport.pl replaces METAR2 with a lot nicer stuff.
mendel++. Very nice example of a module with forking,
etc.
Fixed excuse.pl's return codes.
Roderick++'s extensive factoid locking patches for
sharing DBs between infobots.
Added scripts/make_snap and scripts/restore_snap , which
make and restore ASCII snapshots of the databases,
respectively. This is good to do periodically as a
backup.
Added stockquote.pl to get stock quotes (LotR++) and added
a boolean parameter ('stockquotes') to turn it on or off.
Fixed a bug in the http proxy in the RDF fetching code (LotR++)
Messages no longer record the apparent last channel
when given in private.
Changed src/excuse.pl to guard against the server being
down, though i'm afraid the server is never going
to come back up.
Cleaned extra white space off the end of parameter values
during the read of the config file.
Currency exchance is now case-insensetive.
There were several other small bugfixes that didn't make it
into this file during a move.
0.44.4
Removed 'factpacks' subdirectory. These packs are all on
the web site (http://www.infobot.org), and more.
Tidying of purldoc code.
Tidying of W3Search triggers
Tidying of IMDB, Websters, etc.
Splitting lines in say()/msg()
HTTP proxy support
Little tidying of the Math code.
More informative return values from Process
Better support for `no, $nick, ...'
Much increased `tell' support
perlfaq' support: uses RSS to get faqtoids from perlfaqprime
Much needed fixes to Zippy factoids
Babelfish rewritten
Net::Telnet timeout fix to insult
Fixed `exchange' typo in infobot.config.
\| for quoting pipes in factoids, Avi++
Added the channels patch. infobot.channels now sets channel-specific
options. The format is pretty much the same as the users file.
Documented all the extensions.
Fixed the `eval' command, which you shouldn't be using anyway.
Removed spurious line breaks in Zippy's data.
The `msgonly' parameter, if set, will see a question on channel and
respond to it via /msg
The `continuity' parameter controls how many seconds must elapse before
the infobot assumes you have stopped addressing it. Set this to 0,
and the infobot will never assume that it is being addressed.
Added a warning to Babel.pl if target language is `en'
Close `karma' and `seen' databases in &killed, now karma doesn't
get reset.
0.44.3
NOTE: You must update WWW::Search to the latest version
for the Google search to work.
NOTE: As usual, the new features (mostly) have new
parameters that need to be defined in
files/infobot.config -- to update, you'll need
to move your dbm files into the new source
tree and edit infobot.config. this is the best way.
Made return values from myRoutines.pl said or messaged
rather than using &say and &msg inside myRoutines.
Use 'NOREPLY' to override this if you want to
use msg and/or say yourself (such as in a callback
or when forking).
Moved the current myRoutines.pl file to a file called
Extras.pl. myRoutines.pl is reserved for local
user extensions, and Extras.pl is now where the
add-ons in the distribution are. They both
behave the same as the old myRoutines.pl did.
Extras is called after myRoutines.
Moved several redirects out of Reply.pl and into Extras.
Added 'literal' query -- 'literal foo' will show the
factoid for the key foo, with tags and |s literally.
Added RDF/RSS support (LotR++) in RDF.pl. Uses the tag
<rss="http://path/to/rdf/file"> and replaces it in-line.
RSS is RDF Site Summary; many sites now use this
standard format to encode their headlines/topics.
Requires XML::RSS.
Added currency exchange module (exchange.pl) from
bobby@bofh.dk (thanks!)
Added excuse module (excuse.pl), also from bobby@bofh.dk!
Added 'purldoc' -- ^Masque++ -- which searches through
perl FAQ question titles.
Removed usair module. They changed the interface and
this should just be re-written more gerally.
Added support for Zippy.pl, which provides Zippy witticisms.
i made it require to be addressed. "infobot, yow" or
"infobot, be zippy" is the trigger. (mendel++)
the parameter is "zippy" in infobot.config.
Added 'divine (.*)', a magic 8-ball (boojum++)
Made Search work again for users with the +s user flag set.
I still don't recommend this for bots with very big
dbs.
Another pass at getting the 'reload' code to work (Simon++).
Target adressing in 'tell' made more consistent (Simon++).
Now works with MD5 passwords also (thanks to Bobby Billingsley).
Added timeouts to LWP-using modules.
Fixed CTCP ping reply.
Started RIPE whois to complement Internic whois, moved the
whois stuff into myRoutines. This is getting to be
a mess and still needs work. (Thanks to Bo Krosgaard for
this suggestion).
0.44.2
Added USAir flight information: 'usair flight 781'. requires LWP.
This should be replaced with a more general one.
Added keyed channel patch from Eden Li (tile).
Added new slashdot headline retrieval code care of Richard Hoelscher
(Rahga). It makes Chris Tessone's code go to the XML file on /.
Also restricted its recongized form to "slashdot" or "slashdot
headlines". Now called "Slashdot3".
Added a factpack on Security to factopacks/ submitted by Peter
Johnson (rottz), and one that has all the ports listed for tcp
and udp from Samy Kamkar (CommPort5). Keep it up! :)
Applied a patch to the insult server code from michael@limit.org.
should fix the function as well as "insult x in german".
btw, i can't send email to limit.org, so i hope he sees this :)
Modified METAR code from Lazarus Long <lazarus@frontiernet.net>
and added a status line so it tells the owner it requires
LWP and Geo::METAR.
Added Simon Cozens' Google search. Requires WWW::Search::Google.
"google for foo", "search google for foo".
Expanded the Google search to do everything WWW::Search knows about,
and to fork so it wouldn't block the bot. Dejanews, Google,
Gopher, Excite, Infoseek, HotBot, Lycos, AltaVista, Magellan,
PLweb, SFgate, and Verity. try 'search <engine> for <keywords>'.
But you really need to install WWW::Search to use this.
Added "shut up" (which changes Addressing to "REQUIRE"),
"wake up" (changes it to "OPTIONAL"), and "showmode" that
tells which mode it's in. Aldebaran++ for this. the param
"shutup" controls whether this is on; turn it off if you always
want it to be REQUIRE.
Made the output of "seen" nicer; reports how long it's been.
By the way, the Nickometer code is due to Adam Spiers, and it
was one of the earlier, relatively undocumented add-ons that
made an example for others to start off with. Added comment.
0.44.1
Fixed the CTCP bug which people were exploiting to crash. Thanks!
Wrapped the babelfish translation code 'use's in evals so
lack of URI::Escape won't stop you from running the bot.
Added Chris Tessone's slashdot headlines module with a few minor
changes (the same eval trick as above).
Added some documentation to infobot_guide.html (gasp!)
Added some factpacks in factpacks/ that were on the web site.
0.44.0
WARNING: many changes have been undocumented, but
i'm getting lots of requests to release the current
state -- warts and all. Here it is, 6:35 AM Jun 24 99,
an hour before yapc 99 opens.
many small things, as usual.
babel code (jdf++) for using babelfish to translate
things. 'translate to german: hello'. this
can be shortened to 'x to de hello'. *note:
LWP must be installed for this to work.
'insult server' code; probably not very useful.
Also requires LWP.
0.43.6
freeside++ for code to clean up the imbd redirect.
fimmtiu++ for 'your' patches. blame him now.
fixed the text of the foldoc redirect (TorgoX++)
added passwords for servers with passwords (ksiero++)
including server_pass in infobot.config
made s/// case-insensetive (mendel++)
added vhost support and vhost_name to infobot.config (elph++)
changed some trivial status messages to be prettier
made miscdir fully qualified, and changed it to ./files in
the default infobot.config file.
moved stray help setup code into a subroutine and call it
from Setup.pl
added "say" for +o (/msg <botname> say #channel foo)
made it so that +o can make the bot join any channel
added NOAA.pl, inspired by geniusj's sh script
to myRoutines.pl
added METAR support (mendel++ for metar.pl), and this
plus the weather routine make nice examples
0.43.5
added <action> as a species of <reply>: X is <action> foo!
added murrayb++'s patches for an ignore list file
made help path relative (also murrayb++)
renamed "scripts/make_db" to "scripts/update_db"
added "scripts/unupdate_dbs" to back out all changes by nick
from a log file or part of a log file. good for removing
vandalism.
made 'forget' logging more friendly to reversing it
moved all the setup stuff more cleanly into Setup.pl
made the ignore list modifiab;e at run-time with the P flag
and added 'ignore' and 'unignore' commands via msg
added substitutions: X =~ s/A/B/
0.43.4
made private messages not respoken under the persistant
"seen" -- this was allowing people to get private
information on 0.43.3. 0.43.3 was only available for
a few hours, so i hope this impact is minimal.
0.43.3
many undocumented little things. fixes, of course!
fixed the reply after seen.
made seen persistant. added the infobot.config line 'seen'
for the seen-db location
added what the last thing seen was.
made the karma path fully specified.
0.43.2
fixed the learning from other bots based on URL policy
0.43.1
minor fixes here and there.
fixed the math bug (finally! i think!)
several NL patches. Small CTCP fix.
some statement and question changes. nothing major.
wanted to get this version out before i tried getting
things working on a few more platforms. seems
pretty stable.
0.43.0
* UPDATE YOUR irc.params to infobot.config FILES *
* UPDATE YOUR userfile.txt files to infobot.users FILES *
* SOME DOCUMENTATION is now in doc/infobot_guide.html
changed DEBUG parameter name to VERBOSITY
removed the broken STANDALONE mode for now
and eviscerated the code for it
removed some lint from the params file
files/irc.params IS NOW CALLED files/infobot.config
removed vestigial paramdbm code.
removed MacOS-specific code. this needs-writing.
fixed the "out-loud" comment "you are not a bot owner"
to be silent
removed the vesitigial and misleading infobot.doc
and created some documentation ! in doc/infobot.html
and children
renamed userfile.txt to files/infobot.users
added variable interpolation to infobot.config so
you can use $ident and all previously-defined
parameter values in the assignent of subsequent
paramters.
moved userfile diagnostics into User.pl (!) from
top level infobot script
renamed crontab.infobot to infobot.crontab
converted all prints to status() for uniform logging
and console output
removed other vesitigal logging code (Log.pl)
redid the ansi color by type and status
made internic reply via msg only
removed MLF's -- these need rewriting
moved the addressing code ALL out of Irc*.pl
cleared initial negative on statements when the entry
doesn't yet exist (less weird factoids)
added 'also |' to add disjuncts easily
allowed coherent protection of any word from
processing using \. e.g. \is for
x \is y is y
added %channels, %seen, %verified hashes
added password + hostmask protection and command-on-request
with the syntax /msg <bot> <password> <command>
where <command> is {eval (mode e), op (mode p), die (mode o)}
previously public bot commands are now private message only or
privmsg + password
added "sane" files (sane-is.txt amd sane-are.txt) that
will be loaded into the -is and -are dbs at startup
and will set some items to sane values. put things
that you want to be permanent in these.
isolated statement rejection code
moved math into Math.pl
moved search code into Search.pl
rolled the requires in the top level script into a
single loop that automatically loads all the perl
files in the src directory
fixed the interaction between addressing and volunteering.
minVolunteerLength applies only if addressing is not REQUIRED
fixed the grotty math bug in perlMath that prevented negative
numbers from evalling properly
0.42.1
made it go for the _first_ verb rather than
the first verb in the list. cleaned up the
debug info.
fixed the underscore-erasing bug.
there was a problem is \b$verb\b missing
things like .is; fixed.
karma fix... allow "me", tolerate whitespace
(thanks fimmtiu and SirGawain)
0.42
fixed an interaction between marked questions,
minimum volunteering length, and addressing.
allowed talk between friendly bots
rationalized some of the logging, so you can see
who did everything ('is also' updates, in
particular).
fixed the traceroute calling syntax
for some, karma didn't work with 0.41.5; it may now :)
0.41.5
closed the traceroute hole
fixed the reverse DNS
fixed some 'huh?' replies -- made sure to return
the NOREPLY token in Update.pl
* desire: cut confirmation replies (mode)
* desire: silent mode (learn only)
rev 0.41.0 - 0.41.4
many minor things, mostly natural language,
some infrastructure. allowed "forget" to
end with final punctuation.
added factpack subdirectory. use these to
load up the bot with things. more to come.
fixed "addressing" -> REQUIRE.
revision 0.41
added "karma". now "x++" or "x--" will change x's karma.
"karma for x" will show it's current standing. This
idea came from dkindred@cs.cmu.edu and his plusplus
Zephyr bot. Darrel Kindred is the mastermind here;
I just liked the idea and added it.
added e mode in userfile to expose eval. this is not
recommended. requires a crypted pass, then
/msg bot <pass> eval <perl code>
revision 0.40.1
replaced default userfile and fixed a tiny bit of NL where
it would say "OK" even when X already was Y.
the next rev will be the one for MacPerl etc., i hope. this
was just a quick fix because 0.40 wasn't letting people
teach by default.
revision 0.40
several small fixes -- fixed a big with article deletion,
made it so it doesn't echo when told to die by a non-master,
fixed a few NL things, removed the CTCP die command.
Mailing list opens.
I plan one more rev to make sure this pre-version works
with MacPerl, then we'll switch to the new model.
revision 0.39
integrated wf's changes with my own NL stuff from
purl exploits. this is a quick-turnaround rev to
get things in place for an upcoming major rev.
since nslookup, etc are now keyworded, removed
ipmatch and dmatch regexen from their preconditions.
added param for default signoff message
revision 0.38
user system reworked flags are settable to limit
access to the bot's features. Examples can
be found in files/userfile.txt.
non-blocking sockets added to allow use of DCC
and other various functions to come soon.
revision 0.37
Standalone mode works again after an oops in the
hooks by wildy... :)
revision 0.36
NL stuff, some fixes from purl.
revision 0.35
new option; multiline factoids. you can use the
following syntax to teach infobot facts on
multiple lines:
<mynick> infobot: something is <multi>
anything said from there on will be recorded
as part of the fact. make sure you designate
the end of the fact or it will continue adding
everything you say into the fact.
<mynick> <end>
this will end the fact and store it in the db.
made MLFs work with repeatIgnoreInterval to prevent
some nasty abuse potential; added status
line for repeat ignore
revision 0.34
fixed the addressing bug found in Irc.pl
removed the "okay" message when it doesn't replace
a key with the same message; this makes it nicer
when more than one is on the same channel, though
they still all reply
changed the default params to make urls optional
fixed the "the" bug, and expanded the "can" grammar
to handle cases more flexibly.
undid some bug that were introduced in handing the
code back and forth
folded in code that got out of sync in parallel revs.
revision 0.33.3
added the formatting of public channel messages and
changed the hook code to be a bit more sane
revision 0.33.2
re changed infobot to OPTIONAL listening/learning
instead of just url's as default
revision 0.33.1
added a few irc operator things in param file
fixed the math routines
commented out the dotwise domain thing in Question.pl
because its regex didn't function correctly, etc
maybe just use the one nslookup so it doesnt get
confused with messages.
cleaned up for a hopefully stable-ish 0.33
revision 0.32b
infobot doesn't require perl 5.004 anymore, you
can run safely with perl 5.001 i'm pretty sure.
added support for ANSI Color -- enjoy, you
can turn this on/off in the params file. also
might ansi-fy a few more parts. not much though.
fixed bugs with irc code where infobot
couldn't join &channels (local) or channels
with weird things like '!'.
-patrick
fixed the :) bug
fixed non-default param file to files/irc.params
-kevin
revision 0.31b
ok, reintegrating the irc modules.
re-added $nuh support so that users can use their
passwords, etc.
made numbers with more than 16 digits "a very big
number" in the math handling.
it's indentation wars! now that the tabs are gone,
most things indent nicely.
cut out a few vestigial lines from the inlet code,
such as the hard-coded dbs (not used now anyway).
i'm still torn about the copyright/license thing. have
to figure out how to handle that.
changed the default nick back the Newbie.
removed the #$%#$% param db that was bugging me so
much. just read in the param file and be
happy.
renamed "run_infobots.pl" to "run_if_needed.pl" and
made a couple of minor changes in it.
revision 0.30b
thanks, patrick! Patrick Cole (wildfire) did
everything for rev 029b... many many thanks.
made the irc version the default
changed the default server to cmu
changed the default channel to #infobot
will do more in the near future...
NOTE infobot now requires perl 5.004
revision 0.29b
the first and greatest appearance of the inlet code rolled
into infobot. new look makes it easier to see what's
going on and gives it a greater feel to it. All irc
code rewritten by Patrick Cole graciously
added a traceroute command for lazy people, etc
nslookup for domain lookups
reindented all the code by hand (ugh) because it was in an
"Eight Megs and Constantly Swapping" kind of way :)
infobot can now reconnect split servers ...
"/ctcp infobot autorecon on"
internic whois querys should work now hopefully
revision 0.28b
the first appearance of "curl", the command-line url.
useful for one-line queries and updates of the db.
not as full-featured as the standalone url --
these will probably merge.
fixed a minor bug in writeParamFile
woops. it was set to userLevel > 100 for the eval
instead of >= 100.
revision 0.27b
aha! there was a bug in the argument parser; used pop
instead of shift. this ought to work better now.
added absolute path to url in in4m. use this if you're
going to invoke url from anywhere other than the
home directory.
cleaned up in4m (top level) somewhat
added mkpasswd and ckpasswd in anticipation of userlevels
added writeParamFile in urlParams.pl. I still would like
to get away from the param db and just read and write
a flat file.
allowed $date, $time variables in values, e.g. "date is $date"
allowed \i \me \my in values that prevents "person-switching",
e.g. "x is go ahead and tell \me" so it doesn't turn me
into "in4m" or whatever on output
moved $safeWho generation into &purifyNick, which makes a
nick safe to use in a regex (among other things). it
really just removes 'bad' characters.
lifted the 'forget' code above most of the text processing
so it's more wysiwyf ('what you see is what you forget').
stamped out what i hope is the last nick bracket bug
lifted the normalize query and switch person calls into urlQuestion
so that they don't cause weird interaction problems
fixed a bug in 'you' (in switchPerson) referring to the bot
added a 'chomp' on reading init files to keep out extra \n's
added more stuff in urlUser.pl
removed the secretWord potential nightmare and replaced it
with the userlist potential nightmare
addusers, readUserFile, writeUserFile, ckuser, users, etc
etc. in urlUser.pl
userList parameter in irc.params, standalone.params
userlevel 100 exposes eval (!), userlevel 10 lets you
override the 'REQUIRE' option for urls. come to
think of it, REQUIRE could be a number...
allowed 'allowUrls' to be a number, in which case it is
interpreted as the min userlevel to enter a non-url
revision 0.26b
added a '<reply>' prepended tag to allow simple responses
(thanks, scuzzi_)
made the default behaviour not to whine about things that
are already defined (...but x is y...) unless addressed
which makes it nicer when more than one are on the same
channel
revision 0.25b
mucked around with run_infobots.pl to get it working with
cron more obviously
urlProcess had an old-style %params ; changed to %param
moved a check for null paramfile names into loadParams loop
fixed a bracketing error that led to irc mode overriding
made it optional to use the parameter dbm; it's actually
reasonable to just read the irc.params file only
and not go for the "persistant parameters"
revision 0.24b
added a "commitDBM every Nth transaction" form of the parameter
made dbm retry 10 times to open if it fails
changed the default standalone params to point to the right files dir
added a 'usage' output to dump_db to match make_db
added param allowLeave, which lets people make the bot leave a chan
changed the top-level name to just in4m.
added args to the command line: -p, -i, -s, -h
added a src/myRoutines.pl file so people can customize easily
revision 0.23b
fixed dump_db :/ silly me
fixed another little problem in urlDBM.pl
revision 0.22b
set up params as a db. it's still a hack and needs work,
but it allows for persistant params that you can set
within a session.
fixed various problems in referring to the right dbs
removed gratuitous accesses to the dbs
exposed more stuff in the standalone version. see standalone.txt.
set up initialization of dbs within in4m.pl
removed RUN_ME_FIRST
changed %params to %param to make set look nicer
moved make_db and dump_db into scripts/ subdir
and cleaned them up slightly
renamed params/ to files/
made a doc dir and put the README for standalone in there
added 'where is x at' form (thanks, scuzzi)
revision 0.21b
got rid of the question count access to the db.
made -w happier. someday i'll make -s happy too.
added parameter files to make life better.
the first appearance of the standalone desktop interactive
version that doesn't depend on irc.
added params and hooks for the standalone version.
params{nick} behaviour made consistant (urlSetup was overriding).
@allowed_channels fixed to $params{'allowed_channels'}.
fixed the if (($params{'addressing'} eq 'REQUIRE') && $addressed)
to !addressed in urlStatement (thanks again, cburnett).
made it open and close dbm files on each update unless
told otherwise. some implementations did not guarantee
commit. you can check your implementation and set
this to null or something else if you have a smart dbm.
added params for maxKeyLength and maxDataLength.
added params and fixed the help files. help files are
still ugly in the standalone mode.
added allowUpdate parameter so you can have strictly answerbots;
this will tie in to having restricted lists of users + levels.
made it so by default the irc version has no output. turn
up the debug level if you need more insight into what's
going in.
revision 0.20b
this was a quick rev.
fixed some of the gratuitous named stuff in urlProcess.pl
made it so dns wouldn't try to fork under macperl
got the tracking back up
revision 0.19b:
changed the default db's to be infobot-is and infobot-are
changed RUN_ME_FIRST to deal with that and renamed the .txt files
made a wantNick param
make it so dbs are created if don't exist (as option)
fixed $addressed so it didn't just look for prefixes
fixed a couple of the parameters that weren't referring to the hash
changed $urlCount to $factoidCount
revision 0.18b:
moved a bunch of params into the global hash %params
added &params so people can see the settings
e.g. /msg in4m mysecretword &params();
added some parameters up-front for server, port, etc.
changed the bad nickname code
the burnett fix (:$realname)
added infobot.help as a default help file

2
conf/infobot-are.txt
Unescape Escape View File

@ -0,0 +1,2 @@
roses => red
violets => blue

2
conf/infobot-is.txt
Unescape Escape View File

@ -0,0 +1,2 @@
oznoid => at mailto:lenzo@cs.cmu.edu or at http://www.cs.cmu.edu/~lenzo
infobot => at http://www.cs.cmu.edu/~infobot

10
conf/infobot.channels
Unescape Escape View File

@ -0,0 +1,10 @@
# Channel File (c) 1999 Infobot & Associates
ChannelEntry #test {
fallback yes;
addressing REQUIRE;
shutup TRUE;
msgonly TRUE;
continuity 0;
}

256
conf/infobot.config
Unescape Escape View File

@ -0,0 +1,256 @@
# parameter settings file for the infobot
# kevin lenzo (lenzo@cs.cmu.edu)
# note:
# '$var' means a parameter that has been named; it is interpolated.
# By convention, things with '.ext' (extensions) are text files, and
# things with hyphens in them are DBM file prefixes, used for run-time
# learning or state maintenance.
#
# Nota Bene: Comment out attributes you don't want. Note that the
# word "false" is actually a true value! use 0 or comment
# out options you don't want.
# the internal name for this bot
ident xpubbot
# the nickname we want
wantNick $ident
# the prefix of the dbm files
dbname $ident
# where to put logging info
logfile $dbname.log
# plusplus, an idea hijacked from CMU zephyr community,
# and dkindred++ in particular. Otherwise known
# as 'karma'. this is persistant between shutdowns.
plusplus $dbname-karma
# persistant "seen" db
seen $dbname-seen
# do we have an ignore database? uncomment this if not.
ignore $dbname-ignore
# should we ALWAYS close and reopen dbm on update?
# some systems don't do commitment until quit.
#
# 0 => never force sync
# 1 => force sync on every update
# N => force sync every Nth update
commitDBM 5
# Explicitly set the database module. The default is AnyDBM_File. If
# you want to use any shared database files (via sharedDBMs) you have to
# set this to DB_File.
#DBMModule DB_File
# Specify an extension which should be added to all database names. By
# default this is empty.
#DBMExt .db
# Specify which databases will be shared among multiple infobots on the
# same machine, and so require locking. By default none are shared. If
# you use this at all you have to set DBMModule to DB_File. This can be
# a list of database names, or /all (which means every database), or
# /all-but-ignore (which means every database except the ignore list).
#
# As of this writing, the databases are:
#
# is main database, for singular factoids
# are main database, for plural factoids
# ignore ignored nicks and user/host patterns
# plusplus karma
# seen last seen info by each nick
#sharedDBMs is are plusplus
#sharedDBMs /all
#sharedDBMs /all-but-ignore
# X is Y
# max length of X (the key,
# the 'left hand side' (LHS) of an assignment,
# or the first argument)
maxKeySize 50
# max length of Y (value or data, the 'right hand side', or 2nd argument)
maxDataSize 400
# REQUIRE, OPTIONAL, REJECT for 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.
acceptUrl OPTIONAL
# IRC-related params
ircuser $ident
realname $ident
# server irc.infobot.org
server irc.freenode.net
port 6667
allowed_channels #xpub #infobot #$ident #test
# channels to join
# use #channel,key (thanks to tile++) for keyed channels
# join_channels #infobot #$ident
join_channels #xpub
# server password, if needed
# server_pass myserverpassword
# vhost support... if you have a vhost, you can use this,
# otherwise it won't work.
# inm++, elph++ for this :)
# vhost_name f00.bar.org
# nickServ_pass foo
# chanServ_pass bar
# addressing is when you name the bot. if this is REQUIRE,
# the bot should only speak when spoken to. BUT it may listen.
# anything else will mean it can barge in when it thinks it
# knows something.
# "shutup" determines whether you can switch modes on the
# fly with the bot. if you use REQUIRE for addressing, you
# probably want to comment out the shutup line.
addressing OPTIONAL
# shutup TRUE
# ansi screen control is available from 0.32 onwards
# value of 1 means to use ANSI, 0 means generic bold
ansi_control 1
# things we may or may not want to allow. 1 = allow, 0 otherwise.
# do you want to be a desktop calc?
perlMath 1
fortranMath 0
# do you want to allow DNS lookup/Internic/Traceroute?
allowDNS 1
allowTraceroute 1
allowInternic 1
# ord/chr etc
allowConv 1
# tell so-and-so about such-and-such
allowTelling 1
# let any old joe update stuff. if this is 0, you'll have to
# either change some code, do everything with e.g. update_db,
# or do something else arcane to get factoids in.
allowUpdate 1
# How much verbage to display on the console
VERBOSITY 1
# the magic hack word to unignore everyone
unignoreWord unignore-everyone
# where configuration and help files and such live, the default is the
# files subdir of the main directory
confdir conf
# my help file. this will get confdir prepended
# you may want to change this to $ident.help
helpfile infobot.help
srcdir src
extradir extras
# within how long of getting the same reply should
# we not respond (irc mode only). in seconds.
repeatIgnoreInterval 8
# in what contexts do we let people make the bot leave a
# channel (this is an or'd list; public private)
allowLeave public
# our user list default file (in miscdir)
# you may want to change this to $ident.users
userList infobot.users
# channel list, specifies options which differ from the defaults, by
# channel.
channelList infobot.channels
# default quit message
quitMsg regrouping; bbiab
# how long does something have to be before we'll just volunteer
# the answer without a question mark, question, or being addressed
minVolunteerLength 8
# other bots to ask for help
# friendlyBots url purl script mrapi
# sane defines that ALWAYS overwrite existing values at startup
# this is a prefix for the files (sane-is.txt, sane-are.txt)
sanePrefix sane
# allow weather and METAR lookups, respectively. These should
# actually be turned into a user modes. mendel++. Require
# LWP and metar requires Geo::METAR.
weather true
metar true
# babelfish translator. jdf++. requires LWP, not included.
babel true
# slashdot headlines. requires LWP, not included. get it from CPAN.
slash true
# insult and excuse servers
insult true
excuse true
# google search.. simon++ . expanded to www search using several
# engines since it was so easy once you have WWW::Search.
# use "update" if you want it to update the db, or comment
# out if you don't want it. requires WWW::Search, not included.
# use "forceupdate" to force a db update on every google search.
wwwsearch update
# general headline-getter. uses RDF. (LotR++)
rss true
# purldoc perl documentation lookup DMasque++, HJ++
purldoc true
purldoc_trigger purldoc
purldoc_max_public 3
# speller. requires the ispell program.
ispell true
#zippy quotes (infobot, yow or infobot, be zippy)
zippy true
# the magic 8ball (divine)
magic8_answers $miscdir/magic8.txt
# exchange rates (exchange 233 DEM to USD)
exchange true
# stock quotes
stockquotes true

254
conf/infobot.config-dist
Unescape Escape View File

@ -0,0 +1,254 @@
# parameter settings file for the infobot
# kevin lenzo (lenzo@cs.cmu.edu)
# note:
# '$var' means a parameter that has been named; it is interpolated.
# By convention, things with '.ext' (extensions) are text files, and
# things with hyphens in them are DBM file prefixes, used for run-time
# learning or state maintenance.
#
# Nota Bene: Comment out attributes you don't want. Note that the
# word "false" is actually a true value! use 0 or comment
# out options you don't want.
# the internal name for this bot
ident i-bot
# the nickname we want
wantNick $ident
# the prefix of the dbm files
dbname $ident
# where to put logging info
logfile $dbname.log
# plusplus, an idea hijacked from CMU zephyr community,
# and dkindred++ in particular. Otherwise known
# as 'karma'. this is persistant between shutdowns.
plusplus $dbname-karma
# persistant "seen" db
seen $dbname-seen
# do we have an ignore database? uncomment this if not.
ignore $dbname-ignore
# should we ALWAYS close and reopen dbm on update?
# some systems don't do commitment until quit.
#
# 0 => never force sync
# 1 => force sync on every update
# N => force sync every Nth update
commitDBM 5
# Explicitly set the database module. The default is AnyDBM_File. If
# you want to use any shared database files (via sharedDBMs) you have to
# set this to DB_File.
#DBMModule DB_File
# Specify an extension which should be added to all database names. By
# default this is empty.
#DBMExt .db
# Specify which databases will be shared among multiple infobots on the
# same machine, and so require locking. By default none are shared. If
# you use this at all you have to set DBMModule to DB_File. This can be
# a list of database names, or /all (which means every database), or
# /all-but-ignore (which means every database except the ignore list).
#
# As of this writing, the databases are:
#
# is main database, for singular factoids
# are main database, for plural factoids
# ignore ignored nicks and user/host patterns
# plusplus karma
# seen last seen info by each nick
#sharedDBMs is are plusplus
#sharedDBMs /all
#sharedDBMs /all-but-ignore
# X is Y
# max length of X (the key,
# the 'left hand side' (LHS) of an assignment,
# or the first argument)
maxKeySize 50
# max length of Y (value or data, the 'right hand side', or 2nd argument)
maxDataSize 400
# REQUIRE, OPTIONAL, REJECT for 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.
acceptUrl OPTIONAL
# IRC-related params
ircuser $ident
realname $ident
server irc.infobot.org
port 6667
allowed_channels #infobot #$ident #test
# channels to join
# use #channel,key (thanks to tile++) for keyed channels
join_channels #infobot #$ident
# server password, if needed
# server_pass myserverpassword
# vhost support... if you have a vhost, you can use this,
# otherwise it won't work.
# inm++, elph++ for this :)
# vhost_name f00.bar.org
# nickServ_pass foo
# chanServ_pass bar
# addressing is when you name the bot. if this is REQUIRE,
# the bot should only speak when spoken to. BUT it may listen.
# anything else will mean it can barge in when it thinks it
# knows something.
# "shutup" determines whether you can switch modes on the
# fly with the bot. if you use REQUIRE for addressing, you
# probably want to comment out the shutup line.
addressing OPTIONAL
# shutup TRUE
# ansi screen control is available from 0.32 onwards
# value of 1 means to use ANSI, 0 means generic bold
ansi_control 1
# things we may or may not want to allow. 1 = allow, 0 otherwise.
# do you want to be a desktop calc?
perlMath 1
fortranMath 0
# do you want to allow DNS lookup/Internic/Traceroute?
allowDNS 1
allowTraceroute 1
allowInternic 1
# ord/chr etc
allowConv 1
# tell so-and-so about such-and-such
allowTelling 1
# let any old joe update stuff. if this is 0, you'll have to
# either change some code, do everything with e.g. update_db,
# or do something else arcane to get factoids in.
allowUpdate 1
# How much verbage to display on the console
VERBOSITY 1
# the magic hack word to unignore everyone
unignoreWord unignore-everyone
# where configuration and help files and such live, the default is the
# files subdir of the main directory
confdir conf
# my help file. this will get confdir prepended
# you may want to change this to $ident.help
helpfile infobot.help
srcdir src
extradir extras
# within how long of getting the same reply should
# we not respond (irc mode only). in seconds.
repeatIgnoreInterval 8
# in what contexts do we let people make the bot leave a
# channel (this is an or'd list; public private)
allowLeave public
# our user list default file (in miscdir)
# you may want to change this to $ident.users
userList infobot.users
# channel list, specifies options which differ from the defaults, by
# channel.
channelList infobot.channels
# default quit message
quitMsg regrouping; bbiab
# how long does something have to be before we'll just volunteer
# the answer without a question mark, question, or being addressed
minVolunteerLength 8
# other bots to ask for help
# friendlyBots url purl script mrapi
# sane defines that ALWAYS overwrite existing values at startup
# this is a prefix for the files (sane-is.txt, sane-are.txt)
sanePrefix sane
# allow weather and METAR lookups, respectively. These should
# actually be turned into a user modes. mendel++. Require
# LWP and metar requires Geo::METAR.
weather true
metar true
# babelfish translator. jdf++. requires LWP, not included.
babel true
# slashdot headlines. requires LWP, not included. get it from CPAN.
slash true
# insult and excuse servers
insult true
excuse true
# google search.. simon++ . expanded to www search using several
# engines since it was so easy once you have WWW::Search.
# use "update" if you want it to update the db, or comment
# out if you don't want it. requires WWW::Search, not included.
# use "forceupdate" to force a db update on every google search.
wwwsearch update
# general headline-getter. uses RDF. (LotR++)
rss true
# purldoc perl documentation lookup DMasque++, HJ++
purldoc true
purldoc_trigger purldoc
purldoc_max_public 3
# speller. requires the ispell program.
ispell true
#zippy quotes (infobot, yow or infobot, be zippy)
zippy true
# the magic 8ball (divine)
magic8_answers $miscdir/magic8.txt
# exchange rates (exchange 233 DEM to USD)
exchange true
# stock quotes
stockquotes true

2
conf/infobot.crontab
Unescape Escape View File

@ -0,0 +1,2 @@
*/5 * * * * /usr/users/you/infobot0.1b/run_infobots.pl > /dev/null

13
conf/infobot.help
Unescape Escape View File

@ -0,0 +1,13 @@
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?"
author: oznoid (mailto:lenzo@ri.cmu.edu) is my author.
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 add to an entry with "also". "X is also at ..."
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".
reply: This is a good way to close junk entries; use "X is <reply>" with nothing after it.
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.
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?"

13
conf/infobot.help-dist
Unescape Escape View File

@ -0,0 +1,13 @@
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?"
author: oznoid (mailto:lenzo@ri.cmu.edu) is my author.
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 add to an entry with "also". "X is also at ..."
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".
reply: This is a good way to close junk entries; use "X is <reply>" with nothing after it.
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.
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?"

42
conf/infobot.users
Unescape Escape View File

@ -0,0 +1,42 @@
#
# User File (c) 1998 Infobot & Associates
#
# FLAGS
# ----------------------
# i Ignored Flag
# f MLF Usage Allowed
# t Teaching Allowed
# r Removing Allowed
# m Modifying Allowed
# c Part/Join Allowed
# s Searching Allowed (possibly computationally expensive)
# S user can make bot Say things
# e Extra Privs [ not implemented robustly: AVOID ]
# p oP on channel by public request
# ----------------------
# o Owner Flag
# ----------------------
#
# recommended default user flags: +trmc
UserEntry default {
flags +trmcs;
}
# here's an example entry
UserEntry oznoid {
name "Kevin A. Lenzo";
title "that guy";
flags +ftrmcsSope;
pass rrmrxB6U4ryRk;
mask *!lenzo@*.speech.cs.cmu.edu;
}
UserEntry plonk {
name "Eep Malloy"
title "that guy II";
flags +trmcspo;
pass rrmrxB6U4ryRk;
mask *!*@*.static.telerama.com
}

42
conf/infobot.users-dist
Unescape Escape View File

@ -0,0 +1,42 @@
#
# User File (c) 1998 Infobot & Associates
#
# FLAGS
# ----------------------
# i Ignored Flag
# f MLF Usage Allowed
# t Teaching Allowed
# r Removing Allowed
# m Modifying Allowed
# c Part/Join Allowed
# s Searching Allowed (possibly computationally expensive)
# S user can make bot Say things
# e Extra Privs [ not implemented robustly: AVOID ]
# p oP on channel by public request
# ----------------------
# o Owner Flag
# ----------------------
#
# recommended default user flags: +trmc
UserEntry default {
flags +trmcs;
}
# here's an example entry
UserEntry oznoid {
name "Kevin A. Lenzo";
title "that guy";
flags +ftrmcsSope;
pass rrmrxB6U4ryRk;
mask *!lenzo@*.speech.cs.cmu.edu;
}
UserEntry plonk {
name "Eep Malloy"
title "that guy II";
flags +trmcspo;
pass rrmrxB6U4ryRk;
mask *!*@*.static.telerama.com
}

44
conf/magic8.txt
Unescape Escape View File

@ -0,0 +1,44 @@
original => Outlook Not So Good
original => My Reply Is No
original => Don't Count On It
original => You May Rely On It
original => Ask Again Later
original => Most Likely
original => Cannot Predict Now
original => Yes
original => Yes Definitely
original => Better Not Tell You Now
original => It Is Certain
original => Very Doubtful
original => It Is Decidedly So
original => Concentrate and Ask Again
original => Signs Point to Yes
original => My Sources Say No
original => Without a Doubt
original => Reply Hazy, Try Again
original => As I See It, Yes
sarcastic => NOT
sarcastic => What do YOU think
sarcastic => Obviously
sarcastic => Ask me if I care
sarcastic => Yeah, and I'm the Pope
sarcastic => That's ridiculous
sarcastic => Who cares
sarcastic => Forget about it
sarcastic => You wish
sarcastic => Yeah, right
sarcastic => Sure
sarcastic => Get a clue
sarcastic => In your dreams
sarcastic => Oh, please
sarcastic => Whatever
sarcastic => As if
sarcastic => You've got to be kidding
sarcastic => Dumb question. Ask another
sarcastic => Not a chance
userdef => Outlook Sucks
userdef => THIS SPACE FOR RENT
userdef => Bugger Off
userdef => How appropriate, you fight like a cow
userdef => Eat more cheese, then ask again
userdef => When hell freezes over

6
conf/sane-are.txt
Unescape Escape View File

@ -0,0 +1,6 @@
what => <reply>
who => <reply>
when => <reply>
where => <reply>
why => <reply>
it => <reply>

3
conf/sane-ignore.txt
Unescape Escape View File

@ -0,0 +1,3 @@
*cthulhu!hastur@*unspeakable.net # an example nick!user@host ban
*!*@*nan*direct.ca
*!*@200.38.211.*

8
conf/sane-is.txt
Unescape Escape View File

@ -0,0 +1,8 @@
what => <reply>
who => <reply>
when => <reply>
where => <reply>
why => <reply>
it => <reply>
how => <reply>
infobot guide => http://www.cs.cmu.edu/~infobot/infobot_guide.html

37
doc/how_to_fix_files_uploaded_from_windows_to_unix.txt
Unescape Escape View File

@ -0,0 +1,37 @@
FIXING PERL AND TEXT FILES THAT HAVE BEEN UPLOADED FROM WINDOWS
OK when you upload a file from Windows, it contains all
these nasty control-M's on each line that screw everything
up.
To see them, use
cat -vet <file>
where <file> is the name of some file you want to check.
You should see the control-M's.
To get rid of them, use
perl -pi -e 's/\cM//g' <file>
while <file> is the file name. This does an in-place edit
that removes all the control-Ms. You can do this to a bunch
of files at once:
perl -pi -e 's/\cM//g' <file1> <file2> <file3>
or even
perl -pi -e 's/\cM//g' *
if all the files in the directory are text (like they ARE in
the files/ directory of the infobot).
perl -pi -e 's/\cM//g' files/* src/* infobot
from inside the infobot directory should clean everything up.
You should also clean any factpacks or factoid files or logs
that you use for processing.
kevin

652
doc/infobot_guide.html
Unescape Escape View File

@ -0,0 +1,652 @@
<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN">
<html>
<head>
<title>Infobot Guide 0.44.3</title>
</head>
<body bgcolor="#ffffff">
<h1>Infobot Guide 0.44.3</h1>
<hr>
The canonical source for the infobot source and documentation is
<a href="http://www.cs.cmu.edu/~infobot">http://www.cs.cmu.edu/~infobot</a>.
<hr>
<p>
The infobot connects to an Internet Relay Chat (IRC) server,
joins some channels (maybe), and begins accumulating factoids.
To run one, download the source, uncompress it, untar it,
edit the config files, and it up.
<p>
Interacting with the bot is pretty straightforward. Most of
the commands and variables available to users are listed below.
The bot will interact via message or on-channel.
<p>
<hr>
<h2> Interacting with an infobot</h2>
<UL>
<LI> <b>setting</b> factoids: X is Y
<p>
Saying something like "X is Y" somewhere that the infobot
can see it will cause the bot to store a factoid, unless
X is already defined. It sets the value of X to Y.
<p>
<LI> <b>accessing</b> factoids: What is X?
<p>
You can ask an infobot about something in a number of
different ways, including "what is X?", "where is X?",
or just plain "X?".
</p>
<LI> <b>altering</b> factoids: s/A/B/
<p>
if you just want to change a <i>part</i> of a factoid, use
the <code>s///</code>operator. you have to address the bot
or use a private medium to do this.
<p>
MyBot, X =~ s/A/B/
<p>
will change the first occurence of A to B in the factoid
called X.
<p>
<LI>appending to existing entries: <b><code>also</code></b>
<p>
One can extend an existing factoid using the
keyword <code>also</code>
<p>
<UL>
<code>
poink is also a silly word
</code>
</UL>
<p>
<LI>erasing a factoid: <b><code>forget</code></b>
<p>
A factoid can easily be deleted by using
<p>
<DIR>
<code>
infobot, forget poink
</code>
</DIR>
<p>
<LI>changing a factoid: <code><b>no,</b> ...</code>
<p>
You can change the entry for a factoid completely using
<p>
<UL>
<code>
no, infobot, x is wugga wugga.
</code>
</UL>
<p>
which deletes the prior entry (if possible)
and replaces it with the new one.
<p>
<LI> having the bot tell someone else something: <b><code>tell</code></b>
<p>
A user can ask an infobot to tell someone else something.
<p>
<UL>
<code>
infobot, tell fimmtiu about no web
</code>
<p>
</UL>
<LI><b>karma</b> / plusplus
<p>
karma for a concept may be incremented or decremeted using
<code>++</code> and <code>--</code>. You can get the
current karma 'score' for something by asking for it.
<p>
<UL>
<code>
oznoid++
<p>
oznoid--
<p>
karma for oznoid
</code>
<p>
</UL>
<LI> <code><b>status</b></code>
<p>
infobots reply to status requests.
<p>
<dir>
-> [url] status<p>
[url!infobot@ALF5.SPEECH.CS.CMU.EDU] Since Fri Mar 26 06:42:27 1999, there have been 409
modifications and 2604 questions. I have been awake for 5 days, 4 hours, 24 minutes,
18 seconds this session, and currently reference 47529 factoids.
</dir>
</p>
<LI>joining an allowed channel: <code><b>join</b> #infobot</code>
<p>
On IRC, you can tell the infobot to join a channel
that it's allowed to join with
<p>
<UL>
<code>
infobot, join #infobot
</code>
</UL>
<p>
If it is allowed to (in its paramter settings), it
will try to join the channel.
<p>
<LI>leaving a channel: <code><b>part</b> #infobot</code>
<p>
This causes the bot to leave the given channel
<p>
<UL>
<code>
infobot, part #infobot
</code>
</UL>
<p>
<code>leave</code> is a synonym for <code>part</code>.
<p>
<LI><b>random</b> responses with <code>|</code>
<p>
You can set a list from which to pick a random response by
using <code>|</code>
<p>
<UL>
<code>
x is a|b|c|d
</code>
</UL>
<p>
When x is asked about, the infobot will randomly choose from
the <code>|</code>-spearated list.
<p>
<LI> The <b><code>&lt;reply&gt;</code></b> factoid tag.
<p>
Normally, when the infobot replies to "What is X", it says
"X is Y". This form makes it just reply "Y".
<p>
<UL>
<code>
X is &lt;reply&gt; Y
</code>
</UL>
<p>
<LI> The <b><code>&lt;action&gt;</code></b> factoid tag (as of 0.43.5)
<p>
This causes the bot to respond as with <reply> except
as an ACTION.
<p>
<UL>
<code>
X is &lt;action&gt; Y
</code>
</UL>
<p>
<LI><b>backwacking</b>
<p>
Use <code>\</code> to protect items from evaluation.
<p>
<UL>
<CODE>
x is y is y
</CODE>
</UL>
<p>
will normally set <code>x =is=> y is y</code>, but
<p>
<UL>
<CODE>
x \is y is y
</CODE>
</UL>
<p>
will set
<p>
<UL>
<code>x is y =is=> y</code>
</UL>
<p>
The <code>forget</code>
and <code>no</code> (update) operators apply before checking
for this. This is also useful for getting around the
dereferencing of "i" and "me" and so on.
<p>
<LI>the <b><code>$who</code></b> variable
<p>
Contains the nickname person currently addressing the bot.
It can be used effectively in replies.
<p>
<UL>
<code>
nice day is &lt;reply&gt; you betcha, $who.
</code>
</UL>
<p>
<LI>the <b><code>$date</code></b> variable
<p>
Contains the current date and time, at the bot's host.
<p>
<LI> <code><b>weather</b> for KAGC</code> (0.43.6+)
<p>
Retrieves the weather from NOAA station KAGC. See www.noaa.gov.
Note: Requires LWP.
<p>
<UL>
<LI> <code><b>metar</b> KAGC</code> (0.43.6+)
</UL>
<p>
Retrieves METAR info from NOAA station KAGC. See www.noaa.gov.
Note: Requires Geo::METAR and LWP.
<p>
<LI> <code><b>nslookup</b> irc.cs.cmu.edu</code>
<p>
performs DNS lookup or reverse-lookup on the hostname or IP.
<p>
<LI><code><b>internic</b> yahoo.com</code>
<p>
gets the internic WHOIS record
<p>
<LI><code><b>traceroute</b> apple.com</code>
<p>
gets the traceroute results from the bot's machine to the target machine. Summary only.
<p>
<LI><b>imdb, websters, foldoc</b>
<p>
outputs a well-formed url for a search of IMDB (the Internet Movie DataBase), the Webster's 1913 dictionary, or the foldoc dictionary of geek terms.
<p>
<UL>
<code>
imdb for clerks<p>
webster for lucre
</code>
</UL>
<p>
<LI> New in 0.44.3:
<p>
<UL>
<LI> <code><b>literal</b> foo</code>
<p>
returns the value without the usual post-processing.
</p>
<LI> <code><b>change</b> 100 USD to DEM</code>
<p>
converts currency. Retrieves the current exchange rates from the net.
Requires LWP.
</p>
<LI> <code>&lt;rss="http://www.foo.com/summary.rss"&gt;</code>
<p>
looks up the RSS file (RDF Site Summary) and returns it
in-place where the tag is. Requires XML::RSS and LWP.
</p>
<LI> <code>give me an excuse</code>, or <code>excuse</code>
<p>
connects to the excuse server and returns an excuse.
requires Net::Telnet.
</p>
</UL>
<p>
<LI>Ignoring users: <b>ignore</b> nickname, <b>ignore *.a.com</b>
<p>
Users with the P (oP) flag can tell the bot
to ignore people or hostmasks. And 'unignore'.
use 'ignorelist' to get the current list of ignored masks,
if you have the P flag.
</p>
<LI><code><b>op</b></code> on channel
<p>
The 'p' (oP) flag in the userfile allows this
to work. You'll need to set a hostmask. See
<code>files/infobot.users</code> Also uses a
crypted password.
<p>
<dir>
<code>
/msg &lt;bot&gt; &lt;password&gt; op
</code>
</dir>
<p>
<LI><b><code>die</code></b>
<p>
If the bot owner (+O, Owner) says this or messages it to the bot,
it will kill itself.
<p>
</UL>
<hr>
<h2> scripts/utilities </h2>
The infobot comes with some scripts for working with
the DBM files.
<p>
<UL>
<LI><code>update_db</code>
<p>
This takes a flat ascii file and inserts it into a DBM file.
It creates a new DBM if it didn't exist.
<p>
<UL>
<CODE>
scripts/update_db factpacks/code_to_country.txt infobot-is
</CODE>
</UL>
<p>
will add the factoids in <code>code_to_country.txt</code>
to the <code>infobot-is</code> DBM.
<p>
If you've set <code>DBMModule</code> in your config file, you
need to use the <code>-m</code> switch to specify the alternate
module.
<p>
<UL>
<CODE>
scripts/update_db -d DB_File factpacks/code_to_country.txt infobot-is
</CODE>
</UL>
<p>
<LI><code>dump_db</code>
<p>
The converse. It dumps out the DBM file to a flat
ascii file. Note there is no extension on the DBM name,
even though the system may use one.
<p>
<UL>
<CODE>
scripts/dump_db infobot-is
</CODE>
</UL>
<p>
Note there is no extension on the DBM name, even though the
system may use one (like <code>.pag</code> and
<code>.dir</code> or <code>.db</code>).
<p>
If you've set <code>DBMModule</code> in your config file, you
need to use the <code>-m</code> switch to specify the alternate
module.
<p>
<UL>
<CODE>
scripts/dump_db -m DB_File infobot-is
</CODE>
</UL>
<p>
</UL>
<hr>
<h3> add-on modules </h3>
<UL>
<LI> <code>nickometer</code>, by Adam Spiers. Guages
how 'lame' a nickname is, as a percentage!<p>
<UL>
<code>
nickometer l33tn1ck
</code>
</UL>
<p>
<LI> <code>babel.pl</code> by jdf. translates using the
<a href="http://babelfish.altavista.com/">babelfish</a>
web site for machine translation.
In this implementation, English is assumed
to be the 'main' language, thus everything is
translated <code>to</code> or <code>from</code> another
language.
<p>
<UL>
<code>
(x|translate) (to|from) (de|fr|pt|es|it|german|french|portugese|spanish|italian)
<p>
translate to german this is a test<br>
x to german this is another test<br>
x to de and a third<br>
x from de ein bisschen Deutsch<p>
German, French, Spanish, Italian, and Portugese are
currently supported by babelfish.
</code>
</UL>
<p>
<LI> <code>METAR</code> support, courtesy of mendel<p>
<code>metar KAGC</code>
<p>
retrieves METAR information for KAGC, the Allegheny
County airport station.
<p>
<LI> <code>NOAA</code> weather station support, courtesy of oznoid<p>
<ul>
<code>weather KAGC</code>
</ul>
<p>
retrieves the
<a href="http://weather.noaa.gov/weather/curcond.html">NOAA</a>
weather information from (in this example) KAGC. uses the
same
<a href="http://weather.noaa.gov/weather/curcond.html">codes</a>
as metar info.
<p>
<LI> <code>slashdot</code> headlines, originally from Chris Tessone,
current version from Rahga.<p>
<p>
<ul>
<code>slashdot</code><br>
<code>slashdot headlines</code>
</ul>
<p>
retrieves the current slashdot headlines from
<a href="http://www.slashdot.org">www.slashdot.org</a>.
<LI> W3Search: search web engines for links; thanks
to Simon Couzins for this one. Requires
WWW::Search and WWW::Search::Google.
<ul>
<code>search google for foo</code><br>
<code>google for foo</code><br>
<code>altavista for foo</code><br>
<code>dejanews for foo</code>
</ul>
Currently supports what WWW::Search and WWW::Search::Google
support, namely: Dejanews, Google, Gopher, Excite, Infoseek,
HotBot, Lycos, AltaVista, Magellan, PLweb, SFgate, and Verity.
<p>
<LI>US Airways In-flight info.
<ul>
<code>usair flight 781</code>
</ul>
retrieves the in-flight information for the
appropriate USAir flight. Note: Requires LWP.
</UL>
<hr>
<h2> setting up </h2>
<h3> configuration </h3>
<UL>
<LI> <b> editing the parameter file </b>
<p>
The parameter file, usually in <code>files/infobot.config</code>,
is the most direct way to customize the settings on your infobot.
<p>
<LI> <b>editing the user file</b>
<p>
The user file, usually in <code>files/infobot.users</code>,
is the most direct way to customize the settings on your infobot.
<p>
<LI> <b> editing the main script </b>
<p>
There are certain items you may need to fiddle with
in the main script of the infobot, but normally you
shouldn't have to. The usual reasons are
<p>
<UL>
<LI> <b> changing the bang path to perl </b>
<p>
If you get
<p>
<UL>
<code>
infobot: Command not found.
</code>
</UL>
<p>
or something like it, you need to edit the infobot
script at the top level directory (the script named
'infobot') and set the path to you perl interpreter
in the very first line of the script to
<p>
<UL>
<code>
#!/path/to/perl
</code>
</UL>
<p>
with, of course, the full path to your perl binary.
<p>
<LI> <b> explicitly setting normally relative paths </b>
<p>
If you don't have . in your path, you will probably
need to set some variables explicitly that are normally
determined relative to the infobot script. This is
done in the 'infobot' script.
<p>
</ul>
<LI> <b>Installing Modules to enable features</b>
<p>
Several add-ons, like <code>weather</code> and
web <code>search</code> require perl modules to
be installed. The easiest way to get all the
things you need is to install the CPAN.pm module,
available from <a href="http://www.perl.com/CPAN/modules-by-module/CPAN/">CPAN</a>, and use it to install what you need. This
is best done as root.<p>
Once you have the CPAN module installed, use
it to install the required modules:
<p>
<ul>
<li>the main thing: <code>install Bundle::LWP</code>
<li>for METAR: <code>install Geo::METAR</code>
<li>for W3Search:
<ul>
<li><code>install WWW::Search</code>
<li><code>install WWW::Search::Google</code>
</ul>
</ul>
Once these are installed, start or restart your infobot.
</UL>
<p>
</UL>
<hr>
<h3> running the infobot </h3>
<UL>
<LI> <b>starting it up</b>
<p>
This should be as simple as entering the infobot
parent directory and executing
<p>
<UL>
<code>
infobot
</code>
</UL>
<p>
This starts up the script and generates a whole lot of text.
It's useful and interesting to see what's going on "in the
infobot's head". You can control the amount of verbage
that comes out with the <code>VERBOSITY</code> parameter,
of you can dump all the output to the bitbucket and background
the process at the same time with
<p>
<UL>
<code>
nohup infobot > /dev/null &
</code>
</UL>
<p>
<LI> <b>the console</b>
<p>
Should you choose to look at the stream if consciousness
in the bot, and you haven't reduced the output to nothing
or consigned it to the void, you will be presented with
the <b>console</b>.
<p>
The first thing you should see, assuming all goes well with
making a connection, is the <b>motd</b> (message-of-the-day)
of the server the bot has been configured to connect to.
<p>
Next, you should see the result of the channel joins specified
in the parameter files, and you may see the bot recognizing
hostmasks of people in the userfile, if any have been put
in there.
<p>
If you have the <code>ansi_control</code> paramter set,
and your terminal supports it, the output will be in color.
<p>
NOTE that the 'console' is NOT interactive. You can't
type anything into it; it's just for viewing what's going on.
<p>
<LI> <b><code>cron</code>ning the infobot</b>
<p>
You can set the infobot to automatically start up using
<code>cron</code>. See the included example <code>crontab</code>
file, in <code>files/infobot.crontab</code>
</UL>
<hr>
<h3> shutting it down </h3>
If you have set yourself as the bot's master in the user file
(<code>infobot.users</code>, unless you changed the default),
you can just say or message 'die' to the bot.
<p>
Otherwise, kill the process or hit control-c in the console.
<p>
<hr>
<h2> the FAQ </h2>
The FAQ is available at
<a href="http://www.cs.cmu.edu/~infobot/faq/">
http://www.cs.cmu.edu/~infobot/faq/</a>. It is growing. Slowly.
<hr>
<address><a href="mailto:infobot@protected.speech.cs.cmu.edu">infobot@protected.speech.cs.cmu.edu</a></address>
<!-- Created: Sat Aug 15 12:00:57 EDT 1998 -->
<!-- hhmts start -->
Last modified: Tue Oct 26 14:24:41 EDT 1999
<!-- hhmts end -->
</body>
</html>

312
doc/intro.bit
Unescape Escape View File

@ -0,0 +1,312 @@
<hr>
The canonical source for the infobot source and documentation is
<a href="http://www.infobot.org/">http://www.infobot.org/</a>.
<hr>
<p>
The infobot connects to an Internet Relay Chat (IRC) server,
joins some channels (maybe), and begins accumulating factoids.
To run one, download the source, uncompress it, untar it,
edit the config files, and it up.
<p>
Interacting with the bot is pretty straightforward. Most of
the commands and variables available to users are listed below.
The bot will interact via message or on-channel.
<p>
<hr>
<h2> Interacting with an infobot</h2>
<UL>
<LI> <b>setting</b> factoids: X is Y
<p>
Saying something like "X is Y" somewhere that the infobot
can see it will cause the bot to store a factoid, unless
X is already defined. It sets the value of X to Y.
<p>
<LI> <b>accessing</b> factoids: What is X?
<p>
You can ask an infobot about something in a number of
different ways, including "what is X?", "where is X?",
or just plain "X?".
</p>
<LI> <b>altering</b> factoids: s/A/B/
<p>
if you just want to change a <i>part</i> of a factoid, use
the <code>s///</code>operator. you have to address the bot
or use a private medium to do this.
<p>
MyBot, X =~ s/A/B/
<p>
will change the first occurence of A to B in the factoid
called X.
<p>
<LI>appending to existing entries: <b><code>also</code></b>
<p>
One can extend an existing factoid using the
keyword <code>also</code>
<p>
<UL>
<code>
poink is also a silly word
</code>
</UL>
<p>
<LI>erasing a factoid: <b><code>forget</code></b>
<p>
A factoid can easily be deleted by using
<p>
<DIR>
<code>
infobot, forget poink
</code>
</DIR>
<p>
<LI>changing a factoid: <code><b>no,</b> ...</code>
<p>
You can change the entry for a factoid completely using
<p>
<UL>
<code>
no, infobot, x is wugga wugga.
</code>
</UL>
<p>
which deletes the prior entry (if possible)
and replaces it with the new one.
<p>
<LI> having the bot tell someone else something: <b><code>tell</code></b>
<p>
A user can ask an infobot to tell someone else something.
<p>
<UL>
<code>
infobot, tell fimmtiu about no web
</code>
<p>
</UL>
<LI><b>karma</b> / plusplus
<p>
karma for a concept may be incremented or decremeted using
<code>++</code> and <code>--</code>. You can get the
current karma 'score' for something by asking for it.
<p>
<UL>
<code>
oznoid++
<p>
oznoid--
<p>
karma for oznoid
</code>
<p>
</UL>
<LI> <code><b>status</b></code>
<p>
infobots reply to status requests.
<p>
<dir>
-> [url] status<p>
[url!infobot@ALF5.SPEECH.CS.CMU.EDU] Since Fri Mar 26 06:42:27 1999, there have been 409
modifications and 2604 questions. I have been awake for 5 days, 4 hours, 24 minutes,
18 seconds this session, and currently reference 47529 factoids.
</dir>
</p>
<LI>joining an allowed channel: <code><b>join</b> #infobot</code>
<p>
On IRC, you can tell the infobot to join a channel
that it's allowed to join with
<p>
<UL>
<code>
infobot, join #infobot
</code>
</UL>
<p>
If it is allowed to (in its paramter settings), it
will try to join the channel.
<p>
<LI>leaving a channel: <code><b>part</b> #infobot</code>
<p>
This causes the bot to leave the given channel
<p>
<UL>
<code>
infobot, part #infobot
</code>
</UL>
<p>
<code>leave</code> is a synonym for <code>part</code>.
<p>
<LI><b>random</b> responses with <code>|</code>
<p>
You can set a list from which to pick a random response by
using <code>|</code>
<p>
<UL>
<code>
x is a|b|c|d
</code>
</UL>
<p>
When x is asked about, the infobot will randomly choose from
the <code>|</code>-spearated list.
<p>
<LI> The <b><code>&lt;reply&gt;</code></b> factoid tag.
<p>
Normally, when the infobot replies to "What is X", it says
"X is Y". This form makes it just reply "Y".
<p>
<UL>
<code>
X is &lt;reply&gt; Y
</code>
</UL>
<p>
<LI> The <b><code>&lt;action&gt;</code></b> factoid tag (as of 0.43.5)
<p>
This causes the bot to respond as with <reply> except
as an ACTION.
<p>
<UL>
<code>
X is &lt;action&gt; Y
</code>
</UL>
<p>
<LI><b>backwacking</b>
<p>
Use <code>\</code> to protect items from evaluation.
<p>
<UL>
<CODE>
x is y is y
</CODE>
</UL>
<p>
will normally set <code>x =is=> y is y</code>, but
<p>
<UL>
<CODE>
x \is y is y
</CODE>
</UL>
<p>
will set
<p>
<UL>
<code>x is y =is=> y</code>
</UL>
<p>
The <code>forget</code>
and <code>no</code> (update) operators apply before checking
for this. This is also useful for getting around the
dereferencing of "i" and "me" and so on.
<p>
<LI>the <b><code>$who</code></b> variable
<p>
Contains the nickname person currently addressing the bot.
It can be used effectively in replies.
<p>
<UL>
<code>
nice day is &lt;reply&gt; you betcha, $who.
</code>
</UL>
<p>
<LI>the <b><code>$date</code></b> variable
<p>
Contains the current date and time, at the bot's host.
<p>
<LI> <code><b>literal</b> foo</code>
<p>
returns the value without the usual post-processing.
</p>
<p>
<LI>Ignoring users: <b>ignore</b> nickname, <b>ignore *.a.com</b>
<p>
Users with the P (oP) flag can tell the bot
to ignore people or hostmasks. And 'unignore'.
use 'ignorelist' to get the current list of ignored masks,
if you have the P flag.
</p>
<LI><code><b>op</b></code> on channel
<p>
The 'p' (oP) flag in the userfile allows this
to work. You'll need to set a hostmask. See
<code>files/infobot.users</code> Also uses a
crypted password.
<p>
<dir>
<code>
/msg &lt;bot&gt; &lt;password&gt; op
</code>
</dir>
<p>
<LI><b><code>die</code></b>
<p>
If the bot owner (+O, Owner) says this or messages it to the bot,
it will kill itself.
<p>
</UL>
<hr>
<h2> scripts/utilities </h2>
The infobot comes with some scripts for working with
the DBM files.
<p>
<UL>
<LI><code>update_db</code>
<p>
This takes a flat ascii file and inserts it into a DBM file.
It creates a new DBM if it didn't exist.
<p>
<UL>
<CODE>
scripts/update_db factpacks/code_to_country.txt infobot-is
</CODE>
</UL>
<p>
will add the factoids in <code>code_to_country.txt</code>
to the <code>infobot-is</code> DBM.
<p>
<LI><code>dump_db</code>
<p>
The converse. It dumps out the DBM file to a flat
ascii file. Note there is no extension on the DBM name,
even though the system may use one.
<p>
<UL>
<CODE>
scripts/dump_db infobot-is
</CODE>
</UL>
<p>
Note there is no extension on the DBM name, even though the
system may use one (like <code>.pag</code> and
<code>.dir</code> or <code>.db</code>).
<p>
</UL>
<hr>

86
doc/makemanual.pl
Unescape Escape View File

@ -0,0 +1,86 @@
# First stab at automagically generating the manual from the config
# files and module documentation.
# Simon Cozens, 1999-
# DON'T, I'M NOT FINISHED YET!
use Pod::Html;
use strict;
use vars qw($version $VER_MAJ $VER_MIN $VER_MOD);
sub status (@) {print "@_\n"}
require "../src/Params.pl";
require "../src/IrcExtras.pl";
# Things we know to be core modules:
my %source = map {$_, 1} qw{
ANSI.pl IrcHooks.pl Reply.pl CTCP.pl
Search.pl Channel.pl Math.pl Setup.pl
DBM.pl Misc.pl Speller.pl Extras.pl
Norm.pl Statement.pl module-template Help.pl
Params.pl myRoutines.pl Process.pl Update.pl
Irc.pl Question.pl User.pl IrcExtras.pl
};
status "Generating manual for $version";
loadParamFiles($ARGV[0]||"../files/infobot.config");
open(OUT,">infobot-guide.html")
or die "! Couldn't write on infobot-guide.html: $!\n";
status "Writing the header...";
print OUT <<EOF;
<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN">
<html>
<head>
<title>Infobot Guide $VER_MAJ\.$VER_MIN\.$VER_MOD</title>
</head>
<body bgcolor="#ffffff">
<h1>Infobot Guide $VER_MAJ\.$VER_MIN\.$VER_MOD</h1>
EOF
status "Writing the introduction and main commands summary...";
open(BIT1, "intro.bit")
or die "! Can't load the introduction to the guide: $!\n";
{ local $/=undef; print OUT <BIT1>;}
print "Scanning for extension modules...";
opendir(DH, "../src/") or die "! Couldn't open source directory: $!\n";
my @mods=();
$|=1;
while (defined ($_=readdir(DH))) {
next unless -f "../src/$_";
next if exists $source{$_};
print ".";
read_it($_);
}
status "\nWriting the rest of the document...";
open(BIT1, "outro.bit")
or die "! Can't load the end of the guide: $!\n";
{ local $/=undef; print OUT <BIT1>;}
status "Manual created succesfully.";
sub read_it {
my $file=shift;
open (FH, "../src/$file") or die "! Couldn't open $file: $!\n";
my $found=0;
my @pods;
local $/="";
while (<FH>) {
$found =1 if (/^=head1/);
push @pods, $_ if $found;
}
unless ($found) {
warn "\nNo documentation for $file; bad author!\n" unless $found;
return;
}
close FH;
# Process pods into HTML
}

66
extras/ANSI.pl
Unescape Escape View File

@ -0,0 +1,66 @@
require 5.001;
%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);
$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;
}
# Given a string and a set of attributes, returns the string surrounded by
# escape codes to set those attributes and then clear them at the end of the
# string. If $EACHLINE is set, insert a reset before each occurrence of the
# string $EACHLINE and the starting attribute code after the string
# $EACHLINE, so that no attribute crosses line delimiters (this is often
# desirable if the output is to be piped to a pager or some other program).
sub c {
my $string = shift;
if (defined $EACHLINE) {
my $attr = cl (@_);
join $EACHLINE,
map { $_ ne "" ? $attr . $_ . "\e[0m" : "" }
split ($EACHLINE, $string);
} else {
cl (@_) . $string . "\e[0m";
}
}
1;

414
extras/Aviation.pl
Unescape Escape View File

@ -0,0 +1,414 @@
#
# aviation -- infobot module for various flight-planning bits.
# Was originally 'metar' until infobot 44.5.
#
# 1999/07/?? Rich Lafferty <rich@alcor.concordia.ca>
# - Initial version
# 1999/08/02 lenzo@cs.cmu.edu
# - package, BEGIN, eval checks
# 1999/09/16 lenzo@cs.cmu.edu
# - added a timeout
# 2000/??/?? Lazarus Long <lazarus@frontiernet.net>
# - modified to weather.noaa.gov to reflect hostname change
# 2000/11/09 rich@alcor.concordia.ca
# - NAME CHANGE: now 'aviation' to reflect new functions
# - partial rewrite of metar code: now that we have 'weather', we
# don't need to massage the data for grounded people.
# - status() added to whine about missing modules
# - added more aviation functions (taf, great-circle, zulutime)
# 2000/11/17 rich@alcor.concordia.ca
# - rewrite each function into separate sub
# - fork to handle all requests (even though only web-based requests
# really need to fork.
# 2000/11/18 rich@alcor.concordia.ca
# - added airport name/code lookups, fixed minor bugs in other parts
package Aviation;
my ($no_aviation, $no_entities);
BEGIN {
eval "use LWP::UserAgent";
if ($@) { $no_aviation++};
eval "use HTML::Entities";
if ($@) { $no_entities++};
}
# Set the following to 1 if you want the forecast separators in
# a TAF (PROB, BECMG, FM, TEMPO) to be bold. For those that don't know
# from aviation forecasts, each of the above keywords signifies a new
# section of the TAF -- the equivalent, for example, of the "from 10 to 2"
# in "Sunny tomorrow; from 10 to 2, chance of showers".
my $taf_highlight_bold = 1;
#
# Figure out what we're supposed to do, and do it
#
sub Aviation::get {
if ($no_aviation) {
&main::status("Aviation module requires LWP::UserAgent.");
return '';
}
my ($line, $callback) = @_;
$SIG{CHLD} = 'IGNORE';
my $pid = eval { fork() }; # catch non-forking OSes and other errors
return 'NOREPLY' if $pid; # parent does nothing
if ($line =~ /^metar/i) { $callback->(metar($line)) }
elsif ($line =~ /^taf/i) { $callback->(taf($line)) }
elsif ($line =~ /^great[-\s]?circle/i) { $callback->(greatcircle($line)) }
elsif ($line =~ /^tsd/i) { $callback->(tsd($line)) }
elsif ($line =~ /^zulutime/i) { $callback->(zulutime($line)) }
elsif ($line =~ /^airport/i) { $callback->(airport($line)) }
elsif ($line =~ /^aviation/i) { $callback->(aviation($line)) }
else { $callback->("I think we just lost a wing!") } # reach here -> Extras.pl problem
exit 0 if defined $pid; # child exits, non-forking OS returns
}
#
# aviation - list available aviation functions
#
sub aviation {
return "My aviation-related functions are metar, taf, great-circle, tsd, zulutime, and airport. For help with any, ask me about '<function name> help'.";
}
#
# METAR - current weather observation
#
sub metar {
my $line = shift;
if ($line =~ /^metar\s+(for\s+)?(.*)/i) {
# ICAO airport codes *can* contain numbers, despite earlier claims.
# Americans tend to use old FAA three-letter codes; luckily we can
# *usually* guess what they mean by prepending a 'K'. The author,
# being Canadian, is similarly lazy.
my $site_id = uc($2);
$site_id =~ s/[.?!]$//;
$site_id =~ s/\s+$//g;
return "'$site_id' doesn't look like a valid ICAO airport identifier."
unless $site_id =~ /^[\w\d]{3,4}$/;
$site_id = "C" . $site_id if length($site_id) == 3 && $site_id =~ /^Y/;
$site_id = "K" . $site_id if length($site_id) == 3;
# HELP isn't an airport, so we use it for a reference work.
return "For observations, ask me 'metar <code>'. For information on decoding Aerodrome Weather Observations (METAR), see http://www.avweb.com/toc/metartaf.html"
if $site_id eq 'HELP';
my $metar_url = "http://weather.noaa.gov/cgi-bin/mgetmetar.pl?cccc=$site_id";
# Grab METAR report from Web.
my $agent = new LWP::UserAgent;
if (my $proxy = main::getparam('httpproxy')) { $agent->proxy('http', $proxy) };
$agent->timeout(10);
my $grab = new HTTP::Request GET => $metar_url;
my $reply = $agent->request($grab);
# If it can't find it, assume luser error :-)
return "Either $site_id doesn't exist (try a 4-letter station code like KAGC), or the site NOAA site is unavailable right now."
unless $reply->is_success;
# extract METAR from incredibly and painfully verbose webpage
my $webdata = $reply->as_string;
$webdata =~ m/($site_id\s\d+Z.*?)</s;
my $metar = $1;
$metar =~ s/\n//gm;
$metar =~ s/\s+/ /g;
# Sane?
return "I can't find any observations for $site_id." if length($metar) < 10;
return $metar;
}
else {
# malformed
return "That doesn't look right. The 'metar' command takes an airport identifier and returns the current conditions at the airport in METAR format. (Also, try 'metar HELP'.)";
}
}
#
# TAF - terminal area (aerodrome) forecast
#
sub taf {
my $line = shift;
if ($line =~ /^taf\s+(for\s+)?(.*)/i) {
# ICAO airport codes *can* contain numbers, despite earlier claims.
# Americans tend to use old FAA three-letter codes; luckily we can
# *usually* guess what they mean by prepending a 'K'. The author,
# being Canadian, is similarly lazy.
my $site_id = uc($2);
$site_id =~ s/[.?!]$//;
$site_id =~ s/\s+$//g;
return "'$site_id' doesn't look like a valid ICAO airport identifier."
unless $site_id =~ /^[\w\d]{3,4}$/;
$site_id = "C" . $site_id if length($site_id) == 3 && $site_id =~ /^Y/;
$site_id = "K" . $site_id if length($site_id) == 3;
# HELP isn't an airport, so we use it for a reference work.
return "For a forecast, ask me 'taf <ICAO code>'. For information on decoding Terminal Area Forecasts, see http://www.avweb.com/toc/metartaf.html"
if $site_id eq 'HELP';
my $taf_url = "http://weather.noaa.gov/cgi-bin/mgettaf.pl?cccc=$site_id";
# Grab METAR report from Web.
my $agent = new LWP::UserAgent;
if (my $proxy = main::getparam('httpproxy')) { $agent->proxy('http', $proxy) };
$agent->timeout(10);
my $grab = new HTTP::Request GET => $taf_url;
my $reply = $agent->request($grab);
# If it can't find it, assume luser error :-)
return "I can't seem to retrieve data from weather.noaa.com right now."
unless $reply->is_success;
# extract TAF from equally verbose webpage
my $webdata = $reply->as_string;
$webdata =~ m/($site_id( AMD)* \d+Z .*?)</s;
my $taf = $1;
$taf =~ s/\n//gm;
$taf =~ s/\s+/ /g;
# Optionally highlight beginnings of parts of the forecast. Some
# find it useful, some find it obnoxious, so it's configurable. :-)
$taf =~ s/(FM\d+Z?|TEMPO \d+|BECMG \d+|PROB\d+)/\cB$1\cB/g if $taf_highlight_bold;
# Sane?
return "I can't find any forecast for $site_id." if length($taf) < 10;
return $taf;
}
else {
# malformed
return "That doesn't look right. The 'taf' command takes an airport identifier as an argument and returns the aerodrome forecast for the airport in TAF format. (Also, try 'taf HELP'.)";
}
}
#
# greatcircle -- calculate great circle distance and heading between
# two airports
sub greatcircle {
my $line = shift;
if ($line =~ /^great-?circle\s+((from|between|for)\s+)?(\w+)\s+((and|to)\s)?(\w+)/i) {
# See metar part for explanation of this bit.
my $orig_apt = uc($3);
my $dest_apt = uc($6);
$dest_apt =~ s/[.?!]$//;
$dest_apt =~ s/\s+$//g;
return "'$orig_apt' doesn't look like a valid ICAO airport identifier."
unless $orig_apt =~ /^[\w\d]{3,4}$/;
return "'$dest_apt' doesn't look like a valid ICAO airport identifier."
unless $dest_apt =~ /^[\w\d]{3,4}$/;
$orig_apt = "C" . $orig_apt if length($orig_apt) == 3 && $orig_apt =~ /^Y/;
$orig_apt = "K" . $orig_apt if length($orig_apt) == 3;
$dest_apt = "C" . $dest_apt if length($dest_apt) == 3 && $dest_apt =~ /^Y/;
$dest_apt = "K" . $dest_apt if length($dest_apt) == 3;
my $gc_url = "http://www6.landings.com/cgi-bin/nph-dist_apt?airport1=$orig_apt&airport2=$dest_apt";
# Grab great-circle data
my $agent = new LWP::UserAgent;
if (my $proxy = main::getparam('httpproxy')) { $agent->proxy('http', $proxy) };
$agent->timeout(10);
my $grab = new HTTP::Request GET => $gc_url;
my $reply = $agent->request($grab);
# If it can't find it, assume luser error :-)
unless ($reply->is_success) {
return "I can't seem to retrieve data from www.landings.com right now.";
}
# extract TAF from equally verbose webpage
my $webdata = $reply->as_string;
my $gcd;
if ($webdata =~ m/circle: ([.\d]+).*?, ([.\d]+).*?, ([.\d]+).*?heading: ([.\d]+)/s) {
$gcd = "Great-circle distance: $1 mi, $2 nm, $3 km, heading $4 degrees true";
}
else {
$webdata =~ m/(No airport.*?database)/;
$gcd = $1;
}
return $gcd;
}
else {
# malformed
return "That doesn't look right. The 'great-circle' command takes two airport identifiers and returns the great circle distance and heading between them.";
}
}
#
# tsd -- calculate time, speed, distance, given any two
#
sub tsd {
my $line = shift;
return "To solve time/speed/distance problems, substitute 'x' for " .
"the unknown value in 'tsd TIME SPEED DISTANCE'. For example, " .
"'tsd 3 x 200' will solve for the speed in at which you can travel " .
"200 mi in 3h." if $line =~ /help/i;
my ($time, $speed, $distance) = ($line =~ /^tsd\s+(\S+)\s+(\S+)\s+(\S+)$/);
my $error;
$error++ unless $time && $speed && $distance;
if ($time =~ /^[A-Za-z]$/) { # solve for time
$error++ unless $speed =~ /^[\d.]+$/;
$error++ unless $distance =~ /^[\d.]+$/;
return $distance / $speed unless $error;
}
elsif ($speed =~ /^[A-Za-z]$/) { # solve for speed
$error++ unless $time =~ /^[\d.]+$/;
$error++ unless $distance =~ /^[\d.]+$/;
return $distance / $time unless $error;
}
elsif ($distance =~ /^[A-Za-z]$/) { # solve for distance
$error++ unless $speed =~ /^[\d.]+$/;
$error++ unless $time =~ /^[\d.]+$/;
return $time * $speed unless $error;
}
return "Your time/speed/distance problem looks incorrect. For help, try 'tsd help'.";
}
#
# zulutime -- return current UTC time
#
sub zulutime {
$line = shift;
return "zulutime returns the time in DDHHMM format." if $line =~ /help/i;
return sprintf('%02d%02d%02dZ', reverse((gmtime())[1..3]));
}
#
# airport -- look up airport by identifier (airport name for ___) or by
# name (airport code(s) for ___). To avoid confusion, we
# explicitly discard FAA-but-not-ICAO identifiers.
#
sub airport {
my $line = shift;
if ($line =~ /^airport\s+(name|code|id)s?\s+(for\s+)?(.*)/i) {
my $function = lc($1);
my $query = $3;
if ($function eq 'name') {
$query = "C" . $query if length($query) == 3 && $query =~ /^Y/;
$query = "K" . $query if length($query) == 3;
$query = uc($query);
$query =~ s/[.?!]$//;
$query =~ s/\s+$//;
return "That doesn't look like a valid ICAO airport identifier. (Perhaps you mean 'airport code for $query'?)"
unless length($query) == 4;
my $apt_url = "http://www6.landings.com/cgi-bin/nph-search_apt?1=$query&max_ret=1";
# Grab airport data from Web.
my $agent = new LWP::UserAgent;
if (my $proxy = main::getparam('httpproxy')) { $agent->proxy('http', $proxy) };
$agent->timeout(10);
my $grab = new HTTP::Request GET => $apt_url;
my $reply = $agent->request($grab);
# If it can't find it, assume luser error :-)
return "I can't seem to access my airport data -- perhaps try again later."
unless $reply->is_success;
# extract csv-format airport data from incredibly and painfully verbose webpage
my $webdata = $reply->as_string;
@apt_lines = split (/\n/, $webdata);
my $print_next = 0;
my $response = '';
foreach (@apt_lines) {
# skip over entries without ICAO idents (ICAO: n/a)
if (/\(ICAO: <b>[^n]/) { $response .= "$_, "; $pnext = 1; }
elsif ($pnext) { $response .= $_; $pnext = 0; }
}
$response =~ s/(<.*?>)+/ /g; # naive, but works in *this* case.
$response =~ s/.*?\) //; # strip (ICAO: foo) bit
$response =~ s/\s+/ /g;
$response =~ s/ ,/,/g; # pet peeve.
if ($no_entities and $response =~ /(&.*?;)/) {
&main::status("Aviation module 'airport' function just output a raw HTML entity ($1) because you don't have HTML::Entities installed.");
$response .= "\n(Excuse the HTML entity. I don't have HTML::Entities handy.)";
}
else {
$response = decode_entities($response);
}
if ($response) {
return "$query is $response";
}
else {
return "I can't find an airport for $query.";
}
}
elsif ($function eq 'code' or $function eq 'id') {
$query =~ s/[.?!]$//;
$query =~ s/\s+$//;
my $apt_url = "http://www6.landings.com/cgi-bin/nph-search_apt?5=$query&max_ret=100";
# Grab airport data from Web.
my $agent = new LWP::UserAgent;
if (my $proxy = main::getparam('httpproxy')) { $agent->proxy('http', $proxy) };
$agent->timeout(10);
my $grab = new HTTP::Request GET => $apt_url;
my $reply = $agent->request($grab);
# If it can't find it, assume luser error :-)
return "I can't seem to access my airport data -- perhaps try again later."
unless $reply->is_success;
# extract csv-format airport data from incredibly and painfully verbose webpage
my $webdata = $reply->as_string;
@apt_lines = split (/\n/, $webdata);
my $response = '';
foreach (@apt_lines) {
$response .= "$1 " if m|\(ICAO: <b>([^n]+?)</b>|;
}
$response =~ s/(<.*?>)+/ /g; # naive, but works in *this* case.
if ($response) {
return "$query may be: $response";
}
else {
return "I can't find an airport code for $query.";
}
}
# else fall through to malformed bit below
}
# malformed
return "That doesn't look right. Try 'airport code for CITY' or 'airport name for CODE' instead.";
}
1;
__END__

89
extras/DNS.pl
Unescape Escape View File

@ -0,0 +1,89 @@
# infobot :: Kevin Lenzo (c) 1997
# once again, thanks to Patrick Cole
#use POSIX;
use Socket;
sub REAPER {
$SIG{CHLD} = \&REAPER; # loathe sysV
$waitedpid = wait;
}
$SIG{CHLD} = \&REAPER;
$DNS_CACHE_EXPIRE_TIME = 7*24*60*60;
sub DNS {
my $in = $_[0];
my($match, $x, $y, $result);
if (($DNS_CACHE{$in}) && ((time()-$DNS_TIME_CACHE{$in}) < $DNS_CACHE_EXPIRE_TIME)) {
return $DNS_CACHE{$in};
}
if (!defined($pid = fork)) {
return "no luck, $safeWho";
} elsif ($pid) {
# parent
} else {
# child
if ($in =~ /(\d+\.\d+\.\d+\.\d+)/) {
&status("DNS query by IP address: $in");
$match = $1;
$y = pack('C4', split(/\./, $match));
$x = (gethostbyaddr($y, &AF_INET));
if ($x !~ /^\s*$/) {
$result = $match." is ".$x unless ($x =~ /^\s*$/);
} else {
$result = "I can't seem to find that address in DNS";
}
} else {
&status("DNS query by name: $in");
$x = join('.',unpack('C4',(gethostbyname($in))[4]));
if ($x !~ /^\s*$/) {
$result = $in." is ".$x;
} else {
$result = "I can\'t find that machine name";
}
}
$DNS_TIME_CACHE{$in} = time();
$DNS_CACHE{$in} = $result;
if ($msgType eq 'public') {
&say($result);
} else {
&msg($who, $result);
}
exit; # bye child
}
}
1;
__END__
=head1 NAME
DNS.pl - Look up hosts in DNS
=head1 PREREQUISITES
None.
=head1 PARAMETERS
allowDNS
=head1 PUBLIC INTERFACE
nslookup|DNS [for] <host>
=head1 DESCRIPTION
Looks up DNS entries for the given host using
C<gethostbyaddr>/C<gethostbyname> calls.
=head1 AUTHORS
Kevin Lenzo

818
extras/Extras.pl
Unescape Escape View File

@ -0,0 +1,818 @@
# Infobot extensions inside the distribution.
# Local extensions go in myRoutines.pl
# Kevin A. Lenzo
sub Extras {
# called after it decides if it's been addressed.
# you have access tothe global variables here,
# which is bad, but anyway.
# you can return 'NOREPLY' if you want to stop
# processing past this point but don't want
# an answer. if you don't return NOREPLY, it
# will let all the rest of the default processing
# go to it. think of it as 'catching' the event.
# $addressed is whether the infobot has been
# named or, if a private or standalone
# context, addressed is always 'true'
# $msgType can be 'public', 'private', maybe 'dcc_chat'
# $who is the sender of the message
# $message is the current state of the input, after
# the addressing stuff stripped off the name
# $origMessage is the text of the original message before
# any normalization or processing
# you have access to all the routines in urlIrc.pl too,
# of course.
# -- this section moved from Process.pl -- kl
if ($addressed and $message =~ m|^\s*(.*?)\s+=~\s+s\/(.+?)\/(.*?)\/([a-z]*);?\s*$|) {
# substitution: X =~ s/A/B/
my ($X, $oldpiece, $newpiece, $flags) = ($1, $2, $3, $4);
my $matched = 0;
my $subst = 0;
my $op = quotemeta($oldpiece);
my $np = $newpiece;
$X = lc($X);
foreach $d ("is","are") {
if ($r = get($d, $X)) {
my $old = $r;
$matched++;
if ($r =~ s/$op/$np/i) {
if (length($r) > getparam('maxDataSize')) {
if ($msgType =~ /private/) {
&msg($who, "That's too long, $who");
} else {
&say("That's too long, $who");
}
return 'NOREPLY';
}
set($d, $X, $r);
&status("update: '$X =$d=> $r'; was '$old'");
$subst++;
}
}
}
if ($matched) {
if ($subst) {
if ($msgType =~ /private/) {
&msg($who, "OK, $who");
} else {
&say("OK, $who");
}
return 'NOREPLY';
} else {
if ($msgType =~ /private/) {
&msg($who, "That doesn't contain '$oldpiece'");
} else {
&say("That doesn't contain '$oldpiece', $who");
}
}
} else {
if ($msgType =~ /private/) {
&msg($who, "I didn't have anything matching '$X'");
} else {
&say("I didn't have anything matching '$X', $who");
}
}
return 'NOREPLY';
} # end substitution
if ($addressed and IsFlag("S")) {
if ($message =~ s/^\s*say\s+(\S+)\s+(.*)//) {
&msg($1, $2);
&msg($who, "ok.");
return 'NOREPLY';
}
}
if (($addressed) && ($message =~ /^\s*help\b/i)) {
$message =~ s/^\s*help\s*//i;
$message =~ s/\W+$//;
&help($message);
return 'NOREPLY';
}
if ($message =~ s/^forget\s+((a|an|the)\s+)?//i) {
# cut off final punctuation
$message =~ s/[.!?]+$//;
#return 'no authorization to lobotomize';
#}
$k = &normquery($message);
$k = lc($k);
$found = 0;
foreach $d ("is", "are") {
if ($r = get($d, $k)) {
if (IsFlag("r") ne "r") {
performReply("you have no access to remove factoids");
return 'NOREPLY';
}
$found = 1 ;
&status("forget: <$who> $k =$d=> $r");
clear($d, $k);
$factoidCount--;
}
}
if ($found == 1) {
if ($msgType !~ /public/) {
&msg($who, "$who: I forgot $k");
} else {
&say("$who: I forgot $k");
}
$l = $who; $l =~ s/^=//;
$updateCount++;
return 'NOREPLY';
} else {
if ($msgType !~ /public/) {
&msg($who, "I didn't have anything matching $k");
return 'NOREPLY';
} else {
if ($addressed > 0) {
&say("$who, I didn't have anything matching $k");
return 'NOREPLY';
}
}
}
} # end forget
# Aldebaran++ !
if (getparam("shutup") and $message =~ /^\s*wake\s*up\s*$/i ) {
if ($msgType =~ /public/) {
if ($addressed) {
if (rand() > 0.5) {
&performSay("Ok, ".$who.", I'll start talking.");
&status("Changing to Optional mode");
# Oh shit. - Simon
$chanopts{Channel()}->{'addressing'} = 'OPTIONAL';
return 'NOREPLY';
} else {
&performSay(":O");
return 'NOREPLY';
}
}
} else {
&msg($who, "OK, I'll start talking.");
$param{'addressing'} = 'OPTIONAL';
&status("Changing to Optional mode");
return 'NOREPLY';
}
} # end wake up
if ($param{"shutup"} and $message =~ /^\s*shut\s*up\s*$/i ) {
if ($msgType =~ /public/) {
if ($addressed) {
if (rand() > 0.5) {
&performSay("Sorry, ".$who.", I'll keep my mouth shut. ");
$chanopts{Channel()}->{'addressing'} = 'REQUIRE';
&status("Changing to Require mode");
return 'NOREPLY';
} else {
&performSay(":X");
return 'NOREPLY';
}
}
} else {
&msg($who, "Sorry, I'll try to be quiet.");
$param{'addressing'} = 'REQUIRE';
&status("Changing to Require mode");
return 'NOREPLY';
}
} # end shut up
# -- from here down, 'tell' needs to be worked into the forkers.
# anything that just returns a value will be handled automatically,
# but anything that forks will require special handling.
# mendel++
if (getparam('zippy')) {
if (my $resp = zippy::get($message)) {
return $resp;
}
}
# Masque++
my $triggers = getparam("purldoc_trigger") if getparam('purldoc');
if (defined getparam('purldoc') and $message =~ s/^\s*$triggers\s+-?(\w+)/$1/) {
return &purldoc();
}
# from Chris Tessone: slashdot headlines
# "slashdot" or "slashdot headlines"
if (defined(getparam('slash')) and $message =~
/^\s*slashdot( headlines)?\W*\s*$/) {
my $headlines = &getslashdotheads();
return $headlines;
}
# internic or RIPE whois
if (getparam('allowInternic')) {
if ($message =~ /^(internic|ripe)(?: for)?\s+(\S+)$/i) {
my $where = $1;
my $what = $2;
&domain_summary($what, $where);
return 'NOREPLY';
}
}
# currency exchanger, bobby@bofh.dk
if( defined(getparam('exchange'))
and getparam('exchange')
and ( $message =~ /^\s*(?:ex)?change\s+/i or $message =~ /^\s*currenc(?:ies|y) for\s/i )){
&status("message($message)");
my $response='';
if ($pid = fork) {
# this takes some time, so fork.
return 'NOREPLY';
}
if ($message =~ /^\s*(?:ex)?change\s+([\d\.\,]+)\s+(\S+)\s+(?:into|to|for)\s+(\S+)/i) {
my($Amount,$From,$To) = ($1,$2,$3);
$From = uc $From; $To = uc $To;
&status("calling exchange($From, $To, $Amount) ...");
$response = &exchange($From, $To, $Amount);
# Change Finland, purl! No no. How about 'currency for'.
# } elsif( $message =~ /^\s*(?:ex)?change ([\w\s]+)/) {
} elsif( $message =~ /^\s*currenc(?:ies|y) for\s(?:the\s)?([\w\s]+)/i ) {
# looking up the currency for a country
my $Country = $1;
&status("calling exchange($Country) ...");
$response = &exchange($Country);
} else {
$response = "that doesn't look right";
}
&status("exchange got response($response)");
if($response =~ /^EXCHANGE: \S*/) {
&status($response);
} elsif ($msgType eq 'public') {
&say("$who: $response");
} else{
&msg($who, $response);
}
# exit the child or it gets weird
exit 0;
} # end excange
# Jonathan Feinberg's babel-bot -- jdf++
if (defined getparam('babel') &&
(1 or $addressed) &&
$message =~ m{
^\s*
(?:babel(?:fish)?|x|xlate|translate)
\s+
(to|from) # direction of translation (through)
\s+
($babel::lang_regex)\w* # which language?
\s*
(.+) # The phrase to be translated
}xoi) {
my $whom = $who; # building a closure, need lexical
my $callback = $msgType eq 'public' ?
sub{say("$who: $_[0]")} : sub{msg($who, $_[0])};
&babel::forking_babelfish(lc $1, lc $2, $3, $callback);
return 'NOREPLY';
} # end babel
# insult server. patch thanks to michael@limit.org
if (getparam('insult') and ($message =~ /^\s*insult (.*)\s*$/)) {
my $person = $1;
my $language = "english";
# Could have SWORN Simon patched this. Simon++ for the fix, either way. - 3Jul2K, Masque
# > purl, insult mountain dew
# <purl> mounta ist nichts aber ein gegorener Stapel des squishy Programmfehlerspit.
# if ($person =~ s/ in \s*($babel::lang_regex)\w*\s*$//xi) {
if ($person =~ s/ in \s*($babel::lang_regex)\w*\s*$//i) {
$language = lc($1);
}
$person = $who if $person =~ /^\s*me\s*$/i;
my $insult = &insult();
if ($person ne $who) {
$insult =~ s/^\s*You are/$person is/i;
}
if ($insult =~ /\S/) {
if (getparam('babel') and ($language ne "english")) {
my $whom = $who; # building a closure, need lexical
my $callback = $msgType eq 'public' ?
sub{say("$_[0]")} : sub{msg($whom, $_[0])};
&babel::forking_babelfish("to", $language, $insult, $callback);
return 'NOREPLY';
}
} else {
$insult = "No luck, $who";
}
return $insult;
} # end insult
if (getparam('weather') and ($message =~ /^\s*weather\s+(?:for\s+)?(.*?)\s*\?*\s*$/)) {
my $code = $1;
my $weath ;
if ($code =~ /^[a-zA-Z][a-zA-Z0-9]{3,4}$/) {
$weath = &Weather::NOAA::get($code);
} else {
$weath = "Try a 4-letter station code (see http://weather.noaa.gov/weather/curcond.html for locations and codes)";
}
# if ($msgType eq 'public') {
# &say("$who: $weath");
# } else {
&msg($who, $weath);
# }
return 'NOREPLY';
}
# This replaced 'metar'. Lotsa aviation stuff. Go look.
if(defined(getparam('aviation') or defined(getparam('metar'))) and
$message =~ /^(metar |
taf |
great[-\s]?circle |
zulutime |
tsd |
airport |
aviation)/xi)
{
my $callback = $msgType eq 'public' ?
sub{say("$who: $_[0]")} : sub{msg($who, $_[0])};
&Aviation::get($message, $callback);
return 'NOREPLY';
}
# from Simon: google searching
# modified to fork and generally search by oznoid
if(defined(getparam('wwwsearch')) and $message =~
/^\s*
(?:search\s+)?
($W3Search::regex)
\s+for\s+
[\'\"]?(.*?)[\'\"]?
\s*\?*\s*$
/ix ) {
my $callback = $msgType eq 'public' ?
sub{say("$who: $_[0]")} : sub{msg($who, $_[0])};
&W3Search::forking_W3Search($1,$2,getparam('wwwsearch'), $callback);
return 'NOREPLY';
}
# Adam Spiers' nickometer
if ($message =~ /^\s*(?:lame|nick)-?o-?meter(?: for)? (\S+)/i) {
my $term = $1;
if (lc($term) eq 'me') {
$term = $who;
}
$term =~ s/\?+\s*//;
my $percentage = &nickometer($term);
if ($percentage =~ /NaN/) {
$percentage = "off the scale";
} else {
# $percentage = sprintf("%0.4f", $percentage);
$percentage =~ s/\.0+$//;
$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 'NOREPLY';
} # end nick-o-meter
if ($message =~ /^foldoc(?: for)?\s+(.*)/i) {
my ($terms) = $1;
$terms =~ s/\?\W*$//;
my $key= $terms;
$key =~ s/\s+$//;
$key =~ s/^\s+//;
$key =~ s/\W+/+/g;
my $reply = "$terms may be sought in foldoc at http://wombat.doc.ic.ac.uk/foldoc/foldoc.cgi?query=$key";
return $reply;
}
if ($message =~ /^(?:quote|stock price)(?: of| for)? ([A-Z]{1,6})\?*$/) {
my $reply = "stock quotes for $1 may be sought at http://quote.yahoo.com/q?s=$1\&d=v1";
return $reply;
}
if ($message =~ /^rot13\s+(.*)/i) {
# rot13 it
my $reply = $1;
$reply =~ y/A-Za-z/N-ZA-Mn-za-m/;
return $reply;
}
# search imdb
if ($message =~ s/^\s*(search )?imdb (for )?//) {
$check = $message;
my $url = $message;
# freeside++ for URL cleanup code
my $date = "";
if ($url =~ s/( \(\d+\))$//) { $date = $1; }
$url =~ s/^(The|A|An|Les) (.*)/$2, $1/i;
$url = "http://www.imdb.com/M/title-substring?title=$url$date&type=fuzzy";
$url =~ s/ /+/g;
$V = "-> "; $orig_lhs = $message; $theVerb= "is";
return "$message can be found at $url";
} # end imdb
if ($message =~ s/^\s*(search )?hyperarchive (for )?//) {
$message =~ /\w+/;
$check = $message;
my $q = $message;
$q =~ s/\W+//g;
$result = "http://hyperarchive.lcs.mit.edu/cgi-bin/NewSearch?key=$q";
$V = "-> "; $orig_lhs = $message; $theVerb= "is";
return "$message may be sought at $result";
}
# websters
if ($message =~ s/^\s*(search )?websters* (for )?//) {
$message =~ /\w+/;
$word = $&;
$check = $message;
my $q = $message;
$q =~ s/\W+/+/g;
$result = "http://work.ucsd.edu:5141/cgi-bin/http_webster?$word";
$V = "-> "; $orig_lhs = $message; $theVerb= "is";
return "$message may be sought at $result";
} # end websters
# -- from Question
# Now with INTENSE CASE INSENSITIVITY! SUNDAY SUNDAY SUNDAY!
if ($message =~ /^seen (\S+)/i) {
my $person = $1;
$person =~ s/\?*\s*$//;
my $seen = &get(seen => lc $person);
if ($seen) {
my ($when,$where,$what) = split /$;/, $seen;
my $howlong = time() - $when;
$when = localtime $when;
my $tstring = ($howlong % 60). " seconds ago";
$howlong = int($howlong / 60);
if ($howlong % 60) {
$tstring = ($howlong % 60). " minutes and $tstring";
}
$howlong = int($howlong / 60);
if ($howlong % 24) {
$tstring = ($howlong % 24). " hours, $tstring";
}
$howlong = int($howlong / 24);
if ($howlong % 365) {
$tstring = ($howlong % 365). " days, $tstring";
}
$howlong = int($howlong / 365);
if ($howlong > 0) {
$tstring = "$howlong years, $tstring";
}
if ($msgType =~ /public/) {
&performSay("$person was last seen on $where $tstring, saying: $what [$when]");
} else {
&msg($who, "$person was last seen on $where $tstring, saying: $what [$when]");
}
return 'NOREPLY';
}
if ($msgType =~ /public/) {
&performSay("I haven't seen '$person', $who");
} else {
&msg($who,"I haven't seen '$person', $who");
}
return 'NOREPLY';
}
if ($message =~ /^\s*heya?,? /) {
return 'NOREPLY' unless $addressed;
}
# Gotta be gender-neutral here... we're sensitive to purl's needs. :-)
if ($message =~ /(good(\s+fuckin[\'g]?)?\s+(bo(t|y)|g([ui]|r+)rl))|(bot(\s|\-)?snack)/i) {
&status("random praise [$msgType,$addressed]: $message");
if ($msgType =~ /public/) {
if ($addressed) {
if (rand() < .5) {
&performSay("thanks $who :)");
} else {
&performSay(":)");
}
}
} else {
&msg($who, ":)");
}
return 'NOREPLY';
}
if ($addressed) {
if ($message =~ /you (rock|rocks|rewl|rule|are so+ co+l)/) {
if ($msgType =~ /public/) {
if (rand() < .5) {
&performSay("thanks $who :)");
} else {
&performSay(":)");
}
return 'NOREPLY';
} else {
&msg($who, ":)");
}
}
if ($message =~ /thank(s| you)/i) {
if ($msgType =~ /public/) {
if (rand() < .5) {
&performSay($welcomes[int(rand(@welcomes))]." ".$who);
} else {
&performSay($who.": ".$welcomes[int(rand(@welcomes))]);
}
} else {
if (rand() < .5) {
&msg($who, $welcomes[int(rand(@welcomes))].", ".$who);
} else {
&msg($who, $welcomes[int(rand(@welcomes))]);
}
}
return 'NOREPLY';
}
}
if ($message =~ /^\s*(h(ello|i( there)?|owdy|ey|ola)|salut|bonjour|niihau|que\s*tal)( $param{nick})?\s*$/i) {
if (!$addressed and rand() > 0.35) {
# 65% chance of replying to a random greeting when not addressed
return 'NOREPLY';
}
my($r) = $hello[int(rand(@hello))];
if ($msgType =~ /public/) {
&performSay($r.", $who");
} else {
&msg($who, $r);
}
return 'NOREPLY';
}
if (($message =~ /^\s*(?:nslookup|dns)(?: for)?\s+(\S+)$/i) and getparam('allowDNS')) {
&status("DNS Lookup: $1");
&DNS($1);
return 'NOREPLY';
}
if (getparam('ispell') and ($message =~ s/^spell(ing)? (?:of |for )?//)) {
&status("Spell: $message");
&ispell($message);
return 'NOREPLY';
}
if (($message =~ /^traceroute (\S+)$/i) and getparam("allowTraceroute")) {
&status("traceroute to $1");
&troute($1);
return 'NOREPLY';
}
if ($message =~ /^crypt\s*\(\s*(\S+)\s*(?:,| )\s*(\S+)/) {
my $cr = crypt($1, $2);
if ($msgType =~ /private/) {
&msg($who, $cr);
} else {
&performSay($cr);
}
return 'NOREPLY';
}
# may not want to cut off all: all i know is ...
# but for now seem mostly content-free
if (getparam('allowLeave') =~ /$msgType/) {
if ($message =~ /(leave|part) ((\#|\&)\S+)/i) {
if (IsFlag("o") or $addressed) {
if (IsFlag("c") ne "c") {
&performReply("you don't have the channel flag");
return 'NOREPLY';
}
&channel($2);
&performSay("goodbye, $who.");
&status("PART $2 <$who>");
&part($2);
return 'NOREPLY';
}
}
}
if ($msgType !~ /public/) {
# accept only msgs leaves/joins
my($ok_to_join);
if ($message =~ /join ([\&\#]\S+)(?:\s+(\S+))?/i) {
# Thanks to Eden Li (tile) for the channel key patch
my($which, $key) = ($1, $2);
$key = defined ($key) ? " $key" : "";
foreach $chan (split(/\s+/, $param{'allowed_channels'})) {
if (lc($which) eq lc($chan)) {
$ok_to_join = $which . $key;
last;
}
}
if (IsFlag("o")) { $ok_to_join = $which.$key };
if ($ok_to_join) {
if (IsFlag("c") ne "c") {
&msg($who, "You don't have the channel flag");
return 'NOREPLY';
}
joinChan($ok_to_join);
&status("JOIN $ok_to_join <$who>");
&msg($who, "joining $ok_to_join")
unless ($channel eq &channel());
sleep(1);
# my $temp = &channel();
# &performSay("hello, $who.");
# &channel($temp);
return 'NOREPLY';
} else {
&msg($who, "I am not allowed to join that channel.");
return 'NOREPLY';
}
}
}
if (IsFlag("s") eq "s") {
if ($message =~ /^\s*(scan|search)\s*for\s+/i) {
if ($^O =~ /(win|mac)/i) {
# can't fork
&search($message);
} else {
&status("forking off: $message");
if (my $cpid = fork) {
# do nothing if we're the parent
} else {
# we're the child
&search($message);
&status("child exit: $message");
exit 0;
}
}
return 'NOREPLY';
}
}
if (getparam('allowConv')) {
if ($message =~ /^\s*(asci*|chr) (\d+)\s*$/) {
$num = $2;
if ($num < 32) {
$num += 64;
$res = "^".chr($num);
} else {
$res = chr($2);
}
if ($num == 0) { $res = "NULL"; } ;
return "ascii ".$2." is \'".$res."\'";
}
if ($message =~ /^\s*ord (.)\s*$/) {
$res = $1;
if (ord($res) < 32) {
$res = chr(ord($res) + 64);
if ($res eq chr(64)) {
$res = 'NULL';
} else {
$res = '^'.$res;
}
}
return "\'$res\' is ascii ".ord($1);
}
}
if (getparam('plusplus')) {
my $message2 = $message;
# Fixes the "soandso? has neutral karma" bug. - Masque, 12Apr2k
if ($message2 =~ s/^(?:karma|score)\s+(?:for\s+)?(.*?)\??$/$1/) {
# Some people prefer to have a factoid for their karma.
# This was the default behavior, pre-0.43.
$answer = &doQuestion($msgType, $message, $msgFilter);
return $answer if $answer;
$message2 = lc($message2);
$message2 =~ s/\s+/ /g;
&status("Karma string is currently \'$message2\'");
$message2 ||= "blank karma";
if ($message2 eq "me") {
$message2 = lc($who);
}
my $karma = &get(plusplus => $message2);
if ($karma) {
return "$message2 has karma of $karma";
} else {
return "$message2 has neutral karma";
}
}
}
if (($addressed) && ($message =~ /^statu?s/)) {
$upString = &timeToString(time()-$startTime);
$eTime = &get("is", "the qEpochDate");
return "Since $setup_time, there have been $updateCount "
. "modifications and $questionCount questions. "
. "I have been awake for $upString this session, "
. "and currently reference $factoidCount factoids. "
. "Addressing is in ".lc(getparam('addressing'))." mode.";
}
# divine added routine (boojum++)
if ($message =~ /^(8-?ball|divine)\s+(.*)/i) {
my %m8ball = ('original' => 'shakes the psychic black sphere...',
'sarcastic' => 'shakes the psychic purple sphere...',
'userdef' => 'shakes the psychic prismatic sphere...',
);
if (!@m8_answers) {
my $answer_file = getparam('magic8_answers') || "$param{miscdir}/magic8.txt";
print "reading from $answer_file\n";
if (open MAGIC8, "<$answer_file") {
while (<MAGIC8>) {
chomp;
push @m8_answers, $_;
}
} else {
@m8_answers = ('the Magic Ball is cloudy or missing a fact file.');
}
}
my ($type, $reply) = split /\s+=>\s+/, $m8_answers[rand(@m8_answers)];
if ($msgType eq 'public') {
&say("\cAACTION $m8ball{$type}\cA");
&say("It says '$reply,' $who");
} else {
&msg($who, "\cAACTION $m8ball{$type} \cA");
&msg($who, "It says '$reply'.");
}
return 'NOREPLY';
} # end divine
# excuse server. bobby@bofh.dk
if (getparam('excuse') and
($message =~ /^\s*(?:give\s+(.*)\s+an\s+excuse|excuse\s*(.*))\s*$/)) {
&status("excuses...");
if ($1 ne 'in') {
$person = $1 || "me";
}
$person = $who if $person =~ /^\s*me\s*$/i;
&status("calling &excuse()...");
my $excuse = "$who: " . &excuse();
if ($person ne $who) {
$excuse =~ s/^\s*Your excuse is/$who\'s excuse is/i;
}
if (not $excuse) {
$excuse = "No luck getting an excuse, $who";
}
if ($msgType eq 'public') {
&say($excuse);
} else {
&msg($who, $excuse);
}
return 'NOREPLY';
} # end excuse
return undef;
}
1;

144
extras/Internic.pl
Unescape Escape View File

@ -0,0 +1,144 @@
# infobot :: Kevin Lenzo (c) 1997
use Socket;
use POSIX;
sub I_REAPER {
$SIG{CHLD} = \&I_REAPER;
$waitedpid = wait;
}
$SIG{CHLD} = \&I_REAPER;
$DOMAIN_CACHE_EXPIRE_TIME = 7*24*60*60;
sub domain_summary {
# summarize the goo from internic
my $item = $_[0];
my @result;
my $result;
my @dom;
if (($DOMAIN_CACHE{$item})
&& ((time()-$DOMAIN_TIME_CACHE{$item}) < $DOMAIN_CACHE_EXPIRE_TIME)) {
return $DOMAIN_CACHE{$item};
}
if (!defined($pid = fork)) {
return "no luck, $safeWho";
} elsif ($pid) {
# parent
} else {
# child
@dom = &domain_lookup($item);
if ($dom[0] !~ /No match/) {
foreach (@dom) {
print ;
next if /^\s*$/;
s/:/: /;
s/\s+/ /g;
next if /^\s*Record/;
next if /^\s*Domain Name/;
# next if /^\s*\S+ Contact/;
# last if /^\s*Domain servers/;
last if /^To single out/;
if (s/the internic.*//i) {
push @result, $_;
last;
}
s/Administrative Contact/Admin/;
s/Technical Contact/Tech/;
s/Domain servers in listed order/DNS/;
push @result, $_;
last if ($#result > 15);
}
foreach (@result) { s/\s+/ /; s/^\s+//; }
foreach (0..$#result-1) {
$result[$_].="; " unless $result[$_]=~/:\s*$/;
}
$result = join("", @result);
$result =~ s/\s+;/;/g;
$result =~ s/\s+/ /g;
} else {
$result = "I can't find the domain $item";
}
$DOMAIN_TIME_CACHE{$item} = time();
$DOMAIN_CACHE{$item} = $result;
&msg($who, $result);
exit; # exit child.
}
}
sub domain_lookup {
# do the actual looking up
my($lookup) = @_;
my ($name, $aliases, $proto, $port, $len,
$this, $that, $thisaddr, $thataddr, $hostname);
my @result;
my $whois_server = 'rs.internic.net';
my $whois_port = 43;
$sockaddr = 'S n a4 x8';
chop($hostname = `hostname`);
($name, $aliases, $proto) = getprotobyname('tcp');
($name, $aliases, $whois_port) = getservbyname($whois_port, 'tcp')
unless $whois_port =~ /^\d+$/;
($name, $aliases, $type, $len, $thisaddr) = gethostbyname($hostname);
($name, $aliases, $type, $len, $thataddr) = gethostbyname($whois_server);
$this = pack($sockaddr, AF_INET, 0, $thisaddr);
$that = pack($sockaddr, AF_INET, $whois_port, $thataddr);
socket(DOMAIN_SERVER, PF_INET, SOCK_STREAM, $proto)
|| die "socket: $!";
bind(DOMAIN_SERVER, $this) || die "bind: $!";
connect(DOMAIN_SERVER, $that) || die "connect: $!";
select(DOMAIN_SERVER); $| = 1;
print DOMAIN_SERVER $lookup."\r\n";
@result = ();
my $line;
while (($#result < 30) && ($line = <DOMAIN_SERVER>)) {
next if (1.. $line =~ /Registrant:/);
push(@result,$line);
}
close(DOMAIN_SERVER); select(STDOUT);
unshift @result, "Registrant: " if @result;
@result;
}
1;
__END__
=head1 NAME
Internic.pl - look up Internic/RIPE whois records for a host
=head1 PREREQUISITES
Just the standard stuff.
=head1 PARAMETERS
allowInternic
=head1 PUBLIC INTERFACE
Internic|RIPE for <host>
=head1 DESCRIPTION
Queries RIPE or the Internic for the whois information about the
supplied host, and formats it up nicely.
=head1 AUTHORS
Kevin Lenzo

161
extras/Math.pl
Unescape Escape View File

@ -0,0 +1,161 @@
# infobot copyright (C) kevin lenzo 1997-98
if (!(%digits)) {
%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 math {
my $in = $_[0];
# Math handling.
foreach $x (keys %digits) {
$in =~ s/\b$x\b/$digits{$x}/g;
}
if (getparam('fortranMath')) {
if ($in =~ /^calc\s+(.+)$/) {
$parm = $1;
$parm =~ s/\s//g;
#$parm =~ s/[a-zA-Z]//g;
status("bc: $parm");
open(P, "echo '$parm'|bc 2>&1 |"); # dgl++
$tmp = '';
@prevs = ();
foreach $line (<P>) {
chomp $line;
$line =~ s/\\$//;
$line =~ s/\(standard_in\) 1: /$who: /;
$tmp = 0;
foreach $p (@prevs) {
if ($p eq $line) {
$tmp = 1;
}
}
if ($tmp == 0 && $line !~ /illegal character/) {
performReply($line);
}
push(@prevs, $line);
}
close(P);
return undef;
}
}
if (getparam('perlMath')) {
if (($in !~ /^\s*$/) and ($in !~ /(\d+\.){2,}/)) {
my($locMsg) = $in;
foreach (keys %digits) {
$locMsg =~ s/$_/$digits{$_}/g;
}
while ($locMsg =~ /(exp ([\w\d]+))/) {
$exp = $1;
$val = exp($2);
$locMsg =~ s/$exp/+$val/g;
}
while ($locMsg =~ /(hex2dec\s*([0-9A-Fa-f]+))/) {
$exp = $1;
$val = hex($2);
$locMsg =~ s/$exp/+$val/g;
}
if ($locMsg =~ /^\s*(dec2hex\s*(\d+))\s*\?*/) {
$exp = $1;
$val = sprintf("%x", "$2");
$locMsg =~ s/$exp/+$val/g;
}
$e = exp(1);
$locMsg =~ s/\be\b/$e/;
while ($locMsg =~ /(log\s*((\d+\.?\d*)|\d*\.?\d+))\s*/) {
$exp = $1;
$res = $2;
if ($res == 0) { $val = "Infinity";}
else { $val = log($res); } ;
$locMsg =~ s/$exp/+$val/g;
}
while ($locMsg =~ /(bin2dec ([01]+))/) {
$exp = $1;
$val = join ('', unpack ("B*", $2)) ;
$locMsg =~ s/$exp/+$val/g;
}
while ($locMsg =~ /(dec2bin (\d+))/) {
$exp = $1;
$val = join('', unpack('B*', pack('N', $2)));
$val =~ s/^0+//;
$locMsg =~ s/$exp/+$val/g;
}
$locMsg =~ s/ to the / ** /g;
$locMsg =~ s/\btimes\b/\*/g;
$locMsg =~ s/\bdiv(ided by)? /\/ /g;
$locMsg =~ s/\bover /\/ /g;
$locMsg =~ s/\bsquared/\*\*2 /g;
$locMsg =~ s/\bcubed/\*\*3 /g;
$locMsg =~ s/\bto\s+(\d+)(r?st|nd|rd|th)?( power)?/\*\*$1 /ig;
$locMsg =~ s/\bpercent of/*0.01*/ig;
$locMsg =~ s/\bpercent/*0.01/ig;
$locMsg =~ s/\% of\b/*0.01*/g;
$locMsg =~ s/\%/*0.01/g;
$locMsg =~ s/\bsquare root of (\d+)/$1 ** 0.5 /ig;
$locMsg =~ s/\bcubed? root of (\d+)/$1 **(1.0\/3.0) /ig;
$locMsg =~ s/ of / * /;
$locMsg =~ s/(bit(-| )?)?xor(\'?e?d( with))?/\^/g;
$locMsg =~ s/(bit(-| )?)?or(\'?e?d( with))?/\|/g;
$locMsg =~ s/bit(-| )?and(\'?e?d( with))?/\& /g;
$locMsg =~ s/(plus|and)/+/ig;
if (($locMsg =~ /^\s*[-\d*+\s()\/^\.\|\&\*\!]+\s*$/)
&& ($locMsg !~ /^\s*\(?\d+\.?\d*\)?\s*$/)
&& ($locMsg !~ /^\s*$/)
&& ($locMsg !~ /^\s*[( )]+\s*$/))
{
# $tmpMsg = $locMsg;
$locMsg = eval($locMsg);
if ($locMsg =~ /^[-+\de\.]+$/) {
# $locMsg = sprintf("%1.12f", $locMsg);
$locMsg =~ s/\.0+$//;
$locMsg =~ s/(\.\d+)000\d+/$1/;
if (length($locMsg) > 30) {
$locMsg = "a number with quite a few digits...";
}
return $locMsg;
} else {
$locMsg = undef;
}
}
}
}
return undef;
}
1;

136
extras/NOAA.pl
Unescape Escape View File

@ -0,0 +1,136 @@
#!/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::NOAA::get {
my ($station) = shift;
$station = uc($station);
my $result;
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;
if (my $proxy = main::getparam('httpproxy')) { $ua->proxy('http', $proxy) };
$ua->timeout(10);
my $request = new HTTP::Request('GET', "http://tgsv22.nws.noaa.gov/weather/current/$station.html");
my $response = $ua->request($request);
if (!$response->is_success) {
return "Something failed in connecting to the NOAA web server. Try again later.";
}
$content = $response->content;
if ($content =~ /ERROR/i) {
return "I can't find that station code (see http://weather.noaa.gov/weather/curcond.html for locations codes)";
}
$content =~ s|.*?current weather conditions.*?</TR>||is;
$content =~ s|.*?<TR>(?:\s*<[^>]+>)*\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;
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) {
$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

89
extras/RDF.pl
Unescape Escape View File

@ -0,0 +1,89 @@
# LotR++ for this one
# minor mods by lenzo@cs.cmu.edu
BEGIN {
eval qq{
use LWP::UserAgent;
use XML::RSS;
use HTTP::Request::Common qw(GET);
};
$no_headlines++ if($@);
}
sub get_headlines {
my ($rdf_loc) = @_;
if ($no_headlines) {
return "error: RDF headlines require LWP::UserAgent, XML::RSS, and HTTP::Request... sorry.";
}
if ($rdf_loc) {
&status("getting headlines from $rdf_loc");
my $ua = new LWP::UserAgent;
if (my $proxy = main::getparam('httpproxy')) { $ua->proxy('http', $proxy) };
$ua->timeout(10);
my $request = new HTTP::Request ("GET", $rdf_loc);
my $result = $ua->request ($request);
if ($result->is_success) {
my ($str);
$str = $result->content;
$rss = new XML::RSS;
eval { $rss->parse($str); };
if ($@) {
return "that gave some error";
} else {
my $return;
foreach my $item (@{$rss->{"items"}}) {
$return .= $item->{"title"} . "; ";
last if length($return) > $param{maxDataSize};
}
$return =~ s/; $//;
return $return;
}
} else {
return "error: $rdf_loc wasn't successful";
}
} else {
return "error: no location stored for $where";
}
};
1;
__END__
=head1 NAME
RDF.pl - Read RDF files into factoids
=head1 PREREQUISITES
LWP::UserAgent
XML::RSS
HTTP::Request::Common
=head1 PARAMETERS
rss
=head1 PUBLIC INTERFACE
<site> is <rss="site.rdf">
=head1 DESCRIPTION
This allows you to read and parse RSS files; RSS is a format
for getting news headlines off web news services.
=head1 AUTHORS
LotR <martijn@earthling.net> and Kevin Lenzo, of course.

98
extras/Slashdot3.pl
Unescape Escape View File

@ -0,0 +1,98 @@
#####################
# #
# Slashdot.pl for #
# SlashDot headline #
# retrival #
# tessone@imsa.edu #
# Chris Tessone #
# Licensing: #
# Artistic License #
# (as perl itself) #
#####################
#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.
use strict;
my $no_slashlines;
BEGIN {
$no_slashlines = 0;
eval "use LWP::UserAgent";
$no_slashlines++ if $@;
}
sub getslashdotheads {
# configure
if ($no_slashlines) {
&status("slashdot headlines requires LWP to be installed");
return '';
}
my $ua = new LWP::UserAgent;
if (my $proxy = main::getparam('httpproxy')) { $ua->proxy('http', $proxy) };
$ua->timeout(12);
my $maxheadlines=5;
my $slashurl='http://www.slashdot.org/slashdot.xml';
my $story=0;
my $slashindex = new HTTP::Request('GET',$slashurl);
my $response = $ua->request($slashindex);
if($response->is_success) {
$response->content =~ /<time>(.*?)<\/time>/;
my $lastupdate=$1;
my $headlines = "Slashdot - Updated ".$lastupdate;
my @indexhtml = split(/\n/,$response->content);
# gonna read in this xml stuff.
foreach(@indexhtml) {
if (/<story>/){$story++;}
elsif (/<title>(.*?)<\/title>/){
$headlines .= " | $1";
}
elsif (/<url>(.*?)<\/url>/){
# do nothing
}
elsif (/<time>(.*?)<\/time>/){
# do nothing
}
last if $story >= $maxheadlines;
next;
}
return $headlines;
} else {
return "I can't find the headlines.";
}
}
1;
__END__
=head1 NAME
Slashdot3.pl - Slashdot headlines grabber
=head1 PREREQUISITES
LWP::UserAgent
=head1 PARAMETERS
slashdot
=head1 PUBLIC INTERFACE
slashdot [headlines]
=head1 DESCRIPTION
Retrieves the headlines from Slashdot; probably obsoleted by RDF.
=head1 AUTHORS
Chris Tessone <tessone@imsa.edu>

47
extras/Speller.pl
Unescape Escape View File

@ -0,0 +1,47 @@
# infobot :: Kevin Lenzo (c) 1997
# doce++ for the first version of this!
sub ispell {
my $in = $_[0];
$in =~ s/^\s+//;
$in =~ s/\s+$//;
return "$in looks funny" unless $in =~ /^\w+$/;
#derr@rostrum# ispell -a
#@(#) International Ispell Version 3.1.20 10/10/95
#peice
#& peice 4 0: peace, pence, piece, price
my @tr = `echo $in | ispell -a -S`;
if (grep /^\*/, @tr) {
my $result = "'$in' may be spelled correctly";
if ($msgType =~ /private/) {
&msg($who, $result);
} else {
&say("$who: $result");
}
} else {
@tr = grep /^\s*&/, @tr;
chomp $tr[0];
($junk, $word, $junk, $junk, @rest) = split(/\ |\,\ /,$tr[0]);
my $result = "Possible spellings for $in: @rest";
if (scalar(@rest) == 0) {
$result = "I can't find alternate spellings for '$in'";
}
if ($msgType =~ /private/) {
&msg($who, $result);
} else {
&say($result);
}
}
return '';
}
1;

67
extras/Traceroute.pl
Unescape Escape View File

@ -0,0 +1,67 @@
# infobot :: Kevin Lenzo (c) 1997
# with thanks to Patrick Cole
use POSIX;
sub T_REAPER {
$SIG{CHLD} = \&REAPER; # loathe sysV
$waitedpid = wait;
}
$SIG{CHLD} = \&T_REAPER;
sub troute {
my $in = $_[0];
if (!defined($pid = fork)) {
return "no luck, $safeWho";
} elsif ($pid) {
# parent
} else {
# child
if ($in !~ /^[-_a-zA-Z0-9]+(\.[-_a-zA-Z0-9]+)+$/) {
&status("malformed traceroute: :$in:\n");
exit;
}
@tr = `traceroute $in`;
chomp($out = $tr[@tr-1]);
if ($msgType eq 'public') {
&msg($who, $out);
# &say($out);
} else {
&msg($who, $out);
}
exit; # kill child
}
}
1;
__END__
=head1 NAME
DNS.pl - Look up hosts in DNS
=head1 PREREQUISITES
External `traceroute' application
=head1 PARAMETERS
allowTraceroute
=head1 PUBLIC INTERFACE
traceroute <host>
=head1 DESCRIPTION
Shells out to the `traceroute' application to trace the route to a
host.
=head1 AUTHORS
Kevin Lenzo and Patrick Cole

133
extras/W3Search.pl
Unescape Escape View File

@ -0,0 +1,133 @@
# WWWSearch backend, with queries updating the is-db (optionally)
# Uses WWW::Search::Google and WWW::Search
# originally Google.pl, drastically altered.
use strict;
package W3Search;
my @engines;
my $no_W3Search;
BEGIN {
$no_W3Search = 0;
eval "use WWW::Search";
$no_W3Search++ if $@;
@engines = qw(AltaVista Dejanews Excite Gopher HotBot Infoseek
Lycos Magellan PLweb SFgate Simple Verity Google);
$W3Search::regex = join '|', @engines;
}
sub forking_W3Search {
if ($no_W3Search) {
&main::status("W3Search: this requires WWW::Search::Google to operate.");
return '';
}
my ($where, $what, $type, $callback) = @_;
$SIG{CHLD} = 'IGNORE';
my $pid = eval { fork() }; # catch non-forking OSes and other errors
return 'NOREPLY' if $pid; # parent does nothing
$callback->(W3Search($where, $what, $type));
exit 0 if defined $pid; # child exits, non-forking OS returns
}
sub W3Search {
if ($no_W3Search) {
&status("WWW search requires WWW::Search and WWW::Search::Google");
return 'sorry, can\'t do that';
} else {
my ($where, $what, $type) = @_;
my @matches = grep { lc($_) eq lc($where) ? $_ : undef } @engines;
if (!@matches) {
return "i don't know how to check '$where'";
} else {
$where = shift @matches;
}
my $Search = new WWW::Search($where);
my $Query = WWW::Search::escape_query($what);
$Search->native_query($Query);
my ($Result, $r, $count);
while ($r = $Search->next_result()) {
if ($Result) {
$Result .= " or ".$r->url();
} else {
$Result = $r->url();
}
last if ++$count >= 3;
}
if ($Result) {
if ($type =~ /update/) {
$main::correction_plausible++ if $type =~ /force/i;
$main::addressed++;
$main::googling = 1;
&main::update($what, "is", $Result);
$main::googling = 0;
}
return "$where says $what is $Result";
} else {
return "$where can't find $what";
}
}
}
1;
__END__
=head1 NAME
W3Search.pl - Forking web search interface
=head1 PREREQUISITES
WWW::Search
WWW::Search::Google
Probably some LWP stuff as well.
=head1 PARAMETERS
wwwsearch
=over 4
=item update
URLs retrieved will be added to the `is' database if no entry for the
search term exists.
=item force
URLs retrieved will be added to the `is' database even if a previous
entry for the search term exists.
=back
=head1 PUBLIC INTERFACE
[search] <engine> for <entry>
Where E<lt>C<engine>E<gt> is one of
AltaVista Dejanews Excite Gopher HotBot Infoseek
Lycos Magellan PLweb SFgate Simple Verity Google
=head1 DESCRIPTION
Does exactly what it says on the tin; looks up things in web search
engines and brings you back the results.
=head1 AUTHORS
Original Google.pl was by Simon <simon@brecon.co.uk>, converted and
generalised to this by Kevin Lenzo <lenzo@cs.cmu.edu>. Documentation
by Simon.

615
extras/Zippy.pl
Unescape Escape View File

@ -0,0 +1,615 @@
#
# 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;
my $no_zippy; # Can't think of any situation in which this won't work..
sub zippy::get {
my $line = shift;
unless ($line =~ /^yow[!? ]*$/i or $line =~ /^be zippy\?*$/i) {
return '';
}
unless (@yows) { # read data unless it's been read already.
print "Reading...\n";
while (<DATA>) {
chomp;
push @yows, $_;
}
}
if ($no_zippy) { # ..but just in case :-)
return "YOW! I'm an INFOBOT without ZIPPY!" if $main::addressed;
}
my $yow = $yows[rand(@yows)];
return $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!
=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 ...

146
extras/babel.pl
Unescape Escape View File

@ -0,0 +1,146 @@
#!/usr/bin/perl
# 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 babel;
use strict;
my $no_babel;
BEGIN {
eval "use URI::Escape"; # utility functions for encoding the
if ($@) { $no_babel++}; # babelfish request
eval "use LWP::UserAgent";
if ($@) { $no_babel++};
}
BEGIN {
# Translate some feasible abbreviations into the ones babelfish
# expects.
use vars qw!%lang_code $lang_regex!;
%lang_code = (
fr => 'fr',
sp => 'es',
po => 'pt',
pt => 'pt',
it => 'it',
ge => 'de',
de => 'de',
gr => 'de',
en => 'en'
);
# 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 forking_babelfish {
return '' if $no_babel;
my ($direction, $lang, $phrase, $callback) = @_;
$SIG{CHLD} = 'IGNORE';
my $pid = eval { fork() }; # catch non-forking OSes and other errors
return if $pid; # parent does nothing
$callback->(babelfish($direction, $lang, $phrase));
exit 0 if defined $pid; # child exits, non-forking OS returns
}
sub babelfish {
return '' if $no_babel;
my ($direction, $lang, $phrase) = @_;
$lang = $lang_code{$lang};
my $ua = new LWP::UserAgent;
$ua->timeout(5);
my $req =
#HTTP::Request->new('POST', 'http://babelfish.altavista.digital.com/cgi-bin/translate');
#HTTP::Request->new('POST', 'http://babelfish.altavista.com/translate.dyn');
HTTP::Request->new('POST', 'http://babelfish.altavista.com/raging/translate.dyn');
$req->content_type('application/x-www-form-urlencoded');
my $tolang = "en_$lang";
my $toenglish = "${lang}_en";
if ($direction eq 'to') {
return translate($phrase, $tolang, $req, $ua);
}
elsif ($direction eq 'from') {
return translate($phrase, $toenglish, $req, $ua);
}
my $last_english = $phrase;
my $last_lang;
my %results = ();
my $i = 0;
while ($i++ < 7) {
last if $results{$phrase}++;
$last_lang = $phrase = translate($phrase, $tolang, $req, $ua);
last if $results{$phrase}++;
$last_english = $phrase = translate($phrase, $toenglish, $req, $ua);
}
return $last_english;
}
sub translate {
return '' if $no_babel;
my ($phrase, $languagepair, $req, $ua) = @_;
my $urltext = uri_escape($phrase);
$req->content("urltext=$urltext&lp=$languagepair");
my $res = $ua->request($req);
if ($res->is_success) {
my $html = $res->content;
# This method subject to change with the whims of Altavista's design
# staff.
#print "$html\n===============\n";
# look for the first :< which should be the "To English:<", etc.
# strip any trailing tags, grab text that follows up to the next tag.
my (undef,$translated) = ($html =~ m{:(<[^>]*>\s*)+([^<]*)}sx);
#print "$translated\n===============\n";
# my ($translated) = ($html =~ m{:(<[^>]*>\s*)+([^<]*)}sx);
#print "$translated\n===============\n";
# ($html =~ m{<textarea[^>]*>
# \s*
# ([^<]*)
# }sx);
# ($html =~ m{<br>
# \s+
# <font\ face="arial,\ helvetica">
# \s*
# (?:\*\*\s+time\ out\s+\*\*)?
# \s*
# ([^<]*)
# }sx);
$translated =~ s/\n/ /g;
$translated =~ s/\s*$//;
return $translated;
} else {
return ":("; # failure
}
}
if (0) {
if (-t STDIN) {
my $result = babel::babelfish('to','sp','hello world');
$result =~ s/; /\n/g;
print "Babelfish says: $result\n";
}
}
1;

395
extras/exchange.pl
Unescape Escape View File

@ -0,0 +1,395 @@
#!/usr/bin/perl
# exchange.pl - currency exchange "module"
#
# Last update: 990818 08:30:10, bobby@bofh.dk
#
BEGIN {
eval qq{
use LWP::UserAgent;
use HTTP::Request::Common qw(POST GET);
};
$no_exchange++ if($@);
}
sub exchange {
my($From, $To, $Amount) = @_;
return "exchange.pl: not configured. needs LWP::UserAgent and HTTP::Request::Common"
if( $no_exchange );
my $retval = '';
my $ua = new LWP::UserAgent;
$ua->agent("Mozilla/4.5 " . $ua->agent); # Let's pretend
if (my $proxy = main::getparam('httpproxy')) { $ua->proxy('http', $proxy) };
$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);
%tld2country = &GetTlds;
if( $From =~ /^\.(\w\w)$/ ){ # Probably a tld
$From = $tld2country{uc $1};
}
if( $To =~ /^\.(\w\w)$/ ){ # Probably a tld
$To = $tld2country{uc $1};
}
if($#_ == 0){
# Country lookup
# crysflame++ for the space fix.
$retval = '';
foreach my $Found (grep /$From/i, keys %CurrLookup){
$Found =~ s/,/ uses/g;
$retval .= "$Found, ";
}
$retval =~ s/(?:, )?\|?$//;
return substr($retval, 0, 510);
}else{
# Make sure that $Amount is of the form \d+(\.\d\d)?
$Amount =~ s/[,.](\d\d)$/\01$1/;
$Amount =~ s/[,.]//g;
$Amount =~ s/\01/./;
# 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);
my $res = $ua->request($req); # Submit request
if ($res->is_success) { # Went through ok
my $html = $res->as_string;
my ($When, $Cfrom, $Cto) =
grep /\S+/, ($html =~ m/Rates as of (\d{4}\.\d\d.\d\d\s\d\d:\d\d:\d\d\s\S+)|([\d,.]+)\s*$From|([\d,.]+)\s* $To/gi);
if ($When) {
return "$Cfrom ($Currencies{$From}) makes ".
"$Cto ($Currencies{$To})"; # ." ($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 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;
}
"That's all folks ;-)";
__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>

29
extras/excuse.pl
Unescape Escape View File

@ -0,0 +1,29 @@
#!/usr/bin/perl
# excuse.pl - serve up bofh-style excuses
#
# lenzo@cs.cmu.edu -- fixed return codes
# updated 990818 08:31:11, bobby@bofh.dk
#
BEGIN {
eval "use Net::Telnet";
$no_excuse++ if ($@) ;
}
sub excuse {
my $host = "bofh.engr.wisc.edu";
my $port = 666;
my $t = Net::Telnet->new(Host => $host,
Errmode => "return",
Port => $port);
if (defined $t) {
$t->waitfor("/Your excuse is: /");
my $reply = $t->get;
return $reply;
} else {
return "The server at $host (port $port) appears to be down.";
}
}
1;

48
extras/insult.pl
Unescape Escape View File

@ -0,0 +1,48 @@
#!/usr/bin/perl
my $no_insult;
BEGIN {
eval "use Net::Telnet ();";
$no_insult++ if ($@) ;
}
sub insult {
# alex ayars was a sport and constributed a patch
my $t = new Net::Telnet (Errmode => "return", Timeout => 3);
$t->Net::Telnet::open(Host => "insulthost.colorado.edu", Port => "1695");
my $line = $t->Net::Telnet::getline(Timeout => 4);
return $line;
}
1;
__END__
=head1 NAME
insult.pl - Contact the Insult Server for an insult
=head1 PREREQUISITES
Net::Telnet
=head1 PARAMETERS
insult
=head1 PUBLIC INTERFACE
insult <foo>
If you have Babel enabled,
insult <foo> in <language code>
=head1 DESCRIPTION
Produces an insult from the Insult Server.
=head1 AUTHORS
<michael@limit.org>

51
extras/module-template
Unescape Escape View File

@ -0,0 +1,51 @@
# Template infobot extension
use strict;
BEGIN {
# eval your modules here
}
sub extension {
# Do stuff, return something
}
1;
__END__
=head1 NAME
Filename.pl - Description
=head1 PREREQUISITES
Some::Module
=head1 PARAMETERS
switchname
=over 4
=item value1
Description
=item value2
Description
=back
=head1 PUBLIC INTERFACE
Here you put how you call your sub from the bot user's point of view
=head1 DESCRIPTION
What is it?
=head1 AUTHORS
Who are you?

63
extras/myRoutines.pl
Unescape Escape View File

@ -0,0 +1,63 @@
# Infobot user extension stubs
# Kevin A. Lenzo
# put your routines in here.
@howAreYa = ("just great", "peachy", "mas o menos",
"you know how it is", "eh, ok", "pretty good. how about you");
sub myRoutines {
# called after it decides if it's been addressed.
# you have access tothe global variables here,
# which is bad, but anyway.
# you can return 'NOREPLY' if you want to stop
# processing past this point but don't want
# an answer. if you don't return NOREPLY, it
# will let all the rest of the default processing
# go to it. think of it as 'catching' the event.
# $addressed is whether the infobot has been
# named or, if a private or standalone
# context, addressed is always 'true'
# $msgType can be 'public', 'private', maybe 'dcc_chat'
# $who is the sender of the message
# $message is the current state of the input, after
# the addressing stuff stripped off the name
# $origMessage is the text of the original message before
# any normalization or processing
# you have access to all the routines in urlIrc.pl too,
# of course.
# example:
if ($addressed) {
# only if the infobot is addressed
if ($message =~ /how (the hell )?are (ya|you)( doin\'?g?)?\?*$/) {
return $howAreYa[rand($#howAreYa)];
}
} else {
# we haven't been addressed, but we are still listening
}
# another example: rot13
if ($message =~ /^rot13\s+(.*)/i) {
# rot13 it
my $reply = $1;
$reply =~ y/A-Za-z/N-ZA-Mn-za-m/;
return $reply;
}
return undef; # do nothing and let the other routines have a go
# Extras.pl is called next; look there for more complex examples.
}
1;

205
extras/nickometer.pl
Unescape Escape View File

@ -0,0 +1,205 @@
#!/usr/bin/perl -w
#
# 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: nickometer.pl,v 1.1 2000/12/09 22:24:17 lenzo Exp $
#
use strict;
use Getopt::Std;
use Math::Trig;
use vars qw($VERSION $score $verbose);
$VERSION = '$Revision: 1.1 $'; # '
$VERSION =~ s/^.*?([\d.]+).*?$/$1/;
sub nickometer ($) {
local $_ = shift;
local $score = 0;
# 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 = $_;
unless ($raw) {
$nick =~ tr/023457+8/ozeasttb/;
}
&punish($special_cost{$special}, "matched special case /$special_pattern/")
if $nick =~ /$special_pattern/i;
}
# Allow Perl referencing
s/^\\([A-Za-z])/$1/;
# Keep me safe from Pudge ;-)
s/\^(pudge)/$1/i;
# C-- ain't so bad either
s/^C--$/C/;
# Punish consecutive non-alphas
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 for unmatched
while (s/^([^()]*) (\() (.*) (\)) ([^()]*) $/$1$3$5/x ||
s/^([^{}]*) (\{) (.*) (\}) ([^{}]*) $/$1$3$5/x ||
s/^([^\[\]]*) (\[) (.*) (\]) ([^\[\]]*) $/$1$3$5/x)
{
print "Removed $2$4 outside parentheses; nick now $_\n" if $verbose;
}
my $parentheses = 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 = 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 = $_;
s/^([^A-Za-z]*[A-Z].*[a-z].*?)[_-]?([A-Z])/$1\l$2/;
# A caps first alpha is sometimes not lame
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 = tr/A-Z/A-Z/;
&punish(&slow_pow(7, $caps), "$caps extraneous caps") if $caps;
# Now punish anything that's left
my $remains = $_;
$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 + 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 - 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;

242
extras/purldoc.pl
Unescape Escape View File

@ -0,0 +1,242 @@
# purldoc.pl - Part of the kinder, gentler #Perl.
# Though he hates to admit it, this was written by the gent
# on EFNet #Perl known most often as Masque. Comments to
# masque@pound.perl.org. This code is covered under the same
# license as the rest of infobot.
# Eternal thanks to oznoid for writing the other bits, and
# for being a good friend to all Perldom. We're fortunate
# to have him.
# Please note that in this version, purldoc only searches the
# question _titles_. This is MUCH faster, and reduces the
# amount of work that the host machine has to do. This is
# the same way that perldoc -q does it, so don't complain
# _too_ loudly.
# KNOWN BUGS: Still sucks in many ways.
# removed all throttling code and replaced with returning
# \n-delimited clumps rather than direct msg or say.
sub purldoc {
my @results;
my $msg_params;
my $msg_limit = 6;
# changed this to just return the answers, mainly -- kl
($message, $msg_params) = split /;/, $message, 2;
print "got: $message\n";
my $pd_return = &purldoc_lookup($message, \@results);
return $pd_return unless @results;
my $res = '';
# removed the public/private distinction to be handled in
# the calling code -- kl
# This is one of those ideas that sounds great until you actually
# implement it. I now think the following concept sucks. Hard.
# On the off chance you disagree with me, leave it in. :]
# Complain if the user wants a specific number of all messages.
if ($msg_params =~ /\d+/ && $msg_params =~ /all/i) {
&msg($who, "Oh come now. Don't give me a number AND 'all'.");
return 'NOREPLY';
}
# Many thanks to crimson for the following join incantation.
# This is basically join() with a limit of $msg_limit items. Neat.
# I've uglified it by putting spaces in it and thus making it human
# readable. ;) The solution used lower to truncate the array to
# the message limit is somewhat more elegant, but I'm leaving this
# in comments because it's neat.
# &msg($who, join("; ",(@results[0..(@results < $msg_limit ? @results - $msg_limit : $msg_limit - 1)]))) and return unless $msg_params;
$msg_limit = $1 if $msg_params =~ /(\d+)/;
my $max_lines = getparam('purldoc_max_lines');
if ($msgType =~ /public/) {
my $max_public = getparam('purldoc_max_public');
$msg_limit = $max_public if $max_public < $max_lines;
}
# moved this down -- kl
if (getparam('purldoc') eq 'verbose') {
&msg($who, "There are " . (scalar @results - $msg_limit) . " more matches for your query. /msg me with the query to see more.");
}
# Okay, so it turns out that 'all' is a bit of a lie. It's
# more like 'all, unless X'. 30 will tie the bot up long enough,
# and people need to learn to limit their matches to some degree
# anyway. PATCHES ARE WELCOME. Yes, I'm aware the clumping code
# is total baby-talk. See earlier 'patches' comment.
# clump limit is hardcoded.
# Look what happens when you try to crossbreed style rules!
# ;] Hey, for that matter, check out the low-quality "let's pass
# the -w test" kludge! Did I mention that this whole subroutine
# was written over four days, spending no more than 10 minutes at
# a time per sitting? I'll rewrite this, but for now I just want
# to get the output working. Besides, I've got a couple of hours
# before the next code release....
# Come to think of it, we're not using -w at all. I am
# DEFINITELY going to rewrite this, so please stop laughing
# at this code now. The other subroutine is reasonably well
# written, go read that one instead.
# Thanks, lucs! $#results = $msg_limit -1 is neato. :]
$#results = $msg_limit - 1 if @results > $msg_limit;
if (defined $msg_params && $msg_params =~ /clump/i) {
my $clump;
for (0..$#results) {
$clump .= "$results[$_]; ";
if ($_ == $#results) {
$clump =~ s/; $//;
return $clump;
}
unless (($_ + 1) % 4) {
$clump =~ s/; $/.../;
$clump .= " \n";
}
}
} else {
my $res = '';
for (0..$#results) {
$res .= " \n" if $res;
$res .= $results[$_];
}
return $res;
}
}
# End sub purldoc()
# I probably don't need to pass the array to the subroutine, but
# it looks more impressive when the subroutine is all pr0totyped,
# etc., and perhaps I can distract you, the noble reader, from
# noticing the other less impressive bits of this code by putting
# in overly complicated code. We pass the array because we're only
# using return values if the sub blows up. Lame? Yes. Stupid?
# Perhaps. Intentional? Sure! This is perl, it's supposed to
# be fun. ;)
sub purldoc_lookup (\$\@) {
my $regex = shift;
my $original_regex = $regex;
my $target_filename = getparam('purldoc_override') || 'pod/perlfaq.pod';
my @search_dirs = @INC;
my $results = shift;
# There is most likely a much more elegant way to do this search, however
# this works, and it's 2am, so you're welcome to comment all you like either
# to /dev/null or to masque@pound.perl.com. Patches welcome. :]
unless (getparam('purldoc_override')) {
for (@search_dirs) {
$target_filename = "$_/$target_filename" and last if -e "$_/$target_filename";
}
}
# We don't do -f. -f would be crazy-long to return. It'd be easy
# enough to do, but it should only reply via /msg if implemented.
# Hmm...perhaps it should also be usable as
# 'tell $who about purldoc -f $function', though that has the
# potential for abuse. Perhaps purl should respond '$who wants
# you to ask me about purldoc -f $function,' but that is really
# pretty lame (and likely to be ignored.) Ah well. Reserved for
# future use.
return "No -f for you! NEXT!" if $regex =~ /^\s*-t?f/i;
# Sanity check on $regex. We don't want people searching for 'I', etc.
# It was most tempting to add 'HTML' and 'CGI' to the first regex, but
# I overcame the temptation...for now. ;)
$regex =~ s/(?:^|\b|\s)(?:\-t?qt?|I|do|how|my|what|which|who|can)\b/ /gi;
# I'm not proud of using the fearsome '.*?' here, but that leading and
# trailing whitespace MUST GO! IT ALL MUST GO! WE'LL MAKE ANY DEAL!
# IT'S CRAAAAAAAAAAAAAAAAAAZY MASQUE'S USED REGEX EMPORIUM! COME ON
# DOWN! WE'LL CLUB A SEAL TO MAKE A BETTER DEAL! (Weird Al, UHF)++
$regex =~ s/^\s*(.*?)\s*$/$1/;
# We're pretty picky about the regex. Currently there are no helpful
# two-letter strings in perlfaq (with the possible exception of 'do',
# which is being filtered for other reasons) so we require the length
# to be above that, and also we only want letters of the alphabet,
# thanks.
return "\'$original_regex\' isn't a good purldoc search string." unless $regex =~ /^[A-Za-z ]+$/ and length $regex > 2;
open PURLDOC, "<$target_filename" or return "Sorry, guys. I can't open perlfaq right now.";
# ACHTUNG! THE FOLLOWING CODE IS WILDLY INEFFICIENT! HAVE A CAPS LOCKY DAY.
my $chapter;
my $versecount;
while (<PURLDOC>) {
last if /^=head1 Credits/;
$chapter = $1 and $versecount = 0 if /^=item L<(\w+\d)/;
if (s/=item \* //) {
chomp;
$versecount++;
push(@$results, "$chapter, question $versecount: $_") if /$regex/i;
}
}
return "No matches for keyphrase '$regex' found." unless scalar @$results;
}
1;
__END__
=head1 NAME
purldoc.pl - Interface to the Perl FAQ.
=head1 PREREQUISITES
Nothing.
=head1 PARAMETERS
=over 4
=item purldoc
Turns the facility on and off
=item purldoc_triggers
Regexp used to match a call to the FAQ. Should be something like
`purldoc' or `perldoc'.
=back
=head1 PUBLIC INTERFACE
(Depends on your triggers, but generally:)
purldoc <topic>
=head1 DESCRIPTION
This looks up the given words as parts of a question in the Perl FAQ,
and returns the top three matching questions.
=head1 AUTHORS
Masque <masque@pound.perl.org>

77
extras/stockquote.pl
Unescape Escape View File

@ -0,0 +1,77 @@
use strict;
my $no_quote;
BEGIN {
eval qq{
use LWP::UserAgent;
use HTTP::Request::Common qw(GET);
};
$no_quote++ if($@);
}
sub get_quote {
my ($symbol) = @_;
if ($no_quote) {
return "error: stock quotes require LWP::UserAgent and HTTP::Request... sorry.";
}
if ($symbol) {
&status ("getting stock quote for $symbol");
my $ua = new LWP::UserAgent;
if (my $proxy = main::getparam('httpproxy')) { $ua->proxy('http', $proxy) };
$ua->timeout(10);
my $request = new HTTP::Request ("GET", "http://quote.yahoo.com/d/quotes/csv?s=$symbol&f=sl1d1t1c1ohgv&e=.csv");
my $result = $ua->request ($request);
if ($result->is_success) {
my $str = $result->content;
# strip quotes and extra whitespace
$str =~ s/["\s]//g;
chomp ($str);
my ($name, $current, $date, $time, $change) = split (/,/, $str);
if ($current eq "N/A") {
return "No match for $name";
}
return "At $time GMT-4, $name traded at $current ($change)";
} else {
return "error: there was a problem getting the quote from Yahoo\n";
}
}
}
1;
__END__
=head1 NAME
quote.pl - Get stock quote from yahoo
=head1 PREREQUISITES
LWP::UserAgent
HTTP::Request::Common
=head1 PARAMETERS
quote
=head1 PUBLIC INTERFACE
purl, quote <4-LETTER-TICKERNAME>
=head1 DESCRIPTION
This allows you to get a stock quote for a symbol from yahoo's stock
service.
=head1 AUTHORS
LotR <martijn@earthling.net> based on quote.pl from
Xachbot (http://www.xach.com/xachbot/quote.pl)

108
infobot
Unescape Escape View File

@ -0,0 +1,108 @@
#!/usr/bin/perl
# infobot -- copyright kevin lenzo (c) 1997-infinity
# no warrantee expressed or implied. terms as the
# license for X11R6 when needed.
BEGIN {
$VER_MAJ = 0;
$VER_MIN = 45;
$VER_MOD = 3;
$version = "infobot $VER_MAJ\.$VER_MIN\.$VER_MOD [Wurm]";
}
BEGIN {
$filesep = '/';
# set this to the absolute path if you need it; especially
# if . is not in your path
$param{'basedir'} = ($0 =~ /(.*)$filesep/) ? $1 : '.';
# $infobot_base_dir = '/usr/local/lib/infobot';
# change this next line if you run a local instance of
# an infobot and use the code from the main location.
# the 'files' directory contains infobot.config and
# infobot.users, among other things.
$param{'confdir'} = "$param{basedir}${filesep}conf";
# everything is loaded, then the variables that
# you want to set will override the defaults; this
# is why all these requires are here.
$param{'srcdir'} = $param{'basedir'}.$filesep."src";
opendir DIR, $param{'srcdir'}
or die "can't open source directory $param{srcdir}: $!";
while ($file = readdir DIR) {
next unless $file =~ /\.pl$/;
require "$param{srcdir}$filesep$file";
}
closedir DIR;
$param{'extradir'} = $param{'basedir'}.$filesep."extras";
opendir DIR, $param{'extradir'}
or die "can't open extras directory $param{extradir}: $!";
while ($file = readdir DIR) {
next unless $file =~ /\.pl$/;
require "$param{extradir}$filesep$file";
}
closedir DIR;
}
# get the command line arguments
&getArgs();
# initialize everything
&setup();
# launch the irc event loop
&irc();
exit 0; # just so you don't look farther down in this file :)
# --- support routines
sub usage {
print "\n";
print " usage: $0 [-h] [<paramfile1> [<pf2> ...]]\n";
print "\n";
print " -h this message\n";
print "\n";
}
sub getArgs {
if (@ARGV) {
while (@ARGV) {
my $arg = shift @ARGV;
if ($arg =~ s/^-//) {
# switchies
if ($arg eq 'i') {
# go into irc mode despite db setting
$overrideMode = 'IRC';
} else {
# -h is in here by default
&usage;
exit(1);
}
} else {
# no switchie. currently assumed to be
# a paramfile by default
push @paramfiles, $arg;
}
}
} else {
@paramfiles = ();
}
}
1;

36
scripts/README.scripts
Unescape Escape View File

@ -0,0 +1,36 @@
update_db [-m <module>] <filename> <dbname>
adds items in the file <filename> to the db with
the basename <dbname>. if -m <module> is specified that
module is used rather than AnyDBM_File.
file is of the form provided in ../files/infobot-is.txt
which is to say
<key> => <value>
one per line, and <dbname> is something like infobot-is
if the db doesn't exist, it will be created. if it does
exists, the entries will be added, potentially overwriting
entries that exists with the same key.
NOTE: skips lines that do not contain a => ... you can
add comments this way.
dump_db [-m <module>] <dbname>
turns the db into a flat ascii file of the form above.
try e.g.
dump_db infobot-is
dump_db -m DB_File infobot-is.db
run_infobots.pl
you'll need to edit this script to give the right home
directory, but this is for crontabbing the infobot. it
will run it if it's not already running. this is not
highly tested! YMMV.

71
scripts/curl
Unescape Escape View File

@ -0,0 +1,71 @@
#!/usr/bin/perl
$dbmdir = "/home/infobot/";
$dbmpref = "infobot";
&opendbs;
if (@ARGV) {
$query = join(" ", @ARGV);
&respond($query);
} else {
print "> ";
while (<>) {
last if /^\/?quit/i;
chomp;
if (/s^\/eval\s+/) {
$x = eval($_);
print $x;
} else {
&respond($_);
}
print "> ";
}
}
sub opendbs {
my $dp = "$dbmdir/$dbmpref";
dbmopen(%is, "$dbmdir/$dbmpref-is", undef)
|| die "can't open $dbmdir/$dbmpref-is -- please set path";
dbmopen(%are, "$dbmdir/$dbmpref-are", undef)
|| die "can't open $dbmdir/$dbmpref-are";
}
sub checkdbs {
my @reply;
foreach $k (@_) {
push @reply, $is{$k} if $is{$k};
push @reply, $are{$k} if $are{$k};
}
return @reply;
}
sub respond {
my $query = $_[0];
my @r;
$query =~ tr/A-Z/a-z/;
$query =~ s/wh\S+\s+(is|are)\s+//;
$query =~ s/\s*\?\s*$//;
if ($query =~ /\s+(are|is)\s+/i) {
$lhs = $`; $verb = $1; $rhs = $';
chomp $rhs;
$$verb{$lhs} = $rhs;
} else {
if (@r = &checkdbs($query)) {
foreach (@r) {
chomp;
print "$_\n";
}
} else {
print "undefined: $query\n";
}
}
}
sub dump {
foreach (keys %is) {
print "$_ => $is{$_}\n";
}
}

50
scripts/dump_db
Unescape Escape View File

@ -0,0 +1,50 @@
#!/usr/bin/perl
use Fcntl qw(/^O_/);
(my $Me = $0) =~ s-.*/--;
# XXX This should read your config file and default to the database type
# you specified there. The library should be extended to support this.
my $module = my $def_module = 'AnyDBM_File';
if (@ARGV && $ARGV[0] =~ s/^-m//) {
$module = shift;
if ($module eq '') {
@ARGV or die "$Me: no arg for -m specified\n";
$module = shift;
}
}
if (!@ARGV || grep /^-/, @ARGV) {
print "\n";
print " usage: $Me [-m <dbm module>] <dbname>\n";
print "\n";
print " prints out an ascii flat file of the\n";
print " database <dbname>. <dbname> should be\n";
print " the basename of the db, e.g.\n";
print "\n";
print " $Me infobot-is\n";
print "\n";
print " <dbm module> is an alternate for $def_module,\n";
print " eg DB_File\n";
print "\n";
exit(1);
}
eval "require $module"; die if $@;
$| = 1;
foreach $dbname (@ARGV) {
tie(%db, $module, $dbname, O_RDONLY, undef)
|| die "Couldn't open \"$dbname\" with $module: $!";
my ($key, $val);
while (($key, $val) = each %db) {
chomp $val;
print "$key => $val\n";
}
untie(%db) || die "untie() on $dbname failed: $!";
}

45
scripts/flock-test
Unescape Escape View File

@ -0,0 +1,45 @@
#!/usr/bin/perl -w
use strict;
# $Id: flock-test,v 1.1 2000/11/01 22:41:34 lenzo Exp $
#use sigtrap qw(die normal-signals);
use Fcntl ':flock';
use POSIX 'EWOULDBLOCK';
(my $Me = $0) =~ s-.*/--;
$| = 1;
@ARGV == 2 or die "usage: $Me file <sh|ex|nbsh|nbex>";
my ($file, $type) = @ARGV;
my $no_block = $type =~ s/^nb//;
my $bits = $type eq 'sh' ? LOCK_SH
: $type eq 'ex' ? LOCK_EX
: die "$Me: unknown lock type $type\n";
$type = 'LOCK_' . uc $type;
open FH, "+<$file" or die "$Me: can't read $file: $!\n";
if (flock FH, $bits | LOCK_NB) {
print "Locked $file with type $type, sleeping...";
}
else {
$! == EWOULDBLOCK
or die "$Me: can't flock($file, $type | LOCK_NB): $!\n";
$no_block and die "$Me: can't immediately lock $file with type $type\n";
print "Blocking waiting for $type lock on $file...";
flock FH, $bits
or die "$Me: can't flock($file, $type): $!\n";
print "locked, sleeping...";
}
sleep;
#END {
# if ($locked) {
# flock FH, LOCK_UN or die "$Me: can't unlock $file: $!\n";
# }
#}

18
scripts/get_entries_from_log
Unescape Escape View File

@ -0,0 +1,18 @@
#!/usr/bin/perl
# kevin lenzo
# run infobot.track through here to get the
# enters and updates in order. Adding these
# in order should give you the db as it was.
while (<>) {
next unless s/.*: (enter|update): //;
next if /FAILED/;
chomp;
s/\'; was .*//;
s/\'\s*$//;
s/.*?\'//;
print "$_\n";
}

20
scripts/make_password
Unescape Escape View File

@ -0,0 +1,20 @@
#!/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);
}

31
scripts/make_snap
Unescape Escape View File

@ -0,0 +1,31 @@
#!/usr/bin/perl
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
localtime(time);
$year = 1900 + $year;
my $snapdir = sprintf "snap-%04d%02d%02d-%02d:%02d:%02d",
$year, $month, $mday, $hour, $min, $sec;
mkdir $snapdir, 0744 or die "$snapdir: $!";
$| = 1;
foreach $dbname (<*.db>) {
$dbname =~ s/\.db$//;
my $target = "$snapdir/$dbname.txt";
print "Flattening db $dbname into $target\n";
dbmopen(%db, $dbname, undef) || die "Couldn't dbmopen \"$dbname\"";
open OUT, ">$target" or die "$target: $!";
print OUT "# $dbname at ",localtime(time),"\n";
my $key;
foreach $key (keys %db) {
my $val = $db{$key};
chomp $val;
print OUT "$key => $val\n";
}
dbmclose(%db);
close OUT;
sleep 1;
}

45
scripts/restore_snap
Unescape Escape View File

@ -0,0 +1,45 @@
#!/usr/bin/perl
$snapdir = $ARGV[0];
opendir DIR, $snapdir or die "$snapdir: $!";
@files = grep /.txt$/, readdir DIR;
closedir DIR;
$| = 1;
for $sourcefile (@files) {
$sourcefile = "$snapdir/$sourcefile";
open(IN, $sourcefile)
|| die "can\'t open $sourcefile as source\n";
my $dbname = <IN>;
chomp $dbname;
die "Bad file: $sourcefile" unless $dbname =~ s/^\# (\S+) .*/$1/;
print "Restoring $sourcefile into $dbname\n";
dbmopen(%db, $dbname, 0644) || die "Couldn't dbmopen \"$dbname\"";
while (<IN>) {
chomp;
next if /^\s*$/;
if (!/=>/) {
print "skipping: $_";
next;
}
my ($left, $right) = split(/\s*=>\s*/, $_, 2);
if ($left =~ /^\s*$/) {
warn "Empty key, ignored: ($left => $right)\n";
next;
}
$left =~ s/^\s*//;
$left =~ tr/A-Z/a-z/;
$right =~ s/\s+$//;
$db{$left} = $right;
# print $left ." => ". $right ."\n" if (!(++$dcount % 100));
}
close(IN);
dbmclose(%db);
}

20
scripts/run_if_needed.pl
Unescape Escape View File

@ -0,0 +1,20 @@
#!/usr/bin/perl
# you will probably need to change $homedir
# and possibly the path to perl above
my $homedir = '/usr/home/infobot/infobot0.34';
my @ps = `ps auxw`;
@result = grep !/grep/, @ps;
@result = grep /infobot/, @ps;
if (!@result) {
print "trying to run new process\n";
chdir($homedir) || die "can't chdir to $homedir";
system("nohup $homedir/infobot -i $homedir/files/irc.params > /dev/null &");
} else {
print "already running: \n";
print " @result\n";
}

42
scripts/track2fact
Unescape Escape View File

@ -0,0 +1,42 @@
#!/usr/bin/perl
if (@ARGV != 1) {
print "\n";
print " Usage: $0 <file.track>";
print "\n";
print " generates text files for update_db from\n";
print " the tracking file log.\n";
print "\n";
print " creates <file.track>-is.txt and \n";
print " <file.track>-are.txt\n";
print "\n";
}
foreach $file (@ARGV) {
if (!open IN, $file) {
print "can't open $file: $!\n";
next;
}
open IS, ">$file-is.txt";
open ARE, ">$file-are.txt";
while (<IN>) {
chomp;
if (s/.*?enter: \S+ said \'(.*)\'/$1/
or s/.*?update: \'(.*?)\'; was .*/$1/) {
next if /FAILED/;
if (/^(.*?) is (.*)/) {
print IS "$1 => $2\n";
} elsif (/^(.*?) are (.*)/) {
print ARE "$1 => $2\n";
}
} else {
# do nothing
}
}
close IN;
close IS;
close ARE;
}

91
scripts/unupdate_dbs
Unescape Escape View File

@ -0,0 +1,91 @@
#!/usr/bin/perl
if ((scalar(@ARGV) != 3) || (grep /^-/, @ARGV)) {
print "\n";
print " usage: $0 <logfile> <nickname> <dbmstem>\n";
print "\n";
print " undo the updates entered by nickname that appear\n";
print " in an infobot log file\n";
print "\n";
print " <logfile> is an infobot text log file\n";
print "\n";
print " <nickname> is the nickname whose effects you\n";
print " want to undo (without the brackets, of course)\n";
print "\n";
print " <dbmstem> the the basename of the dbm db\n";
print " (e.g. 'infobot-')\n";
print "\n";
exit(1);
}
($logfile, $nickname, $dbmstem) = @ARGV;
open(IN, $logfile)
|| die "can\'t open $logfile as source\n";
if (not $test = 0) {
dbmopen(%dbis, "$dbmstem-is", 0755)
|| die "Couldn't dbmopen \"$dbmstem-is\"";
dbmopen(%dbare, "$dbmstem-are", 0755)
|| die "Couldn't dbmopen \"$dbmstem-are\"";
}
$| = 1;
while (<IN>) {
chomp;
next unless s/^(\d+) \[(\d+)\] (\S+): <(\S+)> //;
@attr{qw/time entry type nick/} = ($1, $2, $3, $4);
next unless $attr{'nick'} =~ /^$nickname/i;
if ($attr{'type'} eq 'update') {
@attr{qw(X verb corrupted Y)} = /^\'(.*?) =(is|are)=> (.*?)\'; was \'(.*)\'$/;
$attr{X} =~ s/^\s*//;
$attr{X} =~ tr/A-Z/a-z/;
$attr{Y} =~ s/\s+$//;
if ($attr{verb} eq 'is') {
$dbis{$attr{X}} = $attr{Y};
} else {
$dbare{$attr{X}} = $attr{Y};
}
push @undo, "enter: $attr{X} =$attr{verb}=> $attr{Y}";
} elsif ($attr{'type'} eq 'forget') {
$attr{X} = $_;
warn "* can't handle 'forget' easily until 0.43.5: forget $_\n";
} elsif ($attr{'type'} eq 'enter') {
$attr{qw/X verb Y/} = /^(.*?) =(is|are)=> (.*)$/;
push @undo, "delete: $1 =$2=> $3";
}
}
close(IN);
while ($act = pop @undo) {
($type, $X, $verb, $Y) = $act =~ /^(\S+): (.*?) =(\S+)=> (.*)$/;
if ($type eq 'enter') {
print "ENTER $X <=$verb= $Y\n";
if ($verb eq "is") {
$dbis{$X} = $Y;
} else {
$dbare{$X} = $Y;
}
} elsif ($type eq 'delete') {
print "DELETE $X <=$verb= $Y\n";
if ($verb eq "is") {
delete $dbis{$X};
} else {
delete $dbare{$X};
}
}
}
dbmclose(%dbis);
dbmclose(%dbare);
exit;

69
scripts/update_db
Unescape Escape View File

@ -0,0 +1,69 @@
#!/usr/bin/perl
use Fcntl qw(/^O_/);
(my $Me = $0) =~ s-.*/--;
# XXX This should read your config file and default to the database type
# you specified there. The library should be extended to support this.
my $module = my $def_module = 'AnyDBM_File';
if (@ARGV && $ARGV[0] =~ s/^-m//) {
$module = shift;
if ($module eq '') {
@ARGV or die "$Me: no arg for -m specified\n";
$module = shift;
}
}
if (@ARGV != 2 || (grep /^-/, @ARGV)) {
print "\n";
print " usage: $Me [-m <dbm module>] <sourcefile> <dbmname>\n";
print "\n";
print " adds elements in <sourcefile> to dbm <dbmname>\n";
print "\n";
print " <sourcefile> is a text file of one-per-line\n";
print " <key> => <value>\n";
print " pairs, \n";
print "\n";
print " <dbmname> the the basename of the dbm db\n";
print " (e.g. 'infobot-is')\n";
print "\n";
print " <dbm module> is an alternate for $def_module,\n";
print " eg DB_File\n";
print "\n";
exit(1);
}
eval "require $module"; die if $@;
$sourcefile = $ARGV[0];
$dbname = $ARGV[1];
open(IN, $sourcefile)
|| die "can\'t open $sourcefile as source\n";
tie(%db, $module, $dbname, O_RDWR | O_CREAT, 0666)
|| die "Couldn't open \"$dbname\" with $module: $!";
$| = 1;
while (<IN>) {
chomp;
next if /^\s*$/;
if (!/=>/) {
print "skipping: $_";
next;
}
my ($left, $right) = split(/\s*=>\s*/, $_, 2);
$left =~ s/^\s*//;
$left =~ tr/A-Z/a-z/;
$right =~ s/\s+$//;
$db{$left} = $right;
print $left ." => ". $right ."\n" if (!(++$dcount % 100));
}
close(IN);
untie(%db) || die "untie() on $dbname failed: $!";

27
src/CTCP.pl
Unescape Escape View File

@ -0,0 +1,27 @@
# infobot (c) 1997 Lenzo
sub parsectcp {
my ($nick, $user, $host, $type, $dest) = @_;
&status("CTCP $type $dest request from $nick");
if ($type =~ /^version/i) {
ctcpreply($nick, "VERSION", $version);
} elsif ($type =~ /^(echo|ping) ?(.*)/i) {
rawout("NOTICE $nick :\001PING $2\001");
# ctcpreply($nick, uc($1)." $2");
} elsif ($type =~ /^DCC /) {
&status("DCC attempt from $who (not supported, ignored)");
}
}
sub ctcpReplyParse {
my ($nick, $user, $host, $type, $reply) = @_;
&status("CTCP $type reply from $nick: $reply");
}
sub ctcpreply {
my ($rnick, $type, $reply) = @_;
rawout("NOTICE $rnick :\001$type $reply\001");
}
1;

42
src/Channel.pl
Unescape Escape View File

@ -0,0 +1,42 @@
# Channel specific data, based heavily on User.pl
#
# Simon Cozens, for infobot (C) Kevin Lenzo 1997
#
sub parseChannelfile {
$file = $param{'confdir'}.$filesep.$param{'channelList'};
%chanopts = ();
open(FH, $file) or return; # Oz, you didn't check a retval. :P
while (<FH>) {
next unless (!/^#/ && defined $_);
if (/^ChannelEntry\s+(.+?)\s/) {
$workname = $1;
if (/\s*\{\s*/) {
while (<FH>) {
if (/^\s*(\w+)\s+(.+);$/) {
$opt = $1; $val = $2;
$val =~ s/\"//g;
$opt =~ tr/A-Z/a-z/;
$chanopts{$workname}->{$opt} = $val;
} elsif (/^\s*\}\s*$/) {
last;
}
}
} else {
status("parse error: Channel Entry $workname without right brace");
}
}
}
}
sub getparam {
my $optname = shift;
my $chan = channel();
return $param{$optname} if ($msgType =~ /private/);
return $chanopts{$chan}->{$optname}
if defined $chanopts{$chan}->{$optname};
return $param{$optname};
}
"false";

743
src/DBM.pl
Unescape Escape View File

@ -0,0 +1,743 @@
# $Id: DBM.pl,v 1.7 2000/12/09 22:58:27 lenzo Exp $
#
# infobot :: Kevin Lenzo (c) 1997
use strict;
package Infobot::DBM;
=head1 NAME
DBM.pl - infobot's interface to on-disk databases
=head1 SYNOPSIS
openDBMx 'mydb', fatal => 1; # more switches listed below
$val = get 'mydb', $key; # get value
set 'mydb', $key, $val; # set value
$prev_val = postInc 'mydb', $key; # increment, return old value
$prev_val = postDec 'mydb', $key; # decrement, return old value
@keys = getDBMKeys 'mydb'; # get all keys
clear 'mydb', $key; # delete key
clearAll 'mydb'; # delete all keys
insertFile 'mydb', $filename; # load space-separated fields
closeDBM 'mydb'; # close this db
closeDBMAll; # close all dbs
syncDBM 'mydb'; # flush changes to disk
=head1 DESCRIPTION
These functions provide B<infobot>'s interface to on-disk databases.
=cut
BEGIN { push @INC, 'src' } # baad, bad juju here
use vars qw(%DBMS $Debug $Init_done $Old_warnings);
use Fcntl qw(
:flock
O_CREAT
O_RDWR
);
use Symbol qw(
gensym
);
use Util qw(
export_to_main
import_from_main
process_args
);
BEGIN {
if (!$Init_done) {
$Old_warnings = $^W;
$^W = 1;
}
}
my @Import;
my @Export;
BEGIN {
@Import = qw(
$filesep
%param
status
);
@Export = qw(
clear
clearAll
closeDBM
closeDBMAll
forget
get
getDBMKeys
insertFile
openDBM
openDBMx
postDec
postInc
set
showdb
syncDBM
whatdbs
);
export_to_main @Export;
import_from_main @Import;
}
use subs grep /^\w/, @Export;
use vars grep /^\W/, @Import, @Export;
use subs qw(_open);
# %DBMS maps from the user's database name to an array of data about each
# db. The referenced array is indexed by the following constant subs.
%DBMS = () unless $Init_done;
sub F_DBNAME () { 0 } # %DBMS key
sub F_HASH () { 1 } # reference to the tied hash
sub F_FILE () { 2 } # name of file opened
sub F_LOCKING () { 3 } # true if locking is enabled for this db
sub F_LOCK_FH () { 4 } # filehandle used for locking
sub F_LOCK_STAT () { 5 } # current LOCK_* status
sub F_MODULE () { 6 } # database module used
sub F_SYNC_SUB () { 7 } # cached sync() method
sub F_INITFILE () { 8 } # initial contents when creating
sub F_UPDATE_COUNT () { 9 } # number of updates since last sync
$Debug = 0 unless $Init_done;
=head1 CONFIGURATION SETTINGS
=over 4
=item DBMModule
Setting C<DBMModule> lets you explicitly specify the DBM backend which
you'd like to use. Standard values for this are C<NDBM_File>, C<DB_File>,
C<GDBM_File>, C<SDBM_File>, and C<ODBM_File>, but anything which provides
a tied hash interface should work. If you don't specify this the default
will generally be the first of these which is present on your system.
Eg:
DBMModule DB_File
=item DBMExt
This is appened to the file names passed to DBM open. This can be
useful for DBM modules which don't modify the file name passed to them,
such as DB_File and GDBM_File. For example,
DBMExt .db
will provide traditional naming for DB_File databases.
=item sharedDBMs
This provides support for sharing database files among multiple B<infobot>s
on the same machine by using locking. NB: Using any sharedDBMs currently
requires that you set C<DBMModule> to C<DB_File>, as none of the other DBM
modules provides the required support.
Eg, if you said
sharedDBMs is are plusplus
your infobot would use locking when accessing the main factoid databases
and the C<karma> database, but not, say, the C<seen> database. You can
have multiple infobots accessing the same databases for which they all
use locking. It's up to you to make sure that all the bots which access
a particular file use locking for it, if you screw that up the rogue
will end up corrupting your database.
There are two special values:
sharedDBMs /all
sharedDBMs /all-but-ignore
These set up locking for everything, and for everything but the
C<ignore> database (which is used more than any other, so perhaps
it's a good candidate for such special treatment).
=item commitDBM
This setting controls how often changes to the database are flushed to
disk. Normally this isn't done manually, so it will depend on how the
DBM module you're using behaves. If you set C<commitDBM> to a number,
changes will be forced to disk every that many updates (so use 1 to
force a sync after every update).
=back
=cut
unless ($Init_done) {
$param{DBMModule} = 'AnyDBM_File';
$param{DBMExt} = '';
$param{sharedDBMs} = '';
$param{commitDBM} = 0;
}
=head1 INTERFACE FUNCTIONS
=over 4
=item opemDBMx I<dbname>, [I<arg> => I<val>]...
This function opens up a database. The I<dbname> is the name you'll use
to refer to it with all the other functions. The normal practice is to
supply only the I<dbname>, most of the other arguments have reasonable
(preferred, even) defaults. openDBMx() returns true if the database was
opened successfully, false otherwise, unless you've set C<fatal> to a
true value.
Arguments are:
fatal => $boolean
This boolean, which is off by default, tells openDBMx() to
die() rather than returning false if the database can't be
successfully opened.
tag => $tag
This defaults to the I<dbname> you gave. That's normally what
you want, it'd be unusual to specify the tag manually. The tag
is what's actually used to look up the other values in %param.
file => $filename
This allows you to override the name of database file (though
the user's C<DBMExt> is still appended). Normally you wouldn't
specify this, and the value the user specifies in $param{$tag}
is used.
initfile => $filename
When a database is created the code uses insertFile() to load a
file called F<$misc_dir/infobot-$tag.txt> into it. You can
override the name of the file used by specifying it with this
argument.
locking => $boolean
This boolean tells the code whether to use locking or not.
Normally you wouldn't specify it and the user's C<sharedDBMs>
setting would dictate that.
module => $db_module
This allows you to override the user's C<DBMModule> for this database.
=cut
sub openDBMx {
my ($dbname, @arg) = @_;
my ($fatal, $file, $initfile, $tag, $locking, $module);
my $fail = sub {
my $s = join '', @_;
status $s;
die $s if $fatal;
return 0;
};
process_args \@arg,
fatal => \$fatal,
file => \$file,
locking => \$locking,
initfile => \$initfile,
module => \$module,
tag => \$tag
or return;
$tag ||= $dbname;
if (!defined $file) {
my $base = $param{$tag};
if (!defined $base) {
return $fail->("$tag not specified in config file"
. " and no default supplied");
}
$file = $param{basedir} . $filesep . $base;
}
$file .= $param{DBMExt};
$initfile = $param{confdir} . $filesep . "infobot-$tag.txt"
if !defined $initfile;
$locking = $param{sharedDBMs} eq '/all'
|| ($tag ne 'ignore'
&& $param{sharedDBMs} eq '/all-but-ignore')
|| grep { $_ eq $tag } split ' ', $param{sharedDBMs}
if !defined $locking;
$module = $param{DBMModule} if !defined $module;
if ($locking) {
if ($module ne 'DB_File') {
die "Locking is specified for the $tag database, but ",
"DBMModule isn't DB_File (it's $module)";
}
}
eval "require $module";
if ($@) {
chomp $@;
die "Invalid DBMModule setting `$module' ($@)\n";
}
if ($DBMS{$dbname}) {
status "$file replaces $DBMS{$dbname}[F_FILE]"
unless $file eq $DBMS{$dbname}[F_FILE];
}
my $rdb = $DBMS{$dbname} ||= [];
$rdb->[F_DBNAME] = $dbname;
$rdb->[F_FILE] = $file;
$rdb->[F_LOCKING] = $locking;
$rdb->[F_MODULE] = $module;
$rdb->[F_INITFILE] = $initfile;
_open $rdb
or return $fail->($@);
return 1;
}
# Perform the actual open on the given db record. Return true is
# successful, else false and set $@ to an explanation.
sub _open {
my ($rdb) = @_;
my ($created);
my $dbname = $rdb->[F_DBNAME];
my $file = $rdb->[F_FILE];
my $locking = $rdb->[F_LOCKING];
my $module = $rdb->[F_MODULE];
my $with_locking = $locking ? ' (with locking)' : '';
if (tie %{ $rdb->[F_HASH] }, $module, $file, O_RDWR, 0) {
status "opened $dbname -> $file$with_locking";
} elsif (tie %{ $rdb->[F_HASH] }, $module, $file, O_CREAT | O_RDWR, 0666) {
status "created new db $dbname -> $file$with_locking";
$created = 1;
} else {
$@ = "failed to open $dbname -> $file";
return 0;
}
if ($locking) {
my $fh = $rdb->[F_LOCK_FH] = gensym;
my $fd = tied(%{ $rdb->[F_HASH] })->fd;
if (!open $fh, "+<&=$fd") {
delete $DBMS{$dbname};
$@ = "can't fdopen fd $fd to provide locking for $dbname";
return 0;
}
}
$rdb->[F_LOCK_STAT] = LOCK_UN;
$rdb->[F_UPDATE_COUNT] = 0;
# Wait until after the locking FH is set up to do the inserts.
insertFile $dbname, $rdb->[F_INITFILE]
if $created;
return 1;
}
sub _close_open {
my ($dbname) = @_;
my ($fail_reason);
closeDBM '_no_delete', $dbname;
# The old (commented-out) code for this would sleep and retry if the
# reopen failed. It seems bogus to me, but I don't want to piss
# anybody off by removing it.
for (1..10) {
return 1 if _open $DBMS{$dbname};
} continue {
status "Error re-opening $dbname ($@), sleeping";
sleep 1;
}
status "Error re-opening $dbname ($@), giving up";
return 0;
}
=item openDBM $dbname => $file, ...
This is the old interface to opening databases. It's equivalent to
running
openDBMx $dbname, file => $file;
for each pair of arguments. The return value is true if all the opens
succeeded.
=cut
sub openDBM {
my %arg = @_;
my ($dbname, $file, $fail);
while (($dbname, $file) = each %arg) {
next unless $dbname =~ /\S/;
openDBMx $dbname, file => $file
or $fail = 1;
}
return !$fail;
}
=item syncDBM $dbname
Flush to disk any unwritten changes to the database.
=cut
sub syncDBM {
my ($dbname) = @_;
my $rdb = $DBMS{$dbname};
print "sync $rdb->[F_DBNAME]\n" if $Debug;
$rdb->[F_UPDATE_COUNT] = 0;
&{ $rdb->[F_SYNC_SUB] ||= do {
if (tied(%{ $rdb->[F_HASH] })->can('sync')) {
print "syncDBM: $dbname using ->sync\n" if $Debug;
sub { tied(%{ $rdb->[F_HASH] })->sync }
}
else {
print "syncDBM: $dbname using reopen\n" if $Debug;
sub { _close_open $dbname }
}
}
}();
}
sub lock {
my ($rdb, $bits) = @_;
my $have = $rdb->[F_LOCK_STAT];
my $want = $bits - ($bits & LOCK_NB);
printf "lock db %-8s fd %2s have $have want $want bits $bits\n",
$rdb->[F_DBNAME],
$rdb->[F_LOCKING] ? fileno $rdb->[F_LOCK_FH] : '-',
if $Debug;
return if $have == $want;
# Possibly flush when unlocking (or downgrading LOCK_EX to LOCK_SH).
if ($have == LOCK_EX) {
$rdb->[F_UPDATE_COUNT]++;
if ($rdb->[F_LOCKING]
|| $param{commitDBM} eq 'ALWAYS' # grandfather
|| ($param{commitDBM} > 0 &&
$rdb->[F_UPDATE_COUNT] >= $param{commitDBM})) {
syncDBM $rdb->[F_DBNAME];
}
}
flock $rdb->[F_LOCK_FH], $bits or die "Can't lock $rdb->[F_FILE]: $!\n"
if $rdb->[F_LOCKING];
$rdb->[F_LOCK_STAT] = $want;
}
=item insertFile $dbname, $filename
This loads the given file into the database. Input lines look like
key => value
(spaces around the C<=E<gt>> are optional).
=cut
sub insertFile {
my ($dbname, $factfile) = @_;
my $rdb = $DBMS{$dbname};
if (open(IN, $factfile)) {
my ($good, $total);
lock $rdb, LOCK_EX;
while(<IN>) {
chomp;
my ($k, $v) = split(/\s*=>\s*/, $_, 2);
if ($k and $v) {
$rdb->[F_HASH]{$k} = $v;
$good++;
}
$total++;
}
lock $rdb, LOCK_UN;
close(IN);
status "loaded $factfile into $dbname ($good/$total good items)";
} else {
status "FAILED to load $factfile into $dbname";
}
}
=item closeDBM $dbname
Close the database.
=cut
sub closeDBM {
if (@_) {
my ($dbname, $rdb, $no_delete);
$no_delete = shift if $_[0] eq '_no_delete';
foreach $dbname (@_) {
my $rdb = $DBMS{$dbname};
delete $DBMS{$dbname} unless $no_delete;
status untie(%{ $rdb->[F_HASH] })
? "closed db $dbname"
: "Error closing db $dbname ($!)";
}
} else {
status "No dbs specified; none closed";
}
}
=item closeDBMAll
Close all databases.
=cut
sub closeDBMAll {
closeDBM keys %DBMS;
}
=item set $dbname, $key, $val
Set a key/value pair in the database.
=cut
sub set {
my ($dbname, $key, $val, $no_locking) = @_;
if (!$key) {
($dbname, $key, $val) = split(/\s+/, $dbname);
}
# this is a hack to keep set param consistant.. overloaded
if ($dbname eq 'param') {
my $was = $param{$key};
$param{$key} = $val;
return $was;
}
if (!$key) {
return 'NULLKEY';
}
my $rdb = $DBMS{$dbname};
my $rhash = $rdb->[F_HASH];
lock $rdb, LOCK_EX unless $no_locking;
my $was = $rhash->{$key};
$rhash->{$key} = $val;
lock $rdb, LOCK_UN unless $no_locking;
return $was;
}
=item get $dbname, $key
Return the value corresponding to the $key in the database.
=cut
sub get {
my ($dbname, $key, $no_locking) =@_;
if (!$key) {
($dbname, $key) = split(/\s+/, $dbname);
}
my $rdb = $DBMS{$dbname};
lock $rdb, LOCK_SH unless $no_locking;
my $val = $rdb->[F_HASH]{$key};
lock $rdb, LOCK_UN unless $no_locking;
return $val;
}
=item postInc $dbname, $key
Increment the value of $key in the database, return the old value.
=cut
sub postInc {
my ($dbname, $key) = @_;
my $rdb = $DBMS{$dbname};
lock $rdb, LOCK_EX;
set $dbname, $key, 1 + get($dbname, $key, 1), 1;
lock $rdb, LOCK_UN;
}
=item postDec $dbname, $key
Decrement the value of $key in the database, return the old value.
=cut
sub postDec {
my ($dbname, $key) = @_;
my $rdb = $DBMS{$dbname};
lock $rdb, LOCK_EX;
set $dbname, $key, -1 + get($dbname, $key, 1), 1;
lock $rdb, LOCK_UN;
}
sub whatdbs {
my @result;
foreach (keys %DBMS) {
push @result, "$_ => $DBMS{$_}[F_FILE]";
}
return @result;
}
sub showdb {
my ($dbname, $regex) = @_;
my @result;
if (!$regex) {
($dbname, $regex) = split(/\s+/, $dbname, 2);
}
my @whichdbs;
if (!$dbname) {
status "no db given";
status "try showdb <db> <regex>";
# @whichdbs = (keys %DBMS);
} else {
@whichdbs = ($dbname);
}
foreach $dbname (@whichdbs) {
my $rdb = $DBMS{$dbname};
if (!$rdb) {
status "the database $dbname is not open.";
status "try showdb <db> <regex>";
return();
}
lock $rdb, LOCK_SH;
my $rhash = $rdb->[F_HASH];
my ($key, $val);
if (!$regex) {
status "showing all of $dbname";
while (($key, $val) = each %$rhash) {
push @result, "$key => $val";
}
} else {
status "searching $dbname for /$regex/";
while (($key, $val) = each %$rhash) {
push @result, "$key => $val"
if $key =~ /$regex/ || $val =~ /$regex/;
}
}
lock $rdb, LOCK_UN;
}
return @result;
}
sub forget {
clear @_;
return '';
}
=item clear $dbname, $key
Delete a key from the database.
=cut
sub clear {
my ($dbname, $key) =@_;
if (!$key) {
($dbname, $key) = split(/\s+/, $dbname);
}
my $rdb = $DBMS{$dbname};
lock $rdb, LOCK_EX;
my $was = get $dbname, $key, 1;
print "DELETING $dbname $key\n";
delete $DBMS{$dbname}[F_HASH]{$key};
print "DELETED\n";
lock $rdb, LOCK_UN;
return $was;
}
=item clearAll $dbname
Empty the database.
=cut
sub clearAll {
my ($dbname) = @_;
my $rdb = $DBMS{$dbname};
lock $rdb, LOCK_EX;
%{ $rdb->[F_HASH] } = ();
lock $rdb, LOCK_UN;
}
=item getDBMKeys $dbname
Return all the keys in the database.
=cut
sub getDBMKeys {
my ($dbname) = @_;
my $rdb = $DBMS{$dbname};
lock $rdb, LOCK_SH;
my @k = keys %{ $rdb->[F_HASH] };
lock $rdb, LOCK_UN;
return @k;
}
if (!$Init_done) {
$^W = $Old_warnings;
$Init_done = 1;
}
1
__END__
=back
=head1 AUTHOR
Kevin Lenzo, expanded by Roderick Schertler <F<roderick@argon.org>>
=head1 SEE ALSO
infobot(1), perl(1).
=cut

60
src/Help.pl
Unescape Escape View File

@ -0,0 +1,60 @@
# infobot :: Kevin Lenzo (c) 1997
sub setup_help {
$filesep ||= '/';
if (!exists $param{'helpfile'}) {
$param{'helpfile'} = "$infobot.help"; # murrayb++
}
if (open (HELP, "$param{confdir}/$param{helpfile}")) {
undef %help;
while ($help = <HELP>) {
$help =~ s/\#.*//;
chomp $help;
next unless $help;
($key, $val) = split(/:/, $help, 2);
if (!$help{$key}) {
$helptopics .= "$key ";
}
if ($help{$key}) {
$help{$key} .= $val."\n";
} else {
$help{$key} = $val."\n";
}
}
$helptopics =~ s/\s+$//;
&status("Loaded help file $param{helpfile}");
} else {
$help{"main"} = "couldn't find the help file";
&status("No help file $param{helpfile}");
}
}
sub help {
my $topic = $_[0];
if ($topic =~ /^\s*$/) {
$topic = "main";
}
$topic =~ s/^\s*//;
$topic =~ s/\s*$//;
$topic =~ s/\s+/ /;
$topic =~ tr/A-Z/a-z/;
if ($help{$topic}) {
foreach (split(/\n/, $help{$topic})) {
&msg($who,$_);
}
} else {
&msg($who, "no help on $topic");
}
&msg($who, 'topics: '.$helptopics.". use 'help <topic>'.");
return '';
}
1;

475
src/Irc.pl
Unescape Escape View File

@ -0,0 +1,475 @@
# infobot :: Kevin Lenzo & Patrick Cole (c) 1997
use Socket;
sub srvConnect {
my ($server, $port) = @_;
my ($iaddr, $paddr, $proto);
select(STDOUT);
$| = 1;
$iaddr = inet_aton($server);
$ip_num = inet_ntoa($iaddr);
if (not $ip_num) {
die "can't get the address of $server ($ip_num)!\n";
}
&status("Connecting to port $port of server $server ($ip_num)...");
$paddr = sockaddr_in($port, $iaddr);
$proto = getprotobyname('tcp');
socket(SOCK, PF_INET, SOCK_STREAM, $proto) or die "socket failed: $!";
$sockaddr = 'S n a4 x8';
if ($param{'vhost_name'}) {
my $hostname = $param{'vhost_name'};
$this = pack($sockaddr, AF_INET, 0, inet_aton($hostname));
&status("trying to bind as $hostname");
bind(SOCK, $this) || die "bind: $!";
}
connect(SOCK, $paddr) or die "connect failed: $!";
&status(" connected.");
}
sub procservmode {
my ($server, $e, $f) = @_;
my @parts = split (/ /, $f);
$cnt=0;
my $mode="";
my $chan="";
foreach (@parts) {
if ($cnt == 0) {
$chan = $_;
} else {
$mode .= $_;
$mode .= " ";
}
++$cnt;
}
chop $mode;
$mode=~s/://;
if ($server eq $chan) {
if ($params{ansi_control}) {
&status(">>> $b$server$ob sets user mode: $b$mode$ob");
} else {
&status(">>> $server sets mode: $mode");
}
} else {
if ($params{ansi_control}) {
&status(">>> $b$server$ob/$b$chan$ob sets server mode: $b$mode$ob");
} else {
&status(">>> $server/$chan sets mode: $mode");
}
}
}
### added by the xk.
# Usage: &nickServ(text);
sub nickServ {
my $text = shift;
return if !defined $param{'nickServ_pass'};
&status("NickServ: <= '$text'");
if ($text =~ /Password incorrect/i) {
&status("NickServ: ** identify failed.");
return;
}
if ($text =~ /Password accepted/i) {
&status("NickServ: ** identify success.");
return;
}
if ($nickserv_try) { return; }
&status("NickServ: => Identifying to NickServ.");
rawout("PRIVMSG NickServ :IDENTIFY $param{'nickServ_pass'}");
$nickserv_try++;
}
###
# Usage: &chanServ(text);
sub chanServ {
my $text = shift;
# return if !defined $param{'chanServ_ops'};
&status("chanServ_ops => '$param{'chanServ_ops'}'.");
&status("ChanServ: <= '$text'");
# to be continued...
return;
}
# end of xk functions.
sub procmode {
my ($nick, $user, $host, $e, $f) = @_;
my @parts = split (/ /, $f);
$cnt=0;
my $mode="";
my $chan="";
foreach (@parts) {
if ($cnt == 0) {
$chan = $_;
} else {
$mode .= $_;
$mode .= " ";
}
++$cnt;
}
$mode =~ s/\s$//;
if ($param{ansi_control}) {
&status(">>> mode/$b$chan$ob [$b$mode$ob] by $b$nick$ob");
} else {
&status(">>> mode/$chan [$mode] by $nick");
}
if ($chan =~ /^[\#\&]/) {
my ($modes, $targets) = ($mode =~ /^(\S+)\s+(.*)/);
my @m = ($modes =~ /([+-]*\w)/g);
my @t = split /\s+/, $targets;
if (@m != @t) {
&status("number of modes does not match number of targets: @m / @t");
} else {
my $parity = 0;
foreach (0..$#m) {
if ($m[$_] =~ s/^([-+])//) {
$sign = $1;
if ($sign eq '-') {
$parity = -1;
} else {
$parity = 1;
}
}
if ($parity == 0) {
&status("zero parity mode change... ignored");
} else {
if ($parity > 0) {
$channels{$chan}{$m}{$t} = '+';
} else {
delete $channels{$chan}{$mode}{$t};
}
}
}
}
}
}
sub entryEvt {
my ($nick, $user, $host, $type, $chan) = @_;
if ($type=~/PART/) {
if ($param{ansi_control}) {
&status(">>> $nick ($user\@$host) has left $chan");
} else {
&status(">>> $nick ($user\@$host) has left $chan");
}
} elsif ($type=~/JOIN/) {
if ($netsplit) {
foreach (keys(%snick)) {
if ($nick eq $snick{$_}) {
@be = split (/ /);
if ($param{ansi_control}) {
&status(">>> ${b}Netjoined$ob: $be[0] $be[1]");
} else {
&status(">>> ${b}Netjoined$ob: $be[0] $be[1]");
}
$netsplit--;
}
}
}
if ($param{ansi_control}) {
&status(">>> $nick ($user\@$host) has joined $chan");
} else {
&status(">>> $nick ($user\@$host) has joined $chan");
}
} elsif ($type=~/QUIT/) {
$chan=~s/\r//;
if ($chan=~/^([\d\w\_\-\/]+\.[\.\d\w\_\-\/]+)\s([\d\w\_\-\/]+\.[\.\d\w\_\-\/]+)$/) {
$i=0;
while (0 and ($i < $netsplit || !$netsplit)) {
# while ($i < $netsplit || !$netsplit) {
$i++;
if (($prevsplit1{$i} ne $2) && ($prevsplit2{$i} ne $1)) {
&status("Netsplit: $2 split from $1");
$netsplit++;
$prevsplit1{$netsplit} = $2;
$prevsplit2{$netsplit} = $1;
$snick{"$2 $1"}=$nick;
$schan{"$2 $1"}=$chan;
}
}
} else {
if ($param{ansi_control}) {
&status(">>> $b$nick$ob has signed off IRC ($b$chan$ob)");
} else {
&status(">>> $b$nick$ob has signed off IRC ($b$chan$ob)");
}
}
} elsif ($type=~/NICK/) {
if ($param{ansi_control}) {
&status(">>> ".c($nick,'bold green').
" materializes into ".c($chan,'bold green'));
} else {
&status(">>> $b$nick$ob materializes into $b$chan$ob");
}
}
}
sub procevent {
my ($nick, $user, $host, $type, $chan, $msg) = @_;
# support global $nuh, $who
$nuh = "$nick!$user\@$host";
if ($type=~/PRIVMSG/) {
if ($chan =~ /^$ischan/) {
## It's a public message on the channel##
$chan =~ tr/A-Z/a-z/;
if ($msg =~ /\001(.*)\001/ && $msg !~ /ACTION/) {
#### Client To Client Protocol ####
parsectcp($nick, $user, $host, $1, $chan);
} elsif ($msg !~ /ACTION\s(.+)/) {
#### Public Channel Message ####
&IrcMsgHook('public', $chan, $nick, $msg);
} else {
#### Public Action ####
&IrcActionHook($nick, $chan, $1);
}
} else {
## Is Private ##
if ($msg=~/\001(.*)\001/) {
#### Client To Client Protocol ####
parsectcp($nick, $user, $host, $1, $chan);
} else {
#### Is a Private Message ##
&IrcMsgHook('private', $chan, $nick, $msg);
}
}
} elsif ($type=~/NOTICE/) {
if ($chan =~ /^$ischan/) {
$chan =~ tr/A-Z/a-z/;
if ($msg !~ /ACTION (.*)/) {
&status("-$nick/$chan- $msg");
} else {
&status("* $nick/$chan $1");
}
} else {
if ($msg=~/\001([A-Z]*)\s(.*)\001/) {
ctcpReplyParse($nick, $user, $host, $1, $2);
} else {
&status("-$nick($user\@$host)- $msg");
}
}
}
}
sub servmsg {
my $msg=$_[0];
my ($ucount, $uc) = (0, 0);
if ($msg=~/^001/) {
# joinChan(split/\s+/, $param{'join_channels'});
# Line in infobot.config:
# join_channels #chan,key #chan_with_no_key
#
# since , is not allowed in channels, we'll use it to specify keys
# without breaking current join_channels format
for (split /\s+/, $param{'join_channels'}) {
# if it's a keyed chan, replace the comma with a space so it'll
# work as per the RFC (i.e. JOIN #chan key)
s/,/ /;
joinChan ($_);
}
$nicktries=0;
} elsif ($msg=~/^NOTICE ($ident) :(.*)/) {
serverNotice($1,$2);
} elsif ($msg=~/^332 $ident ($ischan) :(.*)/) {
if ($param{ansi_control}) {
&status(">>> topic for $b$1$ob: $2");
} else {
&status(">>> topic for $1: $2");
}
} elsif ($msg=~/^333 $ident $ischan (.*) (.*)$/) {
if ($param{ansi_control}) {
&status(">>> set by $b$1$ob at $b$2$ob");
} else {
&status(">>> set by $1 at $2");
}
} elsif ($msg=~/^433/) {
++$nicktries;
if (length($param{wantNick}) > 9) {
$ident = chop $param{wantNick};
$ident .= $nicktries;
} else {
$ident = $param{wantNick}.$nicktries;
}
if ($param{'opername'}) {
&rawout("OPER $param{opername} $param{operpass}");
}
$param{nick} = $ident;
&status("*** Nickname $param{wantNick} in use, trying $ident");
rawout("NICK $ident");
} elsif ($msg=~/[0-9]+ $ident . ($ischan) :(.*)/) {
my ($chan, $users) = ($1, $2);
&status("NAMES $chan: $users");
my $u;
foreach $u (split /\s+/, $users) {
if (s/\@//) {
$channels{$chan}{o}{$u}++;
}
if (s/\+//) {
$channels{$chan}{v}{$u}++;
}
}
} elsif ($msg=~/[0-9]{3} $ident(\s$ischan)*?\s:(.*)/) {
&status("$2");
}
}
sub serverNotice {
($type, $msg) = @_;
if ($type=~/AUTH/) {
&status("!$param{server}! $msg");
} else {
$msg =~ s/\*\*\* Notice -- //;
&status("-!$param{server}!- $msg");
}
}
sub OperWall {
my ($nick, $msg) = @_;
$msg=~s/\*\*\* Notice -- //;
&status("[wallop($nick)] $msg");
}
sub prockick {
my ($kicker, $chan, $knick, $why) = @_;
if ($param{ansi_control}) {
&status(">>> $b$knick$ob was kicked off $b$chan$ob by $b$kicker$ob ($b$why$ob)");
} else {
&status(">>> $b$knick$ob was kicked off $b$chan$ob by $b$kicker$ob ($b$why$ob)");
}
if ($knick eq $ident) {
&status("SELF attempting to rejoin lost channel $chan");
&joinChan($chan);
}
}
sub prockill {
my ($killer, $knick, $kserv, $killnick, $why) = @_;
if ($knick eq $ident) {
&status("KILLED by $killnick ($why)");
} else {
&status("KILL $knick by $killnick ($why)");
}
}
sub fhbits {
local (@fhlist) = split(' ',$_[0]);
local ($bits);
for (@fhlist) {
vec($bits,fileno($_),1) = 1;
}
$bits;
}
sub irc {
local ($rin, $rout);
local ($buf, $line);
$nicktries=0;
$connected=1;
while ($connected) {
srvConnect($param{server}, $param{port});
if ($param{server_pass}) { # ksiero++
rawout("PASS $param{server_pass}");
}
rawout("NICK $param{wantNick}");
rawout("USER $param{ircuser} $param{ident} $param{server} :$param{realname}");
if ($param{operator}) {
rawout("OPER $param{operName} $param{operPass}\n");
}
$param{nick} = $param{wantNick};
$ident = $param{wantNick};
$/ = "\015" if $^O eq "MacOS";
$rin = fhbits('SOCK');
while (1) {
($nfound,$timeleft) = select($rout=$rin, undef, undef, 0);
if ($rout & SOCK) {
if (sysread(SOCK,$buf,1) <= 0) {
last;
}
if ($buf=~/\n/) {
$line.=$buf;
sparse($line);
undef $line;
} else {
$line.=$buf;
}
}
}
}
}
#Corion++
# Fixed baaaad backdor in server parsing (regexes are a bitch :( )
# /msg infobot :a@b.c PRIVMSG #channel seen <nick>
# can be used to flood a channel witout getting ever caught !
# Affected lines were
# PRIVMSG / NOTICE / TOPIC / KICK
sub sparse {
$_ = $_[0];
s/\r//;
if (/^PING :(\S+)/) { # Pings are important
rawout("PONG :$1");
&status("SELF replied to server PING") if $param{VERBOSITY} > 2;
} elsif (/^:\S+ ([\d]{3} .*)/) {
servmsg($1);
} elsif (/^:([\d\w\_\-\/]+\.[\.\d\w\_\-\/]+) NOTICE ($ident) :(.*)/) {
&status("\-\[$1\]- $3");
} elsif (/^NOTICE (.*) :(.*)/) {
serverNotice($1, $2);
} elsif (/^:NickServ!s\@NickServ NOTICE \S+ :(.*)/i) {
&nickServ($1); # added by the xk.
} elsif (/^:ChanServ!s\@ChanServ NOTICE \S+ :(.*)/i) {
&chanServ($1); # added by the xk.
} elsif (/^:(\S+)!(\S+)@(\S+)\s(PRIVMSG|NOTICE)\s([\#\&]?\S+)\s:(.*)/) {
procevent($1,$2,$3,$4,$5,$6);
} elsif (/^:(\S+)!(\S+)@(\S+)\s(PART|JOIN|NICK|QUIT)\s:?(.*)/) {
entryEvt($1,$2,$3,$4,$5);
} elsif (/^:(.*) WALLOPS :(.*)/) {
OperWall($1,$2);
} elsif (/^:(.*)!(.*)@(.*) (MODE) (.*)/) {
procmode($1,$2,$3,$4,$5);
} elsif (/^:(.*) (MODE) (.*)/) {
procservmode($1,$2,$3);
} elsif (/^:(\S+)!(?:\S+)@(?:\S+) KICK ((\#|&).+) (.*) :(.*)/) {
prockick($1,$2,$4,$5);
} elsif (/^ERROR :(.*)/) {
&status("ERROR $1");
} elsif (/^:([^! ]+)!\S+@\S+ TOPIC (\#.+) :(.*)/) {
if ($param{ansi_control}) {
&status(">>> $1$b\[$ob$2$b\]$ob set the topic: $3");
} else {
&status(">>> $1\[$2\] set the topic: $3");
}
} elsif (/^:(\S+)!\S+@\S+ KILL (.*) :(.*)!(.*) \((.*)\)/) {
prockill($1,$2,$3,$4,$5);
} else {
&status("UNKNOWN $_");
}
#Corion--
}
1;

158
src/IrcExtras.pl
Unescape Escape View File

@ -0,0 +1,158 @@
# infobot :: Kevin Lenzo (c) 1999
use Socket;
$| = 1;
$SIG{'INT'} = 'killed';
$SIG{'KILL'} = 'killed';
$SIG{'TERM'} = 'killed';
$updateCount = 0;
$questionCount = 0;
$autorecon = 0;
$label = "(?:[a-zA-Z\d](?:(?:[a-zA-Z\d\-]+)?[a-zA-Z\d])?)";
$dmatch = "(?:(?:$label\.?)*$label)";
$ipmatch = "\d+\.\d+\.\d+\.\d";
$ischan = "[\#\&].*?";
$isnick = "[a-zA-Z]{1}[a-zA-Z0-9\_\-]+";
sub TimerAlarm {
&status("$TimerWho's timer ended. sending wakeup");
&say("$TimerWho: this is your wake up call, foobar.");
}
sub killed {
my $quitMsg = $param{'quitMsg'} || "regrouping";
&quit($quitMsg);
&closeDBMAll();
# MUHAHAHAHA.
exit(1);
}
sub joinChan {
foreach (@_) {
&status("joined $_");
rawout("JOIN $_");
}
}
sub invite {
my($who, $chan) = @_;
rawout("INVITE $who $chan");
}
sub notice {
my($who, $msg) = @_;
foreach (split(/\n/, $msg)) {
rawout("NOTICE $who :$_");
}
}
sub say {
my @what = @_;
my ($line, $each, $count);
foreach $line (@what) {
for $each (split /\n/, $line) {
sleep 1 if $count++;
if (getparam("msgonly")) {
&msg ($who, $each);
} else {
&status("</$talkchannel> $each");
rawout("PRIVMSG $talkchannel :$each");
}
}
}
}
sub msg {
my $nick = shift;
my @what = @_;
my ($line, $each, $count);
foreach $line (@what) {
for $each (split /\n/, $line) {
sleep 1 if $count++;
&status(">$nick< $each");
rawout("PRIVMSG $nick :$each");
}
}
}
sub quit {
my $quitmsg = $_[0];
rawout("QUIT :$quitmsg");
&status("QUIT $param{nick} has quit IRC ($quitmsg)");
close(SOCK);
}
sub nick {
$nick = $_[0];
rawout("NICK ".$nick);
}
sub part {
foreach (@_) {
status("left $_");
rawout("PART $_");
delete $channels{$_};
}
}
sub mode {
my ($chan, @modes) = @_;
my $modes = join(" ", @modes);
rawout("MODE $chan $modes");
}
sub op {
my ($chan, $arg) = @_;
$arg =~ s/^\s+//;
$arg =~ s/\s+$//;
$arg =~ s/\s+/ /;
my @parts = split(/\s+/, $arg);
my $os = "o" x scalar(@parts);
mode($chan, "+$os $arg");
}
sub deop {
my ($chan, $arg) = @_;
$arg =~ s/^\s+//;
$arg =~ s/\s+$//;
$arg =~ s/\s+/ /;
my @parts = split(/\s+/, $arg);
my $os = "o" x scalar(@parts);
&mode($chan, "-$os $arg");
}
sub timer {
($t, $timerStuff) = @_;
# alarm($t);
}
$SIG{"ALRM"} = \&doTimer;
sub doTimer {
rawout($timerStuff);
}
sub channel {
if (scalar(@_) > 0) {
$talkchannel = $_[0];
}
$talkchannel;
}
sub rawout {
$buf = $_[0];
$buf =~ s/\n//gi;
select(SOCK); $| = 1;
print SOCK "$buf\n";
select(STDOUT);
}
1;

83
src/IrcHooks.pl
Unescape Escape View File

@ -0,0 +1,83 @@
# infobot :: Kevin Lenzo (c) 1997
# Tidied up ?
sub IrcActionHook {
my ($who, $channel, $message) = @_;
&channel($channel);
&process($who, 'public action', $message);
if ($msgType =~ /public/) {
&status("<$who/$channel> $origMessage");
} else {
&status("[$who] $origMessage");
}
}
sub IrcMsgHook {
my ($type, $channel, $who, $message) = @_;
if ($type =~ /public/i) {
&channel($channel);
&process($who, $type, $message);
&status("<$who/$channel> $origMessage");
}
if ($type =~ /private/i) {
if (($params{'mode'} eq 'IRC') && ($who eq $prevwho)) {
$delay = time() - $prevtime;
$prevcount++;
if (0 and $delay < 1) {
# this is where to put people on ignore if they flood you
if (IsFlag("o") ne "o") {
&msg($who, "You will be ignored -- flood detected.");
&postInc(ignore => $who);
&log_line("ignoring ".$who);
return;
}
}
return if (($message eq $prevmsg) && ($delay < 10));
} else {
$prevcount = 0;
$firsttime = time;
}
$prevtime = time unless ($message eq $prevmsg);
$prevmsg = $message;
$prevwho = $who;
&process($who, $type, $message);
&status("[$who] $origMessage");
}
return;
}
sub hook_dcc_request {
my($type, $text) = @_;
if ($type =~ /chat/i) {
&status("received dcc chat request from $who : $text");
my($locWho) = $who;
$locWho =~ tr/A-Z/a-z/;
$locWho =~ s/\W//;
&docommand("dcc chat ".$who);
&msg('='.$who, "Hello, ".$who);
}
return '';
}
sub hook_dcc_chat {
my($locWho, $message)=@_;
$msgType = "dcc_chat";
my($saveWho) = $who;
$who = "=".$who;
&process($who, $msgType, $message);
$who = $saveWho;
return '';
}
1;

166
src/Misc.pl
Unescape Escape View File

@ -0,0 +1,166 @@
# infobot :: Kevin Lenzo (c) 1997
# with thanks to Patrick Cole
use Socket;
# send info to devnull
sub devnull {
return '';
}
# ask frendly bots
sub askFriendlyBots {
my $request = $_[0];
return if ($request =~ /^no\,?\s+/);
foreach $bot (split /\s+/, $param{'friendlyBots'}) {
$request =~ s/^(is|are) //i;
&msg($bot, ":INFOBOT:QUERY <$who> $request");
}
}
# format a public message
sub FormatText {
my($nick, $msg) = @_;
undef @ret;
undef %str;
my $msgLen = length($msg);
my $nickLen = length($nick);
my $tot = 0;
my $cnt = 0;
foreach (split //, $msg) {
if ($cnt == (80 - $nickLen - 3)) {
$tot++;
$cnt=0;
}
$str{$tot} .= $_;
$cnt++;
}
foreach (keys %str) {
push(@ret, $str{$_}."\n");
}
return @ret;
}
sub status {
$statcount++;
my($input) = @_;
if ($param{'VERBOSITY'} > 0) {
if ($param{ansi_control}) {
printf $_green."[%5d] ".$ob, $statcount;
$input =~ s/[\cA-\c_]//ig; # (Derek Moeller)++
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+>) //) {
my $name = $1;
if ($addressed) {
print "$b_red$name $printable$ob\n";
} else {
print "$b_cyan$name$ob $printable\n";
}
} elsif ($printable =~ s/^(-\S+-) //) {
# notice
print "$_green$1 $printable$ob\n";
} elsif ($printable =~ s/^(\[\S+\]) //) {
# message from someone
print "$b_red$1 $printable$ob\n";
} elsif ($printable =~ s/^(>\S+<) //) {
# i'm messaging someone
print "$b_magenta$1 $printable$ob\n";
} elsif ($printable =~ s/^(!\S+!) //) {
# i'm messaging someone
print "$_red$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 {
printf ("[%5d] $input\n", $statcount) if ($input !~ /^\s*$/);
}
}
&log_line("[$statcount] ".$input);
}
sub performSay {
my($in) = @_;
if (!defined($prevIn)) { $prevIn = ""; };
if (($skipReply == 0) && ($in !~ 'NOREPLY')) {
$prevIn = $in;
if (0) { # for mac speech manager niceties
$in =~ s/ at (ht|f)/ $1/ig;
$in =~ s/((ht|f)tp:\S+)/here [[cmnt $1 ]]/ig;
}
&say($in);
}
# this could echo everything to somewhere
# &msg('somebody', ".say $in");
return '';
}
sub performReply {
if ($msgType eq 'private') {
&msg($who, $_[0]);
} else {
&say("$_[0]");
}
}
sub log_line {
my($line) = @_;
my($logwrite) = 0;
my $s = time();
if ($param{'logfile'} ne '') {
$line =~ s/\n*$/\n/;
open(TRACK, ">>$param{logfile}");
$loglines++;
$total_loglines++;
print TRACK "$s $line";
close(TRACK); # if (TRACK);
}
}
sub getAllKeys {
@myIsKeys = getDBMKeys("is");
@myAreKeys = getDBMKeys("are");
$factoidCount = $#myIsKeys + $#myAreKeys + 2;
$updateCount = 0;
}
sub purifyNick {
my $safeWho = $_[0];
$safeWho =~ s/\*//g;
$safeWho =~ s/\\/\\\\/g;
$safeWho =~ s/\[/\\\[/g;
$safeWho =~ s/\]/\\\]/g;
$safeWho =~ s/\|/\\\|/g;
$safeWho =~ tr/A-Z/a-z/;
$safeWho = substr($safeWho, 0, 9);
$safeWho =~ s/\s+.*//;
return $safeWho;
}
1;
__DATA__
/dimer\[0\/: trailing \ in regexp at /usr/users/infobot/infobot-current/src/Misc.pl line 164, <FH> chunk 98.

99
src/Norm.pl
Unescape Escape View File

@ -0,0 +1,99 @@
# infobot :: Kevin Lenzo (c) 1997
sub normquery {
my ($in) = @_;
$in = " $in ";
# where blah is -> where is blah
$in =~ s/ (where|what|who)\s+(\S+)\s+(is|are) / $1 $3 $2 /i;
# where blah is -> where is blah
$in =~ s/ (where|what|who)\s+(.*)\s+(is|are) / $1 $3 $2 /i;
$in =~ s/^\s*(.*?)\s*/$1/;
$in =~ s/be tellin\'?g?/tell/i;
$in =~ s/ \'?bout/ about/i;
$in =~ s/,? any(hoo?w?|ways?)/ /ig;
$in =~ 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
$in =~ s/th(e|at|is) (((m(o|u)th(a|er) ?)?fuck(in\'?g?)?|hell|heck|(god-?)?damn?(ed)?) ?)+//ig;
$in =~ s/wtf/where/gi;
$in =~ s/this (.*) thingy?/ $1/gi;
$in =~ s/this thingy? (called )?//gi;
$in =~ s/ha(s|ve) (an?y?|some|ne) (idea|clue|guess|seen) /know /ig;
$in =~ s/does (any|ne|some) ?(1|one|body) know //ig;
$in =~ s/do you know //ig;
$in =~ s/can (you|u|((any|ne|some) ?(1|one|body)))( please)? tell (me|us|him|her)//ig;
$in =~ s/where (\S+) can \S+ (a|an|the)?//ig;
$in =~ s/(can|do) (i|you|one|we|he|she) (find|get)( this)?/is/i; # where can i find
$in =~ s/(i|one|we|he|she) can (find|get)/is/gi; # where i can find
$in =~ s/(the )?(address|url) (for|to) //i; # this should be more specific
$in =~ s/(where is )+/where is /ig;
$in =~ s/\s+/ /g;
$in =~ s/^\s+//;
if ($in =~ s/\s*[\/?!]*\?+\s*$//) {
$finalQMark = 1;
}
# $in =~ s/\b(the|an?)\s+/ /i; # handle first article in query
$in =~ s/\s+/ /g;
$in =~ s/^\s*(.*?)\s*$/$1/;
$in;
}
# for be-verbs
sub switchPerson {
my($in) = @_;
my $safeWho;
if ($target) {
$safeWho = &purifyNick($target);
} else {
$safeWho = &purifyNick($who);
}
# $safeWho will cause trouble in nicks with deleted \W's
$in =~ s/(^|\W)${safeWho}s\s+/$1${who}\'s /ig; # fix genitives
$in =~ s/(^|\W)${safeWho}s$/$1${who}\'s/ig; # fix genitives
$in =~ s/(^|\W)${safeWho}\'(\s|$)/$1${who}\'s$2/ig; # fix genitives
$in =~ s/(^|\s)i\'m(\W|$)/$1$who is$2/ig;
$in =~ s/(^|\s)i\'ve(\W|$)/$1$who has$2/ig;
$in =~ s/(^|\s)i have(\W|$)/$1$who has$2/ig;
$in =~ s/(^|\s)i haven\'?t(\W|$)/$1$who has not$2/ig;
$in =~ s/(^|\s)i(\W|$)/$1$who$2/ig;
$in =~ s/ am\b/ is/i;
$in =~ s/\bam /is/i;
$in =~ s/yourself/$param{'ident'}/i if ($addressed);
$in =~ s/(^|\s)(me|myself)(\W|$)/$1$who$3/ig;
$in =~ s/(^|\s)my(\W|$)/$1${who}\'s$2/ig; # turn 'my' into name's
$in =~ s/(^|\W)you\'?re(\W|$)/$1you are$2/ig;
if ($addressed > 0) {
$in =~ s/(^|\W)are you(\W|$)/$1is $param{'nick'}$2/ig;
$in =~ s/(^|\W)you are(\W|$)/$1$param{'nick'} is$2/ig;
$in =~ s/(^|\W)you(\W|$)/$1$param{'nick'}$2/ig;
$in =~ s/(^|\W)your(\W|$)/$1$param{'nick'}\'s$2/ig;
}
$in;
}
# ---
1;

68
src/Params.pl
Unescape Escape View File

@ -0,0 +1,68 @@
# infobot :: Kevin Lenzo (c) 1997
if (!$filesep) {
$filesep = '/';
};
sub loadParamFiles {
my (@files) = @_;
my @result;
my $p;
if (!@files) {
# &status("no param files to load");
return '';
}
foreach $p (@files) {
if ($p !~ /\S/) {
&status("warning: param file name is null");
return '';
}
if (open(PARAM, $p)) {
my $count;
while (<PARAM>) {
chomp;
next if /^\s*\#/;
next unless /\S/;
my ($key, $val) = split(/\s+/, $_, 2);
$val =~ s/\s+$//;
# perform variable interpolation
$val =~ s/(\$(\w+))/$param{$2}/g;
&status("setting $key => $val")
if (exists $param{VERBOSITY} and $param{VERBOSITY} > 2);
$param{$key} = $val;
++$count;
}
&status("loaded param file $p ($count items)");
close(PARAM);
} else {
&status("failed to load param file $p");
}
}
}
sub writeParamFile {
my ($filename) = $_[0];
# write the current parameter set to $filename.
# returns 1 if successful
if (open POUT, ">$filename") {
foreach (sort keys %param) {
print POUT "$_ $param{$_}\n";
}
close POUT;
return 1;
} else {
# couldn't write the file
return 0;
}
}
1;

431
src/Process.pl
Unescape Escape View File

@ -0,0 +1,431 @@
# infobot :: Kevin Lenzo 1997-1999
# process the incoming message
$SIG{'ALRM'} = 'TimerAlarm';
sub process {
($who, $msgType, $message) = @_;
my ($result, $caughtBy);
$origMessage = $message; # intentionally global
return 'SELF' if (lc($who) eq lc($param{'nick'}));
$message =~ s/[\cA-\c_]//ig; # strip control characters
$msgFilter = "NOFILTER"; # 26Jun19100 - Masque
# $msgFilter = $1 if $message =~ s/\s+(?:=~)\s?\/\(\?:(.*?)\)\/i?\s*//;
# STILL doesn't match '=~ /(?:(toot!))/'! Grah. Could make this simpler, but this is fun. 29Jun2K - Masque.
# FIXME
$msgFilter = ($1 || $2) if $message =~ s!\s+(?:=~)?\s?/(?:\((?:\?:)?([^)]*)\)|([^()]*))/i?\s*$!!;
$addressed = 0;
$karma = 0; # 12Apr2k - Masque
return 'ANTIHELP' if $instance =~ /antihelp/;
my ($n, $uh) = ($nuh =~ /^([^!]+)!(.*)/);
if ($param{'VERBOSITY'} > 3) { # murrayb++
&status("Splitting incoming address into $n and $uh");
}
if ($msgType =~ /private/ and $message =~ /^hey, what is/) {
$infobots{$nuh} = $who;
&msg($who, "inter-infobot communication now requires version 0.43 or higher.");
return 'INTERBOT';
}
return 'INTERBOT' if $message =~ /^...but/;
return 'INTERBOT' if $message =~ /^.* already had it that way/;
return 'INTERBOT' if $message =~ /^told /; # reply from friendly infobot
return 'INTERBOT' if $message =~ /^told /; # reply from friendly infobot
return 'INTERBOT' if ($message =~ /^[!\*]/);
return 'INTERBOT' if ($message =~ /^gotcha/i);
# this assumes that the ignore list will be fairly small, as we
# loop through each key rather than doing a straight lookup
# -- this should be moved and made more efficient -- kl
if (&get(ignore => $uh) or &get(ignore => $who)) {
&status("IGNORE <$who> $message");
return 'IGNORE';
}
foreach (&getDBMKeys('ignore')) {
my $ignoreRE = $_;
my @parts = split /\*/, "a${ignoreRE}a";
my $recast = join '\S*', map quotemeta($_), @parts;
$recast =~ s/^a(.*)a$/$1/;
if ($nuh =~ /^$recast$/) {
&status("IGNORE <$who> $message");
return 'IGNORE';
}
}
# -- --
if ($msgType =~ /private/ and $message =~ s/^:INFOBOT://) {
&status("infobot <$nuh> identified") unless $infobots{$nuh};
$infobots{$nuh} = $who;
}
if ($infobots{$nuh}) {
if ($msgType =~ /private/) {
if ($message =~ /^QUERY (<.*?>) (.*)/) {
my $r;
my $target = $1;
my $item = $2;
$item =~ s/[.\?]$//;
&status(":INFOBOT:QUERY $who: $message");
if ($r = &get("is", $item)) {
&msg($who, ":INFOBOT:REPLY $target $item =is=> $r");
}
if ($r = &get("are", $item)) {
&msg($who, ":INFOBOT:REPLY $target $item =are=> $r");
}
} elsif ($message =~ /^REPLY <(.*?)> (.*)/) {
my $r;
my $target = $1;
my $item = $2;
&status(":INFOBOT:REPLY $who: $message");
my ($X, $V, $Y) = $item =~ /^(.*?) =(.*?)=> (.*)/;
if ((getparam('acceptUrl') !~ /REQUIRE/) or ($Y =~ /(http|ftp|mailto|telnet|file):/)) {
&set($V, $X, $Y);
&msg($target, "$who knew: $X $V $Y");
}
}
}
return 'INFOBOT';
}
$VerifWho = &verifyUser($nuh);
if ($VerifWho) {
if (IsFlag("i") eq "i") {
&status("Ignoring $who: $VerifWho");
return 'IGNORED';
}
if ($msgType =~ /private/) {
# it's a private message
my ($potentialPass) = $message =~ /^\s*(\S+)/;
if (exists($verified{$VerifWho})) {
# aging. you need to keep talking to it re-verify
if (time() - $verified{$VerifWho} < 60*60) { # 1 hour decay
$verified{$VerifWho} = $now;
} else {
&status("verification for $VerifWho expired");
delete $verified{$VerifWho};
}
}
if ($uPasswd eq "NONE_NEEDED") {
&status("no password needed for $VerifWho");
$verified{$VerifWho} = $now;
}
if (&ckpasswd($potentialPass, $uPasswd)) {
$message =~ s/^\s*\S+\s*//;
$origMessage =~ s/^\s*\S+\s*/<PASSWORD> /;
&status("password verified for $VerifWho");
$verified{$VerifWho} = $now;
if ($message =~ /^\s*$/) {
&msg($who, "i recognize you there");
return 'PASSWD';
}
}
}
}
# see User.pl for the "special" user commands
return 'NOREPLY' if &userProcessing() eq 'NOREPLY';
if ($msgType !~ /public/) { $addressed = 1; }
if (($message =~ s/^(no,?\s+$param{'nick'},?\s*)//i)
or ($addressed and $message =~ s/^(no,?\s+)//i)) {
# clear initial negative
# an initial negative may signify a correction
$correction_plausible = 1;
&status("correction is plausible, initial negative and nick deleted ($1)") if ($param{VERBOSITY} > 2);
} else {
$correction_plausible = 0;
}
if ($message =~ /^\s*$param{'nick'}\s*\?*$/i) {
&status("feedback addressing from $who");
$addressed = 1;
$blocked = 0;
if ($msgType =~ /public/) {
if (rand() > 0.5) {
&performSay("yes, $who?");
} else {
&performSay("$who?");
}
} else {
&msg($who, "yes?");
}
$lastaddressedby = $who;
$lastaddressedtime = time();
return "FEEDBACK";
}
if (($message =~ /^\s*$param{'nick'}\s*([\,\:\> ]+) */i)
or ($message =~ /^\s*$param{'nick'}\s*-+ *\??/i)) {
# i have been addressed!
my($it) = $&;
if ($' !~ /^\s*is/i) {
$message = $';
$addressed = 1;
$blocked = 0;
}
}
if ($message =~ /, ?$param{nick}(\W+)?$/i) { # i have been addressed!
my($it) = $&;
if ($` !~ /^\s*i?s\s*$/i) {
$xxx = quotemeta($it);
$message =~ s/$xxx//;
$addressed = 1;
$blocked = 0;
}
}
if ($addressed) {
&status("$who is addressing me");
$lastaddressedby = $who;
$lastaddressedtime = time();
if ($message =~ /^showmode/i ) {
if ($msgType =~ /public/) {
if ((getparam('addressing') ne 'REQUIRE') or $addressed) {
&performSay ($who.", addressing is currently ".getparam('addressing'));
}
} else {
&msg($who, "addressing is currently ".getparam('addressing'));
}
return "SHOWMODE";
}
my $channel = &channel();
$continuity = 0;
} else { # apparently not addressed
my ($now, $diff);
if (getparam('continuity') and $who eq $lastaddressedby) {
$now = time();
$diff = $now - $lastaddressedtime;
if ($diff < getparam('continuity')) {
# assume we're talking to the same person even if we're
# not addressed, if we've been addressed in x seconds
&status("assuming continuity of address by $who ($diff seconds elapsed)");
$continuity = 1;
}
} else {
$continuity = 0;
}
}
$skipReply = 0;
$message_input_length = length($message);
# this was here to help stop bots from just triggering
# "confused" messages to each other, but should be done
# more systematically. took it out to cut overhead. --kl
# $confusedRE = join '|', map quotemeta($_), @confused unless defined $confusedRE;
# return 'CONFUSED' if $message =~ /$confusedRE/;
return if ($who eq $param{'nick'});
$message =~ s/^\s+//; # strip any dodgey spaces off
# Half finished thought here - "^Pudge - it's there" looks like math but is
# often nick completion or similar.
# if (($message =~ s/^\S+\s*:\s+//) or ($message =~ s/^\S+\s+--?\s+[.\d]//)) {
if (($message =~ s/^\S+\s*:\s+//) or ($message =~ s/^\S+\s+--+\s+//)) {
# stripped the addressee ("^Pudge: it's there")
$reallyTalkingTo = $1;
} else {
$reallyTalkingTo = '';
if ($addressed) {
$reallyTalkingTo = $param{'nick'};
}
}
$message =~ s/^\s*hey,*\s+where/where/i;
$message =~ s/whois/who is/ig;
$message =~ s/where can i find/where is/i;
$message =~ s/how about/where is/i;
$message =~ s/^(gee|boy|golly|gosh),? //i;
$message =~ s/^(well|and|but|or|yes),? //i;
$message =~ s/^(does )?(any|ne)(1|one|body) know //i;
$message =~ s/ da / the /ig;
$message =~ s/^heya*,*( folks)?,*\.* *//i; # clear initial filled pauses & stuff
$message =~ s/^[uh]+m*[,\.]* +//i;
$message =~ s/^o+[hk]+(a+y+)?,*\.* +//i;
$message =~ s/^g(eez|osh|olly)+,*\.* +(.+)/$2/i;
$message =~ s/^w(ow|hee|o+ho+)+,*\.* +(.+)/$2/i;
$message =~ s/^still,* +//i;
$message =~ s/^well,* +//i;
$message =~ s/^\s*(stupid )?q(uestion)?:\s+//i;
my $holdMessage = $message;
# the thing to tell someone about ($tell_obj). Yes i know these are evil globals. --kl
($tell_obj, $target) = (undef,undef,undef);
# i'm telling!
if (getparam('allowTelling')) {
# this one catches most of them
if ($message =~ /^tell\s+(\S+)\s+about\s+(.*)/i) {
($target, $tell_obj) = ($1, $2);
} elsif ($message =~ /tell\s+(\S+)\s+where\s+(\S+)\s+can\s+(\S+)\s+(.*)/i) {
# i'm sure this could all be nicely collapsed
($target, $tell_obj) = ($1, $4);
} elsif ($message =~ /tell\s+(\S+)\s+(what|where)\s+(.*?)\s+(is|are)[.?!]*$/i) {
($target, $qWord, $tell_obj, $verb) = ($1, $2, $3, $4);
$tell_obj = "$qWord $verb $tell_obj";
}
if (($target =~/^\s*[\&\#]/) or ($target =~ /\,/)) {
$result = "No, ".$who.", i won\'t";
$target = $who;
$caughtBy = "tell";
}
if ($target eq $param{'nick'}) {
$result = "Isn\'t that a bit silly, ".$who."?";
$target = $who;
$caughtBy = "tell";
}
$tell_obj =~ s/[\.\?!]+$// if defined $tell_obj;
}
if (not defined $result) {
$target = $who unless defined $target;
$target = $who if $target eq 'me';
$target = undef if $target eq 'us';
# here's where the external routines get called.
# if they return anything but null, that's the "answer".
$message = $tell_obj if $tell_obj;
if ($continuity or $addressed or
(getparam('addressing') ne "REQUIRE")) {
if (defined ($result = &myRoutines())) {
$caughtBy = "myRoutines";
} elsif (defined($result = &Extras())) {
$caughtBy = "Extras";
# BEEP BEEP - TODO ALERT: Change the karma lookup to do a doQuestion
# before returning a karma query to catch factoids that should return
# instead of reporting karma. Assigned to boojum at the moment.
} elsif (defined($result = &doQuestion($msgType, $message, $msgFilter))) {
$caughtBy = "Question";
}
if (($result eq 'NOREPLY') or ($who eq 'NOREPLY')) {
return '';
}
# This fixes the problem of short karma strings (masque++ for
# example) being ignored. -- Masque, 12Apr2K
if ($message =~ /(?:\+\+|--)/) { $karma = 1; }
if (!$finalQMark and !$addressed and !$tell_obj and
!$karma and
($input_message_length < getparam('minVolunteerLength'))) {
$in = '';
return 'NOREPLY';
}
}
if ($caughtBy) {
if ($tell_obj) {
$message = $tell_obj;
&status("$caughtBy: <$who>->$target< [$message] -> $result");
} else {
&status("$caughtBy: <$who> $message");
}
$questionCount++;
}
}
if (defined $result) {
if ($msgType =~ /public/) {
if ($target eq $who) {
&performSay($result) if ($result and not $blocked);
} else {
my $r = "$who wants you to know: $result";
&msg($target, $r);
if ($who ne $target) {
&msg($who, "told $target about $tell_obj ($r)");
}
return 'NOREPLY';
}
} else { # not public
if ($who eq $target) { # to self
&msg($who, $result);
} else { # to someone else
my $r;
if (lc($who) eq lc($target)) {
&msg($target, $result);
} else {
$r = "$who wants you to know: $result";
&msg($target, $r);
&msg($who, "told $target about $tell_obj ($r)");
}
}
}
} else { # not $caughtBy
return "No authorization to teach" unless (IsFlag("t") eq "t");
if (!getparam('allowUpdate')) {
return '';
}
$result = &doStatement($msgType, $holdMessage);
if (($who eq 'NOREPLY')||($result eq 'NOREPLY')) { return ''; };
return 'NOREPLY' if grep $_ eq $who, split /\s+/, $param{friendlyBots};
if (defined $result) {
$caughtBy = "Statement";
if ($msgType =~ /public/) {
&say("OK, $who.") if $addressed;
} else {
&msg($who, "gotcha.");
}
}
}
if ($addressed and not $caughtBy) {
# &status("unparseable: $message");
if ($msgType =~ /public/) {
&say("$who: ".$confused[int(rand(@confused))]) if $addressed;
} else {
&msg($who, $confused[int(rand(@confused))]);
}
return "NOPARSE";
}
}
1;

134
src/Question.pl
Unescape Escape View File

@ -0,0 +1,134 @@
# infobot :: Kevin Lenzo (c) 1997
##
## doQuestion --
##
## decide if $in is a query, and if so, return its value.
## otherwise return null.
##
sub doQuestion {
local ($msgType, $qmsg, $msgFilter) = @_;
chomp $qmsg;
$finalQMark = $qmsg =~ s/\?+\s*$//;
$questionWord = ""; # this is shared for a reason
$input_message_length = length($qmsg);
my($locWho) = $who;
$locWho =~ tr/A-Z/a-z/;
$locWho =~ s/^=//;
my ($origIn) = $qmsg;
$finalQMark += $qmsg =~ s/\?\s*$//;
# convert to canonical reference form
$qmsg = &normquery($qmsg);
$qmsg = &switchPerson($qmsg);
# where is x at?
$qmsg =~ s/\s+at\s*(\?*)$/$1/;
$qmsg = " $qmsg ";
my $qregex = join '|', @qWord;
# what's whats => what is; who'?s => who is, etc
$qmsg =~ s/ ($qregex)\'?s / $1 is /i;
if ($qmsg =~ s/\s+($qregex)\s+//i) { # check for question word
$questionWord = lc($1);
}
$qmsg =~ s/^\s+//;
$qmsg =~ s/\s+$//;
if (($questionWord eq "") && ($finalQMark > 0)
&& ($addressed or $continuity)) {
$questionWord = "where";
}
# ok, here's where we try to actually get it
$answer = &getReply($msgType, $qmsg, $msgFilter);
return 'NOREPLY' if ($answer eq 'NOREPLY');
if (($param{'addressing'} eq 'REQUIRE') && not ($addressed or $continuity)) {
return 'NOREPLY';
}
if (not defined $answer) {
$answer = &math($qmsg); # clean up the argument syntax for this later
}
if ($questionWord ne "" or $finalQMark) {
# if it has not been explicitly marked as a question
if ($addressed && (not defined $answer)) {
# and we're addressed and so far the result is null
&status("notfound: <$who> $origIn :: $qmsg");
return 'NOREPLY' if $infobots{$nuh};
my $reply;
# generate some random i-don't-know reply.
if ($target ne $who and $target ne $talkchannel) {
$target = $who; # set the target back to the originator
$reply = "I don't know about '$qmsg'";
} else {
$reply = $dunno[int(rand(@dunno))];
}
if (rand() > 0.5) {
$reply = "$locWho: $reply";
} else {
$reply = "$reply, $locWho";
}
&askFriendlyBots($qmsg);
# and set the result
$answer = $reply;
} else {
# the item was found
if ($answer ne "") {
&status("match: $qmsg => $answer");
}
}
}
return $answer;
}
sub timeToString {
my $upTime = $_[0];
$upTime = (time()-$startTime);
my $upDays = int($upTime / (60*60*24));
my $upString = "";
if ($upDays > 0) {
$upString .= $upDays." day";
$upString .= "s" if ($upDays > 1);
$upString .=", ";
}
$upTime -= $upDays * 60*60*24;
my $upHours = int($upTime / (60*60));
if ($upHours > 0) {
$upString .= $upHours." hour";
$upString .= "s" if ($upHours > 1);
$upString .=", ";
}
$upTime -= $upHours *60*60;
my $upMinutes = int($upTime / 60);
if ($upMinutes > 0) {
$upString .= $upMinutes." minute";
$upString .= "s" if ($upMinutes > 1);
$upString .=", ";
}
$upTime -= $upMinutes * 60;
my $upSeconds = $upTime;
$upString .= $upSeconds." second";
$upString .= "s" if ($upSeconds != 1);
$upString;
}
1;

336
src/Reply.pl
Unescape Escape View File

@ -0,0 +1,336 @@
# infobot :: Kevin Lenzo (c) 1997
sub getReply {
my($msgType, $message, $msgFilter) = @_;
my($theMsg) = "";
my($locMsg) = $message;
# x is y
# x is the lhs (left hand side)
# 'is' is the mhs ("middle hand side".. the "head", or verb)
# y is the Y (right hand side)
my($X, $V, $Y, $result);
my ($theVerb, $orig_Y);
$locMsg =~ tr/A-Z/a-z/;
my $literal = ($locMsg =~ s/^literal //);
if (getparam('rss') and $message =~ m/^perlfaq\'\s+(.*?)\?*$/) {
# specially defined type. get and process an RSS (RDF Site Summary)
eval "use URI::Escape";
not ($@) and do {
my $q = uri_escape($1, '\W');
my $result = &get_headlines("http://www.perlfaq.com/cgi-bin/rss/kw?q=$q");
if ($result =~ s/^error: //) {
return "$who: couldn't get the perlfaq: $result";
} else {
return "$who: $result";
}
}
} elsif ($result = get("is", $locMsg)) {
# &status("exact: $message =is=> $result");
$theVerb = "is";
$X = $message;
$V = $theVerb;
$Y = $result;
$orig_Y = $X;
} elsif ($result = get("are", $locMsg)) {
# &status("exact: $message =is=> $result");
$theVerb = "are";
$X = $message;
$V = $theVerb;
$Y = $result;
$orig_Y = $X;
} else { # no verb
$y_determiner = '';
$verbs = join '|', @verb;
$message = " $message ";
if ($message =~ / ($verbs) /i) {
$X = $`;
$V = $1;
$Y = $';
$X =~ s/^\s*(.*?)\s*$/$1/;
$Y =~ s/^\s*(.*?)\s*$/$1/;
$orig_Y = $Y;
$Y =~ tr/A-Z/a-z/;
$V =~ s/^\s*(.*?)\s*$/$1/;
if ($Y =~ s/^(an?|the)\s+//) {
$y_determiner = $1;
} else {
$y_determiner = '';
}
if ($questionWord !~ /^\s*$/) {
if ($V eq "is") {
$result = &get("is", $Y);
} else {
if ($V eq "are") {
$result = &get("are", $Y);
}
}
}
$theVerb = $V;
}
if ($param{'VERBOSITY'} > 1) {
my $debugstring = "\tmsgType:\t$msgType\n";
$debugstring .= "\tquestionWord:\t$questionWord\n";
$debugstring .= "\taddressed:\t$addressed\n";
$debugstring .= "\tfinalQMark:\t$finalQMark\n";
$debugstring .= "\tX[$X] verb[$theVerb] det[$y_determiner] Y[$Y]\n";
$debugstring .= "\tresult:\t$result\n";
&status($debugstring);
}
if ($y_determiner) {
# put the det back on
$Y = "$y_determiner $Y";
}
# check "is" tables anyway for lhs alone
if (!defined($V)) { # no explicit head had been found
my $det;
if ($locMsg =~ s/^\s*(an?|the)\s+//) {
$det = $1;
}
$locMsg =~ s/[.!?]+\s*$//;
my($check) = "";
$check = &get("is", $locMsg);
if ($check ne "") {
$result = $check;
$orig_Y = $locMsg;
$theVerb = "is";
$V = "is"; # artificially set the head to is
} else {
$check = &get("are", $locMsg);
if ($check ne "") {
$result = $check;
$V = "are"; # artificially set the head to are
$orig_Y = $locMsg;
$theVerb = "are";
}
}
if ($det) {
$orig_Y = "$det $orig_Y";
}
}
}
if ($V ne "") { # if there was a head...
if (not $literal) { # Changed to cope with $msgFilter - 26Jun19100, Masque
my(@poss) = split(/(?<!\\)\|/, $result);
$poss[0] =~ s/^\s//;
$poss[$#poss] =~ s/\s$//;
my @filtered = grep /\Q$msgFilter\E/, @poss unless $msgFilter eq "NOFILTER";
if (@filtered) {
$theMsg = $filtered[int(rand(@filtered))];
$theMsg =~ s/^\s*//;
} elsif (@poss > 1 && $msgFilter eq "NOFILTER") {
$theMsg = $poss[int(rand(@poss))];
$theMsg =~ s/^\s*//;
} else {
if ($msgFilter eq "NOFILTER" || $result =~ /\Q$msgFilter\E/) {
$theMsg = $result;
} else {
$theMsg = q!<reply>Hmm. No matches for that, $who.!;
}
}
$theMsg =~ s/\\\|/\|/g;
} else {
$theMsg = $result;
}
}
$skipReply = 0;
if ($theMsg ne "") {
if ($msgType =~ /public/) {
my $interval = time() - $prevTime;
if ( ($param{'mode'} eq 'IRC' )
&& getparam('repeatIgnoreInterval')
&& ($theMsg eq $prevMsg)
&& ((time()-$prevTime) < getparam('repeatIgnoreInterval'))) {
&status("repeat ignored ($interval secs < ".getparam('repeatIgnoreInterval').")");
$skipReply = 1;
$theMsg = "NOREPLY";
$prevTime = time();
} else {
$skipReply = 0;
$prevTime = time() unless ($theMsg eq $prevMsg);
$prevMsg = $theMsg;
}
}
# by now $theMsg should contain the result, or null
# this global is nto a great idea
$shortReply = 0;
$noReply = 0;
if (0 and $theMsg =~ s/^\s*<noreply>\s*//i) {
# specially defined type. No reply. Experimental.
$noReply = 1;
return 'NOREPLY';
}
if (!$msgType) {
$msgType = 'private';
&status("NO MSG TYPE / set to private\n");
}
if ($literal) {
$orig_Y =~ s/^literal //;
$theMsg = "$who: $orig_Y =$theVerb= $theMsg";
return $theMsg;
}
if ($msgType !~ /private/ and $theMsg =~ s/^\s*<reply>\s*//i) {
# specially defined type. only remove '<reply>'
$shortReply = 1;
} elsif (getparam('rss') and $theMsg =~ m/(<(?:rss|rdf)\s*=\s*(\S+)>)/i) {
# specially defined type. get and process an RSS (RDF Site Summary)
my ($replace, $rdf_loc) = ($1,$2);
$shortReply = 1;
$rdf_loc =~ s/^\"+//;
$rdf_loc =~ s/\"+$//;
if ($rdf_loc !~ /^(ht|f)tp:/) {
&msg($who, "$orig_Y: bad RSS [$rdf_loc] (not an HTTP or FTP location)");
} else {
my $result = &get_headlines($rdf_loc);
if ($result =~ s/^error: //) {
$theMsg = "couldn't get the headlines: $result";
} else {
$theMsg =~ s/\Q$replace\E/$result/;
$theMsg = "$who: $theMsg";
}
}
} elsif ($msgType !~ /private/ and
$theMsg =~ s/^\s*<action>\s*(.*)/\cAACTION $1\cA/i) {
# specially defined type. only remove '<action>' and make it an action
$shortReply = 1;
} else { # not a short reply
if (!$infobots{$nuh} and $theVerb =~ /is/) {
my($x) = int(rand(16));
# oh this could be done much better
if ($x <= 5) {
$theMsg= "$orig_Y is $theMsg";
}
if ($x == 6) {
$theMsg= "i think $orig_Y is $theMsg";
}
if ($x == 7) {
$theMsg= "hmmm... $orig_Y is $theMsg";
}
if ($x == 8) {
$theMsg= "it has been said that $orig_Y is $theMsg";
}
if ($x == 9) {
$theMsg= "$orig_Y is probably $theMsg";
}
if ($x == 10) {
$theMsg =~ s/[.!?]+$//;
$theMsg= "rumour has it $orig_Y is $theMsg";
# $theMsg .= " dumbass";
}
if ($x == 11) {
$theMsg= "i heard $orig_Y was $theMsg";
}
if ($x == 12) {
$theMsg= "somebody said $orig_Y was $theMsg";
}
if ($x == 13) {
$theMsg= "i guess $orig_Y is $theMsg";
}
if ($x == 14) {
$theMsg= "well, $orig_Y is $theMsg";
}
if ($x == 15) {
$theMsg =~ s/[.!?]+$//;
$theMsg= "$orig_Y is, like, $theMsg";
}
} else {
$theMsg = "$orig_Y $theVerb $theMsg" if ($theMsg !~ /^\s*$/);
}
}
}
my $safeWho = &purifyNick($who);
if (!$shortReply) {
# shouldn't this be in switchPerson?
# this is fixing the person for going back out
# /^onz!lenzo@lenzo.pc.cs.cmu.edu privmsg rurl :*** noctcp: omega42 is/: nested *?+ in regexp at /usr/users/infobot/infobot-current/src/Reply.pl line 266, <FH> chunk 176.
if ($theMsg =~ s/^$safeWho is/you are/i) { # fix the person
} else {
$theMsg =~ s/^$param{'nick'} is /i am /ig;
$theMsg =~ s/ $param{'nick'} is / i am /ig;
$theMsg =~ s/^$param{'nick'} was /i was /ig;
$theMsg =~ s/ $param{'nick'} was / i was /ig;
if ($addressed) {
$theMsg =~ s/^you are (\.*)/i am $1/ig;
$theMsg =~ s/ you are (\.*)/ i am $1/ig;
} else {
if ($theMsg =~ /^you are / or $theMsg =~ / you are /) {
$theMsg = 'NOREPLY';
}
}
}
$theMsg =~ s/ $param{'ident'}\'?s / my /ig;
$theMsg =~ s/^$safeWho\'?s /$safeWho, your /i;
$theMsg =~ s/ $safeWho\'?s / your /ig;
}
if (1) { # $date, $time
$curDate = scalar(localtime());
chomp $curDate;
$curDate =~ s/\:\d+(\s+\w+)\s+\d+$/$1/;
$theMsg =~ s/\$date/$curDate/gi;
$curDate =~ s/\w+\s+\w+\s+\d+\s+//;
$theMsg =~ s/\$time/$curDate/gi;
}
$theMsg =~ s/\$who/$who/gi;
if (1) { # variables. like $me or \me
$theMsg =~ s/(\\){1,}([^\s\\]+)/$1/g;
}
$theMsg =~ s/^\s*//;
$theMsg =~ s/\s+$//;
if (getparam('filter')) {
require "src/filter.pl";
$theMsg = &filter($theMsg);
}
if ($theMsg =~ /\S/) {
return $theMsg;
} else {
return undef;
}
}
1;

89
src/Search.pl
Unescape Escape View File

@ -0,0 +1,89 @@
# infobot copyright kevin lenzo 1997-1999
sub search {
return '' unless $addressed;
my $pattern = shift ;
$pattern =~ s/^\s*(search|scan)(\s+for)?\s+//i;
my $type = lc($1);
my $bail_thresh = 5;
if ($pattern =~ s/^\d+ //) {
$bail_thresh = $&;
} else {
if ($type eq 'scan') {
$bail_thresh = 1;
}
}
$pattern =~ s/\?+\s*$//; # final ? marks
return '' if ($pattern =~ /^\s*$/);
my $minlength = 3;
return "that pattern's too short. try something with at least $minlength characters."
if (length($pattern) < $minlength);
&msg($who,"Looking for $pattern:");
my (@response);
my (@myIsKeys) = getDBMKeys("is");
my $t = time();
my $count = 0;
foreach (@myIsKeys) {
if (/$pattern/) {
$r = &get("is", $_);
} else {
next ;
}
my $t1 = time();
if ($t1-$t < 2) {
sleep 2;
}
&msg($who, "$_ is $r");
$t = $t1;
last if ++$count >= $bail_thresh;
}
my $last;
if ($count < $bail_thresh) {
my (@myAreKeys) = getDBMKeys("are");
foreach (@myAreKeys) {
if (/$pattern/) {
$r = &get("are", $_);
} else {
next ;
}
my $t1 = time();
if ($t1-$t < 2) {
sleep 2;
}
$t = $t1;
&msg($who, "$_ are $r");
last if ++$count >= $bail_thresh;
}
$last = 1;
}
if (!$count) {
&msg($who, "nothing found for $pattern");
} else {
my $reply = " ...showing $count hits";
if ($last) {
$reply .= " (all shown).";
} else {
$reply .= " (more may exist).";
}
&msg($who, $reply);
}
return '';
}
1;

159
src/Setup.pl
Unescape Escape View File

@ -0,0 +1,159 @@
# infobot :: Kevin Lenzo (c) 1997-2000
sub setup {
# param setup should stay after most of the requires
# so that it overrides anything they might set.
&paramSetup();
if ($param{VERBOSITY} > 1) {
my $params = "Parameters are:\n";
foreach (sort keys %param) {
$params .= " $_ -> $param{$_}\n";
}
&status($params);
}
die "dbname is null" if (!$param{'dbname'});
%dbs = ("is" => "$param{basedir}/$param{dbname}-is",
"are" => "$param{basedir}/$param{dbname}-are");
srand();
$setup_time = scalar(localtime());
$setup_time =~ s/\n//g;
$startTime = time();
&setup_help;
&openDBM(%dbs);
$qCount = &get("is", "the qCount");
$qEpochTime = &get("is", "the qEpochTime");
# things to say when people thank me
@welcomes = ('no problem', 'my pleasure', 'sure thing',
'no worries', 'de nada', 'de rien', 'bitte', 'pas de quoi');
# when i'm cofused and I have to reply
@confused = ("huh?",
"what?",
"sorry...",
"i\'m not following you...",
"excuse me?");
# when i recognize a query but can't answer it
@dunno = ('i don\'t know',
'wish i knew',
'i haven\'t a clue',
'no idea',
'bugger all, i dunno');
# check the ignore parameter for a filename containing the
# ignore list
if ($param{ignore}) {
&openDBMx('ignore');
}
if ($param{sanePrefix}) {
for $d (qw/is are/) {
my $dbname = $DBprefix.$d;
my $sane = "$param{confdir}/$param{sanePrefix}";
$sane .= "-$d.txt";
if (-e $sane) {
&status("loading sane defines $sane");
&insertFile($dbname, $sane);
} else {
&status("can't fine sane file $sane");
}
}
if (! open IGNORE, "$param{'confdir'}/$param{sanePrefix}-ignore.txt") {
&status("No fallback ignore file $param{'confdir'}/$param{sanePrefix}-ignore.txt");
} else {
while (<IGNORE>) {
s/^\s+//;
s/\s+\#.*//;
chomp;
/\S/ && do {
&postInc(ignore => $_);
if ($param{'VERBOSITY'} > 0) {
&status("Adding $_ to ignore list (from sane).");
}
};
}
close IGNORE;
}
}
if ($param{'plusplus'}) {
&openDBMx('plusplus');
}
if ($param{'seen'}) {
&openDBMx('seen');
}
# set up the users and ops
&status("Parsing User File");
&parseUserfile();
&status("Parsing Channel File");
# set up the channel file
&parseChannelfile();
# ways to say hello
@hello = ('hello',
'hi',
'hey',
'niihau',
'bonjour',
'hola',
'salut',
'que tal',
'privet',
"what's up");
$param{'maxKeySize'} ||= 30; # maximum LHS length
$param{'maxDataSize'} ||= 200; # maximum total length
if (!(@verb)) {
@verb = split(" ", "is are");
# am was were does has can wants needs feels
# handle s-v agreement for non-being verbs later
}
if (!(@qWord)) {
@qWord = split(" ", "what where who"); # why how when
}
# do this ONCE per startup to amortize. Still too much mem.
#&getAllKeys;
$isCount = &getDBMKeys('is');
$areCount = &getDBMKeys('are');
$factoidCount = $isCount + $areCount;
&status("setup: $factoidCount factoids; $isCount IS; $areCount ARE");
}
sub paramSetup {
my $initdebug = 1;
$param{'DEBUG'} = $initdebug;
if (!@paramfiles) {
# if there is no list of param files, just go for the default
# (usually ./files/infobot.config)
@paramfiles = ("$param{confdir}/infobot.config");
}
# now read in the parameter files
&loadParamFiles(@paramfiles);
}
1;

218
src/Statement.pl
Unescape Escape View File

@ -0,0 +1,218 @@
# infobot :: Kevin Lenzo (c) 1997
##
## doStatement --
##
## decide if $in is a statement, and if so,
## - update the dbm
## - return feedback statement
##
## otherwise return null.
##
sub doStatement {
return '' if (lc($who) eq lc($param{'nick'}));
my($msgType, $in) = @_;
$in =~ s/\\(\S+)/\#$1\#/g;
# switch person
$in =~ s/(^|\s)i am /$1$who is /i;
$in =~ s/(^|\s)my /$1$who\'s /ig;
$in =~ s/(^|\s)your /$1$param{'ident'}\'s /ig;
if ($addressed) {
$in =~ s/(^|\s)you are /$1$param{'ident'} is /i;
}
$in =~ s/^no,\s+//i; # don't want to complain if it's new but negative
if (getparam('plusplus')) {
$in =~ s/\W(--|\+\+)(\(.*?\)|[^(++)(--)\s]+)/$2$1/;
# Hacked to allow multiple karma per line and to fix
# related issues. foo++foo++ no longer becomes
# foofoo++++. - Masque, 12Apr2K
# ...and to allow only one karma point per item
# per line. - Masque, 13Apr2K
my %k_limit;
while ($in =~ s/(\(.*?\)|[^(++)(--)\s]+)(\+\+|--)//) {
my($term,$inc) = ($1,$2);
$term = lc($term);
next if exists $k_limit{$term};
$k_limit{$term} = 1;
# try to normalize phrases
$term =~ s/^\((.*)\)$/$1/;
$term =~ s/\s+/ /g;
if ($msgType !~ /public/i) {
&msg($who, "karma must be done in public!");
return "NOREPLY";
}
if (lc($term) eq lc($who)) {
&msg($who, "please don't karma yourself");
return 'NOREPLY';
}
# Whoops! Better make sure that we're adding karma to something existant.
next if $term eq "";
if ($inc eq '++') {
&postInc(plusplus => $term);
} elsif ($inc eq '--') {
&postDec(plusplus => $term);
}
}
return 'NOREPLY' if $karma;
}
my($theType);
my($lhs, $mhs, $rhs); # left hand side, uh.. middlehand side...
# the unignore hack...
# if we see this word, unignore all
my $magicword=getparam('unignoreWord');
if ($in =~ /$magicword/i) {
&clearAll('ignore');
&status("unignoring all ($who said the word)");
}
# check if we need to be addressed and if we are
if ((getparam('addressing') eq 'REQUIRE') && !$addressed) {
return 'NOREPLY';
}
# prefix www with http:// and ftp with ftp://
$in =~ s/ www\./ http:\/\/www\./ig;
$in =~ s/ ftp\./ ftp:\/\/ftp\./ig;
# look for a "type nugget". this should be externalized.
$theType = "";
$theType = "mailto" if ($in =~ /\bmailto:.+\@.+\..{2,}/i);
$theType = "mailto" if ($in =~ s/\b(\S+\@\S+\.\S{2,})/mailto:$1/gi);
$in =~ s/(mailto:)+/mailto:/g;
$theType = "about" if ($in =~ /\babout:/i);
$theType = 'afp' if ($in =~ /\bafp:/);
$theType = 'file' if ($in =~ /\bfile:/);
$theType = 'palace' if ($in =~ /\bpalace:/);
$theType = 'phoneto' if ($in =~ /\bphone(to)?:/);
if ($in =~ /\b(news|http|ftp|gopher|telnet):\s*\/\/[\-\w]+(\.[\-\w]+)+/) {
$theType = $1;
}
# here's where you set the behaviour.
if ((getparam('acceptUrl') =~ /\d+/) && $addressed
&& (getparam('acceptUrl') < $theUserLevel)) {
} else {
if (getparam('acceptUrl') eq 'REQUIRE') {
# require url type.
# &status("REJECTED non-URL entry") if ($param{VERBOSITY});
return 'NOREPLY' if ($theType eq "");
} elsif (getparam('acceptUrl') eq 'REJECT') {
&status("REJECTED URL entry") if ($param{VERBOSITY});
return 'NOREPLY' unless ($theType eq "");
} else {
# OPTIONAL
# you could put another filter here
}
}
# report status somewhere is we're doing that
&status("type $theType: $in") if $theType;
foreach $item (@verb) { # check for verb
if ($in =~ /(^|\s)$item(\s|$)/i) {
($lhs, $mhs, $rhs) = ($`, $&, $');
$lhs =~ tr/A-Z/a-z/;
$lhs =~ s/^\s*(the|da|an?)\s+//i; # discard article
$lhs =~ s/^\s*(.*?)\s*$/$1/;
$mhs =~ s/^\s*(.*?)\s*$/$1/;
$rhs =~ s/^\s*(.*?)\s*$/$1/;
# note : prevent access to globals in the eval
return '' unless ($lhs and $rhs);
my $maxkey = getparam("maxKeySize");
return "The key is too long (> $maxkey chars)."
if (length($lhs) > $maxkey);
if (length($message) > getparam('maxDataSize')) {
if ($msgType =~ /public/) {
if ($addressed) {
if (rand() > 0.5) {
&performSay("that entry is too long, ".$who);
} else {
&performSay("i'm sorry, but that entry is too long, $who");
}
}
} else {
&msg($who, "The text is too long");
}
return '';
}
return 'NOREPLY' if ($lhs eq 'NOREPLY');
my $failed = 0;
$lhs =~ /^(who|what|when|where|why|how)$/ and $failed++;
if (!$failed and !$addressed) {
# the arsenal of things to ignore if we aren't addressed directly
$lhs =~ /^(who|what|when|where|why|how|it) /i and $failed++;
$lhs =~ /^(this|that|these|those|they|you) /i and $failed++;
$lhs =~ /^(every(one|body)|we) /i and $failed++;
$lhs =~ /^\s*\*/ and $failed++; # server message
$lhs =~ /^\s*<+[-=]+/ and $failed++; # <--- arrows
$lhs =~ /^[\[<\(]\w+[\]>\)]/ and $failed++; # [nick] from bots
$lhs =~ /^heya?,? / and $failed++; # greetings
$lhs =~ /^\s*th(is|at|ere|ese|ose|ey)/i and $failed++; # contextless
$lhs =~ /^\s*it\'?s?\W/i and $failed++; # contextless clitic
$lhs =~ /^\s*if /i and $failed++; # hypothetical
$lhs =~ /^\s*how\W/i and $failed++; # too much trouble for now
$lhs =~ /^\s*why\W/i and $failed++; # too much trouble for now
$lhs =~ /^\s*h(is|er) /i and $failed++; # her name is
$lhs =~ /^\s*\D[\d\w]*\.{2,}/ and $failed++; # x...
$lhs =~ /^\s*so is/i and $failed++; # so is (no referent)
$lhs =~ /^\s*s+o+r+[ye]+\b/i and $failed++; # sorry
$lhs =~ /^\s*supposedly/i and $failed++;
$lhs =~ /^all / and $failed++; # all you have to do, all you guys...
} elsif (!$failed and $addressed) {
# things to skip if we ARE addressed
}
if ($failed) {
&status("statement: IGNORED <$who> $message");
return 'NOREPLY';
}
&status("statement: <$who> $message");
$lhs =~ s/\#(\S+)\#/$1/g;
# Avi++
$rhs =~ s/\#\|\#/\\\|/g;
$rhs =~ s/\#(\S+)\#/$1/g;
$lhs =~ s/\?+\s*$//; # strip the ? off the key
$lhs = &update($lhs, $mhs, $rhs);
return 'NOREPLY' if ($lhs eq 'NOREPLY');
last;
}
}
$lhs;
}
1;

179
src/Update.pl
Unescape Escape View File

@ -0,0 +1,179 @@
# infobot :: Kevin Lenzo (c) 1997
sub update {
my($lhs, $verb, $rhs) = @_;
my($reply) = $lhs;
$lhs =~ s/^\s*=?//; # handle dcc =oznoid and stuff
$lhs =~ s/^i (heard|think) //i;
$lhs =~ s/^some(one|1|body) said //i;
$lhs =~ s/ +/ /g;
# this really needs cleaning up
if ($verb eq "is") {
$also = ($rhs =~ s/^also //i);
my $also_or = ($also and $rhs =~ s/\s*\|\s*//);
if ($exists = &get("is", $lhs)) {
chomp $exists;
if ($exists eq $rhs and not $main::googling) {
if ($msgType =~ /public/) {
&performSay("i already had it that way, $who.");
} else {
&msg($who, "it already was $rhs");
}
return 'NOREPLY';
}
$skipReply = 0;
if ($also) {
if ($also_or) {
$rhs = $exists . '|'.$rhs;
} else {
if ($exists ne $rhs) {
$rhs = $exists .' or '.$rhs;
}
}
if (length($rhs) > getparam('maxDataSize')) {
if ($msgType =~ /public/) {
if ($addressed) {
if (rand() > 0.5) {
&performSay("that is too long, ".$who);
} else {
&performSay("i'm sorry, but that's too long, $who");
}
}
} else {
&msg($who, "The text is too long");
}
return 'NOREPLY';
}
if ($msgType =~ /public/) {
&performSay("okay, $who.");
} else {
&msg($who, "okay.");
}
$updateCount++;
&status("update: <$who> \'$lhs =is=> $rhs\'; was \'$exists\'");
&set("is", $lhs, $rhs);
} else { # not "also"
if (($correction_plausible == 0) && ($exists ne $rhs)) {
if ($addressed) {
if (not $main::googling) {
if ($msgType =~ /public/) {
&performSay("...but $lhs is $exists...");
} else {
&msg($who, "...but $lhs is $exists..");
}
&status("FAILED update: <$who> \'$lhs =$verb=> $rhs\'");
}
} else {
&status("FAILED update: <$who> \'$lhs =$verb=> $rhs\' (not addressed, no reply)");
# we were not addressed, so just
# ignore it.
return 'NOREPLY';
}
} else {
if (IsFlag("m") ne "m") {
performReply("You have no access to change factoids");
return 'NOREPLY';
}
if ($msgType =~ /public/) {
&performSay("okay, $who.");
} else {
&msg($who, "okay.");
}
$updateCount++;
&status("update: <$who> '$lhs =is=> $rhs\'; was \'$exists\'");
&set("is", $lhs, $rhs);
}
}
$reply = 'NOREPLY';
} else {
&status("enter: <$who> $lhs =$verb=> $rhs");
$updateCount++; $factoidCount++;
if ($factoidCount == 31337) { # particular count
$mySaveChannel = &channel();
&say("That would be factoid $factoidCount given on $mySaveChannel by $who.");
&status("FACTOID NUMBER $factoidCount on channel $mySaveChannel by $who.");
&say("woohoo!");
&channel($mySaveChannel);
}
&set("is", $lhs, $rhs);
$is{"theCount"}++;
}
} else { # 'is' failed
if ($verb eq "are") {
$also = ($rhs =~ s/^also //i);
if ($exists = &get("are", $lhs)) {
if ($also) {
if ($exists ne $rhs) {
$rhs = $exists .' or '.$rhs;
}
if ($msgType =~ /public/) {
&performSay("okay, $who.") unless $rhs eq $exists;
} else {
&msg($who, "okay.");
}
$updateCount++;
&status("update: <$who> \'$lhs =are=> $rhs\'; was \'$exists\'");
&set("are", $lhs, $rhs);
} else { # not 'also'
if (($correction_plausible == 0) && ($exists ne $rhs)) {
if ($addressed) {
&status("FAILED update: \'$lhs =$verb=> $rhs\'");
if ($msgType =~ /public/) {
&performSay("...but $lhs is $exists...");
} else {
&msg($who, "...but $lhs is $exists..");
}
} else {
&status("FAILED update: $lhs $verb $rhs (not addressed, no reply)");
# we were not addressed, so just
# ignore it.
return 'NOREPLY';
}
if ($msgType =~ /public/) {
&performSay("...but $lhs are $exists...");
} else {
&msg($who, "...but $lhs are $exists...");
}
} else {
if ($msgType =~ /public/) {
&performSay("okay, $who.") unless $rhs eq $exists;
} else {
&msg($who, "okay.")
unless grep $_ eq $who, split /\s+/, $param{friendlyBots};
}
$updateCount++;
&status("update: <$who> \'$lhs =are=> $rhs\'; was \'$exists\'");
&set("are", $lhs, $rhs);
}
$reply = 'NOREPLY';
}
} else {
&status("enter: <$who> $lhs =are=> $rhs");
$updateCount++;
&set("are", $lhs, $rhs);
$are{"theCount"}++;
}
}
}
$lhs .= " $verb $rhs";
if ($reply ne 'NOREPLY') {
$reply = $lhs;
}
return $reply;
}
# ---
1;

428
src/User.pl
Unescape Escape View File

@ -0,0 +1,428 @@
# all the user stuff
#
# kevin lenzo
#
sub parseUserfile {
$file = $param{'confdir'}.$filesep.$param{'userList'};
%user = ();
@userList = ();
open(FH, $file);
while (<FH>) {
if (!/^#/ && defined $_) {
if (/^UserEntry\s+(.+?)\s/) {
push @userList, $1;
$workname = $1;
if (/\s*\{\s*/) {
while (<FH>) {
if (/^\s*(\w+)\s+(.+);$/) {
$opt = $1; $val = $2;
$val =~ s/\"//g;
if ($opt =~ /^mask$/i) {
push @{$workname."masks"}, $val;
} elsif ($opt =~ /^flags$/i) {
$val =~ s/\+//;
$user{$workname."flags"} = $val;
} else {
$opt =~ tr/A-Z/a-z/;
$user{$workname.$opt} = $val;
}
} elsif (/^\s*\}\s*$/) {
last;
}
}
} else {
status("parse error: User Entry $workname without right brace");
}
}
}
}
my $u;
foreach $u (@userList) {
status("found user $user: flags +".$user{$u."flags"})
if $param{VERBOSITY} > 1;
if ($param{VERBOSITY} > 2) {
my $h;
foreach $h (@{$u."masks"}) {
status(" -> hostmask: $h");
}
}
}
}
sub IsFlag {
my $flags = $_[0];
my ($ret, $f, $o);
my @ind = split //, $flags;
foreach $f (split //, $uFlags) {
foreach $o (@ind) {
if ($f eq $o) {
$ret .= $f;
last;
}
}
}
$ret;
}
sub verifyUser {
my $lnuh = $_[0];
my ($u, $m);
my $VerifWho;
foreach $u (@userList) {
foreach (@{$u."masks"}) {
$m = $_;
$m =~ s/\*/.*?/g;
$m =~ s/([\@\(\)\[\]])/\\$1/g;
if ($lnuh =~ /^$m$/i) {
$VerifWho = $u;
last;
}
}
}
my $now = time();
my $m = $message;
if ($msgType !~ /public/) {
$m = "<private message>";
}
&set('seen', lc $who, $now.$;.channel().$;.$m);
if ($VerifWho) {
$uFlags = $user{$VerifWho."flags"};
$uPasswd = $user{$VerifWho."pass"};
$uTitle = $user{$VerifWho."title"};
if (exists $seenVerif{$VerifWho} and
(time()-$seenVerif{$VerifWho} > 360)) {
status("mask verified for $VerifWho");
}
$seenVerif{$VerifWho} = $now;
}
return $VerifWho;
}
sub mkpasswd {
my $what = $_[0];
my $salt = chr(33+rand(64)).chr(33+rand(64));
$salt =~ s/:/;/g;
return crypt($what, $salt);
}
sub ckuser {
# returns user level if matched, zero otherwise
my ($nuh, $plaintextpass) = @_;
if (!$plaintextpass) {
($nuh, $plaintextpass) = split(/\s+/, $nuh);
}
return '' unless $nuh;
my ($level, $cryptedpass, $rest, $nuh2) = &userinfo($nuh);
if (&ckpasswd($plaintextpass, $cryptedpass)) {
# password matched for user nick!user@host
&status("confirmed user: $nuh");
return $level;
} else {
# no match
return 0;
}
}
sub ckpasswd {
# returns true if arg1 encrypts to arg2
my ($plain, $encrypted) = @_;
if (!$encrypted) {
($plain, $encrypted) = split(/\s+/, $plain, 2);
}
return '' unless ($plain && $encrypted);
return ($encrypted eq crypt($plain, $encrypted));
}
sub userinfo {
my $lnuh = $_[0];
my $k;
if (!$lnuh) {
$lnuh = $nuh;
}
foreach $k (keys %userList) {
my $n = $k;
$n =~ s/\*/.*/g;
$n =~ s/([\@\(\)\[\]])/\\$1/g;
if ($lnuh =~ /^$n$/i) {
# this may expand later
my ($userlevel, $pass, $rest) = split(/:/, $userList{$k}, 3);
return ($userlevel, $pass, $rest, $k);
}
}
return ();
}
sub users {
my @stuff;
foreach (sort keys %userList) {
push(@stuff, "$_ => $userList{$_}\n");
}
return @stuff;
}
sub adduser {
my($nuh, $level, $plainpass, $rest) = @_;
if (!$level) {
($nuh, $level, $plainpass, $rest) = split(/\s+/, $nuh, 4);
}
if (!$plainpass && ($level =~ /\D/)) {
my $x = $level;
if ($plainpass =~ /^\D+/) {
$level = $plainpass;
$plainpass = $level;
}
}
if (($level =~ /^\d+/) && $plainpass) {
my $cryptedpass = mkpasswd($plainpass);
my $i = join(":", $level, $cryptedpass, $rest);
$userLevel{$nuh} = $i;
&status("user $nuh added at level $i");
return "user $nuh added at level $i";
} else {
&status("bad params to adduser");
return '';
}
}
sub writeUserFile {
my $where = $_[0];
chomp $where;
if (!$where) {
$where = $param{'confdir'}.$filesep.$param{'userList'};
}
if (!$where) {
return "no file given and no param set for writing user file\n";
}
if (open(UF, ">$where")) {
foreach (sort keys %userLevel) {
print UF "$_:$userLevel{$_}\n";
}
close UF;
&status("wrote user file to $where");
return "wrote user file";
} else {
&status("failed to write user file to $where");
return "couldn't write user file";
}
}
sub changepass {
my ($nuh, $oldpass, $newpass) = @_;
if (&ckuser($nuh, $oldpass)) {
my $cryptednew = mkpasswd($newpass);
my ($level, $pass, $rest, $nuh2) = &userinfo($nuh);
my $i = join(":", $level, $newpass, $rest);
$userList{$nuh2} = $i;
&status("password changed for $nuh");
return "password changed for $nuh";
} else {
&status("password change failed for $nuh");
return "password did not match you: $nuh";
}
}
sub removeuser {
my $nuh = $_[0];
if ($userList{$nuh}) {
delete $userList{$nuh};
&status("deleted $nuh from userlist");
return "deleted $nuh from the userlist";
} else {
return 'No match for $nuh';
}
}
sub setlevel {
my ($nuh, $newlevel) = @_;
if (!$newlevel) {
($nuh, $newlevel) = split(/\s+/, $nuh, 2);
}
my ($level, $pass, $rest, $nuh2) = &userinfo($nuh);
if ($newlevel !~ /^\d+/) {
return "bad user level: $newlevel";
}
if ($userList{$nuh}) {
($level, $pass, $rest) = split(/:/, $userList{$nuh});
$nuh2 = $nuh;
}
if ($nuh2) {
my $i = join(":", $newlevel, $pass, $rest);
$userList{$nuh2} = $i;
&status("level for $nuh changed to $newlevel (was $level)");
} else {
&status("no match for $nuh");
}
0;
}
sub userProcessing {
my $now = time();
if ($VerifWho) {
if ($msgType =~ /private/) {
my $unverified_message = "you must identify yourself; /msg $param{nick} <pass> <command>";
if (IsFlag("e")) { # eval
if ($message =~ s/^(\S+) eval//) {
if (!exists $verified{$VerifWho}) {
&status("unverified <$who> $message");
&msg($who, $unverified_message);
return 'NOREPLY';
}
my ($pass, $m) = ($1, $message);
$_ = "";
&msg($who, "WARNING: exposed eval security risk");
$x = eval($m);
&msg($who, $x);
}
}
if (IsFlag("o")) { # owner/operator flag
if ($message =~ /^die/) {
if (!exists $verified{$VerifWho}) {
&status("unverified <$who> $message");
&msg($who, $unverified_message);
return 'NOREPLY';
}
&rawout("QUIT :$who");
&closeDBMAll();
sleep 2;
status("Dying by $who\'s request");
exit(0);
}
if ($message =~ /^reload$/i) {
if (!exists $verified{$VerifWho}) {
&status("unverified <$who> $message");
&msg($who, $unverified_message);
return 'NOREPLY';
}
&status("RELOAD <$who>");
opendir DIR, $infobot_src_dir;
while ($file = readdir DIR) {
next unless $file =~ /\.pl$/;
next if $file eq 'Process.pl';
if (!do $file) {
&status("Error reloading $file: "
. ($@ || "did not return a true value"));
}
}
close DIR;
&msg($who, "reloaded init files");
return 'NOREPLY';
}
if ($message =~ /^rehash$/i) {
if (!exists $verified{$VerifWho}) {
&status("unverified <$who> $message");
&msg($who, $unverified_message);
return 'NOREPLY';
}
&status("REHASH <$who>\n");
&setup();
&msg($who, "rehashed");
return 'NOREPLY';
}
if ($message =~ /^modes$/) {
if (!exists $verified{$VerifWho}) {
&status("unverified <$who> $message");
&msg($who, $unverified_message);
return 'NOREPLY';
}
my ($chan, $mode, $user, $msg, $m1);
foreach $chan (keys %channels) {
my $msg = "$chan: ";
foreach $mode (keys %{$channels{$chan}}) {
my $m1 = $msg." $mode: ";
foreach $user (keys %{$channels{$chan}{$mode}}) {
$m1 .= "$user ";
}
&msg($who, $m1);
}
}
return 'NOREPLY';
}
}
if (IsFlag("p") eq "p") { # oP on channel
if ($message =~ s/^op( me)?$//i or $message =~ s/^op //i) {
if (!exists $verified{$VerifWho}) {
&status("unverified <$who> $message");
&msg($who, $unverified_message);
return 'NOREPLY';
}
&status("trying to op $who at their request");
foreach $chan (keys %channels) {
if ($message) {
&op($chan, $message);
} else {
&op($chan, $who);
}
}
return 'NOREPLY';
}
my $regex = 0;
if ($message =~ /^ignore\s+(.*)/) {
my $what = $1;
&postInc(ignore => $what);
&status("ignoring $what at $VerifWho's request");
&msg($who, "added $what to the ignore list");
return 'NOREPLY';
}
if ($message =~ /^ignorelist$/) {
&status("$who asked for the ignore list");
my $all = join " ", &getDBMKeys('ignore');
while (length($all) > 200) {
$all =~ s/(.{0,200}) //;
&msg($who, $1);
}
&msg($who, $all);
return 'NOREPLY';
}
if ($message =~ /^unignore\s+(.*)/) {
my $what = $1;
if (&clear(ignore => $what)) {
&status("unignoring $what at $VerifWho's request");
&msg($who, "removed $what from the ignore list");
} else {
&status("unignore FAILED for $1 at $who's request");
&msg($who, "no entry for $1 on the ignore list");
}
return 'NOREPLY';
}
}
}
} else {
$uFlags = $user{"defaultflags"};
}
}
1;

120
src/Util.pm
Unescape Escape View File

@ -0,0 +1,120 @@
# $Id: Util.pm,v 1.1 2000/11/01 22:40:50 lenzo Exp $
use strict;
package Util;
=head1 NAME
Util - infobot utility functions
=head1 SYNOPSIS
export_to_main qw(func &func2 $scalar @array %hash);
import_from_main qw(func &func2 $scalar @array %hash);
import_export $from_pkg, $to_pkg, @symbol;
process_args \@arg_list, myarg => \$myvar, %more_pairs or die;
=head1 DESCRIPTION
This module provides some utility functions for the B<infobot>.
=cut
use Carp qw(croak);
use Exporter ();
use vars qw($VERSION @ISA @EXPORT_OK);
$VERSION = do{my@r=q$Revision: 1.1 $=~/\d+/g;sprintf '%d.'.'%03d'x$#r,@r};
@ISA = qw(Exporter);
@EXPORT_OK = qw(
export_to_main
import_export
import_from_main
process_args
);
=head1 IMPORTABLE SYMBOLS
=over 4
=cut
sub import_export {
my ($from_pkg, $to_pkg, @symbol) = @_;
my ($symbol, $type, $name, $code);
$code = "package $to_pkg;\n";
for $symbol (@symbol) {
($type, $name) = $symbol =~ /^([\$\@%&])?(\w+)$/
or croak "Invalid symbol `$symbol'";
$type ||= '&';
$code .= "*$name = \\$type${from_pkg}::$name;\n";
}
print $code if 0;
{
no strict 'refs';
eval $code;
die if $@;
}
}
sub export_to_main {
my @symbol = @_;
import_export scalar(caller), 'main', @symbol;
}
sub import_from_main {
my @symbol = @_;
import_export 'main', scalar(caller), @symbol;
}
#------------------------------------------------------------------------------
BEGIN {
import_from_main qw(status);
}
sub process_args {
my ($rarg, %desc) = @_;
my $caller_sub = (caller 1)[3];
my $fail = 0;
while (@$rarg > 1) {
my ($key, $val) = splice @$rarg, 0, 2;
if ($desc{$key}) {
${ $desc{$key} } = $val;
} else {
status "$caller_sub: invalid arg `$key'";
$fail = 1;
}
}
if (@$rarg) {
status "$caller_sub: ignoring trailing value-less arg `$rarg->[0]'";
$fail = 1;
}
return !$fail;
}
1
__END__
=back
=head1 AUTHOR
Roderick Schertler <F<roderick@argon.org>>
=head1 SEE ALSO
infobot(1), perl(1).
=cut
Write Preview
Loading…
Cancel
Save