source: irpg/trunk/bot/bot.v3.1.2.pl@ 4381

Last change on this file since 4381 was 1469, checked in by Daimonos Tereutes, 18 years ago

bug des @arg[x..y]

File size: 109.9 KB
Line 
1#!/usr/local/bin/perl
2# irpg bot v3.1.2 by jotun, jotun@idlerpg.net, et al. See http://idlerpg.net/
3#
4# Some code within this file was written by authors other than myself. As such,
5# distributing this code or distributing modified versions of this code is
6# strictly prohibited without written authorization from the authors. Contact
7# jotun@idlerpg.net. Please note that this may change (at any time, no less) if
8# authorization for distribution is given by patch submitters.
9#
10# As a side note, patches submitted for this project are automatically taken to
11# be freely distributable and modifiable for any use, public or private, though
12# I make no claim to ownership; original copyrights will be retained.. except as
13# I've just stated.
14#
15# Please mail bugs, etc. to me. Patches are welcome to fix bugs or clean up
16# the code, but please do not use a radically different coding style. Thanks
17# to everyone that's contributed!
18#
19# NOTE: This code should NOT be run as root. You deserve anything that happens
20# to you if you run this code as a superuser. Also, note that giving a
21# user admin access to the bot effectively gives them full access to the
22# user under which your bot runs, as they can use the PEVAL command to
23# execute any command, or possibly even change your password. I sincerely
24# suggest that you exercise extreme caution when giving someone admin
25# access to your bot, or that you disable the PEVAL command for non-owner
26# accounts in your config file, .irpg.conf
27
28use strict;
29use warnings;
30use IO::Socket;
31use IO::Socket::INET6;
32use IO::Select;
33use Data::Dumper;
34use Getopt::Long;
35use Locale::gettext;
36use POSIX;
37
38my %opts;
39
40readconfig();
41
42my $version = "3.1.2+johm+chschu+gettext";
43
44# command line overrides .irpg.conf
45GetOptions(\%opts,
46 "help|h",
47 "verbose|v",
48 "ipv6",
49 "lang",
50 "debug",
51 "debugfile=s",
52 "server|s=s",
53 "botnick|n=s",
54 "botuser|u=s",
55 "botrlnm|r=s",
56 "botchan|c=s",
57 "botident|p=s",
58 "botmodes|m=s",
59 "botopcmd|o=s",
60 "localaddr=s",
61 "botghostcmd|g=s",
62 "helpurl=s",
63 "admincommurl=s",
64 "doban",
65 "silentmode=i",
66 "writequestfile",
67 "questfilename=s",
68 "voiceonlogin",
69 "noccodes",
70 "nononp",
71 "mapurl=s",
72 "statuscmd",
73 "pidfile=s",
74 "reconnect",
75 "reconnect_wait=i",
76 "self_clock=i",
77 "modsfile=s",
78 "casematters",
79 "detectsplits",
80 "autologin",
81 "splitwait=i",
82 "allowuserinfo",
83 "noscale",
84 "phonehome",
85 "owner=s",
86 "owneraddonly",
87 "ownerdelonly",
88 "ownerpevalonly",
89 "checkupdates",
90 "senduserlist",
91 "limitpen=i",
92 "mapx=i",
93 "mapy=i",
94 "modesperline=i",
95 "okurl|k=s@",
96 "eventsfile=s",
97 "rpstep=f",
98 "rpbase=i",
99 "rppenstep=f",
100 "dbfile|irpgdb|db|d=s",
101) or debug("Error: Could not parse command line. Try $0 --help\n",1);
102
103$opts{help} and do { help(); exit 0; };
104
105debug("Config: read $_: ".Dumper($opts{$_})) for keys(%opts);
106
107setlocale(LC_MESSAGES, $opts{lang});
108bindtextdomain("irpg","lang");
109textdomain("irpg");
110
111my $outbytes = 0; # sent bytes
112my $primnick = $opts{botnick}; # for regain or register checks
113my $inbytes = 0; # received bytes
114my %onchan; # users on game channel
115my %rps; # role-players
116my %quest = (
117 questers => [],
118 p1 => [], # point 1 for q2
119 p2 => [], # point 2 for q2
120 qtime => time() + int(rand(21600)), # first quest starts in <=6 hours
121 text => "",
122 type => 1,
123 stage => 1); # quest info
124my %mapitems = (); # items lying around
125
126my $rpreport = 0; # constant for reporting top players
127my $oldrpreport = 0; # constant for reporting top players (last value)
128my %prev_online; # user@hosts online on restart, die
129my %auto_login; # users to automatically log back on
130my @bans; # bans auto-set by the bot, saved to be removed after 1 hour
131my $pausemode = 0; # pausemode on/off flag
132my $silentmode = 0; # silent mode 0/1/2/3, see head of file
133my @queue; # outgoing message queue
134my $lastreg = 0; # holds the time of the last reg. cleared every second.
135 # prevents more than one account being registered / second
136my $registrations = 0; # count of registrations this period
137my $sel; # IO::Select object
138my $lasttime = 1; # last time that rpcheck() was run
139my $buffer; # buffer for socket stuff
140my $conn_tries = 0; # number of connection tries. gives up after trying each
141 # server twice
142my $sock; # IO::Socket::INET object
143my %split; # holds nick!user@hosts for clients that have been netsplit
144my $freemessages = 4; # number of "free" privmsgs we can send. 0..$freemessages
145
146sub daemonize(); # prototype to avoid warnings
147
148if (! -e $opts{dbfile}) {
149 $|=1;
150 %rps = ();
151 printf gettext("%s does not appear to exist. I'm guessing this is your ".
152 "first time using IRPG. Please give an account name that you would ".
153 "like to have admin access [%s]: "), $opts{dbfile}, $opts{owner};
154 chomp(my $uname = <STDIN>);
155 $uname =~ s/\s.*//g;
156 $uname = length($uname)?$uname:$opts{owner};
157 print gettext("Enter a character class for this account: ");
158 chomp(my $uclass = <STDIN>);
159 $rps{$uname}{class} = substr($uclass,0,30);
160 print gettext("Enter a password for this account: ");
161 if ($^O ne "MSWin32") {
162 system("stty -echo");
163 }
164 chomp(my $upass = <STDIN>);
165 if ($^O ne "MSWin32") {
166 system("stty echo");
167 }
168 $rps{$uname}{pass} = crypt($upass,mksalt());
169 $rps{$uname}{next} = $opts{rpbase};
170 $rps{$uname}{nick} = "";
171 $rps{$uname}{userhost} = "";
172 $rps{$uname}{level} = 0;
173 $rps{$uname}{online} = 0;
174 $rps{$uname}{idled} = 0;
175 $rps{$uname}{created} = time();
176 $rps{$uname}{lastlogin} = time();
177 $rps{$uname}{x} = int(rand($opts{mapx}));
178 $rps{$uname}{y} = int(rand($opts{mapy}));
179 $rps{$uname}{alignment}="n";
180 $rps{$uname}{isadmin} = 1;
181 for my $item ("ring","amulet","charm","weapon","helm",
182 "tunic","pair of gloves","shield",
183 "set of leggings","pair of boots") {
184 $rps{$uname}{item}{$item} = 0;
185 }
186 for my $pen ("pen_mesg","pen_nick","pen_part",
187 "pen_kick","pen_quit","pen_quest",
188 "pen_logout","pen_logout") {
189 $rps{$uname}{$pen} = 0;
190 }
191 writedb();
192 printf gettext("OK, wrote you into %s \n"),$opts{dbfile};
193}
194
195# this is almost silly...
196if ($opts{checkupdates}) {
197 print gettext("Checking for updates...\n\n");
198 my $tempsock = IO::Socket::INET->new(PeerAddr=>"jotun.ultrazone.org:80",
199 Timeout => 15);
200 if ($tempsock) {
201 print $tempsock "GET /g7/version.php?version=$version HTTP/1.1\r\n".
202 "Host: jotun.ultrazone.org:80\r\n\r\n";
203 my($line,$newversion);
204 while ($line=<$tempsock>) {
205 chomp($line);
206 next() unless $line;
207 if ($line =~ /^Current version : (\S+)/) {
208 if ($version ne $1) {
209 print gettext("There is an update available! Changes include:\n");
210 $newversion=1;
211 }
212 else {
213 printf gettext("You are running the latest version (v%s).".
214 "\n"), $1;
215 close($tempsock);
216 last();
217 }
218 }
219 elsif ($newversion && $line =~ /^( -? .+)/) { print "$1\n"; }
220 elsif ($newversion && $line =~ /^URL: (.+)/) {
221 printf gettext("\nGet the newest version from %s!\n"), $1;
222 close($tempsock);
223 last();
224 }
225 }
226 }
227 else { print gettext(debug("Could not connect to update server."))."\n"; }
228}
229
230print "\n".gettext(debug("Becoming a daemon..."))."\n";
231daemonize();
232
233$SIG{HUP} = "readconfig"; # sighup = reread config file
234
235CONNECT: # cheese.
236
237loaddb();
238
239while (!$sock && $conn_tries < 2*@{$opts{servers}}) {
240 debug("Connecting to $opts{servers}->[0]...");
241 my %sockinfo = (PeerAddr => $opts{servers}->[0]);
242 if ($opts{localaddr}) { $sockinfo{LocalAddr} = $opts{localaddr}; }
243
244 if ($opts{ipv6}) {
245 $sock = IO::Socket::INET6->new(%sockinfo) or
246 debug("Error: failed to connect: $!\n");
247 }
248 else {
249 $sock = IO::Socket::INET->new(%sockinfo) or
250 debug("Error: failed to connect: $!\n");
251 }
252
253 ++$conn_tries;
254 if (!$sock) {
255 # cycle front server to back if connection failed
256 push(@{$opts{servers}},shift(@{$opts{servers}}));
257 }
258 else { debug("Connected."); }
259}
260
261if (!$sock) {
262 debug("Error: Too many connection failures, exhausted server list.\n",1);
263}
264
265$conn_tries=0;
266
267$sel = IO::Select->new($sock);
268
269sts("NICK $opts{botnick}");
270sts("USER $opts{botuser} 0 0 :$opts{botrlnm}");
271
272while (1) {
273 my($readable) = IO::Select->select($sel,undef,undef,0.5);
274 if (defined($readable)) {
275 my $fh = $readable->[0];
276 my $buffer2;
277 $fh->recv($buffer2,512,0);
278 if (length($buffer2)) {
279 $buffer .= $buffer2;
280 while (index($buffer,"\n") != -1) {
281 my $line = substr($buffer,0,index($buffer,"\n")+1);
282 $buffer = substr($buffer,length($line));
283 parse($line);
284 }
285 }
286 else {
287 # uh oh, we've been disconnected from the server, possibly before
288 # we've logged in the users in %auto_login. so, we'll set those
289 # users' online flags to 1, rewrite db, and attempt to reconnect
290 # (if that's wanted of us)
291 $rps{$_}{online}=1 for keys(%auto_login);
292 writedb();
293
294 close($fh);
295 $sel->remove($fh);
296
297 if ($opts{reconnect}) {
298 undef(@queue);
299 undef($sock);
300 debug("Socket closed; disconnected. Cleared outgoing message ".
301 "queue. Waiting $opts{reconnect_wait}s before next ".
302 "connection attempt...");
303 sleep($opts{reconnect_wait});
304 goto CONNECT;
305 }
306 else { debug("Socket closed; disconnected.",1); }
307 }
308 }
309 else { select(undef,undef,undef,1); }
310 if ((time()-$lasttime) >= $opts{self_clock}) { rpcheck(); }
311}
312
313
314sub parse {
315 my($in) = shift;
316 $inbytes += length($in); # increase parsed byte count
317 $in =~ s/[\r\n]//g; # strip all \r and \n
318 debug("<- $in");
319 my @arg = split(/\s/,$in); # split into "words"
320 my $usernick = substr((split(/!/,$arg[0]))[0],1);
321 # logged in char name of nickname, or undef if nickname is not online
322 my $username = finduser($usernick);
323 if (lc($arg[0]) eq 'ping') { sts("PONG $arg[1]",1); }
324 elsif (lc($arg[0]) eq 'error') {
325 # uh oh, we've been disconnected from the server, possibly before we've
326 # logged in the users in %auto_login. so, we'll set those users' online
327 # flags to 1, rewrite db, and attempt to reconnect (if that's wanted of
328 # us)
329 $rps{$_}{online}=1 for keys(%auto_login);
330 writedb();
331 return;
332 }
333 $arg[1] = lc($arg[1]); # original case no longer matters
334 if ($arg[1] eq '433' && $opts{botnick} eq $arg[3]) {
335 $opts{botnick} .= 0;
336 sts("NICK $opts{botnick}");
337 }
338 elsif ($arg[1] eq 'join') {
339 # %onchan holds time user joined channel. used for the advertisement ban
340 $onchan{$usernick}=time();
341 if ($opts{'detectsplits'} && exists($split{substr($arg[0],1)})) {
342 delete($split{substr($arg[0],1)});
343 }
344 elsif ($opts{botnick} eq $usernick) {
345 sts("WHO $opts{botchan}");
346 (my $opcmd = $opts{botopcmd}) =~ s/%botnick%/$opts{botnick}/eg;
347 sts($opcmd);
348 $lasttime = time(); # start rpcheck()
349 }
350 elsif ($opts{autologin}) {
351 for my $k (keys %rps) {
352 if (":".$rps{$k}{userhost} eq $arg[0]) {
353 if ($opts{voiceonlogin}) {
354 sts("MODE $opts{botchan} +v :$usernick");
355 }
356 $rps{$k}{online} = 1;
357 $rps{$k}{nick} = $usernick;
358 $rps{$k}{lastlogin} = time();
359 chanmsg(sprintf(gettext("%s, the level %u ".
360 "%s, is now online from ".
361 "nickname %s. Next level in %s."),
362 $k,$rps{$k}{level},$rps{$k}{class},
363 $usernick,duration($rps{$k}{next})));
364 notice(sprintf(gettext("Logon successful. Next level in ".
365 "%s."),duration($rps{$k}{next})),
366 $usernick);
367 }
368 }
369 }
370 }
371 elsif ($arg[1] eq 'quit') {
372 # if we see our nick come open, grab it (skipping queue)
373 if ($usernick eq $primnick) { sts("NICK $primnick",1); }
374 elsif ($opts{'detectsplits'} &&
375 "@arg[2..$#arg]" =~ /^:\S+\.\S+ \S+\.\S+$/) {
376 if (defined($username)) { # user was online
377 $split{substr($arg[0],1)}{time}=time();
378 $split{substr($arg[0],1)}{account}=$username;
379 }
380 }
381 else {
382 penalize($username,"quit");
383 }
384 delete($onchan{$usernick});
385 }
386 elsif ($arg[1] eq 'nick') {
387 # if someone (nickserv) changes our nick for us, update $opts{botnick}
388 if ($usernick eq $opts{botnick}) {
389 $opts{botnick} = substr($arg[2],1);
390 }
391 # if we see our nick come open, grab it (skipping queue), unless it was
392 # us who just lost it
393 elsif ($usernick eq $primnick) { sts("NICK $primnick",1); }
394 else {
395 penalize($username,"nick",$arg[2]);
396 $onchan{substr($arg[2],1)} = delete($onchan{$usernick});
397 }
398 }
399 elsif ($arg[1] eq 'part') {
400 penalize($username,"part");
401 delete($onchan{$usernick});
402 }
403 elsif ($arg[1] eq 'kick') {
404 $usernick = $arg[3];
405 penalize(finduser($usernick),"kick");
406 delete($onchan{$usernick});
407 }
408 # don't penalize /notices to the bot
409 elsif ($arg[1] eq 'notice' && $arg[2] ne $opts{botnick}) {
410 penalize($username,"notice",length("@arg[3..$#arg]")-1);
411 }
412 elsif ($arg[1] eq '001') {
413 # send our identify command, set our usermode, join channel
414 sts($opts{botident});
415 sts("MODE $opts{botnick} :$opts{botmodes}");
416 sts("JOIN $opts{botchan}");
417 $opts{botchan} =~ s/ .*//; # strip channel key if present
418 }
419 elsif ($arg[1] eq '315') {
420 # 315 is /WHO end. report who we automagically signed online iff it will
421 # print < 1k of text
422 if (keys(%auto_login)) {
423 # not a true measure of size, but easy
424 if (length("%auto_login") < 1024 && $opts{senduserlist}) {
425 chanmsg(sprintf(gettext("%u users matching %u hosts ".
426 "automatically logged in; accounts: "),
427 scalar(keys(%auto_login)),
428 scalar(keys(%prev_online))).
429 join(", ",keys(%auto_login)));
430 }
431 else {
432 chanmsg(sprintf(gettext("%u users matching %u hosts ".
433 "automatically logged in."),
434 scalar(keys(%auto_login)),
435 scalar(keys(%prev_online))));
436 }
437 if ($opts{voiceonlogin}) {
438 my @vnicks = map { $rps{$_}{nick} } keys(%auto_login);
439 while (scalar @vnicks >= $opts{modesperline}) {
440 sts("MODE $opts{botchan} +".
441 ('v' x $opts{modesperline})." ".
442 join(" ",@vnicks[0..$opts{modesperline}-1]));
443 splice(@vnicks,0,$opts{modesperline});
444 }
445 sts("MODE $opts{botchan} +".
446 ('v' x (scalar @vnicks))." ".
447 join(" ",@vnicks));
448 }
449 }
450 else { chanmsg(gettext("0 users qualified for auto login.")); }
451 undef(%prev_online);
452 undef(%auto_login);
453 loadquestfile();
454 }
455 elsif ($arg[1] eq '005') {
456 if ("@arg" =~ /MODES=(\d+)/) { $opts{modesperline}=$1; }
457 }
458 elsif ($arg[1] eq '352') {
459 my $user;
460 # 352 is one line of /WHO. check that the nick!user@host exists as a key
461 # in %prev_online, the list generated in loaddb(). the value is the user
462 # to login
463 $onchan{$arg[7]}=time();
464 if (exists($prev_online{$arg[7]."!".$arg[4]."\@".$arg[5]})) {
465 $rps{$prev_online{$arg[7]."!".$arg[4]."\@".$arg[5]}}{online} = 1;
466 $auto_login{$prev_online{$arg[7]."!".$arg[4]."\@".$arg[5]}}=1;
467 }
468 }
469 elsif ($arg[1] eq 'privmsg') {
470 $arg[0] = substr($arg[0],1); # strip leading : from privmsgs
471 if (lc($arg[2]) eq lc($opts{botnick})) { # to us, not channel
472 $arg[3] = lc(substr($arg[3],1)); # lowercase, strip leading :
473 if ($arg[3] eq "\1version\1") {
474 notice("\1VERSION IRPG bot v$version by jotun; ".
475 "http://idlerpg.net/\1",$usernick);
476 }
477 elsif ($arg[3] eq "peval") {
478 if (!ha($username) || ($opts{ownerpevalonly} &&
479 $opts{owner} ne $username)) {
480 privmsg(sprintf(gettext("You don't have access to %s."),
481 "PEVAL"), $usernick);
482 }
483 else {
484 my @peval = eval "@arg[4..$#arg]";
485 if (@peval >= 4 || length("@peval") > 1024) {
486 privmsg("Command produced too much output to send ".
487 "outright; queueing ".length("@peval").
488 " bytes in ".scalar(@peval)." items. Use ".
489 "CLEARQ to clear queue if needed.",$usernick,1);
490 privmsg($_,$usernick) for @peval;
491 }
492 else { privmsg($_,$usernick, 1) for @peval; }
493 privmsg("EVAL ERROR: $@", $usernick, 1) if $@;
494 }
495 }
496 elsif ($arg[3] eq "register") {
497 if (defined $username) {
498 privmsg(sprintf(gettext("Sorry, you are already online as ".
499 "%s."), $username), $usernick);
500 }
501 else {
502 if ($#arg < 6 || $arg[6] eq "") {
503 privmsg(gettext("Try: REGISTER <char name> <password> ".
504 "<class>"), $usernick);
505 privmsg(gettext("IE : REGISTER Poseidon MyPassword God ".
506 "of the Sea"), $usernick);
507 }
508 elsif ($pausemode) {
509 privmsg(gettext("Sorry, new accounts may not be ".
510 "registered while the bot is in pause ".
511 "mode; please wait a few minutes and ".
512 "try again."),$usernick);
513 }
514 elsif (exists $rps{$arg[4]} || ($opts{casematters} &&
515 scalar(grep { lc($arg[4]) eq lc($_) } keys(%rps)))) {
516 privmsg(gettext("Sorry, that character name is already ".
517 "in use."), $usernick);
518 }
519 elsif (lc($arg[4]) eq lc($opts{botnick}) ||
520 lc($arg[4]) eq lc($primnick)) {
521 privmsg(gettext("Sorry, that character name cannot be ".
522 "registered."), $usernick);
523 }
524 elsif (!exists($onchan{$usernick})) {
525 privmsg(sprintf(gettext("Sorry, you're not in %s."),
526 $opts{botchan}), $usernick);
527 }
528 elsif (length($arg[4]) > 16 || length($arg[4]) < 1) {
529 privmsg(gettext("Sorry, character names must be < 17 ".
530 "and > 0 chars long."), $usernick);
531 }
532 elsif ($arg[4] =~ /^#/) {
533 privmsg(gettext("Sorry, character names may not begin ".
534 "with #."), $usernick);
535 }
536 elsif ($arg[4] =~ /\001/) {
537 privmsg(gettext("Sorry, character names may not include".
538 " character \\001."),$usernick);
539 }
540 elsif ($opts{noccodes} && ($arg[4] =~ /[[:cntrl:]]/ ||
541 "@arg[6..$#arg]" =~ /[[:cntrl:]]/)) {
542 privmsg(gettext("Sorry, neither character names nor ".
543 "classes may include control codes."),
544 $usernick);
545 }
546 elsif ($opts{nononp} && ($arg[4] =~ /[[:^print:]]/ ||
547 "@arg[6..$#arg]" =~ /[[:^print:]]/)) {
548 privmsg(gettext("Sorry, neither character names nor ".
549 "classes may include non-printable ".
550 "chars."), $usernick);
551 }
552 elsif (length("@arg[6..$#arg]") > 30) {
553 privmsg(gettext("Sorry, character classes must be < 31".
554 " chars long."), $usernick);
555 }
556 elsif (time() == $lastreg) {
557 privmsg(gettext("Wait 1 second and try again."),
558 $usernick);
559 }
560 else {
561 if ($opts{voiceonlogin}) {
562 sts("MODE $opts{botchan} +v :$usernick");
563 }
564 ++$registrations;
565 $lastreg = time();
566 $rps{$arg[4]}{next} = $opts{rpbase};
567 $rps{$arg[4]}{class} = "@arg[6..$#arg]";
568 $rps{$arg[4]}{level} = 0;
569 $rps{$arg[4]}{online} = 1;
570 $rps{$arg[4]}{nick} = $usernick;
571 $rps{$arg[4]}{userhost} = $arg[0];
572 $rps{$arg[4]}{created} = time();
573 $rps{$arg[4]}{lastlogin} = time();
574 $rps{$arg[4]}{pass} = crypt($arg[5],mksalt());
575 $rps{$arg[4]}{x} = int(rand($opts{mapx}));
576 $rps{$arg[4]}{y} = int(rand($opts{mapy}));
577 $rps{$arg[4]}{alignment}="n";
578 $rps{$arg[4]}{isadmin} = 0;
579 for my $item ("ring","amulet","charm","weapon","helm",
580 "tunic","pair of gloves","shield",
581 "set of leggings","pair of boots") {
582 $rps{$arg[4]}{item}{$item} = 0;
583 }
584 for my $pen ("pen_mesg","pen_nick","pen_part",
585 "pen_kick","pen_quit","pen_quest",
586 "pen_logout","pen_logout") {
587 $rps{$arg[4]}{$pen} = 0;
588 }
589 chanmsg(sprintf(gettext("Welcome %s\'s new player %s, ".
590 "the %s! Next level in %s."),
591 $usernick,$arg[4], join(" ",(@arg[6..$#arg])),
592 duration($opts{rpbase})));
593 privmsg(sprintf(gettext("Success! Account %s created. ".
594 "You have %u seconds idleness ".
595 "until you reach level 1."),
596 $arg[4],$opts{rpbase}), $usernick);
597 privmsg(gettext("NOTE: The point of the game is to see ".
598 "who can idle the longest. As such, ".
599 "talking in the channel, parting, ".
600 "quitting, and changing nicks all ".
601 "penalize you."),$usernick);
602 if ($opts{phonehome}) {
603 my $tempsock = IO::Socket::INET->new(PeerAddr=>
604 "jotun.ultrazone.org:80");
605 if ($tempsock) {
606 print $tempsock
607 "GET /g7/count.php?new=1 HTTP/1.1\r\n".
608 "Host: jotun.ultrazone.org:80\r\n\r\n";
609 sleep(1);
610 close($tempsock);
611 }
612 }
613 }
614 }
615 }
616 elsif ($arg[3] eq "delold") {
617 if (!ha($username)) {
618 privmsg(sprintf(gettext("You don't have access to %s."),
619 "DELOLD"), $usernick);
620 }
621 # insure it is a number
622 elsif ($arg[4] !~ /^[\d\.]+$/) {
623 privmsg(gettext("Try: DELOLD <# of days>"), $usernick, 1);
624 }
625 else {
626 my @oldaccounts = grep { (time()-$rps{$_}{lastlogin}) >
627 ($arg[4] * 86400) &&
628 !$rps{$_}{online} } keys(%rps);
629 delete(@rps{@oldaccounts});
630 chanmsg(sprintf(gettext("%u accounts not accessed in ".
631 "the last %u days removed by %s."),
632 scalar(@oldaccounts),$arg[4],$arg[0]));
633 }
634 }
635 elsif ($arg[3] eq "del") {
636 if (!ha($username)) {
637 privmsg(sprintf(gettext("You don't have access to %s."),
638 "DEL"), $usernick);
639 }
640 elsif (!defined($arg[4])) {
641 privmsg(gettext("Try: DEL <char name>"), $usernick, 1);
642 }
643 elsif (!exists($rps{$arg[4]})) {
644 privmsg(sprintf(gettext("No such account %s."),$arg[4]),
645 $usernick, 1);
646 }
647 else {
648 delete($rps{$arg[4]});
649 chanmsg(sprintf(gettext("Account %s removed by %s."),
650 $arg[4],$arg[0]));
651 }
652 }
653 elsif ($arg[3] eq "mkadmin") {
654 if (!ha($username) || ($opts{owneraddonly} &&
655 $opts{owner} ne $username)) {
656 privmsg(sprintf(gettext("You don't have access to %s."),
657 "MKADMIN"), $usernick);
658 }
659 elsif (!defined($arg[4])) {
660 privmsg(gettext("Try: MKADMIN <char name>"), $usernick, 1);
661 }
662 elsif (!exists($rps{$arg[4]})) {
663 privmsg(sprintf(gettext("No such account %s."),$arg[4]),
664 $usernick, 1);
665 }
666 else {
667 $rps{$arg[4]}{isadmin}=1;
668 privmsg(sprintf(gettext("Account %s is now a bot admin."),
669 $arg[4]),$usernick, 1);
670 }
671 }
672 elsif ($arg[3] eq "deladmin") {
673 if (!ha($username) || ($opts{ownerdelonly} &&
674 $opts{owner} ne $username)) {
675 privmsg(sprintf(gettext("You don't have access to %s."),
676 "DELADMIN"), $usernick);
677 }
678 elsif (!defined($arg[4])) {
679 privmsg(gettext("Try: DELADMIN <char name>"), $usernick, 1);
680 }
681 elsif (!exists($rps{$arg[4]})) {
682 privmsg(sprintf(gettext("No such account %s."),$arg[4]),
683 $usernick, 1);
684 }
685 elsif ($arg[4] eq $opts{owner}) {
686 privmsg(gettext("Cannot DELADMIN owner account."),
687 $usernick, 1);
688 }
689 else {
690 $rps{$arg[4]}{isadmin}=0;
691 privmsg(sprintf(gettext("Account %s is no longer a bot ".
692 "admin."),$arg[4]), $usernick, 1);
693 }
694 }
695 elsif ($arg[3] eq "hog") {
696 if (!ha($username)) {
697 privmsg(sprintf(gettext("You don't have access to %s."),
698 "HOG"), $usernick);
699 }
700 else {
701 chanmsg(sprintf(gettext("%s has summoned the Hand of God."),
702 $usernick));
703 hog();
704 }
705 }
706 elsif ($arg[3] eq "rehash") {
707 if (!ha($username)) {
708 privmsg(sprintf(gettext("You don't have access to %s."),
709 "REHASH"), $usernick);
710 }
711 else {
712 readconfig();
713 privmsg(gettext("Reread config file."),$usernick,1);
714 $opts{botchan} =~ s/ .*//; # strip channel key if present
715 }
716 }
717 elsif ($arg[3] eq "chpass") {
718 if (!ha($username)) {
719 privmsg(sprintf(gettext("You don't have access to %s."),
720 "CHPASS"), $usernick);
721 }
722 elsif (!defined($arg[5])) {
723 privmsg(gettext("Try: CHPASS <char name> <new pass>"),
724 $usernick, 1);
725 }
726 elsif (!exists($rps{$arg[4]})) {
727 privmsg(sprintf(gettext("No such username %s."),$arg[4]),
728 $usernick, 1);
729 }
730 else {
731 $rps{$arg[4]}{pass} = crypt($arg[5],mksalt());
732 privmsg(sprintf(gettext("Password for %s changed."),
733 $arg[4]), $usernick, 1);
734 }
735 }
736 elsif ($arg[3] eq "chuser") {
737 if (!ha($username)) {
738 privmsg(sprintf(gettext("You don't have access to %s."),
739 "CHUSER"), $usernick);
740 }
741 elsif (!defined($arg[5])) {
742 privmsg(gettext("Try: CHUSER <char name> <new char name>"),
743 $usernick, 1);
744 }
745 elsif (!exists($rps{$arg[4]})) {
746 privmsg(sprintf(gettext("No such username %s."),$arg[4]),
747 $usernick, 1);
748 }
749 elsif (exists($rps{$arg[5]})) {
750 privmsg(sprintf(gettext("Username %s is already taken."),
751 $arg[5]), $usernick,1);
752 }
753 else {
754 $rps{$arg[5]} = delete($rps{$arg[4]});
755 privmsg(sprintf(gettext("Username for %s changed to %s."),
756 $arg[4],$arg[5]), $usernick, 1);
757 }
758 }
759 elsif ($arg[3] eq "chclass") {
760 if (!ha($username)) {
761 privmsg(sprintf(gettext("You don't have access to %s."),
762 "CHCLASS"), $usernick);
763 }
764 elsif (!defined($arg[5])) {
765 privmsg(gettext("Try: CHCLASS <char name> <new char class>"),
766 $usernick, 1);
767 }
768 elsif (!exists($rps{$arg[4]})) {
769 privmsg(sprintf(gettext("No such username %s."),$arg[4]),
770 $usernick, 1);
771 }
772 else {
773 $rps{$arg[4]}{class} = "@arg[5..$#arg]";
774 privmsg(sprintf(gettext("Class for %s changed to %s."),
775 $arg[4],join(" ",(@arg[5..$#arg]))), $usernick, 1);
776 }
777 }
778 elsif ($arg[3] eq "push") {
779 if (!ha($username)) {
780 privmsg(sprintf(gettext("You don't have access to %s."),
781 "PUSH"), $usernick);
782 }
783 # insure it's a positive or negative, integral number of seconds
784 elsif ($arg[5] !~ /^\-?\d+$/) {
785 privmsg(gettext("Try: PUSH <char name> <seconds>"),
786 $usernick, 1);
787 }
788 elsif (!exists($rps{$arg[4]})) {
789 privmsg(sprintf(gettext("No such username %s."),$arg[4]),
790 $usernick, 1);
791 }
792 elsif ($arg[5] > $rps{$arg[4]}{next}) {
793 privmsg(sprintf(gettext("Time to level for %s (%u s) is ".
794 "lower than %d; setting TTL to 0."),
795 $arg[4],$rps{$arg[4]}{next},$arg[5]),
796 $usernick, 1);
797 chanmsg(sprintf(gettext("%s has pushed %s %d seconds ".
798 "toward level %u"),
799 $usernick,$arg[4],$rps{$arg[4]}{next},
800 ($rps{$arg[4]}{level}+1)));
801 $rps{$arg[4]}{next}=0;
802 }
803 else {
804 $rps{$arg[4]}{next} -= $arg[5];
805 chanmsg(sprintf(gettext("%s has pushed %s %d seconds ".
806 "toward level %u. %2\$s reaches ".
807 "next level in %5\$s."),
808 $usernick,$arg[4],$arg[5],
809 ($rps{$arg[4]}{level}+1),
810 duration($rps{$arg[4]}{next})));
811 }
812 }
813 elsif ($arg[3] eq "logout") {
814 if (defined($username)) {
815 penalize($username,"logout");
816 }
817 else {
818 privmsg(gettext("You are not logged in."), $usernick);
819 }
820 }
821 elsif ($arg[3] eq "quest") {
822 if (!@{$quest{questers}}) {
823 privmsg(gettext("There is no active quest."),$usernick);
824 }
825 elsif ($quest{type} == 1) {
826 privmsg(sprintf(gettext("%s, and %s are on a quest to %s".
827 ". Quest to complete in %s."),
828 join(", ",(@{$quest{questers}})[0..2]),
829 $quest{questers}->[3],$quest{text},
830 duration($quest{qtime}-time()))
831 ,$usernick);
832 }
833 elsif ($quest{type} == 2) {
834 privmsg(sprintf(gettext("%s, and %s are on a quest to ".
835 "%s. Participants must first reach ".
836 "[%u,%u], then [%u,%u]."),
837 join(", ",(@{$quest{questers}})[0..2]),
838 $quest{questers}->[3],$quest{text},
839 $quest{p1}->[0],$quest{p1}->[1],
840 $quest{p2}->[0],$quest{p2}->[1]).
841 ($opts{mapurl}?sprintf(gettext(" See %s to monitor ".
842 "their journey's ".
843 "progress."),
844 $opts{mapurl}):""),$usernick);
845 }
846 }
847 elsif ($arg[3] eq "status" && $opts{statuscmd}) {
848 if (!defined($username)) {
849 privmsg(gettext("You are not logged in."), $usernick);
850 }
851 # argument is optional
852 elsif ($arg[4] && !exists($rps{$arg[4]})) {
853 privmsg(gettext("No such user."),$usernick);
854 }
855 elsif ($arg[4]) { # optional 'user' argument
856 privmsg("$arg[4]: Level $rps{$arg[4]}{level} ".
857 "$rps{$arg[4]}{class}; Status: O".
858 ($rps{$arg[4]}{online}?"n":"ff")."line; ".
859 "TTL: ".duration($rps{$arg[4]}{next})."; ".
860 "Idled: ".duration($rps{$arg[4]}{idled}).
861 "; Item sum: ".itemsum($arg[4]),$usernick);
862 }
863 else { # no argument, look up this user
864 privmsg("$username: Level $rps{$username}{level} ".
865 "$rps{$username}{class}; Status: O".
866 ($rps{$username}{online}?"n":"ff")."line; ".
867 "TTL: ".duration($rps{$username}{next})."; ".
868 "Idled: ".duration($rps{$username}{idled})."; ".
869 "Item sum: ".itemsum($username),$usernick);
870 }
871 }
872 elsif ($arg[3] eq "whoami") {
873 if (!defined($username)) {
874 privmsg(gettext("You are not logged in."), $usernick);
875 }
876 else {
877 privmsg(sprintf(gettext("You are %s, the level %u %s. ".
878 "Next level in %s"),
879 $username,$rps{$username}{level},
880 $rps{$username}{class},
881 duration($rps{$username}{next})), $usernick);
882 }
883 }
884 elsif ($arg[3] eq "newpass") {
885 if (!defined($username)) {
886 privmsg(gettext("You are not logged in."), $usernick)
887 }
888 elsif (!defined($arg[4])) {
889 privmsg(gettext("Try: NEWPASS <new password>"), $usernick);
890 }
891 else {
892 $rps{$username}{pass} = crypt($arg[4],mksalt());
893 privmsg(gettext("Your password was changed."),$usernick);
894 }
895 }
896 elsif ($arg[3] eq "align") {
897 if (!defined($username)) {
898 privmsg(gettext("You are not logged in."), $usernick)
899 }
900 elsif (!defined($arg[4]) || (lc($arg[4]) ne "good" &&
901 lc($arg[4]) ne "neutral" && lc($arg[4]) ne "evil")) {
902 privmsg(gettext("Try: ALIGN <good|neutral|evil>"),
903 $usernick);
904 }
905 else {
906 $rps{$username}{alignment} = substr(lc($arg[4]),0,1);
907 chanmsg(sprintf(gettext("%s has changed alignment to: "),
908 $username).gettext(lc($arg[4])).".");
909 privmsg(gettext("Your alignment was changed to ").
910 gettext(lc($arg[4])).".", $usernick);
911 }
912 }
913 elsif ($arg[3] eq "removeme") {
914 if (!defined($username)) {
915 privmsg(gettext("You are not logged in."), $usernick)
916 }
917 else {
918 privmsg(sprintf(gettext("Account %s removed."),$username),
919 $usernick);
920 chanmsg(sprintf(gettext("%s removed his account, %s, the %s".
921 "."),
922 $arg[0],$username,$rps{$username}{class}));
923 delete($rps{$username});
924 }
925 }
926 elsif ($arg[3] eq "help") {
927 if (!ha($username)) {
928 privmsg(sprintf(gettext("For information on IRPG bot ".
929 "commands, see %s"), $opts{helpurl}),
930 $usernick);
931 }
932 else {
933 privmsg(sprintf(gettext("Help URL is %s"),$opts{helpurl}),
934 $usernick, 1);
935 privmsg(sprintf(gettext("Admin commands URL is %s"),
936 $opts{admincommurl}), $usernick, 1);
937 }
938 }
939 elsif ($arg[3] eq "die") {
940 if (!ha($username)) {
941 privmsg(sprintf(gettext("You do not have access to %s."),
942 "DIE"), $usernick);
943 }
944 else {
945 $opts{reconnect} = 0;
946 writedb();
947 sts(sprintf(gettext("QUIT :DIE from %s"),$arg[0]),1);
948 }
949 }
950 elsif ($arg[3] eq "reloaddb") {
951 if (!ha($username)) {
952 privmsg(sprintf(gettext("You do not have access to %s."),
953 "RELOADDB"), $usernick);
954 }
955 elsif (!$pausemode) {
956 privmsg(gettext("ERROR: Can only use LOADDB while in ".
957 "PAUSE mode."), $usernick, 1);
958 }
959 else {
960 loaddb();
961 privmsg(sprintf(gettext("Reread player database file; %u ".
962 "accounts loaded."),
963 scalar(keys(%rps))), $usernick,1);
964 }
965 }
966 elsif ($arg[3] eq "backup") {
967 if (!ha($username)) {
968 privmsg(sprintf(gettext("You do not have access to %s."),
969 "BACKUP"), $usernick);
970 }
971 else {
972 backup();
973 privmsg(sprintf(gettext("%s copied to .dbbackup/%s"),
974 $opts{dbfile},$opts{dbfile}.time()),
975 $usernick,1);
976 }
977 }
978 elsif ($arg[3] eq "pause") {
979 if (!ha($username)) {
980 privmsg(sprintf(gettext("You do not have access to %s."),
981 "PAUSE"), $usernick);
982 }
983 else {
984 $pausemode = $pausemode ? 0 : 1;
985 privmsg(sprintf(gettext("PAUSE_MODE set to %s."),$pausemode),
986 $usernick,1);
987 }
988 }
989 elsif ($arg[3] eq "silent") {
990 if (!ha($username)) {
991 privmsg(sprintf(gettext("You do not have access to %s."),
992 "SILENT"), $usernick);
993 }
994 elsif (!defined($arg[4]) || $arg[4] < 0 || $arg[4] > 3) {
995 privmsg(gettext("Try: SILENT <mode>"), $usernick,1);
996 }
997 else {
998 $silentmode = $arg[4];
999 privmsg(sprintf(gettext("SILENT_MODE set to %s."),
1000 $silentmode), $usernick,1);
1001 }
1002 }
1003 elsif ($arg[3] eq "jump") {
1004 if (!ha($username)) {
1005 privmsg(sprintf(gettext("You do not have access to %s."),
1006 "JUMP"), $usernick);
1007 }
1008 elsif (!defined($arg[4])) {
1009 privmsg(gettext("Try: JUMP <server[:port]>"), $usernick, 1);
1010 }
1011 else {
1012 writedb();
1013 sts(sprintf(gettext("QUIT :JUMP to %s from %s"),
1014 $arg[4],$arg[0]));
1015 unshift(@{$opts{servers}},$arg[4]);
1016 close($sock);
1017 sleep(3);
1018 goto CONNECT;
1019 }
1020 }
1021 elsif ($arg[3] eq "restart") {
1022 if (!ha($username)) {
1023 privmsg(sprintf(gettext("You do not have access to %s."),
1024 "RESTART"), $usernick);
1025 }
1026 else {
1027 writedb();
1028 sts(sprintf(gettext("QUIT :RESTART from %s"),$arg[0]),1);
1029 close($sock);
1030 exec("perl $0");
1031 }
1032 }
1033 elsif ($arg[3] eq "clearq") {
1034 if (!ha($username)) {
1035 privmsg(sprintf(gettext("You do not have access to %s."),
1036 "CLEARQ"), $usernick);
1037 }
1038 else {
1039 undef(@queue);
1040 chanmsg(sprintf(gettext("Outgoing message queue cleared by ".
1041 "%s."),$arg[0]));
1042 privmsg(gettext("Outgoing message queue cleared."),
1043 $usernick,1);
1044 }
1045 }
1046 elsif ($arg[3] eq "info") {
1047 my $info;
1048 if (!ha($username) && $opts{allowuserinfo}) {
1049 $info = sprintf(gettext("IRPG bot v%s by jotun, ".
1050 "http://idlerpg.net/. On via ".
1051 "server: %s. Admins online: %s."),
1052 $version,$opts{servers}->[0],
1053 join(", ", map { $rps{$_}{nick} }
1054 grep { $rps{$_}{isadmin} &&
1055 $rps{$_}{online} } keys(%rps)));
1056 privmsg($info, $usernick);
1057 }
1058 elsif (!ha($username) && !$opts{allowuserinfo}) {
1059 privmsg(sprintf(gettext("You do not have access to %s."),
1060 "INFO"), $usernick);
1061 }
1062 else {
1063 my $queuedbytes = 0;
1064 $queuedbytes += (length($_)+2) for @queue; # +2 = \r\n
1065 $info = sprintf(gettext(
1066 "%.2fkb sent, %.2fkb received in %s. %d IRPG users ".
1067 "online of %d total users. %d accounts created since ".
1068 "startup. PAUSE_MODE is %d, SILENT_MODE is %d. ".
1069 "Outgoing queue is %d bytes in %d items. On via: %s. ".
1070 "Admins online: %s."),
1071 $outbytes/1024,
1072 $inbytes/1024,
1073 duration(time()-$^T),
1074 scalar(grep { $rps{$_}{online} } keys(%rps)),
1075 scalar(keys(%rps)),
1076 $registrations,
1077 $pausemode,
1078 $silentmode,
1079 $queuedbytes,
1080 scalar(@queue),
1081 $opts{servers}->[0],
1082 join(", ",map { $rps{$_}{nick} }
1083 grep { $rps{$_}{isadmin} && $rps{$_}{online} }
1084 keys(%rps)));
1085 privmsg($info, $usernick, 1);
1086 }
1087 }
1088 elsif ($arg[3] eq "login") {
1089 if (defined($username)) {
1090 notice(sprintf(gettext("Sorry, you are already online as ".
1091 "%s."),$username), $usernick);
1092 }
1093 else {
1094 if ($#arg < 5 || $arg[5] eq "") {
1095 notice(gettext("Try: LOGIN <username> <password>"),
1096 $usernick);
1097 }
1098 elsif (!exists $rps{$arg[4]}) {
1099 notice(gettext("Sorry, no such account name. Note that ".
1100 "account names are case sensitive."),
1101 $usernick);
1102 }
1103 elsif (!exists $onchan{$usernick}) {
1104 notice(sprintf(gettext("Sorry, you're not in %s."),
1105 $opts{botchan}), $usernick);
1106 }
1107 elsif ($rps{$arg[4]}{pass} ne
1108 crypt($arg[5],$rps{$arg[4]}{pass})) {
1109 notice(gettext("Wrong password."), $usernick);
1110 }
1111 else {
1112 if ($opts{voiceonlogin}) {
1113 sts("MODE $opts{botchan} +v :$usernick");
1114 }
1115 $rps{$arg[4]}{online} = 1;
1116 $rps{$arg[4]}{nick} = $usernick;
1117 $rps{$arg[4]}{userhost} = $arg[0];
1118 $rps{$arg[4]}{lastlogin} = time();
1119 chanmsg(sprintf(gettext("%s, the level %u %s, is now ".
1120 "online from nickname %s. Next ".
1121 "level in %s."),
1122 $arg[4],$rps{$arg[4]}{level},
1123 $rps{$arg[4]}{class},$usernick,
1124 duration($rps{$arg[4]}{next})));
1125 notice(gettext("Logon successful. Next level in ").
1126 duration($rps{$arg[4]}{next}).".", $usernick);
1127 }
1128 }
1129 }
1130 }
1131 # penalize returns true if user was online and successfully penalized.
1132 # if the user is not logged in, then penalize() fails. so, if user is
1133 # offline, and they say something including "http:", and they've been on
1134 # the channel less than 90 seconds, and the http:-style ban is on, then
1135 # check to see if their url is in @{$opts{okurl}}. if not, kickban them
1136 elsif (!penalize($username,"privmsg",length("@arg[3..$#arg]")) &&
1137 index(lc("@arg[3..$#arg]"),"http:") != -1 &&
1138 (time()-$onchan{$usernick}) < 90 && $opts{doban}) {
1139 my $isokurl = 0;
1140 for (@{$opts{okurl}}) {
1141 if (index(lc("@arg[3..$#arg]"),lc($_)) != -1) { $isokurl = 1; }
1142 }
1143 if (!$isokurl) {
1144 sts("MODE $opts{botchan} +b $arg[0]");
1145 sts("KICK $opts{botchan} $usernick :No advertising; ban will ".
1146 "be lifted within the hour.");
1147 push(@bans,$arg[0]) if @bans < 12;
1148 }
1149 }
1150 }
1151}
1152
1153sub sts { # send to server
1154 my($text,$skipq) = @_;
1155 if ($skipq) {
1156 if ($sock) {
1157 print $sock "$text\r\n";
1158 $outbytes += length($text) + 2;
1159 debug("-> $text");
1160 }
1161 else {
1162 # something is wrong. the socket is closed. clear the queue
1163 undef(@queue);
1164 debug("\$sock isn't writeable in sts(), cleared outgoing queue.\n");
1165 return;
1166 }
1167 }
1168 else {
1169 push(@queue,$text);
1170 debug(sprintf("(q%03d) = %s\n",$#queue,$text));
1171 }
1172}
1173
1174sub fq { # deliver message(s) from queue
1175 if (!@queue) {
1176 ++$freemessages if $freemessages < 4;
1177 return undef;
1178 }
1179 my $sentbytes = 0;
1180 for (0..$freemessages) {
1181 last() if !@queue; # no messages left to send
1182 # lower number of "free" messages we have left
1183 my $line=shift(@queue);
1184 # if we have already sent one message, and the next message to be sent
1185 # plus the previous messages we have sent this call to fq() > 768 bytes,
1186 # then requeue this message and return. we don't want to flood off,
1187 # after all
1188 if ($_ != 0 && (length($line)+$sentbytes) > 768) {
1189 unshift(@queue,$line);
1190 last();
1191 }
1192 if ($sock) {
1193 debug("(fm$freemessages) -> $line");
1194 --$freemessages if $freemessages > 0;
1195 print $sock "$line\r\n";
1196 $sentbytes += length($line) + 2;
1197 }
1198 else {
1199 undef(@queue);
1200 debug("Disconnected: cleared outgoing message queue.");
1201 last();
1202 }
1203 $outbytes += length($line) + 2;
1204 }
1205}
1206
1207sub ttl { # return ttl
1208 my $lvl = shift;
1209 return ($opts{rpbase} * ($opts{rpstep}**$lvl)) if $lvl <= 60;
1210 return (($opts{rpbase} * ($opts{rpstep}**60))
1211 + (86400*($lvl - 60)));
1212}
1213
1214sub penttl { # return ttl with $opts{rppenstep}
1215 my $lvl = shift;
1216 return ($opts{rpbase} * ($opts{rppenstep}**$lvl)) if $lvl <= 60;
1217 return (($opts{rpbase} * ($opts{rppenstep}**60))
1218 + (86400*($lvl - 60)));
1219}
1220
1221sub duration { # return human duration of seconds
1222 my $s = shift;
1223 return "NA ($s)" if $s !~ /^\d+$/;
1224 return sprintf(ngettext("%d day, %02d:%02d:%02d",
1225 "%d days, %02d:%02d:%02d",int($s/86400)),
1226 $s/86400,($s%86400)/3600,($s%3600)/60,($s%60));
1227}
1228
1229sub ts { # timestamp
1230 my @ts = localtime(time());
1231 return sprintf("[%02d/%02d/%02d %02d:%02d:%02d] ",
1232 $ts[4]+1,$ts[3],$ts[5]%100,$ts[2],$ts[1],$ts[0]);
1233}
1234
1235sub hog { # summon the hand of god
1236 my @players = grep { $rps{$_}{online} } keys(%rps);
1237 my $player = $players[rand(@players)];
1238 my $win = int(rand(5));
1239 my $time = int(((5 + int(rand(71)))/100) * $rps{$player}{next});
1240 if ($win) {
1241 chanmsg(clog(sprintf(gettext("Verily I say unto thee, the Heavens have ".
1242 "burst forth, and the blessed hand of God ".
1243 "carried %s %s toward level %u."),
1244 $player,duration($time),($rps{$player}{level}+1))));
1245 $rps{$player}{next} -= $time;
1246 }
1247 else {
1248 chanmsg(clog(sprintf(gettext("Thereupon He stretched out His little ".
1249 "finger among them and consumed %s with ".
1250 "fire, slowing the heathen %s from level ".
1251 "%u."),
1252 $player,duration($time),($rps{$player}{level}+1))));
1253 $rps{$player}{next} += $time;
1254 }
1255 chanmsg(sprintf(gettext("%s reaches next level in %s."),
1256 $player,duration($rps{$player}{next})));
1257}
1258
1259sub rpcheck { # check levels, update database
1260 # check splits hash to see if any split users have expired
1261 checksplits() if $opts{detectsplits};
1262 # send out $freemessages lines of text from the outgoing message queue
1263 fq();
1264 # clear registration limiting
1265 $lastreg = 0;
1266 my $online = scalar(grep { $rps{$_}{online} } keys(%rps));
1267 # there's really nothing to do here if there are no online users
1268 return unless $online;
1269 my $onlineevil = scalar(grep { $rps{$_}{online} &&
1270 $rps{$_}{alignment} eq "e" } keys(%rps));
1271 my $onlinegood = scalar(grep { $rps{$_}{online} &&
1272 $rps{$_}{alignment} eq "g" } keys(%rps));
1273 if (!$opts{noscale}) {
1274 if (rand((20*86400)/$opts{self_clock}) < $online) { hog(); }
1275 if (rand((24*86400)/$opts{self_clock}) < $online) { team_battle(); }
1276 if (rand((8*86400)/$opts{self_clock}) < $online) { calamity(); }
1277 if (rand((4*86400)/$opts{self_clock}) < $online) { godsend(); }
1278 }
1279 else {
1280 hog() if rand(4000) < 1;
1281 team_battle() if rand(4000) < 1;
1282 calamity() if rand(4000) < 1;
1283 godsend() if rand(2000) < 1;
1284 }
1285 if (rand((8*86400)/$opts{self_clock}) < $onlineevil) { evilness(); }
1286 if (rand((12*86400)/$opts{self_clock}) < $onlinegood) { goodness(); }
1287 if (rand((10*86400)/$opts{self_clock}) < 1) { war(); }
1288
1289 moveplayers();
1290 process_items();
1291
1292 # statements using $rpreport do not bother with scaling by the clock because
1293 # $rpreport is adjusted by the number of seconds since last rpcheck()
1294 if (($rpreport%120 < $oldrpreport%120) && $opts{writequestfile}) { writequestfile(); }
1295 if (time() > $quest{qtime}) {
1296 if (!@{$quest{questers}}) { quest(); }
1297 elsif ($quest{type} == 1) {
1298 chanmsg(clog(sprintf(gettext("%s, and %s have blessed the realm by ".
1299 "completing their quest! 25%% of their ".
1300 "burden is eliminated."),
1301 join(", ",(@{$quest{questers}})[0..2]),
1302 $quest{questers}->[3])));
1303 for (@{$quest{questers}}) {
1304 $rps{$_}{next} = int($rps{$_}{next} * .75);
1305 }
1306 undef(@{$quest{questers}});
1307 $quest{qtime} = time() + 21600;
1308 writequestfile();
1309 }
1310 # quest type 2 awards are handled in moveplayers()
1311 }
1312 if ($rpreport && ($rpreport%36000 < $oldrpreport%36000)) { # 10 hours
1313 my @u = sort { $rps{$b}{level} <=> $rps{$a}{level} ||
1314 $rps{$a}{next} <=> $rps{$b}{next} } keys(%rps);
1315 chanmsg(gettext("Idle RPG Top Players:")) if @u;
1316 for my $i (0..2) {
1317 $#u >= $i and
1318 chanmsg(sprintf(gettext("%s, the level %u %s, is #%u! Next level in".
1319 " %s."),
1320 $u[$i],$rps{$u[$i]}{level},
1321 $rps{$u[$i]}{class},($i + 1),
1322 (duration($rps{$u[$i]}{next}))));
1323 }
1324 backup();
1325 }
1326 if (($rpreport%3600 < $oldrpreport%3600) && $rpreport) { # 1 hour
1327 my @players = grep { $rps{$_}{online} &&
1328 $rps{$_}{level} > 44 } keys(%rps);
1329 # 20% of all players must be level 45+
1330 if ((scalar(@players)/scalar(grep { $rps{$_}{online} } keys(%rps))) > .15) {
1331 challenge_opp($players[int(rand(@players))]);
1332 }
1333 while (@bans) {
1334 sts("MODE $opts{botchan} -bbbb :@bans[0..3]");
1335 splice(@bans,0,4);
1336 }
1337 }
1338 if ($rpreport%1800 < $oldrpreport%1800) { # 30 mins
1339 if ($opts{botnick} ne $primnick) {
1340 sts($opts{botghostcmd}) if $opts{botghostcmd};
1341 sts("NICK $primnick");
1342 }
1343 }
1344 if (($rpreport%600 < $oldrpreport%600) && $pausemode) { # warn every 10m
1345 chanmsg(gettext("WARNING: Cannot write database in PAUSE mode!"));
1346 }
1347 # do not write in pause mode, and do not write if not yet connected. (would
1348 # log everyone out if the bot failed to connect. $lasttime = time() on
1349 # successful join to $opts{botchan}, initial value is 1). if fails to open
1350 # $opts{dbfile}, will not update $lasttime and so should have correct values
1351 # on next rpcheck().
1352 if ($lasttime != 1) {
1353 my $curtime=time();
1354 for my $k (keys(%rps)) {
1355 if ($rps{$k}{online} && exists $rps{$k}{nick} &&
1356 $rps{$k}{nick} && exists $onchan{$rps{$k}{nick}}) {
1357 $rps{$k}{next} -= ($curtime - $lasttime);
1358 $rps{$k}{idled} += ($curtime - $lasttime);
1359 if ($rps{$k}{next} < 1) {
1360 my $ttl = int(ttl($rps{$k}{level}));
1361 $rps{$k}{level}++;
1362 $rps{$k}{next} += $ttl;
1363 chanmsg(sprintf(gettext("%s, the %s, has attained level ".
1364 "%u! Next level in %s."),
1365 $k,$rps{$k}{class},$rps{$k}{level},
1366 duration($ttl)));
1367 find_item($k);
1368 challenge_opp($k);
1369 }
1370 }
1371 # attempt to make sure this is an actual user, and not just an
1372 # artifact of a bad PEVAL
1373 }
1374 if (!$pausemode && ($rpreport%60 < $oldrpreport%60)) { writedb(); }
1375 $oldrpreport = $rpreport;
1376 $rpreport += $curtime - $lasttime;
1377 $lasttime = $curtime;
1378 }
1379}
1380
1381sub war { # let the four quadrants battle
1382 my @players = grep { $rps{$_}{online} } keys(%rps);
1383 my @quadrantname = ("Northeast", "Southeast", "Southwest", "Northwest");
1384 my %quadrant = ();
1385 my @sum = (0,0,0,0,0);
1386 # get quadrant for each player and item sum per quadrant
1387 for my $k (@players) {
1388 # "quadrant" 4 is for players in the middle
1389 $quadrant{$k} = 4;
1390 if (2 * $rps{$k}{y} + 1 < $opts{mapy}) {
1391 $quadrant{$k} = 3 if (2 * $rps{$k}{x} + 1 < $opts{mapx});
1392 $quadrant{$k} = 0 if (2 * $rps{$k}{x} + 1 > $opts{mapx});
1393 }
1394 elsif (2 * $rps{$k}{y} + 1 > $opts{mapy})
1395 {
1396 $quadrant{$k} = 2 if (2 * $rps{$k}{x} + 1 < $opts{mapx});
1397 $quadrant{$k} = 1 if (2 * $rps{$k}{x} + 1 > $opts{mapx});
1398 }
1399 $sum[$quadrant{$k}] += itemsum($k);
1400 }
1401 # roll for each quadrant
1402 my @roll = (0,0,0,0);
1403 $roll[$_] = int(rand($sum[$_])) foreach (0..3);
1404 # winner if value >= maximum value of both direct neighbors, "quadrant" 4 never wins
1405 my @iswinner = map($_ < 4 && $roll[$_] >= $roll[($_ + 1) % 4] &&
1406 $roll[$_] >= $roll[($_ + 3) % 4],(0..4));
1407 my @winners = map("the $quadrantname[$_] [$roll[$_]/$sum[$_]]",grep($iswinner[$_],(0..3)));
1408 # construct text from winners array
1409 my $winnertext = "";
1410 $winnertext = pop(@winners) if (scalar(@winners) > 0);
1411 $winnertext = pop(@winners)." and $winnertext" if (scalar(@winners) > 0);
1412 $winnertext = pop(@winners).", $winnertext" while (scalar(@winners) > 0);
1413 $winnertext = "has shown the power of $winnertext" if ($winnertext ne "");
1414 # loser if value < minimum value of both direct neighbors, "quadrant" 4 never loses
1415 my @isloser = map($_ < 4 && $roll[$_] < $roll[($_ + 1) % 4] &&
1416 $roll[$_] < $roll[($_ + 3) % 4],(0..4));
1417 my @losers = map("the $quadrantname[$_] [$roll[$_]/$sum[$_]]",grep($isloser[$_],(0..3)));
1418 # construct text from losers array
1419 my $losertext = "";
1420 $losertext = pop(@losers) if (scalar(@losers) > 0);
1421 $losertext = pop(@losers)." and $losertext" if (scalar(@losers) > 0);
1422 $losertext = pop(@losers).", $losertext" while (scalar(@losers) > 0);
1423 $losertext = "led $losertext to perdition" if ($losertext ne "");
1424 # build array of text for neutrals
1425 my @neutrals = map("the $quadrantname[$_] [$roll[$_]/$sum[$_]]",grep(!$iswinner[$_] && !$isloser[$_],(0..3)));
1426 # construct text from neutrals array
1427 my $neutraltext = "";
1428 $neutraltext = pop(@neutrals) if (scalar(@neutrals) > 0);
1429 $neutraltext = pop(@neutrals)." and $neutraltext" if (scalar(@neutrals) > 0);
1430 $neutraltext = pop(@neutrals).", $neutraltext" while (scalar(@neutrals) > 0);
1431 $neutraltext = " The diplomacy of $neutraltext was admirable." if ($neutraltext ne "");
1432 if ($winnertext ne "" && $losertext ne "") {
1433 # there are winners and losers
1434 chanmsg(clog("The war between the four parts of the realm ".
1435 "$winnertext, whereas it $losertext.$neutraltext"));
1436 }
1437 elsif ($winnertext eq "" && $losertext eq "") {
1438 # there are only neutrals
1439 chanmsg(clog("The war between the four parts of the realm ".
1440 "was well-balanced.$neutraltext"));
1441 }
1442 else {
1443 # there are either winners or losers
1444 chanmsg(clog("The war between the four parts of the realm ".
1445 "$winnertext$losertext.$neutraltext"));
1446 }
1447 for my $k (@players) {
1448 # halve ttl of users in winning quadrant
1449 # users in "quadrant" 4 are not awarded or penalized
1450 $rps{$k}{next} = int($rps{$k}{next} / 2) if ($iswinner[$quadrant{$k}]);
1451 # double ttl of users in losing quadrant
1452 $rps{$k}{next} *= 2 if ($isloser[$quadrant{$k}]);
1453 }
1454}
1455
1456sub challenge_opp { # pit argument player against random player
1457 my $u = shift;
1458 if ($rps{$u}{level} < 25) { return unless rand(4) < 1; }
1459 my @opps = grep { $rps{$_}{online} && $u ne $_ } keys(%rps);
1460 return unless @opps;
1461 my $opp = $opps[int(rand(@opps))];
1462 $opp = $primnick if rand(@opps+1) < 1;
1463 my $mysum = itemsum($u,1);
1464 my $oppsum = itemsum($opp,1);
1465 my $myroll = int(rand($mysum));
1466 my $opproll = int(rand($oppsum));
1467 if ($myroll >= $opproll) {
1468 my $gain = ($opp eq $primnick)?20:int($rps{$opp}{level}/4);
1469 $gain = 7 if $gain < 7;
1470 $gain = int(($gain/100)*$rps{$u}{next});
1471 chanmsg(clog(sprintf(gettext("%s [%u/%u] has challenged %s [%u/%u] in ".
1472 "combat and won! %s is removed from ".
1473 "%1\$s\'s clock."),
1474 $u,$myroll,$mysum,$opp,$opproll,$oppsum,
1475 duration($gain))));
1476 $rps{$u}{next} -= $gain;
1477 chanmsg(sprintf(gettext("%s reaches next level in %s."),
1478 $u,duration($rps{$u}{next})));
1479 my $csfactor = $rps{$u}{alignment} eq "g" ? 50 :
1480 $rps{$u}{alignment} eq "e" ? 20 :
1481 35;
1482 if (rand($csfactor) < 1 && $opp ne $primnick) {
1483 $gain = int(((5 + int(rand(20)))/100) * $rps{$opp}{next});
1484 chanmsg(clog(sprintf(gettext("%s has dealt %s a Critical Strike! %s".
1485 " is added to %2\$s\'s clock."),
1486 $u,$opp,duration($gain))));
1487 $rps{$opp}{next} += $gain;
1488 chanmsg(sprintf(gettext("%s reaches next level in %s."),
1489 $opp,duration($rps{$opp}{next})));
1490 }
1491 elsif (rand(25) < 1 && $opp ne $primnick && $rps{$u}{level} > 19) {
1492 my @items = ("ring","amulet","charm","weapon","helm","tunic",
1493 "pair of gloves","set of leggings","shield",
1494 "pair of boots");
1495 my $type = $items[rand(@items)];
1496 if (itemlevel($rps{$opp}{item}{$type}) > itemlevel($rps{$u}{item}{$type})) {
1497 chanmsg(clog(sprintf(gettext("In the fierce battle, %s dropped ".
1498 "his level %u %s! %s picks it up, ".
1499 "tossing his old level %u %3\$s to".
1500 " %1\$s."),
1501 $opp,itemlevel($rps{$opp}{item}{$type}),
1502 gettext($type),$u,
1503 itemlevel($rps{$u}{item}{$type}))));
1504 my $tempitem = $rps{$u}{item}{$type};
1505 $rps{$u}{item}{$type}=$rps{$opp}{item}{$type};
1506 $rps{$opp}{item}{$type} = $tempitem;
1507 }
1508 }
1509 }
1510 else {
1511 my $gain = ($opp eq $primnick)?10:int($rps{$opp}{level}/7);
1512 $gain = 7 if $gain < 7;
1513 $gain = int(($gain/100)*$rps{$u}{next});
1514 chanmsg(clog(sprintf(gettext("%s [%u/%u] has challenged %s [%u/%u] in ".
1515 "combat and lost! %s is added to %1\$s\'s ".
1516 "clock."),$u,$myroll,$mysum,$opp,$opproll,
1517 $oppsum,duration($gain))));
1518 $rps{$u}{next} += $gain;
1519 chanmsg(sprintf(gettext("%s reaches next level in %s."),
1520 $u,duration($rps{$u}{next})));
1521 }
1522}
1523
1524sub team_battle { # pit three players against three other players
1525 my @opp = grep { $rps{$_}{online} } keys(%rps);
1526 return if @opp < 6;
1527 # choose random point
1528 my $x = int(rand($opts{mapx}));
1529 my $y = int(rand($opts{mapy}));
1530 my %polar = ();
1531 for my $player (@opp) {
1532 my $dx = $rps{$player}{x}-$x;
1533 my $dy = $rps{$player}{y}-$y;
1534 # polar coordinates
1535 $polar{$player}{r} = sqrt($dx*$dx+$dy*$dy);
1536 $polar{$player}{phi} = atan2($dy,$dx)
1537 }
1538 # sort by radius
1539 my @sorted = sort { $polar{$a}{r} <=> $polar{$b}{r} } keys %polar;
1540 # get players at least as close as #6
1541 @sorted = grep { $polar{$_}{r} <= $polar{$sorted[5]}{r} } @sorted;
1542 # pick 6 random players from these
1543 @opp = ();
1544 for (my $i = 0; $i < 6; $i++) {
1545 $opp[$i] = splice(@sorted,int(rand(@sorted)),1);
1546 }
1547 # sort by angle
1548 @opp = sort { $polar{$a}{phi} <=> $polar{$b}{phi} } @opp;
1549 # shift splitting position
1550 my $rot = int(rand(6));
1551 @opp = @opp[$rot..5,0..$rot-1];
1552 my $mysum = itemsum($opp[0],1) + itemsum($opp[1],1) + itemsum($opp[2],1);
1553 my $oppsum = itemsum($opp[3],1) + itemsum($opp[4],1) + itemsum($opp[5],1);
1554 my $gain = $rps{$opp[0]}{next};
1555 for my $p (1,2) {
1556 $gain = $rps{$opp[$p]}{next} if $gain > $rps{$opp[$p]}{next};
1557 }
1558 $gain = int($gain*.20);
1559 my $myroll = int(rand($mysum));
1560 my $opproll = int(rand($oppsum));
1561 if ($myroll >= $opproll) {
1562 chanmsg(clog(sprintf(gettext("%s, %s and %s [%u/%u] have team battled ".
1563 "%s, %s and %s [%u/%u] at [%u,%u] and won!".
1564 " %s is removed from their clocks."),
1565 $opp[0],$opp[1],$opp[2],$myroll,$mysum,
1566 $opp[3],$opp[4],$opp[5],$opproll,$oppsum,
1567 $x,$y,duration($gain))));
1568 $rps{$opp[0]}{next} -= $gain;
1569 $rps{$opp[1]}{next} -= $gain;
1570 $rps{$opp[2]}{next} -= $gain;
1571 }
1572 else {
1573 chanmsg(clog(sprintf(gettext("%s, %s and %s [%u/%u] have team battled ".
1574 "%s, %s and %s [%u/%u] at [%u,%u] and ".
1575 "lost! %s is added to their clocks."),
1576 $opp[0],$opp[1],$opp[2],$myroll,$mysum,
1577 $opp[3],$opp[4],$opp[5],$opproll,$oppsum,
1578 $x,$y,duration($gain))));
1579 $rps{$opp[0]}{next} += $gain;
1580 $rps{$opp[1]}{next} += $gain;
1581 $rps{$opp[2]}{next} += $gain;
1582 }
1583}
1584
1585sub itemlevel {
1586 my $level = shift;
1587 $level =~ s/\D$//;
1588 return $level;
1589}
1590
1591sub itemtag {
1592 my $level = shift;
1593 $level =~ s/^\d+//;
1594 return $level;
1595}
1596
1597sub process_items { # decrease items lying around
1598 my $curtime = time();
1599
1600 for my $xy (keys(%mapitems)) {
1601 for my $i (0..$#{$mapitems{$xy}}) {
1602 my $level = $mapitems{$xy}[$i]{level};
1603 my $ttl = int($opts{rpitembase} * ttl(itemlevel($level)) / 600);
1604 if ($mapitems{$xy}[$i]{lasttime} + $ttl <= $curtime ) {
1605 $mapitems{$xy}[$i]{lasttime} += $ttl;
1606 $mapitems{$xy}[$i]{level} = downgrade_item($level);
1607 splice(@{$mapitems{$xy}},$i,1) if ($mapitems{$xy}[$i]{level} == 0);
1608 }
1609 }
1610 }
1611}
1612
1613sub drop_item { # drop item on the map
1614 my $u = shift;
1615 my $type = shift;
1616 my $level = shift;
1617 my $ulevel = itemlevel($level);
1618 my $x = $rps{$u}{x};
1619 my $y = $rps{$u}{y};
1620
1621 push(@{$mapitems{"$x:$y"}},{type=>$type,level=>$level,lasttime=>time()}) if ($ulevel > 0);
1622}
1623
1624sub downgrade_item { # returns the decreased item level
1625 my $level = shift;
1626 my $ulevel = itemlevel($level);
1627 my $tag = itemtag($level);
1628 my %minlevel = (''=>0,a=>50,h=>50,b=>75,d=>150,e=>175,f=>250,g=>300);
1629 $tag = '' if ($ulevel == $minlevel{$tag});
1630 $ulevel-- if ($ulevel > 0);
1631 return "$ulevel$tag";
1632}
1633
1634sub exchange_item { # take item and drop the current
1635 my $u = shift;
1636 my $type = shift;
1637 my $level = shift;
1638 my $ulevel = itemlevel($level);
1639 my $tag = itemtag($level);
1640
1641 if ($tag eq 'a') {
1642 notice(sprintf(gettext("The light of the gods shines down upon you! ".
1643 "You have found the level %u Mattt's ".
1644 "Omniscience Grand Crown! Your enemies fall ".
1645 "before you as you anticipate their every move."),
1646 $ulevel),$rps{$u}{nick});
1647 }
1648 elsif ($tag eq 'b') {
1649 notice(sprintf(gettext("The light of the gods shines down upon you! ".
1650 "You have found the level %u Res0's ".
1651 "Protectorate Plate Mail! Your enemies cower in".
1652 " fear as their attacks have no effect on you."),
1653 $ulevel),$rps{$u}{nick});
1654 }
1655 elsif ($tag eq 'c') {
1656 notice(sprintf(gettext("The light of the gods shines down upon you! ".
1657 "You have found the level %u Dwyn's Storm Magic ".
1658 "Amulet! Your enemies are swept away by an".
1659 "elemental fury before the war has even begun"),
1660 $ulevel),$rps{$u}{nick});
1661 }
1662 elsif ($tag eq 'd') {
1663 notice(sprintf(gettext("The light of the gods shines down upon you! ".
1664 "You have found the level %u Jotun's Fury ".
1665 "Colossal Sword! Your enemies' hatred is brought".
1666 "to a quick end as you arc your wrist, dealing ".
1667 "the crushing blow."),$ulevel),$rps{$u}{nick});
1668 }
1669 elsif ($tag eq 'e') {
1670 notice(sprintf(gettext("The light of the gods shines down upon you! ".
1671 "You have found the level %u Drdink's Cane of ".
1672 "Blind Rage! Your enemies are tossed aside as ".
1673 "you blindly swing your arm around hitting ".
1674 "stuff."),$ulevel),$rps{$u}{nick});
1675 }
1676 elsif ($tag eq 'f') {
1677 notice(sprintf(gettext("The light of the gods shines down upon you! ".
1678 "You have found the level %u Mrquick's Magical ".
1679 "Boots of Swiftness! Your enemies are left ".
1680 "choking on your dust as you run from them ".
1681 "very, very quickly."),$ulevel),$rps{$u}{nick});
1682 }
1683 elsif ($tag eq 'g') {
1684 notice(sprintf(gettext("The light of the gods shines down upon you! ".
1685 "You have found the level %u Jeff's Cluehammer ".
1686 "of Doom! Your enemies are left with a sudden ".
1687 "and intense clarity of mind... even as you ".
1688 "relieve them of it."),$ulevel),$rps{$u}{nick});
1689 }
1690 elsif ($tag eq 'h') {
1691 notice(sprintf(gettext("The light of the gods shines down upon you! ".
1692 "You have found the level %u Juliet's Glorious ".
1693 "Ring of Sparkliness! You enemies are blinded ".
1694 "by both its glory and their greed as you bring ".
1695 "desolation upon them."),$ulevel),
1696 $rps{$u}{nick});
1697 }
1698 else {
1699 notice(sprintf(gettext("You found a level %u %s! Your current %2\$s is ".
1700 "only level %u, so it seems Luck is with you!"),
1701 $ulevel,gettext($type),itemlevel($rps{$u}{item}{$type})),
1702 $rps{$u}{nick});
1703 }
1704
1705 drop_item($u,$type,$rps{$u}{item}{$type});
1706 $rps{$u}{item}{$type} = $level;
1707}
1708
1709sub find_item { # find item for argument player
1710 my $u = shift;
1711 my @items = ("ring","amulet","charm","weapon","helm","tunic",
1712 "pair of gloves","set of leggings","shield","pair of boots");
1713 my $type = $items[rand(@items)];
1714 my $level = 1;
1715 my $ulevel;
1716 for my $num (1 .. int($rps{$u}{level}*1.5)) {
1717 if (rand(1.4**($num/4)) < 1) {
1718 $level = $num;
1719 }
1720 }
1721 if ($rps{$u}{level} >= 25 && rand(40) < 1) {
1722 $ulevel = 50+int(rand(25));
1723 if ($ulevel >= $level && $ulevel > itemlevel($rps{$u}{item}{helm})) {
1724 exchange_item($u,"helm",$ulevel."a");
1725 return;
1726 }
1727 }
1728 elsif ($rps{$u}{level} >= 25 && rand(40) < 1) {
1729 $ulevel = 50+int(rand(25));
1730 if ($ulevel >= $level && $ulevel > itemlevel($rps{$u}{item}{ring})) {
1731 exchange_item($u,"ring",$ulevel."h");
1732 return;
1733 }
1734 }
1735 elsif ($rps{$u}{level} >= 30 && rand(40) < 1) {
1736 $ulevel = 75+int(rand(25));
1737 if ($ulevel >= $level && $ulevel > itemlevel($rps{$u}{item}{tunic})) {
1738 exchange_item($u,"tunic",$ulevel."b");
1739 return;
1740 }
1741 }
1742 elsif ($rps{$u}{level} >= 35 && rand(40) < 1) {
1743 $ulevel = 100+int(rand(25));
1744 if ($ulevel >= $level && $ulevel > itemlevel($rps{$u}{item}{amulet})) {
1745 exchange_item($u,"amulet",$ulevel."c");
1746 return;
1747 }
1748 }
1749 elsif ($rps{$u}{level} >= 40 && rand(40) < 1) {
1750 $ulevel = 150+int(rand(25));
1751 if ($ulevel >= $level && $ulevel > itemlevel($rps{$u}{item}{weapon})) {
1752 exchange_item($u,"weapon",$ulevel."d");
1753 return;
1754 }
1755 }
1756 elsif ($rps{$u}{level} >= 45 && rand(40) < 1) {
1757 $ulevel = 175+int(rand(26));
1758 if ($ulevel >= $level && $ulevel > itemlevel($rps{$u}{item}{weapon})) {
1759 exchange_item($u,"weapon",$ulevel."e");
1760 return;
1761 }
1762 }
1763 elsif ($rps{$u}{level} >= 48 && rand(40) < 1) {
1764 $ulevel = 250+int(rand(51));
1765 if ($ulevel >= $level && $ulevel >
1766 itemlevel($rps{$u}{item}{"pair of boots"})) {
1767 exchange_item($u,"pair of boots",$ulevel."f");
1768 return;
1769 }
1770 }
1771 elsif ($rps{$u}{level} >= 52 && rand(40) < 1) {
1772 $ulevel = 300+int(rand(51));
1773 if ($ulevel >= $level && $ulevel > itemlevel($rps{$u}{item}{weapon})) {
1774 exchange_item($u,"weapon",$ulevel."g");
1775 return;
1776 }
1777 }
1778 if ($level > itemlevel($rps{$u}{item}{$type})) {
1779 exchange_item($u,$type,$level);
1780 }
1781 else {
1782 notice(sprintf(gettext("You found a level %u %s. Your current %2\$s is ".
1783 "level %3\$u, so it seems Luck is against you. ".
1784 "You toss the %2\$s."),
1785 $level,gettext($type),itemlevel($rps{$u}{item}{$type})),
1786 $rps{$u}{nick});
1787 drop_item($u,$type,$level);
1788 }
1789}
1790
1791sub loaddb { # load the players and items database
1792 backup();
1793 my $l;
1794 %rps = ();
1795 if (!open(RPS,$opts{dbfile}) && -e $opts{dbfile}) {
1796 sts("QUIT :loaddb() failed: $!");
1797 }
1798 while ($l=<RPS>) {
1799 chomp($l);
1800 next if $l =~ /^#/; # skip comments
1801 my @i = split("\t",$l);
1802 print Dumper(@i) if @i != 32;
1803 if (@i != 32) {
1804 sts("QUIT: Anomaly in loaddb(); line $. of $opts{dbfile} has ".
1805 "wrong fields (".scalar(@i).")");
1806 debug("Anomaly in loaddb(); line $. of $opts{dbfile} has wrong ".
1807 "fields (".scalar(@i).")",1);
1808 }
1809 if (!$sock) { # if not RELOADDB
1810 if ($i[8]) { $prev_online{$i[7]}=$i[0]; } # log back in
1811 }
1812 ($rps{$i[0]}{pass},
1813 $rps{$i[0]}{isadmin},
1814 $rps{$i[0]}{level},
1815 $rps{$i[0]}{class},
1816 $rps{$i[0]}{next},
1817 $rps{$i[0]}{nick},
1818 $rps{$i[0]}{userhost},
1819 $rps{$i[0]}{online},
1820 $rps{$i[0]}{idled},
1821 $rps{$i[0]}{x},
1822 $rps{$i[0]}{y},
1823 $rps{$i[0]}{pen_mesg},
1824 $rps{$i[0]}{pen_nick},
1825 $rps{$i[0]}{pen_part},
1826 $rps{$i[0]}{pen_kick},
1827 $rps{$i[0]}{pen_quit},
1828 $rps{$i[0]}{pen_quest},
1829 $rps{$i[0]}{pen_logout},
1830 $rps{$i[0]}{created},
1831 $rps{$i[0]}{lastlogin},
1832 $rps{$i[0]}{item}{amulet},
1833 $rps{$i[0]}{item}{charm},
1834 $rps{$i[0]}{item}{helm},
1835 $rps{$i[0]}{item}{"pair of boots"},
1836 $rps{$i[0]}{item}{"pair of gloves"},
1837 $rps{$i[0]}{item}{ring},
1838 $rps{$i[0]}{item}{"set of leggings"},
1839 $rps{$i[0]}{item}{shield},
1840 $rps{$i[0]}{item}{tunic},
1841 $rps{$i[0]}{item}{weapon},
1842 $rps{$i[0]}{alignment}) = (@i[1..7],($sock?$i[8]:0),@i[9..$#i]);
1843 }
1844 close(RPS);
1845 debug("loaddb(): loaded ".scalar(keys(%rps))." accounts, ".
1846 scalar(keys(%prev_online))." previously online.");
1847 if (!open(ITEMS,$opts{itemdbfile}) && -e $opts{itemdbfile}) {
1848 sts("QUIT :loaddb() failed: $!");
1849 }
1850 my $cnt = 0;
1851 %mapitems = ();
1852 while ($l=<ITEMS>) {
1853 chomp($l);
1854 next if $l =~ /^#/; # skip comments
1855 my @i = split("\t",$l);
1856 print Dumper(@i) if @i != 5;
1857 if (@i != 5) {
1858 sts("QUIT: Anomaly in loaddb(); line $. of $opts{itemdbfile} has ".
1859 "wrong fields (".scalar(@i).")");
1860 debug("Anomaly in loaddb(); line $. of $opts{itemdbfile} has wrong ".
1861 "fields (".scalar(@i).")",1);
1862 }
1863 my $curtime = time();
1864 push(@{$mapitems{"$i[0]:$i[1]"}},{type=>$i[2],level=>$i[3],lasttime=>$curtime-$i[4]});
1865 $cnt++;
1866 }
1867 close(ITEMS);
1868 debug("loaddb(): loaded $cnt items.");
1869}
1870
1871sub moveplayers {
1872 return unless $lasttime > 1;
1873 my $onlinecount = grep { $rps{$_}{online} } keys %rps;
1874 return unless $onlinecount;
1875 for (my $i=0;$i<$opts{self_clock};++$i) {
1876 # temporary hash to hold player positions, detect collisions
1877 my %positions = ();
1878 if ($quest{type} == 2 && @{$quest{questers}}) {
1879 my $allgo = 1; # have all users reached <p1|p2>?
1880 for (@{$quest{questers}}) {
1881 if ($quest{stage}==1) {
1882 if ($rps{$_}{x} != $quest{p1}->[0] ||
1883 $rps{$_}{y} != $quest{p1}->[1]) {
1884 $allgo=0;
1885 last();
1886 }
1887 }
1888 else {
1889 if ($rps{$_}{x} != $quest{p2}->[0] ||
1890 $rps{$_}{y} != $quest{p2}->[1]) {
1891 $allgo=0;
1892 last();
1893 }
1894 }
1895 }
1896 # all participants have reached point 1, now point 2
1897 if ($quest{stage}==1 && $allgo) {
1898 $quest{stage}=2;
1899 $allgo=0; # have not all reached p2 yet
1900 }
1901 elsif ($quest{stage} == 2 && $allgo) {
1902 chanmsg(clog(sprintf(gettext("%s, and %s have completed their ".
1903 "journey! 25%% of their burden is ".
1904 "eliminated."),
1905 join(", ",(@{$quest{questers}})[0..2]),
1906 $quest{questers}->[3])));
1907 for (@{$quest{questers}}) {
1908 $rps{$_}{next} = int($rps{$_}{next} * .75);
1909 }
1910 undef(@{$quest{questers}});
1911 $quest{qtime} = time() + 21600; # next quest starts in 6 hours
1912 $quest{type} = 1; # probably not needed
1913 writequestfile();
1914 }
1915 else {
1916 my(%temp,$player);
1917 # load keys of %temp with online users
1918 ++@temp{grep { $rps{$_}{online} } keys(%rps)};
1919 # delete questers from list
1920 delete(@temp{@{$quest{questers}}});
1921 while ($player = each(%temp)) {
1922 $rps{$player}{x} += int(rand(3))-1;
1923 $rps{$player}{y} += int(rand(3))-1;
1924 # if player goes over edge, wrap them back around
1925 if ($rps{$player}{x} > $opts{mapx}) { $rps{$player}{x}=0; }
1926 if ($rps{$player}{y} > $opts{mapy}) { $rps{$player}{y}=0; }
1927 if ($rps{$player}{x} < 0) { $rps{$player}{x}=$opts{mapx}; }
1928 if ($rps{$player}{y} < 0) { $rps{$player}{y}=$opts{mapy}; }
1929
1930 if (exists($positions{$rps{$player}{x}}{$rps{$player}{y}}) &&
1931 !$positions{$rps{$player}{x}}{$rps{$player}{y}}{battled}) {
1932 if ($rps{$positions{$rps{$player}{x}}{$rps{$player}{y}}{user}}{isadmin} &&
1933 !$rps{$player}{isadmin} && rand(100) < 1) {
1934 chanmsg(sprintf(gettext("%s encounters %s and bows".
1935 " humbly."),
1936 $player,
1937 $positions{$rps{$player}{x}}{$rps{$player}{y}}{user}));
1938 }
1939 if (rand($onlinecount) < 1) {
1940 $positions{$rps{$player}{x}}{$rps{$player}{y}}{battled}=1;
1941 collision_fight($player,
1942 $positions{$rps{$player}{x}}{$rps{$player}{y}}{user});
1943 }
1944 }
1945 else {
1946 $positions{$rps{$player}{x}}{$rps{$player}{y}}{battled}=0;
1947 $positions{$rps{$player}{x}}{$rps{$player}{y}}{user}=$player;
1948 }
1949 }
1950 for (@{$quest{questers}}) {
1951 if ($quest{stage} == 1) {
1952 if (rand(100) < 1) {
1953 if ($rps{$_}{x} != $quest{p1}->[0]) {
1954 $rps{$_}{x} += ($rps{$_}{x} < $quest{p1}->[0] ?
1955 1 : -1);
1956 }
1957 if ($rps{$_}{y} != $quest{p1}->[1]) {
1958 $rps{$_}{y} += ($rps{$_}{y} < $quest{p1}->[1] ?
1959 1 : -1);
1960 }
1961 }
1962 }
1963 elsif ($quest{stage}==2) {
1964 if (rand(100) < 1) {
1965 if ($rps{$_}{x} != $quest{p2}->[0]) {
1966 $rps{$_}{x} += ($rps{$_}{x} < $quest{p2}->[0] ?
1967 1 : -1);
1968 }
1969 if ($rps{$_}{y} != $quest{p2}->[1]) {
1970 $rps{$_}{y} += ($rps{$_}{y} < $quest{p2}->[1] ?
1971 1 : -1);
1972 }
1973 }
1974 }
1975 }
1976 }
1977 }
1978 else {
1979 for my $player (keys(%rps)) {
1980 next unless $rps{$player}{online};
1981 $rps{$player}{x} += int(rand(3))-1;
1982 $rps{$player}{y} += int(rand(3))-1;
1983 # if player goes over edge, wrap them back around
1984 if ($rps{$player}{x} > $opts{mapx}) { $rps{$player}{x} = 0; }
1985 if ($rps{$player}{y} > $opts{mapy}) { $rps{$player}{y} = 0; }
1986 if ($rps{$player}{x} < 0) { $rps{$player}{x} = $opts{mapx}; }
1987 if ($rps{$player}{y} < 0) { $rps{$player}{y} = $opts{mapy}; }
1988 if (exists($positions{$rps{$player}{x}}{$rps{$player}{y}}) &&
1989 !$positions{$rps{$player}{x}}{$rps{$player}{y}}{battled}) {
1990 if ($rps{$positions{$rps{$player}{x}}{$rps{$player}{y}}{user}}{isadmin} &&
1991 !$rps{$player}{isadmin} && rand(100) < 1) {
1992 chanmsg(sprintf(gettext("%s encounters %s and bows ".
1993 "humbly."),$player,
1994 $positions{$rps{$player}{x}}{$rps{$player}{y}}{user}));
1995 }
1996 if (rand($onlinecount) < 1) {
1997 $positions{$rps{$player}{x}}{$rps{$player}{y}}{battled}=1;
1998 collision_fight($player,
1999 $positions{$rps{$player}{x}}{$rps{$player}{y}}{user});
2000 }
2001 }
2002 else {
2003 $positions{$rps{$player}{x}}{$rps{$player}{y}}{battled}=0;
2004 $positions{$rps{$player}{x}}{$rps{$player}{y}}{user}=$player;
2005 }
2006 }
2007 }
2008 # pick up items lying around
2009 for my $u (keys(%rps)) {
2010 next unless $rps{$u}{online};
2011 my $x = $rps{$u}{x};
2012 my $y = $rps{$u}{y};
2013 for $i (0..$#{$mapitems{"$x:$y"}}) {
2014 my $item = $mapitems{"$x:$y"}[$i];
2015 if (itemlevel($item->{level}) > itemlevel($rps{$u}{item}{$item->{type}})) {
2016 exchange_item($u,$item->{type},$item->{level});
2017 splice(@{$mapitems{"$x:$y"}},$i,1);
2018 }
2019 }
2020 }
2021 }
2022}
2023
2024sub mksalt { # generate a random salt for passwds
2025 join '',('a'..'z','A'..'Z','0'..'9','/','.')[rand(64), rand(64)];
2026}
2027
2028sub chanmsg { # send a message to the channel
2029 my $msg = shift or return undef;
2030 if ($silentmode & 1) { return undef; }
2031 privmsg($msg, $opts{botchan}, shift);
2032}
2033
2034sub privmsg { # send a message to an arbitrary entity
2035 my $msg = shift or return undef;
2036 my $target = shift or return undef;
2037 my $force = shift;
2038 if (($silentmode == 3 || ($target !~ /^[\+\&\#]/ && $silentmode == 2))
2039 && !$force) {
2040 return undef;
2041 }
2042 while (length($msg)) {
2043 sts("PRIVMSG $target :".substr($msg,0,450),$force);
2044 substr($msg,0,450)="";
2045 }
2046}
2047
2048sub notice { # send a notice to an arbitrary entity
2049 my $msg = shift or return undef;
2050 my $target = shift or return undef;
2051 my $force = shift;
2052 if (($silentmode == 3 || ($target !~ /^[\+\&\#]/ && $silentmode == 2))
2053 && !$force) {
2054 return undef;
2055 }
2056 while (length($msg)) {
2057 sts("NOTICE $target :".substr($msg,0,450),$force);
2058 substr($msg,0,450)="";
2059 }
2060}
2061
2062sub help { # print help message
2063 (my $prog = $0) =~ s/^.*\///;
2064
2065 print "
2066usage: $prog [OPTIONS]
2067 --help, -h Print this message
2068 --verbose, -v Print verbose messages
2069 --server, -s Specify IRC server:port to connect to
2070 --botnick, -n Bot's IRC nick
2071 --botuser, -u Bot's username
2072 --botrlnm, -r Bot's real name
2073 --botchan, -c IRC channel to join
2074 --botident, -p Specify identify-to-services command
2075 --botmodes, -m Specify usermodes for the bot to set upon connect
2076 --botopcmd, -o Specify command to send to server on successful connect
2077 --botghostcmd, -g Specify command to send to server to regain primary
2078 nickname when in use
2079 --doban Advertisement ban on/off flag
2080 --okurl, -k Bot will not ban for web addresses that contain these
2081 strings
2082 --debug Debug on/off flag
2083 --helpurl URL to refer new users to
2084 --admincommurl URL to refer admins to
2085
2086 Timing parameters:
2087 --rpbase Base time to level up
2088 --rpstep Time to next level = rpbase * (rpstep ** CURRENT_LEVEL)
2089 --rppenstep PENALTY_SECS=(PENALTY*(RPPENSTEP**CURRENT_LEVEL))
2090
2091";
2092}
2093
2094sub itemsum {
2095 my $user = shift;
2096 # is this for a battle? if so, good users get a 10% boost and evil users get
2097 # a 10% detriment
2098 my $battle = shift;
2099 return -1 unless defined $user;
2100 my $sum = 0;
2101 if ($user eq $primnick) {
2102 for my $u (keys(%rps)) {
2103 $sum = itemsum($u) if $sum < itemsum($u);
2104 }
2105 return $sum+1;
2106 }
2107 if (!exists($rps{$user})) { return -1; }
2108 $sum += itemlevel($rps{$user}{item}{$_}) for keys(%{$rps{$user}{item}});
2109 if ($battle) {
2110 return $rps{$user}{alignment} eq 'e' ? int($sum*.9) :
2111 $rps{$user}{alignment} eq 'g' ? int($sum*1.1) :
2112 $sum;
2113 }
2114 return $sum;
2115}
2116
2117sub daemonize() {
2118 # win32 doesn't daemonize (this way?)
2119 if ($^O eq "MSWin32") {
2120 print debug("Nevermind, this is Win32, no I'm not.")."\n";
2121 return;
2122 }
2123 use POSIX 'setsid';
2124 $SIG{CHLD} = sub { };
2125 fork() && exit(0); # kill parent
2126 POSIX::setsid() || debug("POSIX::setsid() failed: $!",1);
2127 $SIG{CHLD} = sub { };
2128 fork() && exit(0); # kill the parent as the process group leader
2129 $SIG{CHLD} = sub { };
2130 open(STDIN,'/dev/null') || debug("Cannot read /dev/null: $!",1);
2131 open(STDOUT,'>/dev/null') || debug("Cannot write to /dev/null: $!",1);
2132 open(STDERR,'>/dev/null') || debug("Cannot write to /dev/null: $!",1);
2133 # write our PID to $opts{pidfile}, or return semi-silently on failure
2134 open(PIDFILE,">$opts{pidfile}") || do {
2135 debug("Error: failed opening pid file: $!");
2136 return;
2137 };
2138 print PIDFILE $$;
2139 close(PIDFILE);
2140}
2141
2142sub calamity { # suffer a little one
2143 my @players = grep { $rps{$_}{online} } keys(%rps);
2144 return unless @players;
2145 my $player = $players[rand(@players)];
2146 if (rand(10) < 1) {
2147 my @items = ("amulet","charm","weapon","tunic","set of leggings",
2148 "shield");
2149 my $type = $items[rand(@items)];
2150 if ($type eq "amulet") {
2151 chanmsg(clog(sprintf(gettext("%s fell, chipping the stone in his ".
2152 "amulet! %1\$s\'s %s loses 10%% of its".
2153 " effectiveness."),
2154 $player,gettext($type))));
2155 }
2156 elsif ($type eq "charm") {
2157 chanmsg(clog(sprintf(gettext("%s slipped and dropped his charm in a".
2158 " dirty bog! %1\$s\'s %s loses 10%% of".
2159 " its effectiveness."),
2160 $player,gettext($type))));
2161 }
2162 elsif ($type eq "weapon") {
2163 chanmsg(clog(sprintf(gettext("%s left his weapon out in the rain to".
2164 " rust! %1\$s\'s %s loses 10%% of its ".
2165 "effectiveness."),
2166 $player,gettext($type))));
2167 }
2168 elsif ($type eq "tunic") {
2169 chanmsg(clog(sprintf(gettext("%s spilled a level 7 shrinking potion".
2170 " on his tunic! %1\$s\'s %s loses 10%%".
2171 " of its effectiveness."),
2172 $player,gettext($type))));
2173 }
2174 elsif ($type eq "shield") {
2175 chanmsg(clog(sprintf(gettext("%s\'s shield was damaged by a ".
2176 "dragon's fiery breath! %1\$s\'s %s ".
2177 "loses 10%% of its effectiveness."),
2178 $player,gettext($type))));
2179 }
2180 else {
2181 chanmsg(clog(sprintf(gettext("%s burned a hole through his leggings".
2182 " while ironing them! %1\$s\'s %s ".
2183 "loses 10%% of its effectiveness."),
2184 $player,gettext($type))));
2185 }
2186 my $suffix="";
2187 if ($rps{$player}{item}{$type} =~ /(\D)$/) { $suffix=$1; }
2188 $rps{$player}{item}{$type} = int(itemlevel($rps{$player}{item}{$type}) * .9);
2189 $rps{$player}{item}{$type}.=$suffix;
2190 }
2191 else {
2192 my $time = int(int(5 + rand(8)) / 100 * $rps{$player}{next});
2193 if (!open(Q,$opts{eventsfile})) {
2194 return chanmsg("ERROR: Failed to open $opts{eventsfile}: $!");
2195 }
2196 my($i,$actioned);
2197 while (my $line = <Q>) {
2198 chomp($line);
2199 if ($line =~ /^C (.*)/ && rand(++$i) < 1) { $actioned = $1; }
2200 }
2201 chanmsg(clog(sprintf(gettext("%s %s. This terrible calamity has slowed ".
2202 "them %s from level %u."),
2203 $player,$actioned,duration($time),
2204 ($rps{$player}{level}+1))));
2205 $rps{$player}{next} += $time;
2206 chanmsg(sprintf(gettext("%s reaches next level in %s."),
2207 $player,duration($rps{$player}{next})));
2208 }
2209}
2210
2211sub godsend { # bless the unworthy
2212 my @players = grep { $rps{$_}{online} } keys(%rps);
2213 return unless @players;
2214 my $player = $players[rand(@players)];
2215 if (rand(10) < 1) {
2216 my @items = ("amulet","charm","weapon","tunic","set of leggings",
2217 "shield");
2218 my $type = $items[rand(@items)];
2219 if ($type eq "amulet") {
2220 chanmsg(clog(sprintf(gettext("%s\'s %s was blessed by a passing".
2221 " cleric! %1\$s\'s %2\$s gains 10%% ".
2222 "effectiveness."),
2223 $player,gettext($type))));
2224 }
2225 elsif ($type eq "charm") {
2226 chanmsg(clog(sprintf(gettext("%s\'s %s ate a bolt of lightning! ".
2227 "%1\$s\'s %2\$s gains 10%% ".
2228 "effectiveness."),
2229 $player,gettext($type))));
2230 }
2231 elsif ($type eq "weapon") {
2232 chanmsg(clog(sprintf(gettext("%s sharpened the edge of his %s! ".
2233 "%1\$s\'s %2\$s gains 10%% ".
2234 "effectiveness."),
2235 $player,gettext($type))));
2236 }
2237 elsif ($type eq "tunic") {
2238 chanmsg(clog(sprintf(gettext("A magician cast a spell of Rigidity ".
2239 "on %s\'s %s! %1\$s\'s %2\$s gains ".
2240 "10%% effectiveness."),
2241 $player,gettext($type))));
2242 }
2243 elsif ($type eq "shield") {
2244 chanmsg(clog(sprintf(gettext("%s reinforced his %s with a ".
2245 "dragon's scales! %1\$s\'s %2\$s gains".
2246 " 10%% effectiveness."),
2247 $player,gettext($type))));
2248 }
2249 else {
2250 chanmsg(clog(sprintf(gettext("The local wizard imbued %s\'s pants ".
2251 "with a Spirit of Fortitude! %1\$s\'s ".
2252 "%2\$s gains 10%% effectiveness."),
2253 $player,gettext($type))));
2254 }
2255 my $suffix="";
2256 if ($rps{$player}{item}{$type} =~ /(\D)$/) { $suffix=$1; }
2257 $rps{$player}{item}{$type} = int(itemlevel($rps{$player}{item}{$type}) * 1.1);
2258 $rps{$player}{item}{$type}.=$suffix;
2259 }
2260 else {
2261 my $time = int(int(5 + rand(8)) / 100 * $rps{$player}{next});
2262 my $actioned;
2263 if (!open(Q,$opts{eventsfile})) {
2264 return chanmsg("ERROR: Failed to open $opts{eventsfile}: $!");
2265 }
2266 my $i;
2267 while (my $line = <Q>) {
2268 chomp($line);
2269 if ($line =~ /^G (.*)/ && rand(++$i) < 1) {
2270 $actioned = $1;
2271 }
2272 }
2273 chanmsg(clog(sprintf(gettext("%s %s! This wondrous godsend has ".
2274 "accelerated them %s towards level %u."),
2275 $player,$actioned,duration($time),
2276 ($rps{$player}{level}+1))));
2277 $rps{$player}{next} -= $time;
2278 chanmsg(sprintf(gettext("%s reaches next level in %s."),
2279 $player,duration($rps{$player}{next})));
2280 }
2281}
2282
2283sub quest {
2284 @{$quest{questers}} = grep { $rps{$_}{online} && $rps{$_}{level} > 39 &&
2285 time()-$rps{$_}{lastlogin}>36000 } keys(%rps);
2286 if (@{$quest{questers}} < 4) { return undef(@{$quest{questers}}); }
2287 while (@{$quest{questers}} > 4) {
2288 splice(@{$quest{questers}},int(rand(@{$quest{questers}})),1);
2289 }
2290 if (!open(Q,$opts{eventsfile})) {
2291 return chanmsg("ERROR: Failed to open $opts{eventsfile}: $!");
2292 }
2293 my $i;
2294 while (my $line = <Q>) {
2295 chomp($line);
2296 if ($line =~ /^Q/ && rand(++$i) < 1) {
2297 if ($line =~ /^Q1 (.*)/) {
2298 $quest{text} = $1;
2299 $quest{type} = 1;
2300 $quest{qtime} = time() + 43200 + int(rand(43201)); # 12-24 hours
2301 }
2302 elsif ($line =~ /^Q2 (\d+) (\d+) (\d+) (\d+) (.*)/) {
2303 $quest{p1} = [$1,$2];
2304 $quest{p2} = [$3,$4];
2305 $quest{text} = $5;
2306 $quest{type} = 2;
2307 $quest{stage} = 1;
2308 }
2309 }
2310 }
2311 close(Q);
2312 if ($quest{type} == 1) {
2313 chanmsg(sprintf(gettext("%s, and %s have been chosen by the gods to ".
2314 "%s. Quest to end in %s."),
2315 join(", ",(@{$quest{questers}})[0..2]),
2316 $quest{questers}->[3],$quest{text},
2317 duration($quest{qtime}-time())));
2318 }
2319 elsif ($quest{type} == 2) {
2320 chanmsg(sprintf(gettext("%s, and %s have been chosen by the gods to ".
2321 "%s. Participants must first reach [%u,%u], ".
2322 "then [%u,%u]."),
2323 join(", ",(@{$quest{questers}})[0..2]),
2324 $quest{questers}->[3],$quest{text},
2325 $quest{p1}->[0],$quest{p1}->[1],
2326 $quest{p2}->[0],$quest{p2}->[1]).
2327 ($opts{mapurl}?sprintf(gettext(" See %s to monitor their ".
2328 "journey's progress."),
2329 $opts{mapurl}):""));
2330 }
2331 writequestfile();
2332}
2333
2334sub questpencheck {
2335 my $k = shift;
2336 my ($quester,$player);
2337 for $quester (@{$quest{questers}}) {
2338 if ($quester eq $k) {
2339 chanmsg(clog(sprintf(gettext(
2340 "%s\'s prudence and self-regard has brought the ".
2341 "wrath of the gods upon the realm. All your great ".
2342 "wickedness makes you as it were heavy with lead, ".
2343 "and to tend downwards with great weight and ".
2344 "pressure towards hell. Therefore have you drawn ".
2345 "yourselves 15 steps closer to that gaping maw.")
2346 ,$k)));
2347 for $player (grep { $rps{$_}{online} } keys %rps) {
2348 my $gain = int(15 * penttl($rps{$player}{level}) / $opts{rpbase});
2349 $rps{$player}{pen_quest} += $gain;
2350 $rps{$player}{next} += $gain;
2351 }
2352 undef(@{$quest{questers}});
2353 $quest{qtime} = time() + 43200; # 12 hours
2354 writequestfile();
2355 last;
2356 }
2357 }
2358}
2359
2360sub clog {
2361 my $mesg = shift;
2362 open(B,">>$opts{modsfile}") or do {
2363 debug("Error: Cannot open $opts{modsfile}: $!");
2364 chanmsg("Error: Cannot open $opts{modsfile}: $!");
2365 return $mesg;
2366 };
2367 print B ts()."$mesg\n";
2368 close(B);
2369 return $mesg;
2370}
2371
2372sub backup() {
2373 if (! -d ".dbbackup/") { mkdir(".dbbackup",0700); }
2374 if ($^O ne "MSWin32") {
2375 system("cp $opts{dbfile} .dbbackup/$opts{dbfile}".time());
2376 system("cp $opts{itemdbfile} .dbbackup/$opts{itemdbfile}".time());
2377 }
2378 else {
2379 system("copy $opts{dbfile} .dbbackup\\$opts{dbfile}".time());
2380 system("copy $opts{itemdbfile} .dbbackup\\$opts{itemdbfile}".time());
2381 }
2382}
2383
2384sub penalize {
2385 my $username = shift;
2386 return 0 if !defined($username);
2387 return 0 if !exists($rps{$username});
2388 my $type = shift;
2389 my $pen = 0;
2390 questpencheck($username);
2391 if ($type eq "quit") {
2392 $pen = int(20 * penttl($rps{$username}{level}) / $opts{rpbase});
2393 if ($opts{limitpen} && $pen > $opts{limitpen}) {
2394 $pen = $opts{limitpen};
2395 }
2396 $rps{$username}{pen_quit}+=$pen;
2397 $rps{$username}{online}=0;
2398 }
2399 elsif ($type eq "nick") {
2400 my $newnick = shift;
2401 $pen = int(30 * penttl($rps{$username}{level}) / $opts{rpbase});
2402 if ($opts{limitpen} && $pen > $opts{limitpen}) {
2403 $pen = $opts{limitpen};
2404 }
2405 $rps{$username}{pen_nick}+=$pen;
2406 $rps{$username}{nick} = substr($newnick,1);
2407 $rps{$username}{userhost} =~ s/^[^!]+/$rps{$username}{nick}/e;
2408 notice(sprintf(gettext("Penalty of %s added to your timer for ".
2409 "nick change."),duration($pen)),$rps{$username}{nick});
2410 }
2411 elsif ($type eq "privmsg" || $type eq "notice") {
2412 $pen = int(shift(@_) * penttl($rps{$username}{level}) / $opts{rpbase});
2413 if ($opts{limitpen} && $pen > $opts{limitpen}) {
2414 $pen = $opts{limitpen};
2415 }
2416 $rps{$username}{pen_mesg}+=$pen;
2417 notice(sprintf(gettext("Penalty of %s added to your timer for %s."),
2418 duration($pen),$type),$rps{$username}{nick});
2419 }
2420 elsif ($type eq "part") {
2421 $pen = int(200 * penttl($rps{$username}{level}) / $opts{rpbase});
2422 if ($opts{limitpen} && $pen > $opts{limitpen}) {
2423 $pen = $opts{limitpen};
2424 }
2425 $rps{$username}{pen_part}+=$pen;
2426 notice(sprintf(gettext("Penalty of %s added to your timer for parting."),
2427 duration($pen)),$rps{$username}{nick});
2428 $rps{$username}{online}=0;
2429 }
2430 elsif ($type eq "kick") {
2431 $pen = int(250 * penttl($rps{$username}{level}) / $opts{rpbase});
2432 if ($opts{limitpen} && $pen > $opts{limitpen}) {
2433 $pen = $opts{limitpen};
2434 }
2435 $rps{$username}{pen_kick}+=$pen;
2436 notice(sprintf(gettext("Penalty of %s added to your timer for ".
2437 "being kicked."),duration($pen)),$rps{$username}{nick});
2438 $rps{$username}{online}=0;
2439 }
2440 elsif ($type eq "logout") {
2441 $pen = int(20 * penttl($rps{$username}{level}) / $opts{rpbase});
2442 if ($opts{limitpen} && $pen > $opts{limitpen}) {
2443 $pen = $opts{limitpen};
2444 }
2445 $rps{$username}{pen_logout} += $pen;
2446 notice(sprintf(gettext("Penalty of %s added to your timer for ".
2447 "LOGOUT command."),duration($pen)),$rps{$username}{nick});
2448 $rps{$username}{online}=0;
2449 }
2450 $rps{$username}{next} += $pen;
2451 return 1; # successfully penalized a user! woohoo!
2452}
2453
2454sub debug {
2455 (my $text = shift) =~ s/[\r\n]//g;
2456 my $die = shift;
2457 if ($opts{debug} || $opts{verbose}) {
2458 open(DBG,">>$opts{debugfile}") or do {
2459 chanmsg("Error: Cannot open debug file: $!");
2460 return;
2461 };
2462 print DBG ts()."$text\n";
2463 close(DBG);
2464 }
2465 if ($die) { die("$text\n"); }
2466 return $text;
2467}
2468
2469sub finduser {
2470 my $nick = shift;
2471 return undef if !defined($nick);
2472 for my $user (keys(%rps)) {
2473 next unless $rps{$user}{online};
2474 if ($rps{$user}{nick} eq $nick) { return $user; }
2475 }
2476 return undef;
2477}
2478
2479sub ha { # return 0/1 if username has access
2480 my $user = shift;
2481 if (!defined($user)) {
2482 debug("Error: Attempted ha() for undefined username");
2483 return 0;
2484 }
2485 if (!exists($rps{$user})) {
2486 debug("Error: Attempted ha() for invalid username \"$user\"");
2487 return 0;
2488 }
2489 return $rps{$user}{isadmin};
2490}
2491
2492sub checksplits { # removed expired split hosts from the hash
2493 my $host;
2494 while ($host = each(%split)) {
2495 if (time()-$split{$host}{time} > $opts{splitwait}) {
2496 $rps{$split{$host}{account}}{online} = 0;
2497 delete($split{$host});
2498 }
2499 }
2500}
2501
2502sub collision_fight {
2503 my($u,$opp) = @_;
2504 my $mysum = itemsum($u,1);
2505 my $oppsum = itemsum($opp,1);
2506 my $myroll = int(rand($mysum));
2507 my $opproll = int(rand($oppsum));
2508 if ($myroll >= $opproll) {
2509 my $gain = int($rps{$opp}{level}/4);
2510 $gain = 7 if $gain < 7;
2511 $gain = int(($gain/100)*$rps{$u}{next});
2512 chanmsg(clog(sprintf(gettext("%s [%u/%u] has come upon %s [%u/%u] and ".
2513 "taken them in combat! %s is removed from ".
2514 "%1\$s\'s clock."),
2515 $u,$myroll,$mysum,$opp,$opproll,$oppsum,
2516 duration($gain))));
2517 $rps{$u}{next} -= $gain;
2518 chanmsg(sprintf(gettext("%s reaches next level in %s."),
2519 $u,duration($rps{$u}{next})));
2520 if (rand(35) < 1 && $opp ne $primnick) {
2521 $gain = int(((5 + int(rand(20)))/100) * $rps{$opp}{next});
2522 chanmsg(clog(sprintf(gettext("%s has dealt %s a Critical Strike! %s".
2523 " is added to %2\$s\'s clock."),
2524 $u,$opp,duration($gain))));
2525 $rps{$opp}{next} += $gain;
2526 chanmsg(sprintf(gettext("%s reaches next level in %s."),$opp,duration($rps{$opp}{next})));
2527 }
2528 elsif (rand(25) < 1 && $opp ne $primnick && $rps{$u}{level} > 19) {
2529 my @items = ("ring","amulet","charm","weapon","helm","tunic",
2530 "pair of gloves","set of leggings","shield",
2531 "pair of boots");
2532 my $type = $items[rand(@items)];
2533 if (itemlevel($rps{$opp}{item}{$type}) > itemlevel($rps{$u}{item}{$type})) {
2534 chanmsg(sprintf(gettext("In the fierce battle, %s dropped his ".
2535 "level %u %s! %s picks it up, tossing ".
2536 "his old level %u %3\$s to %1\$s."),
2537 $opp,itemlevel($rps{$opp}{item}{$type}),
2538 gettext($type),$u,
2539 itemlevel($rps{$u}{item}{$type})));
2540 my $tempitem = $rps{$u}{item}{$type};
2541 $rps{$u}{item}{$type}=$rps{$opp}{item}{$type};
2542 $rps{$opp}{item}{$type} = $tempitem;
2543 }
2544 }
2545 }
2546 else {
2547 my $gain = ($opp eq $primnick)?10:int($rps{$opp}{level}/7);
2548 $gain = 7 if $gain < 7;
2549 $gain = int(($gain/100)*$rps{$u}{next});
2550 chanmsg(clog(sprintf(gettext("%s [%u/%u] has come upon %s [%u/%u] and ".
2551 "been defeated in combat! %s is added to ".
2552 "%1\$s\'s clock."),
2553 $u,$myroll,$mysum,$opp,$opproll,$oppsum,
2554 duration($gain))));
2555 $rps{$u}{next} += $gain;
2556 chanmsg(sprintf(gettext("%s reaches next level in %s."),$u,duration($rps{$u}{next})));
2557 }
2558}
2559
2560sub writequestfile {
2561 return unless $opts{writequestfile};
2562 open(QF,">$opts{questfilename}") or do {
2563 chanmsg("Error: Cannot open $opts{questfilename}: $!");
2564 return;
2565 };
2566 # if no active quest, just empty questfile. otherwise, write it
2567 if (@{$quest{questers}}) {
2568 if ($quest{type}==1) {
2569 print QF "T $quest{text}\n".
2570 "Y 1\n".
2571 "S $quest{qtime}\n".
2572 "P1 $quest{questers}->[0]\n".
2573 "P2 $quest{questers}->[1]\n".
2574 "P3 $quest{questers}->[2]\n".
2575 "P4 $quest{questers}->[3]\n";
2576 }
2577 elsif ($quest{type}==2) {
2578 print QF "T $quest{text}\n".
2579 "Y 2\n".
2580 "S $quest{stage}\n".
2581 "P $quest{p1}->[0] $quest{p1}->[1] $quest{p2}->[0] ".
2582 "$quest{p2}->[1]\n".
2583 "P1 $quest{questers}->[0] $rps{$quest{questers}->[0]}{x} ".
2584 "$rps{$quest{questers}->[0]}{y}\n".
2585 "P2 $quest{questers}->[1] $rps{$quest{questers}->[1]}{x} ".
2586 "$rps{$quest{questers}->[1]}{y}\n".
2587 "P3 $quest{questers}->[2] $rps{$quest{questers}->[2]}{x} ".
2588 "$rps{$quest{questers}->[2]}{y}\n".
2589 "P4 $quest{questers}->[3] $rps{$quest{questers}->[3]}{x} ".
2590 "$rps{$quest{questers}->[3]}{y}\n";
2591 }
2592 }
2593 close(QF);
2594}
2595
2596sub loadquestfile {
2597 return unless ($opts{writequestfile} && -e $opts{questfilename});
2598 open(QF,$opts{questfilename}) or do {
2599 chanmsg("Error: Cannot open $opts{questfilename}: $!");
2600 return;
2601 };
2602
2603 my %questdata = ();
2604 while (my $line = <QF>) {
2605 chomp $line;
2606 my ($tag,$data) = split(/ /,$line,2);
2607 $questdata{$tag} = $data;
2608 }
2609 return unless defined($questdata{Y});
2610
2611 $quest{text} = $questdata{T};
2612 $quest{type} = $questdata{Y};
2613 if ($quest{type} == 1) {
2614 $quest{qtime} = $questdata{S};
2615 }
2616 else {
2617 $quest{stage} = $questdata{S};
2618 my ($p1x,$p1y,$p2x,$p2y) = split(/ /,$questdata{P});
2619 $quest{p1}->[0] = $p1x;
2620 $quest{p1}->[1] = $p1y;
2621 $quest{p2}->[0] = $p2x;
2622 $quest{p2}->[1] = $p2y;
2623 }
2624 for my $i (0..3) {
2625 ($quest{questers}->[$i],) = split(/ /,$questdata{'P'.($i+1)},2);
2626 if (!$rps{$quest{questers}->[$i]}{online}) {
2627 undef(@{$quest{questers}});
2628 last;
2629 }
2630 }
2631 close(QF);
2632 writequestfile();
2633}
2634
2635sub goodness {
2636 my @players = grep { $rps{$_}{alignment} eq "g" &&
2637 $rps{$_}{online} } keys(%rps);
2638 return unless @players > 1;
2639 splice(@players,int(rand(@players)),1) while @players > 2;
2640 my $gain = 5 + int(rand(8));
2641 chanmsg(clog(sprintf(gettext("%s and %s have not let the iniquities of ".
2642 "evil men poison them. Together have they prayed to their ".
2643 "god, and it is his light that now shines upon them. %u%% ".
2644 "of their time is removed from their clocks."),
2645 $players[0],$players[1],$gain)));
2646 $rps{$players[0]}{next} = int($rps{$players[0]}{next}*(1 - ($gain/100)));
2647 $rps{$players[1]}{next} = int($rps{$players[1]}{next}*(1 - ($gain/100)));
2648 chanmsg(sprintf(gettext("%s reaches next level in %s."),
2649 $players[0],duration($rps{$players[0]}{next})));
2650 chanmsg(sprintf(gettext("%s reaches next level in %s."),
2651 $players[1],duration($rps{$players[1]}{next})));
2652}
2653
2654sub evilness {
2655 my @evil = grep { $rps{$_}{alignment} eq "e" &&
2656 $rps{$_}{online} } keys(%rps);
2657 return unless @evil;
2658 my $me = $evil[rand(@evil)];
2659 if (int(rand(2)) < 1) {
2660 # evil only steals from good :^(
2661 my @good = grep { $rps{$_}{alignment} eq "g" &&
2662 $rps{$_}{online} } keys(%rps);
2663 my $target = $good[rand(@good)];
2664 my @items = ("ring","amulet","charm","weapon","helm","tunic",
2665 "pair of gloves","set of leggings","shield",
2666 "pair of boots");
2667 my $type = $items[rand(@items)];
2668 if (itemlevel($rps{$target}{item}{$type}) > itemlevel($rps{$me}{item}{$type})) {
2669 my $tempitem = $rps{$me}{item}{$type};
2670 $rps{$me}{item}{$type} = $rps{$target}{item}{$type};
2671 $rps{$target}{item}{$type} = $tempitem;
2672 chanmsg(clog(sprintf(gettext("%s stole %s\'s level %u %s while ".
2673 "they were sleeping! %1\$s leaves his ".
2674 "old level %u %4\$s behind, which ".
2675 "%2\$s then takes."),
2676 $me,$target,itemlevel($rps{$me}{item}{$type}),
2677 gettext($type),
2678 itemlevel($rps{$target}{item}{$type}))));
2679 }
2680 else {
2681 notice(sprintf(gettext("You made to steal %s\'s %s, but realized ".
2682 "it was lower level than your own. You ".
2683 "creep back into the shadows."),
2684 $target,gettext($type)),$rps{$me}{nick});
2685 }
2686 }
2687 else { # being evil only pays about half of the time...
2688 my $gain = 1 + int(rand(5));
2689 chanmsg(clog(sprintf(gettext("%s is forsaken by his evil god. %s".
2690 " is added to his clock."),$me,
2691 duration(int($rps{$me}{next} * ($gain/100))))));
2692 $rps{$me}{next} = int($rps{$me}{next} * (1 + ($gain/100)));
2693 chanmsg(sprintf(gettext("%s reaches next level in %s."),
2694 $me,duration($rps{$me}{next})));
2695 }
2696}
2697
2698sub writedb {
2699 open(RPS,">$opts{dbfile}") or do {
2700 chanmsg("ERROR: Cannot write $opts{dbfile}: $!");
2701 return 0;
2702 };
2703 print RPS join("\t","# username",
2704 "pass",
2705 "is admin",
2706 "level",
2707 "class",
2708 "next ttl",
2709 "nick",
2710 "userhost",
2711 "online",
2712 "idled",
2713 "x pos",
2714 "y pos",
2715 "pen_mesg",
2716 "pen_nick",
2717 "pen_part",
2718 "pen_kick",
2719 "pen_quit",
2720 "pen_quest",
2721 "pen_logout",
2722 "created",
2723 "last login",
2724 "amulet",
2725 "charm",
2726 "helm",
2727 "boots",
2728 "gloves",
2729 "ring",
2730 "leggings",
2731 "shield",
2732 "tunic",
2733 "weapon",
2734 "alignment")."\n";
2735 my $k;
2736 keys(%rps); # reset internal pointer
2737 while ($k=each(%rps)) {
2738 if (exists($rps{$k}{next}) && defined($rps{$k}{next})) {
2739 print RPS join("\t",$k,
2740 $rps{$k}{pass},
2741 $rps{$k}{isadmin},
2742 $rps{$k}{level},
2743 $rps{$k}{class},
2744 $rps{$k}{next},
2745 $rps{$k}{nick},
2746 $rps{$k}{userhost},
2747 $rps{$k}{online},
2748 $rps{$k}{idled},
2749 $rps{$k}{x},
2750 $rps{$k}{y},
2751 $rps{$k}{pen_mesg},
2752 $rps{$k}{pen_nick},
2753 $rps{$k}{pen_part},
2754 $rps{$k}{pen_kick},
2755 $rps{$k}{pen_quit},
2756 $rps{$k}{pen_quest},
2757 $rps{$k}{pen_logout},
2758 $rps{$k}{created},
2759 $rps{$k}{lastlogin},
2760 $rps{$k}{item}{amulet},
2761 $rps{$k}{item}{charm},
2762 $rps{$k}{item}{helm},
2763 $rps{$k}{item}{"pair of boots"},
2764 $rps{$k}{item}{"pair of gloves"},
2765 $rps{$k}{item}{ring},
2766 $rps{$k}{item}{"set of leggings"},
2767 $rps{$k}{item}{shield},
2768 $rps{$k}{item}{tunic},
2769 $rps{$k}{item}{weapon},
2770 $rps{$k}{alignment})."\n";
2771 }
2772 }
2773 close(RPS);
2774 open(ITEMS,">$opts{itemdbfile}") or do {
2775 chanmsg("ERROR: Cannot write $opts{itemdbfile}: $!");
2776 return 0;
2777 };
2778 print ITEMS join("\t","# x pos",
2779 "y pos",
2780 "type",
2781 "level",
2782 "age")."\n";
2783 my $curtime = time();
2784 for my $xy (keys(%mapitems)) {
2785 for my $i (0..$#{$mapitems{$xy}}) {
2786 my @coords = split(/:/,$xy);
2787 print ITEMS join("\t",$coords[0],
2788 $coords[1],
2789 $mapitems{$xy}[$i]{type},
2790 $mapitems{$xy}[$i]{level},
2791 $curtime-$mapitems{$xy}[$i]{lasttime})."\n";
2792 }
2793 }
2794 close(ITEMS);
2795}
2796
2797sub readconfig {
2798 if (! -e ".irpg.conf") {
2799 debug("Error: Cannot find .irpg.conf. Copy it to this directory, ".
2800 "please.",1);
2801 }
2802 else {
2803 open(CONF,"<.irpg.conf") or do {
2804 debug("Failed to open config file .irpg.conf: $!",1);
2805 };
2806 my($line,$key,$val);
2807 while ($line=<CONF>) {
2808 next() if $line =~ /^#/; # skip comments
2809 $line =~ s/[\r\n]//g;
2810 $line =~ s/^\s+//g;
2811 next() if !length($line); # skip blank lines
2812 ($key,$val) = split(/\s+/,$line,2);
2813 $val = "" if !defined($val);
2814 $key = lc($key);
2815 if (lc($val) eq "on" || lc($val) eq "yes") { $val = 1; }
2816 elsif (lc($val) eq "off" || lc($val) eq "no") { $val = 0; }
2817 if ($key eq "die") {
2818 die("Please edit the file .irpg.conf to setup your bot's ".
2819 "options. Also, read the README file if you haven't ".
2820 "yet.\n");
2821 }
2822 elsif ($key eq "server") { push(@{$opts{servers}},$val); }
2823 elsif ($key eq "okurl") { push(@{$opts{okurl}},$val); }
2824 else { $opts{$key} = $val; }
2825 }
2826 }
2827}
Note: See TracBrowser for help on using the repository browser.