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.36 by root, Thu Aug 24 14:04:29 2006 UTC vs.
Revision 1.549 by root, Tue May 11 13:19:59 2010 UTC

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

Diff Legend

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