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.38 by root, Thu Aug 24 17:29:30 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 @PLUGIN_EVENT; 94our @REFLECT; # set by XS
19our %PROP_TYPE; 95our %REFLECT; # set by us
20our %PROP_IDX;
21our $LIBDIR = maps_directory "perl";
22 96
23our $TICK = MAX_TIME * 1e-6; 97our $CONFDIR = confdir;
24our $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
25our $NEXT_TICK; 121our $NEXT_TICK;
122our $USE_FSYNC = 1; # use fsync to write maps - default on
26 123
27BEGIN { 124our $BDB_DEADLOCK_WATCHER;
28 @PLUGIN_EVENT = map lc, @PLUGIN_EVENT; 125our $BDB_CHECKPOINT_WATCHER;
126our $BDB_TRICKLE_WATCHER;
127our $DB_ENV;
29 128
30 *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 {
31 my $msg = join "", @_; 258 my $msg = join "", @_;
259
32 $msg .= "\n" 260 $msg .= "\n"
33 unless $msg =~ /\n$/; 261 unless $msg =~ /\n$/;
34 262
35 print STDERR "cfperl: $msg"; 263 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
264
36 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 $!;
37 }; 666 };
38} 667 cf::cleanup "db_open(db): $@" if $@;
39 668
40my %ignore_set = (MAP_PROP_PATH => 1); # I hate the plug-in api. Deeply! 669 $db
670}
41 671
42# generate property mutators 672our $DB;
43sub prop_gen {
44 my ($prefix, $class) = @_;
45 673
46 no strict 'refs'; 674sub db_init {
675 cf::sync_job {
676 $DB ||= db_table "db";
677 };
678}
47 679
48 for my $prop (keys %PROP_TYPE) { 680sub db_get($$) {
49 $prop =~ /^\Q$prefix\E_(.*$)/ or next; 681 my $key = "$_[0]/$_[1]";
50 my $sub = lc $1;
51 682
52 my $type = $PROP_TYPE{$prop}; 683 cf::sync_job {
53 my $idx = $PROP_IDX {$prop}; 684 BDB::db_get $DB, undef, $key, my $data;
54 685
55 *{"$class\::get_$sub"} = *{"$class\::$sub"} = sub { 686 $! ? ()
56 $_[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->[$_]: $!";
57 }; 728 }
58 729
59 *{"$class\::set_$sub"} = sub { 730 # if processing is expensive, check
60 $_[0]->set_property ($type, $idx, $_[1]); 731 # checksum first
61 } unless $ignore_set{$prop}; 732 if (1) {
62 } 733 $md5 =
63} 734 join "\x00",
735 $processversion,
736 map {
737 cf::cede_to_tick;
738 ($src->[$_], Digest::MD5::md5_hex $data[$_])
739 } 0.. $#$src;
740
64 741
65# 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;
66 745
67prop_gen OBJECT_PROP => "cf::object"; 746 return db_get cache => "$id/data";
68# CFAPI_OBJECT_ANIMATION? 747 }
69prop_gen PLAYER_PROP => "cf::object::player"; 748 }
70 749
71prop_gen MAP_PROP => "cf::map"; 750 my $t1 = Time::HiRes::time;
72prop_gen ARCH_PROP => "cf::arch"; 751 my $data = $process->(\@data);
752 my $t2 = Time::HiRes::time;
73 753
74# guessed hierarchies 754 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
75 755
76@ext::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 756 db_put cache => "$id/data", $data;
77@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;
78 759
79# we bless all objects into derived classes to force a method lookup 760 return $data;
80# within the Safe compartment. 761 }
81for my $pkg (qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region cf::arch)) {
82 no strict 'refs';
83 @{"ext::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
84}
85 762
86$Event::DIED = sub { 763 db_get cache => "$id/data"
87 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;
88}; 1016};
89 1017
90my %ext_pkg; 1018# all those should be optimised
91my @exts; 1019sub cf::attachable::detach {
92my @hook; 1020 my ($obj, $name) = @_;
93my %command;
94my %extcmd;
95 1021
96sub inject_event { 1022 if (ref $obj) {
97 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 {
98 my $event_code = shift; 1061 my $event = shift;
1062 my $callbacks = shift;
99 1063
100 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
101 or return; 1256 or return;
102 1257
103 &$cb 1258 unless (aio_stat "$filename.pst") {
104} 1259 (aio_load "$filename.pst", $av) >= 0
105
106sub inject_global_event {
107 my $event = shift;
108
109 my $cb = $hook[$event]
110 or return; 1260 or return;
111 1261
112 List::Util::max map &$_, values %$cb 1262 my $st = eval { Coro::Storable::thaw $av };
113} 1263 $av = $st->{objs};
114
115sub inject_command {
116 my ($name, $obj, $params) = @_;
117
118 for my $cmd (@{ $command{$name} }) {
119 $cmd->[1]->($obj, $params);
120 } 1264 }
121 1265
122 -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)
123} 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
124 1289
125sub register_command { 1290sub register_command {
126 my ($name, $time, $cb) = @_; 1291 my ($name, $cb) = @_;
127 1292
128 my $caller = caller; 1293 my $caller = caller;
129 #warn "registering command '$name/$time' to '$caller'"; 1294 #warn "registering command '$name/$time' to '$caller'";
130 1295
131 push @{ $command{$name} }, [$time, $cb, $caller]; 1296 push @{ $COMMAND{$name} }, [$caller, $cb];
132 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
133} 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
134 1322
135sub register_extcmd { 1323sub register_extcmd {
136 my ($name, $cb) = @_; 1324 my ($name, $cb) = @_;
137 1325
138 my $caller = caller; 1326 $EXTCMD{$name} = $cb;
139 #warn "registering extcmd '$name' to '$caller'";
140
141 $extcmd{$name} = [$cb, $caller];
142} 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
143 1839
144sub 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 {
145 my ($base, $pkg) = @_; 1854 my ($self, $merge) = @_;
146 1855
147 for my $idx (0 .. $#PLUGIN_EVENT) { 1856 # we have to keep some variables in memory intact
148 if (my $ref = $pkg->can ("on_$PLUGIN_EVENT[$idx]")) { 1857 local $self->{path};
149 #warn "registering $PLUGIN_EVENT[$idx] hook to '$pkg'\n"; 1858 local $self->{load_path};
150 $hook[$idx]{$base} = $ref;
151 }
152 }
153}
154 1859
155sub load_extension { 1860 $self->SUPER::thawer_merge ($merge);
1861}
1862
1863sub normalise {
156 my ($path) = @_; 1864 my ($path, $base) = @_;
157 1865
158 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 1866 $path = "$path"; # make sure its a string
159 my $base = $1;
160 my $pkg = $1;
161 $pkg =~ s/[^[:word:]]/_/g;
162 $pkg = "cf::ext::$pkg";
163 1867
164 warn "loading '$path' into '$pkg'\n"; 1868 $path =~ s/\.map$//;
165 1869
166 open my $fh, "<:utf8", $path 1870 # map plan:
167 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
168 1878
169 my $source = 1879 $path =~ s/$PATH_SEP/\//go;
170 "package $pkg; use strict; use utf8;\n"
171 . "#line 1 \"$path\"\n{\n"
172 . (do { local $/; <$fh> })
173 . "\n};\n1";
174 1880
175 eval $source 1881 # treat it as relative path if it starts with
176 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'";
177 1885
178 push @exts, $pkg; 1886 $base =~ s{[^/]+/?$}{};
179 $ext_pkg{$base} = $pkg; 1887 $path = "$base/$path";
1888 }
180 1889
181# no strict 'refs'; 1890 for ($path) {
182# @{"$pkg\::ISA"} = ext::; 1891 redo if s{//}{/};
1892 redo if s{/\.?/}{/};
1893 redo if s{/[^/]+/\.\./}{/};
1894 }
183 1895
184 register $base, $pkg; 1896 $path
185} 1897}
186 1898
187sub 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 {
188 my ($pkg) = @_; 1920 my ($self) = @_;
189 1921
190 warn "removing extension $pkg\n"; 1922 $self
1923}
191 1924
192 # remove hooks 1925sub as_string {
193 for my $idx (0 .. $#PLUGIN_EVENT) { 1926 my ($self) = @_;
194 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
195 } 1990 1
1991}
196 1992
197 # remove commands 1993sub load_header_orig {
198 for my $name (keys %command) { 1994 my ($self) = @_;
199 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} };
200 1995
201 if (@cb) { 1996 $self->load_header_from ($self->load_path)
202 $command{$name} = \@cb; 1997}
203 $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;
204 } else { 2029 } else {
205 delete $command{$name}; 2030 $self->load_header_orig
206 delete $COMMAND{"$name\000"}; 2031 or return;
207 } 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
208 } 2041 1
209
210 # remove extcmds
211 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) {
212 delete $extcmd{$name};
213 }
214
215 if (my $cb = $pkg->can ("on_unload")) {
216 eval {
217 $cb->($pkg);
218 1
219 } or warn "$pkg unloaded, but with errors: $@";
220 }
221
222 Symbol::delete_package $pkg;
223} 2042}
224 2043
225sub load_extensions { 2044sub find;
226 my $LIBDIR = maps_directory "perl"; 2045sub find {
2046 my ($path, $origin) = @_;
227 2047
228 for my $ext (<$LIBDIR/*.ext>) { 2048 $path = normalise $path, $origin && $origin->path;
229 next unless -r $ext;
230 eval {
231 load_extension $ext;
232 1
233 } or warn "$ext not loaded: $@";
234 }
235}
236 2049
237sub _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 {
238 my ($msg) = @_; 2079 my ($self) = @_;
239 2080
240 $msg->("reloading..."); 2081 local $self->{deny_reset} = 1; # loading can take a long time
241 2082
242 eval { 2083 my $path = $self->{path};
243 # 1. cancel all watchers
244 $_->cancel for Event::all_watchers;
245 2084
246 # 2. unload all extensions 2085 {
247 for (@exts) { 2086 my $guard = cf::lock_acquire "map_data:$path";
248 $msg->("unloading <$_>");
249 unload_extension $_;
250 }
251 2087
252 # 3. unload all modules loaded from $LIBDIR 2088 return unless $self->valid;
253 while (my ($k, $v) = each %INC) { 2089 return unless $self->in_memory == cf::MAP_SWAPPED;
254 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
255 2090
256 $msg->("removing <$k>"); 2091 $self->in_memory (cf::MAP_LOADING);
257 delete $INC{$k};
258 2092
259 $k =~ s/\.pm$//; 2093 $self->alloc;
260 $k =~ s/\//::/g;
261 2094
262 if (my $cb = $k->can ("unload_module")) { 2095 $self->pre_load;
263 $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 }
264 } 2114 }
265
266 Symbol::delete_package $k;
267 }
268
269 # 4. get rid of ext::, as good as possible
270 Symbol::delete_package "ext::$_"
271 for qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region);
272
273 # 5. remove register_script_function callbacks
274 # TODO
275 2115 }
276 # 6. unload cf.pm "a bit"
277 delete $INC{"cf.pm"};
278 2116
279 # don't, removes xs symbols, too 2117 $f->resolve_delayed_derefs;
280 #Symbol::delete_package __PACKAGE__;
281 2118
282 # 7. reload cf.pm 2119 cf::cede_to_tick;
283 $msg->("reloading cf.pm"); 2120 # now do the right thing for maps
284 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;
285 }; 2227 };
286 $msg->($@) if $@; 2228 $MAP_PREFETCHER->prio (6);
287 2229
288 $msg->("reloaded"); 2230 ()
289}; 2231}
290 2232
291sub perl_reload() { 2233# common code, used by both ->save and ->swapout
292 _perl_reload { 2234sub _save {
293 warn $_[0]; 2235 my ($self) = @_;
294 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;
295 }; 2253 };
296}
297 2254
298register_command "perl-reload", 0, sub { 2255 cf::get_slot 0.02;
299 my ($who, $arg) = @_;
300 2256
301 if ($who->flag (FLAG_WIZ)) { 2257 if ($uniq) {
302 _perl_reload { 2258 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
303 warn $_[0]; 2259 $self->_save_objects ($uniq, cf::IO_UNIQUES);
304 $who->message ($_[0]);
305 };
306 }
307};
308
309#############################################################################
310# utility functions
311
312use JSON::Syck (); # TODO# replace by JSON::PC once working
313
314sub from_json($) {
315 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
316 JSON::Syck::Load $_[0]
317}
318
319sub to_json($) {
320 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
321 JSON::Syck::Dump $_[0]
322}
323
324#############################################################################
325# extcmd framework, basically convert ext <msg>
326# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
327
328sub on_extcmd {
329 my ($pl, $buf) = @_;
330
331 my $msg = eval { from_json $buf };
332
333 if (ref $msg) {
334 if (my $cb = $extcmd{$msg->{msgtype}}) {
335 if (my %reply = $cb->[0]->($pl, $msg)) {
336 $pl->ext_reply ($msg->{msgid}, %reply);
337 }
338 }
339 } else { 2260 } else {
340 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);
341 }
342
343 1 2262 }
344} 2263}
345 2264
346############################################################################# 2265sub save {
347# load/save/clean perl data associated with a map
348
349*on_mapclean = sub {
350 my ($map) = @_; 2266 my ($self) = @_;
351 2267
352 my $path = $map->tmpname; 2268 my $lock = cf::lock_acquire "map_data:$self->{path}";
353 defined $path or return;
354 2269
355 unlink "$path.cfperl"; 2270 $self->_save;
356}; 2271}
357 2272
358*on_mapin = 2273sub swap_out {
359*on_mapload = sub {
360 my ($map) = @_; 2274 my ($self) = @_;
361 2275
362 my $path = $map->tmpname; 2276 my $lock = cf::lock_acquire "map_data:$self->{path}";
363 $path = $map->path unless defined $path;
364 2277
365 open my $fh, "<:raw", "$path.cfperl" 2278 return if $self->in_memory != cf::MAP_ACTIVE;
366 or return; # no perl data 2279 return if $self->{deny_save};
2280 return if $self->players;
367 2281
368 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);
369 2286
370 $data->{version} <= 1 2287 # then atomically save
371 or return; # too new 2288 $self->_save;
372 2289
373 $map->_set_obs ($data->{obs}); 2290 # then free the map
374}; 2291 $self->clear;
2292}
375 2293
376*on_mapout = sub { 2294sub reset_at {
377 my ($map) = @_; 2295 my ($self) = @_;
378 2296
379 my $path = $map->tmpname; 2297 # TODO: safety, remove and allow resettable per-player maps
380 $path = $map->path unless defined $path; 2298 return 1e99 if $self->{deny_reset};
381 2299
382 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;
383 2302
384 if (defined $obs) { 2303 $time + $to
385 open my $fh, ">:raw", "$path.cfperl" 2304}
386 or die "$path.cfperl: $!";
387 2305
388 stat $path; 2306sub should_reset {
2307 my ($self) = @_;
389 2308
390 print $fh Storable::nfreeze { 2309 $self->reset_at <= $cf::RUNTIME
391 size => (stat _)[7], 2310}
392 time => (stat _)[9], 2311
393 version => 1, 2312sub reset {
394 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/$_";
395 }; 2444 }
396 2445
397 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
398 } else { 2500 } else {
399 unlink "$path.cfperl"; 2501 warn "$ref: cannot resolve object reference\n";
2502 undef
400 } 2503 }
401};
402
403#############################################################################
404# load/save perl data associated with player->ob objects
405
406sub all_objects(@) {
407 @_, map all_objects ($_->inv), @_
408} 2504}
409 2505
410*on_player_load = sub { 2506package cf;
411 my ($ob, $path) = @_;
412 2507
413 for my $o (all_objects $ob) { 2508=back
414 if (my $value = $o->get_ob_key_value ("_perl_data")) {
415 $o->set_ob_key_value ("_perl_data");
416 2509
417 %$o = %{ Storable::thaw pack "H*", $value }; 2510=head3 cf::object::player
418 }
419 }
420};
421 2511
422*on_player_save = sub { 2512=over 4
423 my ($ob, $path) = @_;
424 2513
425 $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_)
426 for grep %$_, all_objects $ob;
427};
428
429#############################################################################
430# core extensions - in perl
431
432=item cf::player::exists $login
433
434Returns true when the given account exists.
435
436=cut
437
438sub cf::player::exists($) {
439 cf::player::find $_[0]
440 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
441}
442
443=item $player->reply ($npc, $msg[, $flags]) 2514=item $player_object->reply ($npc, $msg[, $flags])
444 2515
445Sends 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>
446can 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
447dialogue with the given NPC character. 2518dialogue with the given NPC character.
448 2519
449=cut 2520=cut
450 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
451# rough implementation of a future "reply" method that works 2536# rough implementation of a future "reply" method that works
452# with dialog boxes. 2537# with dialog boxes.
2538#TODO: the first argument must go, split into a $npc->reply_to ( method
453sub cf::object::player::reply($$$;$) { 2539sub cf::object::player::reply($$$;$) {
454 my ($self, $npc, $msg, $flags) = @_; 2540 my ($self, $npc, $msg, $flags) = @_;
455 2541
456 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2542 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
457 2543
458 if ($self->{record_replies}) { 2544 if ($self->{record_replies}) {
459 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2545 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2546
460 } 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 {
461 $msg = $npc->name . " says: $msg" if $npc; 2555 $msg = $npc->name . " says: $msg" if $npc;
462 $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,
463 } 2765 };
464}
465 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
466=item $player->ext_reply ($msgid, $msgtype, %msg) 3080=item $client->ext_reply ($msgid, @msg)
467 3081
468Sends an ext reply to the player. 3082Sends an ext reply to the client.
469 3083
470=cut 3084=cut
471 3085
472sub cf::player::ext_reply($$$%) { 3086sub cf::client::ext_reply($$@) {
473 my ($self, $id, %msg) = @_; 3087 my ($self, $id, @msg) = @_;
474 3088
475 $msg{msgid} = $id; 3089 if ($self->extcmd == 2) {
476 3090 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
477 $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 }
478} 3096}
479 3097
480############################################################################# 3098=item $success = $client->query ($flags, "text", \&cb)
481# map scripting support
482 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
483our $safe = new Safe "ext"; 3225our $safe = new Safe "safe";
484our $safe_hole = new Safe::Hole; 3226our $safe_hole = new Safe::Hole;
485 3227
486$SIG{FPE} = 'IGNORE'; 3228$SIG{FPE} = 'IGNORE';
487 3229
488$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));
489 3235
490# here we export the classes and methods available to script code 3236# here we export the classes and methods available to script code
491 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
492for ( 3258for (
493 ["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)],
494 ["cf::object::player" => qw(player)], 3262 ["cf::object::player" => qw(player)],
495 ["cf::player" => qw(peaceful)], 3263 ["cf::player" => qw(peaceful send_msg)],
3264 ["cf::map" => qw(trigger)],
496) { 3265) {
497 no strict 'refs'; 3266 no strict 'refs';
498 my ($pkg, @funs) = @$_; 3267 my ($pkg, @funs) = @$_;
499 *{"ext::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3268 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
500 for @funs; 3269 for @funs;
501} 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
502 3283
503sub safe_eval($;@) { 3284sub safe_eval($;@) {
504 my ($code, %vars) = @_; 3285 my ($code, %vars) = @_;
505 3286
506 my $qcode = $code; 3287 my $qcode = $code;
507 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3288 $qcode =~ s/"/‟/g; # not allowed in #line filenames
508 $qcode =~ s/\n/\\n/g; 3289 $qcode =~ s/\n/\\n/g;
509 3290
3291 %vars = (_dummy => 0) unless %vars;
3292
3293 my @res;
510 local $_; 3294 local $_;
511 local @ext::cf::_safe_eval_args = values %vars;
512 3295
513 $code = 3296 my $eval =
514 "do {\n" 3297 "do {\n"
515 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3298 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
516 . "#line 0 \"{$qcode}\"\n" 3299 . "#line 0 \"{$qcode}\"\n"
517 . $code 3300 . $code
518 . "\n}" 3301 . "\n}"
519 ; 3302 ;
520 3303
3304 if ($CFG{safe_eval}) {
521 sub_generation_inc; 3305 sub_generation_inc;
3306 local @safe::cf::_safe_eval_args = values %vars;
522 my @res = wantarray ? $safe->reval ($code) : scalar $safe->reval ($code); 3307 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
523 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 }
524 3319
525 wantarray ? @res : $res[0] 3320 wantarray ? @res : $res[0]
526} 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
527 3337
528sub register_script_function { 3338sub register_script_function {
529 my ($fun, $cb) = @_; 3339 my ($fun, $cb) = @_;
530 3340
531 no strict 'refs'; 3341 $fun = "safe::$fun" if $CFG{safe_eval};
532 *{"ext::$fun"} = $safe_hole->wrap ($cb); 3342 *$fun = $safe_hole->wrap ($cb);
533} 3343}
3344
3345=back
3346
3347=cut
534 3348
535############################################################################# 3349#############################################################################
536# the server's main() 3350# the server's init and main functions
537 3351
538sub run { 3352sub load_facedata($) {
539 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;
540} 3635}
541 3636
542############################################################################# 3637#############################################################################
543# initialisation 3638# initialisation and cleanup
544 3639
545register "<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};
546 3974
547unshift @INC, $LIBDIR; 3975unshift @INC, $LIBDIR;
548 3976
549load_extensions; 3977my $bug_warning = 0;
550 3978
551$TICK_WATCHER = Event->timer ( 3979our @WAIT_FOR_TICK;
552 prio => 1, 3980our @WAIT_FOR_TICK_BEGIN;
553 at => $NEXT_TICK || 1, 3981
554 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
555 cf::server_tick; # one server iteration 4005 cf::server_tick; # one server iteration
556 4006
557 my $NOW = Event::time; 4007 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
558 $NEXT_TICK += $TICK;
559 4008
560 # if we are delayed by four ticks, skip them all 4009 if ($NOW >= $NEXT_RUNTIME_WRITE) {
561 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 4010 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
562 4011 Coro::async_pool {
563 $TICK_WATCHER->at ($NEXT_TICK); 4012 $Coro::current->{desc} = "runtime saver";
564 $TICK_WATCHER->start; 4013 write_runtime_sync
4014 or warn "ERROR: unable to write runtime file: $!";
4015 };
565 }, 4016 }
566); 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 }
567 4134
5681 41351
569 4136

Diff Legend

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