ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/server/lib/cf.pm
(Generate patch)

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.35 by root, Thu Aug 24 13:35:48 2006 UTC vs.
Revision 1.608 by root, Sun Nov 18 09:53:57 2012 UTC

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

Diff Legend

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