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.35 by root, Thu Aug 24 13:35:48 2006 UTC vs.
Revision 1.565 by root, Sat Apr 30 05:41:17 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;
5use Storable; 29use Socket;
30use EV;
6use Opcode; 31use Opcode;
7use Safe; 32use Safe;
8use Safe::Hole; 33use Safe::Hole;
34use Storable ();
35use Carp ();
9 36
37use Guard ();
38use Coro ();
39use Coro::State;
40use Coro::Handle;
41use Coro::EV;
42use Coro::AnyEvent;
43use Coro::Timer;
44use Coro::Signal;
45use Coro::Semaphore;
46use Coro::SemaphoreSet;
47use Coro::AnyEvent;
48use Coro::AIO;
49use Coro::BDB 1.6;
50use Coro::Storable;
51use Coro::Util ();
52
53use JSON::XS 2.01 ();
54use BDB ();
55use Data::Dumper;
56use Fcntl;
57use YAML::XS ();
58use IO::AIO ();
10use Time::HiRes; 59use Time::HiRes;
11use Event; 60use Compress::LZF;
12$Event::Eval = 1; # no idea why this is required, but it is 61use Digest::MD5 ();
13 62
14use strict; 63AnyEvent::detect;
15 64
16our %COMMAND; 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
17our @EVENT; 93our @EVENT;
18our %PROP_TYPE; 94our @REFLECT; # set by XS
19our %PROP_IDX; 95our %REFLECT; # set by us
20our $LIBDIR = maps_directory "perl";
21 96
22our $TICK = MAX_TIME * 1e-6; 97our $CONFDIR = confdir;
23our $TICK_WATCHER; 98
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
24our $NEXT_TICK; 123our $NEXT_TICK;
124our $USE_FSYNC = 1; # use fsync to write maps - default on
25 125
26BEGIN { 126our $BDB_DEADLOCK_WATCHER;
27 @EVENT = map lc, @EVENT; 127our $BDB_CHECKPOINT_WATCHER;
128our $BDB_TRICKLE_WATCHER;
129our $DB_ENV;
28 130
29 *CORE::GLOBAL::warn = sub { 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 {
30 my $msg = join "", @_; 271 my $msg = join "", @_;
272
31 $msg .= "\n" 273 $msg .= "\n"
32 unless $msg =~ /\n$/; 274 unless $msg =~ /\n$/;
33 275
34 print STDERR "cfperl: $msg"; 276 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
35 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 $!;
36 }; 757 };
37} 758 cf::cleanup "db_open(db): $@" if $@;
38 759
39my %ignore_set = (MAP_PROP_PATH => 1); # I hate the plug-in api. Deeply! 760 $db
761}
40 762
41# generate property mutators 763our $DB;
42sub prop_gen {
43 my ($prefix, $class) = @_;
44 764
45 no strict 'refs'; 765sub db_init {
766 $DB ||= db_table "db";
767}
46 768
47 for my $prop (keys %PROP_TYPE) { 769sub db_get($$) {
48 $prop =~ /^\Q$prefix\E_(.*$)/ or next; 770 my $key = "$_[0]/$_[1]";
49 my $sub = lc $1;
50 771
51 my $type = $PROP_TYPE{$prop}; 772 cf::error "db_get called from main context"
52 my $idx = $PROP_IDX {$prop}; 773 if $Coro::current == $Coro::main;
53 774
54 *{"$class\::get_$sub"} = *{"$class\::$sub"} = sub { 775 BDB::db_get $DB, undef, $key, my $data;
55 $_[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->[$_];
56 }; 817 }
57 818
58 *{"$class\::set_$sub"} = sub { 819 # if processing is expensive, check
59 $_[0]->set_property ($type, $idx, $_[1]); 820 # checksum first
60 } unless $ignore_set{$prop}; 821 if (1) {
61 } 822 $md5 =
62} 823 join "\x00",
824 $processversion,
825 map {
826 cf::cede_to_tick;
827 ($src->[$_], Digest::MD5::md5_hex $data[$_])
828 } 0.. $#$src;
829
63 830
64# 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;
65 834
66prop_gen OBJECT_PROP => "cf::object"; 835 return db_get cache => "$id/data";
67# CFAPI_OBJECT_ANIMATION? 836 }
68prop_gen PLAYER_PROP => "cf::object::player"; 837 }
69 838
70prop_gen MAP_PROP => "cf::map"; 839 my $t1 = Time::HiRes::time;
71prop_gen ARCH_PROP => "cf::arch"; 840 my $data = $process->(\@data);
841 my $t2 = Time::HiRes::time;
72 842
73# guessed hierarchies 843 info "cache: '$id' processed in ", $t2 - $t1, "s\n";
74 844
75@ext::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 845 db_put cache => "$id/data", $data;
76@ext::cf::object::map::ISA = @cf::object::map::ISA = 'cf::object'; 846 db_put cache => "$id/md5" , $md5;
847 db_put cache => "$id/meta", $meta;
77 848
78# we bless all objects into derived classes to force a method lookup 849 return $data;
79# within the Safe compartment. 850 }
80for my $pkg (qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region cf::arch)) {
81 no strict 'refs';
82 @{"ext::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
83}
84 851
85$Event::DIED = sub { 852 db_get cache => "$id/data"
86 warn "error in event callback: @_"; 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;
87}; 1105};
88 1106
89my %ext_pkg; 1107# all those should be optimised
90my @exts; 1108sub cf::attachable::detach {
91my @hook; 1109 my ($obj, $name) = @_;
92my %command;
93my %extcmd;
94 1110
95sub inject_event { 1111 if (ref $obj) {
96 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 {
97 my $event_code = shift; 1150 my $event = shift;
1151 my $callbacks = shift;
98 1152
99 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
100 or return; 1344 or return;
101 1345
102 &$cb 1346 unless (aio_stat "$filename.pst") {
103} 1347 (aio_load "$filename.pst", $av) >= 0
104
105sub inject_global_event {
106 my $event = shift;
107
108 my $cb = $hook[$event]
109 or return; 1348 or return;
110 1349
111 List::Util::max map &$_, values %$cb 1350 my $st = eval { Coro::Storable::thaw $av };
112} 1351 $av = $st->{objs};
113
114sub inject_command {
115 my ($name, $obj, $params) = @_;
116
117 for my $cmd (@{ $command{$name} }) {
118 $cmd->[1]->($obj, $params);
119 } 1352 }
120 1353
121 -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)
122} 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
123 1377
124sub register_command { 1378sub register_command {
125 my ($name, $time, $cb) = @_; 1379 my ($name, $cb) = @_;
126 1380
127 my $caller = caller; 1381 my $caller = caller;
128 #warn "registering command '$name/$time' to '$caller'"; 1382 #warn "registering command '$name/$time' to '$caller'";
129 1383
130 push @{ $command{$name} }, [$time, $cb, $caller]; 1384 push @{ $COMMAND{$name} }, [$caller, $cb];
131 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
132} 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
133 1410
134sub register_extcmd { 1411sub register_extcmd {
135 my ($name, $cb) = @_; 1412 my ($name, $cb) = @_;
136 1413
137 my $caller = caller; 1414 $EXTCMD{$name} = $cb;
138 #warn "registering extcmd '$name' to '$caller'";
139
140 $extcmd{$name} = [$cb, $caller];
141} 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
142 1921
143sub 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 {
144 my ($base, $pkg) = @_; 1935 my ($self, $merge) = @_;
145 1936
146 for my $idx (0 .. $#EVENT) { 1937 # we have to keep some variables in memory intact
147 if (my $ref = $pkg->can ("on_$EVENT[$idx]")) { 1938 local $self->{path};
148 #warn "registering $EVENT[$idx] hook to '$pkg'\n"; 1939 local $self->{load_path};
149 $hook[$idx]{$base} = $ref;
150 }
151 }
152}
153 1940
154sub load_extension { 1941 $self->SUPER::thawer_merge ($merge);
1942}
1943
1944sub normalise {
155 my ($path) = @_; 1945 my ($path, $base) = @_;
156 1946
157 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 1947 $path = "$path"; # make sure it's a string
158 my $base = $1;
159 my $pkg = $1;
160 $pkg =~ s/[^[:word:]]/_/g;
161 $pkg = "cf::ext::$pkg";
162 1948
163 warn "loading '$path' into '$pkg'\n"; 1949 $path =~ s/\.map$//;
164 1950
165 open my $fh, "<:utf8", $path 1951 # map plan:
166 or die "$path: $!"; 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 # !up !down for quad maps, or other maps with up/down layers
167 1960
168 my $source = 1961 $path =~ s/$PATH_SEP/\//go;
169 "package $pkg; use strict; use utf8;\n"
170 . "#line 1 \"$path\"\n{\n"
171 . (do { local $/; <$fh> })
172 . "\n};\n1";
173 1962
174 eval $source 1963 # treat it as relative path if it starts with
175 or die "$path: $@"; 1964 # something that looks reasonable
1965 if ($path =~ m{^(?:\./|\.\./|\w)}) {
1966 $base or Carp::carp "normalise called with relative path and no base: '$path'";
176 1967
177 push @exts, $pkg; 1968 $base =~ s{[^/]+/?$}{};
178 $ext_pkg{$base} = $pkg; 1969 $path = "$base/$path";
179 1970
180# no strict 'refs'; 1971 } elsif ($path eq '!up') {
181# @{"$pkg\::ISA"} = ext::; 1972 $base && ref $base
1973 or Carp::carp "normalise called with relative tile path and no base: '$path'";
182 1974
183 register $base, $pkg; 1975 my $uppth = $base->tile_path (cf::TILE_UP);
184} 1976 $path = $uppth if $uppth;
185 1977
186sub unload_extension { 1978 } elsif ($path eq '!down') {
1979 $base && ref $base
1980 or Carp::carp "normalise called with relative tile path and no base: '$path'";
1981
1982 my $dpth = $base->tile_path (cf::TILE_DOWN);
1983 $path = $dpth if $dpth;
1984 }
1985
1986 for ($path) {
1987 redo if s{/\.?/}{/};
1988 redo if s{/[^/]+/\.\./}{/};
1989 }
1990
1991 $path
1992}
1993
1994sub new_from_path {
1995 my (undef, $path, $base) = @_;
1996
1997 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object
1998
1999 $path = normalise $path, $base;
2000
2001 for my $pkg (sort { $EXT_MAP{$b}[0] <=> $EXT_MAP{$a}[0] } keys %EXT_MAP) {
2002 if ($path =~ $EXT_MAP{$pkg}[1]) {
2003 my $self = bless cf::map::new, $pkg;
2004 $self->{path} = $path; $self->path ($path);
2005 $self->init; # pass $1 etc.
2006 return $self;
2007 }
2008 }
2009
2010 Carp::cluck "unable to resolve path '$path' (base '$base')";
2011 ()
2012}
2013
2014# may re-bless or do other evil things
2015sub init {
187 my ($pkg) = @_; 2016 my ($self) = @_;
188 2017
189 warn "removing extension $pkg\n"; 2018 $self
2019}
190 2020
191 # remove hooks 2021sub as_string {
192 for my $idx (0 .. $#EVENT) { 2022 my ($self) = @_;
193 delete $hook[$idx]{$pkg}; 2023
2024 "$self->{path}"
2025}
2026
2027# the displayed name, this is a one way mapping
2028sub visible_name {
2029 &as_string
2030}
2031
2032# the original (read-only) location
2033sub load_path {
2034 my ($self) = @_;
2035
2036 "$MAPDIR/$self->{path}.map"
2037}
2038
2039# the temporary/swap location
2040sub save_path {
2041 my ($self) = @_;
2042
2043 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
2044 "$TMPDIR/$path.map"
2045}
2046
2047# the unique path, undef == no special unique path
2048sub uniq_path {
2049 my ($self) = @_;
2050
2051 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
2052 "$UNIQUEDIR/$path"
2053}
2054
2055sub decay_objects {
2056 my ($self) = @_;
2057
2058 return if $self->{deny_reset};
2059
2060 $self->do_decay_objects;
2061}
2062
2063sub unlink_save {
2064 my ($self) = @_;
2065
2066 utf8::encode (my $save = $self->save_path);
2067 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
2068 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst";
2069}
2070
2071sub load_header_from($) {
2072 my ($self, $path) = @_;
2073
2074 utf8::encode $path;
2075 my $f = new_from_file cf::object::thawer $path
2076 or return;
2077
2078 $self->_load_header ($f)
2079 or return;
2080
2081 local $MAP_LOADING{$self->{path}} = $self;
2082 $f->resolve_delayed_derefs;
2083
2084 $self->{load_path} = $path;
2085
194 } 2086 1
2087}
195 2088
196 # remove commands 2089sub load_header_orig {
197 for my $name (keys %command) { 2090 my ($self) = @_;
198 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} };
199 2091
200 if (@cb) { 2092 $self->load_header_from ($self->load_path)
201 $command{$name} = \@cb; 2093}
202 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb; 2094
2095sub load_header_temp {
2096 my ($self) = @_;
2097
2098 $self->load_header_from ($self->save_path)
2099}
2100
2101sub prepare_temp {
2102 my ($self) = @_;
2103
2104 $self->last_access ((delete $self->{last_access})
2105 || $cf::RUNTIME); #d#
2106 # safety
2107 $self->{instantiate_time} = $cf::RUNTIME
2108 if $self->{instantiate_time} > $cf::RUNTIME;
2109}
2110
2111sub prepare_orig {
2112 my ($self) = @_;
2113
2114 $self->{load_original} = 1;
2115 $self->{instantiate_time} = $cf::RUNTIME;
2116 $self->last_access ($cf::RUNTIME);
2117 $self->instantiate;
2118}
2119
2120sub load_header {
2121 my ($self) = @_;
2122
2123 if ($self->load_header_temp) {
2124 $self->prepare_temp;
203 } else { 2125 } else {
204 delete $command{$name}; 2126 $self->load_header_orig
205 delete $COMMAND{"$name\000"}; 2127 or return;
206 } 2128 $self->prepare_orig;
2129 }
2130
2131 $self->{deny_reset} = 1
2132 if $self->no_reset;
2133
2134 $self->default_region (cf::region::find_by_path $self->{path})
2135 unless $self->default_region;
2136
207 } 2137 1
2138}
208 2139
209 # remove extcmds 2140sub find;
210 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 2141sub find {
211 delete $extcmd{$name}; 2142 my ($path, $origin) = @_;
2143
2144 cf::cede_to_tick;
2145
2146 $path = normalise $path, $origin;
2147
2148 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
2149 my $guard2 = cf::lock_acquire "map_find:$path";
2150
2151 $cf::MAP{$path} || do {
2152 my $map = new_from_path cf::map $path
2153 or return;
2154
2155 $map->{last_save} = $cf::RUNTIME;
2156
2157 $map->load_header
2158 or return;
2159
2160 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
2161 # doing this can freeze the server in a sync job, obviously
2162 #$cf::WAIT_FOR_TICK->wait;
2163 undef $guard2;
2164 undef $guard1;
2165 $map->reset;
2166 return find $path;
2167 }
2168
2169 $cf::MAP{$path} = $map
2170 }
2171}
2172
2173sub pre_load { }
2174#sub post_load { } # XS
2175
2176sub load {
2177 my ($self) = @_;
2178
2179 local $self->{deny_reset} = 1; # loading can take a long time
2180
2181 my $path = $self->{path};
2182
212 } 2183 {
2184 my $guard = cf::lock_acquire "map_data:$path";
213 2185
214 if (my $cb = $pkg->can ("on_unload")) { 2186 return unless $self->valid;
215 eval { 2187 return unless $self->in_memory == cf::MAP_SWAPPED;
216 $cb->($pkg); 2188
2189 $self->in_memory (cf::MAP_LOADING);
2190
2191 $self->alloc;
2192
2193 $self->pre_load;
2194 cf::cede_to_tick;
2195
2196 if (exists $self->{load_path}) {
2197 my $f = new_from_file cf::object::thawer $self->{load_path};
2198 $f->skip_block;
2199 $self->_load_objects ($f)
2200 or return;
2201
2202 $self->post_load_original
2203 if delete $self->{load_original};
2204
2205 if (my $uniq = $self->uniq_path) {
2206 utf8::encode $uniq;
2207 unless (aio_stat $uniq) {
2208 if (my $f = new_from_file cf::object::thawer $uniq) {
2209 $self->clear_unique_items;
2210 $self->_load_objects ($f);
2211 $f->resolve_delayed_derefs;
2212 }
217 1 2213 }
218 } or warn "$pkg unloaded, but with errors: $@";
219 }
220
221 Symbol::delete_package $pkg;
222}
223
224sub load_extensions {
225 my $LIBDIR = maps_directory "perl";
226
227 for my $ext (<$LIBDIR/*.ext>) {
228 next unless -r $ext;
229 eval {
230 load_extension $ext;
231 1
232 } or warn "$ext not loaded: $@";
233 }
234}
235
236register_command "perl-reload", 0, sub {
237 my ($who, $arg) = @_;
238
239 if ($who->flag (FLAG_WIZ)) {
240 $who->message ("reloading...");
241
242 warn "reloading...\n";
243 eval {
244 # 1. cancel all watchers
245 $_->cancel for Event::all_watchers;
246
247 # 2. unload all extensions
248 for (@exts) {
249 $who->message ("unloading <$_>");
250 unload_extension $_;
251 } 2214 }
252 2215
253 # 3. unload all modules loaded from $LIBDIR 2216 $f->resolve_delayed_derefs;
2217 }
2218
2219 cf::cede_to_tick;
2220 # now do the right thing for maps
2221 $self->link_multipart_objects;
2222 $self->difficulty ($self->estimate_difficulty)
2223 unless $self->difficulty;
2224 cf::cede_to_tick;
2225
2226 unless ($self->{deny_activate}) {
2227 $self->decay_objects;
2228 $self->fix_auto_apply;
2229 $self->update_buttons;
2230 cf::cede_to_tick;
2231 $self->activate;
2232 }
2233
2234 $self->{last_save} = $cf::RUNTIME;
2235 $self->last_access ($cf::RUNTIME);
2236
2237 $self->in_memory (cf::MAP_ACTIVE);
2238 }
2239
2240 $self->post_load;
2241
2242 1
2243}
2244
2245# customize the map for a given player, i.e.
2246# return the _real_ map. used by e.g. per-player
2247# maps to change the path to ~playername/mappath
2248sub customise_for {
2249 my ($self, $ob) = @_;
2250
2251 return find "~" . $ob->name . "/" . $self->{path}
2252 if $self->per_player;
2253
2254# return find "?party/" . $ob->name . "/" . $self->{path}
2255# if $self->per_party;
2256
2257 $self
2258}
2259
2260# find and load all maps in the 3x3 area around a map
2261sub load_neighbours {
2262 my ($map) = @_;
2263
2264 my @neigh; # diagonal neighbours
2265
2266 for (0 .. 3) {
2267 my $neigh = $map->tile_path ($_)
2268 or next;
2269 $neigh = find $neigh, $map
2270 or next;
2271 $neigh->load;
2272
2273 # now find the diagonal neighbours
2274 push @neigh,
2275 [$neigh->tile_path (($_ + 3) % 4), $neigh],
2276 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2277 }
2278
2279 for (grep defined $_->[0], @neigh) {
2280 my ($path, $origin) = @$_;
2281 my $neigh = find $path, $origin
2282 or next;
2283 $neigh->load;
2284 }
2285}
2286
2287sub find_sync {
2288 my ($path, $origin) = @_;
2289
2290 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync"
2291 if $Coro::current == $Coro::main;
2292
2293 find $path, $origin
2294}
2295
2296sub do_load_sync {
2297 my ($map) = @_;
2298
2299 return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync"
2300 if $Coro::current == $Coro::main;
2301
2302 $map->load;
2303}
2304
2305our %MAP_PREFETCH;
2306our $MAP_PREFETCHER = undef;
2307
2308sub find_async {
2309 my ($path, $origin, $load) = @_;
2310
2311 $path = normalise $path, $origin;
2312
2313 if (my $map = $cf::MAP{$path}) {
2314 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
2315 }
2316
2317 $MAP_PREFETCH{$path} |= $load;
2318
2319 $MAP_PREFETCHER ||= cf::async {
2320 $Coro::current->{desc} = "map prefetcher";
2321
2322 while (%MAP_PREFETCH) {
254 while (my ($k, $v) = each %INC) { 2323 while (my ($k, $v) = each %MAP_PREFETCH) {
255 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2324 if (my $map = find $k) {
256 2325 $map->load if $v;
257 $who->message ("removing <$k>");
258 delete $INC{$k};
259
260 $k =~ s/\.pm$//;
261 $k =~ s/\//::/g;
262
263 if (my $cb = $k->can ("unload_module")) {
264 $cb->();
265 } 2326 }
266 2327
267 Symbol::delete_package $k; 2328 delete $MAP_PREFETCH{$k};
268 } 2329 }
269
270 # 4. get rid of ext::, as good as possible
271 Symbol::delete_package "ext::$_"
272 for qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region);
273
274 # 5. remove register_script_function callbacks
275 # TODO
276
277 # 6. unload cf.pm "a bit"
278 delete $INC{"cf.pm"};
279
280 # don't, removes xs symbols, too
281 #Symbol::delete_package __PACKAGE__;
282
283 # 7. reload cf.pm
284 $who->message ("reloading cf.pm");
285 require cf;
286 }; 2330 }
287 warn $@ if $@; 2331 undef $MAP_PREFETCHER;
288 $who->message ($@) if $@; 2332 };
289 warn "reloaded\n"; 2333 $MAP_PREFETCHER->prio (6);
290 2334
291 $who->message ("reloaded"); 2335 ()
2336}
2337
2338# common code, used by both ->save and ->swapout
2339sub _save {
2340 my ($self) = @_;
2341
2342 $self->{last_save} = $cf::RUNTIME;
2343
2344 return unless $self->dirty;
2345
2346 my $save = $self->save_path; utf8::encode $save;
2347 my $uniq = $self->uniq_path; utf8::encode $uniq;
2348
2349 $self->{load_path} = $save;
2350
2351 return if $self->{deny_save};
2352
2353 local $self->{last_access} = $self->last_access;#d#
2354
2355 cf::async {
2356 $Coro::current->{desc} = "map player save";
2357 $_->contr->save for $self->players;
2358 };
2359
2360 cf::get_slot 0.02;
2361
2362 if ($uniq) {
2363 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
2364 $self->_save_objects ($uniq, cf::IO_UNIQUES);
292 } else { 2365 } else {
293 $who->message ("Intruder Alert!"); 2366 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
294 } 2367 }
295};
296
297#############################################################################
298# utility functions
299
300use JSON::Syck (); # TODO# replace by JSON::PC once working
301
302sub from_json($) {
303 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
304 JSON::Syck::Load $_[0]
305} 2368}
306 2369
307sub to_json($) { 2370sub save {
308 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
309 JSON::Syck::Dump $_[0]
310}
311
312#############################################################################
313# extcmd framework, basically convert ext <msg>
314# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
315
316sub on_extcmd {
317 my ($pl, $buf) = @_; 2371 my ($self) = @_;
318 2372
319 my $msg = eval { from_json $buf }; 2373 my $lock = cf::lock_acquire "map_data:$self->{path}";
320 2374
321 if (ref $msg) { 2375 $self->_save;
322 if (my $cb = $extcmd{$msg->{msgtype}}) { 2376}
323 if (my %reply = $cb->[0]->($pl, $msg)) { 2377
324 $pl->ext_reply ($msg->{msgid}, %reply); 2378sub swap_out {
2379 my ($self) = @_;
2380
2381 my $lock = cf::lock_acquire "map_data:$self->{path}";
2382
2383 return if $self->in_memory != cf::MAP_ACTIVE;
2384 return if $self->{deny_save};
2385 return if $self->players;
2386
2387 # first deactivate the map and "unlink" it from the core
2388 $self->deactivate;
2389 $_->clear_links_to ($self) for values %cf::MAP;
2390 $self->in_memory (cf::MAP_SWAPPED);
2391
2392 # then atomically save
2393 $self->_save;
2394
2395 # then free the map
2396 $self->clear;
2397}
2398
2399sub reset_at {
2400 my ($self) = @_;
2401
2402 # TODO: safety, remove and allow resettable per-player maps
2403 return 1e99 if $self->{deny_reset};
2404
2405 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2406 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2407
2408 $time + $to
2409}
2410
2411sub should_reset {
2412 my ($self) = @_;
2413
2414 $self->reset_at <= $cf::RUNTIME
2415}
2416
2417sub reset {
2418 my ($self) = @_;
2419
2420 my $lock = cf::lock_acquire "map_data:$self->{path}";
2421
2422 return if $self->players;
2423
2424 cf::trace "resetting map ", $self->path, "\n";
2425
2426 $self->in_memory (cf::MAP_SWAPPED);
2427
2428 # need to save uniques path
2429 unless ($self->{deny_save}) {
2430 my $uniq = $self->uniq_path; utf8::encode $uniq;
2431
2432 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2433 if $uniq;
2434 }
2435
2436 delete $cf::MAP{$self->path};
2437
2438 $self->deactivate;
2439 $_->clear_links_to ($self) for values %cf::MAP;
2440 $self->clear;
2441
2442 $self->unlink_save;
2443 $self->destroy;
2444}
2445
2446my $nuke_counter = "aaaa";
2447
2448sub nuke {
2449 my ($self) = @_;
2450
2451 {
2452 my $lock = cf::lock_acquire "map_data:$self->{path}";
2453
2454 delete $cf::MAP{$self->path};
2455
2456 $self->unlink_save;
2457
2458 bless $self, "cf::map::wrap";
2459 delete $self->{deny_reset};
2460 $self->{deny_save} = 1;
2461 $self->reset_timeout (1);
2462 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2463
2464 $cf::MAP{$self->path} = $self;
2465 }
2466
2467 $self->reset; # polite request, might not happen
2468}
2469
2470=item $maps = cf::map::tmp_maps
2471
2472Returns an arrayref with all map paths of currently instantiated and saved
2473maps. May block.
2474
2475=cut
2476
2477sub tmp_maps() {
2478 [
2479 map {
2480 utf8::decode $_;
2481 /\.map$/
2482 ? normalise $_
2483 : ()
2484 } @{ aio_readdir $TMPDIR or [] }
2485 ]
2486}
2487
2488=item $maps = cf::map::random_maps
2489
2490Returns an arrayref with all map paths of currently instantiated and saved
2491random maps. May block.
2492
2493=cut
2494
2495sub random_maps() {
2496 [
2497 map {
2498 utf8::decode $_;
2499 /\.map$/
2500 ? normalise "?random/$_"
2501 : ()
2502 } @{ aio_readdir $RANDOMDIR or [] }
2503 ]
2504}
2505
2506=item cf::map::unique_maps
2507
2508Returns an arrayref of paths of all shared maps that have
2509instantiated unique items. May block.
2510
2511=cut
2512
2513sub unique_maps() {
2514 [
2515 map {
2516 utf8::decode $_;
2517 s/\.map$//; # TODO future compatibility hack
2518 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
2519 ? ()
2520 : normalise $_
2521 } @{ aio_readdir $UNIQUEDIR or [] }
2522 ]
2523}
2524
2525=item cf::map::static_maps
2526
2527Returns an arrayref if paths of all static maps (all preinstalled F<.map>
2528file in the shared directory excluding F</styles> and F</editor>). May
2529block.
2530
2531=cut
2532
2533sub static_maps() {
2534 my @dirs = "";
2535 my @maps;
2536
2537 while (@dirs) {
2538 my $dir = shift @dirs;
2539
2540 next if $dir eq "/styles" || $dir eq "/editor";
2541
2542 my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
2543 or return;
2544
2545 for (@$files) {
2546 s/\.map$// or next;
2547 utf8::decode $_;
2548 push @maps, "$dir/$_";
325 } 2549 }
326 } 2550
2551 push @dirs, map "$dir/$_", @$dirs;
2552 }
2553
2554 \@maps
2555}
2556
2557=back
2558
2559=head3 cf::object
2560
2561=cut
2562
2563package cf::object;
2564
2565=over 4
2566
2567=item $ob->inv_recursive
2568
2569Returns the inventory of the object I<and> their inventories, recursively,
2570but I<not> the object itself.
2571
2572=cut
2573
2574sub inv_recursive_;
2575sub inv_recursive_ {
2576 map { $_, inv_recursive_ $_->inv } @_
2577}
2578
2579sub inv_recursive {
2580 inv_recursive_ inv $_[0]
2581}
2582
2583=item $ref = $ob->ref
2584
2585Creates and returns a persistent reference to an object that can be stored as a string.
2586
2587=item $ob = cf::object::deref ($refstring)
2588
2589returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2590even if the object actually exists. May block.
2591
2592=cut
2593
2594sub deref {
2595 my ($ref) = @_;
2596
2597 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2598 my ($uuid, $name) = ($1, $2);
2599 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2600 or return;
2601 $pl->ob->uuid eq $uuid
2602 or return;
2603
2604 $pl->ob
327 } else { 2605 } else {
328 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 2606 warn "$ref: cannot resolve object reference\n";
329 } 2607 undef
330
331 1 2608 }
332} 2609}
333 2610
334############################################################################# 2611package cf;
335# load/save/clean perl data associated with a map
336 2612
337*on_mapclean = sub { 2613=back
338 my ($map) = @_;
339 2614
340 my $path = $map->tmpname; 2615=head3 cf::object::player
341 defined $path or return;
342 2616
343 unlink "$path.cfperl"; 2617=over 4
344};
345 2618
346*on_mapin =
347*on_mapload = sub {
348 my ($map) = @_;
349
350 my $path = $map->tmpname;
351 $path = $map->path unless defined $path;
352
353 open my $fh, "<:raw", "$path.cfperl"
354 or return; # no perl data
355
356 my $data = Storable::thaw do { local $/; <$fh> };
357
358 $data->{version} <= 1
359 or return; # too new
360
361 $map->_set_obs ($data->{obs});
362};
363
364*on_mapout = sub {
365 my ($map) = @_;
366
367 my $path = $map->tmpname;
368 $path = $map->path unless defined $path;
369
370 my $obs = $map->_get_obs;
371
372 if (defined $obs) {
373 open my $fh, ">:raw", "$path.cfperl"
374 or die "$path.cfperl: $!";
375
376 stat $path;
377
378 print $fh Storable::nfreeze {
379 size => (stat _)[7],
380 time => (stat _)[9],
381 version => 1,
382 obs => $obs,
383 };
384
385 chmod SAVE_MODE, "$path.cfperl"; # very racy, but cf-compatible *g*
386 } else {
387 unlink "$path.cfperl";
388 }
389};
390
391#############################################################################
392# load/save perl data associated with player->ob objects
393
394sub all_objects(@) {
395 @_, map all_objects ($_->inv), @_
396}
397
398*on_player_load = sub {
399 my ($ob, $path) = @_;
400
401 for my $o (all_objects $ob) {
402 if (my $value = $o->get_ob_key_value ("_perl_data")) {
403 $o->set_ob_key_value ("_perl_data");
404
405 %$o = %{ Storable::thaw pack "H*", $value };
406 }
407 }
408};
409
410*on_player_save = sub {
411 my ($ob, $path) = @_;
412
413 $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_)
414 for grep %$_, all_objects $ob;
415};
416
417#############################################################################
418# core extensions - in perl
419
420=item cf::player::exists $login
421
422Returns true when the given account exists.
423
424=cut
425
426sub cf::player::exists($) {
427 cf::player::find $_[0]
428 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
429}
430
431=item $player->reply ($npc, $msg[, $flags]) 2619=item $player_object->reply ($npc, $msg[, $flags])
432 2620
433Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 2621Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
434can be C<undef>. Does the right thing when the player is currently in a 2622can be C<undef>. Does the right thing when the player is currently in a
435dialogue with the given NPC character. 2623dialogue with the given NPC character.
436 2624
437=cut 2625=cut
438 2626
2627our $SAY_CHANNEL = {
2628 id => "say",
2629 title => "Map",
2630 reply => "say ",
2631 tooltip => "Things said to and replied from NPCs near you and other players on the same map only.",
2632};
2633
2634our $CHAT_CHANNEL = {
2635 id => "chat",
2636 title => "Chat",
2637 reply => "chat ",
2638 tooltip => "Player chat and shouts, global to the server.",
2639};
2640
439# rough implementation of a future "reply" method that works 2641# rough implementation of a future "reply" method that works
440# with dialog boxes. 2642# with dialog boxes.
2643#TODO: the first argument must go, split into a $npc->reply_to ( method
441sub cf::object::player::reply($$$;$) { 2644sub cf::object::player::reply($$$;$) {
442 my ($self, $npc, $msg, $flags) = @_; 2645 my ($self, $npc, $msg, $flags) = @_;
443 2646
444 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2647 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
445 2648
446 if ($self->{record_replies}) { 2649 if ($self->{record_replies}) {
447 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2650 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2651
448 } else { 2652 } else {
2653 my $pl = $self->contr;
2654
2655 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2656 my $dialog = $pl->{npc_dialog};
2657 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2658
2659 } else {
449 $msg = $npc->name . " says: $msg" if $npc; 2660 $msg = $npc->name . " says: $msg" if $npc;
450 $self->message ($msg, $flags); 2661 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2662 }
2663 }
2664}
2665
2666=item $object->send_msg ($channel, $msg, $color, [extra...])
2667
2668=cut
2669
2670sub cf::object::send_msg {
2671 my $pl = shift->contr
2672 or return;
2673 $pl->send_msg (@_);
2674}
2675
2676=item $player_object->may ("access")
2677
2678Returns wether the given player is authorized to access resource "access"
2679(e.g. "command_wizcast").
2680
2681=cut
2682
2683sub cf::object::player::may {
2684 my ($self, $access) = @_;
2685
2686 $self->flag (cf::FLAG_WIZ) ||
2687 (ref $cf::CFG{"may_$access"}
2688 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
2689 : $cf::CFG{"may_$access"})
2690}
2691
2692=item $player_object->enter_link
2693
2694Freezes the player and moves him/her to a special map (C<{link}>).
2695
2696The player should be reasonably safe there for short amounts of time (e.g.
2697for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2698though, as the player cannot control the character while it is on the link
2699map.
2700
2701Will never block.
2702
2703=item $player_object->leave_link ($map, $x, $y)
2704
2705Moves the player out of the special C<{link}> map onto the specified
2706map. If the map is not valid (or omitted), the player will be moved back
2707to the location he/she was before the call to C<enter_link>, or, if that
2708fails, to the emergency map position.
2709
2710Might block.
2711
2712=cut
2713
2714sub link_map {
2715 unless ($LINK_MAP) {
2716 $LINK_MAP = cf::map::find "{link}"
2717 or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
2718 $LINK_MAP->load;
2719 }
2720
2721 $LINK_MAP
2722}
2723
2724sub cf::object::player::enter_link {
2725 my ($self) = @_;
2726
2727 $self->deactivate_recursive;
2728
2729 ++$self->{_link_recursion};
2730
2731 return if UNIVERSAL::isa $self->map, "ext::map_link";
2732
2733 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2734 if $self->map && $self->map->{path} ne "{link}";
2735
2736 $self->enter_map ($LINK_MAP || link_map, 3, 3);
2737}
2738
2739sub cf::object::player::leave_link {
2740 my ($self, $map, $x, $y) = @_;
2741
2742 return unless $self->contr->active;
2743
2744 my $link_pos = delete $self->{_link_pos};
2745
2746 unless ($map) {
2747 # restore original map position
2748 ($map, $x, $y) = @{ $link_pos || [] };
2749 $map = cf::map::find $map;
2750
2751 unless ($map) {
2752 ($map, $x, $y) = @$EMERGENCY_POSITION;
2753 $map = cf::map::find $map
2754 or die "FATAL: cannot load emergency map\n";
2755 }
2756 }
2757
2758 ($x, $y) = (-1, -1)
2759 unless (defined $x) && (defined $y);
2760
2761 # use -1 or undef as default coordinates, not 0, 0
2762 ($x, $y) = ($map->enter_x, $map->enter_y)
2763 if $x <= 0 && $y <= 0;
2764
2765 $map->load;
2766 $map->load_neighbours;
2767
2768 return unless $self->contr->active;
2769
2770 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2771 if ($self->enter_map ($map, $x, $y)) {
2772 # entering was successful
2773 delete $self->{_link_recursion};
2774 # only activate afterwards, to support waiting in hooks
2775 $self->activate_recursive;
2776 }
2777
2778}
2779
2780=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
2781
2782Moves the player to the given map-path and coordinates by first freezing
2783her, loading and preparing them map, calling the provided $check callback
2784that has to return the map if sucecssful, and then unfreezes the player on
2785the new (success) or old (failed) map position. In either case, $done will
2786be called at the end of this process.
2787
2788Note that $check will be called with a potentially non-loaded map, so if
2789it needs a loaded map it has to call C<< ->load >>.
2790
2791=cut
2792
2793our $GOTOGEN;
2794
2795sub cf::object::player::goto {
2796 my ($self, $path, $x, $y, $check, $done) = @_;
2797
2798 if ($self->{_link_recursion} >= $MAX_LINKS) {
2799 error "FATAL: link recursion exceeded, ", $self->name, " goto $path $x $y, redirecting.";
2800 $self->failmsg ("Something went wrong inside the server - please contact an administrator!");
2801 ($path, $x, $y) = @$EMERGENCY_POSITION;
2802 }
2803
2804 # do generation counting so two concurrent goto's will be executed in-order
2805 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2806
2807 $self->enter_link;
2808
2809 (async {
2810 $Coro::current->{desc} = "player::goto $path $x $y";
2811
2812 # *tag paths override both path and x|y
2813 if ($path =~ /^\*(.*)$/) {
2814 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2815 my $ob = $obs[rand @obs];
2816
2817 # see if we actually can go there
2818 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2819 $ob = $obs[rand @obs];
2820 } else {
2821 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2822 }
2823 # else put us there anyways for now #d#
2824
2825 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2826 } else {
2827 ($path, $x, $y) = (undef, undef, undef);
2828 }
2829 }
2830
2831 my $map = eval {
2832 my $map = defined $path ? cf::map::find $path, $self->map : undef;
2833
2834 if ($map) {
2835 $map = $map->customise_for ($self);
2836 $map = $check->($map, $x, $y, $self) if $check && $map;
2837 } else {
2838 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2839 }
2840
2841 $map
2842 };
2843
2844 if ($@) {
2845 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2846 LOG llevError | logBacktrace, Carp::longmess $@;
2847 }
2848
2849 if ($gen == $self->{_goto_generation}) {
2850 delete $self->{_goto_generation};
2851 $self->leave_link ($map, $x, $y);
2852 }
2853
2854 $done->($self) if $done;
2855 })->prio (1);
2856}
2857
2858=item $player_object->enter_exit ($exit_object)
2859
2860=cut
2861
2862sub parse_random_map_params {
2863 my ($spec) = @_;
2864
2865 my $rmp = { # defaults
2866 xsize => (cf::rndm 15, 40),
2867 ysize => (cf::rndm 15, 40),
2868 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
2869 #layout => string,
451 } 2870 };
452}
453 2871
2872 for (split /\n/, $spec) {
2873 my ($k, $v) = split /\s+/, $_, 2;
2874
2875 $rmp->{lc $k} = $v if (length $k) && (length $v);
2876 }
2877
2878 $rmp
2879}
2880
2881sub prepare_random_map {
2882 my ($exit) = @_;
2883
2884 # all this does is basically replace the /! path by
2885 # a new random map path (?random/...) with a seed
2886 # that depends on the exit object
2887
2888 my $rmp = parse_random_map_params $exit->msg;
2889
2890 if ($exit->map) {
2891 $rmp->{region} = $exit->region->name;
2892 $rmp->{origin_map} = $exit->map->path;
2893 $rmp->{origin_x} = $exit->x;
2894 $rmp->{origin_y} = $exit->y;
2895
2896 $exit->map->touch;
2897 }
2898
2899 $rmp->{random_seed} ||= $exit->random_seed;
2900
2901 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2902 my $md5 = Digest::MD5::md5_hex $data;
2903 my $meta = "$RANDOMDIR/$md5.meta";
2904
2905 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2906 aio_write $fh, 0, (length $data), $data, 0;
2907 undef $fh;
2908 aio_rename "$meta~", $meta;
2909
2910 my $slaying = "?random/$md5";
2911
2912 if ($exit->valid) {
2913 $exit->slaying ("?random/$md5");
2914 $exit->msg (undef);
2915 }
2916 }
2917}
2918
2919sub cf::object::player::enter_exit {
2920 my ($self, $exit) = @_;
2921
2922 return unless $self->type == cf::PLAYER;
2923
2924 $self->enter_link;
2925
2926 (async {
2927 $Coro::current->{desc} = "enter_exit";
2928
2929 unless (eval {
2930 $self->deactivate_recursive; # just to be sure
2931
2932 # random map handling
2933 {
2934 my $guard = cf::lock_acquire "exit_prepare:$exit";
2935
2936 prepare_random_map $exit
2937 if $exit->slaying eq "/!";
2938 }
2939
2940 my $map = cf::map::normalise $exit->slaying, $exit->map;
2941 my $x = $exit->stats->hp;
2942 my $y = $exit->stats->sp;
2943
2944 $self->goto ($map, $x, $y);
2945
2946 # if exit is damned, update players death & WoR home-position
2947 $self->contr->savebed ($map, $x, $y)
2948 if $exit->flag (cf::FLAG_DAMNED);
2949
2950 1
2951 }) {
2952 $self->message ("Something went wrong deep within the deliantra server. "
2953 . "I'll try to bring you back to the map you were before. "
2954 . "Please report this to the dungeon master!",
2955 cf::NDI_UNIQUE | cf::NDI_RED);
2956
2957 error "ERROR in enter_exit: $@";
2958 $self->leave_link;
2959 }
2960 })->prio (1);
2961}
2962
2963=head3 cf::client
2964
2965=over 4
2966
2967=item $client->send_drawinfo ($text, $flags)
2968
2969Sends a drawinfo packet to the client. Circumvents output buffering so
2970should not be used under normal circumstances.
2971
2972=cut
2973
2974sub cf::client::send_drawinfo {
2975 my ($self, $text, $flags) = @_;
2976
2977 utf8::encode $text;
2978 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2979}
2980
2981=item $client->send_big_packet ($pkt)
2982
2983Like C<send_packet>, but tries to compress large packets, and fragments
2984them as required.
2985
2986=cut
2987
2988our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
2989
2990sub cf::client::send_big_packet {
2991 my ($self, $pkt) = @_;
2992
2993 # try lzf for large packets
2994 $pkt = "lzf " . Compress::LZF::compress $pkt
2995 if 1024 <= length $pkt and $self->{can_lzf};
2996
2997 # split very large packets
2998 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
2999 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
3000 $pkt = "frag";
3001 }
3002
3003 $self->send_packet ($pkt);
3004}
3005
3006=item $client->send_msg ($channel, $msg, $color, [extra...])
3007
3008Send a drawinfo or msg packet to the client, formatting the msg for the
3009client if neccessary. C<$type> should be a string identifying the type of
3010the message, with C<log> being the default. If C<$color> is negative, suppress
3011the message unless the client supports the msg packet.
3012
3013=cut
3014
3015# non-persistent channels (usually the info channel)
3016our %CHANNEL = (
3017 "c/motd" => {
3018 id => "infobox",
3019 title => "MOTD",
3020 reply => undef,
3021 tooltip => "The message of the day",
3022 },
3023 "c/identify" => {
3024 id => "infobox",
3025 title => "Identify",
3026 reply => undef,
3027 tooltip => "Items recently identified",
3028 },
3029 "c/examine" => {
3030 id => "infobox",
3031 title => "Examine",
3032 reply => undef,
3033 tooltip => "Signs and other items you examined",
3034 },
3035 "c/shopinfo" => {
3036 id => "infobox",
3037 title => "Shop Info",
3038 reply => undef,
3039 tooltip => "What your bargaining skill tells you about the shop",
3040 },
3041 "c/book" => {
3042 id => "infobox",
3043 title => "Book",
3044 reply => undef,
3045 tooltip => "The contents of a note or book",
3046 },
3047 "c/lookat" => {
3048 id => "infobox",
3049 title => "Look",
3050 reply => undef,
3051 tooltip => "What you saw there",
3052 },
3053 "c/who" => {
3054 id => "infobox",
3055 title => "Players",
3056 reply => undef,
3057 tooltip => "Shows players who are currently online",
3058 },
3059 "c/body" => {
3060 id => "infobox",
3061 title => "Body Parts",
3062 reply => undef,
3063 tooltip => "Shows which body parts you posess and are available",
3064 },
3065 "c/statistics" => {
3066 id => "infobox",
3067 title => "Statistics",
3068 reply => undef,
3069 tooltip => "Shows your primary statistics",
3070 },
3071 "c/skills" => {
3072 id => "infobox",
3073 title => "Skills",
3074 reply => undef,
3075 tooltip => "Shows your experience per skill and item power",
3076 },
3077 "c/shopitems" => {
3078 id => "infobox",
3079 title => "Shop Items",
3080 reply => undef,
3081 tooltip => "Shows the items currently for sale in this shop",
3082 },
3083 "c/resistances" => {
3084 id => "infobox",
3085 title => "Resistances",
3086 reply => undef,
3087 tooltip => "Shows your resistances",
3088 },
3089 "c/pets" => {
3090 id => "infobox",
3091 title => "Pets",
3092 reply => undef,
3093 tooltip => "Shows information abotu your pets/a specific pet",
3094 },
3095 "c/perceiveself" => {
3096 id => "infobox",
3097 title => "Perceive Self",
3098 reply => undef,
3099 tooltip => "You gained detailed knowledge about yourself",
3100 },
3101 "c/uptime" => {
3102 id => "infobox",
3103 title => "Uptime",
3104 reply => undef,
3105 tooltip => "How long the server has been running since last restart",
3106 },
3107 "c/mapinfo" => {
3108 id => "infobox",
3109 title => "Map Info",
3110 reply => undef,
3111 tooltip => "Information related to the maps",
3112 },
3113 "c/party" => {
3114 id => "party",
3115 title => "Party",
3116 reply => "gsay ",
3117 tooltip => "Messages and chat related to your party",
3118 },
3119 "c/death" => {
3120 id => "death",
3121 title => "Death",
3122 reply => undef,
3123 tooltip => "Reason for and more info about your most recent death",
3124 },
3125 "c/say" => $SAY_CHANNEL,
3126 "c/chat" => $CHAT_CHANNEL,
3127);
3128
3129sub cf::client::send_msg {
3130 my ($self, $channel, $msg, $color, @extra) = @_;
3131
3132 $msg = $self->pl->expand_cfpod ($msg)
3133 unless $color & cf::NDI_VERBATIM;
3134
3135 $color &= cf::NDI_CLIENT_MASK; # just in case...
3136
3137 # check predefined channels, for the benefit of C
3138 if ($CHANNEL{$channel}) {
3139 $channel = $CHANNEL{$channel};
3140
3141 $self->ext_msg (channel_info => $channel);
3142 $channel = $channel->{id};
3143
3144 } elsif (ref $channel) {
3145 # send meta info to client, if not yet sent
3146 unless (exists $self->{channel}{$channel->{id}}) {
3147 $self->{channel}{$channel->{id}} = $channel;
3148 $self->ext_msg (channel_info => $channel);
3149 }
3150
3151 $channel = $channel->{id};
3152 }
3153
3154 return unless @extra || length $msg;
3155
3156 # default colour, mask it out
3157 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
3158 if $color & cf::NDI_DEF;
3159
3160 my $pkt = "msg "
3161 . $self->{json_coder}->encode (
3162 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
3163 );
3164
3165 $self->send_big_packet ($pkt);
3166}
3167
3168=item $client->ext_msg ($type, @msg)
3169
3170Sends an ext event to the client.
3171
3172=cut
3173
3174sub cf::client::ext_msg($$@) {
3175 my ($self, $type, @msg) = @_;
3176
3177 if ($self->extcmd == 2) {
3178 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
3179 } elsif ($self->extcmd == 1) { # TODO: remove
3180 push @msg, msgtype => "event_$type";
3181 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3182 }
3183}
3184
454=item $player->ext_reply ($msgid, $msgtype, %msg) 3185=item $client->ext_reply ($msgid, @msg)
455 3186
456Sends an ext reply to the player. 3187Sends an ext reply to the client.
457 3188
458=cut 3189=cut
459 3190
460sub cf::player::ext_reply($$$%) { 3191sub cf::client::ext_reply($$@) {
461 my ($self, $id, %msg) = @_; 3192 my ($self, $id, @msg) = @_;
462 3193
463 $msg{msgid} = $id; 3194 if ($self->extcmd == 2) {
464 3195 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
465 $self->send ("ext " . to_json \%msg); 3196 } elsif ($self->extcmd == 1) {
3197 #TODO: version 1, remove
3198 unshift @msg, msgtype => "reply", msgid => $id;
3199 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3200 }
466} 3201}
467 3202
468############################################################################# 3203=item $success = $client->query ($flags, "text", \&cb)
469# map scripting support
470 3204
3205Queues a query to the client, calling the given callback with
3206the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
3207C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
3208
3209Queries can fail, so check the return code. Or don't, as queries will
3210become reliable at some point in the future.
3211
3212=cut
3213
3214sub cf::client::query {
3215 my ($self, $flags, $text, $cb) = @_;
3216
3217 return unless $self->state == ST_PLAYING
3218 || $self->state == ST_SETUP
3219 || $self->state == ST_CUSTOM;
3220
3221 $self->state (ST_CUSTOM);
3222
3223 utf8::encode $text;
3224 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
3225
3226 $self->send_packet ($self->{query_queue}[0][0])
3227 if @{ $self->{query_queue} } == 1;
3228
3229 1
3230}
3231
3232cf::client->attach (
3233 on_connect => sub {
3234 my ($ns) = @_;
3235
3236 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
3237 },
3238 on_reply => sub {
3239 my ($ns, $msg) = @_;
3240
3241 # this weird shuffling is so that direct followup queries
3242 # get handled first
3243 my $queue = delete $ns->{query_queue}
3244 or return; # be conservative, not sure how that can happen, but we saw a crash here
3245
3246 (shift @$queue)->[1]->($msg);
3247 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
3248
3249 push @{ $ns->{query_queue} }, @$queue;
3250
3251 if (@{ $ns->{query_queue} } == @$queue) {
3252 if (@$queue) {
3253 $ns->send_packet ($ns->{query_queue}[0][0]);
3254 } else {
3255 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
3256 }
3257 }
3258 },
3259 on_exticmd => sub {
3260 my ($ns, $buf) = @_;
3261
3262 my $msg = eval { $ns->{json_coder}->decode ($buf) };
3263
3264 if (ref $msg) {
3265 my ($type, $reply, @payload) =
3266 "ARRAY" eq ref $msg
3267 ? @$msg
3268 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
3269
3270 my @reply;
3271
3272 if (my $cb = $EXTICMD{$type}) {
3273 @reply = $cb->($ns, @payload);
3274 }
3275
3276 $ns->ext_reply ($reply, @reply)
3277 if $reply;
3278
3279 } else {
3280 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3281 }
3282
3283 cf::override;
3284 },
3285);
3286
3287=item $client->async (\&cb)
3288
3289Create a new coroutine, running the specified callback. The coroutine will
3290be automatically cancelled when the client gets destroyed (e.g. on logout,
3291or loss of connection).
3292
3293=cut
3294
3295sub cf::client::async {
3296 my ($self, $cb) = @_;
3297
3298 my $coro = &Coro::async ($cb);
3299
3300 $coro->on_destroy (sub {
3301 delete $self->{_coro}{$coro+0};
3302 });
3303
3304 $self->{_coro}{$coro+0} = $coro;
3305
3306 $coro
3307}
3308
3309cf::client->attach (
3310 on_client_destroy => sub {
3311 my ($ns) = @_;
3312
3313 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
3314 },
3315);
3316
3317=back
3318
3319
3320=head2 SAFE SCRIPTING
3321
3322Functions that provide a safe environment to compile and execute
3323snippets of perl code without them endangering the safety of the server
3324itself. Looping constructs, I/O operators and other built-in functionality
3325is not available in the safe scripting environment, and the number of
3326functions and methods that can be called is greatly reduced.
3327
3328=cut
3329
471our $safe = new Safe "ext"; 3330our $safe = new Safe "safe";
472our $safe_hole = new Safe::Hole; 3331our $safe_hole = new Safe::Hole;
473 3332
474$SIG{FPE} = 'IGNORE'; 3333$SIG{FPE} = 'IGNORE';
475 3334
476$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 3335$safe->permit_only (Opcode::opset qw(
3336 :base_core :base_mem :base_orig :base_math :base_loop
3337 grepstart grepwhile mapstart mapwhile
3338 sort time
3339));
477 3340
478# here we export the classes and methods available to script code 3341# here we export the classes and methods available to script code
479 3342
3343=pod
3344
3345The following functions and methods are available within a safe environment:
3346
3347 cf::object
3348 contr pay_amount pay_player map x y force_find force_add destroy
3349 insert remove name archname title slaying race decrease split
3350 value
3351
3352 cf::object::player
3353 player
3354
3355 cf::player
3356 peaceful
3357
3358 cf::map
3359 trigger
3360
3361=cut
3362
480for ( 3363for (
481 ["cf::object" => qw(contr pay_amount pay_player)], 3364 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3365 insert remove inv nrof name archname title slaying race
3366 decrease split destroy change_exp value msg lore send_msg)],
482 ["cf::object::player" => qw(player)], 3367 ["cf::object::player" => qw(player)],
483 ["cf::player" => qw(peaceful)], 3368 ["cf::player" => qw(peaceful send_msg)],
3369 ["cf::map" => qw(trigger)],
484) { 3370) {
485 no strict 'refs';
486 my ($pkg, @funs) = @$_; 3371 my ($pkg, @funs) = @$_;
487 *{"ext::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3372 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
488 for @funs; 3373 for @funs;
489} 3374}
3375
3376=over 4
3377
3378=item @retval = safe_eval $code, [var => value, ...]
3379
3380Compiled and executes the given perl code snippet. additional var/value
3381pairs result in temporary local (my) scalar variables of the given name
3382that are available in the code snippet. Example:
3383
3384 my $five = safe_eval '$first + $second', first => 1, second => 4;
3385
3386=cut
490 3387
491sub safe_eval($;@) { 3388sub safe_eval($;@) {
492 my ($code, %vars) = @_; 3389 my ($code, %vars) = @_;
493 3390
494 my $qcode = $code; 3391 my $qcode = $code;
495 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3392 $qcode =~ s/"/‟/g; # not allowed in #line filenames
496 $qcode =~ s/\n/\\n/g; 3393 $qcode =~ s/\n/\\n/g;
497 3394
3395 %vars = (_dummy => 0) unless %vars;
3396
3397 my @res;
498 local $_; 3398 local $_;
499 local @ext::cf::_safe_eval_args = values %vars;
500 3399
501 $code = 3400 my $eval =
502 "do {\n" 3401 "do {\n"
503 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3402 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
504 . "#line 0 \"{$qcode}\"\n" 3403 . "#line 0 \"{$qcode}\"\n"
505 . $code 3404 . $code
506 . "\n}" 3405 . "\n}"
507 ; 3406 ;
508 3407
3408 if ($CFG{safe_eval}) {
509 sub_generation_inc; 3409 sub_generation_inc;
3410 local @safe::cf::_safe_eval_args = values %vars;
510 my @res = wantarray ? $safe->reval ($code) : scalar $safe->reval ($code); 3411 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
511 sub_generation_inc; 3412 sub_generation_inc;
3413 } else {
3414 local @cf::_safe_eval_args = values %vars;
3415 @res = wantarray ? eval eval : scalar eval $eval;
3416 }
3417
3418 if ($@) {
3419 warn "$@",
3420 "while executing safe code '$code'\n",
3421 "with arguments " . (join " ", %vars) . "\n";
3422 }
512 3423
513 wantarray ? @res : $res[0] 3424 wantarray ? @res : $res[0]
514} 3425}
3426
3427=item cf::register_script_function $function => $cb
3428
3429Register a function that can be called from within map/npc scripts. The
3430function should be reasonably secure and should be put into a package name
3431like the extension.
3432
3433Example: register a function that gets called whenever a map script calls
3434C<rent::overview>, as used by the C<rent> extension.
3435
3436 cf::register_script_function "rent::overview" => sub {
3437 ...
3438 };
3439
3440=cut
515 3441
516sub register_script_function { 3442sub register_script_function {
517 my ($fun, $cb) = @_; 3443 my ($fun, $cb) = @_;
518 3444
519 no strict 'refs'; 3445 $fun = "safe::$fun" if $CFG{safe_eval};
520 *{"ext::$fun"} = $safe_hole->wrap ($cb); 3446 *$fun = $safe_hole->wrap ($cb);
521} 3447}
3448
3449=back
3450
3451=cut
522 3452
523############################################################################# 3453#############################################################################
524# the server's main() 3454# the server's init and main functions
525 3455
526sub run { 3456sub load_facedata($) {
527 Event::loop; 3457 my ($path) = @_;
3458
3459 # HACK to clear player env face cache, we need some signal framework
3460 # for this (global event?)
3461 %ext::player_env::MUSIC_FACE_CACHE = ();
3462
3463 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3464
3465 trace "loading facedata from $path\n";
3466
3467 my $facedata = decode_storable load_file $path;
3468
3469 $facedata->{version} == 2
3470 or cf::cleanup "$path: version mismatch, cannot proceed.";
3471
3472 # patch in the exptable
3473 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3474 $facedata->{resource}{"res/exp_table"} = {
3475 type => FT_RSRC,
3476 data => $exp_table,
3477 hash => (Digest::MD5::md5 $exp_table),
3478 };
3479 cf::cede_to_tick;
3480
3481 {
3482 my $faces = $facedata->{faceinfo};
3483
3484 while (my ($face, $info) = each %$faces) {
3485 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3486
3487 cf::face::set_visibility $idx, $info->{visibility};
3488 cf::face::set_magicmap $idx, $info->{magicmap};
3489 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3490 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3491 cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph} ;
3492
3493 cf::cede_to_tick;
3494 }
3495
3496 while (my ($face, $info) = each %$faces) {
3497 next unless $info->{smooth};
3498
3499 my $idx = cf::face::find $face
3500 or next;
3501
3502 if (my $smooth = cf::face::find $info->{smooth}) {
3503 cf::face::set_smooth $idx, $smooth;
3504 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3505 } else {
3506 error "smooth face '$info->{smooth}' not found for face '$face'";
3507 }
3508
3509 cf::cede_to_tick;
3510 }
3511 }
3512
3513 {
3514 my $anims = $facedata->{animinfo};
3515
3516 while (my ($anim, $info) = each %$anims) {
3517 cf::anim::set $anim, $info->{frames}, $info->{facings};
3518 cf::cede_to_tick;
3519 }
3520
3521 cf::anim::invalidate_all; # d'oh
3522 }
3523
3524 {
3525 my $res = $facedata->{resource};
3526
3527 while (my ($name, $info) = each %$res) {
3528 if (defined $info->{type}) {
3529 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3530
3531 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3532 cf::face::set_type $idx, $info->{type};
3533 } else {
3534 $RESOURCE{$name} = $info; # unused
3535 }
3536
3537 cf::cede_to_tick;
3538 }
3539 }
3540
3541 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3542
3543 1
3544}
3545
3546register_exticmd fx_want => sub {
3547 my ($ns, $want) = @_;
3548
3549 while (my ($k, $v) = each %$want) {
3550 $ns->fx_want ($k, $v);
3551 }
3552};
3553
3554sub load_resource_file($) {
3555 my $guard = lock_acquire "load_resource_file";
3556
3557 my $status = load_resource_file_ $_[0];
3558 get_slot 0.1, 100;
3559 cf::arch::commit_load;
3560
3561 $status
3562}
3563
3564sub reload_regions {
3565 # HACK to clear player env face cache, we need some signal framework
3566 # for this (global event?)
3567 %ext::player_env::MUSIC_FACE_CACHE = ();
3568
3569 load_resource_file "$MAPDIR/regions"
3570 or die "unable to load regions file\n";
3571
3572 for (cf::region::list) {
3573 $_->{match} = qr/$_->{match}/
3574 if exists $_->{match};
3575 }
3576}
3577
3578sub reload_facedata {
3579 load_facedata "$DATADIR/facedata"
3580 or die "unable to load facedata\n";
3581}
3582
3583sub reload_archetypes {
3584 load_resource_file "$DATADIR/archetypes"
3585 or die "unable to load archetypes\n";
3586}
3587
3588sub reload_treasures {
3589 load_resource_file "$DATADIR/treasures"
3590 or die "unable to load treasurelists\n";
3591}
3592
3593sub reload_sound {
3594 trace "loading sound config from $DATADIR/sound\n";
3595
3596 my $soundconf = JSON::XS->new->utf8->relaxed->decode (load_file "$DATADIR/sound");
3597
3598 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3599 my $sound = $soundconf->{compat}[$_]
3600 or next;
3601
3602 my $face = cf::face::find "sound/$sound->[1]";
3603 cf::sound::set $sound->[0] => $face;
3604 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3605 }
3606
3607 while (my ($k, $v) = each %{$soundconf->{event}}) {
3608 my $face = cf::face::find "sound/$v";
3609 cf::sound::set $k => $face;
3610 }
3611}
3612
3613sub reload_resources {
3614 trace "reloading resource files...\n";
3615
3616 reload_exp_table;
3617 reload_materials;
3618 reload_facedata;
3619 reload_sound;
3620 reload_archetypes;
3621 reload_regions;
3622 reload_treasures;
3623
3624 trace "finished reloading resource files\n";
3625}
3626
3627sub reload_config {
3628 trace "reloading config file...\n";
3629
3630 my $config = load_file "$CONFDIR/config";
3631 utf8::decode $config;
3632 *CFG = decode_yaml $config;
3633
3634 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3635
3636 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3637 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3638
3639 if (exists $CFG{mlockall}) {
3640 eval {
3641 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3642 and die "WARNING: m(un)lockall failed: $!\n";
3643 };
3644 warn $@ if $@;
3645 }
3646}
3647
3648sub pidfile() {
3649 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3650 or die "$PIDFILE: $!";
3651 flock $fh, &Fcntl::LOCK_EX
3652 or die "$PIDFILE: flock: $!";
3653 $fh
3654}
3655
3656# make sure only one server instance is running at any one time
3657sub atomic {
3658 my $fh = pidfile;
3659
3660 my $pid = <$fh>;
3661 kill 9, $pid if $pid > 0;
3662
3663 seek $fh, 0, 0;
3664 print $fh $$;
3665}
3666
3667sub main_loop {
3668 trace "EV::loop starting\n";
3669 if (1) {
3670 EV::loop;
3671 }
3672 trace "EV::loop returned\n";
3673 goto &main_loop unless $REALLY_UNLOOP;
3674}
3675
3676sub main {
3677 cf::init_globals; # initialise logging
3678
3679 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3680 LOG llevInfo, "Copyright (C) 2005-2011 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3681 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3682 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3683
3684 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3685
3686 # we must not ever block the main coroutine
3687 local $Coro::idle = sub {
3688 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3689 (async {
3690 $Coro::current->{desc} = "IDLE BUG HANDLER";
3691 EV::loop EV::LOOP_ONESHOT;
3692 })->prio (Coro::PRIO_MAX);
3693 };
3694
3695 evthread_start IO::AIO::poll_fileno;
3696
3697 cf::sync_job {
3698 cf::incloader::init ();
3699
3700 cf::init_anim;
3701 cf::init_attackmess;
3702 cf::init_dynamic;
3703
3704 cf::load_settings;
3705
3706 reload_resources;
3707 reload_config;
3708 db_init;
3709
3710 cf::init_uuid;
3711 cf::init_signals;
3712 cf::init_skills;
3713
3714 cf::init_beforeplay;
3715
3716 atomic;
3717
3718 load_extensions;
3719
3720 utime time, time, $RUNTIMEFILE;
3721
3722 # no (long-running) fork's whatsoever before this point(!)
3723 use POSIX ();
3724 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3725
3726 cf::_post_init 0;
3727 };
3728
3729 cf::object::thawer::errors_are_fatal 0;
3730 info "parse errors in files are no longer fatal from this point on.\n";
3731
3732 my $free_main; $free_main = EV::idle sub {
3733 undef $free_main;
3734 undef &main; # free gobs of memory :)
3735 };
3736
3737 goto &main_loop;
528} 3738}
529 3739
530############################################################################# 3740#############################################################################
531# initialisation 3741# initialisation and cleanup
532 3742
533register "<global>", __PACKAGE__; 3743# install some emergency cleanup handlers
3744BEGIN {
3745 our %SIGWATCHER = ();
3746 for my $signal (qw(INT HUP TERM)) {
3747 $SIGWATCHER{$signal} = AE::signal $signal, sub {
3748 cf::cleanup "SIG$signal";
3749 };
3750 }
3751}
534 3752
535unshift @INC, $LIBDIR; 3753sub write_runtime_sync {
3754 my $t0 = AE::time;
536 3755
537load_extensions; 3756 # first touch the runtime file to show we are still running:
3757 # the fsync below can take a very very long time.
538 3758
539$TICK_WATCHER = Event->timer ( 3759 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
540 prio => 1, 3760
541 at => $NEXT_TICK || 1, 3761 my $guard = cf::lock_acquire "write_runtime";
542 cb => sub { 3762
3763 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3764 or return;
3765
3766 my $value = $cf::RUNTIME + 90 + 10;
3767 # 10 is the runtime save interval, for a monotonic clock
3768 # 60 allows for the watchdog to kill the server.
3769
3770 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3771 and return;
3772
3773 # always fsync - this file is important
3774 aio_fsync $fh
3775 and return;
3776
3777 # touch it again to show we are up-to-date
3778 aio_utime $fh, undef, undef;
3779
3780 close $fh
3781 or return;
3782
3783 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3784 and return;
3785
3786 trace sprintf "runtime file written (%gs).\n", AE::time - $t0;
3787
3788 1
3789}
3790
3791our $uuid_lock;
3792our $uuid_skip;
3793
3794sub write_uuid_sync($) {
3795 $uuid_skip ||= $_[0];
3796
3797 return if $uuid_lock;
3798 local $uuid_lock = 1;
3799
3800 my $uuid = "$LOCALDIR/uuid";
3801
3802 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3803 or return;
3804
3805 my $value = uuid_seq uuid_cur;
3806
3807 unless ($value) {
3808 info "cowardly refusing to write zero uuid value!\n";
3809 return;
3810 }
3811
3812 my $value = uuid_str $value + $uuid_skip;
3813 $uuid_skip = 0;
3814
3815 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3816 and return;
3817
3818 # always fsync - this file is important
3819 aio_fsync $fh
3820 and return;
3821
3822 close $fh
3823 or return;
3824
3825 aio_rename "$uuid~", $uuid
3826 and return;
3827
3828 trace "uuid file written ($value).\n";
3829
3830 1
3831
3832}
3833
3834sub write_uuid($$) {
3835 my ($skip, $sync) = @_;
3836
3837 $sync ? write_uuid_sync $skip
3838 : async { write_uuid_sync $skip };
3839}
3840
3841sub emergency_save() {
3842 my $freeze_guard = cf::freeze_mainloop;
3843
3844 info "emergency_perl_save: enter\n";
3845
3846 # this is a trade-off: we want to be very quick here, so
3847 # save all maps without fsync, and later call a global sync
3848 # (which in turn might be very very slow)
3849 local $USE_FSYNC = 0;
3850
3851 cf::sync_job {
3852 cf::write_runtime_sync; # external watchdog should not bark
3853
3854 # use a peculiar iteration method to avoid tripping on perl
3855 # refcount bugs in for. also avoids problems with players
3856 # and maps saved/destroyed asynchronously.
3857 info "emergency_perl_save: begin player save\n";
3858 for my $login (keys %cf::PLAYER) {
3859 my $pl = $cf::PLAYER{$login} or next;
3860 $pl->valid or next;
3861 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3862 $pl->save;
3863 }
3864 info "emergency_perl_save: end player save\n";
3865
3866 cf::write_runtime_sync; # external watchdog should not bark
3867
3868 info "emergency_perl_save: begin map save\n";
3869 for my $path (keys %cf::MAP) {
3870 my $map = $cf::MAP{$path} or next;
3871 $map->valid or next;
3872 $map->save;
3873 }
3874 info "emergency_perl_save: end map save\n";
3875
3876 cf::write_runtime_sync; # external watchdog should not bark
3877
3878 info "emergency_perl_save: begin database checkpoint\n";
3879 BDB::db_env_txn_checkpoint $DB_ENV;
3880 info "emergency_perl_save: end database checkpoint\n";
3881
3882 info "emergency_perl_save: begin write uuid\n";
3883 write_uuid_sync 1;
3884 info "emergency_perl_save: end write uuid\n";
3885
3886 cf::write_runtime_sync; # external watchdog should not bark
3887
3888 trace "emergency_perl_save: syncing database to disk";
3889 BDB::db_env_txn_checkpoint $DB_ENV;
3890
3891 info "emergency_perl_save: starting sync\n";
3892 IO::AIO::aio_sync sub {
3893 info "emergency_perl_save: finished sync\n";
3894 };
3895
3896 cf::write_runtime_sync; # external watchdog should not bark
3897
3898 trace "emergency_perl_save: flushing outstanding aio requests";
3899 while (IO::AIO::nreqs || BDB::nreqs) {
3900 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3901 }
3902
3903 cf::write_runtime_sync; # external watchdog should not bark
3904 };
3905
3906 info "emergency_perl_save: leave\n";
3907}
3908
3909sub post_cleanup {
3910 my ($make_core) = @_;
3911
3912 IO::AIO::flush;
3913
3914 error Carp::longmess "post_cleanup backtrace"
3915 if $make_core;
3916
3917 my $fh = pidfile;
3918 unlink $PIDFILE if <$fh> == $$;
3919}
3920
3921# a safer delete_package, copied from Symbol
3922sub clear_package($) {
3923 my $pkg = shift;
3924
3925 # expand to full symbol table name if needed
3926 unless ($pkg =~ /^main::.*::$/) {
3927 $pkg = "main$pkg" if $pkg =~ /^::/;
3928 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3929 $pkg .= '::' unless $pkg =~ /::$/;
3930 }
3931
3932 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3933 my $stem_symtab = *{$stem}{HASH};
3934
3935 defined $stem_symtab and exists $stem_symtab->{$leaf}
3936 or return;
3937
3938 # clear all symbols
3939 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3940 for my $name (keys %$leaf_symtab) {
3941 _gv_clear *{"$pkg$name"};
3942# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3943 }
3944}
3945
3946sub do_reload_perl() {
3947 # can/must only be called in main
3948 unless (in_main) {
3949 error "can only reload from main coroutine";
3950 return;
3951 }
3952
3953 return if $RELOAD++;
3954
3955 my $t1 = AE::time;
3956
3957 while ($RELOAD) {
3958 cf::get_slot 0.1, -1, "reload_perl";
3959 info "perl_reload: reloading...";
3960
3961 trace "perl_reload: entering sync_job";
3962
3963 cf::sync_job {
3964 #cf::emergency_save;
3965
3966 trace "perl_reload: cancelling all extension coros";
3967 $_->cancel for values %EXT_CORO;
3968 %EXT_CORO = ();
3969
3970 trace "perl_reload: removing commands";
3971 %COMMAND = ();
3972
3973 trace "perl_reload: removing ext/exti commands";
3974 %EXTCMD = ();
3975 %EXTICMD = ();
3976
3977 trace "perl_reload: unloading/nuking all extensions";
3978 for my $pkg (@EXTS) {
3979 trace "... unloading $pkg";
3980
3981 if (my $cb = $pkg->can ("unload")) {
3982 eval {
3983 $cb->($pkg);
3984 1
3985 } or error "$pkg unloaded, but with errors: $@";
3986 }
3987
3988 trace "... clearing $pkg";
3989 clear_package $pkg;
3990 }
3991
3992 trace "perl_reload: unloading all perl modules loaded from $LIBDIR";
3993 while (my ($k, $v) = each %INC) {
3994 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3995
3996 trace "... unloading $k";
3997 delete $INC{$k};
3998
3999 $k =~ s/\.pm$//;
4000 $k =~ s/\//::/g;
4001
4002 if (my $cb = $k->can ("unload_module")) {
4003 $cb->();
4004 }
4005
4006 clear_package $k;
4007 }
4008
4009 trace "perl_reload: getting rid of safe::, as good as possible";
4010 clear_package "safe::$_"
4011 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
4012
4013 trace "perl_reload: unloading cf.pm \"a bit\"";
4014 delete $INC{"cf.pm"};
4015 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
4016
4017 # don't, removes xs symbols, too,
4018 # and global variables created in xs
4019 #clear_package __PACKAGE__;
4020
4021 info "perl_reload: unload completed, starting to reload now";
4022
4023 trace "perl_reload: reloading cf.pm";
4024 require cf;
4025 cf::_connect_to_perl_1;
4026
4027 trace "perl_reload: loading config and database again";
4028 cf::reload_config;
4029
4030 trace "perl_reload: loading extensions";
4031 cf::load_extensions;
4032
4033 if ($REATTACH_ON_RELOAD) {
4034 trace "perl_reload: reattaching attachments to objects/players";
4035 _global_reattach; # objects, sockets
4036 trace "perl_reload: reattaching attachments to maps";
4037 reattach $_ for values %MAP;
4038 trace "perl_reload: reattaching attachments to players";
4039 reattach $_ for values %PLAYER;
4040 }
4041
4042 cf::_post_init 1;
4043
4044 trace "perl_reload: leaving sync_job";
4045
4046 1
4047 } or do {
4048 error $@;
4049 cf::cleanup "perl_reload: error, exiting.";
4050 };
4051
4052 --$RELOAD;
4053 }
4054
4055 $t1 = AE::time - $t1;
4056 info "perl_reload: completed in ${t1}s\n";
4057};
4058
4059our $RELOAD_WATCHER; # used only during reload
4060
4061sub reload_perl() {
4062 # doing reload synchronously and two reloads happen back-to-back,
4063 # coro crashes during coro_state_free->destroy here.
4064
4065 $RELOAD_WATCHER ||= cf::async {
4066 Coro::AIO::aio_wait cache_extensions;
4067
4068 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
4069 do_reload_perl;
4070 undef $RELOAD_WATCHER;
4071 };
4072 };
4073}
4074
4075register_command "reload" => sub {
4076 my ($who, $arg) = @_;
4077
4078 if ($who->flag (FLAG_WIZ)) {
4079 $who->message ("reloading server.");
4080 async {
4081 $Coro::current->{desc} = "perl_reload";
4082 reload_perl;
4083 };
4084 }
4085};
4086
4087#############################################################################
4088
4089my $bug_warning = 0;
4090
4091our @WAIT_FOR_TICK;
4092our @WAIT_FOR_TICK_BEGIN;
4093
4094sub wait_for_tick() {
4095 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
4096
4097 my $signal = new Coro::Signal;
4098 push @WAIT_FOR_TICK, $signal;
4099 $signal->wait;
4100}
4101
4102sub wait_for_tick_begin() {
4103 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
4104
4105 my $signal = new Coro::Signal;
4106 push @WAIT_FOR_TICK_BEGIN, $signal;
4107 $signal->wait;
4108}
4109
4110sub tick {
4111 if ($Coro::current != $Coro::main) {
4112 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
4113 unless ++$bug_warning > 10;
4114 return;
4115 }
4116
543 cf::server_tick; # one server iteration 4117 cf::server_tick; # one server iteration
544 4118
545 my $NOW = Event::time; 4119 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
546 $NEXT_TICK += $TICK;
547 4120
548 # if we are delayed by > 0.25 second, skip ticks 4121 if ($NOW >= $NEXT_RUNTIME_WRITE) {
549 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + .25; 4122 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
550 4123 Coro::async_pool {
551 $TICK_WATCHER->at ($NEXT_TICK); 4124 $Coro::current->{desc} = "runtime saver";
552 $TICK_WATCHER->start; 4125 write_runtime_sync
4126 or error "ERROR: unable to write runtime file: $!";
4127 };
553 }, 4128 }
554); 4129
4130 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
4131 $sig->send;
4132 }
4133 while (my $sig = shift @WAIT_FOR_TICK) {
4134 $sig->send;
4135 }
4136
4137 $LOAD = ($NOW - $TICK_START) / $TICK;
4138 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
4139
4140 if (0) {
4141 if ($NEXT_TICK) {
4142 my $jitter = $TICK_START - $NEXT_TICK;
4143 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
4144 debug "jitter $JITTER\n";#d#
4145 }
4146 }
4147}
4148
4149{
4150 # configure BDB
4151
4152 BDB::min_parallel 16;
4153 BDB::max_poll_reqs $TICK * 0.1;
4154 $AnyEvent::BDB::WATCHER->priority (1);
4155
4156 unless ($DB_ENV) {
4157 $DB_ENV = BDB::db_env_create;
4158 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
4159 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
4160 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
4161 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
4162 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
4163
4164 cf::sync_job {
4165 eval {
4166 BDB::db_env_open
4167 $DB_ENV,
4168 $BDBDIR,
4169 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
4170 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
4171 0666;
4172
4173 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
4174 };
4175
4176 cf::cleanup "db_env_open(db): $@" if $@;
4177 };
4178 }
4179
4180 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
4181 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
4182 };
4183 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
4184 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
4185 };
4186 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
4187 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
4188 };
4189}
4190
4191{
4192 # configure IO::AIO
4193
4194 IO::AIO::min_parallel 8;
4195 IO::AIO::max_poll_time $TICK * 0.1;
4196 undef $AnyEvent::AIO::WATCHER;
4197}
4198
4199our $_log_backtrace;
4200our $_log_backtrace_last;
4201
4202sub _log_backtrace {
4203 my ($msg, @addr) = @_;
4204
4205 $msg =~ s/\n$//;
4206
4207 if ($_log_backtrace_last eq $msg) {
4208 LOG llevInfo, "[ABT] $msg\n";
4209 LOG llevInfo, "[ABT] [duplicate, suppressed]\n";
4210 # limit the # of concurrent backtraces
4211 } elsif ($_log_backtrace < 2) {
4212 $_log_backtrace_last = $msg;
4213 ++$_log_backtrace;
4214 my $perl_bt = Carp::longmess $msg;
4215 async {
4216 $Coro::current->{desc} = "abt $msg";
4217
4218 my @bt = fork_call {
4219 @addr = map { sprintf "%x", $_ } @addr;
4220 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
4221 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
4222 or die "addr2line: $!";
4223
4224 my @funcs;
4225 my @res = <$fh>;
4226 chomp for @res;
4227 while (@res) {
4228 my ($func, $line) = splice @res, 0, 2, ();
4229 push @funcs, "[$func] $line";
4230 }
4231
4232 @funcs
4233 };
4234
4235 LOG llevInfo, "[ABT] $perl_bt\n";
4236 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
4237 LOG llevInfo, "[ABT] $_\n" for @bt;
4238 --$_log_backtrace;
4239 };
4240 } else {
4241 LOG llevInfo, "[ABT] $msg\n";
4242 LOG llevInfo, "[ABT] [overload, suppressed]\n";
4243 }
4244}
4245
4246# load additional modules
4247require "cf/$_.pm" for @EXTRA_MODULES;
4248cf::_connect_to_perl_2;
4249
4250END { cf::emergency_save }
555 4251
5561 42521
557 4253

Diff Legend

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