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.40 by root, Fri Aug 25 15:21:57 2006 UTC vs.
Revision 1.493 by root, Mon Oct 26 02:34:37 2009 UTC

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

Diff Legend

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