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.17 by root, Mon Jun 19 10:20:07 2006 UTC vs.
Revision 1.493 by root, Mon Oct 26 02:34:37 2009 UTC

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

Diff Legend

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