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

Diff Legend

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