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.14 by root, Fri Mar 31 22:47:35 2006 UTC vs.
Revision 1.577 by root, Tue Jan 3 11:25:33 2012 UTC

1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3#
4# Copyright (©) 2006,2007,2008,2009,2010,2011,2012 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;
29use Socket;
30use EV;
31use Opcode;
32use Safe;
33use Safe::Hole;
5use Storable; 34use Storable ();
35use Carp ();
6 36
7use strict; 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 ();
8 52
9our %COMMAND; 53use JSON::XS 2.01 ();
54use BDB ();
55use Data::Dumper;
56use Fcntl;
57use YAML::XS ();
58use IO::AIO ();
59use Time::HiRes;
60use Compress::LZF;
61use Digest::MD5 ();
62
63AnyEvent::detect;
64
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
10our @EVENT; 93our @EVENT;
11our %PROP_TYPE; 94our @REFLECT; # set by XS
12our %PROP_IDX; 95our %REFLECT; # set by us
13 96
14BEGIN { 97our $CONFDIR = confdir;
15 @EVENT = map lc, @EVENT;
16 98
17 *CORE::GLOBAL::warn = sub { 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
123our $NEXT_TICK;
124our $USE_FSYNC = 1; # use fsync to write maps - default on
125
126our $BDB_DEADLOCK_WATCHER;
127our $BDB_CHECKPOINT_WATCHER;
128our $BDB_TRICKLE_WATCHER;
129our $DB_ENV;
130
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 {
18 my $msg = join "", @_; 294 my $msg = join "", @_;
295
19 $msg .= "\n" 296 $msg .= "\n"
20 unless $msg =~ /\n$/; 297 unless $msg =~ /\n$/;
21 298
22 print STDERR "cfperl: $msg"; 299 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
23 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 $!;
24 }; 779 };
25} 780 cf::cleanup "db_open(db): $@" if $@;
26 781
27my %ignore_set = (MAP_PROP_PATH => 1); # I hate the plug-in api. Deeply! 782 $db
783}
28 784
29# generate property mutators 785our $DB;
30sub prop_gen { 786
787sub db_init {
788 $DB ||= db_table "db";
789}
790
791sub db_get($$) {
792 my $key = "$_[0]/$_[1]";
793
794 cf::error "db_get called from main context"
795 if $Coro::current == $Coro::main;
796
797 BDB::db_get $DB, undef, $key, my $data;
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->[$_];
839 }
840
841 # if processing is expensive, check
842 # checksum first
843 if (1) {
844 $md5 =
845 join "\x00",
846 $processversion,
847 map {
848 cf::cede_to_tick;
849 ($src->[$_], Digest::MD5::md5_hex $data[$_])
850 } 0.. $#$src;
851
852
853 my $dbmd5 = db_get cache => "$id/md5";
854 if ($dbmd5 eq $md5) {
855 db_put cache => "$id/meta", $meta;
856
857 return db_get cache => "$id/data";
858 }
859 }
860
861 my $t1 = Time::HiRes::time;
862 my $data = $process->(\@data);
863 my $t2 = Time::HiRes::time;
864
865 info "cache: '$id' processed in ", $t2 - $t1, "s\n";
866
867 db_put cache => "$id/data", $data;
868 db_put cache => "$id/md5" , $md5;
869 db_put cache => "$id/meta", $meta;
870
871 return $data;
872 }
873
874 db_get cache => "$id/data"
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;
1127};
1128
1129# all those should be optimised
1130sub cf::attachable::detach {
1131 my ($obj, $name) = @_;
1132
1133 if (ref $obj) {
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 {
1172 my $event = shift;
1173 my $callbacks = shift;
1174
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
1366 or return;
1367
1368 unless (aio_stat "$filename.pst") {
1369 (aio_load "$filename.pst", $av) >= 0
1370 or return;
1371
1372 my $st = eval { Coro::Storable::thaw $av };
1373 $av = $st->{objs};
1374 }
1375
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)
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
1399
1400sub register_command {
1401 my ($name, $cb) = @_;
1402
1403 my $caller = caller;
1404 #warn "registering command '$name/$time' to '$caller'";
1405
1406 push @{ $COMMAND{$name} }, [$caller, $cb];
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
1432
1433sub register_extcmd {
1434 my ($name, $cb) = @_;
1435
1436 $EXTCMD{$name} = $cb;
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) = @$msg; # version 1 used %type, $id, %$hash
1467
1468 my @reply;
1469
1470 if (my $cb = $EXTCMD{$type}) {
1471 @reply = $cb->($pl, @payload);
1472 }
1473
1474 $pl->ext_reply ($reply, @reply)
1475 if $reply;
1476
1477 } else {
1478 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1479 }
1480
1481 cf::override;
1482 },
1483);
1484
1485# "readahead" all extensions
1486sub cache_extensions {
1487 my $grp = IO::AIO::aio_group;
1488
1489 add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
1490 for (grep /\.ext$/, @{$_[0]}) {
1491 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
1492 }
1493 };
1494
1495 $grp
1496}
1497
1498sub load_extensions {
1499 info "loading extensions...";
1500
1501 cf::sync_job {
1502 my %todo;
1503
1504 for my $path (<$LIBDIR/*.ext>) {
1505 next unless -r $path;
1506
1507 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1508 my $base = $1;
1509 my $pkg = $1;
1510 $pkg =~ s/[^[:word:]]/_/g;
1511 $pkg = "ext::$pkg";
1512
1513 open my $fh, "<:utf8", $path
1514 or die "$path: $!";
1515
1516 my $source = do { local $/; <$fh> };
1517
1518 my %ext = (
1519 path => $path,
1520 base => $base,
1521 pkg => $pkg,
1522 );
1523
1524 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1525 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1526
1527 $ext{source} =
1528 "package $pkg; use common::sense;\n"
1529 . "#line 1 \"$path\"\n{\n"
1530 . $source
1531 . "\n};\n1";
1532
1533 $todo{$base} = \%ext;
1534 }
1535
1536 my $pass = 0;
1537 my %done;
1538 while (%todo) {
1539 my $progress;
1540
1541 ++$pass;
1542
1543 ext:
1544 while (my ($k, $v) = each %todo) {
1545 for (split /,\s*/, $v->{meta}{depends}) {
1546 next ext
1547 unless exists $done{$_};
1548 }
1549
1550 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1551
1552 my $active = eval $v->{source};
1553
1554 if (length $@) {
1555 error "$v->{path}: $@\n";
1556
1557 cf::cleanup "mandatory extension '$k' failed to load, exiting."
1558 if exists $v->{meta}{mandatory};
1559
1560 warn "$v->{base}: optional extension cannot be loaded, skipping.\n";
1561 delete $todo{$k};
1562 } else {
1563 $done{$k} = delete $todo{$k};
1564 push @EXTS, $v->{pkg};
1565 $progress = 1;
1566
1567 info "$v->{base}: extension inactive.\n"
1568 unless $active;
1569 }
1570 }
1571
1572 unless ($progress) {
1573 warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
1574
1575 while (my ($k, $v) = each %todo) {
1576 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
1577 if exists $v->{meta}{mandatory};
1578 }
1579
1580 last;
1581 }
1582 }
1583 };
1584}
1585
1586#############################################################################
1587
1588=back
1589
1590=head2 CORE EXTENSIONS
1591
1592Functions and methods that extend core deliantra objects.
1593
1594=cut
1595
1596package cf::player;
1597
1598use Coro::AIO;
1599
1600=head3 cf::player
1601
1602=over 4
1603
1604=item cf::player::num_playing
1605
1606Returns the official number of playing players, as per the Crossfire metaserver rules.
1607
1608=cut
1609
1610sub num_playing {
1611 scalar grep
1612 $_->ob->map
1613 && !$_->hidden
1614 && !$_->ob->flag (cf::FLAG_WIZ),
1615 cf::player::list
1616}
1617
1618=item cf::player::find $login
1619
1620Returns the given player object, loading it if necessary (might block).
1621
1622=cut
1623
1624sub playerdir($) {
1625 "$PLAYERDIR/"
1626 . (ref $_[0] ? $_[0]->ob->name : $_[0])
1627}
1628
1629sub path($) {
1630 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
1631
1632 (playerdir $login) . "/playerdata"
1633}
1634
1635sub find_active($) {
1636 $cf::PLAYER{$_[0]}
1637 and $cf::PLAYER{$_[0]}->active
1638 and $cf::PLAYER{$_[0]}
1639}
1640
1641sub exists($) {
1642 my ($login) = @_;
1643
1644 $cf::PLAYER{$login}
1645 or !aio_stat path $login
1646}
1647
1648sub find($) {
1649 return $cf::PLAYER{$_[0]} || do {
1650 my $login = $_[0];
1651
1652 my $guard = cf::lock_acquire "user_find:$login";
1653
1654 $cf::PLAYER{$_[0]} || do {
1655 # rename old playerfiles to new ones
1656 #TODO: remove when no longer required
1657 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1658 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1659 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1660 aio_unlink +(playerdir $login) . "/$login.pl";
1661
1662 my $f = new_from_file cf::object::thawer path $login
1663 or return;
1664
1665 my $pl = cf::player::load_pl $f
1666 or return;
1667
1668 local $cf::PLAYER_LOADING{$login} = $pl;
1669 $f->resolve_delayed_derefs;
1670 $cf::PLAYER{$login} = $pl
1671 }
1672 }
1673}
1674
1675cf::player->attach (
1676 on_load => sub {
1677 my ($pl, $path) = @_;
1678
1679 # restore slots saved in save, below
1680 my $slots = delete $pl->{_slots};
1681
1682 $pl->ob->current_weapon ($slots->[0]);
1683 $pl->combat_ob ($slots->[1]);
1684 $pl->ranged_ob ($slots->[2]);
1685 },
1686);
1687
1688sub save($) {
1689 my ($pl) = @_;
1690
1691 return if $pl->{deny_save};
1692
1693 my $path = path $pl;
1694 my $guard = cf::lock_acquire "user_save:$path";
1695
1696 return if $pl->{deny_save};
1697
1698 aio_mkdir playerdir $pl, 0770;
1699 $pl->{last_save} = $cf::RUNTIME;
1700
1701 cf::get_slot 0.01;
1702
1703 # save slots, to be restored later
1704 local $pl->{_slots} = [$pl->ob->current_weapon, $pl->combat_ob, $pl->ranged_ob];
1705
1706 $pl->save_pl ($path);
1707 cf::cede_to_tick;
1708}
1709
1710sub new($) {
1711 my ($login) = @_;
1712
1713 my $self = create;
1714
1715 $self->ob->name ($login);
1716 $self->{deny_save} = 1;
1717
1718 $cf::PLAYER{$login} = $self;
1719
1720 $self
1721}
1722
1723=item $player->send_msg ($channel, $msg, $color, [extra...])
1724
1725=cut
1726
1727sub send_msg {
1728 my $ns = shift->ns
1729 or return;
1730 $ns->send_msg (@_);
1731}
1732
1733=item $pl->quit_character
1734
1735Nukes the player without looking back. If logged in, the connection will
1736be destroyed. May block for a long time.
1737
1738=cut
1739
1740sub quit_character {
1741 my ($pl) = @_;
1742
1743 my $name = $pl->ob->name;
1744
1745 $pl->{deny_save} = 1;
1746 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1747
1748 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->ns;
1749 $pl->deactivate;
1750
1751 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1752 $pl->invoke (cf::EVENT_PLAYER_QUIT) if $pl->ns;
1753 ext::highscore::check ($pl->ob);
1754
1755 $pl->ns->destroy if $pl->ns;
1756
1757 my $path = playerdir $pl;
1758 my $temp = "$path~$cf::RUNTIME~deleting~";
1759 aio_rename $path, $temp;
1760 delete $cf::PLAYER{$pl->ob->name};
1761 $pl->destroy;
1762
1763 my $prefix = qr<^~\Q$name\E/>;
1764
1765 # nuke player maps
1766 $cf::MAP{$_}->nuke for grep /$prefix/, keys %cf::MAP;
1767
1768 IO::AIO::aio_rmtree $temp;
1769}
1770
1771=item $pl->kick
1772
1773Kicks a player out of the game. This destroys the connection.
1774
1775=cut
1776
1777sub kick {
1778 my ($pl, $kicker) = @_;
1779
1780 $pl->invoke (cf::EVENT_PLAYER_KICK, $kicker);
1781 $pl->killer ("kicked");
1782 $pl->ns->destroy;
1783}
1784
1785=item cf::player::list_logins
1786
1787Returns am arrayref of all valid playernames in the system, can take a
1788while and may block, so not sync_job-capable, ever.
1789
1790=cut
1791
1792sub list_logins {
1793 my $dirs = aio_readdir $PLAYERDIR
1794 or return [];
1795
1796 my @logins;
1797
1798 for my $login (@$dirs) {
1799 my $path = path $login;
1800
1801 # a .pst is a dead give-away for a valid player
1802 # if no pst file found, open and chekc for blocked users
1803 if (aio_stat "$path.pst") {
1804 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1805 aio_read $fh, 0, 512, my $buf, 0 or next;
1806 $buf !~ /^password -------------$/m or next; # official not-valid tag
1807 }
1808
1809 utf8::decode $login;
1810 push @logins, $login;
1811 }
1812
1813 \@logins
1814}
1815
1816=item $player->maps
1817
1818=item cf::player::maps $login
1819
1820Returns an arrayref of map paths that are private for this
1821player. May block.
1822
1823=cut
1824
1825sub maps($) {
1826 my ($pl) = @_;
1827
1828 $pl = ref $pl ? $pl->ob->name : $pl;
1829
1830 my $files = aio_readdir playerdir $pl
1831 or return;
1832
1833 my @paths;
1834
1835 for (@$files) {
1836 utf8::decode $_;
1837 next if /\.(?:pl|pst)$/;
1838 next unless /^$PATH_SEP/o;
1839
1840 push @paths, cf::map::normalise "~$pl/$_";
1841 }
1842
1843 \@paths
1844}
1845
1846=item $protocol_xml = $player->expand_cfpod ($cfpod)
1847
1848Expand deliantra pod fragments into protocol xml.
1849
1850=item $player->ext_reply ($msgid, @msg)
1851
1852Sends an ext reply to the player.
1853
1854=cut
1855
1856sub ext_reply($$@) {
1857 my ($self, $id, @msg) = @_;
1858
1859 $self->ns->ext_reply ($id, @msg)
1860}
1861
1862=item $player->ext_msg ($type, @msg)
1863
1864Sends an ext event to the client.
1865
1866=cut
1867
1868sub ext_msg($$@) {
1869 my ($self, $type, @msg) = @_;
1870
1871 $self->ns->ext_msg ($type, @msg);
1872}
1873
1874=head3 cf::region
1875
1876=over 4
1877
1878=cut
1879
1880package cf::region;
1881
1882=item cf::region::find_by_path $path
1883
1884Tries to decuce the likely region for a map knowing only its path.
1885
1886=cut
1887
1888sub find_by_path($) {
1889 my ($path) = @_;
1890
1891 $path =~ s/^~[^\/]*//; # skip ~login
1892
1893 my ($match, $specificity);
1894
1895 for my $region (list) {
1896 if ($region->{match} && $path =~ $region->{match}) {
1897 ($match, $specificity) = ($region, $region->specificity)
1898 if $region->specificity > $specificity;
1899 }
1900 }
1901
1902 $match
1903}
1904
1905=back
1906
1907=head3 cf::map
1908
1909=over 4
1910
1911=cut
1912
1913package cf::map;
1914
1915use Fcntl;
1916use Coro::AIO;
1917
1918use overload
1919 '""' => \&as_string,
1920 fallback => 1;
1921
1922our $MAX_RESET = 3600;
1923our $DEFAULT_RESET = 3000;
1924
1925sub generate_random_map {
1926 my ($self, $rmp) = @_;
1927
1928 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1929
1930 $self->_create_random_map ($rmp);
1931}
1932
1933=item cf::map->register ($regex, $prio)
1934
1935Register a handler for the map path matching the given regex at the
1936givne priority (higher is better, built-in handlers have priority 0, the
1937default).
1938
1939=cut
1940
1941sub register {
1942 my (undef, $regex, $prio) = @_;
1943 my $pkg = caller;
1944
1945 push @{"$pkg\::ISA"}, __PACKAGE__;
1946
1947 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1948}
1949
1950# also paths starting with '/'
1951$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1952
1953sub thawer_merge {
1954 my ($self, $merge) = @_;
1955
1956 # we have to keep some variables in memory intact
1957 local $self->{path};
1958 local $self->{load_path};
1959
1960 $self->SUPER::thawer_merge ($merge);
1961}
1962
1963sub normalise {
1964 my ($path, $base) = @_;
1965
1966 $path = "$path"; # make sure it's a string
1967
1968 $path =~ s/\.map$//;
1969
1970 # map plan:
1971 #
1972 # /! non-realised random map exit (special hack!)
1973 # {... are special paths that are not being touched
1974 # ?xxx/... are special absolute paths
1975 # ?random/... random maps
1976 # /... normal maps
1977 # ~user/... per-player map of a specific user
1978
1979 $path =~ s/$PATH_SEP/\//go;
1980
1981 # treat it as relative path if it starts with
1982 # something that looks reasonable
1983 if ($path =~ m{^(?:\./|\.\./|\w)}) {
1984 $base or Carp::carp "normalise called with relative path and no base: '$path'";
1985
1986 $base =~ s{[^/]+/?$}{};
1987 $path = "$base/$path";
1988 }
1989
1990 for ($path) {
1991 redo if s{/\.?/}{/};
1992 redo if s{/[^/]+/\.\./}{/};
1993 }
1994
1995 $path
1996}
1997
1998sub new_from_path {
1999 my (undef, $path, $base) = @_;
2000
2001 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object
2002
2003 $path = normalise $path, $base;
2004
2005 for my $pkg (sort { $EXT_MAP{$b}[0] <=> $EXT_MAP{$a}[0] } keys %EXT_MAP) {
2006 if ($path =~ $EXT_MAP{$pkg}[1]) {
2007 my $self = bless cf::map::new, $pkg;
2008 $self->{path} = $path; $self->path ($path);
2009 $self->init; # pass $1 etc.
2010 return $self;
2011 }
2012 }
2013
2014 Carp::cluck "unable to resolve path '$path' (base '$base')";
2015 ()
2016}
2017
2018# may re-bless or do other evil things
2019sub init {
2020 my ($self) = @_;
2021
2022 $self
2023}
2024
2025sub as_string {
2026 my ($self) = @_;
2027
2028 "$self->{path}"
2029}
2030
2031# the displayed name, this is a one way mapping
2032sub visible_name {
2033 &as_string
2034}
2035
2036# the original (read-only) location
2037sub load_path {
2038 my ($self) = @_;
2039
2040 "$MAPDIR/$self->{path}.map"
2041}
2042
2043# the temporary/swap location
2044sub save_path {
2045 my ($self) = @_;
2046
2047 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
2048 "$TMPDIR/$path.map"
2049}
2050
2051# the unique path, undef == no special unique path
2052sub uniq_path {
2053 my ($self) = @_;
2054
2055 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
2056 "$UNIQUEDIR/$path"
2057}
2058
2059sub decay_objects {
2060 my ($self) = @_;
2061
2062 return if $self->{deny_reset};
2063
2064 $self->do_decay_objects;
2065}
2066
2067sub unlink_save {
2068 my ($self) = @_;
2069
2070 utf8::encode (my $save = $self->save_path);
2071 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
2072 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst";
2073}
2074
2075sub load_header_from($) {
2076 my ($self, $path) = @_;
2077
2078 utf8::encode $path;
2079 my $f = new_from_file cf::object::thawer $path
2080 or return;
2081
2082 $self->_load_header ($f)
2083 or return;
2084
2085 local $MAP_LOADING{$self->{path}} = $self;
2086 $f->resolve_delayed_derefs;
2087
2088 $self->{load_path} = $path;
2089
2090 1
2091}
2092
2093# used to laod the header of an original map
2094sub load_header_orig {
2095 my ($self) = @_;
2096
2097 $self->load_header_from ($self->load_path)
2098}
2099
2100# used to laod the header of an instantiated map
2101sub load_header_temp {
2102 my ($self) = @_;
2103
2104 $self->load_header_from ($self->save_path)
2105}
2106
2107# called after loading the header from an instantiated map
2108sub prepare_temp {
2109 my ($self) = @_;
2110
2111 $self->last_access ((delete $self->{last_access})
2112 || $cf::RUNTIME); #d#
2113 # safety
2114 $self->{instantiate_time} = $cf::RUNTIME
2115 if $self->{instantiate_time} > $cf::RUNTIME;
2116}
2117
2118# called after loading the header from an original map
2119sub prepare_orig {
2120 my ($self) = @_;
2121
2122 $self->{load_original} = 1;
2123 $self->{instantiate_time} = $cf::RUNTIME;
2124 $self->last_access ($cf::RUNTIME);
2125 $self->instantiate;
2126}
2127
2128sub load_header {
2129 my ($self) = @_;
2130
2131 if ($self->load_header_temp) {
2132 $self->prepare_temp;
2133 } else {
2134 $self->load_header_orig
2135 or return;
2136 $self->prepare_orig;
2137 }
2138
2139 $self->{deny_reset} = 1
2140 if $self->no_reset;
2141
2142 $self->default_region (cf::region::find_by_path $self->{path})
2143 unless $self->default_region;
2144
2145 1
2146}
2147
2148sub find;
2149sub find {
2150 my ($path, $origin) = @_;
2151
2152 cf::cede_to_tick;
2153
2154 $path = normalise $path, $origin;
2155
2156 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
2157 my $guard2 = cf::lock_acquire "map_find:$path";
2158
2159 $cf::MAP{$path} || do {
2160 my $map = new_from_path cf::map $path
2161 or return;
2162
2163 $map->{last_save} = $cf::RUNTIME;
2164
2165 $map->load_header
2166 or return;
2167
2168 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
2169 # doing this can freeze the server in a sync job, obviously
2170 #$cf::WAIT_FOR_TICK->wait;
2171 undef $guard2;
2172 undef $guard1;
2173 $map->reset;
2174 return find $path;
2175 }
2176
2177 $cf::MAP{$path} = $map
2178 }
2179}
2180
2181sub pre_load { }
2182#sub post_load { } # XS
2183
2184sub load {
2185 my ($self) = @_;
2186
2187 local $self->{deny_reset} = 1; # loading can take a long time
2188
2189 my $path = $self->{path};
2190
2191 {
2192 my $guard = cf::lock_acquire "map_data:$path";
2193
2194 return unless $self->valid;
2195 return unless $self->state == cf::MAP_SWAPPED;
2196
2197 $self->alloc;
2198
2199 $self->pre_load;
2200 cf::cede_to_tick;
2201
2202 if (exists $self->{load_path}) {
2203 my $f = new_from_file cf::object::thawer $self->{load_path};
2204 $f->skip_block;
2205 $self->_load_objects ($f)
2206 or return;
2207
2208 $self->post_load_original
2209 if delete $self->{load_original};
2210
2211 if (my $uniq = $self->uniq_path) {
2212 utf8::encode $uniq;
2213 unless (aio_stat $uniq) {
2214 if (my $f = new_from_file cf::object::thawer $uniq) {
2215 $self->clear_unique_items;
2216 $self->_load_objects ($f);
2217 $f->resolve_delayed_derefs;
2218 }
2219 }
2220 }
2221
2222 $f->resolve_delayed_derefs;
2223 } else {
2224 $self->post_load_original
2225 if delete $self->{load_original};
2226 }
2227
2228 $self->state (cf::MAP_INACTIVE);
2229
2230 cf::cede_to_tick;
2231 # now do the right thing for maps
2232 $self->link_multipart_objects;
2233 $self->difficulty ($self->estimate_difficulty)
2234 unless $self->difficulty;
2235 cf::cede_to_tick;
2236
2237 unless ($self->{deny_activate}) {
2238 $self->decay_objects;
2239 $self->fix_auto_apply;
2240 $self->update_buttons;
2241 cf::cede_to_tick;
2242 #$self->activate; # no longer activate maps automatically
2243 }
2244
2245 $self->{last_save} = $cf::RUNTIME;
2246 $self->last_access ($cf::RUNTIME);
2247 }
2248
2249 $self->post_load;
2250
2251 1
2252}
2253
2254# customize the map for a given player, i.e.
2255# return the _real_ map. used by e.g. per-player
2256# maps to change the path to ~playername/mappath
2257sub customise_for {
2258 my ($self, $ob) = @_;
2259
2260 return find "~" . $ob->name . "/" . $self->{path}
2261 if $self->per_player;
2262
2263# return find "?party/" . $ob->name . "/" . $self->{path}
2264# if $self->per_party;
2265
2266 $self
2267}
2268
2269sub find_sync {
2270 my ($path, $origin) = @_;
2271
2272 # it's a bug to call this from the main context
2273 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync"
2274 if $Coro::current == $Coro::main;
2275
2276 find $path, $origin
2277}
2278
2279sub do_load_sync {
2280 my ($map) = @_;
2281
2282 # it's a bug to call this from the main context
2283 return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync"
2284 if $Coro::current == $Coro::main;
2285
2286 $map->load;
2287}
2288
2289our %MAP_PREFETCH;
2290our $MAP_PREFETCHER = undef;
2291
2292sub find_async {
2293 my ($path, $origin, $load) = @_;
2294
2295 $path = normalise $path, $origin;
2296
2297 if (my $map = $cf::MAP{$path}) {
2298 return $map if !$load || $map->linkable;
2299 }
2300
2301 $MAP_PREFETCH{$path} |= $load;
2302
2303 $MAP_PREFETCHER ||= cf::async {
2304 $Coro::current->{desc} = "map prefetcher";
2305
2306 while (%MAP_PREFETCH) {
2307 while (my ($k, $v) = each %MAP_PREFETCH) {
2308 if (my $map = find $k) {
2309 $map->load if $v;
2310 }
2311
2312 delete $MAP_PREFETCH{$k};
2313 }
2314 }
2315 undef $MAP_PREFETCHER;
2316 };
2317 $MAP_PREFETCHER->prio (6);
2318
2319 ()
2320}
2321
2322# common code, used by both ->save and ->swapout
2323sub _save {
2324 my ($self) = @_;
2325
2326 $self->{last_save} = $cf::RUNTIME;
2327
2328 return unless $self->dirty;
2329
2330 my $save = $self->save_path; utf8::encode $save;
2331 my $uniq = $self->uniq_path; utf8::encode $uniq;
2332
2333 $self->{load_path} = $save;
2334
2335 return if $self->{deny_save};
2336
2337 local $self->{last_access} = $self->last_access;#d#
2338
2339 cf::async {
2340 $Coro::current->{desc} = "map player save";
2341 $_->contr->save for $self->players;
2342 };
2343
2344 cf::get_slot 0.02;
2345
2346 if ($uniq) {
2347 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
2348 $self->_save_objects ($uniq, cf::IO_UNIQUES);
2349 } else {
2350 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
2351 }
2352}
2353
2354sub save {
2355 my ($self) = @_;
2356
2357 my $lock = cf::lock_acquire "map_data:$self->{path}";
2358
2359 $self->_save;
2360}
2361
2362sub swap_out {
2363 my ($self) = @_;
2364
2365 my $lock = cf::lock_acquire "map_data:$self->{path}";
2366
2367 return if !$self->linkable;
2368 return if $self->{deny_save};
2369 return if $self->players;
2370
2371 # first deactivate the map and "unlink" it from the core
2372 $self->deactivate;
2373 $_->clear_links_to ($self) for values %cf::MAP;
2374 $self->state (cf::MAP_SWAPPED);
2375
2376 # then atomically save
2377 $self->_save;
2378
2379 # then free the map
2380 $self->clear;
2381}
2382
2383sub reset_at {
2384 my ($self) = @_;
2385
2386 # TODO: safety, remove and allow resettable per-player maps
2387 return 1e99 if $self->{deny_reset};
2388
2389 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2390 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2391
2392 $time + $to
2393}
2394
2395sub should_reset {
2396 my ($self) = @_;
2397
2398 $self->reset_at <= $cf::RUNTIME
2399}
2400
2401sub reset {
2402 my ($self) = @_;
2403
2404 my $lock = cf::lock_acquire "map_data:$self->{path}";
2405
2406 return if $self->players;
2407
2408 cf::trace "resetting map ", $self->path, "\n";
2409
2410 $self->state (cf::MAP_SWAPPED);
2411
2412 # need to save uniques path
2413 unless ($self->{deny_save}) {
2414 my $uniq = $self->uniq_path; utf8::encode $uniq;
2415
2416 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2417 if $uniq;
2418 }
2419
2420 delete $cf::MAP{$self->path};
2421
2422 $self->deactivate;
2423 $_->clear_links_to ($self) for values %cf::MAP;
2424 $self->clear;
2425
2426 $self->unlink_save;
2427 $self->destroy;
2428}
2429
2430my $nuke_counter = "aaaa";
2431
2432sub nuke {
2433 my ($self) = @_;
2434
2435 {
2436 my $lock = cf::lock_acquire "map_data:$self->{path}";
2437
2438 delete $cf::MAP{$self->path};
2439
2440 $self->unlink_save;
2441
2442 bless $self, "cf::map::wrap";
2443 delete $self->{deny_reset};
2444 $self->{deny_save} = 1;
2445 $self->reset_timeout (1);
2446 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2447
2448 $cf::MAP{$self->path} = $self;
2449 }
2450
2451 $self->reset; # polite request, might not happen
2452}
2453
2454=item $maps = cf::map::tmp_maps
2455
2456Returns an arrayref with all map paths of currently instantiated and saved
2457maps. May block.
2458
2459=cut
2460
2461sub tmp_maps() {
2462 [
2463 map {
2464 utf8::decode $_;
2465 /\.map$/
2466 ? normalise $_
2467 : ()
2468 } @{ aio_readdir $TMPDIR or [] }
2469 ]
2470}
2471
2472=item $maps = cf::map::random_maps
2473
2474Returns an arrayref with all map paths of currently instantiated and saved
2475random maps. May block.
2476
2477=cut
2478
2479sub random_maps() {
2480 [
2481 map {
2482 utf8::decode $_;
2483 /\.map$/
2484 ? normalise "?random/$_"
2485 : ()
2486 } @{ aio_readdir $RANDOMDIR or [] }
2487 ]
2488}
2489
2490=item cf::map::unique_maps
2491
2492Returns an arrayref of paths of all shared maps that have
2493instantiated unique items. May block.
2494
2495=cut
2496
2497sub unique_maps() {
2498 [
2499 map {
2500 utf8::decode $_;
2501 s/\.map$//; # TODO future compatibility hack
2502 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
2503 ? ()
2504 : normalise $_
2505 } @{ aio_readdir $UNIQUEDIR or [] }
2506 ]
2507}
2508
2509=item cf::map::static_maps
2510
2511Returns an arrayref if paths of all static maps (all preinstalled F<.map>
2512file in the shared directory excluding F</styles> and F</editor>). May
2513block.
2514
2515=cut
2516
2517sub static_maps() {
2518 my @dirs = "";
2519 my @maps;
2520
2521 while (@dirs) {
2522 my $dir = shift @dirs;
2523
2524 next if $dir eq "/styles" || $dir eq "/editor";
2525
2526 my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
2527 or return;
2528
2529 for (@$files) {
2530 s/\.map$// or next;
2531 utf8::decode $_;
2532 push @maps, "$dir/$_";
2533 }
2534
2535 push @dirs, map "$dir/$_", @$dirs;
2536 }
2537
2538 \@maps
2539}
2540
2541=back
2542
2543=head3 cf::object
2544
2545=cut
2546
2547package cf::object;
2548
2549=over 4
2550
2551=item $ob->inv_recursive
2552
2553Returns the inventory of the object I<and> their inventories, recursively,
2554but I<not> the object itself.
2555
2556=cut
2557
2558sub inv_recursive_;
2559sub inv_recursive_ {
2560 map { $_, inv_recursive_ $_->inv } @_
2561}
2562
2563sub inv_recursive {
2564 inv_recursive_ inv $_[0]
2565}
2566
2567=item $ref = $ob->ref
2568
2569Creates and returns a persistent reference to an object that can be stored as a string.
2570
2571=item $ob = cf::object::deref ($refstring)
2572
2573returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2574even if the object actually exists. May block.
2575
2576=cut
2577
2578sub deref {
2579 my ($ref) = @_;
2580
2581 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2582 my ($uuid, $name) = ($1, $2);
2583 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2584 or return;
2585 $pl->ob->uuid eq $uuid
2586 or return;
2587
2588 $pl->ob
2589 } else {
2590 warn "$ref: cannot resolve object reference\n";
2591 undef
2592 }
2593}
2594
2595package cf;
2596
2597=back
2598
2599=head3 cf::object::player
2600
2601=over 4
2602
2603=item $player_object->reply ($npc, $msg[, $flags])
2604
2605Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
2606can be C<undef>. Does the right thing when the player is currently in a
2607dialogue with the given NPC character.
2608
2609=cut
2610
2611our $SAY_CHANNEL = {
2612 id => "say",
2613 title => "Map",
2614 reply => "say ",
2615 tooltip => "Things said to and replied from NPCs near you and other players on the same map only.",
2616};
2617
2618our $CHAT_CHANNEL = {
2619 id => "chat",
2620 title => "Chat",
2621 reply => "chat ",
2622 tooltip => "Player chat and shouts, global to the server.",
2623};
2624
2625# rough implementation of a future "reply" method that works
2626# with dialog boxes.
2627#TODO: the first argument must go, split into a $npc->reply_to ( method
2628sub cf::object::player::reply($$$;$) {
2629 my ($self, $npc, $msg, $flags) = @_;
2630
2631 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
2632
2633 if ($self->{record_replies}) {
2634 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2635
2636 } else {
2637 my $pl = $self->contr;
2638
2639 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2640 my $dialog = $pl->{npc_dialog};
2641 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2642
2643 } else {
2644 $msg = $npc->name . " says: $msg" if $npc;
2645 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2646 }
2647 }
2648}
2649
2650=item $object->send_msg ($channel, $msg, $color, [extra...])
2651
2652=cut
2653
2654sub cf::object::send_msg {
2655 my $pl = shift->contr
2656 or return;
2657 $pl->send_msg (@_);
2658}
2659
2660=item $player_object->may ("access")
2661
2662Returns wether the given player is authorized to access resource "access"
2663(e.g. "command_wizcast").
2664
2665=cut
2666
2667sub cf::object::player::may {
31 my ($prefix, $class) = @_; 2668 my ($self, $access) = @_;
32 2669
33 no strict 'refs'; 2670 $self->flag (cf::FLAG_WIZ) ||
2671 (ref $cf::CFG{"may_$access"}
2672 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
2673 : $cf::CFG{"may_$access"})
2674}
34 2675
35 for my $prop (keys %PROP_TYPE) { 2676=item $player_object->enter_link
36 $prop =~ /^\Q$prefix\E_(.*$)/ or next;
37 my $sub = lc $1;
38 2677
39 my $type = $PROP_TYPE{$prop}; 2678Freezes the player and moves him/her to a special map (C<{link}>).
40 my $idx = $PROP_IDX {$prop};
41 2679
42 *{"$class\::get_$sub"} = *{"$class\::$sub"} = sub { 2680The player should be reasonably safe there for short amounts of time (e.g.
43 $_[0]->get_property ($type, $idx) 2681for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2682though, as the player cannot control the character while it is on the link
2683map.
2684
2685Will never block.
2686
2687=item $player_object->leave_link ($map, $x, $y)
2688
2689Moves the player out of the special C<{link}> map onto the specified
2690map. If the map is not valid (or omitted), the player will be moved back
2691to the location he/she was before the call to C<enter_link>, or, if that
2692fails, to the emergency map position.
2693
2694Might block.
2695
2696=cut
2697
2698sub link_map {
2699 unless ($LINK_MAP) {
2700 $LINK_MAP = cf::map::find "{link}"
2701 or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
2702 $LINK_MAP->load;
2703 }
2704
2705 $LINK_MAP
2706}
2707
2708sub cf::object::player::enter_link {
2709 my ($self) = @_;
2710
2711 $self->deactivate_recursive;
2712
2713 ++$self->{_link_recursion};
2714
2715 return if UNIVERSAL::isa $self->map, "ext::map_link";
2716
2717 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2718 if $self->map && $self->map->{path} ne "{link}";
2719
2720 $self->enter_map ($LINK_MAP || link_map, 3, 3);
2721}
2722
2723sub cf::object::player::leave_link {
2724 my ($self, $map, $x, $y) = @_;
2725
2726 return unless $self->contr->active;
2727
2728 my $link_pos = delete $self->{_link_pos};
2729
2730 unless ($map) {
2731 # restore original map position
2732 ($map, $x, $y) = @{ $link_pos || [] };
2733 $map = cf::map::find $map;
2734
2735 unless ($map) {
2736 ($map, $x, $y) = @$EMERGENCY_POSITION;
2737 $map = cf::map::find $map
2738 or die "FATAL: cannot load emergency map\n";
2739 }
2740 }
2741
2742 ($x, $y) = (-1, -1)
2743 unless (defined $x) && (defined $y);
2744
2745 # use -1 or undef as default coordinates, not 0, 0
2746 ($x, $y) = ($map->enter_x, $map->enter_y)
2747 if $x <= 0 && $y <= 0;
2748
2749 $map->load;
2750
2751 return unless $self->contr->active;
2752
2753 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2754 if ($self->enter_map ($map, $x, $y)) {
2755 # entering was successful
2756 delete $self->{_link_recursion};
2757 # only activate afterwards, to support waiting in hooks
2758 $self->activate_recursive;
2759 }
2760
2761}
2762
2763=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
2764
2765Moves the player to the given map-path and coordinates by first freezing
2766her, loading and preparing them map, calling the provided $check callback
2767that has to return the map if sucecssful, and then unfreezes the player on
2768the new (success) or old (failed) map position. In either case, $done will
2769be called at the end of this process.
2770
2771Note that $check will be called with a potentially non-loaded map, so if
2772it needs a loaded map it has to call C<< ->load >>.
2773
2774=cut
2775
2776our $GOTOGEN;
2777
2778sub cf::object::player::goto {
2779 my ($self, $path, $x, $y, $check, $done) = @_;
2780
2781 if ($self->{_link_recursion} >= $MAX_LINKS) {
2782 error "FATAL: link recursion exceeded, ", $self->name, " goto $path $x $y, redirecting.";
2783 $self->failmsg ("Something went wrong inside the server - please contact an administrator!");
2784 ($path, $x, $y) = @$EMERGENCY_POSITION;
2785 }
2786
2787 # do generation counting so two concurrent goto's will be executed in-order
2788 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2789
2790 $self->enter_link;
2791
2792 (async {
2793 $Coro::current->{desc} = "player::goto $path $x $y";
2794
2795 # *tag paths override both path and x|y
2796 if ($path =~ /^\*(.*)$/) {
2797 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2798 my $ob = $obs[rand @obs];
2799
2800 # see if we actually can go there
2801 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2802 $ob = $obs[rand @obs];
2803 } else {
2804 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2805 }
2806 # else put us there anyways for now #d#
2807
2808 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2809 } else {
2810 ($path, $x, $y) = (undef, undef, undef);
2811 }
2812 }
2813
2814 my $map = eval {
2815 my $map = defined $path ? cf::map::find $path, $self->map : undef;
2816
2817 if ($map) {
2818 $map = $map->customise_for ($self);
2819 $map = $check->($map, $x, $y, $self) if $check && $map;
2820 } else {
2821 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2822 }
2823
2824 $map
44 }; 2825 };
45 2826
46 *{"$class\::set_$sub"} = sub { 2827 if ($@) {
47 $_[0]->set_property ($type, $idx, $_[1]); 2828 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
48 } unless $ignore_set{$prop}; 2829 LOG llevError | logBacktrace, Carp::longmess $@;
2830 }
2831
2832 if ($gen == $self->{_goto_generation}) {
2833 delete $self->{_goto_generation};
2834 $self->leave_link ($map, $x, $y);
2835 }
2836
2837 $done->($self) if $done;
2838 })->prio (1);
2839}
2840
2841=item $player_object->enter_exit ($exit_object)
2842
2843=cut
2844
2845sub parse_random_map_params {
2846 my ($spec) = @_;
2847
2848 my $rmp = { # defaults
2849 xsize => (cf::rndm 15, 40),
2850 ysize => (cf::rndm 15, 40),
2851 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
2852 #layout => string,
49 } 2853 };
50}
51 2854
52# auto-generate most of the API 2855 for (split /\n/, $spec) {
2856 my ($k, $v) = split /\s+/, $_, 2;
53 2857
54prop_gen OBJECT_PROP => "cf::object"; 2858 $rmp->{lc $k} = $v if (length $k) && (length $v);
55# CFAPI_OBJECT_ANIMATION? 2859 }
56prop_gen PLAYER_PROP => "cf::object::player";
57 2860
58prop_gen MAP_PROP => "cf::map"; 2861 $rmp
59prop_gen ARCH_PROP => "cf::arch";
60
61# guessed hierarchies
62
63@cf::object::player::ISA = 'cf::object';
64@cf::object::map::ISA = 'cf::object';
65
66my %ext_pkg;
67my @exts;
68my @hook;
69my %command;
70
71sub inject_event {
72 my $extension = shift;
73 my $event_code = shift;
74
75 my $cb = $hook[$event_code]{$extension}
76 or return;
77
78 &$cb
79} 2862}
80 2863
81sub inject_global_event { 2864sub prepare_random_map {
82 my $event = shift; 2865 my ($exit) = @_;
83 2866
84 my $cb = $hook[$event] 2867 # all this does is basically replace the /! path by
85 or return; 2868 # a new random map path (?random/...) with a seed
2869 # that depends on the exit object
86 2870
87 List::Util::max map &$_, values %$cb 2871 my $rmp = parse_random_map_params $exit->msg;
88}
89 2872
90sub inject_command { 2873 if ($exit->map) {
91 my ($name, $obj, $params) = @_; 2874 $rmp->{region} = $exit->region->name;
2875 $rmp->{origin_map} = $exit->map->path;
2876 $rmp->{origin_x} = $exit->x;
2877 $rmp->{origin_y} = $exit->y;
92 2878
93 for my $cmd (@{ $command{$name} }) { 2879 $exit->map->touch;
94 $cmd->[1]->($obj, $params); 2880 }
2881
2882 $rmp->{random_seed} ||= $exit->random_seed;
2883
2884 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2885 my $md5 = Digest::MD5::md5_hex $data;
2886 my $meta = "$RANDOMDIR/$md5.meta";
2887
2888 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2889 aio_write $fh, 0, (length $data), $data, 0;
2890 undef $fh;
2891 aio_rename "$meta~", $meta;
2892
2893 my $slaying = "?random/$md5";
2894
2895 if ($exit->valid) {
2896 $exit->slaying ("?random/$md5");
2897 $exit->msg (undef);
2898 }
2899 }
2900}
2901
2902sub cf::object::player::enter_exit {
2903 my ($self, $exit) = @_;
2904
2905 return unless $self->type == cf::PLAYER;
2906
2907 $self->enter_link;
2908
2909 (async {
2910 $Coro::current->{desc} = "enter_exit";
2911
2912 unless (eval {
2913 $self->deactivate_recursive; # just to be sure
2914
2915 my $map = cf::map::normalise $exit->slaying, $exit->map;
2916 my $x = $exit->stats->hp;
2917 my $y = $exit->stats->sp;
2918
2919 # special map handling
2920 my $slaying = $exit->slaying;
2921
2922 # special map handling
2923 if ($slaying eq "/!") {
2924 my $guard = cf::lock_acquire "exit_prepare:$exit";
2925
2926 prepare_random_map $exit
2927 if $exit->slaying eq "/!"; # need to re-check after getting the lock
2928
2929 $map = $exit->slaying;
2930
2931 } elsif ($slaying eq '!up') {
2932 $map = $exit->map->tile_path (cf::TILE_UP);
2933 $x = $exit->x;
2934 $y = $exit->y;
2935
2936 } elsif ($slaying eq '!down') {
2937 $map = $exit->map->tile_path (cf::TILE_DOWN);
2938 $x = $exit->x;
2939 $y = $exit->y;
2940 }
2941
2942 $self->goto ($map, $x, $y);
2943
2944 # if exit is damned, update players death & WoR home-position
2945 $self->contr->savebed ($map, $x, $y)
2946 if $exit->flag (cf::FLAG_DAMNED);
2947
2948 1
2949 }) {
2950 $self->message ("Something went wrong deep within the deliantra server. "
2951 . "I'll try to bring you back to the map you were before. "
2952 . "Please report this to the dungeon master!",
2953 cf::NDI_UNIQUE | cf::NDI_RED);
2954
2955 error "ERROR in enter_exit: $@";
2956 $self->leave_link;
2957 }
2958 })->prio (1);
2959}
2960
2961=head3 cf::client
2962
2963=over 4
2964
2965=item $client->send_drawinfo ($text, $flags)
2966
2967Sends a drawinfo packet to the client. Circumvents output buffering so
2968should not be used under normal circumstances.
2969
2970=cut
2971
2972sub cf::client::send_drawinfo {
2973 my ($self, $text, $flags) = @_;
2974
2975 utf8::encode $text;
2976 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2977}
2978
2979=item $client->send_big_packet ($pkt)
2980
2981Like C<send_packet>, but tries to compress large packets, and fragments
2982them as required.
2983
2984=cut
2985
2986our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
2987
2988sub cf::client::send_big_packet {
2989 my ($self, $pkt) = @_;
2990
2991 # try lzf for large packets
2992 $pkt = "lzf " . Compress::LZF::compress $pkt
2993 if 1024 <= length $pkt and $self->{can_lzf};
2994
2995 # split very large packets
2996 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
2997 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
2998 $pkt = "frag";
2999 }
3000
3001 $self->send_packet ($pkt);
3002}
3003
3004=item $client->send_msg ($channel, $msg, $color, [extra...])
3005
3006Send a drawinfo or msg packet to the client, formatting the msg for the
3007client if neccessary. C<$type> should be a string identifying the type of
3008the message, with C<log> being the default. If C<$color> is negative, suppress
3009the message unless the client supports the msg packet.
3010
3011=cut
3012
3013# non-persistent channels (usually the info channel)
3014our %CHANNEL = (
3015 "c/motd" => {
3016 id => "infobox",
3017 title => "MOTD",
3018 reply => undef,
3019 tooltip => "The message of the day",
95 } 3020 },
96 3021 "c/identify" => {
97 -1 3022 id => "infobox",
98} 3023 title => "Identify",
99 3024 reply => undef,
100sub register_command { 3025 tooltip => "Items recently identified",
101 my ($name, $time, $cb) = @_;
102
103 my $caller = caller;
104
105 warn "registering command '$name/$time' to '$caller'";
106
107 push @{ $command{$name} }, [$time, $cb, $caller];
108 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
109}
110
111sub register {
112 my ($base, $pkg) = @_;
113
114 for my $idx (0 .. $#EVENT) {
115 if (my $ref = $pkg->can ("on_$EVENT[$idx]")) {
116 warn "registering $EVENT[$idx] hook to '$pkg'\n";
117 $hook[$idx]{$base} = $ref;
118 }
119 } 3026 },
120} 3027 "c/examine" => {
3028 id => "infobox",
3029 title => "Examine",
3030 reply => undef,
3031 tooltip => "Signs and other items you examined",
3032 },
3033 "c/shopinfo" => {
3034 id => "infobox",
3035 title => "Shop Info",
3036 reply => undef,
3037 tooltip => "What your bargaining skill tells you about the shop",
3038 },
3039 "c/book" => {
3040 id => "infobox",
3041 title => "Book",
3042 reply => undef,
3043 tooltip => "The contents of a note or book",
3044 },
3045 "c/lookat" => {
3046 id => "infobox",
3047 title => "Look",
3048 reply => undef,
3049 tooltip => "What you saw there",
3050 },
3051 "c/who" => {
3052 id => "infobox",
3053 title => "Players",
3054 reply => undef,
3055 tooltip => "Shows players who are currently online",
3056 },
3057 "c/body" => {
3058 id => "infobox",
3059 title => "Body Parts",
3060 reply => undef,
3061 tooltip => "Shows which body parts you posess and are available",
3062 },
3063 "c/statistics" => {
3064 id => "infobox",
3065 title => "Statistics",
3066 reply => undef,
3067 tooltip => "Shows your primary statistics",
3068 },
3069 "c/skills" => {
3070 id => "infobox",
3071 title => "Skills",
3072 reply => undef,
3073 tooltip => "Shows your experience per skill and item power",
3074 },
3075 "c/shopitems" => {
3076 id => "infobox",
3077 title => "Shop Items",
3078 reply => undef,
3079 tooltip => "Shows the items currently for sale in this shop",
3080 },
3081 "c/resistances" => {
3082 id => "infobox",
3083 title => "Resistances",
3084 reply => undef,
3085 tooltip => "Shows your resistances",
3086 },
3087 "c/pets" => {
3088 id => "infobox",
3089 title => "Pets",
3090 reply => undef,
3091 tooltip => "Shows information abotu your pets/a specific pet",
3092 },
3093 "c/perceiveself" => {
3094 id => "infobox",
3095 title => "Perceive Self",
3096 reply => undef,
3097 tooltip => "You gained detailed knowledge about yourself",
3098 },
3099 "c/uptime" => {
3100 id => "infobox",
3101 title => "Uptime",
3102 reply => undef,
3103 tooltip => "How long the server has been running since last restart",
3104 },
3105 "c/mapinfo" => {
3106 id => "infobox",
3107 title => "Map Info",
3108 reply => undef,
3109 tooltip => "Information related to the maps",
3110 },
3111 "c/party" => {
3112 id => "party",
3113 title => "Party",
3114 reply => "gsay ",
3115 tooltip => "Messages and chat related to your party",
3116 },
3117 "c/death" => {
3118 id => "death",
3119 title => "Death",
3120 reply => undef,
3121 tooltip => "Reason for and more info about your most recent death",
3122 },
3123 "c/say" => $SAY_CHANNEL,
3124 "c/chat" => $CHAT_CHANNEL,
3125);
121 3126
122sub load_extension { 3127sub cf::client::send_msg {
3128 my ($self, $channel, $msg, $color, @extra) = @_;
3129
3130 $msg = $self->pl->expand_cfpod ($msg)
3131 unless $color & cf::NDI_VERBATIM;
3132
3133 $color &= cf::NDI_CLIENT_MASK; # just in case...
3134
3135 # check predefined channels, for the benefit of C
3136 if ($CHANNEL{$channel}) {
3137 $channel = $CHANNEL{$channel};
3138
3139 $self->ext_msg (channel_info => $channel);
3140 $channel = $channel->{id};
3141
3142 } elsif (ref $channel) {
3143 # send meta info to client, if not yet sent
3144 unless (exists $self->{channel}{$channel->{id}}) {
3145 $self->{channel}{$channel->{id}} = $channel;
3146 $self->ext_msg (channel_info => $channel);
3147 }
3148
3149 $channel = $channel->{id};
3150 }
3151
3152 return unless @extra || length $msg;
3153
3154 # default colour, mask it out
3155 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
3156 if $color & cf::NDI_DEF;
3157
3158 my $pkt = "msg "
3159 . $self->{json_coder}->encode (
3160 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
3161 );
3162
3163 $self->send_big_packet ($pkt);
3164}
3165
3166=item $client->ext_msg ($type, @msg)
3167
3168Sends an ext event to the client.
3169
3170=cut
3171
3172sub cf::client::ext_msg($$@) {
3173 my ($self, $type, @msg) = @_;
3174
3175 if ($self->extcmd == 2) {
3176 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
3177 } elsif ($self->extcmd == 1) { # TODO: remove
3178 push @msg, msgtype => "event_$type";
3179 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3180 }
3181}
3182
3183=item $client->ext_reply ($msgid, @msg)
3184
3185Sends an ext reply to the client.
3186
3187=cut
3188
3189sub cf::client::ext_reply($$@) {
3190 my ($self, $id, @msg) = @_;
3191
3192 return unless $self->extcmd == 2;
3193
3194 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
3195}
3196
3197=item $success = $client->query ($flags, "text", \&cb)
3198
3199Queues a query to the client, calling the given callback with
3200the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
3201C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
3202
3203Queries can fail, so check the return code. Or don't, as queries will
3204become reliable at some point in the future.
3205
3206=cut
3207
3208sub cf::client::query {
3209 my ($self, $flags, $text, $cb) = @_;
3210
3211 return unless $self->state == ST_PLAYING
3212 || $self->state == ST_SETUP
3213 || $self->state == ST_CUSTOM;
3214
3215 $self->state (ST_CUSTOM);
3216
3217 utf8::encode $text;
3218 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
3219
3220 $self->send_packet ($self->{query_queue}[0][0])
3221 if @{ $self->{query_queue} } == 1;
3222
3223 1
3224}
3225
3226cf::client->attach (
3227 on_connect => sub {
3228 my ($ns) = @_;
3229
3230 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
3231 },
3232 on_reply => sub {
3233 my ($ns, $msg) = @_;
3234
3235 # this weird shuffling is so that direct followup queries
3236 # get handled first
3237 my $queue = delete $ns->{query_queue}
3238 or return; # be conservative, not sure how that can happen, but we saw a crash here
3239
3240 (shift @$queue)->[1]->($msg);
3241 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
3242
3243 push @{ $ns->{query_queue} }, @$queue;
3244
3245 if (@{ $ns->{query_queue} } == @$queue) {
3246 if (@$queue) {
3247 $ns->send_packet ($ns->{query_queue}[0][0]);
3248 } else {
3249 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
3250 }
3251 }
3252 },
3253 on_exticmd => sub {
3254 my ($ns, $buf) = @_;
3255
3256 my $msg = eval { $ns->{json_coder}->decode ($buf) };
3257
3258 if (ref $msg) {
3259 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
3260
3261 my @reply;
3262
3263 if (my $cb = $EXTICMD{$type}) {
3264 @reply = $cb->($ns, @payload);
3265 }
3266
3267 $ns->ext_reply ($reply, @reply)
3268 if $reply;
3269
3270 } else {
3271 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3272 }
3273
3274 cf::override;
3275 },
3276);
3277
3278=item $client->async (\&cb)
3279
3280Create a new coroutine, running the specified callback. The coroutine will
3281be automatically cancelled when the client gets destroyed (e.g. on logout,
3282or loss of connection).
3283
3284=cut
3285
3286sub cf::client::async {
3287 my ($self, $cb) = @_;
3288
3289 my $coro = &Coro::async ($cb);
3290
3291 $coro->on_destroy (sub {
3292 delete $self->{_coro}{$coro+0};
3293 });
3294
3295 $self->{_coro}{$coro+0} = $coro;
3296
3297 $coro
3298}
3299
3300cf::client->attach (
3301 on_client_destroy => sub {
3302 my ($ns) = @_;
3303
3304 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
3305 },
3306);
3307
3308=back
3309
3310
3311=head2 SAFE SCRIPTING
3312
3313Functions that provide a safe environment to compile and execute
3314snippets of perl code without them endangering the safety of the server
3315itself. Looping constructs, I/O operators and other built-in functionality
3316is not available in the safe scripting environment, and the number of
3317functions and methods that can be called is greatly reduced.
3318
3319=cut
3320
3321our $safe = new Safe "safe";
3322our $safe_hole = new Safe::Hole;
3323
3324$SIG{FPE} = 'IGNORE';
3325
3326$safe->permit_only (Opcode::opset qw(
3327 :base_core :base_mem :base_orig :base_math :base_loop
3328 grepstart grepwhile mapstart mapwhile
3329 sort time
3330));
3331
3332# here we export the classes and methods available to script code
3333
3334=pod
3335
3336The following functions and methods are available within a safe environment:
3337
3338 cf::object
3339 contr pay_amount pay_player map x y force_find force_add destroy
3340 insert remove name archname title slaying race decrease split
3341 value
3342
3343 cf::object::player
3344 player
3345
3346 cf::player
3347 peaceful
3348
3349 cf::map
3350 trigger
3351
3352=cut
3353
3354for (
3355 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3356 insert remove inv nrof name archname title slaying race
3357 decrease split destroy change_exp value msg lore send_msg)],
3358 ["cf::object::player" => qw(player)],
3359 ["cf::player" => qw(peaceful send_msg)],
3360 ["cf::map" => qw(trigger)],
3361) {
3362 my ($pkg, @funs) = @$_;
3363 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
3364 for @funs;
3365}
3366
3367=over 4
3368
3369=item @retval = safe_eval $code, [var => value, ...]
3370
3371Compiled and executes the given perl code snippet. additional var/value
3372pairs result in temporary local (my) scalar variables of the given name
3373that are available in the code snippet. Example:
3374
3375 my $five = safe_eval '$first + $second', first => 1, second => 4;
3376
3377=cut
3378
3379sub safe_eval($;@) {
3380 my ($code, %vars) = @_;
3381
3382 my $qcode = $code;
3383 $qcode =~ s/"/‟/g; # not allowed in #line filenames
3384 $qcode =~ s/\n/\\n/g;
3385
3386 %vars = (_dummy => 0) unless %vars;
3387
3388 my @res;
3389 local $_;
3390
3391 my $eval =
3392 "do {\n"
3393 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
3394 . "#line 0 \"{$qcode}\"\n"
3395 . $code
3396 . "\n}"
3397 ;
3398
3399 if ($CFG{safe_eval}) {
3400 sub_generation_inc;
3401 local @safe::cf::_safe_eval_args = values %vars;
3402 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
3403 sub_generation_inc;
3404 } else {
3405 local @cf::_safe_eval_args = values %vars;
3406 @res = wantarray ? eval eval : scalar eval $eval;
3407 }
3408
3409 if ($@) {
3410 warn "$@",
3411 "while executing safe code '$code'\n",
3412 "with arguments " . (join " ", %vars) . "\n";
3413 }
3414
3415 wantarray ? @res : $res[0]
3416}
3417
3418=item cf::register_script_function $function => $cb
3419
3420Register a function that can be called from within map/npc scripts. The
3421function should be reasonably secure and should be put into a package name
3422like the extension.
3423
3424Example: register a function that gets called whenever a map script calls
3425C<rent::overview>, as used by the C<rent> extension.
3426
3427 cf::register_script_function "rent::overview" => sub {
3428 ...
3429 };
3430
3431=cut
3432
3433sub register_script_function {
3434 my ($fun, $cb) = @_;
3435
3436 $fun = "safe::$fun" if $CFG{safe_eval};
3437 *$fun = $safe_hole->wrap ($cb);
3438}
3439
3440=back
3441
3442=cut
3443
3444#############################################################################
3445# the server's init and main functions
3446
3447sub load_facedata($) {
123 my ($path) = @_; 3448 my ($path) = @_;
124 3449
125 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 3450 # HACK to clear player env face cache, we need some signal framework
126 my $base = $1; 3451 # for this (global event?)
127 my $pkg = $1; 3452 %ext::player_env::MUSIC_FACE_CACHE = ();
128 $pkg =~ s/[^[:word:]]/_/g;
129 $pkg = "cf::ext::$pkg";
130 3453
131 warn "loading '$path' into '$pkg'\n"; 3454 my $enc = JSON::XS->new->utf8->canonical->relaxed;
132 3455
133 open my $fh, "<:utf8", $path 3456 trace "loading facedata from $path\n";
134 or die "$path: $!";
135 3457
136 my $source = 3458 my $facedata = decode_storable load_file $path;
137 "package $pkg; use strict; use utf8;\n"
138 . "#line 1 \"$path\"\n{\n"
139 . (do { local $/; <$fh> })
140 . "\n};\n1";
141 3459
142 eval $source 3460 $facedata->{version} == 2
143 or die "$path: $@"; 3461 or cf::cleanup "$path: version mismatch, cannot proceed.";
144 3462
145 push @exts, $pkg; 3463 # patch in the exptable
146 $ext_pkg{$base} = $pkg; 3464 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
147 3465 $facedata->{resource}{"res/exp_table"} = {
148# no strict 'refs'; 3466 type => FT_RSRC,
149# @{"$pkg\::ISA"} = cf::ext::; 3467 data => $exp_table,
150 3468 hash => (Digest::MD5::md5 $exp_table),
151 register $base, $pkg;
152}
153
154sub unload_extension {
155 my ($pkg) = @_;
156
157 warn "removing extension $pkg\n";
158
159 # remove hooks
160 for my $idx (0 .. $#EVENT) {
161 delete $hook[$idx]{$pkg};
162 } 3469 };
3470 cf::cede_to_tick;
163 3471
164 # remove commands 3472 {
165 for my $name (keys %command) { 3473 my $faces = $facedata->{faceinfo};
166 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} };
167 3474
168 if (@cb) { 3475 while (my ($face, $info) = each %$faces) {
169 $command{$name} = \@cb; 3476 my $idx = (cf::face::find $face) || cf::face::alloc $face;
170 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb; 3477
3478 cf::face::set_visibility $idx, $info->{visibility};
3479 cf::face::set_magicmap $idx, $info->{magicmap};
3480 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3481 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3482 cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph} ;
3483
3484 cf::cede_to_tick;
3485 }
3486
3487 while (my ($face, $info) = each %$faces) {
3488 next unless $info->{smooth};
3489
3490 my $idx = cf::face::find $face
3491 or next;
3492
3493 if (my $smooth = cf::face::find $info->{smooth}) {
3494 cf::face::set_smooth $idx, $smooth;
3495 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
171 } else { 3496 } else {
172 delete $command{$name}; 3497 error "smooth face '$info->{smooth}' not found for face '$face'";
173 delete $COMMAND{"$name\000"};
174 } 3498 }
3499
3500 cf::cede_to_tick;
3501 }
3502 }
3503
175 } 3504 {
3505 my $anims = $facedata->{animinfo};
176 3506
177 Symbol::delete_package $pkg; 3507 while (my ($anim, $info) = each %$anims) {
178} 3508 cf::anim::set $anim, $info->{frames}, $info->{facings};
3509 cf::cede_to_tick;
3510 }
179 3511
3512 cf::anim::invalidate_all; # d'oh
3513 }
3514
3515 {
3516 my $res = $facedata->{resource};
3517
3518 while (my ($name, $info) = each %$res) {
3519 if (defined $info->{type}) {
3520 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3521
3522 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3523 cf::face::set_type $idx, $info->{type};
3524 } else {
3525 $RESOURCE{$name} = $info; # unused
3526 }
3527
3528 cf::cede_to_tick;
3529 }
3530 }
3531
3532 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3533
3534 1
3535}
3536
3537register_exticmd fx_want => sub {
3538 my ($ns, $want) = @_;
3539
3540 while (my ($k, $v) = each %$want) {
3541 $ns->fx_want ($k, $v);
3542 }
3543};
3544
3545sub load_resource_file($) {
3546 my $guard = lock_acquire "load_resource_file";
3547
3548 my $status = load_resource_file_ $_[0];
3549 get_slot 0.1, 100;
3550 cf::arch::commit_load;
3551
3552 $status
3553}
3554
180sub load_extensions { 3555sub reload_regions {
181 my $LIBDIR = maps_directory "perl"; 3556 # HACK to clear player env face cache, we need some signal framework
3557 # for this (global event?)
3558 %ext::player_env::MUSIC_FACE_CACHE = ();
182 3559
183 for my $ext (<$LIBDIR/*.ext>) { 3560 load_resource_file "$MAPDIR/regions"
184 next unless -r $ext; 3561 or die "unable to load regions file\n";
3562
3563 for (cf::region::list) {
3564 $_->{match} = qr/$_->{match}/
3565 if exists $_->{match};
3566 }
3567}
3568
3569sub reload_facedata {
3570 load_facedata "$DATADIR/facedata"
3571 or die "unable to load facedata\n";
3572}
3573
3574sub reload_archetypes {
3575 load_resource_file "$DATADIR/archetypes"
3576 or die "unable to load archetypes\n";
3577}
3578
3579sub reload_treasures {
3580 load_resource_file "$DATADIR/treasures"
3581 or die "unable to load treasurelists\n";
3582}
3583
3584sub reload_sound {
3585 trace "loading sound config from $DATADIR/sound\n";
3586
3587 my $soundconf = JSON::XS->new->utf8->relaxed->decode (load_file "$DATADIR/sound");
3588
3589 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3590 my $sound = $soundconf->{compat}[$_]
3591 or next;
3592
3593 my $face = cf::face::find "sound/$sound->[1]";
3594 cf::sound::set $sound->[0] => $face;
3595 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3596 }
3597
3598 while (my ($k, $v) = each %{$soundconf->{event}}) {
3599 my $face = cf::face::find "sound/$v";
3600 cf::sound::set $k => $face;
3601 }
3602}
3603
3604sub reload_resources {
3605 trace "reloading resource files...\n";
3606
3607 reload_exp_table;
3608 reload_materials;
3609 reload_facedata;
3610 reload_sound;
3611 reload_archetypes;
3612 reload_regions;
3613 reload_treasures;
3614
3615 trace "finished reloading resource files\n";
3616}
3617
3618sub reload_config {
3619 trace "reloading config file...\n";
3620
3621 my $config = load_file "$CONFDIR/config";
3622 utf8::decode $config;
3623 *CFG = decode_yaml $config;
3624
3625 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3626
3627 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3628 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3629
3630 if (exists $CFG{mlockall}) {
185 eval { 3631 eval {
186 load_extension $ext; 3632 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
187 1 3633 and die "WARNING: m(un)lockall failed: $!\n";
188 } or warn "$ext not loaded: $@";
189 }
190}
191
192register_command "perl-reload", 0, sub {
193 my ($who, $arg) = @_;
194
195 if ($who->flag (FLAG_WIZ)) {
196 $who->message ("reloading...");
197
198 warn "reloading...\n";
199 eval {
200 unload_extension $_ for @exts;
201 delete $INC{"cf.pm"};
202
203 # don't, removes xs symbols, too
204 #Symbol::delete_package $pkg;
205
206 require cf;
207 }; 3634 };
208 warn $@ if $@; 3635 warn $@ if $@;
209 $who->message ($@) if $@; 3636 }
210 warn "reloaded\n"; 3637}
211 3638
3639sub pidfile() {
3640 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3641 or die "$PIDFILE: $!";
3642 flock $fh, &Fcntl::LOCK_EX
3643 or die "$PIDFILE: flock: $!";
3644 $fh
3645}
3646
3647# make sure only one server instance is running at any one time
3648sub atomic {
3649 my $fh = pidfile;
3650
3651 my $pid = <$fh>;
3652 kill 9, $pid if $pid > 0;
3653
3654 seek $fh, 0, 0;
3655 print $fh $$;
3656}
3657
3658sub main_loop {
3659 trace "EV::loop starting\n";
3660 if (1) {
3661 EV::loop;
3662 }
3663 trace "EV::loop returned\n";
3664 goto &main_loop unless $REALLY_UNLOOP;
3665}
3666
3667sub main {
3668 cf::init_globals; # initialise logging
3669
3670 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3671 LOG llevInfo, "Copyright (C) 2005-2012 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3672 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3673 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3674
3675 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3676
3677 # we must not ever block the main coroutine
3678 local $Coro::idle = sub {
3679 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3680 (async {
3681 $Coro::current->{desc} = "IDLE BUG HANDLER";
3682 EV::loop EV::LOOP_ONESHOT;
3683 })->prio (Coro::PRIO_MAX);
3684 };
3685
3686 evthread_start IO::AIO::poll_fileno;
3687
3688 cf::sync_job {
3689 cf::incloader::init ();
3690
3691 cf::init_anim;
3692 cf::init_attackmess;
3693 cf::init_dynamic;
3694
3695 cf::load_settings;
3696
3697 reload_resources;
3698 reload_config;
3699 db_init;
3700
3701 cf::init_uuid;
3702 cf::init_signals;
3703 cf::init_skills;
3704
3705 cf::init_beforeplay;
3706
3707 atomic;
3708
3709 load_extensions;
3710
3711 utime time, time, $RUNTIMEFILE;
3712
3713 # no (long-running) fork's whatsoever before this point(!)
3714 use POSIX ();
3715 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3716
3717 cf::_post_init 0;
3718 };
3719
3720 cf::object::thawer::errors_are_fatal 0;
3721 info "parse errors in files are no longer fatal from this point on.\n";
3722
3723 AE::postpone {
3724 undef &main; # free gobs of memory :)
3725 };
3726
3727 goto &main_loop;
3728}
3729
3730#############################################################################
3731# initialisation and cleanup
3732
3733# install some emergency cleanup handlers
3734BEGIN {
3735 our %SIGWATCHER = ();
3736 for my $signal (qw(INT HUP TERM)) {
3737 $SIGWATCHER{$signal} = AE::signal $signal, sub {
3738 cf::cleanup "SIG$signal";
3739 };
3740 }
3741}
3742
3743sub write_runtime_sync {
3744 my $t0 = AE::time;
3745
3746 # first touch the runtime file to show we are still running:
3747 # the fsync below can take a very very long time.
3748
3749 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3750
3751 my $guard = cf::lock_acquire "write_runtime";
3752
3753 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3754 or return;
3755
3756 my $value = $cf::RUNTIME + 90 + 10;
3757 # 10 is the runtime save interval, for a monotonic clock
3758 # 60 allows for the watchdog to kill the server.
3759
3760 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3761 and return;
3762
3763 # always fsync - this file is important
3764 aio_fsync $fh
3765 and return;
3766
3767 # touch it again to show we are up-to-date
3768 aio_utime $fh, undef, undef;
3769
3770 close $fh
3771 or return;
3772
3773 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3774 and return;
3775
3776 trace sprintf "runtime file written (%gs).\n", AE::time - $t0;
3777
3778 1
3779}
3780
3781our $uuid_lock;
3782our $uuid_skip;
3783
3784sub write_uuid_sync($) {
3785 $uuid_skip ||= $_[0];
3786
3787 return if $uuid_lock;
3788 local $uuid_lock = 1;
3789
3790 my $uuid = "$LOCALDIR/uuid";
3791
3792 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3793 or return;
3794
3795 my $value = uuid_seq uuid_cur;
3796
3797 unless ($value) {
3798 info "cowardly refusing to write zero uuid value!\n";
3799 return;
3800 }
3801
3802 my $value = uuid_str $value + $uuid_skip;
3803 $uuid_skip = 0;
3804
3805 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3806 and return;
3807
3808 # always fsync - this file is important
3809 aio_fsync $fh
3810 and return;
3811
3812 close $fh
3813 or return;
3814
3815 aio_rename "$uuid~", $uuid
3816 and return;
3817
3818 trace "uuid file written ($value).\n";
3819
3820 1
3821
3822}
3823
3824sub write_uuid($$) {
3825 my ($skip, $sync) = @_;
3826
3827 $sync ? write_uuid_sync $skip
3828 : async { write_uuid_sync $skip };
3829}
3830
3831sub emergency_save() {
3832 my $freeze_guard = cf::freeze_mainloop;
3833
3834 info "emergency_perl_save: enter\n";
3835
3836 # this is a trade-off: we want to be very quick here, so
3837 # save all maps without fsync, and later call a global sync
3838 # (which in turn might be very very slow)
3839 local $USE_FSYNC = 0;
3840
3841 cf::sync_job {
3842 cf::write_runtime_sync; # external watchdog should not bark
3843
3844 # use a peculiar iteration method to avoid tripping on perl
3845 # refcount bugs in for. also avoids problems with players
3846 # and maps saved/destroyed asynchronously.
3847 info "emergency_perl_save: begin player save\n";
3848 for my $login (keys %cf::PLAYER) {
3849 my $pl = $cf::PLAYER{$login} or next;
3850 $pl->valid or next;
3851 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3852 $pl->save;
3853 }
3854 info "emergency_perl_save: end player save\n";
3855
3856 cf::write_runtime_sync; # external watchdog should not bark
3857
3858 info "emergency_perl_save: begin map save\n";
3859 for my $path (keys %cf::MAP) {
3860 my $map = $cf::MAP{$path} or next;
3861 $map->valid or next;
3862 $map->save;
3863 }
3864 info "emergency_perl_save: end map save\n";
3865
3866 cf::write_runtime_sync; # external watchdog should not bark
3867
3868 info "emergency_perl_save: begin database checkpoint\n";
3869 BDB::db_env_txn_checkpoint $DB_ENV;
3870 info "emergency_perl_save: end database checkpoint\n";
3871
3872 info "emergency_perl_save: begin write uuid\n";
3873 write_uuid_sync 1;
3874 info "emergency_perl_save: end write uuid\n";
3875
3876 cf::write_runtime_sync; # external watchdog should not bark
3877
3878 trace "emergency_perl_save: syncing database to disk";
3879 BDB::db_env_txn_checkpoint $DB_ENV;
3880
3881 info "emergency_perl_save: starting sync\n";
3882 IO::AIO::aio_sync sub {
3883 info "emergency_perl_save: finished sync\n";
3884 };
3885
3886 cf::write_runtime_sync; # external watchdog should not bark
3887
3888 trace "emergency_perl_save: flushing outstanding aio requests";
3889 while (IO::AIO::nreqs || BDB::nreqs) {
3890 Coro::AnyEvent::sleep 0.01; # let the sync_job do it's thing
3891 }
3892
3893 cf::write_runtime_sync; # external watchdog should not bark
3894 };
3895
3896 info "emergency_perl_save: leave\n";
3897}
3898
3899sub post_cleanup {
3900 my ($make_core) = @_;
3901
3902 IO::AIO::flush;
3903
3904 error Carp::longmess "post_cleanup backtrace"
3905 if $make_core;
3906
3907 my $fh = pidfile;
3908 unlink $PIDFILE if <$fh> == $$;
3909}
3910
3911# a safer delete_package, copied from Symbol
3912sub clear_package($) {
3913 my $pkg = shift;
3914
3915 # expand to full symbol table name if needed
3916 unless ($pkg =~ /^main::.*::$/) {
3917 $pkg = "main$pkg" if $pkg =~ /^::/;
3918 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3919 $pkg .= '::' unless $pkg =~ /::$/;
3920 }
3921
3922 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3923 my $stem_symtab = *{$stem}{HASH};
3924
3925 defined $stem_symtab and exists $stem_symtab->{$leaf}
3926 or return;
3927
3928 # clear all symbols
3929 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3930 for my $name (keys %$leaf_symtab) {
3931 _gv_clear *{"$pkg$name"};
3932# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3933 }
3934}
3935
3936sub do_reload_perl() {
3937 # can/must only be called in main
3938 unless (in_main) {
3939 error "can only reload from main coroutine";
3940 return;
3941 }
3942
3943 return if $RELOAD++;
3944
3945 my $t1 = AE::time;
3946
3947 while ($RELOAD) {
3948 cf::get_slot 0.1, -1, "reload_perl";
3949 info "perl_reload: reloading...";
3950
3951 trace "perl_reload: entering sync_job";
3952
3953 cf::sync_job {
3954 #cf::emergency_save;
3955
3956 trace "perl_reload: cancelling all extension coros";
3957 $_->cancel for values %EXT_CORO;
3958 %EXT_CORO = ();
3959
3960 trace "perl_reload: removing commands";
3961 %COMMAND = ();
3962
3963 trace "perl_reload: removing ext/exti commands";
3964 %EXTCMD = ();
3965 %EXTICMD = ();
3966
3967 trace "perl_reload: unloading/nuking all extensions";
3968 for my $pkg (@EXTS) {
3969 trace "... unloading $pkg";
3970
3971 if (my $cb = $pkg->can ("unload")) {
3972 eval {
3973 $cb->($pkg);
3974 1
3975 } or error "$pkg unloaded, but with errors: $@";
3976 }
3977
3978 trace "... clearing $pkg";
3979 clear_package $pkg;
3980 }
3981
3982 trace "perl_reload: unloading all perl modules loaded from $LIBDIR";
3983 while (my ($k, $v) = each %INC) {
3984 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3985
3986 trace "... unloading $k";
3987 delete $INC{$k};
3988
3989 $k =~ s/\.pm$//;
3990 $k =~ s/\//::/g;
3991
3992 if (my $cb = $k->can ("unload_module")) {
3993 $cb->();
3994 }
3995
3996 clear_package $k;
3997 }
3998
3999 trace "perl_reload: getting rid of safe::, as good as possible";
4000 clear_package "safe::$_"
4001 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
4002
4003 trace "perl_reload: unloading cf.pm \"a bit\"";
4004 delete $INC{"cf.pm"};
4005 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
4006
4007 # don't, removes xs symbols, too,
4008 # and global variables created in xs
4009 #clear_package __PACKAGE__;
4010
4011 info "perl_reload: unload completed, starting to reload now";
4012
4013 trace "perl_reload: reloading cf.pm";
4014 require cf;
4015 cf::_connect_to_perl_1;
4016
4017 trace "perl_reload: loading config and database again";
4018 cf::reload_config;
4019
4020 trace "perl_reload: loading extensions";
4021 cf::load_extensions;
4022
4023 if ($REATTACH_ON_RELOAD) {
4024 trace "perl_reload: reattaching attachments to objects/players";
4025 _global_reattach; # objects, sockets
4026 trace "perl_reload: reattaching attachments to maps";
4027 reattach $_ for values %MAP;
4028 trace "perl_reload: reattaching attachments to players";
4029 reattach $_ for values %PLAYER;
4030 }
4031
4032 cf::_post_init 1;
4033
4034 trace "perl_reload: leaving sync_job";
4035
4036 1
4037 } or do {
4038 error $@;
4039 cf::cleanup "perl_reload: error, exiting.";
4040 };
4041
4042 --$RELOAD;
4043 }
4044
4045 $t1 = AE::time - $t1;
4046 info "perl_reload: completed in ${t1}s\n";
4047};
4048
4049our $RELOAD_WATCHER; # used only during reload
4050
4051sub reload_perl() {
4052 # doing reload synchronously and two reloads happen back-to-back,
4053 # coro crashes during coro_state_free->destroy here.
4054
4055 $RELOAD_WATCHER ||= cf::async {
4056 Coro::AIO::aio_wait cache_extensions;
4057
4058 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
4059 do_reload_perl;
4060 undef $RELOAD_WATCHER;
4061 };
4062 };
4063}
4064
4065register_command "reload" => sub {
4066 my ($who, $arg) = @_;
4067
4068 if ($who->flag (FLAG_WIZ)) {
212 $who->message ("reloaded"); 4069 $who->message ("reloading server.");
4070 async {
4071 $Coro::current->{desc} = "perl_reload";
4072 reload_perl;
4073 };
4074 }
4075};
4076
4077#############################################################################
4078
4079my $bug_warning = 0;
4080
4081sub wait_for_tick() {
4082 return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
4083
4084 $WAIT_FOR_TICK->wait;
4085}
4086
4087sub wait_for_tick_begin() {
4088 return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
4089
4090 my $signal = new Coro::Signal;
4091 push @WAIT_FOR_TICK_BEGIN, $signal;
4092 $signal->wait;
4093}
4094
4095sub tick {
4096 if ($Coro::current != $Coro::main) {
4097 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
4098 unless ++$bug_warning > 10;
4099 return;
4100 }
4101
4102 cf::one_tick; # one server iteration
4103
4104 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
4105
4106 if ($NOW >= $NEXT_RUNTIME_WRITE) {
4107 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
4108 Coro::async_pool {
4109 $Coro::current->{desc} = "runtime saver";
4110 write_runtime_sync
4111 or error "ERROR: unable to write runtime file: $!";
4112 };
4113 }
4114
4115 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
4116 $sig->send;
4117 }
4118 $WAIT_FOR_TICK->broadcast;
4119
4120 $LOAD = ($NOW - $TICK_START) / $TICK;
4121 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
4122
4123 if (0) {
4124 if ($NEXT_TICK) {
4125 my $jitter = $TICK_START - $NEXT_TICK;
4126 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
4127 debug "jitter $JITTER\n";#d#
4128 }
4129 }
4130}
4131
4132{
4133 # configure BDB
4134
4135 BDB::min_parallel 16;
4136 BDB::max_poll_reqs $TICK * 0.1;
4137 #$AnyEvent::BDB::WATCHER->priority (1);
4138
4139 unless ($DB_ENV) {
4140 $DB_ENV = BDB::db_env_create;
4141 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
4142 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
4143 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
4144 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
4145 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
4146
4147 cf::sync_job {
4148 eval {
4149 BDB::db_env_open
4150 $DB_ENV,
4151 $BDBDIR,
4152 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
4153 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
4154 0666;
4155
4156 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
4157 };
4158
4159 cf::cleanup "db_env_open(db): $@" if $@;
4160 };
4161 }
4162
4163 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
4164 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
4165 };
4166 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
4167 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
4168 };
4169 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
4170 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
4171 };
4172}
4173
4174{
4175 # configure IO::AIO
4176
4177 IO::AIO::min_parallel 8;
4178 IO::AIO::max_poll_time $TICK * 0.1;
4179 undef $AnyEvent::AIO::WATCHER;
4180}
4181
4182our $_log_backtrace;
4183our $_log_backtrace_last;
4184
4185sub _log_backtrace {
4186 my ($msg, @addr) = @_;
4187
4188 $msg =~ s/\n$//;
4189
4190 if ($_log_backtrace_last eq $msg) {
4191 LOG llevInfo, "[ABT] $msg\n";
4192 LOG llevInfo, "[ABT] [duplicate, suppressed]\n";
4193 # limit the # of concurrent backtraces
4194 } elsif ($_log_backtrace < 2) {
4195 $_log_backtrace_last = $msg;
4196 ++$_log_backtrace;
4197 my $perl_bt = Carp::longmess $msg;
4198 async {
4199 $Coro::current->{desc} = "abt $msg";
4200
4201 my @bt = fork_call {
4202 @addr = map { sprintf "%x", $_ } @addr;
4203 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
4204 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
4205 or die "addr2line: $!";
4206
4207 my @funcs;
4208 my @res = <$fh>;
4209 chomp for @res;
4210 while (@res) {
4211 my ($func, $line) = splice @res, 0, 2, ();
4212 push @funcs, "[$func] $line";
4213 }
4214
4215 @funcs
4216 };
4217
4218 LOG llevInfo, "[ABT] $perl_bt\n";
4219 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
4220 LOG llevInfo, "[ABT] $_\n" for @bt;
4221 --$_log_backtrace;
4222 };
213 } else { 4223 } else {
214 $who->message ("Intruder Alert!"); 4224 LOG llevInfo, "[ABT] $msg\n";
4225 LOG llevInfo, "[ABT] [overload, suppressed]\n";
215 } 4226 }
216}; 4227}
217 4228
218############################################################################# 4229# load additional modules
219# load/save/clean perl data associated with a map 4230require "cf/$_.pm" for @EXTRA_MODULES;
4231cf::_connect_to_perl_2;
220 4232
221*on_mapclean = sub { 4233END { cf::emergency_save }
222 my ($map) = @_;
223
224 my $path = $map->tmpname;
225 defined $path or return;
226
227 unlink "$path.cfperl";
228};
229
230*on_mapin =
231*on_mapload = sub {
232 my ($map) = @_;
233
234 my $path = $map->tmpname;
235 $path = $map->path unless defined $path;
236
237 open my $fh, "<:raw", "$path.cfperl"
238 or return; # no perl data
239
240 my $data = Storable::thaw do { local $/; <$fh> };
241
242 $data->{version} <= 1
243 or return; # too new
244
245 $map->_set_obs ($data->{obs});
246};
247
248*on_mapout = sub {
249 my ($map) = @_;
250
251 my $path = $map->tmpname;
252 $path = $map->path unless defined $path;
253
254 my $obs = $map->_get_obs;
255
256 if (defined $obs) {
257 open my $fh, ">:raw", "$path.cfperl"
258 or die "$path.cfperl: $!";
259
260 stat $path;
261
262 print $fh Storable::nfreeze {
263 size => (stat _)[7],
264 time => (stat _)[9],
265 version => 1,
266 obs => $obs,
267 };
268
269 chmod SAVE_MODE, "$path.cfperl"; # very racy, but cf-compatible *g*
270 } else {
271 unlink "$path.cfperl";
272 }
273};
274
275#############################################################################
276# load/save perl data associated with player->ob objects
277
278*on_player_load = sub {
279 my ($ob, $path) = @_;
280
281 if (open my $fh, "<:raw", "$path.cfperl") {
282
283 #d##TODO#remove
284
285 my $data = Storable::thaw do { local $/; <$fh> };
286
287 $data->{version} <= 1
288 or return; # too new
289
290 %$ob = %{$data->{ob}};
291 return;
292 }
293
294 for my $o ($ob, $ob->inv) {
295 if (my $value = $o->get_ob_key_value ("_perl_data")) {
296 $o->set_ob_key_value ("_perl_data");
297
298 %$o = %{ Storable::thaw pack "H*", $value };
299 }
300 }
301};
302
303*on_player_save = sub {
304 my ($ob, $path) = @_;
305
306 $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_)
307 for grep %$_, $ob, $ob->inv;
308
309 unlink "$path.cfperl";#d##TODO#remove
310};
311
312register "<global>", __PACKAGE__;
313
314load_extensions;
315 4234
3161 42351
317 4236

Diff Legend

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