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

Diff Legend

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