source: irpg/trunk/bot/bot.v3.1.2.pl.backup@ 1447

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

import initial

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