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.575 by root, Sat Aug 13 20:20:30 2011 UTC

1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3#
4# Copyright (©) 2006,2007,2008,2009,2010,2011 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5#
6# Deliantra is free software: you can redistribute it and/or modify it under
7# the terms of the Affero GNU General Public License as published by the
8# Free Software Foundation, either version 3 of the License, or (at your
9# option) any later version.
10#
11# This program is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14# GNU General Public License for more details.
15#
16# You should have received a copy of the Affero GNU General Public License
17# and the GNU General Public License along with this program. If not, see
18# <http://www.gnu.org/licenses/>.
19#
20# The authors can be reached via e-mail to <support@deliantra.net>
21#
22
1package cf; 23package cf;
24
25use common::sense;
2 26
3use Symbol; 27use Symbol;
4use List::Util; 28use List::Util;
5use Storable; 29use Socket;
30use EV;
6use Opcode; 31use Opcode;
7use Safe; 32use Safe;
8use Safe::Hole; 33use Safe::Hole;
34use Storable ();
35use Carp ();
9 36
37use Guard ();
38use Coro ();
39use Coro::State;
40use Coro::Handle;
41use Coro::EV;
42use Coro::AnyEvent;
43use Coro::Timer;
44use Coro::Signal;
45use Coro::Semaphore;
46use Coro::SemaphoreSet;
47use Coro::AnyEvent;
48use Coro::AIO;
49use Coro::BDB 1.6;
50use Coro::Storable;
51use Coro::Util ();
52
53use JSON::XS 2.01 ();
54use BDB ();
55use Data::Dumper;
56use Fcntl;
57use YAML::XS ();
58use IO::AIO ();
10use Time::HiRes; 59use Time::HiRes;
11use Event; 60use Compress::LZF;
12$Event::Eval = 1; # no idea why this is required, but it is 61use Digest::MD5 ();
13 62
14use strict; 63AnyEvent::detect;
15 64
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
113our %RESOURCE; # unused
114
115our $OUTPUT_RATE_MIN = 3000;
116our $OUTPUT_RATE_MAX = 1000000;
117
118our $MAX_LINKS = 32; # how many chained exits to follow
119our $VERBOSE_IO = 1;
120
121our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
122our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
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) =
311 my $pkg = $1; 1467 "ARRAY" eq ref $msg
312 $pkg =~ s/[^[:word:]]/_/g; 1468 ? @$msg
313 $pkg = "cf::ext::$pkg"; 1469 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
314 1470
315 warn "loading '$path' into '$pkg'\n"; 1471 my @reply;
316 1472
317 open my $fh, "<:utf8", $path 1473 if (my $cb = $EXTCMD{$type}) {
318 or die "$path: $!"; 1474 @reply = $cb->($pl, @payload);
1475 }
319 1476
320 my $source = 1477 $pl->ext_reply ($reply, @reply)
321 "package $pkg; use strict; use utf8;\n" 1478 if $reply;
322 . "#line 1 \"$path\"\n{\n"
323 . (do { local $/; <$fh> })
324 . "\n};\n1";
325 1479
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 { 1480 } else {
356 delete $command{$name}; 1481 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
357 delete $COMMAND{"$name\000"};
358 } 1482 }
1483
1484 cf::override;
359 } 1485 },
1486);
360 1487
361 # remove extcmds 1488# "readahead" all extensions
362 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 1489sub cache_extensions {
363 delete $extcmd{$name}; 1490 my $grp = IO::AIO::aio_group;
1491
1492 add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
1493 for (grep /\.ext$/, @{$_[0]}) {
1494 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
1495 }
364 } 1496 };
365 1497
366 if (my $cb = $pkg->can ("on_unload")) { 1498 $grp
367 eval {
368 $cb->($pkg);
369 1
370 } or warn "$pkg unloaded, but with errors: $@";
371 }
372
373 Symbol::delete_package $pkg;
374} 1499}
375 1500
376sub load_extensions { 1501sub load_extensions {
377 my $LIBDIR = maps_directory "perl"; 1502 info "loading extensions...";
378 1503
1504 cf::sync_job {
1505 my %todo;
1506
379 for my $ext (<$LIBDIR/*.ext>) { 1507 for my $path (<$LIBDIR/*.ext>) {
380 next unless -r $ext; 1508 next unless -r $path;
381 eval { 1509
382 load_extension $ext; 1510 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1511 my $base = $1;
1512 my $pkg = $1;
1513 $pkg =~ s/[^[:word:]]/_/g;
1514 $pkg = "ext::$pkg";
1515
1516 open my $fh, "<:utf8", $path
1517 or die "$path: $!";
1518
1519 my $source = do { local $/; <$fh> };
1520
1521 my %ext = (
1522 path => $path,
1523 base => $base,
1524 pkg => $pkg,
383 1 1525 );
384 } or warn "$ext not loaded: $@";
385 }
386}
387 1526
388sub _perl_reload(&) { 1527 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
389 my ($msg) = @_; 1528 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
390 1529
391 $msg->("reloading..."); 1530 $ext{source} =
1531 "package $pkg; use common::sense;\n"
1532 . "#line 1 \"$path\"\n{\n"
1533 . $source
1534 . "\n};\n1";
392 1535
393 eval { 1536 $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 } 1537 }
402 1538
403 # 3. unload all modules loaded from $LIBDIR 1539 my $pass = 0;
1540 my %done;
1541 while (%todo) {
1542 my $progress;
1543
1544 ++$pass;
1545
1546 ext:
404 while (my ($k, $v) = each %INC) { 1547 while (my ($k, $v) = each %todo) {
405 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 1548 for (split /,\s*/, $v->{meta}{depends}) {
1549 next ext
1550 unless exists $done{$_};
1551 }
406 1552
407 $msg->("removing <$k>"); 1553 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1554
1555 my $active = eval $v->{source};
1556
1557 if (length $@) {
1558 error "$v->{path}: $@\n";
1559
1560 cf::cleanup "mandatory extension '$k' failed to load, exiting."
1561 if exists $v->{meta}{mandatory};
1562
1563 warn "$v->{base}: optional extension cannot be loaded, skipping.\n";
408 delete $INC{$k}; 1564 delete $todo{$k};
1565 } else {
1566 $done{$k} = delete $todo{$k};
1567 push @EXTS, $v->{pkg};
1568 $progress = 1;
409 1569
410 $k =~ s/\.pm$//; 1570 info "$v->{base}: extension inactive.\n"
411 $k =~ s/\//::/g; 1571 unless $active;
412 1572 }
413 if (my $cb = $k->can ("unload_module")) {
414 $cb->();
415 } 1573 }
416 1574
417 Symbol::delete_package $k; 1575 unless ($progress) {
1576 warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
1577
1578 while (my ($k, $v) = each %todo) {
1579 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
1580 if exists $v->{meta}{mandatory};
1581 }
1582
1583 last;
418 } 1584 }
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 1585 }
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 }; 1586 };
437 $msg->($@) if $@;
438
439 $msg->("reloaded");
440};
441
442sub perl_reload() {
443 _perl_reload {
444 warn $_[0];
445 print "$_[0]\n";
446 };
447} 1587}
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 1588
460############################################################################# 1589#############################################################################
461# utility functions
462 1590
463use JSON::Syck (); # TODO# replace by JSON::PC once working 1591=back
464 1592
465sub from_json($) { 1593=head2 CORE EXTENSIONS
466 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
467 JSON::Syck::Load $_[0]
468}
469 1594
470sub to_json($) { 1595Functions and methods that extend core deliantra objects.
471 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
472 JSON::Syck::Dump $_[0]
473}
474 1596
475############################################################################# 1597=cut
476# extcmd framework, basically convert ext <msg>
477# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
478 1598
479sub on_extcmd { 1599package cf::player;
480 my ($pl, $buf) = @_;
481 1600
482 my $msg = eval { from_json $buf }; 1601use Coro::AIO;
483 1602
484 if (ref $msg) { 1603=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 1604
494 1 1605=over 4
495}
496 1606
497############################################################################# 1607=item cf::player::num_playing
498# load/save/clean perl data associated with a map
499 1608
500*cf::mapsupport::on_clean = sub { 1609Returns the official number of playing players, as per the Crossfire metaserver rules.
1610
1611=cut
1612
1613sub num_playing {
1614 scalar grep
1615 $_->ob->map
1616 && !$_->hidden
1617 && !$_->ob->flag (cf::FLAG_WIZ),
1618 cf::player::list
1619}
1620
1621=item cf::player::find $login
1622
1623Returns the given player object, loading it if necessary (might block).
1624
1625=cut
1626
1627sub playerdir($) {
1628 "$PLAYERDIR/"
1629 . (ref $_[0] ? $_[0]->ob->name : $_[0])
1630}
1631
1632sub path($) {
1633 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
1634
1635 (playerdir $login) . "/playerdata"
1636}
1637
1638sub find_active($) {
1639 $cf::PLAYER{$_[0]}
1640 and $cf::PLAYER{$_[0]}->active
1641 and $cf::PLAYER{$_[0]}
1642}
1643
1644sub exists($) {
501 my ($map) = @_; 1645 my ($login) = @_;
502 1646
503 my $path = $map->tmpname; 1647 $cf::PLAYER{$login}
504 defined $path or return; 1648 or !aio_stat path $login
1649}
505 1650
506 unlink "$path.cfperl"; 1651sub find($) {
507}; 1652 return $cf::PLAYER{$_[0]} || do {
1653 my $login = $_[0];
508 1654
509*cf::mapsupport::on_swapin = 1655 my $guard = cf::lock_acquire "user_find:$login";
510*cf::mapsupport::on_load = sub {
511 my ($map) = @_;
512 1656
513 my $path = $map->tmpname; 1657 $cf::PLAYER{$_[0]} || do {
514 $path = $map->path unless defined $path; 1658 # rename old playerfiles to new ones
1659 #TODO: remove when no longer required
1660 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1661 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1662 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1663 aio_unlink +(playerdir $login) . "/$login.pl";
515 1664
516 open my $fh, "<:raw", "$path.cfperl" 1665 my $f = new_from_file cf::object::thawer path $login
517 or return; # no perl data 1666 or return;
518 1667
519 my $data = Storable::thaw do { local $/; <$fh> }; 1668 my $pl = cf::player::load_pl $f
1669 or return;
520 1670
521 $data->{version} <= 1 1671 local $cf::PLAYER_LOADING{$login} = $pl;
522 or return; # too new 1672 $f->resolve_delayed_derefs;
523 1673 $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 }; 1674 }
547
548 chmod SAVE_MODE, "$path.cfperl"; # very racy, but cf-compatible *g*
549 } else {
550 unlink "$path.cfperl";
551 } 1675 }
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} 1676}
562 1677
563attach_to_players 1678cf::player->attach (
564 on_load => sub { 1679 on_load => sub {
565 my ($pl, $path) = @_; 1680 my ($pl, $path) = @_;
566 1681
567 for my $o (all_objects $pl->ob) { 1682 # restore slots saved in save, below
568 if (my $value = $o->get_ob_key_value ("_perl_data")) { 1683 my $slots = delete $pl->{_slots};
569 $o->set_ob_key_value ("_perl_data");
570 1684
571 %$o = %{ Storable::thaw pack "H*", $value }; 1685 $pl->ob->current_weapon ($slots->[0]);
1686 $pl->combat_ob ($slots->[1]);
1687 $pl->ranged_ob ($slots->[2]);
1688 },
1689);
1690
1691sub save($) {
1692 my ($pl) = @_;
1693
1694 return if $pl->{deny_save};
1695
1696 my $path = path $pl;
1697 my $guard = cf::lock_acquire "user_save:$path";
1698
1699 return if $pl->{deny_save};
1700
1701 aio_mkdir playerdir $pl, 0770;
1702 $pl->{last_save} = $cf::RUNTIME;
1703
1704 cf::get_slot 0.01;
1705
1706 # save slots, to be restored later
1707 local $pl->{_slots} = [$pl->ob->current_weapon, $pl->combat_ob, $pl->ranged_ob];
1708
1709 $pl->save_pl ($path);
1710 cf::cede_to_tick;
1711}
1712
1713sub new($) {
1714 my ($login) = @_;
1715
1716 my $self = create;
1717
1718 $self->ob->name ($login);
1719 $self->{deny_save} = 1;
1720
1721 $cf::PLAYER{$login} = $self;
1722
1723 $self
1724}
1725
1726=item $player->send_msg ($channel, $msg, $color, [extra...])
1727
1728=cut
1729
1730sub send_msg {
1731 my $ns = shift->ns
1732 or return;
1733 $ns->send_msg (@_);
1734}
1735
1736=item $pl->quit_character
1737
1738Nukes the player without looking back. If logged in, the connection will
1739be destroyed. May block for a long time.
1740
1741=cut
1742
1743sub quit_character {
1744 my ($pl) = @_;
1745
1746 my $name = $pl->ob->name;
1747
1748 $pl->{deny_save} = 1;
1749 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1750
1751 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->ns;
1752 $pl->deactivate;
1753
1754 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1755 $pl->invoke (cf::EVENT_PLAYER_QUIT) if $pl->ns;
1756 ext::highscore::check ($pl->ob);
1757
1758 $pl->ns->destroy if $pl->ns;
1759
1760 my $path = playerdir $pl;
1761 my $temp = "$path~$cf::RUNTIME~deleting~";
1762 aio_rename $path, $temp;
1763 delete $cf::PLAYER{$pl->ob->name};
1764 $pl->destroy;
1765
1766 my $prefix = qr<^~\Q$name\E/>;
1767
1768 # nuke player maps
1769 $cf::MAP{$_}->nuke for grep /$prefix/, keys %cf::MAP;
1770
1771 IO::AIO::aio_rmtree $temp;
1772}
1773
1774=item $pl->kick
1775
1776Kicks a player out of the game. This destroys the connection.
1777
1778=cut
1779
1780sub kick {
1781 my ($pl, $kicker) = @_;
1782
1783 $pl->invoke (cf::EVENT_PLAYER_KICK, $kicker);
1784 $pl->killer ("kicked");
1785 $pl->ns->destroy;
1786}
1787
1788=item cf::player::list_logins
1789
1790Returns am arrayref of all valid playernames in the system, can take a
1791while and may block, so not sync_job-capable, ever.
1792
1793=cut
1794
1795sub list_logins {
1796 my $dirs = aio_readdir $PLAYERDIR
1797 or return [];
1798
1799 my @logins;
1800
1801 for my $login (@$dirs) {
1802 my $path = path $login;
1803
1804 # a .pst is a dead give-away for a valid player
1805 # if no pst file found, open and chekc for blocked users
1806 if (aio_stat "$path.pst") {
1807 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1808 aio_read $fh, 0, 512, my $buf, 0 or next;
1809 $buf !~ /^password -------------$/m or next; # official not-valid tag
1810 }
1811
1812 utf8::decode $login;
1813 push @logins, $login;
1814 }
1815
1816 \@logins
1817}
1818
1819=item $player->maps
1820
1821=item cf::player::maps $login
1822
1823Returns an arrayref of map paths that are private for this
1824player. May block.
1825
1826=cut
1827
1828sub maps($) {
1829 my ($pl) = @_;
1830
1831 $pl = ref $pl ? $pl->ob->name : $pl;
1832
1833 my $files = aio_readdir playerdir $pl
1834 or return;
1835
1836 my @paths;
1837
1838 for (@$files) {
1839 utf8::decode $_;
1840 next if /\.(?:pl|pst)$/;
1841 next unless /^$PATH_SEP/o;
1842
1843 push @paths, cf::map::normalise "~$pl/$_";
1844 }
1845
1846 \@paths
1847}
1848
1849=item $protocol_xml = $player->expand_cfpod ($cfpod)
1850
1851Expand deliantra pod fragments into protocol xml.
1852
1853=item $player->ext_reply ($msgid, @msg)
1854
1855Sends an ext reply to the player.
1856
1857=cut
1858
1859sub ext_reply($$@) {
1860 my ($self, $id, @msg) = @_;
1861
1862 $self->ns->ext_reply ($id, @msg)
1863}
1864
1865=item $player->ext_msg ($type, @msg)
1866
1867Sends an ext event to the client.
1868
1869=cut
1870
1871sub ext_msg($$@) {
1872 my ($self, $type, @msg) = @_;
1873
1874 $self->ns->ext_msg ($type, @msg);
1875}
1876
1877=head3 cf::region
1878
1879=over 4
1880
1881=cut
1882
1883package cf::region;
1884
1885=item cf::region::find_by_path $path
1886
1887Tries to decuce the likely region for a map knowing only its path.
1888
1889=cut
1890
1891sub find_by_path($) {
1892 my ($path) = @_;
1893
1894 $path =~ s/^~[^\/]*//; # skip ~login
1895
1896 my ($match, $specificity);
1897
1898 for my $region (list) {
1899 if ($region->{match} && $path =~ $region->{match}) {
1900 ($match, $specificity) = ($region, $region->specificity)
1901 if $region->specificity > $specificity;
1902 }
1903 }
1904
1905 $match
1906}
1907
1908=back
1909
1910=head3 cf::map
1911
1912=over 4
1913
1914=cut
1915
1916package cf::map;
1917
1918use Fcntl;
1919use Coro::AIO;
1920
1921use overload
1922 '""' => \&as_string,
1923 fallback => 1;
1924
1925our $MAX_RESET = 3600;
1926our $DEFAULT_RESET = 3000;
1927
1928sub generate_random_map {
1929 my ($self, $rmp) = @_;
1930
1931 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1932
1933 $self->_create_random_map ($rmp);
1934}
1935
1936=item cf::map->register ($regex, $prio)
1937
1938Register a handler for the map path matching the given regex at the
1939givne priority (higher is better, built-in handlers have priority 0, the
1940default).
1941
1942=cut
1943
1944sub register {
1945 my (undef, $regex, $prio) = @_;
1946 my $pkg = caller;
1947
1948 push @{"$pkg\::ISA"}, __PACKAGE__;
1949
1950 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1951}
1952
1953# also paths starting with '/'
1954$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1955
1956sub thawer_merge {
1957 my ($self, $merge) = @_;
1958
1959 # we have to keep some variables in memory intact
1960 local $self->{path};
1961 local $self->{load_path};
1962
1963 $self->SUPER::thawer_merge ($merge);
1964}
1965
1966sub normalise {
1967 my ($path, $base) = @_;
1968
1969 $path = "$path"; # make sure it's a string
1970
1971 $path =~ s/\.map$//;
1972
1973 # map plan:
1974 #
1975 # /! non-realised random map exit (special hack!)
1976 # {... are special paths that are not being touched
1977 # ?xxx/... are special absolute paths
1978 # ?random/... random maps
1979 # /... normal maps
1980 # ~user/... per-player map of a specific user
1981
1982 $path =~ s/$PATH_SEP/\//go;
1983
1984 # treat it as relative path if it starts with
1985 # something that looks reasonable
1986 if ($path =~ m{^(?:\./|\.\./|\w)}) {
1987 $base or Carp::carp "normalise called with relative path and no base: '$path'";
1988
1989 $base =~ s{[^/]+/?$}{};
1990 $path = "$base/$path";
1991 }
1992
1993 for ($path) {
1994 redo if s{/\.?/}{/};
1995 redo if s{/[^/]+/\.\./}{/};
1996 }
1997
1998 $path
1999}
2000
2001sub new_from_path {
2002 my (undef, $path, $base) = @_;
2003
2004 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object
2005
2006 $path = normalise $path, $base;
2007
2008 for my $pkg (sort { $EXT_MAP{$b}[0] <=> $EXT_MAP{$a}[0] } keys %EXT_MAP) {
2009 if ($path =~ $EXT_MAP{$pkg}[1]) {
2010 my $self = bless cf::map::new, $pkg;
2011 $self->{path} = $path; $self->path ($path);
2012 $self->init; # pass $1 etc.
2013 return $self;
2014 }
2015 }
2016
2017 Carp::cluck "unable to resolve path '$path' (base '$base')";
2018 ()
2019}
2020
2021# may re-bless or do other evil things
2022sub init {
2023 my ($self) = @_;
2024
2025 $self
2026}
2027
2028sub as_string {
2029 my ($self) = @_;
2030
2031 "$self->{path}"
2032}
2033
2034# the displayed name, this is a one way mapping
2035sub visible_name {
2036 &as_string
2037}
2038
2039# the original (read-only) location
2040sub load_path {
2041 my ($self) = @_;
2042
2043 "$MAPDIR/$self->{path}.map"
2044}
2045
2046# the temporary/swap location
2047sub save_path {
2048 my ($self) = @_;
2049
2050 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
2051 "$TMPDIR/$path.map"
2052}
2053
2054# the unique path, undef == no special unique path
2055sub uniq_path {
2056 my ($self) = @_;
2057
2058 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
2059 "$UNIQUEDIR/$path"
2060}
2061
2062sub decay_objects {
2063 my ($self) = @_;
2064
2065 return if $self->{deny_reset};
2066
2067 $self->do_decay_objects;
2068}
2069
2070sub unlink_save {
2071 my ($self) = @_;
2072
2073 utf8::encode (my $save = $self->save_path);
2074 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
2075 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst";
2076}
2077
2078sub load_header_from($) {
2079 my ($self, $path) = @_;
2080
2081 utf8::encode $path;
2082 my $f = new_from_file cf::object::thawer $path
2083 or return;
2084
2085 $self->_load_header ($f)
2086 or return;
2087
2088 local $MAP_LOADING{$self->{path}} = $self;
2089 $f->resolve_delayed_derefs;
2090
2091 $self->{load_path} = $path;
2092
2093 1
2094}
2095
2096# used to laod the header of an original map
2097sub load_header_orig {
2098 my ($self) = @_;
2099
2100 $self->load_header_from ($self->load_path)
2101}
2102
2103# used to laod the header of an instantiated map
2104sub load_header_temp {
2105 my ($self) = @_;
2106
2107 $self->load_header_from ($self->save_path)
2108}
2109
2110# called after loading the header from an instantiated map
2111sub prepare_temp {
2112 my ($self) = @_;
2113
2114 $self->last_access ((delete $self->{last_access})
2115 || $cf::RUNTIME); #d#
2116 # safety
2117 $self->{instantiate_time} = $cf::RUNTIME
2118 if $self->{instantiate_time} > $cf::RUNTIME;
2119}
2120
2121# called after loading the header from an original map
2122sub prepare_orig {
2123 my ($self) = @_;
2124
2125 $self->{load_original} = 1;
2126 $self->{instantiate_time} = $cf::RUNTIME;
2127 $self->last_access ($cf::RUNTIME);
2128 $self->instantiate;
2129}
2130
2131sub load_header {
2132 my ($self) = @_;
2133
2134 if ($self->load_header_temp) {
2135 $self->prepare_temp;
2136 } else {
2137 $self->load_header_orig
2138 or return;
2139 $self->prepare_orig;
2140 }
2141
2142 $self->{deny_reset} = 1
2143 if $self->no_reset;
2144
2145 $self->default_region (cf::region::find_by_path $self->{path})
2146 unless $self->default_region;
2147
2148 1
2149}
2150
2151sub find;
2152sub find {
2153 my ($path, $origin) = @_;
2154
2155 cf::cede_to_tick;
2156
2157 $path = normalise $path, $origin;
2158
2159 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
2160 my $guard2 = cf::lock_acquire "map_find:$path";
2161
2162 $cf::MAP{$path} || do {
2163 my $map = new_from_path cf::map $path
2164 or return;
2165
2166 $map->{last_save} = $cf::RUNTIME;
2167
2168 $map->load_header
2169 or return;
2170
2171 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
2172 # doing this can freeze the server in a sync job, obviously
2173 #$cf::WAIT_FOR_TICK->wait;
2174 undef $guard2;
2175 undef $guard1;
2176 $map->reset;
2177 return find $path;
2178 }
2179
2180 $cf::MAP{$path} = $map
2181 }
2182}
2183
2184sub pre_load { }
2185#sub post_load { } # XS
2186
2187sub load {
2188 my ($self) = @_;
2189
2190 local $self->{deny_reset} = 1; # loading can take a long time
2191
2192 my $path = $self->{path};
2193
2194 {
2195 my $guard = cf::lock_acquire "map_data:$path";
2196
2197 return unless $self->valid;
2198 return unless $self->state == cf::MAP_SWAPPED;
2199
2200 $self->alloc;
2201
2202 $self->pre_load;
2203 cf::cede_to_tick;
2204
2205 if (exists $self->{load_path}) {
2206 my $f = new_from_file cf::object::thawer $self->{load_path};
2207 $f->skip_block;
2208 $self->_load_objects ($f)
2209 or return;
2210
2211 $self->post_load_original
2212 if delete $self->{load_original};
2213
2214 if (my $uniq = $self->uniq_path) {
2215 utf8::encode $uniq;
2216 unless (aio_stat $uniq) {
2217 if (my $f = new_from_file cf::object::thawer $uniq) {
2218 $self->clear_unique_items;
2219 $self->_load_objects ($f);
2220 $f->resolve_delayed_derefs;
2221 }
2222 }
572 } 2223 }
2224
2225 $f->resolve_delayed_derefs;
2226 } else {
2227 $self->post_load_original
2228 if delete $self->{load_original};
573 } 2229 }
2230
2231 $self->state (cf::MAP_INACTIVE);
2232
2233 cf::cede_to_tick;
2234 # now do the right thing for maps
2235 $self->link_multipart_objects;
2236 $self->difficulty ($self->estimate_difficulty)
2237 unless $self->difficulty;
2238 cf::cede_to_tick;
2239
2240 unless ($self->{deny_activate}) {
2241 $self->decay_objects;
2242 $self->fix_auto_apply;
2243 $self->update_buttons;
2244 cf::cede_to_tick;
2245 #$self->activate; # no longer activate maps automatically
2246 }
2247
2248 $self->{last_save} = $cf::RUNTIME;
2249 $self->last_access ($cf::RUNTIME);
574 }, 2250 }
575 on_save => sub {
576 my ($pl, $path) = @_;
577 2251
578 $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_) 2252 $self->post_load;
579 for grep %$_, all_objects $pl->ob; 2253
2254 1
2255}
2256
2257# customize the map for a given player, i.e.
2258# return the _real_ map. used by e.g. per-player
2259# maps to change the path to ~playername/mappath
2260sub customise_for {
2261 my ($self, $ob) = @_;
2262
2263 return find "~" . $ob->name . "/" . $self->{path}
2264 if $self->per_player;
2265
2266# return find "?party/" . $ob->name . "/" . $self->{path}
2267# if $self->per_party;
2268
2269 $self
2270}
2271
2272sub find_sync {
2273 my ($path, $origin) = @_;
2274
2275 # it's a bug to call this from the main context
2276 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync"
2277 if $Coro::current == $Coro::main;
2278
2279 find $path, $origin
2280}
2281
2282sub do_load_sync {
2283 my ($map) = @_;
2284
2285 # it's a bug to call this from the main context
2286 return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync"
2287 if $Coro::current == $Coro::main;
2288
2289 $map->load;
2290}
2291
2292our %MAP_PREFETCH;
2293our $MAP_PREFETCHER = undef;
2294
2295sub find_async {
2296 my ($path, $origin, $load) = @_;
2297
2298 $path = normalise $path, $origin;
2299
2300 if (my $map = $cf::MAP{$path}) {
2301 return $map if !$load || $map->linkable;
580 }, 2302 }
581;
582 2303
583############################################################################# 2304 $MAP_PREFETCH{$path} |= $load;
584# core extensions - in perl
585 2305
586=item cf::player::exists $login 2306 $MAP_PREFETCHER ||= cf::async {
2307 $Coro::current->{desc} = "map prefetcher";
587 2308
588Returns true when the given account exists. 2309 while (%MAP_PREFETCH) {
2310 while (my ($k, $v) = each %MAP_PREFETCH) {
2311 if (my $map = find $k) {
2312 $map->load if $v;
2313 }
589 2314
590=cut 2315 delete $MAP_PREFETCH{$k};
2316 }
2317 }
2318 undef $MAP_PREFETCHER;
2319 };
2320 $MAP_PREFETCHER->prio (6);
591 2321
592sub cf::player::exists($) { 2322 ()
593 cf::player::find $_[0]
594 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
595} 2323}
596 2324
2325# common code, used by both ->save and ->swapout
2326sub _save {
2327 my ($self) = @_;
2328
2329 $self->{last_save} = $cf::RUNTIME;
2330
2331 return unless $self->dirty;
2332
2333 my $save = $self->save_path; utf8::encode $save;
2334 my $uniq = $self->uniq_path; utf8::encode $uniq;
2335
2336 $self->{load_path} = $save;
2337
2338 return if $self->{deny_save};
2339
2340 local $self->{last_access} = $self->last_access;#d#
2341
2342 cf::async {
2343 $Coro::current->{desc} = "map player save";
2344 $_->contr->save for $self->players;
2345 };
2346
2347 cf::get_slot 0.02;
2348
2349 if ($uniq) {
2350 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
2351 $self->_save_objects ($uniq, cf::IO_UNIQUES);
2352 } else {
2353 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
2354 }
2355}
2356
2357sub save {
2358 my ($self) = @_;
2359
2360 my $lock = cf::lock_acquire "map_data:$self->{path}";
2361
2362 $self->_save;
2363}
2364
2365sub swap_out {
2366 my ($self) = @_;
2367
2368 my $lock = cf::lock_acquire "map_data:$self->{path}";
2369
2370 return if !$self->linkable;
2371 return if $self->{deny_save};
2372 return if $self->players;
2373
2374 # first deactivate the map and "unlink" it from the core
2375 $self->deactivate;
2376 $_->clear_links_to ($self) for values %cf::MAP;
2377 $self->state (cf::MAP_SWAPPED);
2378
2379 # then atomically save
2380 $self->_save;
2381
2382 # then free the map
2383 $self->clear;
2384}
2385
2386sub reset_at {
2387 my ($self) = @_;
2388
2389 # TODO: safety, remove and allow resettable per-player maps
2390 return 1e99 if $self->{deny_reset};
2391
2392 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2393 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2394
2395 $time + $to
2396}
2397
2398sub should_reset {
2399 my ($self) = @_;
2400
2401 $self->reset_at <= $cf::RUNTIME
2402}
2403
2404sub reset {
2405 my ($self) = @_;
2406
2407 my $lock = cf::lock_acquire "map_data:$self->{path}";
2408
2409 return if $self->players;
2410
2411 cf::trace "resetting map ", $self->path, "\n";
2412
2413 $self->state (cf::MAP_SWAPPED);
2414
2415 # need to save uniques path
2416 unless ($self->{deny_save}) {
2417 my $uniq = $self->uniq_path; utf8::encode $uniq;
2418
2419 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2420 if $uniq;
2421 }
2422
2423 delete $cf::MAP{$self->path};
2424
2425 $self->deactivate;
2426 $_->clear_links_to ($self) for values %cf::MAP;
2427 $self->clear;
2428
2429 $self->unlink_save;
2430 $self->destroy;
2431}
2432
2433my $nuke_counter = "aaaa";
2434
2435sub nuke {
2436 my ($self) = @_;
2437
2438 {
2439 my $lock = cf::lock_acquire "map_data:$self->{path}";
2440
2441 delete $cf::MAP{$self->path};
2442
2443 $self->unlink_save;
2444
2445 bless $self, "cf::map::wrap";
2446 delete $self->{deny_reset};
2447 $self->{deny_save} = 1;
2448 $self->reset_timeout (1);
2449 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2450
2451 $cf::MAP{$self->path} = $self;
2452 }
2453
2454 $self->reset; # polite request, might not happen
2455}
2456
2457=item $maps = cf::map::tmp_maps
2458
2459Returns an arrayref with all map paths of currently instantiated and saved
2460maps. May block.
2461
2462=cut
2463
2464sub tmp_maps() {
2465 [
2466 map {
2467 utf8::decode $_;
2468 /\.map$/
2469 ? normalise $_
2470 : ()
2471 } @{ aio_readdir $TMPDIR or [] }
2472 ]
2473}
2474
2475=item $maps = cf::map::random_maps
2476
2477Returns an arrayref with all map paths of currently instantiated and saved
2478random maps. May block.
2479
2480=cut
2481
2482sub random_maps() {
2483 [
2484 map {
2485 utf8::decode $_;
2486 /\.map$/
2487 ? normalise "?random/$_"
2488 : ()
2489 } @{ aio_readdir $RANDOMDIR or [] }
2490 ]
2491}
2492
2493=item cf::map::unique_maps
2494
2495Returns an arrayref of paths of all shared maps that have
2496instantiated unique items. May block.
2497
2498=cut
2499
2500sub unique_maps() {
2501 [
2502 map {
2503 utf8::decode $_;
2504 s/\.map$//; # TODO future compatibility hack
2505 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
2506 ? ()
2507 : normalise $_
2508 } @{ aio_readdir $UNIQUEDIR or [] }
2509 ]
2510}
2511
2512=item cf::map::static_maps
2513
2514Returns an arrayref if paths of all static maps (all preinstalled F<.map>
2515file in the shared directory excluding F</styles> and F</editor>). May
2516block.
2517
2518=cut
2519
2520sub static_maps() {
2521 my @dirs = "";
2522 my @maps;
2523
2524 while (@dirs) {
2525 my $dir = shift @dirs;
2526
2527 next if $dir eq "/styles" || $dir eq "/editor";
2528
2529 my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
2530 or return;
2531
2532 for (@$files) {
2533 s/\.map$// or next;
2534 utf8::decode $_;
2535 push @maps, "$dir/$_";
2536 }
2537
2538 push @dirs, map "$dir/$_", @$dirs;
2539 }
2540
2541 \@maps
2542}
2543
2544=back
2545
2546=head3 cf::object
2547
2548=cut
2549
2550package cf::object;
2551
2552=over 4
2553
2554=item $ob->inv_recursive
2555
2556Returns the inventory of the object I<and> their inventories, recursively,
2557but I<not> the object itself.
2558
2559=cut
2560
2561sub inv_recursive_;
2562sub inv_recursive_ {
2563 map { $_, inv_recursive_ $_->inv } @_
2564}
2565
2566sub inv_recursive {
2567 inv_recursive_ inv $_[0]
2568}
2569
2570=item $ref = $ob->ref
2571
2572Creates and returns a persistent reference to an object that can be stored as a string.
2573
2574=item $ob = cf::object::deref ($refstring)
2575
2576returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2577even if the object actually exists. May block.
2578
2579=cut
2580
2581sub deref {
2582 my ($ref) = @_;
2583
2584 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2585 my ($uuid, $name) = ($1, $2);
2586 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2587 or return;
2588 $pl->ob->uuid eq $uuid
2589 or return;
2590
2591 $pl->ob
2592 } else {
2593 warn "$ref: cannot resolve object reference\n";
2594 undef
2595 }
2596}
2597
2598package cf;
2599
2600=back
2601
2602=head3 cf::object::player
2603
2604=over 4
2605
597=item $player->reply ($npc, $msg[, $flags]) 2606=item $player_object->reply ($npc, $msg[, $flags])
598 2607
599Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 2608Sends 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 2609can be C<undef>. Does the right thing when the player is currently in a
601dialogue with the given NPC character. 2610dialogue with the given NPC character.
602 2611
603=cut 2612=cut
604 2613
2614our $SAY_CHANNEL = {
2615 id => "say",
2616 title => "Map",
2617 reply => "say ",
2618 tooltip => "Things said to and replied from NPCs near you and other players on the same map only.",
2619};
2620
2621our $CHAT_CHANNEL = {
2622 id => "chat",
2623 title => "Chat",
2624 reply => "chat ",
2625 tooltip => "Player chat and shouts, global to the server.",
2626};
2627
605# rough implementation of a future "reply" method that works 2628# rough implementation of a future "reply" method that works
606# with dialog boxes. 2629# with dialog boxes.
2630#TODO: the first argument must go, split into a $npc->reply_to ( method
607sub cf::object::player::reply($$$;$) { 2631sub cf::object::player::reply($$$;$) {
608 my ($self, $npc, $msg, $flags) = @_; 2632 my ($self, $npc, $msg, $flags) = @_;
609 2633
610 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2634 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
611 2635
612 if ($self->{record_replies}) { 2636 if ($self->{record_replies}) {
613 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2637 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2638
614 } else { 2639 } else {
2640 my $pl = $self->contr;
2641
2642 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2643 my $dialog = $pl->{npc_dialog};
2644 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2645
2646 } else {
615 $msg = $npc->name . " says: $msg" if $npc; 2647 $msg = $npc->name . " says: $msg" if $npc;
616 $self->message ($msg, $flags); 2648 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2649 }
2650 }
2651}
2652
2653=item $object->send_msg ($channel, $msg, $color, [extra...])
2654
2655=cut
2656
2657sub cf::object::send_msg {
2658 my $pl = shift->contr
2659 or return;
2660 $pl->send_msg (@_);
2661}
2662
2663=item $player_object->may ("access")
2664
2665Returns wether the given player is authorized to access resource "access"
2666(e.g. "command_wizcast").
2667
2668=cut
2669
2670sub cf::object::player::may {
2671 my ($self, $access) = @_;
2672
2673 $self->flag (cf::FLAG_WIZ) ||
2674 (ref $cf::CFG{"may_$access"}
2675 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
2676 : $cf::CFG{"may_$access"})
2677}
2678
2679=item $player_object->enter_link
2680
2681Freezes the player and moves him/her to a special map (C<{link}>).
2682
2683The player should be reasonably safe there for short amounts of time (e.g.
2684for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2685though, as the player cannot control the character while it is on the link
2686map.
2687
2688Will never block.
2689
2690=item $player_object->leave_link ($map, $x, $y)
2691
2692Moves the player out of the special C<{link}> map onto the specified
2693map. If the map is not valid (or omitted), the player will be moved back
2694to the location he/she was before the call to C<enter_link>, or, if that
2695fails, to the emergency map position.
2696
2697Might block.
2698
2699=cut
2700
2701sub link_map {
2702 unless ($LINK_MAP) {
2703 $LINK_MAP = cf::map::find "{link}"
2704 or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
2705 $LINK_MAP->load;
2706 }
2707
2708 $LINK_MAP
2709}
2710
2711sub cf::object::player::enter_link {
2712 my ($self) = @_;
2713
2714 $self->deactivate_recursive;
2715
2716 ++$self->{_link_recursion};
2717
2718 return if UNIVERSAL::isa $self->map, "ext::map_link";
2719
2720 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2721 if $self->map && $self->map->{path} ne "{link}";
2722
2723 $self->enter_map ($LINK_MAP || link_map, 3, 3);
2724}
2725
2726sub cf::object::player::leave_link {
2727 my ($self, $map, $x, $y) = @_;
2728
2729 return unless $self->contr->active;
2730
2731 my $link_pos = delete $self->{_link_pos};
2732
2733 unless ($map) {
2734 # restore original map position
2735 ($map, $x, $y) = @{ $link_pos || [] };
2736 $map = cf::map::find $map;
2737
2738 unless ($map) {
2739 ($map, $x, $y) = @$EMERGENCY_POSITION;
2740 $map = cf::map::find $map
2741 or die "FATAL: cannot load emergency map\n";
2742 }
2743 }
2744
2745 ($x, $y) = (-1, -1)
2746 unless (defined $x) && (defined $y);
2747
2748 # use -1 or undef as default coordinates, not 0, 0
2749 ($x, $y) = ($map->enter_x, $map->enter_y)
2750 if $x <= 0 && $y <= 0;
2751
2752 $map->load;
2753
2754 return unless $self->contr->active;
2755
2756 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2757 if ($self->enter_map ($map, $x, $y)) {
2758 # entering was successful
2759 delete $self->{_link_recursion};
2760 # only activate afterwards, to support waiting in hooks
2761 $self->activate_recursive;
2762 }
2763
2764}
2765
2766=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
2767
2768Moves the player to the given map-path and coordinates by first freezing
2769her, loading and preparing them map, calling the provided $check callback
2770that has to return the map if sucecssful, and then unfreezes the player on
2771the new (success) or old (failed) map position. In either case, $done will
2772be called at the end of this process.
2773
2774Note that $check will be called with a potentially non-loaded map, so if
2775it needs a loaded map it has to call C<< ->load >>.
2776
2777=cut
2778
2779our $GOTOGEN;
2780
2781sub cf::object::player::goto {
2782 my ($self, $path, $x, $y, $check, $done) = @_;
2783
2784 if ($self->{_link_recursion} >= $MAX_LINKS) {
2785 error "FATAL: link recursion exceeded, ", $self->name, " goto $path $x $y, redirecting.";
2786 $self->failmsg ("Something went wrong inside the server - please contact an administrator!");
2787 ($path, $x, $y) = @$EMERGENCY_POSITION;
2788 }
2789
2790 # do generation counting so two concurrent goto's will be executed in-order
2791 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2792
2793 $self->enter_link;
2794
2795 (async {
2796 $Coro::current->{desc} = "player::goto $path $x $y";
2797
2798 # *tag paths override both path and x|y
2799 if ($path =~ /^\*(.*)$/) {
2800 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2801 my $ob = $obs[rand @obs];
2802
2803 # see if we actually can go there
2804 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2805 $ob = $obs[rand @obs];
2806 } else {
2807 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2808 }
2809 # else put us there anyways for now #d#
2810
2811 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2812 } else {
2813 ($path, $x, $y) = (undef, undef, undef);
2814 }
2815 }
2816
2817 my $map = eval {
2818 my $map = defined $path ? cf::map::find $path, $self->map : undef;
2819
2820 if ($map) {
2821 $map = $map->customise_for ($self);
2822 $map = $check->($map, $x, $y, $self) if $check && $map;
2823 } else {
2824 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2825 }
2826
2827 $map
2828 };
2829
2830 if ($@) {
2831 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2832 LOG llevError | logBacktrace, Carp::longmess $@;
2833 }
2834
2835 if ($gen == $self->{_goto_generation}) {
2836 delete $self->{_goto_generation};
2837 $self->leave_link ($map, $x, $y);
2838 }
2839
2840 $done->($self) if $done;
2841 })->prio (1);
2842}
2843
2844=item $player_object->enter_exit ($exit_object)
2845
2846=cut
2847
2848sub parse_random_map_params {
2849 my ($spec) = @_;
2850
2851 my $rmp = { # defaults
2852 xsize => (cf::rndm 15, 40),
2853 ysize => (cf::rndm 15, 40),
2854 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
2855 #layout => string,
617 } 2856 };
618}
619 2857
2858 for (split /\n/, $spec) {
2859 my ($k, $v) = split /\s+/, $_, 2;
2860
2861 $rmp->{lc $k} = $v if (length $k) && (length $v);
2862 }
2863
2864 $rmp
2865}
2866
2867sub prepare_random_map {
2868 my ($exit) = @_;
2869
2870 # all this does is basically replace the /! path by
2871 # a new random map path (?random/...) with a seed
2872 # that depends on the exit object
2873
2874 my $rmp = parse_random_map_params $exit->msg;
2875
2876 if ($exit->map) {
2877 $rmp->{region} = $exit->region->name;
2878 $rmp->{origin_map} = $exit->map->path;
2879 $rmp->{origin_x} = $exit->x;
2880 $rmp->{origin_y} = $exit->y;
2881
2882 $exit->map->touch;
2883 }
2884
2885 $rmp->{random_seed} ||= $exit->random_seed;
2886
2887 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2888 my $md5 = Digest::MD5::md5_hex $data;
2889 my $meta = "$RANDOMDIR/$md5.meta";
2890
2891 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2892 aio_write $fh, 0, (length $data), $data, 0;
2893 undef $fh;
2894 aio_rename "$meta~", $meta;
2895
2896 my $slaying = "?random/$md5";
2897
2898 if ($exit->valid) {
2899 $exit->slaying ("?random/$md5");
2900 $exit->msg (undef);
2901 }
2902 }
2903}
2904
2905sub cf::object::player::enter_exit {
2906 my ($self, $exit) = @_;
2907
2908 return unless $self->type == cf::PLAYER;
2909
2910 $self->enter_link;
2911
2912 (async {
2913 $Coro::current->{desc} = "enter_exit";
2914
2915 unless (eval {
2916 $self->deactivate_recursive; # just to be sure
2917
2918 my $map = cf::map::normalise $exit->slaying, $exit->map;
2919 my $x = $exit->stats->hp;
2920 my $y = $exit->stats->sp;
2921
2922 # special map handling
2923 my $slaying = $exit->slaying;
2924
2925 # special map handling
2926 if ($slaying eq "/!") {
2927 my $guard = cf::lock_acquire "exit_prepare:$exit";
2928
2929 prepare_random_map $exit
2930 if $exit->slaying eq "/!"; # need to re-check after getting the lock
2931
2932 $map = $exit->slaying;
2933
2934 } elsif ($slaying eq '!up') {
2935 $map = $exit->map->tile_path (cf::TILE_UP);
2936 $x = $exit->x;
2937 $y = $exit->y;
2938
2939 } elsif ($slaying eq '!down') {
2940 $map = $exit->map->tile_path (cf::TILE_DOWN);
2941 $x = $exit->x;
2942 $y = $exit->y;
2943 }
2944
2945 $self->goto ($map, $x, $y);
2946
2947 # if exit is damned, update players death & WoR home-position
2948 $self->contr->savebed ($map, $x, $y)
2949 if $exit->flag (cf::FLAG_DAMNED);
2950
2951 1
2952 }) {
2953 $self->message ("Something went wrong deep within the deliantra server. "
2954 . "I'll try to bring you back to the map you were before. "
2955 . "Please report this to the dungeon master!",
2956 cf::NDI_UNIQUE | cf::NDI_RED);
2957
2958 error "ERROR in enter_exit: $@";
2959 $self->leave_link;
2960 }
2961 })->prio (1);
2962}
2963
2964=head3 cf::client
2965
2966=over 4
2967
2968=item $client->send_drawinfo ($text, $flags)
2969
2970Sends a drawinfo packet to the client. Circumvents output buffering so
2971should not be used under normal circumstances.
2972
2973=cut
2974
2975sub cf::client::send_drawinfo {
2976 my ($self, $text, $flags) = @_;
2977
2978 utf8::encode $text;
2979 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2980}
2981
2982=item $client->send_big_packet ($pkt)
2983
2984Like C<send_packet>, but tries to compress large packets, and fragments
2985them as required.
2986
2987=cut
2988
2989our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
2990
2991sub cf::client::send_big_packet {
2992 my ($self, $pkt) = @_;
2993
2994 # try lzf for large packets
2995 $pkt = "lzf " . Compress::LZF::compress $pkt
2996 if 1024 <= length $pkt and $self->{can_lzf};
2997
2998 # split very large packets
2999 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
3000 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
3001 $pkt = "frag";
3002 }
3003
3004 $self->send_packet ($pkt);
3005}
3006
3007=item $client->send_msg ($channel, $msg, $color, [extra...])
3008
3009Send a drawinfo or msg packet to the client, formatting the msg for the
3010client if neccessary. C<$type> should be a string identifying the type of
3011the message, with C<log> being the default. If C<$color> is negative, suppress
3012the message unless the client supports the msg packet.
3013
3014=cut
3015
3016# non-persistent channels (usually the info channel)
3017our %CHANNEL = (
3018 "c/motd" => {
3019 id => "infobox",
3020 title => "MOTD",
3021 reply => undef,
3022 tooltip => "The message of the day",
3023 },
3024 "c/identify" => {
3025 id => "infobox",
3026 title => "Identify",
3027 reply => undef,
3028 tooltip => "Items recently identified",
3029 },
3030 "c/examine" => {
3031 id => "infobox",
3032 title => "Examine",
3033 reply => undef,
3034 tooltip => "Signs and other items you examined",
3035 },
3036 "c/shopinfo" => {
3037 id => "infobox",
3038 title => "Shop Info",
3039 reply => undef,
3040 tooltip => "What your bargaining skill tells you about the shop",
3041 },
3042 "c/book" => {
3043 id => "infobox",
3044 title => "Book",
3045 reply => undef,
3046 tooltip => "The contents of a note or book",
3047 },
3048 "c/lookat" => {
3049 id => "infobox",
3050 title => "Look",
3051 reply => undef,
3052 tooltip => "What you saw there",
3053 },
3054 "c/who" => {
3055 id => "infobox",
3056 title => "Players",
3057 reply => undef,
3058 tooltip => "Shows players who are currently online",
3059 },
3060 "c/body" => {
3061 id => "infobox",
3062 title => "Body Parts",
3063 reply => undef,
3064 tooltip => "Shows which body parts you posess and are available",
3065 },
3066 "c/statistics" => {
3067 id => "infobox",
3068 title => "Statistics",
3069 reply => undef,
3070 tooltip => "Shows your primary statistics",
3071 },
3072 "c/skills" => {
3073 id => "infobox",
3074 title => "Skills",
3075 reply => undef,
3076 tooltip => "Shows your experience per skill and item power",
3077 },
3078 "c/shopitems" => {
3079 id => "infobox",
3080 title => "Shop Items",
3081 reply => undef,
3082 tooltip => "Shows the items currently for sale in this shop",
3083 },
3084 "c/resistances" => {
3085 id => "infobox",
3086 title => "Resistances",
3087 reply => undef,
3088 tooltip => "Shows your resistances",
3089 },
3090 "c/pets" => {
3091 id => "infobox",
3092 title => "Pets",
3093 reply => undef,
3094 tooltip => "Shows information abotu your pets/a specific pet",
3095 },
3096 "c/perceiveself" => {
3097 id => "infobox",
3098 title => "Perceive Self",
3099 reply => undef,
3100 tooltip => "You gained detailed knowledge about yourself",
3101 },
3102 "c/uptime" => {
3103 id => "infobox",
3104 title => "Uptime",
3105 reply => undef,
3106 tooltip => "How long the server has been running since last restart",
3107 },
3108 "c/mapinfo" => {
3109 id => "infobox",
3110 title => "Map Info",
3111 reply => undef,
3112 tooltip => "Information related to the maps",
3113 },
3114 "c/party" => {
3115 id => "party",
3116 title => "Party",
3117 reply => "gsay ",
3118 tooltip => "Messages and chat related to your party",
3119 },
3120 "c/death" => {
3121 id => "death",
3122 title => "Death",
3123 reply => undef,
3124 tooltip => "Reason for and more info about your most recent death",
3125 },
3126 "c/say" => $SAY_CHANNEL,
3127 "c/chat" => $CHAT_CHANNEL,
3128);
3129
3130sub cf::client::send_msg {
3131 my ($self, $channel, $msg, $color, @extra) = @_;
3132
3133 $msg = $self->pl->expand_cfpod ($msg)
3134 unless $color & cf::NDI_VERBATIM;
3135
3136 $color &= cf::NDI_CLIENT_MASK; # just in case...
3137
3138 # check predefined channels, for the benefit of C
3139 if ($CHANNEL{$channel}) {
3140 $channel = $CHANNEL{$channel};
3141
3142 $self->ext_msg (channel_info => $channel);
3143 $channel = $channel->{id};
3144
3145 } elsif (ref $channel) {
3146 # send meta info to client, if not yet sent
3147 unless (exists $self->{channel}{$channel->{id}}) {
3148 $self->{channel}{$channel->{id}} = $channel;
3149 $self->ext_msg (channel_info => $channel);
3150 }
3151
3152 $channel = $channel->{id};
3153 }
3154
3155 return unless @extra || length $msg;
3156
3157 # default colour, mask it out
3158 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
3159 if $color & cf::NDI_DEF;
3160
3161 my $pkt = "msg "
3162 . $self->{json_coder}->encode (
3163 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
3164 );
3165
3166 $self->send_big_packet ($pkt);
3167}
3168
3169=item $client->ext_msg ($type, @msg)
3170
3171Sends an ext event to the client.
3172
3173=cut
3174
3175sub cf::client::ext_msg($$@) {
3176 my ($self, $type, @msg) = @_;
3177
3178 if ($self->extcmd == 2) {
3179 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
3180 } elsif ($self->extcmd == 1) { # TODO: remove
3181 push @msg, msgtype => "event_$type";
3182 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3183 }
3184}
3185
620=item $player->ext_reply ($msgid, $msgtype, %msg) 3186=item $client->ext_reply ($msgid, @msg)
621 3187
622Sends an ext reply to the player. 3188Sends an ext reply to the client.
623 3189
624=cut 3190=cut
625 3191
626sub cf::player::ext_reply($$$%) { 3192sub cf::client::ext_reply($$@) {
627 my ($self, $id, %msg) = @_; 3193 my ($self, $id, @msg) = @_;
628 3194
629 $msg{msgid} = $id; 3195 if ($self->extcmd == 2) {
630 3196 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
631 $self->send ("ext " . to_json \%msg); 3197 } elsif ($self->extcmd == 1) {
3198 #TODO: version 1, remove
3199 unshift @msg, msgtype => "reply", msgid => $id;
3200 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3201 }
632} 3202}
633 3203
634############################################################################# 3204=item $success = $client->query ($flags, "text", \&cb)
635# map scripting support
636 3205
3206Queues a query to the client, calling the given callback with
3207the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
3208C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
3209
3210Queries can fail, so check the return code. Or don't, as queries will
3211become reliable at some point in the future.
3212
3213=cut
3214
3215sub cf::client::query {
3216 my ($self, $flags, $text, $cb) = @_;
3217
3218 return unless $self->state == ST_PLAYING
3219 || $self->state == ST_SETUP
3220 || $self->state == ST_CUSTOM;
3221
3222 $self->state (ST_CUSTOM);
3223
3224 utf8::encode $text;
3225 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
3226
3227 $self->send_packet ($self->{query_queue}[0][0])
3228 if @{ $self->{query_queue} } == 1;
3229
3230 1
3231}
3232
3233cf::client->attach (
3234 on_connect => sub {
3235 my ($ns) = @_;
3236
3237 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
3238 },
3239 on_reply => sub {
3240 my ($ns, $msg) = @_;
3241
3242 # this weird shuffling is so that direct followup queries
3243 # get handled first
3244 my $queue = delete $ns->{query_queue}
3245 or return; # be conservative, not sure how that can happen, but we saw a crash here
3246
3247 (shift @$queue)->[1]->($msg);
3248 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
3249
3250 push @{ $ns->{query_queue} }, @$queue;
3251
3252 if (@{ $ns->{query_queue} } == @$queue) {
3253 if (@$queue) {
3254 $ns->send_packet ($ns->{query_queue}[0][0]);
3255 } else {
3256 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
3257 }
3258 }
3259 },
3260 on_exticmd => sub {
3261 my ($ns, $buf) = @_;
3262
3263 my $msg = eval { $ns->{json_coder}->decode ($buf) };
3264
3265 if (ref $msg) {
3266 my ($type, $reply, @payload) =
3267 "ARRAY" eq ref $msg
3268 ? @$msg
3269 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
3270
3271 my @reply;
3272
3273 if (my $cb = $EXTICMD{$type}) {
3274 @reply = $cb->($ns, @payload);
3275 }
3276
3277 $ns->ext_reply ($reply, @reply)
3278 if $reply;
3279
3280 } else {
3281 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3282 }
3283
3284 cf::override;
3285 },
3286);
3287
3288=item $client->async (\&cb)
3289
3290Create a new coroutine, running the specified callback. The coroutine will
3291be automatically cancelled when the client gets destroyed (e.g. on logout,
3292or loss of connection).
3293
3294=cut
3295
3296sub cf::client::async {
3297 my ($self, $cb) = @_;
3298
3299 my $coro = &Coro::async ($cb);
3300
3301 $coro->on_destroy (sub {
3302 delete $self->{_coro}{$coro+0};
3303 });
3304
3305 $self->{_coro}{$coro+0} = $coro;
3306
3307 $coro
3308}
3309
3310cf::client->attach (
3311 on_client_destroy => sub {
3312 my ($ns) = @_;
3313
3314 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
3315 },
3316);
3317
3318=back
3319
3320
3321=head2 SAFE SCRIPTING
3322
3323Functions that provide a safe environment to compile and execute
3324snippets of perl code without them endangering the safety of the server
3325itself. Looping constructs, I/O operators and other built-in functionality
3326is not available in the safe scripting environment, and the number of
3327functions and methods that can be called is greatly reduced.
3328
3329=cut
3330
637our $safe = new Safe "ext"; 3331our $safe = new Safe "safe";
638our $safe_hole = new Safe::Hole; 3332our $safe_hole = new Safe::Hole;
639 3333
640$SIG{FPE} = 'IGNORE'; 3334$SIG{FPE} = 'IGNORE';
641 3335
642$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 3336$safe->permit_only (Opcode::opset qw(
3337 :base_core :base_mem :base_orig :base_math :base_loop
3338 grepstart grepwhile mapstart mapwhile
3339 sort time
3340));
643 3341
644# here we export the classes and methods available to script code 3342# here we export the classes and methods available to script code
645 3343
3344=pod
3345
3346The following functions and methods are available within a safe environment:
3347
3348 cf::object
3349 contr pay_amount pay_player map x y force_find force_add destroy
3350 insert remove name archname title slaying race decrease split
3351 value
3352
3353 cf::object::player
3354 player
3355
3356 cf::player
3357 peaceful
3358
3359 cf::map
3360 trigger
3361
3362=cut
3363
646for ( 3364for (
647 ["cf::object" => qw(contr pay_amount pay_player)], 3365 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3366 insert remove inv nrof name archname title slaying race
3367 decrease split destroy change_exp value msg lore send_msg)],
648 ["cf::object::player" => qw(player)], 3368 ["cf::object::player" => qw(player)],
649 ["cf::player" => qw(peaceful)], 3369 ["cf::player" => qw(peaceful send_msg)],
3370 ["cf::map" => qw(trigger)],
650) { 3371) {
651 no strict 'refs';
652 my ($pkg, @funs) = @$_; 3372 my ($pkg, @funs) = @$_;
653 *{"ext::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3373 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
654 for @funs; 3374 for @funs;
655} 3375}
3376
3377=over 4
3378
3379=item @retval = safe_eval $code, [var => value, ...]
3380
3381Compiled and executes the given perl code snippet. additional var/value
3382pairs result in temporary local (my) scalar variables of the given name
3383that are available in the code snippet. Example:
3384
3385 my $five = safe_eval '$first + $second', first => 1, second => 4;
3386
3387=cut
656 3388
657sub safe_eval($;@) { 3389sub safe_eval($;@) {
658 my ($code, %vars) = @_; 3390 my ($code, %vars) = @_;
659 3391
660 my $qcode = $code; 3392 my $qcode = $code;
661 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3393 $qcode =~ s/"/‟/g; # not allowed in #line filenames
662 $qcode =~ s/\n/\\n/g; 3394 $qcode =~ s/\n/\\n/g;
663 3395
3396 %vars = (_dummy => 0) unless %vars;
3397
3398 my @res;
664 local $_; 3399 local $_;
665 local @ext::cf::_safe_eval_args = values %vars;
666 3400
667 $code = 3401 my $eval =
668 "do {\n" 3402 "do {\n"
669 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3403 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
670 . "#line 0 \"{$qcode}\"\n" 3404 . "#line 0 \"{$qcode}\"\n"
671 . $code 3405 . $code
672 . "\n}" 3406 . "\n}"
673 ; 3407 ;
674 3408
3409 if ($CFG{safe_eval}) {
675 sub_generation_inc; 3410 sub_generation_inc;
3411 local @safe::cf::_safe_eval_args = values %vars;
676 my @res = wantarray ? $safe->reval ($code) : scalar $safe->reval ($code); 3412 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
677 sub_generation_inc; 3413 sub_generation_inc;
3414 } else {
3415 local @cf::_safe_eval_args = values %vars;
3416 @res = wantarray ? eval eval : scalar eval $eval;
3417 }
3418
3419 if ($@) {
3420 warn "$@",
3421 "while executing safe code '$code'\n",
3422 "with arguments " . (join " ", %vars) . "\n";
3423 }
678 3424
679 wantarray ? @res : $res[0] 3425 wantarray ? @res : $res[0]
680} 3426}
3427
3428=item cf::register_script_function $function => $cb
3429
3430Register a function that can be called from within map/npc scripts. The
3431function should be reasonably secure and should be put into a package name
3432like the extension.
3433
3434Example: register a function that gets called whenever a map script calls
3435C<rent::overview>, as used by the C<rent> extension.
3436
3437 cf::register_script_function "rent::overview" => sub {
3438 ...
3439 };
3440
3441=cut
681 3442
682sub register_script_function { 3443sub register_script_function {
683 my ($fun, $cb) = @_; 3444 my ($fun, $cb) = @_;
684 3445
685 no strict 'refs'; 3446 $fun = "safe::$fun" if $CFG{safe_eval};
686 *{"ext::$fun"} = $safe_hole->wrap ($cb); 3447 *$fun = $safe_hole->wrap ($cb);
687} 3448}
3449
3450=back
3451
3452=cut
688 3453
689############################################################################# 3454#############################################################################
690# the server's main() 3455# the server's init and main functions
3456
3457sub load_facedata($) {
3458 my ($path) = @_;
3459
3460 # HACK to clear player env face cache, we need some signal framework
3461 # for this (global event?)
3462 %ext::player_env::MUSIC_FACE_CACHE = ();
3463
3464 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3465
3466 trace "loading facedata from $path\n";
3467
3468 my $facedata = decode_storable load_file $path;
3469
3470 $facedata->{version} == 2
3471 or cf::cleanup "$path: version mismatch, cannot proceed.";
3472
3473 # patch in the exptable
3474 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3475 $facedata->{resource}{"res/exp_table"} = {
3476 type => FT_RSRC,
3477 data => $exp_table,
3478 hash => (Digest::MD5::md5 $exp_table),
3479 };
3480 cf::cede_to_tick;
3481
3482 {
3483 my $faces = $facedata->{faceinfo};
3484
3485 while (my ($face, $info) = each %$faces) {
3486 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3487
3488 cf::face::set_visibility $idx, $info->{visibility};
3489 cf::face::set_magicmap $idx, $info->{magicmap};
3490 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3491 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3492 cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph} ;
3493
3494 cf::cede_to_tick;
3495 }
3496
3497 while (my ($face, $info) = each %$faces) {
3498 next unless $info->{smooth};
3499
3500 my $idx = cf::face::find $face
3501 or next;
3502
3503 if (my $smooth = cf::face::find $info->{smooth}) {
3504 cf::face::set_smooth $idx, $smooth;
3505 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3506 } else {
3507 error "smooth face '$info->{smooth}' not found for face '$face'";
3508 }
3509
3510 cf::cede_to_tick;
3511 }
3512 }
3513
3514 {
3515 my $anims = $facedata->{animinfo};
3516
3517 while (my ($anim, $info) = each %$anims) {
3518 cf::anim::set $anim, $info->{frames}, $info->{facings};
3519 cf::cede_to_tick;
3520 }
3521
3522 cf::anim::invalidate_all; # d'oh
3523 }
3524
3525 {
3526 my $res = $facedata->{resource};
3527
3528 while (my ($name, $info) = each %$res) {
3529 if (defined $info->{type}) {
3530 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3531
3532 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3533 cf::face::set_type $idx, $info->{type};
3534 } else {
3535 $RESOURCE{$name} = $info; # unused
3536 }
3537
3538 cf::cede_to_tick;
3539 }
3540 }
3541
3542 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3543
3544 1
3545}
3546
3547register_exticmd fx_want => sub {
3548 my ($ns, $want) = @_;
3549
3550 while (my ($k, $v) = each %$want) {
3551 $ns->fx_want ($k, $v);
3552 }
3553};
3554
3555sub load_resource_file($) {
3556 my $guard = lock_acquire "load_resource_file";
3557
3558 my $status = load_resource_file_ $_[0];
3559 get_slot 0.1, 100;
3560 cf::arch::commit_load;
3561
3562 $status
3563}
3564
3565sub reload_regions {
3566 # HACK to clear player env face cache, we need some signal framework
3567 # for this (global event?)
3568 %ext::player_env::MUSIC_FACE_CACHE = ();
3569
3570 load_resource_file "$MAPDIR/regions"
3571 or die "unable to load regions file\n";
3572
3573 for (cf::region::list) {
3574 $_->{match} = qr/$_->{match}/
3575 if exists $_->{match};
3576 }
3577}
3578
3579sub reload_facedata {
3580 load_facedata "$DATADIR/facedata"
3581 or die "unable to load facedata\n";
3582}
3583
3584sub reload_archetypes {
3585 load_resource_file "$DATADIR/archetypes"
3586 or die "unable to load archetypes\n";
3587}
3588
3589sub reload_treasures {
3590 load_resource_file "$DATADIR/treasures"
3591 or die "unable to load treasurelists\n";
3592}
3593
3594sub reload_sound {
3595 trace "loading sound config from $DATADIR/sound\n";
3596
3597 my $soundconf = JSON::XS->new->utf8->relaxed->decode (load_file "$DATADIR/sound");
3598
3599 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3600 my $sound = $soundconf->{compat}[$_]
3601 or next;
3602
3603 my $face = cf::face::find "sound/$sound->[1]";
3604 cf::sound::set $sound->[0] => $face;
3605 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3606 }
3607
3608 while (my ($k, $v) = each %{$soundconf->{event}}) {
3609 my $face = cf::face::find "sound/$v";
3610 cf::sound::set $k => $face;
3611 }
3612}
3613
3614sub reload_resources {
3615 trace "reloading resource files...\n";
3616
3617 reload_exp_table;
3618 reload_materials;
3619 reload_facedata;
3620 reload_sound;
3621 reload_archetypes;
3622 reload_regions;
3623 reload_treasures;
3624
3625 trace "finished reloading resource files\n";
3626}
3627
3628sub reload_config {
3629 trace "reloading config file...\n";
3630
3631 my $config = load_file "$CONFDIR/config";
3632 utf8::decode $config;
3633 *CFG = decode_yaml $config;
3634
3635 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3636
3637 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3638 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3639
3640 if (exists $CFG{mlockall}) {
3641 eval {
3642 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3643 and die "WARNING: m(un)lockall failed: $!\n";
3644 };
3645 warn $@ if $@;
3646 }
3647}
3648
3649sub pidfile() {
3650 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3651 or die "$PIDFILE: $!";
3652 flock $fh, &Fcntl::LOCK_EX
3653 or die "$PIDFILE: flock: $!";
3654 $fh
3655}
3656
3657# make sure only one server instance is running at any one time
3658sub atomic {
3659 my $fh = pidfile;
3660
3661 my $pid = <$fh>;
3662 kill 9, $pid if $pid > 0;
3663
3664 seek $fh, 0, 0;
3665 print $fh $$;
3666}
3667
3668sub main_loop {
3669 trace "EV::loop starting\n";
3670 if (1) {
3671 EV::loop;
3672 }
3673 trace "EV::loop returned\n";
3674 goto &main_loop unless $REALLY_UNLOOP;
3675}
691 3676
692sub main { 3677sub main {
693 Event::loop; 3678 cf::init_globals; # initialise logging
3679
3680 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3681 LOG llevInfo, "Copyright (C) 2005-2011 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3682 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3683 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3684
3685 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3686
3687 # we must not ever block the main coroutine
3688 local $Coro::idle = sub {
3689 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3690 (async {
3691 $Coro::current->{desc} = "IDLE BUG HANDLER";
3692 EV::loop EV::LOOP_ONESHOT;
3693 })->prio (Coro::PRIO_MAX);
3694 };
3695
3696 evthread_start IO::AIO::poll_fileno;
3697
3698 cf::sync_job {
3699 cf::incloader::init ();
3700
3701 cf::init_anim;
3702 cf::init_attackmess;
3703 cf::init_dynamic;
3704
3705 cf::load_settings;
3706
3707 reload_resources;
3708 reload_config;
3709 db_init;
3710
3711 cf::init_uuid;
3712 cf::init_signals;
3713 cf::init_skills;
3714
3715 cf::init_beforeplay;
3716
3717 atomic;
3718
3719 load_extensions;
3720
3721 utime time, time, $RUNTIMEFILE;
3722
3723 # no (long-running) fork's whatsoever before this point(!)
3724 use POSIX ();
3725 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3726
3727 cf::_post_init 0;
3728 };
3729
3730 cf::object::thawer::errors_are_fatal 0;
3731 info "parse errors in files are no longer fatal from this point on.\n";
3732
3733 AE::postpone {
3734 undef &main; # free gobs of memory :)
3735 };
3736
3737 goto &main_loop;
694} 3738}
695 3739
696############################################################################# 3740#############################################################################
697# initialisation 3741# initialisation and cleanup
698 3742
699register "<global>", __PACKAGE__; 3743# install some emergency cleanup handlers
700 3744BEGIN {
701unshift @INC, $LIBDIR; 3745 our %SIGWATCHER = ();
702 3746 for my $signal (qw(INT HUP TERM)) {
703load_extensions; 3747 $SIGWATCHER{$signal} = AE::signal $signal, sub {
704 3748 cf::cleanup "SIG$signal";
705$TICK_WATCHER = Event->timer ( 3749 };
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 }, 3750 }
720); 3751}
3752
3753sub write_runtime_sync {
3754 my $t0 = AE::time;
3755
3756 # first touch the runtime file to show we are still running:
3757 # the fsync below can take a very very long time.
3758
3759 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3760
3761 my $guard = cf::lock_acquire "write_runtime";
3762
3763 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3764 or return;
3765
3766 my $value = $cf::RUNTIME + 90 + 10;
3767 # 10 is the runtime save interval, for a monotonic clock
3768 # 60 allows for the watchdog to kill the server.
3769
3770 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3771 and return;
3772
3773 # always fsync - this file is important
3774 aio_fsync $fh
3775 and return;
3776
3777 # touch it again to show we are up-to-date
3778 aio_utime $fh, undef, undef;
3779
3780 close $fh
3781 or return;
3782
3783 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3784 and return;
3785
3786 trace sprintf "runtime file written (%gs).\n", AE::time - $t0;
3787
3788 1
3789}
3790
3791our $uuid_lock;
3792our $uuid_skip;
3793
3794sub write_uuid_sync($) {
3795 $uuid_skip ||= $_[0];
3796
3797 return if $uuid_lock;
3798 local $uuid_lock = 1;
3799
3800 my $uuid = "$LOCALDIR/uuid";
3801
3802 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3803 or return;
3804
3805 my $value = uuid_seq uuid_cur;
3806
3807 unless ($value) {
3808 info "cowardly refusing to write zero uuid value!\n";
3809 return;
3810 }
3811
3812 my $value = uuid_str $value + $uuid_skip;
3813 $uuid_skip = 0;
3814
3815 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3816 and return;
3817
3818 # always fsync - this file is important
3819 aio_fsync $fh
3820 and return;
3821
3822 close $fh
3823 or return;
3824
3825 aio_rename "$uuid~", $uuid
3826 and return;
3827
3828 trace "uuid file written ($value).\n";
3829
3830 1
3831
3832}
3833
3834sub write_uuid($$) {
3835 my ($skip, $sync) = @_;
3836
3837 $sync ? write_uuid_sync $skip
3838 : async { write_uuid_sync $skip };
3839}
3840
3841sub emergency_save() {
3842 my $freeze_guard = cf::freeze_mainloop;
3843
3844 info "emergency_perl_save: enter\n";
3845
3846 # this is a trade-off: we want to be very quick here, so
3847 # save all maps without fsync, and later call a global sync
3848 # (which in turn might be very very slow)
3849 local $USE_FSYNC = 0;
3850
3851 cf::sync_job {
3852 cf::write_runtime_sync; # external watchdog should not bark
3853
3854 # use a peculiar iteration method to avoid tripping on perl
3855 # refcount bugs in for. also avoids problems with players
3856 # and maps saved/destroyed asynchronously.
3857 info "emergency_perl_save: begin player save\n";
3858 for my $login (keys %cf::PLAYER) {
3859 my $pl = $cf::PLAYER{$login} or next;
3860 $pl->valid or next;
3861 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3862 $pl->save;
3863 }
3864 info "emergency_perl_save: end player save\n";
3865
3866 cf::write_runtime_sync; # external watchdog should not bark
3867
3868 info "emergency_perl_save: begin map save\n";
3869 for my $path (keys %cf::MAP) {
3870 my $map = $cf::MAP{$path} or next;
3871 $map->valid or next;
3872 $map->save;
3873 }
3874 info "emergency_perl_save: end map save\n";
3875
3876 cf::write_runtime_sync; # external watchdog should not bark
3877
3878 info "emergency_perl_save: begin database checkpoint\n";
3879 BDB::db_env_txn_checkpoint $DB_ENV;
3880 info "emergency_perl_save: end database checkpoint\n";
3881
3882 info "emergency_perl_save: begin write uuid\n";
3883 write_uuid_sync 1;
3884 info "emergency_perl_save: end write uuid\n";
3885
3886 cf::write_runtime_sync; # external watchdog should not bark
3887
3888 trace "emergency_perl_save: syncing database to disk";
3889 BDB::db_env_txn_checkpoint $DB_ENV;
3890
3891 info "emergency_perl_save: starting sync\n";
3892 IO::AIO::aio_sync sub {
3893 info "emergency_perl_save: finished sync\n";
3894 };
3895
3896 cf::write_runtime_sync; # external watchdog should not bark
3897
3898 trace "emergency_perl_save: flushing outstanding aio requests";
3899 while (IO::AIO::nreqs || BDB::nreqs) {
3900 Coro::AnyEvent::sleep 0.01; # let the sync_job do it's thing
3901 }
3902
3903 cf::write_runtime_sync; # external watchdog should not bark
3904 };
3905
3906 info "emergency_perl_save: leave\n";
3907}
3908
3909sub post_cleanup {
3910 my ($make_core) = @_;
3911
3912 IO::AIO::flush;
3913
3914 error Carp::longmess "post_cleanup backtrace"
3915 if $make_core;
3916
3917 my $fh = pidfile;
3918 unlink $PIDFILE if <$fh> == $$;
3919}
3920
3921# a safer delete_package, copied from Symbol
3922sub clear_package($) {
3923 my $pkg = shift;
3924
3925 # expand to full symbol table name if needed
3926 unless ($pkg =~ /^main::.*::$/) {
3927 $pkg = "main$pkg" if $pkg =~ /^::/;
3928 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3929 $pkg .= '::' unless $pkg =~ /::$/;
3930 }
3931
3932 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3933 my $stem_symtab = *{$stem}{HASH};
3934
3935 defined $stem_symtab and exists $stem_symtab->{$leaf}
3936 or return;
3937
3938 # clear all symbols
3939 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3940 for my $name (keys %$leaf_symtab) {
3941 _gv_clear *{"$pkg$name"};
3942# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3943 }
3944}
3945
3946sub do_reload_perl() {
3947 # can/must only be called in main
3948 unless (in_main) {
3949 error "can only reload from main coroutine";
3950 return;
3951 }
3952
3953 return if $RELOAD++;
3954
3955 my $t1 = AE::time;
3956
3957 while ($RELOAD) {
3958 cf::get_slot 0.1, -1, "reload_perl";
3959 info "perl_reload: reloading...";
3960
3961 trace "perl_reload: entering sync_job";
3962
3963 cf::sync_job {
3964 #cf::emergency_save;
3965
3966 trace "perl_reload: cancelling all extension coros";
3967 $_->cancel for values %EXT_CORO;
3968 %EXT_CORO = ();
3969
3970 trace "perl_reload: removing commands";
3971 %COMMAND = ();
3972
3973 trace "perl_reload: removing ext/exti commands";
3974 %EXTCMD = ();
3975 %EXTICMD = ();
3976
3977 trace "perl_reload: unloading/nuking all extensions";
3978 for my $pkg (@EXTS) {
3979 trace "... unloading $pkg";
3980
3981 if (my $cb = $pkg->can ("unload")) {
3982 eval {
3983 $cb->($pkg);
3984 1
3985 } or error "$pkg unloaded, but with errors: $@";
3986 }
3987
3988 trace "... clearing $pkg";
3989 clear_package $pkg;
3990 }
3991
3992 trace "perl_reload: unloading all perl modules loaded from $LIBDIR";
3993 while (my ($k, $v) = each %INC) {
3994 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3995
3996 trace "... unloading $k";
3997 delete $INC{$k};
3998
3999 $k =~ s/\.pm$//;
4000 $k =~ s/\//::/g;
4001
4002 if (my $cb = $k->can ("unload_module")) {
4003 $cb->();
4004 }
4005
4006 clear_package $k;
4007 }
4008
4009 trace "perl_reload: getting rid of safe::, as good as possible";
4010 clear_package "safe::$_"
4011 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
4012
4013 trace "perl_reload: unloading cf.pm \"a bit\"";
4014 delete $INC{"cf.pm"};
4015 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
4016
4017 # don't, removes xs symbols, too,
4018 # and global variables created in xs
4019 #clear_package __PACKAGE__;
4020
4021 info "perl_reload: unload completed, starting to reload now";
4022
4023 trace "perl_reload: reloading cf.pm";
4024 require cf;
4025 cf::_connect_to_perl_1;
4026
4027 trace "perl_reload: loading config and database again";
4028 cf::reload_config;
4029
4030 trace "perl_reload: loading extensions";
4031 cf::load_extensions;
4032
4033 if ($REATTACH_ON_RELOAD) {
4034 trace "perl_reload: reattaching attachments to objects/players";
4035 _global_reattach; # objects, sockets
4036 trace "perl_reload: reattaching attachments to maps";
4037 reattach $_ for values %MAP;
4038 trace "perl_reload: reattaching attachments to players";
4039 reattach $_ for values %PLAYER;
4040 }
4041
4042 cf::_post_init 1;
4043
4044 trace "perl_reload: leaving sync_job";
4045
4046 1
4047 } or do {
4048 error $@;
4049 cf::cleanup "perl_reload: error, exiting.";
4050 };
4051
4052 --$RELOAD;
4053 }
4054
4055 $t1 = AE::time - $t1;
4056 info "perl_reload: completed in ${t1}s\n";
4057};
4058
4059our $RELOAD_WATCHER; # used only during reload
4060
4061sub reload_perl() {
4062 # doing reload synchronously and two reloads happen back-to-back,
4063 # coro crashes during coro_state_free->destroy here.
4064
4065 $RELOAD_WATCHER ||= cf::async {
4066 Coro::AIO::aio_wait cache_extensions;
4067
4068 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
4069 do_reload_perl;
4070 undef $RELOAD_WATCHER;
4071 };
4072 };
4073}
4074
4075register_command "reload" => sub {
4076 my ($who, $arg) = @_;
4077
4078 if ($who->flag (FLAG_WIZ)) {
4079 $who->message ("reloading server.");
4080 async {
4081 $Coro::current->{desc} = "perl_reload";
4082 reload_perl;
4083 };
4084 }
4085};
4086
4087#############################################################################
4088
4089my $bug_warning = 0;
4090
4091sub wait_for_tick() {
4092 return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
4093
4094 $WAIT_FOR_TICK->wait;
4095}
4096
4097sub wait_for_tick_begin() {
4098 return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
4099
4100 my $signal = new Coro::Signal;
4101 push @WAIT_FOR_TICK_BEGIN, $signal;
4102 $signal->wait;
4103}
4104
4105sub tick {
4106 if ($Coro::current != $Coro::main) {
4107 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
4108 unless ++$bug_warning > 10;
4109 return;
4110 }
4111
4112 cf::one_tick; # one server iteration
4113
4114 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
4115
4116 if ($NOW >= $NEXT_RUNTIME_WRITE) {
4117 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
4118 Coro::async_pool {
4119 $Coro::current->{desc} = "runtime saver";
4120 write_runtime_sync
4121 or error "ERROR: unable to write runtime file: $!";
4122 };
4123 }
4124
4125 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
4126 $sig->send;
4127 }
4128 $WAIT_FOR_TICK->broadcast;
4129
4130 $LOAD = ($NOW - $TICK_START) / $TICK;
4131 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
4132
4133 if (0) {
4134 if ($NEXT_TICK) {
4135 my $jitter = $TICK_START - $NEXT_TICK;
4136 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
4137 debug "jitter $JITTER\n";#d#
4138 }
4139 }
4140}
4141
4142{
4143 # configure BDB
4144
4145 BDB::min_parallel 16;
4146 BDB::max_poll_reqs $TICK * 0.1;
4147 #$AnyEvent::BDB::WATCHER->priority (1);
4148
4149 unless ($DB_ENV) {
4150 $DB_ENV = BDB::db_env_create;
4151 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
4152 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
4153 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
4154 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
4155 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
4156
4157 cf::sync_job {
4158 eval {
4159 BDB::db_env_open
4160 $DB_ENV,
4161 $BDBDIR,
4162 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
4163 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
4164 0666;
4165
4166 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
4167 };
4168
4169 cf::cleanup "db_env_open(db): $@" if $@;
4170 };
4171 }
4172
4173 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
4174 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
4175 };
4176 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
4177 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
4178 };
4179 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
4180 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
4181 };
4182}
4183
4184{
4185 # configure IO::AIO
4186
4187 IO::AIO::min_parallel 8;
4188 IO::AIO::max_poll_time $TICK * 0.1;
4189 undef $AnyEvent::AIO::WATCHER;
4190}
4191
4192our $_log_backtrace;
4193our $_log_backtrace_last;
4194
4195sub _log_backtrace {
4196 my ($msg, @addr) = @_;
4197
4198 $msg =~ s/\n$//;
4199
4200 if ($_log_backtrace_last eq $msg) {
4201 LOG llevInfo, "[ABT] $msg\n";
4202 LOG llevInfo, "[ABT] [duplicate, suppressed]\n";
4203 # limit the # of concurrent backtraces
4204 } elsif ($_log_backtrace < 2) {
4205 $_log_backtrace_last = $msg;
4206 ++$_log_backtrace;
4207 my $perl_bt = Carp::longmess $msg;
4208 async {
4209 $Coro::current->{desc} = "abt $msg";
4210
4211 my @bt = fork_call {
4212 @addr = map { sprintf "%x", $_ } @addr;
4213 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
4214 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
4215 or die "addr2line: $!";
4216
4217 my @funcs;
4218 my @res = <$fh>;
4219 chomp for @res;
4220 while (@res) {
4221 my ($func, $line) = splice @res, 0, 2, ();
4222 push @funcs, "[$func] $line";
4223 }
4224
4225 @funcs
4226 };
4227
4228 LOG llevInfo, "[ABT] $perl_bt\n";
4229 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
4230 LOG llevInfo, "[ABT] $_\n" for @bt;
4231 --$_log_backtrace;
4232 };
4233 } else {
4234 LOG llevInfo, "[ABT] $msg\n";
4235 LOG llevInfo, "[ABT] [overload, suppressed]\n";
4236 }
4237}
4238
4239# load additional modules
4240require "cf/$_.pm" for @EXTRA_MODULES;
4241cf::_connect_to_perl_2;
4242
4243END { cf::emergency_save }
721 4244
7221 42451
723 4246

Diff Legend

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