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.31 by elmex, Mon Aug 14 04:22:04 2006 UTC vs.
Revision 1.563 by root, Sat Apr 23 04:56:51 2011 UTC

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

Diff Legend

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