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.18 by root, Tue Jul 11 14:24:15 2006 UTC vs.
Revision 1.570 by root, Wed May 4 07:41:14 2011 UTC

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

Diff Legend

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