ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/server/lib/cf.pm
(Generate patch)

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.37 by root, Thu Aug 24 14:05:22 2006 UTC vs.
Revision 1.510 by root, Tue Apr 6 22:59:28 2010 UTC

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

Diff Legend

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