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

Last change on this file since 1444 was 1444, checked in by tereutes, 13 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.