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.16 by root, Mon Jun 12 13:25:27 2006 UTC vs.
Revision 1.606 by root, Sun Nov 18 08:34:23 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;
29use Socket;
30use EV;
31use Opcode;
32use Safe;
33use Safe::Hole;
5use Storable; 34use Storable ();
35use Carp ();
6 36
7use strict; 37use AnyEvent ();
38use AnyEvent::IO ();
39use AnyEvent::DNS ();
8 40
9our %COMMAND; 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 ();
55
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
10our @EVENT; 98our @EVENT;
11our %PROP_TYPE; 99our @REFLECT; # set by XS
12our %PROP_IDX; 100our %REFLECT; # set by us
13 101
14BEGIN { 102our $CONFDIR = confdir;
15 @EVENT = map lc, @EVENT;
16 103
17 *CORE::GLOBAL::warn = sub { 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
128our $NEXT_TICK;
129our $USE_FSYNC = 1; # use fsync to write maps - default on
130
131our $BDB_DEADLOCK_WATCHER;
132our $BDB_CHECKPOINT_WATCHER;
133our $BDB_TRICKLE_WATCHER;
134our $DB_ENV;
135
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 {
18 my $msg = join "", @_; 301 my $msg = join "", @_;
302
19 $msg .= "\n" 303 $msg .= "\n"
20 unless $msg =~ /\n$/; 304 unless $msg =~ /\n$/;
21 305
22 print STDERR "cfperl: $msg"; 306 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
23 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 $!;
24 }; 820 };
25} 821 cf::cleanup "db_open(db): $@" if $@;
26 822
27my %ignore_set = (MAP_PROP_PATH => 1); # I hate the plug-in api. Deeply! 823 $db
824}
28 825
29# generate property mutators 826our $DB;
30sub prop_gen {
31 my ($prefix, $class) = @_;
32 827
33 no strict 'refs'; 828sub db_init {
829 $DB ||= db_table "db";
830}
34 831
35 for my $prop (keys %PROP_TYPE) { 832sub db_get($$) {
36 $prop =~ /^\Q$prefix\E_(.*$)/ or next; 833 my $key = "$_[0]/$_[1]";
37 my $sub = lc $1;
38 834
39 my $type = $PROP_TYPE{$prop}; 835 cf::error "db_get called from main context"
40 my $idx = $PROP_IDX {$prop}; 836 if $Coro::current == $Coro::main;
41 837
42 *{"$class\::get_$sub"} = *{"$class\::$sub"} = sub { 838 BDB::db_get $DB, undef, $key, my $data;
43 $_[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->[$_];
44 }; 880 }
45 881
46 *{"$class\::set_$sub"} = sub { 882 # if processing is expensive, check
47 $_[0]->set_property ($type, $idx, $_[1]); 883 # checksum first
48 } unless $ignore_set{$prop}; 884 if (1) {
49 } 885 $md5 =
50} 886 join "\x00",
887 $processversion,
888 map {
889 cf::cede_to_tick;
890 ($src->[$_], Digest::MD5::md5_hex $data[$_])
891 } 0.. $#$src;
892
51 893
52# 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;
53 897
54prop_gen OBJECT_PROP => "cf::object"; 898 return db_get cache => "$id/data";
55# CFAPI_OBJECT_ANIMATION? 899 }
56prop_gen PLAYER_PROP => "cf::object::player"; 900 }
57 901
58prop_gen MAP_PROP => "cf::map"; 902 my $t1 = EV::time;
59prop_gen ARCH_PROP => "cf::arch"; 903 my $data = $process->(\@data);
904 my $t2 = EV::time;
60 905
61# guessed hierarchies 906 info "cache: '$id' processed in ", $t2 - $t1, "s\n";
62 907
63@cf::object::player::ISA = 'cf::object'; 908 db_put cache => "$id/data", $data;
64@cf::object::map::ISA = 'cf::object'; 909 db_put cache => "$id/md5" , $md5;
910 db_put cache => "$id/meta", $meta;
65 911
66my %ext_pkg; 912 return $data;
67my @exts; 913 }
68my @hook;
69my %command;
70my %extcmd;
71 914
72sub inject_event { 915 db_get cache => "$id/data"
73 my $extension = shift; 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;
1168};
1169
1170# all those should be optimised
1171sub cf::attachable::detach {
1172 my ($obj, $name) = @_;
1173
1174 if (ref $obj) {
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 {
74 my $event_code = shift; 1213 my $event = shift;
1214 my $callbacks = shift;
75 1215
76 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
77 or return; 1407 or return;
78 1408
79 &$cb 1409 unless (aio_stat "$filename.pst") {
80} 1410 (aio_load "$filename.pst", $av) >= 0
81
82sub inject_global_event {
83 my $event = shift;
84
85 my $cb = $hook[$event]
86 or return; 1411 or return;
87 1412
88 List::Util::max map &$_, values %$cb 1413 my $st = eval { Coro::Storable::thaw $av };
89} 1414 $av = $st->{objs};
90
91sub inject_command {
92 my ($name, $obj, $params) = @_;
93
94 for my $cmd (@{ $command{$name} }) {
95 $cmd->[1]->($obj, $params);
96 } 1415 }
97 1416
98 -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)
99} 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
100 1440
101sub register_command { 1441sub register_command {
102 my ($name, $time, $cb) = @_; 1442 my ($name, $cb) = @_;
103 1443
104 my $caller = caller; 1444 my $caller = caller;
105 #warn "registering command '$name/$time' to '$caller'"; 1445 #warn "registering command '$name/$time' to '$caller'";
106 1446
107 push @{ $command{$name} }, [$time, $cb, $caller]; 1447 push @{ $COMMAND{$name} }, [$caller, $cb];
108 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
109} 1448}
110 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
111sub register_extcmd { 1482sub register_extcmd($$) {
112 my ($name, $cb) = @_; 1483 my ($name, $cb) = @_;
113 1484
114 my $caller = caller; 1485 $EXTCMD{$name} = $cb;
115 #warn "registering extcmd '$name' to '$caller'";
116
117 $extcmd{$name} = [$cb, $caller];
118} 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
119 2022
120sub 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 {
2036 my ($self, $merge) = @_;
2037
2038 # we have to keep some variables in memory intact
2039 local $self->{path};
2040 local $self->{load_path};
2041
2042 $self->SUPER::thawer_merge ($merge);
2043}
2044
2045sub normalise {
2046 my ($path, $base) = @_;
2047
2048 $path = "$path"; # make sure it's a string
2049
2050 $path =~ s/\.map$//;
2051
2052 # map plan:
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
2060
2061 $path =~ s/$PATH_SEP/\//go;
2062
2063 # treat it as relative path if it starts with
2064 # something that looks reasonable
2065 if ($path =~ m{^(?:\./|\.\./|\w)}) {
2066 $base or Carp::carp "normalise called with relative path and no base: '$path'";
2067
2068 $base =~ s{[^/]+/?$}{};
2069 $path = "$base/$path";
2070 }
2071
2072 for ($path) {
2073 redo if s{/\.?/}{/};
2074 redo if s{/[^/]+/\.\./}{/};
2075 }
2076
2077 $path
2078}
2079
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 {
2102 my ($self) = @_;
2103
2104 $self
2105}
2106
2107sub as_string {
2108 my ($self) = @_;
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($) {
121 my ($base, $pkg) = @_; 2158 my ($self, $path) = @_;
122 2159
123 for my $idx (0 .. $#EVENT) { 2160 utf8::encode $path;
124 if (my $ref = $pkg->can ("on_$EVENT[$idx]")) { 2161 my $f = new_from_file cf::object::thawer $path
125 #warn "registering $EVENT[$idx] hook to '$pkg'\n"; 2162 or return;
126 $hook[$idx]{$base} = $ref; 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
2172 1
2173}
2174
2175# used to laod the header of an original map
2176sub load_header_orig {
2177 my ($self) = @_;
2178
2179 $self->load_header_from ($self->load_path)
2180}
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;
2305 } else {
2306 $self->post_load_original
2307 if delete $self->{load_original};
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
2333 1
2334}
2335
2336# customize the map for a given player, i.e.
2337# return the _real_ map. used by e.g. per-player
2338# maps to change the path to ~playername/mappath
2339sub customise_for {
2340 my ($self, $ob) = @_;
2341
2342 return find "~" . $ob->name . "/" . $self->{path}
2343 if $self->per_player;
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;
2392 }
2393
2394 delete $MAP_PREFETCH{$k};
2395 }
2396 }
2397 undef $MAP_PREFETCHER;
2398 };
2399 $MAP_PREFETCHER->prio (6);
2400
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);
2431 } else {
2432 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
2433 }
2434}
2435
2436sub save {
2437 my ($self) = @_;
2438
2439 my $lock = cf::lock_acquire "map_data:$self->{path}";
2440
2441 $self->_save;
2442}
2443
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/$_";
2615 }
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
2671 } else {
2672 warn "$ref: cannot resolve object reference\n";
2673 undef
2674 }
2675}
2676
2677package cf;
2678
2679=back
2680
2681=head3 cf::object::player
2682
2683=over 4
2684
2685=item $player_object->reply ($npc, $msg[, $flags])
2686
2687Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
2688can be C<undef>. Does the right thing when the player is currently in a
2689dialogue with the given NPC character.
2690
2691=cut
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
2707# rough implementation of a future "reply" method that works
2708# with dialog boxes.
2709#TODO: the first argument must go, split into a $npc->reply_to ( method
2710sub cf::object::player::reply($$$;$) {
2711 my ($self, $npc, $msg, $flags) = @_;
2712
2713 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
2714
2715 if ($self->{record_replies}) {
2716 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2717
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 {
2726 $msg = $npc->name . " says: $msg" if $npc;
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
127 } 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,
128 } 2935 };
129}
130 2936
131sub load_extension { 2937 for (split /\n/, $spec) {
2938 my ($k, $v) = split /\s+/, $_, 2;
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_drawinfo ($text, $flags)
3048
3049Sends a drawinfo packet to the client. Circumvents output buffering so
3050should not be used under normal circumstances.
3051
3052=cut
3053
3054sub cf::client::send_drawinfo {
3055 my ($self, $text, $flags) = @_;
3056
3057 utf8::encode $text;
3058 $self->send_packet (sprintf "msg %d 0 %s", $flags || cf::NDI_BLACK, $text);
3059}
3060
3061=item $client->send_big_packet ($pkt)
3062
3063Like C<send_packet>, but tries to compress large packets, and fragments
3064them as required.
3065
3066=cut
3067
3068our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
3069
3070sub cf::client::send_big_packet {
3071 my ($self, $pkt) = @_;
3072
3073 # try lzf for large packets
3074 $pkt = "lzf " . Compress::LZF::compress $pkt
3075 if 1024 <= length $pkt and $self->{can_lzf};
3076
3077 # split very large packets
3078 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
3079 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
3080 $pkt = "frag";
3081 }
3082
3083 $self->send_packet ($pkt);
3084}
3085
3086=item $client->send_msg ($channel, $msg, $color, [extra...])
3087
3088Send a msg packet to the client, formatting the msg for the client if
3089necessary. C<$type> should be a string identifying the type of the
3090message, with C<log> being the default. If C<$color> is negative, suppress
3091the message unless the client supports the msg packet.
3092
3093=cut
3094
3095# non-persistent channels (usually the info channel)
3096our %CHANNEL = (
3097 "c/motd" => {
3098 id => "infobox",
3099 title => "MOTD",
3100 reply => undef,
3101 tooltip => "The message of the day",
3102 },
3103 "c/identify" => {
3104 id => "infobox",
3105 title => "Identify",
3106 reply => undef,
3107 tooltip => "Items recently identified",
3108 },
3109 "c/examine" => {
3110 id => "infobox",
3111 title => "Examine",
3112 reply => undef,
3113 tooltip => "Signs and other items you examined",
3114 },
3115 "c/shopinfo" => {
3116 id => "infobox",
3117 title => "Shop Info",
3118 reply => undef,
3119 tooltip => "What your bargaining skill tells you about the shop",
3120 },
3121 "c/book" => {
3122 id => "infobox",
3123 title => "Book",
3124 reply => undef,
3125 tooltip => "The contents of a note or book",
3126 },
3127 "c/lookat" => {
3128 id => "infobox",
3129 title => "Look",
3130 reply => undef,
3131 tooltip => "What you saw there",
3132 },
3133 "c/who" => {
3134 id => "infobox",
3135 title => "Players",
3136 reply => undef,
3137 tooltip => "Shows players who are currently online",
3138 },
3139 "c/body" => {
3140 id => "infobox",
3141 title => "Body Parts",
3142 reply => undef,
3143 tooltip => "Shows which body parts you posess and are available",
3144 },
3145 "c/statistics" => {
3146 id => "infobox",
3147 title => "Statistics",
3148 reply => undef,
3149 tooltip => "Shows your primary statistics",
3150 },
3151 "c/skills" => {
3152 id => "infobox",
3153 title => "Skills",
3154 reply => undef,
3155 tooltip => "Shows your experience per skill and item power",
3156 },
3157 "c/shopitems" => {
3158 id => "infobox",
3159 title => "Shop Items",
3160 reply => undef,
3161 tooltip => "Shows the items currently for sale in this shop",
3162 },
3163 "c/resistances" => {
3164 id => "infobox",
3165 title => "Resistances",
3166 reply => undef,
3167 tooltip => "Shows your resistances",
3168 },
3169 "c/pets" => {
3170 id => "infobox",
3171 title => "Pets",
3172 reply => undef,
3173 tooltip => "Shows information abotu your pets/a specific pet",
3174 },
3175 "c/perceiveself" => {
3176 id => "infobox",
3177 title => "Perceive Self",
3178 reply => undef,
3179 tooltip => "You gained detailed knowledge about yourself",
3180 },
3181 "c/uptime" => {
3182 id => "infobox",
3183 title => "Uptime",
3184 reply => undef,
3185 tooltip => "How long the server has been running since last restart",
3186 },
3187 "c/mapinfo" => {
3188 id => "infobox",
3189 title => "Map Info",
3190 reply => undef,
3191 tooltip => "Information related to the maps",
3192 },
3193 "c/party" => {
3194 id => "party",
3195 title => "Party",
3196 reply => "gsay ",
3197 tooltip => "Messages and chat related to your party",
3198 },
3199 "c/death" => {
3200 id => "death",
3201 title => "Death",
3202 reply => undef,
3203 tooltip => "Reason for and more info about your most recent death",
3204 },
3205 "c/fatal" => {
3206 id => "fatal",
3207 title => "Fatal Error",
3208 reply => undef,
3209 tooltip => "Reason for the server disconnect",
3210 },
3211 "c/say" => $SAY_CHANNEL,
3212 "c/chat" => $CHAT_CHANNEL,
3213);
3214
3215sub cf::client::send_msg {
3216 my ($self, $channel, $msg, $color, @extra) = @_;
3217
3218 $msg = $self->pl->expand_cfpod ($msg)
3219 unless $color & cf::NDI_VERBATIM;
3220
3221 $color &= cf::NDI_CLIENT_MASK; # just in case...
3222
3223 # check predefined channels, for the benefit of C
3224 if ($CHANNEL{$channel}) {
3225 $channel = $CHANNEL{$channel};
3226
3227 $self->ext_msg (channel_info => $channel);
3228 $channel = $channel->{id};
3229
3230 } elsif (ref $channel) {
3231 # send meta info to client, if not yet sent
3232 unless (exists $self->{channel}{$channel->{id}}) {
3233 $self->{channel}{$channel->{id}} = $channel;
3234 $self->ext_msg (channel_info => $channel);
3235 }
3236
3237 $channel = $channel->{id};
3238 }
3239
3240 return unless @extra || length $msg;
3241
3242 # default colour, mask it out
3243 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
3244 if $color & cf::NDI_DEF;
3245
3246 my $pkt = "msg "
3247 . $self->{json_coder}->encode (
3248 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
3249 );
3250
3251 $self->send_big_packet ($pkt);
3252}
3253
3254=item $client->ext_msg ($type, @msg)
3255
3256Sends an ext event to the client.
3257
3258=cut
3259
3260sub cf::client::ext_msg($$@) {
3261 my ($self, $type, @msg) = @_;
3262
3263 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
3264}
3265
3266=item $success = $client->query ($flags, "text", \&cb)
3267
3268Queues a query to the client, calling the given callback with
3269the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
3270C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
3271
3272Queries can fail, so check the return code. Or don't, as queries will
3273become reliable at some point in the future.
3274
3275=cut
3276
3277sub cf::client::query {
3278 my ($self, $flags, $text, $cb) = @_;
3279
3280 return unless $self->state == ST_PLAYING
3281 || $self->state == ST_SETUP
3282 || $self->state == ST_CUSTOM;
3283
3284 $self->state (ST_CUSTOM);
3285
3286 utf8::encode $text;
3287 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
3288
3289 $self->send_packet ($self->{query_queue}[0][0])
3290 if @{ $self->{query_queue} } == 1;
3291
3292 1
3293}
3294
3295cf::client->attach (
3296 on_connect => sub {
3297 my ($ns) = @_;
3298
3299 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
3300 },
3301 on_reply => sub {
3302 my ($ns, $msg) = @_;
3303
3304 # this weird shuffling is so that direct followup queries
3305 # get handled first
3306 my $queue = delete $ns->{query_queue}
3307 or return; # be conservative, not sure how that can happen, but we saw a crash here
3308
3309 (shift @$queue)->[1]->($msg);
3310 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
3311
3312 push @{ $ns->{query_queue} }, @$queue;
3313
3314 if (@{ $ns->{query_queue} } == @$queue) {
3315 if (@$queue) {
3316 $ns->send_packet ($ns->{query_queue}[0][0]);
3317 } else {
3318 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
3319 }
3320 }
3321 },
3322 on_exticmd => sub {
3323 my ($ns, $buf) = @_;
3324
3325 my $msg = eval { $ns->{json_coder}->decode ($buf) };
3326
3327 if (ref $msg) {
3328 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
3329
3330 if (my $cb = $EXTIACMD{$type}) {
3331 $cb->(
3332 $ns,
3333 sub {
3334 $ns->ext_msg ("reply-$reply", @_)
3335 if $reply;
3336 },
3337 @payload
3338 );
3339 } else {
3340 my @reply;
3341
3342 if (my $cb = $EXTICMD{$type}) {
3343 @reply = $cb->($ns, @payload);
3344 }
3345
3346 $ns->ext_msg ("reply-$reply", @reply)
3347 if $reply;
3348 }
3349 } else {
3350 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3351 }
3352
3353 cf::override;
3354 },
3355);
3356
3357=item $client->async (\&cb)
3358
3359Create a new coroutine, running the specified callback. The coroutine will
3360be automatically cancelled when the client gets destroyed (e.g. on logout,
3361or loss of connection).
3362
3363=cut
3364
3365sub cf::client::async {
3366 my ($self, $cb) = @_;
3367
3368 my $coro = &Coro::async ($cb);
3369
3370 $coro->on_destroy (sub {
3371 delete $self->{_coro}{$coro+0};
3372 });
3373
3374 $self->{_coro}{$coro+0} = $coro;
3375
3376 $coro
3377}
3378
3379cf::client->attach (
3380 on_client_destroy => sub {
3381 my ($ns) = @_;
3382
3383 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
3384 },
3385);
3386
3387=back
3388
3389
3390=head2 SAFE SCRIPTING
3391
3392Functions that provide a safe environment to compile and execute
3393snippets of perl code without them endangering the safety of the server
3394itself. Looping constructs, I/O operators and other built-in functionality
3395is not available in the safe scripting environment, and the number of
3396functions and methods that can be called is greatly reduced.
3397
3398=cut
3399
3400our $safe = new Safe "safe";
3401our $safe_hole = new Safe::Hole;
3402
3403$SIG{FPE} = 'IGNORE';
3404
3405$safe->permit_only (Opcode::opset qw(
3406 :base_core :base_mem :base_orig :base_math :base_loop
3407 grepstart grepwhile mapstart mapwhile
3408 sort time
3409));
3410
3411# here we export the classes and methods available to script code
3412
3413=pod
3414
3415The following functions and methods are available within a safe environment:
3416
3417 cf::object
3418 contr pay_amount pay_player map x y force_find force_add destroy
3419 insert remove name archname title slaying race decrease split
3420 value
3421
3422 cf::object::player
3423 player
3424
3425 cf::player
3426 peaceful
3427
3428 cf::map
3429 trigger
3430
3431=cut
3432
3433for (
3434 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3435 insert remove inv nrof name archname title slaying race
3436 decrease split destroy change_exp value msg lore send_msg)],
3437 ["cf::object::player" => qw(player)],
3438 ["cf::player" => qw(peaceful send_msg)],
3439 ["cf::map" => qw(trigger)],
3440) {
3441 my ($pkg, @funs) = @$_;
3442 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
3443 for @funs;
3444}
3445
3446=over 4
3447
3448=item @retval = safe_eval $code, [var => value, ...]
3449
3450Compiled and executes the given perl code snippet. additional var/value
3451pairs result in temporary local (my) scalar variables of the given name
3452that are available in the code snippet. Example:
3453
3454 my $five = safe_eval '$first + $second', first => 1, second => 4;
3455
3456=cut
3457
3458sub safe_eval($;@) {
3459 my ($code, %vars) = @_;
3460
3461 my $qcode = $code;
3462 $qcode =~ s/"/‟/g; # not allowed in #line filenames
3463 $qcode =~ s/\n/\\n/g;
3464
3465 %vars = (_dummy => 0) unless %vars;
3466
3467 my @res;
3468 local $_;
3469
3470 my $eval =
3471 "do {\n"
3472 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
3473 . "#line 0 \"{$qcode}\"\n"
3474 . $code
3475 . "\n}"
3476 ;
3477
3478 if ($CFG{safe_eval}) {
3479 sub_generation_inc;
3480 local @safe::cf::_safe_eval_args = values %vars;
3481 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
3482 sub_generation_inc;
3483 } else {
3484 local @cf::_safe_eval_args = values %vars;
3485 @res = wantarray ? eval eval : scalar eval $eval;
3486 }
3487
3488 if ($@) {
3489 warn "$@",
3490 "while executing safe code '$code'\n",
3491 "with arguments " . (join " ", %vars) . "\n";
3492 }
3493
3494 wantarray ? @res : $res[0]
3495}
3496
3497=item cf::register_script_function $function => $cb
3498
3499Register a function that can be called from within map/npc scripts. The
3500function should be reasonably secure and should be put into a package name
3501like the extension.
3502
3503Example: register a function that gets called whenever a map script calls
3504C<rent::overview>, as used by the C<rent> extension.
3505
3506 cf::register_script_function "rent::overview" => sub {
3507 ...
3508 };
3509
3510=cut
3511
3512sub register_script_function {
3513 my ($fun, $cb) = @_;
3514
3515 $fun = "safe::$fun" if $CFG{safe_eval};
3516 *$fun = $safe_hole->wrap ($cb);
3517}
3518
3519=back
3520
3521=cut
3522
3523#############################################################################
3524# the server's init and main functions
3525
3526{
3527 package cf::face;
3528
3529 our %HASH; # hash => idx
3530 our @DATA; # dynamically-created facedata, only faceste 0 used
3531 our @FOFS; # file offset, if > 0
3532 our @SIZE; # size of face, in octets
3533 our @META; # meta hash of face, if any
3534 our $DATAFH; # facedata filehandle
3535
3536 # internal api, not finalised
3537 sub set {
3538 my ($name, $type, $data) = @_;
3539
3540 my $idx = cf::face::find $name;
3541
3542 if ($idx) {
3543 delete $HASH{cf::face::get_csum $idx};
3544 } else {
3545 $idx = cf::face::alloc $name;
3546 }
3547
3548 my $hash = cf::face::mangle_csum Digest::MD5::md5 $data;
3549
3550 cf::face::set_type $idx, $type;
3551 cf::face::set_csum $idx, 0, $hash;
3552
3553 # we need to destroy the SV itself, not just modify it, as a running ix
3554 # might hold a reference to it: "delete" achieves that.
3555 delete $FOFS[0][$idx];
3556 delete $DATA[0][$idx];
3557 $DATA[0][$idx] = $data;
3558 $SIZE[0][$idx] = length $data;
3559 delete $META[$idx];
3560 $HASH{$hash} = $idx;#d#
3561
3562 $idx
3563 }
3564
3565 sub _get_data($$$) {
3566 my ($idx, $set, $cb) = @_;
3567
3568 if (defined $DATA[$set][$idx]) {
3569 $cb->($DATA[$set][$idx]);
3570 } elsif (my $fofs = $FOFS[$set][$idx]) {
3571 my $size = $SIZE[$set][$idx];
3572 my $buf;
3573 IO::AIO::aio_read $DATAFH, $fofs, $size, $buf, 0, sub {
3574 if ($_[0] == $size) {
3575 #cf::debug "read face $idx, $size from $fofs as ", length $buf;#d#
3576 $cb->($buf);
3577 } else {
3578 cf::error "INTERNAL ERROR: unable to read facedata for face $idx#$set ($size, $fofs), ignoring request.";
3579 }
3580 };
3581 } else {
3582 cf::error "requested facedata for unknown face $idx#$set, ignoring.";
3583 }
3584 }
3585
3586 # rather ineffient
3587 sub cf::face::get_data($;$) {
3588 my ($idx, $set) = @_;
3589
3590 _get_data $idx, $set, Coro::rouse_cb;
3591 Coro::rouse_wait
3592 }
3593
3594 sub cf::face::ix {
3595 my ($ns, $set, $idx, $pri) = @_;
3596
3597 _get_data $idx, $set, sub {
3598 $ns->ix_send ($idx, $pri, $_[0]);
3599 };
3600 }
3601}
3602
3603sub load_facedata($) {
132 my ($path) = @_; 3604 my ($path) = @_;
133 3605
134 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 3606 my $enc = JSON::XS->new->utf8->canonical->relaxed;
135 my $base = $1;
136 my $pkg = $1;
137 $pkg =~ s/[^[:word:]]/_/g;
138 $pkg = "cf::ext::$pkg";
139 3607
140 warn "loading '$path' into '$pkg'\n"; 3608 trace "loading facedata from $path\n";
141 3609
142 open my $fh, "<:utf8", $path 3610 my $facedata = decode_storable load_file "$path/faceinfo";
143 or die "$path: $!";
144 3611
145 my $source = 3612 $facedata->{version} == 2
146 "package $pkg; use strict; use utf8;\n" 3613 or cf::cleanup "$path/faceinfo: version mismatch, cannot proceed.";
147 . "#line 1 \"$path\"\n{\n"
148 . (do { local $/; <$fh> })
149 . "\n};\n1";
150 3614
151 eval $source 3615 my $fh = aio_open "$DATADIR/facedata", IO::AIO::O_RDONLY, 0
152 or die "$path: $@"; 3616 or cf::cleanup "$path/facedata: $!, cannot proceed.";
153 3617
154 push @exts, $pkg; 3618 get_slot 1, -100, "load_facedata"; # make sure we get a very big slot
155 $ext_pkg{$base} = $pkg;
156 3619
157# no strict 'refs'; 3620 # BEGIN ATOMIC
158# @{"$pkg\::ISA"} = cf::ext::; 3621 # from here on, everything must be atomic - no thread switch allowed
3622 my $t1 = EV::time;
159 3623
160 register $base, $pkg;
161}
162
163sub unload_extension {
164 my ($pkg) = @_;
165
166 warn "removing extension $pkg\n";
167
168 # remove hooks
169 for my $idx (0 .. $#EVENT) {
170 delete $hook[$idx]{$pkg};
171 } 3624 {
3625 my $faces = $facedata->{faceinfo};
172 3626
173 # remove commands 3627 for my $face (sort keys %$faces) {
174 for my $name (keys %command) { 3628 my $info = $faces->{$face};
175 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 3629 my $idx = (cf::face::find $face) || cf::face::alloc $face;
176 3630
177 if (@cb) { 3631 cf::face::set_visibility $idx, $info->{visibility};
178 $command{$name} = \@cb; 3632 cf::face::set_magicmap $idx, $info->{magicmap};
179 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb; 3633 cf::face::set_csum $idx, 0, $info->{hash64}; $cf::face::SIZE[0][$idx] = $info->{size64}; $cf::face::FOFS[0][$idx] = $info->{fofs64};
3634 cf::face::set_csum $idx, 1, $info->{hash32}; $cf::face::SIZE[1][$idx] = $info->{size32}; $cf::face::FOFS[1][$idx] = $info->{fofs32};
3635 cf::face::set_csum $idx, 2, $info->{glyph}; $cf::face::DATA[2][$idx] = $info->{glyph};
3636 $cf::face::HASH{$info->{hash64}} = $idx;
3637 delete $cf::face::META[$idx];
3638 }
3639
3640 while (my ($face, $info) = each %$faces) {
3641 next unless $info->{smooth};
3642
3643 my $idx = cf::face::find $face
3644 or next;
3645
3646 if (my $smooth = cf::face::find $info->{smooth}) {
3647 cf::face::set_smooth $idx, $smooth;
3648 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
180 } else { 3649 } else {
181 delete $command{$name}; 3650 error "smooth face '$info->{smooth}' not found for face '$face'";
182 delete $COMMAND{"$name\000"};
183 } 3651 }
3652 }
3653 }
3654
184 } 3655 {
3656 my $anims = $facedata->{animinfo};
185 3657
186 # remove extcmds 3658 while (my ($anim, $info) = each %$anims) {
187 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 3659 cf::anim::set $anim, $info->{frames}, $info->{facings};
188 delete $extcmd{$name}; 3660 }
3661
3662 cf::anim::invalidate_all; # d'oh
3663 }
3664
189 } 3665 {
3666 my $res = $facedata->{resource};
190 3667
191 Symbol::delete_package $pkg; 3668 while (my ($name, $info) = each %$res) {
192} 3669 if (defined (my $type = $info->{type})) {
3670 # TODO: different hash - must free and use new index, or cache ixface data queue
3671 my $idx = (cf::face::find $name) || cf::face::alloc $name;
193 3672
3673 cf::face::set_type $idx, $type;
3674 cf::face::set_csum $idx, 0, $info->{hash};
3675 $cf::face::SIZE[0][$idx] = $info->{size};
3676 $cf::face::FOFS[0][$idx] = $info->{fofs};
3677 $cf::face::META[$idx] = $type & 1 ? undef : $info->{meta}; # preserve meta unless prepended already
3678 $cf::face::HASH{$info->{hash}} = $idx;
3679 } else {
3680# $RESOURCE{$name} = $info; # unused
3681 }
3682 }
3683 }
3684
3685 ($fh, $cf::face::DATAFH) = ($cf::face::DATAFH, $fh);
3686
3687 # HACK to clear player env face cache, we need some signal framework
3688 # for this (global event?)
3689 %ext::player_env::MUSIC_FACE_CACHE = ();
3690
3691 # END ATOMIC
3692
3693 cf::debug "facedata atomic update time ", EV::time - $t1;
3694
3695 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3696
3697 aio_close $fh if $fh; # close old facedata
3698
3699 1
3700}
3701
3702register_exticmd fx_want => sub {
3703 my ($ns, $want) = @_;
3704
3705 while (my ($k, $v) = each %$want) {
3706 $ns->fx_want ($k, $v);
3707 }
3708};
3709
3710sub load_resource_file($) {
3711 my $guard = lock_acquire "load_resource_file";
3712
3713 my $status = load_resource_file_ $_[0];
3714 get_slot 0.1, 100;
3715 cf::arch::commit_load;
3716
3717 $status
3718}
3719
3720sub reload_exp_table {
3721 _reload_exp_table;
3722
3723 cf::face::set
3724 "res/exp_table" => FT_RSRC,
3725 JSON::XS->new->utf8->canonical->encode (
3726 [map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]
3727 );
3728}
3729
3730sub reload_materials {
3731 _reload_materials;
3732}
3733
194sub load_extensions { 3734sub reload_regions {
195 my $LIBDIR = maps_directory "perl"; 3735 # HACK to clear player env face cache, we need some signal framework
3736 # for this (global event?)
3737 %ext::player_env::MUSIC_FACE_CACHE = ();
196 3738
197 for my $ext (<$LIBDIR/*.ext>) { 3739 load_resource_file "$MAPDIR/regions"
198 next unless -r $ext; 3740 or die "unable to load regions file\n";
3741
3742 for (cf::region::list) {
3743 $_->{match} = qr/$_->{match}/
3744 if exists $_->{match};
3745 }
3746}
3747
3748sub reload_facedata {
3749 load_facedata $DATADIR
3750 or die "unable to load facedata\n";
3751}
3752
3753sub reload_archetypes {
3754 load_resource_file "$DATADIR/archetypes"
3755 or die "unable to load archetypes\n";
3756
3757 cf::face::set
3758 "res/skill_info" => FT_RSRC,
3759 JSON::XS->new->utf8->canonical->encode (
3760 [map [cf::arch::skillvec ($_)->name], 0 .. cf::arch::skillvec_size - 1]
3761 );
3762
3763 cf::face::set
3764 "res/spell_paths" => FT_RSRC,
3765 JSON::XS->new->utf8->canonical->encode (
3766 [map [cf::spellpathnames ($_)], 0 .. NRSPELLPATHS - 1]
3767 );
3768}
3769
3770sub reload_treasures {
3771 load_resource_file "$DATADIR/treasures"
3772 or die "unable to load treasurelists\n";
3773}
3774
3775sub reload_sound {
3776 trace "loading sound config from $DATADIR/sound\n";
3777
3778 my $soundconf = JSON::XS->new->utf8->relaxed->decode (load_file "$DATADIR/sound");
3779
3780 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3781 my $sound = $soundconf->{compat}[$_]
3782 or next;
3783
3784 my $face = cf::face::find "sound/$sound->[1]";
3785 cf::sound::set $sound->[0] => $face;
3786 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3787 }
3788
3789 while (my ($k, $v) = each %{$soundconf->{event}}) {
3790 my $face = cf::face::find "sound/$v";
3791 cf::sound::set $k => $face;
3792 }
3793}
3794
3795sub reload_resources {
3796 trace "reloading resource files...\n";
3797
3798 reload_materials;
3799 reload_facedata;
3800 reload_exp_table;
3801 reload_sound;
3802 reload_archetypes;
3803 reload_regions;
3804 reload_treasures;
3805
3806 trace "finished reloading resource files\n";
3807}
3808
3809sub reload_config {
3810 trace "reloading config file...\n";
3811
3812 my $config = load_file "$CONFDIR/config";
3813 utf8::decode $config;
3814 *CFG = decode_yaml $config;
3815
3816 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3817
3818 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3819 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3820
3821 if (exists $CFG{mlockall}) {
199 eval { 3822 eval {
200 load_extension $ext; 3823 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
201 1 3824 and die "WARNING: m(un)lockall failed: $!\n";
202 } or warn "$ext not loaded: $@";
203 }
204}
205
206register_command "perl-reload", 0, sub {
207 my ($who, $arg) = @_;
208
209 if ($who->flag (FLAG_WIZ)) {
210 $who->message ("reloading...");
211
212 warn "reloading...\n";
213 eval {
214 unload_extension $_ for @exts;
215 delete $INC{"cf.pm"};
216
217 # don't, removes xs symbols, too
218 #Symbol::delete_package $pkg;
219
220 require cf;
221 }; 3825 };
222 warn $@ if $@; 3826 warn $@ if $@;
223 $who->message ($@) if $@; 3827 }
224 warn "reloaded\n"; 3828}
225 3829
3830sub pidfile() {
3831 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3832 or die "$PIDFILE: $!";
3833 flock $fh, &Fcntl::LOCK_EX
3834 or die "$PIDFILE: flock: $!";
3835 $fh
3836}
3837
3838# make sure only one server instance is running at any one time
3839sub atomic {
3840 my $fh = pidfile;
3841
3842 my $pid = <$fh>;
3843 kill 9, $pid if $pid > 0;
3844
3845 seek $fh, 0, 0;
3846 print $fh $$;
3847}
3848
3849sub main_loop {
3850 trace "EV::loop starting\n";
3851 if (1) {
3852 EV::loop;
3853 }
3854 trace "EV::loop returned\n";
3855 goto &main_loop unless $REALLY_UNLOOP;
3856}
3857
3858sub main {
3859 cf::init_globals; # initialise logging
3860
3861 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3862 LOG llevInfo, "Copyright (C) 2005-2012 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3863 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3864 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3865
3866 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3867
3868 # we must not ever block the main coroutine
3869 $Coro::idle = sub {
3870 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3871 (async {
3872 $Coro::current->{desc} = "IDLE BUG HANDLER";
3873 EV::loop EV::LOOP_ONESHOT;
3874 })->prio (Coro::PRIO_MAX);
3875 };
3876
3877 evthread_start IO::AIO::poll_fileno;
3878
3879 cf::sync_job {
3880 cf::incloader::init ();
3881
3882 db_init;
3883
3884 cf::init_anim;
3885 cf::init_attackmess;
3886 cf::init_dynamic;
3887
3888 cf::load_settings;
3889
3890 reload_resources;
3891 reload_config;
3892
3893 cf::init_uuid;
3894 cf::init_signals;
3895 cf::init_skills;
3896
3897 cf::init_beforeplay;
3898
3899 atomic;
3900
3901 load_extensions;
3902
3903 utime time, time, $RUNTIMEFILE;
3904
3905 # no (long-running) fork's whatsoever before this point(!)
3906 use POSIX ();
3907 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3908
3909 cf::_post_init 0;
3910 };
3911
3912 cf::object::thawer::errors_are_fatal 0;
3913 info "parse errors in files are no longer fatal from this point on.\n";
3914
3915 AE::postpone {
3916 undef &main; # free gobs of memory :)
3917 };
3918
3919 goto &main_loop;
3920}
3921
3922#############################################################################
3923# initialisation and cleanup
3924
3925# install some emergency cleanup handlers
3926BEGIN {
3927 our %SIGWATCHER = ();
3928 for my $signal (qw(INT HUP TERM)) {
3929 $SIGWATCHER{$signal} = AE::signal $signal, sub {
3930 cf::cleanup "SIG$signal";
3931 };
3932 }
3933}
3934
3935sub write_runtime_sync {
3936 my $t0 = AE::time;
3937
3938 # first touch the runtime file to show we are still running:
3939 # the fsync below can take a very very long time.
3940
3941 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3942
3943 my $guard = cf::lock_acquire "write_runtime";
3944
3945 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3946 or return;
3947
3948 my $value = $cf::RUNTIME + 90 + 10;
3949 # 10 is the runtime save interval, for a monotonic clock
3950 # 60 allows for the watchdog to kill the server.
3951
3952 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3953 and return;
3954
3955 # always fsync - this file is important
3956 aio_fsync $fh
3957 and return;
3958
3959 # touch it again to show we are up-to-date
3960 aio_utime $fh, undef, undef;
3961
3962 close $fh
3963 or return;
3964
3965 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3966 and return;
3967
3968 trace sprintf "runtime file written (%gs).\n", AE::time - $t0;
3969
3970 1
3971}
3972
3973our $uuid_lock;
3974our $uuid_skip;
3975
3976sub write_uuid_sync($) {
3977 $uuid_skip ||= $_[0];
3978
3979 return if $uuid_lock;
3980 local $uuid_lock = 1;
3981
3982 my $uuid = "$LOCALDIR/uuid";
3983
3984 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3985 or return;
3986
3987 my $value = uuid_seq uuid_cur;
3988
3989 unless ($value) {
3990 info "cowardly refusing to write zero uuid value!\n";
3991 return;
3992 }
3993
3994 my $value = uuid_str $value + $uuid_skip;
3995 $uuid_skip = 0;
3996
3997 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3998 and return;
3999
4000 # always fsync - this file is important
4001 aio_fsync $fh
4002 and return;
4003
4004 close $fh
4005 or return;
4006
4007 aio_rename "$uuid~", $uuid
4008 and return;
4009
4010 trace "uuid file written ($value).\n";
4011
4012 1
4013
4014}
4015
4016sub write_uuid($$) {
4017 my ($skip, $sync) = @_;
4018
4019 $sync ? write_uuid_sync $skip
4020 : async { write_uuid_sync $skip };
4021}
4022
4023sub emergency_save() {
4024 my $freeze_guard = cf::freeze_mainloop;
4025
4026 info "emergency_perl_save: enter\n";
4027
4028 # this is a trade-off: we want to be very quick here, so
4029 # save all maps without fsync, and later call a global sync
4030 # (which in turn might be very very slow)
4031 local $USE_FSYNC = 0;
4032
4033 cf::sync_job {
4034 cf::write_runtime_sync; # external watchdog should not bark
4035
4036 # use a peculiar iteration method to avoid tripping on perl
4037 # refcount bugs in for. also avoids problems with players
4038 # and maps saved/destroyed asynchronously.
4039 info "emergency_perl_save: begin player save\n";
4040 for my $login (keys %cf::PLAYER) {
4041 my $pl = $cf::PLAYER{$login} or next;
4042 $pl->valid or next;
4043 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
4044 $pl->save;
4045 }
4046 info "emergency_perl_save: end player save\n";
4047
4048 cf::write_runtime_sync; # external watchdog should not bark
4049
4050 info "emergency_perl_save: begin map save\n";
4051 for my $path (keys %cf::MAP) {
4052 my $map = $cf::MAP{$path} or next;
4053 $map->valid or next;
4054 $map->save;
4055 }
4056 info "emergency_perl_save: end map save\n";
4057
4058 cf::write_runtime_sync; # external watchdog should not bark
4059
4060 info "emergency_perl_save: begin database checkpoint\n";
4061 BDB::db_env_txn_checkpoint $DB_ENV;
4062 info "emergency_perl_save: end database checkpoint\n";
4063
4064 info "emergency_perl_save: begin write uuid\n";
4065 write_uuid_sync 1;
4066 info "emergency_perl_save: end write uuid\n";
4067
4068 cf::write_runtime_sync; # external watchdog should not bark
4069
4070 trace "emergency_perl_save: syncing database to disk";
4071 BDB::db_env_txn_checkpoint $DB_ENV;
4072
4073 info "emergency_perl_save: starting sync\n";
4074 IO::AIO::aio_sync sub {
4075 info "emergency_perl_save: finished sync\n";
4076 };
4077
4078 cf::write_runtime_sync; # external watchdog should not bark
4079
4080 trace "emergency_perl_save: flushing outstanding aio requests";
4081 while (IO::AIO::nreqs || BDB::nreqs) {
4082 Coro::AnyEvent::sleep 0.01; # let the sync_job do it's thing
4083 }
4084
4085 cf::write_runtime_sync; # external watchdog should not bark
4086 };
4087
4088 info "emergency_perl_save: leave\n";
4089}
4090
4091sub post_cleanup {
4092 my ($make_core) = @_;
4093
4094 IO::AIO::flush;
4095
4096 error Carp::longmess "post_cleanup backtrace"
4097 if $make_core;
4098
4099 my $fh = pidfile;
4100 unlink $PIDFILE if <$fh> == $$;
4101}
4102
4103# a safer delete_package, copied from Symbol
4104sub clear_package($) {
4105 my $pkg = shift;
4106
4107 # expand to full symbol table name if needed
4108 unless ($pkg =~ /^main::.*::$/) {
4109 $pkg = "main$pkg" if $pkg =~ /^::/;
4110 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
4111 $pkg .= '::' unless $pkg =~ /::$/;
4112 }
4113
4114 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
4115 my $stem_symtab = *{$stem}{HASH};
4116
4117 defined $stem_symtab and exists $stem_symtab->{$leaf}
4118 or return;
4119
4120 # clear all symbols
4121 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
4122 for my $name (keys %$leaf_symtab) {
4123 _gv_clear *{"$pkg$name"};
4124# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
4125 }
4126}
4127
4128sub do_reload_perl() {
4129 # can/must only be called in main
4130 unless (in_main) {
4131 error "can only reload from main coroutine";
4132 return;
4133 }
4134
4135 return if $RELOAD++;
4136
4137 my $t1 = AE::time;
4138
4139 while ($RELOAD) {
4140 cf::get_slot 0.1, -1, "reload_perl";
4141 info "perl_reload: reloading...";
4142
4143 trace "perl_reload: entering sync_job";
4144
4145 cf::sync_job {
4146 #cf::emergency_save;
4147
4148 trace "perl_reload: cancelling all extension coros";
4149 $_->cancel for values %EXT_CORO;
4150 %EXT_CORO = ();
4151
4152 trace "perl_reload: removing commands";
4153 %COMMAND = ();
4154
4155 trace "perl_reload: removing ext/exti commands";
4156 %EXTCMD = ();
4157 %EXTICMD = ();
4158
4159 trace "perl_reload: unloading/nuking all extensions";
4160 for my $pkg (@EXTS) {
4161 trace "... unloading $pkg";
4162
4163 if (my $cb = $pkg->can ("unload")) {
4164 eval {
4165 $cb->($pkg);
4166 1
4167 } or error "$pkg unloaded, but with errors: $@";
4168 }
4169
4170 trace "... clearing $pkg";
4171 clear_package $pkg;
4172 }
4173
4174 trace "perl_reload: unloading all perl modules loaded from $LIBDIR";
4175 while (my ($k, $v) = each %INC) {
4176 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
4177
4178 trace "... unloading $k";
4179 delete $INC{$k};
4180
4181 $k =~ s/\.pm$//;
4182 $k =~ s/\//::/g;
4183
4184 if (my $cb = $k->can ("unload_module")) {
4185 $cb->();
4186 }
4187
4188 clear_package $k;
4189 }
4190
4191 trace "perl_reload: getting rid of safe::, as good as possible";
4192 clear_package "safe::$_"
4193 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
4194
4195 trace "perl_reload: unloading cf.pm \"a bit\"";
4196 delete $INC{"cf.pm"};
4197 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
4198
4199 # don't, removes xs symbols, too,
4200 # and global variables created in xs
4201 #clear_package __PACKAGE__;
4202
4203 info "perl_reload: unload completed, starting to reload now";
4204
4205 trace "perl_reload: reloading cf.pm";
4206 require cf;
4207 cf::_connect_to_perl_1;
4208
4209 trace "perl_reload: loading config and database again";
4210 cf::reload_config;
4211
4212 trace "perl_reload: loading extensions";
4213 cf::load_extensions;
4214
4215 if ($REATTACH_ON_RELOAD) {
4216 trace "perl_reload: reattaching attachments to objects/players";
4217 _global_reattach; # objects, sockets
4218 trace "perl_reload: reattaching attachments to maps";
4219 reattach $_ for values %MAP;
4220 trace "perl_reload: reattaching attachments to players";
4221 reattach $_ for values %PLAYER;
4222 }
4223
4224 cf::_post_init 1;
4225
4226 trace "perl_reload: leaving sync_job";
4227
4228 1
4229 } or do {
4230 error $@;
4231 cf::cleanup "perl_reload: error, exiting.";
4232 };
4233
4234 --$RELOAD;
4235 }
4236
4237 $t1 = AE::time - $t1;
4238 info "perl_reload: completed in ${t1}s\n";
4239};
4240
4241our $RELOAD_WATCHER; # used only during reload
4242
4243sub reload_perl() {
4244 # doing reload synchronously and two reloads happen back-to-back,
4245 # coro crashes during coro_state_free->destroy here.
4246
4247 $RELOAD_WATCHER ||= cf::async {
4248 Coro::AIO::aio_wait cache_extensions;
4249
4250 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
4251 do_reload_perl;
4252 undef $RELOAD_WATCHER;
4253 };
4254 };
4255}
4256
4257register_command "reload" => sub {
4258 my ($who, $arg) = @_;
4259
4260 if ($who->flag (FLAG_WIZ)) {
226 $who->message ("reloaded"); 4261 $who->message ("reloading server.");
4262 async {
4263 $Coro::current->{desc} = "perl_reload";
4264 reload_perl;
4265 };
4266 }
4267};
4268
4269#############################################################################
4270
4271my $bug_warning = 0;
4272
4273sub wait_for_tick() {
4274 return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
4275
4276 $WAIT_FOR_TICK->wait;
4277}
4278
4279sub wait_for_tick_begin() {
4280 return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
4281
4282 my $signal = new Coro::Signal;
4283 push @WAIT_FOR_TICK_BEGIN, $signal;
4284 $signal->wait;
4285}
4286
4287sub tick {
4288 if ($Coro::current != $Coro::main) {
4289 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
4290 unless ++$bug_warning > 10;
4291 return;
4292 }
4293
4294 cf::one_tick; # one server iteration
4295
4296 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
4297
4298 if ($NOW >= $NEXT_RUNTIME_WRITE) {
4299 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
4300 Coro::async_pool {
4301 $Coro::current->{desc} = "runtime saver";
4302 write_runtime_sync
4303 or error "ERROR: unable to write runtime file: $!";
4304 };
4305 }
4306
4307 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
4308 $sig->send;
4309 }
4310 $WAIT_FOR_TICK->broadcast;
4311
4312 $LOAD = ($NOW - $TICK_START) / $TICK;
4313 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
4314
4315 if (0) {
4316 if ($NEXT_TICK) {
4317 my $jitter = $TICK_START - $NEXT_TICK;
4318 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
4319 debug "jitter $JITTER\n";#d#
4320 }
4321 }
4322}
4323
4324{
4325 # configure BDB
4326 info "initialising database";
4327
4328 BDB::min_parallel 16;
4329 BDB::max_poll_reqs $TICK * 0.1;
4330 #$AnyEvent::BDB::WATCHER->priority (1);
4331
4332 unless ($DB_ENV) {
4333 $DB_ENV = BDB::db_env_create;
4334 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
4335 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
4336 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
4337 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
4338 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
4339
4340 cf::sync_job {
4341 eval {
4342 BDB::db_env_open
4343 $DB_ENV,
4344 $BDBDIR,
4345 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
4346 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
4347 0666;
4348
4349 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
4350 };
4351
4352 cf::cleanup "db_env_open(db): $@" if $@;
4353 };
4354 }
4355
4356 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
4357 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
4358 };
4359 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
4360 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
4361 };
4362 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
4363 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
4364 };
4365
4366 info "database initialised";
4367}
4368
4369{
4370 # configure IO::AIO
4371
4372 info "initialising aio";
4373 IO::AIO::min_parallel 8;
4374 IO::AIO::max_poll_time $TICK * 0.1;
4375 undef $AnyEvent::AIO::WATCHER;
4376 info "aio initialised";
4377}
4378
4379our $_log_backtrace;
4380our $_log_backtrace_last;
4381
4382sub _log_backtrace {
4383 my ($msg, @addr) = @_;
4384
4385 $msg =~ s/\n$//;
4386
4387 if ($_log_backtrace_last eq $msg) {
4388 LOG llevInfo, "[ABT] $msg\n";
4389 LOG llevInfo, "[ABT] [duplicate, suppressed]\n";
4390 # limit the # of concurrent backtraces
4391 } elsif ($_log_backtrace < 2) {
4392 $_log_backtrace_last = $msg;
4393 ++$_log_backtrace;
4394 my $perl_bt = Carp::longmess $msg;
4395 async {
4396 $Coro::current->{desc} = "abt $msg";
4397
4398 my @bt = fork_call {
4399 @addr = map { sprintf "%x", $_ } @addr;
4400 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
4401 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
4402 or die "addr2line: $!";
4403
4404 my @funcs;
4405 my @res = <$fh>;
4406 chomp for @res;
4407 while (@res) {
4408 my ($func, $line) = splice @res, 0, 2, ();
4409 push @funcs, "[$func] $line";
4410 }
4411
4412 @funcs
4413 };
4414
4415 LOG llevInfo, "[ABT] $perl_bt\n";
4416 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
4417 LOG llevInfo, "[ABT] $_\n" for @bt;
4418 --$_log_backtrace;
4419 };
227 } else { 4420 } else {
228 $who->message ("Intruder Alert!"); 4421 LOG llevInfo, "[ABT] $msg\n";
4422 LOG llevInfo, "[ABT] [overload, suppressed]\n";
229 } 4423 }
230};
231
232#############################################################################
233# extcmd framework, basically convert ext <id> <pkg> arg1 args
234# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
235
236sub on_extcmd {
237 my ($pl, $buf) = @_;
238
239 my ($type) = $buf =~ s/^(\S+) // ? $1 : "";
240
241 $extcmd{$type}[0]->($pl, $buf)
242 if $extcmd{$type};
243} 4424}
244 4425
245############################################################################# 4426# load additional modules
246# load/save/clean perl data associated with a map 4427require "cf/$_.pm" for @EXTRA_MODULES;
4428cf::_connect_to_perl_2;
247 4429
248*on_mapclean = sub { 4430END { cf::emergency_save }
249 my ($map) = @_;
250
251 my $path = $map->tmpname;
252 defined $path or return;
253
254 unlink "$path.cfperl";
255};
256
257*on_mapin =
258*on_mapload = sub {
259 my ($map) = @_;
260
261 my $path = $map->tmpname;
262 $path = $map->path unless defined $path;
263
264 open my $fh, "<:raw", "$path.cfperl"
265 or return; # no perl data
266
267 my $data = Storable::thaw do { local $/; <$fh> };
268
269 $data->{version} <= 1
270 or return; # too new
271
272 $map->_set_obs ($data->{obs});
273};
274
275*on_mapout = sub {
276 my ($map) = @_;
277
278 my $path = $map->tmpname;
279 $path = $map->path unless defined $path;
280
281 my $obs = $map->_get_obs;
282
283 if (defined $obs) {
284 open my $fh, ">:raw", "$path.cfperl"
285 or die "$path.cfperl: $!";
286
287 stat $path;
288
289 print $fh Storable::nfreeze {
290 size => (stat _)[7],
291 time => (stat _)[9],
292 version => 1,
293 obs => $obs,
294 };
295
296 chmod SAVE_MODE, "$path.cfperl"; # very racy, but cf-compatible *g*
297 } else {
298 unlink "$path.cfperl";
299 }
300};
301
302#############################################################################
303# load/save perl data associated with player->ob objects
304
305*on_player_load = sub {
306 my ($ob, $path) = @_;
307
308 if (open my $fh, "<:raw", "$path.cfperl") {
309
310 #d##TODO#remove
311
312 my $data = Storable::thaw do { local $/; <$fh> };
313
314 $data->{version} <= 1
315 or return; # too new
316
317 %$ob = %{$data->{ob}};
318 return;
319 }
320
321 for my $o ($ob, $ob->inv) {
322 if (my $value = $o->get_ob_key_value ("_perl_data")) {
323 $o->set_ob_key_value ("_perl_data");
324
325 %$o = %{ Storable::thaw pack "H*", $value };
326 }
327 }
328};
329
330*on_player_save = sub {
331 my ($ob, $path) = @_;
332
333 $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_)
334 for grep %$_, $ob, $ob->inv;
335
336 unlink "$path.cfperl";#d##TODO#remove
337};
338
339register "<global>", __PACKAGE__;
340
341load_extensions;
342 4431
3431 44321
344 4433

Diff Legend

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