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.39 by root, Fri Aug 25 13:24:50 2006 UTC vs.
Revision 1.580 by root, Wed Jan 4 03:22:48 2012 UTC

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

Diff Legend

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