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.43 by root, Fri Aug 25 17:11:53 2006 UTC vs.
Revision 1.571 by root, Wed May 4 19:04:45 2011 UTC

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

Diff Legend

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