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.19 by root, Sun Jul 16 17:15:39 2006 UTC vs.
Revision 1.532 by root, Thu Apr 29 07:32:34 2010 UTC

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

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines