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

Diff Legend

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