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.37 by root, Thu Aug 24 14:05:22 2006 UTC vs.
Revision 1.530 by root, Wed Apr 28 21:05:33 2010 UTC

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

Diff Legend

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