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.36 by root, Thu Aug 24 14:04:29 2006 UTC vs.
Revision 1.572 by root, Sun May 8 11:44:43 2011 UTC

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

Diff Legend

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