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.25 by root, Thu Jul 20 07:22:40 2006 UTC vs.
Revision 1.591 by root, Tue Nov 6 23:33:15 2012 UTC

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

Diff Legend

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