ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/server/lib/cf.pm
(Generate patch)

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.33 by root, Mon Aug 21 01:51:23 2006 UTC vs.
Revision 1.477 by root, Wed Sep 2 22:52:36 2009 UTC

1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3#
4# Copyright (©) 2006,2007,2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5#
6# Deliantra is free software: you can redistribute it and/or modify
7# it under the terms of the GNU General Public License as published by
8# the Free Software Foundation, either version 3 of the License, or
9# (at your option) any later version.
10#
11# This program is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14# GNU General Public License for more details.
15#
16# You should have received a copy of the GNU General Public License
17# along with this program. If not, see <http://www.gnu.org/licenses/>.
18#
19# The authors can be reached via e-mail to <support@deliantra.net>
20#
21
1package cf; 22package cf;
23
24use 5.10.0;
25use utf8;
26use strict qw(vars subs);
2 27
3use Symbol; 28use Symbol;
4use List::Util; 29use List::Util;
5use Storable; 30use Socket;
31use EV;
6use Opcode; 32use Opcode;
7use Safe; 33use Safe;
8use Safe::Hole; 34use Safe::Hole;
35use Storable ();
9 36
37use Guard ();
38use Coro ();
39use Coro::State;
40use Coro::Handle;
41use Coro::EV;
42use Coro::AnyEvent;
43use Coro::Timer;
44use Coro::Signal;
45use Coro::Semaphore;
46use Coro::SemaphoreSet;
47use Coro::AnyEvent;
48use Coro::AIO;
49use Coro::BDB 1.6;
50use Coro::Storable;
51use Coro::Util ();
52
53use JSON::XS 2.01 ();
54use BDB ();
55use Data::Dumper;
56use Digest::MD5;
57use Fcntl;
58use YAML ();
59use IO::AIO ();
10use Time::HiRes; 60use Time::HiRes;
11use Event; 61use Compress::LZF;
12$Event::Eval = 1; # no idea why this is required, but it is 62use Digest::MD5 ();
13 63
14use strict; 64AnyEvent::detect;
15 65
16our %COMMAND; 66# configure various modules to our taste
67#
68$Storable::canonical = 1; # reduce rsync transfers
69Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
70
71$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
72
73# make sure c-lzf reinitialises itself
74Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";
75Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
76
77# strictly for debugging
78$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
79
80sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
81
82our %COMMAND = ();
83our %COMMAND_TIME = ();
84
85our @EXTS = (); # list of extension package names
86our %EXTCMD = ();
87our %EXTICMD = ();
88our %EXT_CORO = (); # coroutines bound to extensions
89our %EXT_MAP = (); # pluggable maps
90
91our $RELOAD; # number of reloads so far, non-zero while in reload
17our @EVENT; 92our @EVENT;
18our %PROP_TYPE;
19our %PROP_IDX;
20our $LIBDIR = maps_directory "perl";
21 93
22BEGIN { 94our $CONFDIR = confdir;
23 @EVENT = map lc, @EVENT; 95our $DATADIR = datadir;
96our $LIBDIR = "$DATADIR/ext";
97our $PODDIR = "$DATADIR/pod";
98our $MAPDIR = "$DATADIR/" . mapdir;
99our $LOCALDIR = localdir;
100our $TMPDIR = "$LOCALDIR/" . tmpdir;
101our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
102our $PLAYERDIR = "$LOCALDIR/" . playerdir;
103our $RANDOMDIR = "$LOCALDIR/random";
104our $BDBDIR = "$LOCALDIR/db";
105our $PIDFILE = "$LOCALDIR/pid";
106our $RUNTIMEFILE = "$LOCALDIR/runtime";
24 107
25 *CORE::GLOBAL::warn = sub { 108our %RESOURCE;
109
110our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
111our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
112our $NEXT_TICK;
113our $USE_FSYNC = 1; # use fsync to write maps - default on
114
115our $BDB_DEADLOCK_WATCHER;
116our $BDB_CHECKPOINT_WATCHER;
117our $BDB_TRICKLE_WATCHER;
118our $DB_ENV;
119
120our @EXTRA_MODULES = qw(pod mapscript);
121
122our %CFG;
123
124our $UPTIME; $UPTIME ||= time;
125our $RUNTIME;
126our $NOW;
127
128our (%PLAYER, %PLAYER_LOADING); # all users
129our (%MAP, %MAP_LOADING ); # all maps
130our $LINK_MAP; # the special {link} map, which is always available
131
132# used to convert map paths into valid unix filenames by replacing / by ∕
133our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
134
135our $LOAD; # a number between 0 (idle) and 1 (too many objects)
136our $LOADAVG; # same thing, but with alpha-smoothing
137our $JITTER; # average jitter
138our $TICK_START; # for load detecting purposes
139
140our @POST_INIT;
141
142our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
143our $REALLY_UNLOOP; # never set to true, please :)
144
145binmode STDOUT;
146binmode STDERR;
147
148# read virtual server time, if available
149unless ($RUNTIME || !-e $RUNTIMEFILE) {
150 open my $fh, "<", $RUNTIMEFILE
151 or die "unable to read $RUNTIMEFILE file: $!";
152 $RUNTIME = <$fh> + 0.;
153}
154
155eval "sub TICK() { $TICK } 1" or die;
156
157mkdir $_
158 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
159
160our $EMERGENCY_POSITION;
161
162sub cf::map::normalise;
163
164#############################################################################
165
166=head2 GLOBAL VARIABLES
167
168=over 4
169
170=item $cf::UPTIME
171
172The timestamp of the server start (so not actually an uptime).
173
174=item $cf::RUNTIME
175
176The time this server has run, starts at 0 and is increased by $cf::TICK on
177every server tick.
178
179=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
180$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
181$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
182
183Various directories - "/etc", read-only install directory, perl-library
184directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
185unique-items directory, player file directory, random maps directory and
186database environment.
187
188=item $cf::NOW
189
190The time of the last (current) server tick.
191
192=item $cf::TICK
193
194The interval between server ticks, in seconds.
195
196=item $cf::LOADAVG
197
198The current CPU load on the server (alpha-smoothed), as a value between 0
199(none) and 1 (overloaded), indicating how much time is spent on processing
200objects per tick. Healthy values are < 0.5.
201
202=item $cf::LOAD
203
204The raw value load value from the last tick.
205
206=item %cf::CFG
207
208Configuration for the server, loaded from C</etc/deliantra-server/config>, or
209from wherever your confdir points to.
210
211=item cf::wait_for_tick, cf::wait_for_tick_begin
212
213These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
214returns directly I<after> the tick processing (and consequently, can only wake one process
215per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
216
217=item @cf::INVOKE_RESULTS
218
219This array contains the results of the last C<invoke ()> call. When
220C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
221that call.
222
223=back
224
225=cut
226
227$Coro::State::WARNHOOK = sub {
26 my $msg = join "", @_; 228 my $msg = join "", @_;
229
27 $msg .= "\n" 230 $msg .= "\n"
28 unless $msg =~ /\n$/; 231 unless $msg =~ /\n$/;
29 232
30 print STDERR "cfperl: $msg"; 233 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
234
31 LOG llevError, "cfperl: $msg"; 235 LOG llevError, $msg;
32 }; 236};
33}
34 237
35my %ignore_set = (MAP_PROP_PATH => 1); # I hate the plug-in api. Deeply! 238$Coro::State::DIEHOOK = sub {
239 return unless $^S eq 0; # "eq", not "=="
36 240
37# generate property mutators 241 warn Carp::longmess $_[0];
38sub prop_gen {
39 my ($prefix, $class) = @_;
40 242
41 no strict 'refs'; 243 if ($Coro::current == $Coro::main) {#d#
244 warn "DIEHOOK called in main context, Coro bug?\n";#d#
245 return;#d#
246 }#d#
42 247
43 for my $prop (keys %PROP_TYPE) { 248 # kill coroutine otherwise
44 $prop =~ /^\Q$prefix\E_(.*$)/ or next; 249 Coro::terminate
45 my $sub = lc $1; 250};
46 251
47 my $type = $PROP_TYPE{$prop}; 252@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
48 my $idx = $PROP_IDX {$prop}; 253@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
49 254@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
50 *{"$class\::get_$sub"} = *{"$class\::$sub"} = sub { 255@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
51 $_[0]->get_property ($type, $idx) 256@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
52 }; 257@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
53
54 *{"$class\::set_$sub"} = sub {
55 $_[0]->set_property ($type, $idx, $_[1]);
56 } unless $ignore_set{$prop};
57 }
58}
59
60# auto-generate most of the API
61
62prop_gen OBJECT_PROP => "cf::object";
63# CFAPI_OBJECT_ANIMATION?
64prop_gen PLAYER_PROP => "cf::object::player";
65
66prop_gen MAP_PROP => "cf::map";
67prop_gen ARCH_PROP => "cf::arch";
68
69# guessed hierarchies
70
71@ext::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 258@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
72@ext::cf::object::map::ISA = @cf::object::map::ISA = 'cf::object';
73 259
74# we bless all objects into derived classes to force a method lookup 260# we bless all objects into (empty) derived classes to force a method lookup
75# within the Safe compartment. 261# within the Safe compartment.
76for my $pkg (qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region cf::arch)) { 262for my $pkg (qw(
77 no strict 'refs'; 263 cf::global cf::attachable
264 cf::object cf::object::player
265 cf::client cf::player
266 cf::arch cf::living
267 cf::map cf::mapspace
268 cf::party cf::region
269)) {
78 @{"ext::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 270 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
79} 271}
80 272
81$Event::DIED = sub { 273$EV::DIED = sub {
82 warn "error in event callback: @_"; 274 warn "error in event callback: @_";
83}; 275};
84 276
85my %ext_pkg; 277#############################################################################
86my @exts;
87my @hook;
88my %command;
89my %extcmd;
90 278
91sub inject_event { 279=head2 UTILITY FUNCTIONS
92 my $extension = shift; 280
281=over 4
282
283=item dumpval $ref
284
285=cut
286
287sub dumpval {
288 eval {
289 local $SIG{__DIE__};
290 my $d;
291 if (1) {
292 $d = new Data::Dumper([$_[0]], ["*var"]);
293 $d->Terse(1);
294 $d->Indent(2);
295 $d->Quotekeys(0);
296 $d->Useqq(1);
297 #$d->Bless(...);
298 $d->Seen($_[1]) if @_ > 1;
299 $d = $d->Dump();
300 }
301 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
302 $d
303 } || "[unable to dump $_[0]: '$@']";
304}
305
306=item $ref = cf::decode_json $json
307
308Converts a JSON string into the corresponding perl data structure.
309
310=item $json = cf::encode_json $ref
311
312Converts a perl data structure into its JSON representation.
313
314=cut
315
316our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
317
318sub encode_json($) { $json_coder->encode ($_[0]) }
319sub decode_json($) { $json_coder->decode ($_[0]) }
320
321=item cf::post_init { BLOCK }
322
323Execute the given codeblock, I<after> all extensions have been (re-)loaded,
324but I<before> the server starts ticking again.
325
326The cdoeblock will have a single boolean argument to indicate whether this
327is a reload or not.
328
329=cut
330
331sub post_init(&) {
332 push @POST_INIT, shift;
333}
334
335=item cf::lock_wait $string
336
337Wait until the given lock is available. See cf::lock_acquire.
338
339=item my $lock = cf::lock_acquire $string
340
341Wait until the given lock is available and then acquires it and returns
342a L<Guard> object. If the guard object gets destroyed (goes out of scope,
343for example when the coroutine gets canceled), the lock is automatically
344returned.
345
346Locks are *not* recursive, locking from the same coro twice results in a
347deadlocked coro.
348
349Lock names should begin with a unique identifier (for example, cf::map::find
350uses map_find and cf::map::load uses map_load).
351
352=item $locked = cf::lock_active $string
353
354Return true if the lock is currently active, i.e. somebody has locked it.
355
356=cut
357
358our $LOCKS = new Coro::SemaphoreSet;
359
360sub lock_wait($) {
361 $LOCKS->wait ($_[0]);
362}
363
364sub lock_acquire($) {
365 $LOCKS->guard ($_[0])
366}
367
368sub lock_active($) {
369 $LOCKS->count ($_[0]) < 1
370}
371
372sub freeze_mainloop {
373 tick_inhibit_inc;
374
375 &Guard::guard (\&tick_inhibit_dec);
376}
377
378=item cf::periodic $interval, $cb
379
380Like EV::periodic, but randomly selects a starting point so that the actions
381get spread over timer.
382
383=cut
384
385sub periodic($$) {
386 my ($interval, $cb) = @_;
387
388 my $start = rand List::Util::min 180, $interval;
389
390 EV::periodic $start, $interval, 0, $cb
391}
392
393=item cf::get_slot $time[, $priority[, $name]]
394
395Allocate $time seconds of blocking CPU time at priority C<$priority>:
396This call blocks and returns only when you have at least C<$time> seconds
397of cpu time till the next tick. The slot is only valid till the next cede.
398
399The optional C<$name> can be used to identify the job to run. It might be
400used for statistical purposes and should identify the same time-class.
401
402Useful for short background jobs.
403
404=cut
405
406our @SLOT_QUEUE;
407our $SLOT_QUEUE;
408
409$SLOT_QUEUE->cancel if $SLOT_QUEUE;
410$SLOT_QUEUE = Coro::async {
411 $Coro::current->desc ("timeslot manager");
412
413 my $signal = new Coro::Signal;
414
415 while () {
416 next_job:
417 my $avail = cf::till_tick;
418 if ($avail > 0.01) {
419 for (0 .. $#SLOT_QUEUE) {
420 if ($SLOT_QUEUE[$_][0] < $avail) {
421 my $job = splice @SLOT_QUEUE, $_, 1, ();
422 $job->[2]->send;
423 Coro::cede;
424 goto next_job;
425 }
426 }
427 }
428
429 if (@SLOT_QUEUE) {
430 # we do not use wait_for_tick() as it returns immediately when tick is inactive
431 push @cf::WAIT_FOR_TICK, $signal;
432 $signal->wait;
433 } else {
434 Coro::schedule;
435 }
436 }
437};
438
439sub get_slot($;$$) {
440 return if tick_inhibit || $Coro::current == $Coro::main;
441
442 my ($time, $pri, $name) = @_;
443
444 $time = $TICK * .6 if $time > $TICK * .6;
445 my $sig = new Coro::Signal;
446
447 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
448 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
449 $SLOT_QUEUE->ready;
450 $sig->wait;
451}
452
453=item cf::async { BLOCK }
454
455Currently the same as Coro::async_pool, meaning you cannot use
456C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
457thing you are allowed to do is call C<prio> on it.
458
459=cut
460
461BEGIN { *async = \&Coro::async_pool }
462
463=item cf::sync_job { BLOCK }
464
465The design of Deliantra requires that the main coroutine ($Coro::main)
466is always able to handle events or runnable, as Deliantra is only
467partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
468acceptable.
469
470If it must be done, put the blocking parts into C<sync_job>. This will run
471the given BLOCK in another coroutine while waiting for the result. The
472server will be frozen during this time, so the block should either finish
473fast or be very important.
474
475=cut
476
477sub sync_job(&) {
478 my ($job) = @_;
479
480 if ($Coro::current == $Coro::main) {
481 my $time = EV::time;
482
483 # this is the main coro, too bad, we have to block
484 # till the operation succeeds, freezing the server :/
485
486 LOG llevError, Carp::longmess "sync job";#d#
487
488 my $freeze_guard = freeze_mainloop;
489
490 my $busy = 1;
491 my @res;
492
493 (async {
494 $Coro::current->desc ("sync job coro");
495 @res = eval { $job->() };
496 warn $@ if $@;
497 undef $busy;
498 })->prio (Coro::PRIO_MAX);
499
500 while ($busy) {
501 if (Coro::nready) {
502 Coro::cede_notself;
503 } else {
504 EV::loop EV::LOOP_ONESHOT;
505 }
506 }
507
508 my $time = EV::time - $time;
509
510 $TICK_START += $time; # do not account sync jobs to server load
511
512 wantarray ? @res : $res[0]
513 } else {
514 # we are in another coroutine, how wonderful, everything just works
515
516 $job->()
517 }
518}
519
520=item $coro = cf::async_ext { BLOCK }
521
522Like async, but this coro is automatically being canceled when the
523extension calling this is being unloaded.
524
525=cut
526
527sub async_ext(&) {
528 my $cb = shift;
529
530 my $coro = &Coro::async ($cb);
531
532 $coro->on_destroy (sub {
533 delete $EXT_CORO{$coro+0};
534 });
535 $EXT_CORO{$coro+0} = $coro;
536
537 $coro
538}
539
540=item fork_call { }, $args
541
542Executes the given code block with the given arguments in a seperate
543process, returning the results. Everything must be serialisable with
544Coro::Storable. May, of course, block. Note that the executed sub may
545never block itself or use any form of event handling.
546
547=cut
548
549sub fork_call(&@) {
550 my ($cb, @args) = @_;
551
552 # we seemingly have to make a local copy of the whole thing,
553 # otherwise perl prematurely frees the stuff :/
554 # TODO: investigate and fix (likely this will be rather laborious)
555
556 my @res = Coro::Util::fork_eval {
557 reset_signals;
558 &$cb
559 }, @args;
560
561 wantarray ? @res : $res[-1]
562}
563
564=item $coin = coin_from_name $name
565
566=cut
567
568our %coin_alias = (
569 "silver" => "silvercoin",
570 "silvercoin" => "silvercoin",
571 "silvercoins" => "silvercoin",
572 "gold" => "goldcoin",
573 "goldcoin" => "goldcoin",
574 "goldcoins" => "goldcoin",
575 "platinum" => "platinacoin",
576 "platinumcoin" => "platinacoin",
577 "platinumcoins" => "platinacoin",
578 "platina" => "platinacoin",
579 "platinacoin" => "platinacoin",
580 "platinacoins" => "platinacoin",
581 "royalty" => "royalty",
582 "royalties" => "royalty",
583);
584
585sub coin_from_name($) {
586 $coin_alias{$_[0]}
587 ? cf::arch::find $coin_alias{$_[0]}
588 : undef
589}
590
591=item $value = cf::db_get $family => $key
592
593Returns a single value from the environment database.
594
595=item cf::db_put $family => $key => $value
596
597Stores the given C<$value> in the family. It can currently store binary
598data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
599
600=item $db = cf::db_table "name"
601
602Create and/or open a new database table. The string must not be "db" and must be unique
603within each server.
604
605=cut
606
607sub db_table($) {
608 my ($name) = @_;
609 my $db = BDB::db_create $DB_ENV;
610
611 eval {
612 $db->set_flags (BDB::CHKSUM);
613
614 utf8::encode $name;
615 BDB::db_open $db, undef, $name, undef, BDB::BTREE,
616 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
617 cf::cleanup "db_open(db): $!" if $!;
618 };
619 cf::cleanup "db_open(db): $@" if $@;
620
621 $db
622}
623
624our $DB;
625
626sub db_init {
627 cf::sync_job {
628 $DB ||= db_table "db";
629 };
630}
631
632sub db_get($$) {
633 my $key = "$_[0]/$_[1]";
634
635 cf::sync_job {
636 BDB::db_get $DB, undef, $key, my $data;
637
638 $! ? ()
639 : $data
640 }
641}
642
643sub db_put($$$) {
644 BDB::dbreq_pri 4;
645 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
646}
647
648=item cf::cache $id => [$paths...], $processversion => $process
649
650Generic caching function that returns the value of the resource $id,
651caching and regenerating as required.
652
653This function can block.
654
655=cut
656
657sub cache {
658 my ($id, $src, $processversion, $process) = @_;
659
660 my $meta =
661 join "\x00",
662 $processversion,
663 map {
664 aio_stat $_
665 and Carp::croak "$_: $!";
666
667 ($_, (stat _)[7,9])
668 } @$src;
669
670 my $dbmeta = db_get cache => "$id/meta";
671 if ($dbmeta ne $meta) {
672 # changed, we may need to process
673
674 my @data;
675 my $md5;
676
677 for (0 .. $#$src) {
678 0 <= aio_load $src->[$_], $data[$_]
679 or Carp::croak "$src->[$_]: $!";
680 }
681
682 # if processing is expensive, check
683 # checksum first
684 if (1) {
685 $md5 =
686 join "\x00",
687 $processversion,
688 map {
689 cf::cede_to_tick;
690 ($src->[$_], Digest::MD5::md5_hex $data[$_])
691 } 0.. $#$src;
692
693
694 my $dbmd5 = db_get cache => "$id/md5";
695 if ($dbmd5 eq $md5) {
696 db_put cache => "$id/meta", $meta;
697
698 return db_get cache => "$id/data";
699 }
700 }
701
702 my $t1 = Time::HiRes::time;
703 my $data = $process->(\@data);
704 my $t2 = Time::HiRes::time;
705
706 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
707
708 db_put cache => "$id/data", $data;
709 db_put cache => "$id/md5" , $md5;
710 db_put cache => "$id/meta", $meta;
711
712 return $data;
713 }
714
715 db_get cache => "$id/data"
716}
717
718=item cf::datalog type => key => value, ...
719
720Log a datalog packet of the given type with the given key-value pairs.
721
722=cut
723
724sub datalog($@) {
725 my ($type, %kv) = @_;
726 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
727}
728
729=back
730
731=cut
732
733#############################################################################
734
735=head2 ATTACHABLE OBJECTS
736
737Many objects in deliantra are so-called attachable objects. That means you can
738attach callbacks/event handlers (a collection of which is called an "attachment")
739to it. All such attachable objects support the following methods.
740
741In the following description, CLASS can be any of C<global>, C<object>
742C<player>, C<client> or C<map> (i.e. the attachable objects in
743Deliantra).
744
745=over 4
746
747=item $attachable->attach ($attachment, key => $value...)
748
749=item $attachable->detach ($attachment)
750
751Attach/detach a pre-registered attachment to a specific object and give it
752the specified key/value pairs as arguments.
753
754Example, attach a minesweeper attachment to the given object, making it a
75510x10 minesweeper game:
756
757 $obj->attach (minesweeper => width => 10, height => 10);
758
759=item $bool = $attachable->attached ($name)
760
761Checks wether the named attachment is currently attached to the object.
762
763=item cf::CLASS->attach ...
764
765=item cf::CLASS->detach ...
766
767Define an anonymous attachment and attach it to all objects of the given
768CLASS. See the next function for an explanation of its arguments.
769
770You can attach to global events by using the C<cf::global> class.
771
772Example, log all player logins:
773
774 cf::player->attach (
775 on_login => sub {
776 my ($pl) = @_;
777 ...
778 },
779 );
780
781Example, attach to the jeweler skill:
782
783 cf::object->attach (
784 type => cf::SKILL,
785 subtype => cf::SK_JEWELER,
786 on_use_skill => sub {
787 my ($sk, $ob, $part, $dir, $msg) = @_;
788 ...
789 },
790 );
791
792=item cf::CLASS::attachment $name, ...
793
794Register an attachment by C<$name> through which attachable objects of the
795given CLASS can refer to this attachment.
796
797Some classes such as deliantra maps and objects can specify attachments
798that are attached at load/instantiate time, thus the need for a name.
799
800These calls expect any number of the following handler/hook descriptions:
801
802=over 4
803
804=item prio => $number
805
806Set the priority for all following handlers/hooks (unless overwritten
807by another C<prio> setting). Lower priority handlers get executed
808earlier. The default priority is C<0>, and many built-in handlers are
809registered at priority C<-1000>, so lower priorities should not be used
810unless you know what you are doing.
811
812=item type => $type
813
814(Only for C<< cf::object->attach >> calls), limits the attachment to the
815given type of objects only (the additional parameter C<subtype> can be
816used to further limit to the given subtype).
817
818=item on_I<event> => \&cb
819
820Call the given code reference whenever the named event happens (event is
821something like C<instantiate>, C<apply>, C<use_skill> and so on, and which
822handlers are recognised generally depends on the type of object these
823handlers attach to).
824
825See F<include/eventinc.h> for the full list of events supported, and their
826class.
827
828=item package => package::
829
830Look for sub functions of the name C<< on_I<event> >> in the given
831package and register them. Only handlers for eevents supported by the
832object/class are recognised.
833
834=back
835
836Example, define an attachment called "sockpuppet" that calls the given
837event handler when a monster attacks:
838
839 cf::object::attachment sockpuppet =>
840 on_skill_attack => sub {
841 my ($self, $victim) = @_;
842 ...
843 }
844 }
845
846=item $attachable->valid
847
848Just because you have a perl object does not mean that the corresponding
849C-level object still exists. If you try to access an object that has no
850valid C counterpart anymore you get an exception at runtime. This method
851can be used to test for existence of the C object part without causing an
852exception.
853
854=cut
855
856# the following variables are defined in .xs and must not be re-created
857our @CB_GLOBAL = (); # registry for all global events
858our @CB_ATTACHABLE = (); # registry for all attachables
859our @CB_OBJECT = (); # all objects (should not be used except in emergency)
860our @CB_PLAYER = ();
861our @CB_CLIENT = ();
862our @CB_TYPE = (); # registry for type (cf-object class) based events
863our @CB_MAP = ();
864
865my %attachment;
866
867sub cf::attachable::thawer_merge {
868 # simply override everything except _meta
869 local $_[0]{_meta};
870 %{$_[0]} = %{$_[1]};
871}
872
873sub _attach_cb($$$$) {
874 my ($registry, $event, $prio, $cb) = @_;
875
876 use sort 'stable';
877
878 $cb = [$prio, $cb];
879
880 @{$registry->[$event]} = sort
881 { $a->[0] cmp $b->[0] }
882 @{$registry->[$event] || []}, $cb;
883}
884
885# hack
886my %attachable_klass = map +($_ => 1), KLASS_OBJECT, KLASS_CLIENT, KLASS_PLAYER, KLASS_MAP;
887
888# attach handles attaching event callbacks
889# the only thing the caller has to do is pass the correct
890# registry (== where the callback attaches to).
891sub _attach {
892 my ($registry, $klass, @arg) = @_;
893
894 my $object_type;
895 my $prio = 0;
896 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;
897
898 #TODO: get rid of this hack
899 if ($attachable_klass{$klass}) {
900 %cb_id = (%cb_id, map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == KLASS_ATTACHABLE, 0 .. $#EVENT);
901 }
902
903 while (@arg) {
904 my $type = shift @arg;
905
906 if ($type eq "prio") {
907 $prio = shift @arg;
908
909 } elsif ($type eq "type") {
910 $object_type = shift @arg;
911 $registry = $CB_TYPE[$object_type] ||= [];
912
913 } elsif ($type eq "subtype") {
914 defined $object_type or Carp::croak "subtype specified without type";
915 my $object_subtype = shift @arg;
916 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
917
918 } elsif ($type eq "package") {
919 my $pkg = shift @arg;
920
921 while (my ($name, $id) = each %cb_id) {
922 if (my $cb = $pkg->can ($name)) {
923 _attach_cb $registry, $id, $prio, $cb;
924 }
925 }
926
927 } elsif (exists $cb_id{$type}) {
928 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
929
930 } elsif (ref $type) {
931 warn "attaching objects not supported, ignoring.\n";
932
933 } else {
934 shift @arg;
935 warn "attach argument '$type' not supported, ignoring.\n";
936 }
937 }
938}
939
940sub _object_attach {
941 my ($obj, $name, %arg) = @_;
942
943 return if exists $obj->{_attachment}{$name};
944
945 if (my $attach = $attachment{$name}) {
946 my $registry = $obj->registry;
947
948 for (@$attach) {
949 my ($klass, @attach) = @$_;
950 _attach $registry, $klass, @attach;
951 }
952
953 $obj->{$name} = \%arg;
954 } else {
955 warn "object uses attachment '$name' which is not available, postponing.\n";
956 }
957
958 $obj->{_attachment}{$name} = undef;
959}
960
961sub cf::attachable::attach {
962 if (ref $_[0]) {
963 _object_attach @_;
964 } else {
965 _attach shift->_attach_registry, @_;
966 }
967 _recalc_want;
968};
969
970# all those should be optimised
971sub cf::attachable::detach {
972 my ($obj, $name) = @_;
973
974 if (ref $obj) {
975 delete $obj->{_attachment}{$name};
976 reattach ($obj);
977 } else {
978 Carp::croak "cannot, currently, detach class attachments";
979 }
980 _recalc_want;
981};
982
983sub cf::attachable::attached {
984 my ($obj, $name) = @_;
985
986 exists $obj->{_attachment}{$name}
987}
988
989for my $klass (qw(ATTACHABLE GLOBAL OBJECT PLAYER CLIENT MAP)) {
990 eval "#line " . __LINE__ . " 'cf.pm'
991 sub cf::\L$klass\E::_attach_registry {
992 (\\\@CB_$klass, KLASS_$klass)
993 }
994
995 sub cf::\L$klass\E::attachment {
996 my \$name = shift;
997
998 \$attachment{\$name} = [[KLASS_$klass, \@_]];
999 }
1000 ";
1001 die if $@;
1002}
1003
1004our $override;
1005our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
1006
1007sub override {
1008 $override = 1;
1009 @INVOKE_RESULTS = (@_);
1010}
1011
1012sub do_invoke {
93 my $event_code = shift; 1013 my $event = shift;
1014 my $callbacks = shift;
94 1015
95 my $cb = $hook[$event_code]{$extension} 1016 @INVOKE_RESULTS = ();
1017
1018 local $override;
1019
1020 for (@$callbacks) {
1021 eval { &{$_->[1]} };
1022
1023 if ($@) {
1024 warn "$@";
1025 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
1026 override;
1027 }
1028
1029 return 1 if $override;
1030 }
1031
1032 0
1033}
1034
1035=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
1036
1037=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
1038
1039Generate an object-specific event with the given arguments.
1040
1041This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
1042removed in future versions), and there is no public API to access override
1043results (if you must, access C<@cf::INVOKE_RESULTS> directly).
1044
1045=back
1046
1047=cut
1048
1049#############################################################################
1050# object support
1051
1052sub _object_equal($$);
1053sub _object_equal($$) {
1054 my ($a, $b) = @_;
1055
1056 return 0 unless (ref $a) eq (ref $b);
1057
1058 if ("HASH" eq ref $a) {
1059 my @ka = keys %$a;
1060 my @kb = keys %$b;
1061
1062 return 0 if @ka != @kb;
1063
1064 for (0 .. $#ka) {
1065 return 0 unless $ka[$_] eq $kb[$_];
1066 return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
1067 }
1068
1069 } elsif ("ARRAY" eq ref $a) {
1070
1071 return 0 if @$a != @$b;
1072
1073 for (0 .. $#$a) {
1074 return 0 unless _object_equal $a->[$_], $b->[$_];
1075 }
1076
1077 } elsif ($a ne $b) {
1078 return 0;
1079 }
1080
1081 1
1082}
1083
1084our $SLOW_MERGES;#d#
1085sub _can_merge {
1086 my ($ob1, $ob2) = @_;
1087
1088 ++$SLOW_MERGES;#d#
1089
1090 # we do the slow way here
1091 return _object_equal $ob1, $ob2
1092}
1093
1094sub reattach {
1095 # basically do the same as instantiate, without calling instantiate
1096 my ($obj) = @_;
1097
1098 # no longer needed after getting rid of delete_package?
1099 #bless $obj, ref $obj; # re-bless in case extensions have been reloaded
1100
1101 my $registry = $obj->registry;
1102
1103 @$registry = ();
1104
1105 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
1106
1107 for my $name (keys %{ $obj->{_attachment} || {} }) {
1108 if (my $attach = $attachment{$name}) {
1109 for (@$attach) {
1110 my ($klass, @attach) = @$_;
1111 _attach $registry, $klass, @attach;
1112 }
1113 } else {
1114 warn "object uses attachment '$name' that is not available, postponing.\n";
1115 }
1116 }
1117}
1118
1119cf::attachable->attach (
1120 prio => -1000000,
1121 on_instantiate => sub {
1122 my ($obj, $data) = @_;
1123
1124 $data = decode_json $data;
1125
1126 for (@$data) {
1127 my ($name, $args) = @$_;
1128
1129 $obj->attach ($name, %{$args || {} });
1130 }
1131 },
1132 on_reattach => \&reattach,
1133 on_clone => sub {
1134 my ($src, $dst) = @_;
1135
1136 @{$dst->registry} = @{$src->registry};
1137
1138 %$dst = %$src;
1139
1140 %{$dst->{_attachment}} = %{$src->{_attachment}}
1141 if exists $src->{_attachment};
1142 },
1143);
1144
1145sub object_freezer_save {
1146 my ($filename, $rdata, $objs) = @_;
1147
1148 sync_job {
1149 if (length $$rdata) {
1150 utf8::decode (my $decname = $filename);
1151 warn sprintf "saving %s (%d,%d)\n",
1152 $decname, length $$rdata, scalar @$objs;
1153
1154 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1155 aio_chmod $fh, SAVE_MODE;
1156 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1157 if ($cf::USE_FSYNC) {
1158 aio_sync_file_range $fh, 0, 0, IO::AIO::SYNC_FILE_RANGE_WAIT_BEFORE | IO::AIO::SYNC_FILE_RANGE_WRITE | IO::AIO::SYNC_FILE_RANGE_WAIT_AFTER;
1159 aio_fsync $fh;
1160 }
1161 aio_close $fh;
1162
1163 if (@$objs) {
1164 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1165 aio_chmod $fh, SAVE_MODE;
1166 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1167 aio_write $fh, 0, (length $data), $data, 0;
1168 if ($cf::USE_FSYNC) {
1169 aio_sync_file_range $fh, 0, 0, IO::AIO::SYNC_FILE_RANGE_WAIT_BEFORE | IO::AIO::SYNC_FILE_RANGE_WRITE | IO::AIO::SYNC_FILE_RANGE_WAIT_AFTER;
1170 aio_fsync $fh;
1171 }
1172 aio_close $fh;
1173 aio_rename "$filename.pst~", "$filename.pst";
1174 }
1175 } else {
1176 aio_unlink "$filename.pst";
1177 }
1178
1179 aio_rename "$filename~", $filename;
1180
1181 $filename =~ s%/[^/]+$%%;
1182 aio_pathsync $filename if $cf::USE_FSYNC;
1183 } else {
1184 warn "unable to save objects: $filename~: $!\n";
1185 }
1186 } else {
1187 aio_unlink $filename;
1188 aio_unlink "$filename.pst";
1189 }
1190 };
1191}
1192
1193sub object_freezer_as_string {
1194 my ($rdata, $objs) = @_;
1195
1196 use Data::Dumper;
1197
1198 $$rdata . Dumper $objs
1199}
1200
1201sub object_thawer_load {
1202 my ($filename) = @_;
1203
1204 my ($data, $av);
1205
1206 (aio_load $filename, $data) >= 0
96 or return; 1207 or return;
97 1208
98 &$cb 1209 unless (aio_stat "$filename.pst") {
99} 1210 (aio_load "$filename.pst", $av) >= 0
100
101sub inject_global_event {
102 my $event = shift;
103
104 my $cb = $hook[$event]
105 or return; 1211 or return;
106 1212
107 List::Util::max map &$_, values %$cb 1213 my $st = eval { Coro::Storable::thaw $av };
108} 1214 $av = $st->{objs};
109
110sub inject_command {
111 my ($name, $obj, $params) = @_;
112
113 for my $cmd (@{ $command{$name} }) {
114 $cmd->[1]->($obj, $params);
115 } 1215 }
116 1216
117 -1 1217 utf8::decode (my $decname = $filename);
1218 warn sprintf "loading %s (%d,%d)\n",
1219 $decname, length $data, scalar @{$av || []};
1220
1221 ($data, $av)
118} 1222}
1223
1224=head2 COMMAND CALLBACKS
1225
1226=over 4
1227
1228=cut
1229
1230#############################################################################
1231# command handling &c
1232
1233=item cf::register_command $name => \&callback($ob,$args);
1234
1235Register a callback for execution when the client sends the user command
1236$name.
1237
1238=cut
119 1239
120sub register_command { 1240sub register_command {
121 my ($name, $time, $cb) = @_; 1241 my ($name, $cb) = @_;
122 1242
123 my $caller = caller; 1243 my $caller = caller;
124 #warn "registering command '$name/$time' to '$caller'"; 1244 #warn "registering command '$name/$time' to '$caller'";
125 1245
126 push @{ $command{$name} }, [$time, $cb, $caller]; 1246 push @{ $COMMAND{$name} }, [$caller, $cb];
127 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
128} 1247}
1248
1249=item cf::register_extcmd $name => \&callback($pl,$packet);
1250
1251Register a callback for execution when the client sends an (synchronous)
1252extcmd packet. Ext commands will be processed in the order they are
1253received by the server, like other user commands. The first argument is
1254the logged-in player. Ext commands can only be processed after a player
1255has logged in successfully.
1256
1257If the callback returns something, it is sent back as if reply was being
1258called.
1259
1260=item cf::register_exticmd $name => \&callback($ns,$packet);
1261
1262Register a callback for execution when the client sends an (asynchronous)
1263exticmd packet. Exti commands are processed by the server as soon as they
1264are received, i.e. out of order w.r.t. other commands. The first argument
1265is a client socket. Exti commands can be received anytime, even before
1266log-in.
1267
1268If the callback returns something, it is sent back as if reply was being
1269called.
1270
1271=cut
129 1272
130sub register_extcmd { 1273sub register_extcmd {
131 my ($name, $cb) = @_; 1274 my ($name, $cb) = @_;
132 1275
133 my $caller = caller; 1276 $EXTCMD{$name} = $cb;
134 #warn "registering extcmd '$name' to '$caller'";
135
136 $extcmd{$name} = [$cb, $caller];
137} 1277}
1278
1279sub register_exticmd {
1280 my ($name, $cb) = @_;
1281
1282 $EXTICMD{$name} = $cb;
1283}
1284
1285use File::Glob ();
1286
1287cf::player->attach (
1288 on_command => sub {
1289 my ($pl, $name, $params) = @_;
1290
1291 my $cb = $COMMAND{$name}
1292 or return;
1293
1294 for my $cmd (@$cb) {
1295 $cmd->[1]->($pl->ob, $params);
1296 }
1297
1298 cf::override;
1299 },
1300 on_extcmd => sub {
1301 my ($pl, $buf) = @_;
1302
1303 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1304
1305 if (ref $msg) {
1306 my ($type, $reply, @payload) =
1307 "ARRAY" eq ref $msg
1308 ? @$msg
1309 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1310
1311 my @reply;
1312
1313 if (my $cb = $EXTCMD{$type}) {
1314 @reply = $cb->($pl, @payload);
1315 }
1316
1317 $pl->ext_reply ($reply, @reply)
1318 if $reply;
1319
1320 } else {
1321 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1322 }
1323
1324 cf::override;
1325 },
1326);
1327
1328# "readahead" all extensions
1329sub cache_extensions {
1330 my $grp = IO::AIO::aio_group;
1331
1332 add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
1333 for (grep /\.ext$/, @{$_[0]}) {
1334 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
1335 }
1336 };
1337
1338 $grp
1339}
1340
1341sub load_extensions {
1342 cf::sync_job {
1343 my %todo;
1344
1345 for my $path (<$LIBDIR/*.ext>) {
1346 next unless -r $path;
1347
1348 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1349 my $base = $1;
1350 my $pkg = $1;
1351 $pkg =~ s/[^[:word:]]/_/g;
1352 $pkg = "ext::$pkg";
1353
1354 open my $fh, "<:utf8", $path
1355 or die "$path: $!";
1356
1357 my $source = do { local $/; <$fh> };
1358
1359 my %ext = (
1360 path => $path,
1361 base => $base,
1362 pkg => $pkg,
1363 );
1364
1365 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1366 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1367
1368 $ext{source} =
1369 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n"
1370 . "#line 1 \"$path\"\n{\n"
1371 . $source
1372 . "\n};\n1";
1373
1374 $todo{$base} = \%ext;
1375 }
1376
1377 my %done;
1378 while (%todo) {
1379 my $progress;
1380
1381 while (my ($k, $v) = each %todo) {
1382 for (split /,\s*/, $v->{meta}{depends}) {
1383 goto skip
1384 unless exists $done{$_};
1385 }
1386
1387 warn "... loading '$k' into '$v->{pkg}'\n";
1388
1389 unless (eval $v->{source}) {
1390 my $msg = $@ ? "$v->{path}: $@\n"
1391 : "$v->{base}: extension inactive.\n";
1392
1393 if (exists $v->{meta}{mandatory}) {
1394 warn $msg;
1395 cf::cleanup "mandatory extension failed to load, exiting.";
1396 }
1397
1398 warn $msg;
1399 }
1400
1401 $done{$k} = delete $todo{$k};
1402 push @EXTS, $v->{pkg};
1403 $progress = 1;
1404 }
1405
1406 skip:
1407 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1408 unless $progress;
1409 }
1410 };
1411}
1412
1413#############################################################################
1414
1415=back
1416
1417=head2 CORE EXTENSIONS
1418
1419Functions and methods that extend core deliantra objects.
1420
1421=cut
1422
1423package cf::player;
1424
1425use Coro::AIO;
1426
1427=head3 cf::player
1428
1429=over 4
1430
1431=item cf::player::num_playing
1432
1433Returns the official number of playing players, as per the Crossfire metaserver rules.
1434
1435=cut
1436
1437sub num_playing {
1438 scalar grep
1439 $_->ob->map
1440 && !$_->hidden
1441 && !$_->ob->flag (cf::FLAG_WIZ),
1442 cf::player::list
1443}
1444
1445=item cf::player::find $login
1446
1447Returns the given player object, loading it if necessary (might block).
1448
1449=cut
1450
1451sub playerdir($) {
1452 "$PLAYERDIR/"
1453 . (ref $_[0] ? $_[0]->ob->name : $_[0])
1454}
1455
1456sub path($) {
1457 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
1458
1459 (playerdir $login) . "/playerdata"
1460}
1461
1462sub find_active($) {
1463 $cf::PLAYER{$_[0]}
1464 and $cf::PLAYER{$_[0]}->active
1465 and $cf::PLAYER{$_[0]}
1466}
1467
1468sub exists($) {
1469 my ($login) = @_;
1470
1471 $cf::PLAYER{$login}
1472 or !aio_stat path $login
1473}
1474
1475sub find($) {
1476 return $cf::PLAYER{$_[0]} || do {
1477 my $login = $_[0];
1478
1479 my $guard = cf::lock_acquire "user_find:$login";
1480
1481 $cf::PLAYER{$_[0]} || do {
1482 # rename old playerfiles to new ones
1483 #TODO: remove when no longer required
1484 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1485 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1486 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1487 aio_unlink +(playerdir $login) . "/$login.pl";
1488
1489 my $f = new_from_file cf::object::thawer path $login
1490 or return;
1491
1492 my $pl = cf::player::load_pl $f
1493 or return;
1494
1495 local $cf::PLAYER_LOADING{$login} = $pl;
1496 $f->resolve_delayed_derefs;
1497 $cf::PLAYER{$login} = $pl
1498 }
1499 }
1500}
1501
1502sub save($) {
1503 my ($pl) = @_;
1504
1505 return if $pl->{deny_save};
1506
1507 my $path = path $pl;
1508 my $guard = cf::lock_acquire "user_save:$path";
1509
1510 return if $pl->{deny_save};
1511
1512 aio_mkdir playerdir $pl, 0770;
1513 $pl->{last_save} = $cf::RUNTIME;
1514
1515 cf::get_slot 0.01;
1516
1517 $pl->save_pl ($path);
1518 cf::cede_to_tick;
1519}
1520
1521sub new($) {
1522 my ($login) = @_;
1523
1524 my $self = create;
1525
1526 $self->ob->name ($login);
1527 $self->{deny_save} = 1;
1528
1529 $cf::PLAYER{$login} = $self;
1530
1531 $self
1532}
1533
1534=item $player->send_msg ($channel, $msg, $color, [extra...])
1535
1536=cut
1537
1538sub send_msg {
1539 my $ns = shift->ns
1540 or return;
1541 $ns->send_msg (@_);
1542}
1543
1544=item $pl->quit_character
1545
1546Nukes the player without looking back. If logged in, the connection will
1547be destroyed. May block for a long time.
1548
1549=cut
1550
1551sub quit_character {
1552 my ($pl) = @_;
1553
1554 my $name = $pl->ob->name;
1555
1556 $pl->{deny_save} = 1;
1557 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1558
1559 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1560 $pl->deactivate;
1561 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1562 $pl->ob->check_score;
1563 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1564 $pl->ns->destroy if $pl->ns;
1565
1566 my $path = playerdir $pl;
1567 my $temp = "$path~$cf::RUNTIME~deleting~";
1568 aio_rename $path, $temp;
1569 delete $cf::PLAYER{$pl->ob->name};
1570 $pl->destroy;
1571
1572 my $prefix = qr<^~\Q$name\E/>;
1573
1574 # nuke player maps
1575 $cf::MAP{$_}->nuke for grep /$prefix/, keys %cf::MAP;
1576
1577 IO::AIO::aio_rmtree $temp;
1578}
1579
1580=item $pl->kick
1581
1582Kicks a player out of the game. This destroys the connection.
1583
1584=cut
1585
1586sub kick {
1587 my ($pl, $kicker) = @_;
1588
1589 $pl->invoke (cf::EVENT_PLAYER_KICK, $kicker);
1590 $pl->killer ("kicked");
1591 $pl->ns->destroy;
1592}
1593
1594=item cf::player::list_logins
1595
1596Returns am arrayref of all valid playernames in the system, can take a
1597while and may block, so not sync_job-capable, ever.
1598
1599=cut
1600
1601sub list_logins {
1602 my $dirs = aio_readdir $PLAYERDIR
1603 or return [];
1604
1605 my @logins;
1606
1607 for my $login (@$dirs) {
1608 my $path = path $login;
1609
1610 # a .pst is a dead give-away for a valid player
1611 # if no pst file found, open and chekc for blocked users
1612 if (aio_stat "$path.pst") {
1613 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1614 aio_read $fh, 0, 512, my $buf, 0 or next;
1615 $buf !~ /^password -------------$/m or next; # official not-valid tag
1616 }
1617
1618 utf8::decode $login;
1619 push @logins, $login;
1620 }
1621
1622 \@logins
1623}
1624
1625=item $player->maps
1626
1627Returns an arrayref of map paths that are private for this
1628player. May block.
1629
1630=cut
1631
1632sub maps($) {
1633 my ($pl) = @_;
1634
1635 $pl = ref $pl ? $pl->ob->name : $pl;
1636
1637 my $files = aio_readdir playerdir $pl
1638 or return;
1639
1640 my @paths;
1641
1642 for (@$files) {
1643 utf8::decode $_;
1644 next if /\.(?:pl|pst)$/;
1645 next unless /^$PATH_SEP/o;
1646
1647 push @paths, cf::map::normalise "~$pl/$_";
1648 }
1649
1650 \@paths
1651}
1652
1653=item $protocol_xml = $player->expand_cfpod ($cfpod)
1654
1655Expand deliantra pod fragments into protocol xml.
1656
1657=item $player->ext_reply ($msgid, @msg)
1658
1659Sends an ext reply to the player.
1660
1661=cut
1662
1663sub ext_reply($$@) {
1664 my ($self, $id, @msg) = @_;
1665
1666 $self->ns->ext_reply ($id, @msg)
1667}
1668
1669=item $player->ext_msg ($type, @msg)
1670
1671Sends an ext event to the client.
1672
1673=cut
1674
1675sub ext_msg($$@) {
1676 my ($self, $type, @msg) = @_;
1677
1678 $self->ns->ext_msg ($type, @msg);
1679}
1680
1681=head3 cf::region
1682
1683=over 4
1684
1685=cut
1686
1687package cf::region;
1688
1689=item cf::region::find_by_path $path
1690
1691Tries to decuce the likely region for a map knowing only its path.
1692
1693=cut
1694
1695sub find_by_path($) {
1696 my ($path) = @_;
1697
1698 my ($match, $specificity);
1699
1700 for my $region (list) {
1701 if ($region->{match} && $path =~ $region->{match}) {
1702 ($match, $specificity) = ($region, $region->specificity)
1703 if $region->specificity > $specificity;
1704 }
1705 }
1706
1707 $match
1708}
1709
1710=back
1711
1712=head3 cf::map
1713
1714=over 4
1715
1716=cut
1717
1718package cf::map;
1719
1720use Fcntl;
1721use Coro::AIO;
1722
1723use overload
1724 '""' => \&as_string,
1725 fallback => 1;
1726
1727our $MAX_RESET = 3600;
1728our $DEFAULT_RESET = 3000;
1729
1730sub generate_random_map {
1731 my ($self, $rmp) = @_;
1732
1733 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1734
1735 # mit "rum" bekleckern, nicht
1736 $self->_create_random_map (
1737 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1738 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1739 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1740 $rmp->{exit_on_final_map},
1741 $rmp->{xsize}, $rmp->{ysize},
1742 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1743 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1744 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1745 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1746 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1747 (cf::region::find $rmp->{region}), $rmp->{custom}
1748 )
1749}
1750
1751=item cf::map->register ($regex, $prio)
1752
1753Register a handler for the map path matching the given regex at the
1754givne priority (higher is better, built-in handlers have priority 0, the
1755default).
1756
1757=cut
138 1758
139sub register { 1759sub register {
1760 my (undef, $regex, $prio) = @_;
1761 my $pkg = caller;
1762
1763 no strict;
1764 push @{"$pkg\::ISA"}, __PACKAGE__;
1765
1766 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1767}
1768
1769# also paths starting with '/'
1770$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}];
1771
1772sub thawer_merge {
140 my ($base, $pkg) = @_; 1773 my ($self, $merge) = @_;
141 1774
142 for my $idx (0 .. $#EVENT) { 1775 # we have to keep some variables in memory intact
143 if (my $ref = $pkg->can ("on_$EVENT[$idx]")) { 1776 local $self->{path};
144 #warn "registering $EVENT[$idx] hook to '$pkg'\n"; 1777 local $self->{load_path};
145 $hook[$idx]{$base} = $ref;
146 }
147 }
148}
149 1778
150sub load_extension { 1779 $self->SUPER::thawer_merge ($merge);
1780}
1781
1782sub normalise {
151 my ($path) = @_; 1783 my ($path, $base) = @_;
152 1784
153 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 1785 $path = "$path"; # make sure its a string
154 my $base = $1;
155 my $pkg = $1;
156 $pkg =~ s/[^[:word:]]/_/g;
157 $pkg = "cf::ext::$pkg";
158 1786
159 warn "loading '$path' into '$pkg'\n"; 1787 $path =~ s/\.map$//;
160 1788
161 open my $fh, "<:utf8", $path 1789 # map plan:
162 or die "$path: $!"; 1790 #
1791 # /! non-realised random map exit (special hack!)
1792 # {... are special paths that are not being touched
1793 # ?xxx/... are special absolute paths
1794 # ?random/... random maps
1795 # /... normal maps
1796 # ~user/... per-player map of a specific user
163 1797
164 my $source = 1798 $path =~ s/$PATH_SEP/\//go;
165 "package $pkg; use strict; use utf8;\n"
166 . "#line 1 \"$path\"\n{\n"
167 . (do { local $/; <$fh> })
168 . "\n};\n1";
169 1799
170 eval $source 1800 # treat it as relative path if it starts with
171 or die "$path: $@"; 1801 # something that looks reasonable
1802 if ($path =~ m{^(?:\./|\.\./|\w)}) {
1803 $base or Carp::carp "normalise called with relative path and no base: '$path'";
172 1804
173 push @exts, $pkg; 1805 $base =~ s{[^/]+/?$}{};
174 $ext_pkg{$base} = $pkg; 1806 $path = "$base/$path";
1807 }
175 1808
176# no strict 'refs'; 1809 for ($path) {
177# @{"$pkg\::ISA"} = ext::; 1810 redo if s{//}{/};
1811 redo if s{/\.?/}{/};
1812 redo if s{/[^/]+/\.\./}{/};
1813 }
178 1814
179 register $base, $pkg; 1815 $path
180} 1816}
181 1817
182sub unload_extension { 1818sub new_from_path {
1819 my (undef, $path, $base) = @_;
1820
1821 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object
1822
1823 $path = normalise $path, $base;
1824
1825 for my $pkg (sort { $EXT_MAP{$b}[0] <=> $EXT_MAP{$a}[0] } keys %EXT_MAP) {
1826 if ($path =~ $EXT_MAP{$pkg}[1]) {
1827 my $self = bless cf::map::new, $pkg;
1828 $self->{path} = $path; $self->path ($path);
1829 $self->init; # pass $1 etc.
1830 return $self;
1831 }
1832 }
1833
1834 Carp::cluck "unable to resolve path '$path' (base '$base').";
1835 ()
1836}
1837
1838sub init {
183 my ($pkg) = @_; 1839 my ($self) = @_;
184 1840
185 warn "removing extension $pkg\n"; 1841 $self
1842}
186 1843
187 # remove hooks 1844sub as_string {
188 for my $idx (0 .. $#EVENT) { 1845 my ($self) = @_;
189 delete $hook[$idx]{$pkg}; 1846
1847 "$self->{path}"
1848}
1849
1850# the displayed name, this is a one way mapping
1851sub visible_name {
1852 &as_string
1853}
1854
1855# the original (read-only) location
1856sub load_path {
1857 my ($self) = @_;
1858
1859 "$MAPDIR/$self->{path}.map"
1860}
1861
1862# the temporary/swap location
1863sub save_path {
1864 my ($self) = @_;
1865
1866 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1867 "$TMPDIR/$path.map"
1868}
1869
1870# the unique path, undef == no special unique path
1871sub uniq_path {
1872 my ($self) = @_;
1873
1874 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1875 "$UNIQUEDIR/$path"
1876}
1877
1878sub decay_objects {
1879 my ($self) = @_;
1880
1881 return if $self->{deny_reset};
1882
1883 $self->do_decay_objects;
1884}
1885
1886sub unlink_save {
1887 my ($self) = @_;
1888
1889 utf8::encode (my $save = $self->save_path);
1890 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
1891 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst";
1892}
1893
1894sub load_header_from($) {
1895 my ($self, $path) = @_;
1896
1897 utf8::encode $path;
1898 my $f = new_from_file cf::object::thawer $path
1899 or return;
1900
1901 $self->_load_header ($f)
1902 or return;
1903
1904 local $MAP_LOADING{$self->{path}} = $self;
1905 $f->resolve_delayed_derefs;
1906
1907 $self->{load_path} = $path;
1908
190 } 1909 1
1910}
191 1911
192 # remove commands 1912sub load_header_orig {
193 for my $name (keys %command) { 1913 my ($self) = @_;
194 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} };
195 1914
196 if (@cb) { 1915 $self->load_header_from ($self->load_path)
197 $command{$name} = \@cb; 1916}
198 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb; 1917
1918sub load_header_temp {
1919 my ($self) = @_;
1920
1921 $self->load_header_from ($self->save_path)
1922}
1923
1924sub prepare_temp {
1925 my ($self) = @_;
1926
1927 $self->last_access ((delete $self->{last_access})
1928 || $cf::RUNTIME); #d#
1929 # safety
1930 $self->{instantiate_time} = $cf::RUNTIME
1931 if $self->{instantiate_time} > $cf::RUNTIME;
1932}
1933
1934sub prepare_orig {
1935 my ($self) = @_;
1936
1937 $self->{load_original} = 1;
1938 $self->{instantiate_time} = $cf::RUNTIME;
1939 $self->last_access ($cf::RUNTIME);
1940 $self->instantiate;
1941}
1942
1943sub load_header {
1944 my ($self) = @_;
1945
1946 if ($self->load_header_temp) {
1947 $self->prepare_temp;
199 } else { 1948 } else {
200 delete $command{$name}; 1949 $self->load_header_orig
201 delete $COMMAND{"$name\000"}; 1950 or return;
202 } 1951 $self->prepare_orig;
1952 }
1953
1954 $self->{deny_reset} = 1
1955 if $self->no_reset;
1956
1957 $self->default_region (cf::region::find_by_path $self->{path})
1958 unless $self->default_region;
1959
203 } 1960 1
1961}
204 1962
205 # remove extcmds 1963sub find;
206 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 1964sub find {
207 delete $extcmd{$name}; 1965 my ($path, $origin) = @_;
1966
1967 $path = normalise $path, $origin && $origin->path;
1968
1969 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1970 my $guard2 = cf::lock_acquire "map_find:$path";
1971
1972 $cf::MAP{$path} || do {
1973 my $map = new_from_path cf::map $path
1974 or return;
1975
1976 $map->{last_save} = $cf::RUNTIME;
1977
1978 $map->load_header
1979 or return;
1980
1981 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1982 # doing this can freeze the server in a sync job, obviously
1983 #$cf::WAIT_FOR_TICK->wait;
1984 undef $guard2;
1985 undef $guard1;
1986 $map->reset;
1987 return find $path;
1988 }
1989
1990 $cf::MAP{$path} = $map
1991 }
1992}
1993
1994sub pre_load { }
1995sub post_load { }
1996
1997sub load {
1998 my ($self) = @_;
1999
2000 local $self->{deny_reset} = 1; # loading can take a long time
2001
2002 my $path = $self->{path};
2003
208 } 2004 {
2005 my $guard = cf::lock_acquire "map_data:$path";
209 2006
210 if (my $cb = $pkg->can ("on_unload")) { 2007 return unless $self->valid;
211 eval { 2008 return unless $self->in_memory == cf::MAP_SWAPPED;
212 $cb->($pkg); 2009
2010 $self->in_memory (cf::MAP_LOADING);
2011
2012 $self->alloc;
2013
2014 $self->pre_load;
2015 cf::cede_to_tick;
2016
2017 my $f = new_from_file cf::object::thawer $self->{load_path};
2018 $f->skip_block;
2019 $self->_load_objects ($f)
2020 or return;
2021
2022 $self->post_load_original
2023 if delete $self->{load_original};
2024
2025 if (my $uniq = $self->uniq_path) {
2026 utf8::encode $uniq;
2027 unless (aio_stat $uniq) {
2028 if (my $f = new_from_file cf::object::thawer $uniq) {
2029 $self->clear_unique_items;
2030 $self->_load_objects ($f);
2031 $f->resolve_delayed_derefs;
213 1 2032 }
214 } or warn "$pkg unloaded, but with errors: $@";
215 }
216
217 Symbol::delete_package $pkg;
218}
219
220sub load_extensions {
221 my $LIBDIR = maps_directory "perl";
222
223 for my $ext (<$LIBDIR/*.ext>) {
224 next unless -r $ext;
225 eval {
226 load_extension $ext;
227 1
228 } or warn "$ext not loaded: $@";
229 }
230}
231
232register_command "perl-reload", 0, sub {
233 my ($who, $arg) = @_;
234
235 if ($who->flag (FLAG_WIZ)) {
236 $who->message ("reloading...");
237
238 warn "reloading...\n";
239 eval {
240 # 1. cancel all watchers
241 $_->cancel for Event::all_watchers;
242
243 # 2. unload all extensions
244 for (@exts) {
245 $who->message ("unloading <$_>");
246 unload_extension $_;
247 } 2033 }
2034 }
248 2035
249 # 3. unload all modules loaded from $LIBDIR 2036 $f->resolve_delayed_derefs;
2037
2038 cf::cede_to_tick;
2039 # now do the right thing for maps
2040 $self->link_multipart_objects;
2041 $self->difficulty ($self->estimate_difficulty)
2042 unless $self->difficulty;
2043 cf::cede_to_tick;
2044
2045 unless ($self->{deny_activate}) {
2046 $self->decay_objects;
2047 $self->fix_auto_apply;
2048 $self->update_buttons;
2049 cf::cede_to_tick;
2050 $self->activate;
2051 }
2052
2053 $self->{last_save} = $cf::RUNTIME;
2054 $self->last_access ($cf::RUNTIME);
2055
2056 $self->in_memory (cf::MAP_ACTIVE);
2057 }
2058
2059 $self->post_load;
2060}
2061
2062sub customise_for {
2063 my ($self, $ob) = @_;
2064
2065 return find "~" . $ob->name . "/" . $self->{path}
2066 if $self->per_player;
2067
2068# return find "?party/" . $ob->name . "/" . $self->{path}
2069# if $self->per_party;
2070
2071 $self
2072}
2073
2074# find and load all maps in the 3x3 area around a map
2075sub load_neighbours {
2076 my ($map) = @_;
2077
2078 my @neigh; # diagonal neighbours
2079
2080 for (0 .. 3) {
2081 my $neigh = $map->tile_path ($_)
2082 or next;
2083 $neigh = find $neigh, $map
2084 or next;
2085 $neigh->load;
2086
2087 push @neigh,
2088 [$neigh->tile_path (($_ + 3) % 4), $neigh],
2089 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2090 }
2091
2092 for (grep defined $_->[0], @neigh) {
2093 my ($path, $origin) = @$_;
2094 my $neigh = find $path, $origin
2095 or next;
2096 $neigh->load;
2097 }
2098}
2099
2100sub find_sync {
2101 my ($path, $origin) = @_;
2102
2103 cf::sync_job { find $path, $origin }
2104}
2105
2106sub do_load_sync {
2107 my ($map) = @_;
2108
2109 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
2110 if $Coro::current == $Coro::main;
2111
2112 cf::sync_job { $map->load };
2113}
2114
2115our %MAP_PREFETCH;
2116our $MAP_PREFETCHER = undef;
2117
2118sub find_async {
2119 my ($path, $origin, $load) = @_;
2120
2121 $path = normalise $path, $origin && $origin->{path};
2122
2123 if (my $map = $cf::MAP{$path}) {
2124 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
2125 }
2126
2127 $MAP_PREFETCH{$path} |= $load;
2128
2129 $MAP_PREFETCHER ||= cf::async {
2130 $Coro::current->{desc} = "map prefetcher";
2131
2132 while (%MAP_PREFETCH) {
250 while (my ($k, $v) = each %INC) { 2133 while (my ($k, $v) = each %MAP_PREFETCH) {
251 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2134 if (my $map = find $k) {
252 2135 $map->load if $v;
253 $who->message ("removing <$k>");
254 delete $INC{$k};
255
256 $k =~ s/\.pm$//;
257 $k =~ s/\//::/g;
258
259 if (my $cb = $k->can ("unload_module")) {
260 $cb->();
261 } 2136 }
262 2137
263 Symbol::delete_package $k; 2138 delete $MAP_PREFETCH{$k};
264 } 2139 }
265
266 # 4. get rid of ext::, as good as possible
267 Symbol::delete_package "ext::$_"
268 for qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region);
269
270 # 5. remove register_script_function callbacks
271 # TODO
272
273 # 6. unload cf.pm "a bit"
274 delete $INC{"cf.pm"};
275
276 # don't, removes xs symbols, too
277 #Symbol::delete_package __PACKAGE__;
278
279 # 7. reload cf.pm
280 $who->message ("reloading cf.pm");
281 require cf;
282 }; 2140 }
283 warn $@ if $@; 2141 undef $MAP_PREFETCHER;
284 $who->message ($@) if $@; 2142 };
285 warn "reloaded\n"; 2143 $MAP_PREFETCHER->prio (6);
286 2144
287 $who->message ("reloaded"); 2145 ()
2146}
2147
2148sub save {
2149 my ($self) = @_;
2150
2151 my $lock = cf::lock_acquire "map_data:$self->{path}";
2152
2153 $self->{last_save} = $cf::RUNTIME;
2154
2155 return unless $self->dirty;
2156
2157 my $save = $self->save_path; utf8::encode $save;
2158 my $uniq = $self->uniq_path; utf8::encode $uniq;
2159
2160 $self->{load_path} = $save;
2161
2162 return if $self->{deny_save};
2163
2164 local $self->{last_access} = $self->last_access;#d#
2165
2166 cf::async {
2167 $Coro::current->{desc} = "map player save";
2168 $_->contr->save for $self->players;
2169 };
2170
2171 cf::get_slot 0.02;
2172
2173 if ($uniq) {
2174 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
2175 $self->_save_objects ($uniq, cf::IO_UNIQUES);
288 } else { 2176 } else {
289 $who->message ("Intruder Alert!"); 2177 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
290 } 2178 }
291};
292
293#############################################################################
294# utility functions
295
296use JSON::Syck (); # TODO# replace by JSON::PC once working
297
298sub from_json($) {
299 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
300 JSON::Syck::Load $_[0]
301} 2179}
302 2180
303sub to_json($) { 2181sub swap_out {
304 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
305 JSON::Syck::Dump $_[0]
306}
307
308#############################################################################
309# extcmd framework, basically convert ext <msg>
310# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
311
312sub on_extcmd {
313 my ($pl, $buf) = @_; 2182 my ($self) = @_;
314 2183
315 my $msg = eval { from_json $buf }; 2184 # save first because save cedes
2185 $self->save;
316 2186
317 if (ref $msg) { 2187 my $lock = cf::lock_acquire "map_data:$self->{path}";
318 if (my $cb = $extcmd{$msg->{msgtype}}) { 2188
319 if (my %reply = $cb->[0]->($pl, $msg)) { 2189 return if $self->players;
320 $pl->ext_reply ($msg->{msgid}, %reply); 2190 return if $self->in_memory != cf::MAP_ACTIVE;
321 } 2191 return if $self->{deny_save};
322 } 2192
2193 $self->in_memory (cf::MAP_SWAPPED);
2194
2195 $self->deactivate;
2196 $_->clear_links_to ($self) for values %cf::MAP;
2197 $self->clear;
2198}
2199
2200sub reset_at {
2201 my ($self) = @_;
2202
2203 # TODO: safety, remove and allow resettable per-player maps
2204 return 1e99 if $self->{deny_reset};
2205
2206 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2207 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2208
2209 $time + $to
2210}
2211
2212sub should_reset {
2213 my ($self) = @_;
2214
2215 $self->reset_at <= $cf::RUNTIME
2216}
2217
2218sub reset {
2219 my ($self) = @_;
2220
2221 my $lock = cf::lock_acquire "map_data:$self->{path}";
2222
2223 return if $self->players;
2224
2225 warn "resetting map ", $self->path;
2226
2227 $self->in_memory (cf::MAP_SWAPPED);
2228
2229 # need to save uniques path
2230 unless ($self->{deny_save}) {
2231 my $uniq = $self->uniq_path; utf8::encode $uniq;
2232
2233 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2234 if $uniq;
2235 }
2236
2237 delete $cf::MAP{$self->path};
2238
2239 $self->deactivate;
2240 $_->clear_links_to ($self) for values %cf::MAP;
2241 $self->clear;
2242
2243 $self->unlink_save;
2244 $self->destroy;
2245}
2246
2247my $nuke_counter = "aaaa";
2248
2249sub nuke {
2250 my ($self) = @_;
2251
2252 {
2253 my $lock = cf::lock_acquire "map_data:$self->{path}";
2254
2255 delete $cf::MAP{$self->path};
2256
2257 $self->unlink_save;
2258
2259 bless $self, "cf::map";
2260 delete $self->{deny_reset};
2261 $self->{deny_save} = 1;
2262 $self->reset_timeout (1);
2263 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2264
2265 $cf::MAP{$self->path} = $self;
2266 }
2267
2268 $self->reset; # polite request, might not happen
2269}
2270
2271=item $maps = cf::map::tmp_maps
2272
2273Returns an arrayref with all map paths of currently instantiated and saved
2274maps. May block.
2275
2276=cut
2277
2278sub tmp_maps() {
2279 [
2280 map {
2281 utf8::decode $_;
2282 /\.map$/
2283 ? normalise $_
2284 : ()
2285 } @{ aio_readdir $TMPDIR or [] }
2286 ]
2287}
2288
2289=item $maps = cf::map::random_maps
2290
2291Returns an arrayref with all map paths of currently instantiated and saved
2292random maps. May block.
2293
2294=cut
2295
2296sub random_maps() {
2297 [
2298 map {
2299 utf8::decode $_;
2300 /\.map$/
2301 ? normalise "?random/$_"
2302 : ()
2303 } @{ aio_readdir $RANDOMDIR or [] }
2304 ]
2305}
2306
2307=item cf::map::unique_maps
2308
2309Returns an arrayref of paths of all shared maps that have
2310instantiated unique items. May block.
2311
2312=cut
2313
2314sub unique_maps() {
2315 [
2316 map {
2317 utf8::decode $_;
2318 s/\.map$//; # TODO future compatibility hack
2319 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
2320 ? ()
2321 : normalise $_
2322 } @{ aio_readdir $UNIQUEDIR or [] }
2323 ]
2324}
2325
2326=back
2327
2328=head3 cf::object
2329
2330=cut
2331
2332package cf::object;
2333
2334=over 4
2335
2336=item $ob->inv_recursive
2337
2338Returns the inventory of the object I<and> their inventories, recursively,
2339but I<not> the object itself.
2340
2341=cut
2342
2343sub inv_recursive_;
2344sub inv_recursive_ {
2345 map { $_, inv_recursive_ $_->inv } @_
2346}
2347
2348sub inv_recursive {
2349 inv_recursive_ inv $_[0]
2350}
2351
2352=item $ref = $ob->ref
2353
2354Creates and returns a persistent reference to an object that can be stored as a string.
2355
2356=item $ob = cf::object::deref ($refstring)
2357
2358returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2359even if the object actually exists. May block.
2360
2361=cut
2362
2363sub deref {
2364 my ($ref) = @_;
2365
2366 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2367 my ($uuid, $name) = ($1, $2);
2368 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2369 or return;
2370 $pl->ob->uuid eq $uuid
2371 or return;
2372
2373 $pl->ob
323 } else { 2374 } else {
324 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 2375 warn "$ref: cannot resolve object reference\n";
325 } 2376 undef
326
327 1 2377 }
328} 2378}
329 2379
330############################################################################# 2380package cf;
331# load/save/clean perl data associated with a map
332 2381
333*on_mapclean = sub { 2382=back
334 my ($map) = @_;
335 2383
336 my $path = $map->tmpname; 2384=head3 cf::object::player
337 defined $path or return;
338 2385
339 unlink "$path.cfperl"; 2386=over 4
340};
341 2387
342*on_mapin =
343*on_mapload = sub {
344 my ($map) = @_;
345
346 my $path = $map->tmpname;
347 $path = $map->path unless defined $path;
348
349 open my $fh, "<:raw", "$path.cfperl"
350 or return; # no perl data
351
352 my $data = Storable::thaw do { local $/; <$fh> };
353
354 $data->{version} <= 1
355 or return; # too new
356
357 $map->_set_obs ($data->{obs});
358};
359
360*on_mapout = sub {
361 my ($map) = @_;
362
363 my $path = $map->tmpname;
364 $path = $map->path unless defined $path;
365
366 my $obs = $map->_get_obs;
367
368 if (defined $obs) {
369 open my $fh, ">:raw", "$path.cfperl"
370 or die "$path.cfperl: $!";
371
372 stat $path;
373
374 print $fh Storable::nfreeze {
375 size => (stat _)[7],
376 time => (stat _)[9],
377 version => 1,
378 obs => $obs,
379 };
380
381 chmod SAVE_MODE, "$path.cfperl"; # very racy, but cf-compatible *g*
382 } else {
383 unlink "$path.cfperl";
384 }
385};
386
387#############################################################################
388# load/save perl data associated with player->ob objects
389
390sub all_objects(@) {
391 @_, map all_objects ($_->inv), @_
392}
393
394*on_player_load = sub {
395 my ($ob, $path) = @_;
396
397 for my $o (all_objects $ob) {
398 if (my $value = $o->get_ob_key_value ("_perl_data")) {
399 $o->set_ob_key_value ("_perl_data");
400
401 %$o = %{ Storable::thaw pack "H*", $value };
402 }
403 }
404};
405
406*on_player_save = sub {
407 my ($ob, $path) = @_;
408
409 $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_)
410 for grep %$_, all_objects $ob;
411};
412
413#############################################################################
414# core extensions - in perl
415
416my $delta_timer = Event->timer (
417 parked => 1,
418 prio => Event::PRIO_HIGH,
419 cb => sub { Event::unloop (undef) },
420);
421
422sub sleep_delta($) {
423 $delta_timer->at (Event::time + $_[0]);
424 $delta_timer->start;
425 Event::loop;
426}
427
428=item cf::player::exists $login
429
430Returns true when the given account exists.
431
432=cut
433
434sub cf::player::exists($) {
435 cf::player::find $_[0]
436 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
437}
438
439=item $player->reply ($npc, $msg[, $flags]) 2388=item $player_object->reply ($npc, $msg[, $flags])
440 2389
441Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 2390Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
442can be C<undef>. Does the right thing when the player is currently in a 2391can be C<undef>. Does the right thing when the player is currently in a
443dialogue with the given NPC character. 2392dialogue with the given NPC character.
444 2393
445=cut 2394=cut
446 2395
2396our $SAY_CHANNEL = {
2397 id => "say",
2398 title => "Map",
2399 reply => "say ",
2400 tooltip => "Things said to and replied from NPCs near you and other players on the same map only.",
2401};
2402
2403our $CHAT_CHANNEL = {
2404 id => "chat",
2405 title => "Chat",
2406 reply => "chat ",
2407 tooltip => "Player chat and shouts, global to the server.",
2408};
2409
447# rough implementation of a future "reply" method that works 2410# rough implementation of a future "reply" method that works
448# with dialog boxes. 2411# with dialog boxes.
2412#TODO: the first argument must go, split into a $npc->reply_to ( method
449sub cf::object::player::reply($$$;$) { 2413sub cf::object::player::reply($$$;$) {
450 my ($self, $npc, $msg, $flags) = @_; 2414 my ($self, $npc, $msg, $flags) = @_;
451 2415
452 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2416 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
453 2417
454 if ($self->{record_replies}) { 2418 if ($self->{record_replies}) {
455 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2419 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2420
456 } else { 2421 } else {
2422 my $pl = $self->contr;
2423
2424 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2425 my $dialog = $pl->{npc_dialog};
2426 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2427
2428 } else {
457 $msg = $npc->name . " says: $msg" if $npc; 2429 $msg = $npc->name . " says: $msg" if $npc;
458 $self->message ($msg, $flags); 2430 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2431 }
2432 }
2433}
2434
2435=item $object->send_msg ($channel, $msg, $color, [extra...])
2436
2437=cut
2438
2439sub cf::object::send_msg {
2440 my $pl = shift->contr
2441 or return;
2442 $pl->send_msg (@_);
2443}
2444
2445=item $player_object->may ("access")
2446
2447Returns wether the given player is authorized to access resource "access"
2448(e.g. "command_wizcast").
2449
2450=cut
2451
2452sub cf::object::player::may {
2453 my ($self, $access) = @_;
2454
2455 $self->flag (cf::FLAG_WIZ) ||
2456 (ref $cf::CFG{"may_$access"}
2457 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
2458 : $cf::CFG{"may_$access"})
2459}
2460
2461=item $player_object->enter_link
2462
2463Freezes the player and moves him/her to a special map (C<{link}>).
2464
2465The player should be reasonably safe there for short amounts of time (e.g.
2466for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2467though, as the palyer cannot control the character while it is on the link
2468map.
2469
2470Will never block.
2471
2472=item $player_object->leave_link ($map, $x, $y)
2473
2474Moves the player out of the special C<{link}> map onto the specified
2475map. If the map is not valid (or omitted), the player will be moved back
2476to the location he/she was before the call to C<enter_link>, or, if that
2477fails, to the emergency map position.
2478
2479Might block.
2480
2481=cut
2482
2483sub link_map {
2484 unless ($LINK_MAP) {
2485 $LINK_MAP = cf::map::find "{link}"
2486 or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
2487 $LINK_MAP->load;
2488 }
2489
2490 $LINK_MAP
2491}
2492
2493sub cf::object::player::enter_link {
2494 my ($self) = @_;
2495
2496 $self->deactivate_recursive;
2497
2498 return if UNIVERSAL::isa $self->map, "ext::map_link";
2499
2500 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2501 if $self->map && $self->map->{path} ne "{link}";
2502
2503 $self->enter_map ($LINK_MAP || link_map, 10, 10);
2504}
2505
2506sub cf::object::player::leave_link {
2507 my ($self, $map, $x, $y) = @_;
2508
2509 return unless $self->contr->active;
2510
2511 my $link_pos = delete $self->{_link_pos};
2512
2513 unless ($map) {
2514 # restore original map position
2515 ($map, $x, $y) = @{ $link_pos || [] };
2516 $map = cf::map::find $map;
2517
2518 unless ($map) {
2519 ($map, $x, $y) = @$EMERGENCY_POSITION;
2520 $map = cf::map::find $map
2521 or die "FATAL: cannot load emergency map\n";
2522 }
2523 }
2524
2525 ($x, $y) = (-1, -1)
2526 unless (defined $x) && (defined $y);
2527
2528 # use -1 or undef as default coordinates, not 0, 0
2529 ($x, $y) = ($map->enter_x, $map->enter_y)
2530 if $x <=0 && $y <= 0;
2531
2532 $map->load;
2533 $map->load_neighbours;
2534
2535 return unless $self->contr->active;
2536
2537 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2538 $self->enter_map ($map, $x, $y);
2539
2540 # only activate afterwards, to support waiting in hooks
2541 $self->activate_recursive;
2542}
2543
2544=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2545
2546Moves the player to the given map-path and coordinates by first freezing
2547her, loading and preparing them map, calling the provided $check callback
2548that has to return the map if sucecssful, and then unfreezes the player on
2549the new (success) or old (failed) map position. In either case, $done will
2550be called at the end of this process.
2551
2552Note that $check will be called with a potentially non-loaded map, so if
2553it needs a loaded map it has to call C<< ->load >>.
2554
2555=cut
2556
2557our $GOTOGEN;
2558
2559sub cf::object::player::goto {
2560 my ($self, $path, $x, $y, $check, $done) = @_;
2561
2562 # do generation counting so two concurrent goto's will be executed in-order
2563 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2564
2565 $self->enter_link;
2566
2567 (async {
2568 $Coro::current->{desc} = "player::goto $path $x $y";
2569
2570 # *tag paths override both path and x|y
2571 if ($path =~ /^\*(.*)$/) {
2572 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2573 my $ob = $obs[rand @obs];
2574
2575 # see if we actually can go there
2576 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2577 $ob = $obs[rand @obs];
2578 } else {
2579 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2580 }
2581 # else put us there anyways for now #d#
2582
2583 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2584 } else {
2585 ($path, $x, $y) = (undef, undef, undef);
2586 }
2587 }
2588
2589 my $map = eval {
2590 my $map = defined $path ? cf::map::find $path : undef;
2591
2592 if ($map) {
2593 $map = $map->customise_for ($self);
2594 $map = $check->($map) if $check && $map;
2595 } else {
2596 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2597 }
2598
2599 $map
2600 };
2601
2602 if ($@) {
2603 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2604 LOG llevError | logBacktrace, Carp::longmess $@;
2605 }
2606
2607 if ($gen == $self->{_goto_generation}) {
2608 delete $self->{_goto_generation};
2609 $self->leave_link ($map, $x, $y);
2610 }
2611
2612 $done->() if $done;
2613 })->prio (1);
2614}
2615
2616=item $player_object->enter_exit ($exit_object)
2617
2618=cut
2619
2620sub parse_random_map_params {
2621 my ($spec) = @_;
2622
2623 my $rmp = { # defaults
2624 xsize => (cf::rndm 15, 40),
2625 ysize => (cf::rndm 15, 40),
2626 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
2627 #layout => string,
459 } 2628 };
460}
461 2629
2630 for (split /\n/, $spec) {
2631 my ($k, $v) = split /\s+/, $_, 2;
2632
2633 $rmp->{lc $k} = $v if (length $k) && (length $v);
2634 }
2635
2636 $rmp
2637}
2638
2639sub prepare_random_map {
2640 my ($exit) = @_;
2641
2642 # all this does is basically replace the /! path by
2643 # a new random map path (?random/...) with a seed
2644 # that depends on the exit object
2645
2646 my $rmp = parse_random_map_params $exit->msg;
2647
2648 if ($exit->map) {
2649 $rmp->{region} = $exit->region->name;
2650 $rmp->{origin_map} = $exit->map->path;
2651 $rmp->{origin_x} = $exit->x;
2652 $rmp->{origin_y} = $exit->y;
2653
2654 $exit->map->touch;
2655 }
2656
2657 $rmp->{random_seed} ||= $exit->random_seed;
2658
2659 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2660 my $md5 = Digest::MD5::md5_hex $data;
2661 my $meta = "$RANDOMDIR/$md5.meta";
2662
2663 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2664 aio_write $fh, 0, (length $data), $data, 0;
2665 undef $fh;
2666 aio_rename "$meta~", $meta;
2667
2668 my $slaying = "?random/$md5";
2669
2670 if ($exit->valid) {
2671 $exit->slaying ("?random/$md5");
2672 $exit->msg (undef);
2673 }
2674 }
2675}
2676
2677sub cf::object::player::enter_exit {
2678 my ($self, $exit) = @_;
2679
2680 return unless $self->type == cf::PLAYER;
2681
2682 $self->enter_link;
2683
2684 (async {
2685 $Coro::current->{desc} = "enter_exit";
2686
2687 unless (eval {
2688 $self->deactivate_recursive; # just to be sure
2689
2690 # random map handling
2691 {
2692 my $guard = cf::lock_acquire "exit_prepare:$exit";
2693
2694 prepare_random_map $exit
2695 if $exit->slaying eq "/!";
2696 }
2697
2698 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2699 my $x = $exit->stats->hp;
2700 my $y = $exit->stats->sp;
2701
2702 $self->goto ($map, $x, $y);
2703
2704 # if exit is damned, update players death & WoR home-position
2705 $self->contr->savebed ($map, $x, $y)
2706 if $exit->flag (cf::FLAG_DAMNED);
2707
2708 1
2709 }) {
2710 $self->message ("Something went wrong deep within the deliantra server. "
2711 . "I'll try to bring you back to the map you were before. "
2712 . "Please report this to the dungeon master!",
2713 cf::NDI_UNIQUE | cf::NDI_RED);
2714
2715 warn "ERROR in enter_exit: $@";
2716 $self->leave_link;
2717 }
2718 })->prio (1);
2719}
2720
2721=head3 cf::client
2722
2723=over 4
2724
2725=item $client->send_drawinfo ($text, $flags)
2726
2727Sends a drawinfo packet to the client. Circumvents output buffering so
2728should not be used under normal circumstances.
2729
2730=cut
2731
2732sub cf::client::send_drawinfo {
2733 my ($self, $text, $flags) = @_;
2734
2735 utf8::encode $text;
2736 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2737}
2738
2739=item $client->send_msg ($channel, $msg, $color, [extra...])
2740
2741Send a drawinfo or msg packet to the client, formatting the msg for the
2742client if neccessary. C<$type> should be a string identifying the type of
2743the message, with C<log> being the default. If C<$color> is negative, suppress
2744the message unless the client supports the msg packet.
2745
2746=cut
2747
2748# non-persistent channels (usually the info channel)
2749our %CHANNEL = (
2750 "c/identify" => {
2751 id => "infobox",
2752 title => "Identify",
2753 reply => undef,
2754 tooltip => "Items recently identified",
2755 },
2756 "c/examine" => {
2757 id => "infobox",
2758 title => "Examine",
2759 reply => undef,
2760 tooltip => "Signs and other items you examined",
2761 },
2762 "c/book" => {
2763 id => "infobox",
2764 title => "Book",
2765 reply => undef,
2766 tooltip => "The contents of a note or book",
2767 },
2768 "c/lookat" => {
2769 id => "infobox",
2770 title => "Look",
2771 reply => undef,
2772 tooltip => "What you saw there",
2773 },
2774 "c/who" => {
2775 id => "infobox",
2776 title => "Players",
2777 reply => undef,
2778 tooltip => "Shows players who are currently online",
2779 },
2780 "c/body" => {
2781 id => "infobox",
2782 title => "Body Parts",
2783 reply => undef,
2784 tooltip => "Shows which body parts you posess and are available",
2785 },
2786 "c/statistics" => {
2787 id => "infobox",
2788 title => "Statistics",
2789 reply => undef,
2790 tooltip => "Shows your primary statistics",
2791 },
2792 "c/skills" => {
2793 id => "infobox",
2794 title => "Skills",
2795 reply => undef,
2796 tooltip => "Shows your experience per skill and item power",
2797 },
2798 "c/shopitems" => {
2799 id => "infobox",
2800 title => "Shop Items",
2801 reply => undef,
2802 tooltip => "Shows the items currently for sale in this shop",
2803 },
2804 "c/resistances" => {
2805 id => "infobox",
2806 title => "Resistances",
2807 reply => undef,
2808 tooltip => "Shows your resistances",
2809 },
2810 "c/pets" => {
2811 id => "infobox",
2812 title => "Pets",
2813 reply => undef,
2814 tooltip => "Shows information abotu your pets/a specific pet",
2815 },
2816 "c/perceiveself" => {
2817 id => "infobox",
2818 title => "Perceive Self",
2819 reply => undef,
2820 tooltip => "You gained detailed knowledge about yourself",
2821 },
2822 "c/uptime" => {
2823 id => "infobox",
2824 title => "Uptime",
2825 reply => undef,
2826 tooltip => "How long the server has been running since last restart",
2827 },
2828 "c/mapinfo" => {
2829 id => "infobox",
2830 title => "Map Info",
2831 reply => undef,
2832 tooltip => "Information related to the maps",
2833 },
2834 "c/party" => {
2835 id => "party",
2836 title => "Party",
2837 reply => "gsay ",
2838 tooltip => "Messages and chat related to your party",
2839 },
2840 "c/death" => {
2841 id => "death",
2842 title => "Death",
2843 reply => undef,
2844 tooltip => "Reason for and more info about your most recent death",
2845 },
2846 "c/say" => $SAY_CHANNEL,
2847 "c/chat" => $CHAT_CHANNEL,
2848);
2849
2850sub cf::client::send_msg {
2851 my ($self, $channel, $msg, $color, @extra) = @_;
2852
2853 $msg = $self->pl->expand_cfpod ($msg)
2854 unless $color & cf::NDI_VERBATIM;
2855
2856 $color &= cf::NDI_CLIENT_MASK; # just in case...
2857
2858 # check predefined channels, for the benefit of C
2859 if ($CHANNEL{$channel}) {
2860 $channel = $CHANNEL{$channel};
2861
2862 $self->ext_msg (channel_info => $channel);
2863 $channel = $channel->{id};
2864
2865 } elsif (ref $channel) {
2866 # send meta info to client, if not yet sent
2867 unless (exists $self->{channel}{$channel->{id}}) {
2868 $self->{channel}{$channel->{id}} = $channel;
2869 $self->ext_msg (channel_info => $channel);
2870 }
2871
2872 $channel = $channel->{id};
2873 }
2874
2875 return unless @extra || length $msg;
2876
2877 # default colour, mask it out
2878 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2879 if $color & cf::NDI_DEF;
2880
2881 my $pkt = "msg "
2882 . $self->{json_coder}->encode (
2883 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2884 );
2885
2886 # try lzf for large packets
2887 $pkt = "lzf " . Compress::LZF::compress $pkt
2888 if 1024 <= length $pkt and $self->{can_lzf};
2889
2890 # split very large packets
2891 if (8192 < length $pkt and $self->{can_lzf}) {
2892 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2893 $pkt = "frag";
2894 }
2895
2896 $self->send_packet ($pkt);
2897}
2898
2899=item $client->ext_msg ($type, @msg)
2900
2901Sends an ext event to the client.
2902
2903=cut
2904
2905sub cf::client::ext_msg($$@) {
2906 my ($self, $type, @msg) = @_;
2907
2908 if ($self->extcmd == 2) {
2909 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2910 } elsif ($self->extcmd == 1) { # TODO: remove
2911 push @msg, msgtype => "event_$type";
2912 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2913 }
2914}
2915
462=item $player->ext_reply ($msgid, $msgtype, %msg) 2916=item $client->ext_reply ($msgid, @msg)
463 2917
464Sends an ext reply to the player. 2918Sends an ext reply to the client.
465 2919
466=cut 2920=cut
467 2921
468sub cf::player::ext_reply($$$%) { 2922sub cf::client::ext_reply($$@) {
469 my ($self, $id, %msg) = @_; 2923 my ($self, $id, @msg) = @_;
470 2924
471 $msg{msgid} = $id; 2925 if ($self->extcmd == 2) {
472 2926 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
473 $self->send ("ext " . to_json \%msg); 2927 } elsif ($self->extcmd == 1) {
2928 #TODO: version 1, remove
2929 unshift @msg, msgtype => "reply", msgid => $id;
2930 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2931 }
474} 2932}
475 2933
476############################################################################# 2934=item $success = $client->query ($flags, "text", \&cb)
477# map scripting support
478 2935
2936Queues a query to the client, calling the given callback with
2937the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
2938C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2939
2940Queries can fail, so check the return code. Or don't, as queries will
2941become reliable at some point in the future.
2942
2943=cut
2944
2945sub cf::client::query {
2946 my ($self, $flags, $text, $cb) = @_;
2947
2948 return unless $self->state == ST_PLAYING
2949 || $self->state == ST_SETUP
2950 || $self->state == ST_CUSTOM;
2951
2952 $self->state (ST_CUSTOM);
2953
2954 utf8::encode $text;
2955 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2956
2957 $self->send_packet ($self->{query_queue}[0][0])
2958 if @{ $self->{query_queue} } == 1;
2959
2960 1
2961}
2962
2963cf::client->attach (
2964 on_connect => sub {
2965 my ($ns) = @_;
2966
2967 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2968 },
2969 on_reply => sub {
2970 my ($ns, $msg) = @_;
2971
2972 # this weird shuffling is so that direct followup queries
2973 # get handled first
2974 my $queue = delete $ns->{query_queue}
2975 or return; # be conservative, not sure how that can happen, but we saw a crash here
2976
2977 (shift @$queue)->[1]->($msg);
2978 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
2979
2980 push @{ $ns->{query_queue} }, @$queue;
2981
2982 if (@{ $ns->{query_queue} } == @$queue) {
2983 if (@$queue) {
2984 $ns->send_packet ($ns->{query_queue}[0][0]);
2985 } else {
2986 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2987 }
2988 }
2989 },
2990 on_exticmd => sub {
2991 my ($ns, $buf) = @_;
2992
2993 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2994
2995 if (ref $msg) {
2996 my ($type, $reply, @payload) =
2997 "ARRAY" eq ref $msg
2998 ? @$msg
2999 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
3000
3001 my @reply;
3002
3003 if (my $cb = $EXTICMD{$type}) {
3004 @reply = $cb->($ns, @payload);
3005 }
3006
3007 $ns->ext_reply ($reply, @reply)
3008 if $reply;
3009
3010 } else {
3011 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3012 }
3013
3014 cf::override;
3015 },
3016);
3017
3018=item $client->async (\&cb)
3019
3020Create a new coroutine, running the specified callback. The coroutine will
3021be automatically cancelled when the client gets destroyed (e.g. on logout,
3022or loss of connection).
3023
3024=cut
3025
3026sub cf::client::async {
3027 my ($self, $cb) = @_;
3028
3029 my $coro = &Coro::async ($cb);
3030
3031 $coro->on_destroy (sub {
3032 delete $self->{_coro}{$coro+0};
3033 });
3034
3035 $self->{_coro}{$coro+0} = $coro;
3036
3037 $coro
3038}
3039
3040cf::client->attach (
3041 on_destroy => sub {
3042 my ($ns) = @_;
3043
3044 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
3045 },
3046);
3047
3048=back
3049
3050
3051=head2 SAFE SCRIPTING
3052
3053Functions that provide a safe environment to compile and execute
3054snippets of perl code without them endangering the safety of the server
3055itself. Looping constructs, I/O operators and other built-in functionality
3056is not available in the safe scripting environment, and the number of
3057functions and methods that can be called is greatly reduced.
3058
3059=cut
3060
479our $safe = new Safe "ext"; 3061our $safe = new Safe "safe";
480our $safe_hole = new Safe::Hole; 3062our $safe_hole = new Safe::Hole;
481 3063
482$SIG{FPE} = 'IGNORE'; 3064$SIG{FPE} = 'IGNORE';
483 3065
484$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 3066$safe->permit_only (Opcode::opset qw(
3067 :base_core :base_mem :base_orig :base_math
3068 grepstart grepwhile mapstart mapwhile
3069 sort time
3070));
485 3071
486# here we export the classes and methods available to script code 3072# here we export the classes and methods available to script code
487 3073
3074=pod
3075
3076The following functions and methods are available within a safe environment:
3077
3078 cf::object
3079 contr pay_amount pay_player map x y force_find force_add destroy
3080 insert remove name archname title slaying race decrease split
3081 value
3082
3083 cf::object::player
3084 player
3085
3086 cf::player
3087 peaceful
3088
3089 cf::map
3090 trigger
3091
3092=cut
3093
488for ( 3094for (
489 ["cf::object" => qw(contr pay_amount pay_player)], 3095 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3096 insert remove inv nrof name archname title slaying race
3097 decrease split destroy change_exp value msg lore send_msg)],
490 ["cf::object::player" => qw(player)], 3098 ["cf::object::player" => qw(player)],
491 ["cf::player" => qw(peaceful)], 3099 ["cf::player" => qw(peaceful send_msg)],
3100 ["cf::map" => qw(trigger)],
492) { 3101) {
493 no strict 'refs'; 3102 no strict 'refs';
494 my ($pkg, @funs) = @$_; 3103 my ($pkg, @funs) = @$_;
495 *{"ext::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3104 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
496 for @funs; 3105 for @funs;
497} 3106}
3107
3108=over 4
3109
3110=item @retval = safe_eval $code, [var => value, ...]
3111
3112Compiled and executes the given perl code snippet. additional var/value
3113pairs result in temporary local (my) scalar variables of the given name
3114that are available in the code snippet. Example:
3115
3116 my $five = safe_eval '$first + $second', first => 1, second => 4;
3117
3118=cut
498 3119
499sub safe_eval($;@) { 3120sub safe_eval($;@) {
500 my ($code, %vars) = @_; 3121 my ($code, %vars) = @_;
501 3122
502 my $qcode = $code; 3123 my $qcode = $code;
503 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3124 $qcode =~ s/"/‟/g; # not allowed in #line filenames
504 $qcode =~ s/\n/\\n/g; 3125 $qcode =~ s/\n/\\n/g;
505 3126
3127 %vars = (_dummy => 0) unless %vars;
3128
506 local $_; 3129 local $_;
507 local @ext::cf::_safe_eval_args = values %vars; 3130 local @safe::cf::_safe_eval_args = values %vars;
508 3131
509 $code = 3132 my $eval =
510 "do {\n" 3133 "do {\n"
511 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3134 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
512 . "#line 0 \"{$qcode}\"\n" 3135 . "#line 0 \"{$qcode}\"\n"
513 . $code 3136 . $code
514 . "\n}" 3137 . "\n}"
515 ; 3138 ;
516 3139
517 sub_generation_inc; 3140 sub_generation_inc;
518 my @res = wantarray ? $safe->reval ($code) : scalar $safe->reval ($code); 3141 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
519 sub_generation_inc; 3142 sub_generation_inc;
520 3143
3144 if ($@) {
3145 warn "$@";
3146 warn "while executing safe code '$code'\n";
3147 warn "with arguments " . (join " ", %vars) . "\n";
3148 }
3149
521 wantarray ? @res : $res[0] 3150 wantarray ? @res : $res[0]
522} 3151}
3152
3153=item cf::register_script_function $function => $cb
3154
3155Register a function that can be called from within map/npc scripts. The
3156function should be reasonably secure and should be put into a package name
3157like the extension.
3158
3159Example: register a function that gets called whenever a map script calls
3160C<rent::overview>, as used by the C<rent> extension.
3161
3162 cf::register_script_function "rent::overview" => sub {
3163 ...
3164 };
3165
3166=cut
523 3167
524sub register_script_function { 3168sub register_script_function {
525 my ($fun, $cb) = @_; 3169 my ($fun, $cb) = @_;
526 3170
527 no strict 'refs'; 3171 no strict 'refs';
528 *{"ext::$fun"} = $safe_hole->wrap ($cb); 3172 *{"safe::$fun"} = $safe_hole->wrap ($cb);
529} 3173}
3174
3175=back
3176
3177=cut
530 3178
531############################################################################# 3179#############################################################################
532# initialisation 3180# the server's init and main functions
533 3181
534register "<global>", __PACKAGE__; 3182sub load_facedata($) {
3183 my ($path) = @_;
3184
3185 # HACK to clear player env face cache, we need some signal framework
3186 # for this (global event?)
3187 %ext::player_env::MUSIC_FACE_CACHE = ();
3188
3189 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3190
3191 warn "loading facedata from $path\n";
3192
3193 my $facedata;
3194 0 < aio_load $path, $facedata
3195 or die "$path: $!";
3196
3197 $facedata = Coro::Storable::thaw $facedata;
3198
3199 $facedata->{version} == 2
3200 or cf::cleanup "$path: version mismatch, cannot proceed.";
3201
3202 # patch in the exptable
3203 $facedata->{resource}{"res/exp_table"} = {
3204 type => FT_RSRC,
3205 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
3206 };
3207 cf::cede_to_tick;
3208
3209 {
3210 my $faces = $facedata->{faceinfo};
3211
3212 while (my ($face, $info) = each %$faces) {
3213 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3214
3215 cf::face::set_visibility $idx, $info->{visibility};
3216 cf::face::set_magicmap $idx, $info->{magicmap};
3217 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
3218 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
3219
3220 cf::cede_to_tick;
3221 }
3222
3223 while (my ($face, $info) = each %$faces) {
3224 next unless $info->{smooth};
3225
3226 my $idx = cf::face::find $face
3227 or next;
3228
3229 if (my $smooth = cf::face::find $info->{smooth}) {
3230 cf::face::set_smooth $idx, $smooth;
3231 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3232 } else {
3233 warn "smooth face '$info->{smooth}' not found for face '$face'";
3234 }
3235
3236 cf::cede_to_tick;
3237 }
3238 }
3239
3240 {
3241 my $anims = $facedata->{animinfo};
3242
3243 while (my ($anim, $info) = each %$anims) {
3244 cf::anim::set $anim, $info->{frames}, $info->{facings};
3245 cf::cede_to_tick;
3246 }
3247
3248 cf::anim::invalidate_all; # d'oh
3249 }
3250
3251 {
3252 # TODO: for gcfclient pleasure, we should give resources
3253 # that gcfclient doesn't grok a >10000 face index.
3254 my $res = $facedata->{resource};
3255
3256 while (my ($name, $info) = each %$res) {
3257 if (defined $info->{type}) {
3258 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3259 my $data;
3260
3261 if ($info->{type} & 1) {
3262 # prepend meta info
3263
3264 my $meta = $enc->encode ({
3265 name => $name,
3266 %{ $info->{meta} || {} },
3267 });
3268
3269 $data = pack "(w/a*)*", $meta, $info->{data};
3270 } else {
3271 $data = $info->{data};
3272 }
3273
3274 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3275 cf::face::set_type $idx, $info->{type};
3276 } else {
3277 $RESOURCE{$name} = $info;
3278 }
3279
3280 cf::cede_to_tick;
3281 }
3282 }
3283
3284 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3285
3286 1
3287}
3288
3289cf::global->attach (on_resource_update => sub {
3290 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3291 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3292
3293 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3294 my $sound = $soundconf->{compat}[$_]
3295 or next;
3296
3297 my $face = cf::face::find "sound/$sound->[1]";
3298 cf::sound::set $sound->[0] => $face;
3299 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3300 }
3301
3302 while (my ($k, $v) = each %{$soundconf->{event}}) {
3303 my $face = cf::face::find "sound/$v";
3304 cf::sound::set $k => $face;
3305 }
3306 }
3307});
3308
3309register_exticmd fx_want => sub {
3310 my ($ns, $want) = @_;
3311
3312 while (my ($k, $v) = each %$want) {
3313 $ns->fx_want ($k, $v);
3314 }
3315};
3316
3317sub load_resource_file($) {
3318 my $guard = lock_acquire "load_resource_file";
3319
3320 my $status = load_resource_file_ $_[0];
3321 get_slot 0.1, 100;
3322 cf::arch::commit_load;
3323
3324 $status
3325}
3326
3327sub reload_regions {
3328 # HACK to clear player env face cache, we need some signal framework
3329 # for this (global event?)
3330 %ext::player_env::MUSIC_FACE_CACHE = ();
3331
3332 load_resource_file "$MAPDIR/regions"
3333 or die "unable to load regions file\n";
3334
3335 for (cf::region::list) {
3336 $_->{match} = qr/$_->{match}/
3337 if exists $_->{match};
3338 }
3339}
3340
3341sub reload_facedata {
3342 load_facedata "$DATADIR/facedata"
3343 or die "unable to load facedata\n";
3344}
3345
3346sub reload_archetypes {
3347 load_resource_file "$DATADIR/archetypes"
3348 or die "unable to load archetypes\n";
3349}
3350
3351sub reload_treasures {
3352 load_resource_file "$DATADIR/treasures"
3353 or die "unable to load treasurelists\n";
3354}
3355
3356sub reload_resources {
3357 warn "reloading resource files...\n";
3358
3359 reload_facedata;
3360 reload_archetypes;
3361 reload_regions;
3362 reload_treasures;
3363
3364 warn "finished reloading resource files\n";
3365}
3366
3367sub reload_config {
3368 open my $fh, "<:utf8", "$CONFDIR/config"
3369 or return;
3370
3371 local $/;
3372 *CFG = YAML::Load <$fh>;
3373
3374 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
3375
3376 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3377 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3378
3379 if (exists $CFG{mlockall}) {
3380 eval {
3381 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3382 and die "WARNING: m(un)lockall failed: $!\n";
3383 };
3384 warn $@ if $@;
3385 }
3386}
3387
3388sub pidfile() {
3389 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3390 or die "$PIDFILE: $!";
3391 flock $fh, &Fcntl::LOCK_EX
3392 or die "$PIDFILE: flock: $!";
3393 $fh
3394}
3395
3396# make sure only one server instance is running at any one time
3397sub atomic {
3398 my $fh = pidfile;
3399
3400 my $pid = <$fh>;
3401 kill 9, $pid if $pid > 0;
3402
3403 seek $fh, 0, 0;
3404 print $fh $$;
3405}
3406
3407sub main_loop {
3408 warn "EV::loop starting\n";
3409 if (1) {
3410 EV::loop;
3411 }
3412 warn "EV::loop returned\n";
3413 goto &main_loop unless $REALLY_UNLOOP;
3414}
3415
3416sub main {
3417 cf::init_globals; # initialise logging
3418
3419 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3420 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3421 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3422 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3423
3424 cf::init_experience;
3425 cf::init_anim;
3426 cf::init_attackmess;
3427 cf::init_dynamic;
3428
3429 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3430
3431 # we must not ever block the main coroutine
3432 local $Coro::idle = sub {
3433 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3434 (async {
3435 $Coro::current->{desc} = "IDLE BUG HANDLER";
3436 EV::loop EV::LOOP_ONESHOT;
3437 })->prio (Coro::PRIO_MAX);
3438 };
3439
3440 evthread_start IO::AIO::poll_fileno;
3441
3442 cf::sync_job {
3443 reload_resources;
3444 reload_config;
3445 db_init;
3446
3447 cf::load_settings;
3448 cf::load_materials;
3449 cf::init_uuid;
3450 cf::init_signals;
3451 cf::init_commands;
3452 cf::init_skills;
3453
3454 cf::init_beforeplay;
3455
3456 atomic;
3457
3458 load_extensions;
3459
3460 utime time, time, $RUNTIMEFILE;
3461
3462 # no (long-running) fork's whatsoever before this point(!)
3463 use POSIX ();
3464 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3465
3466 (pop @POST_INIT)->(0) while @POST_INIT;
3467 };
3468
3469 main_loop;
3470}
3471
3472#############################################################################
3473# initialisation and cleanup
3474
3475# install some emergency cleanup handlers
3476BEGIN {
3477 our %SIGWATCHER = ();
3478 for my $signal (qw(INT HUP TERM)) {
3479 $SIGWATCHER{$signal} = EV::signal $signal, sub {
3480 cf::cleanup "SIG$signal";
3481 };
3482 }
3483}
3484
3485sub write_runtime_sync {
3486 # first touch the runtime file to show we are still running:
3487 # the fsync below can take a very very long time.
3488
3489 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3490
3491 my $guard = cf::lock_acquire "write_runtime";
3492
3493 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644
3494 or return;
3495
3496 my $value = $cf::RUNTIME + 90 + 10;
3497 # 10 is the runtime save interval, for a monotonic clock
3498 # 60 allows for the watchdog to kill the server.
3499
3500 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3501 and return;
3502
3503 # always fsync - this file is important
3504 aio_fsync $fh
3505 and return;
3506
3507 # touch it again to show we are up-to-date
3508 aio_utime $fh, undef, undef;
3509
3510 close $fh
3511 or return;
3512
3513 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3514 and return;
3515
3516 warn "runtime file written.\n";
3517
3518 1
3519}
3520
3521our $uuid_lock;
3522our $uuid_skip;
3523
3524sub write_uuid_sync($) {
3525 $uuid_skip ||= $_[0];
3526
3527 return if $uuid_lock;
3528 local $uuid_lock = 1;
3529
3530 my $uuid = "$LOCALDIR/uuid";
3531
3532 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3533 or return;
3534
3535 my $value = uuid_seq uuid_cur;
3536
3537 unless ($value) {
3538 warn "cowardly refusing to write zero uuid value!\n";
3539 return;
3540 }
3541
3542 my $value = uuid_str $value + $uuid_skip;
3543 $uuid_skip = 0;
3544
3545 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3546 and return;
3547
3548 # always fsync - this file is important
3549 aio_fsync $fh
3550 and return;
3551
3552 close $fh
3553 or return;
3554
3555 aio_rename "$uuid~", $uuid
3556 and return;
3557
3558 warn "uuid file written ($value).\n";
3559
3560 1
3561
3562}
3563
3564sub write_uuid($$) {
3565 my ($skip, $sync) = @_;
3566
3567 $sync ? write_uuid_sync $skip
3568 : async { write_uuid_sync $skip };
3569}
3570
3571sub emergency_save() {
3572 my $freeze_guard = cf::freeze_mainloop;
3573
3574 warn "emergency_perl_save: enter\n";
3575
3576 cf::sync_job {
3577 # this is a trade-off: we want to be very quick here, so
3578 # save all maps without fsync, and later call a global sync
3579 # (which in turn might be very very slow)
3580 local $USE_FSYNC = 0;
3581
3582 # use a peculiar iteration method to avoid tripping on perl
3583 # refcount bugs in for. also avoids problems with players
3584 # and maps saved/destroyed asynchronously.
3585 warn "emergency_perl_save: begin player save\n";
3586 for my $login (keys %cf::PLAYER) {
3587 my $pl = $cf::PLAYER{$login} or next;
3588 $pl->valid or next;
3589 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3590 $pl->save;
3591 }
3592 warn "emergency_perl_save: end player save\n";
3593
3594 warn "emergency_perl_save: begin map save\n";
3595 for my $path (keys %cf::MAP) {
3596 my $map = $cf::MAP{$path} or next;
3597 $map->valid or next;
3598 $map->save;
3599 }
3600 warn "emergency_perl_save: end map save\n";
3601
3602 warn "emergency_perl_save: begin database checkpoint\n";
3603 BDB::db_env_txn_checkpoint $DB_ENV;
3604 warn "emergency_perl_save: end database checkpoint\n";
3605
3606 warn "emergency_perl_save: begin write uuid\n";
3607 write_uuid_sync 1;
3608 warn "emergency_perl_save: end write uuid\n";
3609 };
3610
3611 warn "emergency_perl_save: starting sync()\n";
3612 IO::AIO::aio_sync sub {
3613 warn "emergency_perl_save: finished sync()\n";
3614 };
3615
3616 warn "emergency_perl_save: leave\n";
3617}
3618
3619sub post_cleanup {
3620 my ($make_core) = @_;
3621
3622 warn Carp::longmess "post_cleanup backtrace"
3623 if $make_core;
3624
3625 my $fh = pidfile;
3626 unlink $PIDFILE if <$fh> == $$;
3627}
3628
3629# a safer delete_package, copied from Symbol
3630sub clear_package($) {
3631 my $pkg = shift;
3632
3633 # expand to full symbol table name if needed
3634 unless ($pkg =~ /^main::.*::$/) {
3635 $pkg = "main$pkg" if $pkg =~ /^::/;
3636 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3637 $pkg .= '::' unless $pkg =~ /::$/;
3638 }
3639
3640 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3641 my $stem_symtab = *{$stem}{HASH};
3642
3643 defined $stem_symtab and exists $stem_symtab->{$leaf}
3644 or return;
3645
3646 # clear all symbols
3647 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3648 for my $name (keys %$leaf_symtab) {
3649 _gv_clear *{"$pkg$name"};
3650# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3651 }
3652 warn "cleared package $pkg\n";#d#
3653}
3654
3655sub do_reload_perl() {
3656 # can/must only be called in main
3657 if ($Coro::current != $Coro::main) {
3658 warn "can only reload from main coroutine";
3659 return;
3660 }
3661
3662 return if $RELOAD++;
3663
3664 my $t1 = EV::time;
3665
3666 while ($RELOAD) {
3667 warn "reloading...";
3668
3669 warn "entering sync_job";
3670
3671 cf::sync_job {
3672 cf::write_runtime_sync; # external watchdog should not bark
3673 cf::emergency_save;
3674 cf::write_runtime_sync; # external watchdog should not bark
3675
3676 warn "syncing database to disk";
3677 BDB::db_env_txn_checkpoint $DB_ENV;
3678
3679 # if anything goes wrong in here, we should simply crash as we already saved
3680
3681 warn "flushing outstanding aio requests";
3682 while (IO::AIO::nreqs || BDB::nreqs) {
3683 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3684 }
3685
3686 warn "cancelling all extension coros";
3687 $_->cancel for values %EXT_CORO;
3688 %EXT_CORO = ();
3689
3690 warn "removing commands";
3691 %COMMAND = ();
3692
3693 warn "removing ext/exti commands";
3694 %EXTCMD = ();
3695 %EXTICMD = ();
3696
3697 warn "unloading/nuking all extensions";
3698 for my $pkg (@EXTS) {
3699 warn "... unloading $pkg";
3700
3701 if (my $cb = $pkg->can ("unload")) {
3702 eval {
3703 $cb->($pkg);
3704 1
3705 } or warn "$pkg unloaded, but with errors: $@";
3706 }
3707
3708 warn "... clearing $pkg";
3709 clear_package $pkg;
3710 }
3711
3712 warn "unloading all perl modules loaded from $LIBDIR";
3713 while (my ($k, $v) = each %INC) {
3714 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3715
3716 warn "... unloading $k";
3717 delete $INC{$k};
3718
3719 $k =~ s/\.pm$//;
3720 $k =~ s/\//::/g;
3721
3722 if (my $cb = $k->can ("unload_module")) {
3723 $cb->();
3724 }
3725
3726 clear_package $k;
3727 }
3728
3729 warn "getting rid of safe::, as good as possible";
3730 clear_package "safe::$_"
3731 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3732
3733 warn "unloading cf.pm \"a bit\"";
3734 delete $INC{"cf.pm"};
3735 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3736
3737 # don't, removes xs symbols, too,
3738 # and global variables created in xs
3739 #clear_package __PACKAGE__;
3740
3741 warn "unload completed, starting to reload now";
3742
3743 warn "reloading cf.pm";
3744 require cf;
3745 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3746
3747 warn "loading config and database again";
3748 cf::reload_config;
3749
3750 warn "loading extensions";
3751 cf::load_extensions;
3752
3753 if ($REATTACH_ON_RELOAD) {
3754 warn "reattaching attachments to objects/players";
3755 _global_reattach; # objects, sockets
3756 warn "reattaching attachments to maps";
3757 reattach $_ for values %MAP;
3758 warn "reattaching attachments to players";
3759 reattach $_ for values %PLAYER;
3760 }
3761
3762 warn "running post_init jobs";
3763 (pop @POST_INIT)->(1) while @POST_INIT;
3764
3765 warn "leaving sync_job";
3766
3767 1
3768 } or do {
3769 warn $@;
3770 cf::cleanup "error while reloading, exiting.";
3771 };
3772
3773 warn "reloaded";
3774 --$RELOAD;
3775 }
3776
3777 $t1 = EV::time - $t1;
3778 warn "reload completed in ${t1}s\n";
3779};
3780
3781our $RELOAD_WATCHER; # used only during reload
3782
3783sub reload_perl() {
3784 # doing reload synchronously and two reloads happen back-to-back,
3785 # coro crashes during coro_state_free->destroy here.
3786
3787 $RELOAD_WATCHER ||= cf::async {
3788 Coro::AIO::aio_wait cache_extensions;
3789
3790 $RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub {
3791 do_reload_perl;
3792 undef $RELOAD_WATCHER;
3793 };
3794 };
3795}
3796
3797register_command "reload" => sub {
3798 my ($who, $arg) = @_;
3799
3800 if ($who->flag (FLAG_WIZ)) {
3801 $who->message ("reloading server.");
3802 async {
3803 $Coro::current->{desc} = "perl_reload";
3804 reload_perl;
3805 };
3806 }
3807};
535 3808
536unshift @INC, $LIBDIR; 3809unshift @INC, $LIBDIR;
537 3810
538load_extensions; 3811my $bug_warning = 0;
3812
3813our @WAIT_FOR_TICK;
3814our @WAIT_FOR_TICK_BEGIN;
3815
3816sub wait_for_tick {
3817 return if tick_inhibit || $Coro::current == $Coro::main;
3818
3819 my $signal = new Coro::Signal;
3820 push @WAIT_FOR_TICK, $signal;
3821 $signal->wait;
3822}
3823
3824sub wait_for_tick_begin {
3825 return if tick_inhibit || $Coro::current == $Coro::main;
3826
3827 my $signal = new Coro::Signal;
3828 push @WAIT_FOR_TICK_BEGIN, $signal;
3829 $signal->wait;
3830}
3831
3832sub tick {
3833 if ($Coro::current != $Coro::main) {
3834 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3835 unless ++$bug_warning > 10;
3836 return;
3837 }
3838
3839 cf::server_tick; # one server iteration
3840
3841 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3842 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3843 Coro::async_pool {
3844 $Coro::current->{desc} = "runtime saver";
3845 write_runtime_sync
3846 or warn "ERROR: unable to write runtime file: $!";
3847 };
3848 }
3849
3850 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3851 $sig->send;
3852 }
3853 while (my $sig = shift @WAIT_FOR_TICK) {
3854 $sig->send;
3855 }
3856
3857 $LOAD = ($NOW - $TICK_START) / $TICK;
3858 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3859
3860 if (0) {
3861 if ($NEXT_TICK) {
3862 my $jitter = $TICK_START - $NEXT_TICK;
3863 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3864 warn "jitter $JITTER\n";#d#
3865 }
3866 }
3867}
3868
3869{
3870 # configure BDB
3871
3872 BDB::min_parallel 8;
3873 BDB::max_poll_reqs $TICK * 0.1;
3874 $AnyEvent::BDB::WATCHER->priority (1);
3875
3876 unless ($DB_ENV) {
3877 $DB_ENV = BDB::db_env_create;
3878 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3879 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
3880 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
3881 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3882 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3883
3884 cf::sync_job {
3885 eval {
3886 BDB::db_env_open
3887 $DB_ENV,
3888 $BDBDIR,
3889 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3890 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3891 0666;
3892
3893 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3894 };
3895
3896 cf::cleanup "db_env_open(db): $@" if $@;
3897 };
3898 }
3899
3900 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3901 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3902 };
3903 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3904 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3905 };
3906 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3907 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3908 };
3909}
3910
3911{
3912 # configure IO::AIO
3913
3914 IO::AIO::min_parallel 8;
3915 IO::AIO::max_poll_time $TICK * 0.1;
3916 undef $AnyEvent::AIO::WATCHER;
3917}
3918
3919my $_log_backtrace;
3920
3921sub _log_backtrace {
3922 my ($msg, @addr) = @_;
3923
3924 $msg =~ s/\n//;
3925
3926 # limit the # of concurrent backtraces
3927 if ($_log_backtrace < 2) {
3928 ++$_log_backtrace;
3929 my $perl_bt = Carp::longmess $msg;
3930 async {
3931 $Coro::current->{desc} = "abt $msg";
3932
3933 my @bt = fork_call {
3934 @addr = map { sprintf "%x", $_ } @addr;
3935 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3936 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3937 or die "addr2line: $!";
3938
3939 my @funcs;
3940 my @res = <$fh>;
3941 chomp for @res;
3942 while (@res) {
3943 my ($func, $line) = splice @res, 0, 2, ();
3944 push @funcs, "[$func] $line";
3945 }
3946
3947 @funcs
3948 };
3949
3950 LOG llevInfo, "[ABT] $perl_bt\n";
3951 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
3952 LOG llevInfo, "[ABT] $_\n" for @bt;
3953 --$_log_backtrace;
3954 };
3955 } else {
3956 LOG llevInfo, "[ABT] $msg\n";
3957 LOG llevInfo, "[ABT] [suppressed]\n";
3958 }
3959}
3960
3961# load additional modules
3962require "cf/$_.pm" for @EXTRA_MODULES;
3963
3964END { cf::emergency_save }
539 3965
5401 39661
541 3967

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines