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.96 by root, Fri Dec 22 06:02:29 2006 UTC vs.
Revision 1.568 by root, Tue May 3 17:12:14 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/$_";
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
1960 $path =~ s/$PATH_SEP/\//go;
1961
1962 # treat it as relative path if it starts with
1963 # something that looks reasonable
1964 if ($path =~ m{^(?:\./|\.\./|\w)}) {
1965 $base or Carp::carp "normalise called with relative path and no base: '$path'";
1966
1967 $base =~ s{[^/]+/?$}{};
1968 $path = "$base/$path";
1969 }
1970
1971 for ($path) {
1972 redo if s{/\.?/}{/};
1973 redo if s{/[^/]+/\.\./}{/};
1974 }
1975
1976 $path
1977}
1978
1979sub new_from_path {
1980 my (undef, $path, $base) = @_;
1981
1982 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object
1983
1984 $path = normalise $path, $base;
1985
1986 for my $pkg (sort { $EXT_MAP{$b}[0] <=> $EXT_MAP{$a}[0] } keys %EXT_MAP) {
1987 if ($path =~ $EXT_MAP{$pkg}[1]) {
1988 my $self = bless cf::map::new, $pkg;
1989 $self->{path} = $path; $self->path ($path);
1990 $self->init; # pass $1 etc.
1991 return $self;
1992 }
1993 }
1994
1995 Carp::cluck "unable to resolve path '$path' (base '$base')";
1996 ()
1997}
1998
1999# may re-bless or do other evil things
2000sub init {
2001 my ($self) = @_;
2002
2003 $self
2004}
2005
2006sub as_string {
2007 my ($self) = @_;
2008
2009 "$self->{path}"
2010}
2011
2012# the displayed name, this is a one way mapping
2013sub visible_name {
2014 &as_string
2015}
2016
2017# the original (read-only) location
2018sub load_path {
2019 my ($self) = @_;
2020
2021 "$MAPDIR/$self->{path}.map"
2022}
2023
2024# the temporary/swap location
2025sub save_path {
2026 my ($self) = @_;
2027
2028 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
2029 "$TMPDIR/$path.map"
2030}
2031
2032# the unique path, undef == no special unique path
2033sub uniq_path {
2034 my ($self) = @_;
2035
2036 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
2037 "$UNIQUEDIR/$path"
2038}
2039
2040sub decay_objects {
2041 my ($self) = @_;
2042
2043 return if $self->{deny_reset};
2044
2045 $self->do_decay_objects;
2046}
2047
2048sub unlink_save {
2049 my ($self) = @_;
2050
2051 utf8::encode (my $save = $self->save_path);
2052 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
2053 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst";
2054}
2055
2056sub load_header_from($) {
2057 my ($self, $path) = @_;
2058
2059 utf8::encode $path;
2060 my $f = new_from_file cf::object::thawer $path
2061 or return;
2062
2063 $self->_load_header ($f)
2064 or return;
2065
2066 local $MAP_LOADING{$self->{path}} = $self;
2067 $f->resolve_delayed_derefs;
2068
2069 $self->{load_path} = $path;
2070
2071 1
2072}
2073
2074# used to laod the header of an original map
2075sub load_header_orig {
2076 my ($self) = @_;
2077
2078 $self->load_header_from ($self->load_path)
2079}
2080
2081# used to laod the header of an instantiated map
2082sub load_header_temp {
2083 my ($self) = @_;
2084
2085 $self->load_header_from ($self->save_path)
2086}
2087
2088# called after loading the header from an instantiated map
2089sub prepare_temp {
2090 my ($self) = @_;
2091
2092 $self->last_access ((delete $self->{last_access})
2093 || $cf::RUNTIME); #d#
2094 # safety
2095 $self->{instantiate_time} = $cf::RUNTIME
2096 if $self->{instantiate_time} > $cf::RUNTIME;
2097}
2098
2099# called after loading the header from an original map
2100sub prepare_orig {
2101 my ($self) = @_;
2102
2103 $self->{load_original} = 1;
2104 $self->{instantiate_time} = $cf::RUNTIME;
2105 $self->last_access ($cf::RUNTIME);
2106 $self->instantiate;
2107}
2108
2109sub load_header {
2110 my ($self) = @_;
2111
2112 if ($self->load_header_temp) {
2113 $self->prepare_temp;
2114 } else {
2115 $self->load_header_orig
2116 or return;
2117 $self->prepare_orig;
2118 }
2119
2120 $self->{deny_reset} = 1
2121 if $self->no_reset;
2122
2123 $self->default_region (cf::region::find_by_path $self->{path})
2124 unless $self->default_region;
2125
2126 1
2127}
2128
2129sub find;
2130sub find {
2131 my ($path, $origin) = @_;
2132
2133 cf::cede_to_tick;
2134
2135 $path = normalise $path, $origin;
2136
2137 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
2138 my $guard2 = cf::lock_acquire "map_find:$path";
2139
2140 $cf::MAP{$path} || do {
2141 my $map = new_from_path cf::map $path
2142 or return;
2143
2144 $map->{last_save} = $cf::RUNTIME;
2145
2146 $map->load_header
2147 or return;
2148
2149 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
2150 # doing this can freeze the server in a sync job, obviously
2151 #$cf::WAIT_FOR_TICK->wait;
2152 undef $guard2;
2153 undef $guard1;
2154 $map->reset;
2155 return find $path;
2156 }
2157
2158 $cf::MAP{$path} = $map
2159 }
2160}
2161
2162sub pre_load { }
2163#sub post_load { } # XS
2164
2165sub load {
2166 my ($self) = @_;
2167
2168 local $self->{deny_reset} = 1; # loading can take a long time
2169
2170 my $path = $self->{path};
2171
2172 {
2173 my $guard = cf::lock_acquire "map_data:$path";
2174
2175 return unless $self->valid;
2176 return unless $self->in_memory == cf::MAP_SWAPPED;
2177
2178 $self->in_memory (cf::MAP_LOADING);
2179
2180 $self->alloc;
2181
2182 $self->pre_load;
2183 cf::cede_to_tick;
2184
2185 if (exists $self->{load_path}) {
2186 my $f = new_from_file cf::object::thawer $self->{load_path};
2187 $f->skip_block;
2188 $self->_load_objects ($f)
2189 or return;
2190
2191 $self->post_load_original
2192 if delete $self->{load_original};
2193
2194 if (my $uniq = $self->uniq_path) {
2195 utf8::encode $uniq;
2196 unless (aio_stat $uniq) {
2197 if (my $f = new_from_file cf::object::thawer $uniq) {
2198 $self->clear_unique_items;
2199 $self->_load_objects ($f);
2200 $f->resolve_delayed_derefs;
2201 }
2202 }
2203 }
2204
2205 $f->resolve_delayed_derefs;
2206 } else {
2207 $self->post_load_original
2208 if delete $self->{load_original};
2209 }
2210
2211 cf::cede_to_tick;
2212 # now do the right thing for maps
2213 $self->link_multipart_objects;
2214 $self->difficulty ($self->estimate_difficulty)
2215 unless $self->difficulty;
2216 cf::cede_to_tick;
2217
2218 unless ($self->{deny_activate}) {
2219 $self->decay_objects;
2220 $self->fix_auto_apply;
2221 $self->update_buttons;
2222 cf::cede_to_tick;
2223 #$self->activate; # no longer activate maps automatically
2224 }
2225
2226 $self->{last_save} = $cf::RUNTIME;
2227 $self->last_access ($cf::RUNTIME);
2228
2229 $self->in_memory (cf::MAP_ACTIVE);
2230 }
2231
2232 $self->post_load;
2233
2234 1
2235}
2236
2237# customize the map for a given player, i.e.
2238# return the _real_ map. used by e.g. per-player
2239# maps to change the path to ~playername/mappath
2240sub customise_for {
2241 my ($self, $ob) = @_;
2242
2243 return find "~" . $ob->name . "/" . $self->{path}
2244 if $self->per_player;
2245
2246# return find "?party/" . $ob->name . "/" . $self->{path}
2247# if $self->per_party;
2248
2249 $self
2250}
2251
2252# find and load all maps in the 3x3 area around a map
2253sub load_neighbours {
2254 my ($map) = @_;
2255
2256 my @neigh; # diagonal neighbours
2257
2258 for (0 .. 3) {
2259 my $neigh = $map->tile_path ($_)
2260 or next;
2261 $neigh = find $neigh, $map
2262 or next;
2263 $neigh->load;
2264
2265 # now find the diagonal neighbours
2266 push @neigh,
2267 [$neigh->tile_path (($_ + 3) % 4), $neigh],
2268 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2269 }
2270
2271 for (grep defined $_->[0], @neigh) {
2272 my ($path, $origin) = @$_;
2273 my $neigh = find $path, $origin
2274 or next;
2275 $neigh->load;
2276 }
2277}
2278
2279sub find_sync {
2280 my ($path, $origin) = @_;
2281
2282 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync"
2283 if $Coro::current == $Coro::main;
2284
2285 find $path, $origin
2286}
2287
2288sub do_load_sync {
2289 my ($map) = @_;
2290
2291 return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync"
2292 if $Coro::current == $Coro::main;
2293
2294 $map->load;
2295}
2296
2297our %MAP_PREFETCH;
2298our $MAP_PREFETCHER = undef;
2299
2300sub find_async {
2301 my ($path, $origin, $load) = @_;
2302
2303 $path = normalise $path, $origin;
2304
2305 if (my $map = $cf::MAP{$path}) {
2306 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
2307 }
2308
2309 $MAP_PREFETCH{$path} |= $load;
2310
2311 $MAP_PREFETCHER ||= cf::async {
2312 $Coro::current->{desc} = "map prefetcher";
2313
2314 while (%MAP_PREFETCH) {
2315 while (my ($k, $v) = each %MAP_PREFETCH) {
2316 if (my $map = find $k) {
2317 $map->load if $v;
2318 }
2319
2320 delete $MAP_PREFETCH{$k};
2321 }
2322 }
2323 undef $MAP_PREFETCHER;
2324 };
2325 $MAP_PREFETCHER->prio (6);
2326
2327 ()
2328}
2329
2330# common code, used by both ->save and ->swapout
2331sub _save {
2332 my ($self) = @_;
2333
2334 $self->{last_save} = $cf::RUNTIME;
2335
2336 return unless $self->dirty;
2337
2338 my $save = $self->save_path; utf8::encode $save;
2339 my $uniq = $self->uniq_path; utf8::encode $uniq;
2340
2341 $self->{load_path} = $save;
2342
2343 return if $self->{deny_save};
2344
2345 local $self->{last_access} = $self->last_access;#d#
2346
2347 cf::async {
2348 $Coro::current->{desc} = "map player save";
2349 $_->contr->save for $self->players;
2350 };
2351
2352 cf::get_slot 0.02;
2353
2354 if ($uniq) {
2355 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
2356 $self->_save_objects ($uniq, cf::IO_UNIQUES);
2357 } else {
2358 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
2359 }
2360}
2361
2362sub save {
2363 my ($self) = @_;
2364
2365 my $lock = cf::lock_acquire "map_data:$self->{path}";
2366
2367 $self->_save;
2368}
2369
2370sub swap_out {
2371 my ($self) = @_;
2372
2373 my $lock = cf::lock_acquire "map_data:$self->{path}";
2374
2375 return if $self->in_memory != cf::MAP_ACTIVE;
2376 return if $self->{deny_save};
2377 return if $self->players;
2378
2379 # first deactivate the map and "unlink" it from the core
2380 $self->deactivate;
2381 $_->clear_links_to ($self) for values %cf::MAP;
2382 $self->in_memory (cf::MAP_SWAPPED);
2383
2384 # then atomically save
2385 $self->_save;
2386
2387 # then free the map
2388 $self->clear;
2389}
2390
2391sub reset_at {
2392 my ($self) = @_;
2393
2394 # TODO: safety, remove and allow resettable per-player maps
2395 return 1e99 if $self->{deny_reset};
2396
2397 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2398 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2399
2400 $time + $to
2401}
2402
2403sub should_reset {
2404 my ($self) = @_;
2405
2406 $self->reset_at <= $cf::RUNTIME
2407}
2408
2409sub reset {
2410 my ($self) = @_;
2411
2412 my $lock = cf::lock_acquire "map_data:$self->{path}";
2413
2414 return if $self->players;
2415
2416 cf::trace "resetting map ", $self->path, "\n";
2417
2418 $self->in_memory (cf::MAP_SWAPPED);
2419
2420 # need to save uniques path
2421 unless ($self->{deny_save}) {
2422 my $uniq = $self->uniq_path; utf8::encode $uniq;
2423
2424 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2425 if $uniq;
2426 }
2427
2428 delete $cf::MAP{$self->path};
2429
2430 $self->deactivate;
2431 $_->clear_links_to ($self) for values %cf::MAP;
2432 $self->clear;
2433
2434 $self->unlink_save;
2435 $self->destroy;
2436}
2437
2438my $nuke_counter = "aaaa";
2439
2440sub nuke {
2441 my ($self) = @_;
2442
2443 {
2444 my $lock = cf::lock_acquire "map_data:$self->{path}";
2445
2446 delete $cf::MAP{$self->path};
2447
2448 $self->unlink_save;
2449
2450 bless $self, "cf::map::wrap";
2451 delete $self->{deny_reset};
2452 $self->{deny_save} = 1;
2453 $self->reset_timeout (1);
2454 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2455
2456 $cf::MAP{$self->path} = $self;
2457 }
2458
2459 $self->reset; # polite request, might not happen
2460}
2461
2462=item $maps = cf::map::tmp_maps
2463
2464Returns an arrayref with all map paths of currently instantiated and saved
2465maps. May block.
2466
2467=cut
2468
2469sub tmp_maps() {
2470 [
2471 map {
2472 utf8::decode $_;
2473 /\.map$/
2474 ? normalise $_
2475 : ()
2476 } @{ aio_readdir $TMPDIR or [] }
2477 ]
2478}
2479
2480=item $maps = cf::map::random_maps
2481
2482Returns an arrayref with all map paths of currently instantiated and saved
2483random maps. May block.
2484
2485=cut
2486
2487sub random_maps() {
2488 [
2489 map {
2490 utf8::decode $_;
2491 /\.map$/
2492 ? normalise "?random/$_"
2493 : ()
2494 } @{ aio_readdir $RANDOMDIR or [] }
2495 ]
2496}
2497
2498=item cf::map::unique_maps
2499
2500Returns an arrayref of paths of all shared maps that have
2501instantiated unique items. May block.
2502
2503=cut
2504
2505sub unique_maps() {
2506 [
2507 map {
2508 utf8::decode $_;
2509 s/\.map$//; # TODO future compatibility hack
2510 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
2511 ? ()
2512 : normalise $_
2513 } @{ aio_readdir $UNIQUEDIR or [] }
2514 ]
2515}
2516
2517=item cf::map::static_maps
2518
2519Returns an arrayref if paths of all static maps (all preinstalled F<.map>
2520file in the shared directory excluding F</styles> and F</editor>). May
2521block.
2522
2523=cut
2524
2525sub static_maps() {
2526 my @dirs = "";
2527 my @maps;
2528
2529 while (@dirs) {
2530 my $dir = shift @dirs;
2531
2532 next if $dir eq "/styles" || $dir eq "/editor";
2533
2534 my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
2535 or return;
2536
2537 for (@$files) {
2538 s/\.map$// or next;
2539 utf8::decode $_;
2540 push @maps, "$dir/$_";
2541 }
2542
2543 push @dirs, map "$dir/$_", @$dirs;
2544 }
2545
2546 \@maps
2547}
2548
2549=back
2550
2551=head3 cf::object
2552
2553=cut
2554
2555package cf::object;
2556
2557=over 4
2558
2559=item $ob->inv_recursive
2560
2561Returns the inventory of the object I<and> their inventories, recursively,
2562but I<not> the object itself.
2563
2564=cut
2565
2566sub inv_recursive_;
2567sub inv_recursive_ {
2568 map { $_, inv_recursive_ $_->inv } @_
2569}
2570
2571sub inv_recursive {
2572 inv_recursive_ inv $_[0]
2573}
2574
2575=item $ref = $ob->ref
2576
2577Creates and returns a persistent reference to an object that can be stored as a string.
2578
2579=item $ob = cf::object::deref ($refstring)
2580
2581returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2582even if the object actually exists. May block.
2583
2584=cut
2585
2586sub deref {
2587 my ($ref) = @_;
2588
2589 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2590 my ($uuid, $name) = ($1, $2);
2591 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2592 or return;
2593 $pl->ob->uuid eq $uuid
2594 or return;
2595
2596 $pl->ob
2597 } else {
2598 warn "$ref: cannot resolve object reference\n";
2599 undef
2600 }
2601}
2602
2603package cf;
782 2604
783=back 2605=back
784 2606
785=head3 cf::object::player 2607=head3 cf::object::player
786 2608
… …
791Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 2613Sends 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 2614can be C<undef>. Does the right thing when the player is currently in a
793dialogue with the given NPC character. 2615dialogue with the given NPC character.
794 2616
795=cut 2617=cut
2618
2619our $SAY_CHANNEL = {
2620 id => "say",
2621 title => "Map",
2622 reply => "say ",
2623 tooltip => "Things said to and replied from NPCs near you and other players on the same map only.",
2624};
2625
2626our $CHAT_CHANNEL = {
2627 id => "chat",
2628 title => "Chat",
2629 reply => "chat ",
2630 tooltip => "Player chat and shouts, global to the server.",
2631};
796 2632
797# rough implementation of a future "reply" method that works 2633# rough implementation of a future "reply" method that works
798# with dialog boxes. 2634# with dialog boxes.
799#TODO: the first argument must go, split into a $npc->reply_to ( method 2635#TODO: the first argument must go, split into a $npc->reply_to ( method
800sub cf::object::player::reply($$$;$) { 2636sub cf::object::player::reply($$$;$) {
… …
802 2638
803 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2639 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
804 2640
805 if ($self->{record_replies}) { 2641 if ($self->{record_replies}) {
806 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2642 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2643
807 } else { 2644 } else {
2645 my $pl = $self->contr;
2646
2647 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2648 my $dialog = $pl->{npc_dialog};
2649 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2650
2651 } else {
808 $msg = $npc->name . " says: $msg" if $npc; 2652 $msg = $npc->name . " says: $msg" if $npc;
809 $self->message ($msg, $flags); 2653 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2654 }
810 } 2655 }
2656}
2657
2658=item $object->send_msg ($channel, $msg, $color, [extra...])
2659
2660=cut
2661
2662sub cf::object::send_msg {
2663 my $pl = shift->contr
2664 or return;
2665 $pl->send_msg (@_);
811} 2666}
812 2667
813=item $player_object->may ("access") 2668=item $player_object->may ("access")
814 2669
815Returns wether the given player is authorized to access resource "access" 2670Returns wether the given player is authorized to access resource "access"
… …
824 (ref $cf::CFG{"may_$access"} 2679 (ref $cf::CFG{"may_$access"}
825 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}} 2680 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
826 : $cf::CFG{"may_$access"}) 2681 : $cf::CFG{"may_$access"})
827} 2682}
828 2683
2684=item $player_object->enter_link
2685
2686Freezes the player and moves him/her to a special map (C<{link}>).
2687
2688The player should be reasonably safe there for short amounts of time (e.g.
2689for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2690though, as the player cannot control the character while it is on the link
2691map.
2692
2693Will never block.
2694
2695=item $player_object->leave_link ($map, $x, $y)
2696
2697Moves the player out of the special C<{link}> map onto the specified
2698map. If the map is not valid (or omitted), the player will be moved back
2699to the location he/she was before the call to C<enter_link>, or, if that
2700fails, to the emergency map position.
2701
2702Might block.
2703
2704=cut
2705
2706sub link_map {
2707 unless ($LINK_MAP) {
2708 $LINK_MAP = cf::map::find "{link}"
2709 or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
2710 $LINK_MAP->load;
2711 }
2712
2713 $LINK_MAP
2714}
2715
2716sub cf::object::player::enter_link {
2717 my ($self) = @_;
2718
2719 $self->deactivate_recursive;
2720
2721 ++$self->{_link_recursion};
2722
2723 return if UNIVERSAL::isa $self->map, "ext::map_link";
2724
2725 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2726 if $self->map && $self->map->{path} ne "{link}";
2727
2728 $self->enter_map ($LINK_MAP || link_map, 3, 3);
2729}
2730
2731sub cf::object::player::leave_link {
2732 my ($self, $map, $x, $y) = @_;
2733
2734 return unless $self->contr->active;
2735
2736 my $link_pos = delete $self->{_link_pos};
2737
2738 unless ($map) {
2739 # restore original map position
2740 ($map, $x, $y) = @{ $link_pos || [] };
2741 $map = cf::map::find $map;
2742
2743 unless ($map) {
2744 ($map, $x, $y) = @$EMERGENCY_POSITION;
2745 $map = cf::map::find $map
2746 or die "FATAL: cannot load emergency map\n";
2747 }
2748 }
2749
2750 ($x, $y) = (-1, -1)
2751 unless (defined $x) && (defined $y);
2752
2753 # use -1 or undef as default coordinates, not 0, 0
2754 ($x, $y) = ($map->enter_x, $map->enter_y)
2755 if $x <= 0 && $y <= 0;
2756
2757 $map->load;
2758 $map->load_neighbours;
2759
2760 return unless $self->contr->active;
2761
2762 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2763 if ($self->enter_map ($map, $x, $y)) {
2764 # entering was successful
2765 delete $self->{_link_recursion};
2766 # only activate afterwards, to support waiting in hooks
2767 $self->activate_recursive;
2768 }
2769
2770}
2771
2772=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
2773
2774Moves the player to the given map-path and coordinates by first freezing
2775her, loading and preparing them map, calling the provided $check callback
2776that has to return the map if sucecssful, and then unfreezes the player on
2777the new (success) or old (failed) map position. In either case, $done will
2778be called at the end of this process.
2779
2780Note that $check will be called with a potentially non-loaded map, so if
2781it needs a loaded map it has to call C<< ->load >>.
2782
2783=cut
2784
2785our $GOTOGEN;
2786
2787sub cf::object::player::goto {
2788 my ($self, $path, $x, $y, $check, $done) = @_;
2789
2790 if ($self->{_link_recursion} >= $MAX_LINKS) {
2791 error "FATAL: link recursion exceeded, ", $self->name, " goto $path $x $y, redirecting.";
2792 $self->failmsg ("Something went wrong inside the server - please contact an administrator!");
2793 ($path, $x, $y) = @$EMERGENCY_POSITION;
2794 }
2795
2796 # do generation counting so two concurrent goto's will be executed in-order
2797 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2798
2799 $self->enter_link;
2800
2801 (async {
2802 $Coro::current->{desc} = "player::goto $path $x $y";
2803
2804 # *tag paths override both path and x|y
2805 if ($path =~ /^\*(.*)$/) {
2806 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2807 my $ob = $obs[rand @obs];
2808
2809 # see if we actually can go there
2810 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2811 $ob = $obs[rand @obs];
2812 } else {
2813 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2814 }
2815 # else put us there anyways for now #d#
2816
2817 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2818 } else {
2819 ($path, $x, $y) = (undef, undef, undef);
2820 }
2821 }
2822
2823 my $map = eval {
2824 my $map = defined $path ? cf::map::find $path, $self->map : undef;
2825
2826 if ($map) {
2827 $map = $map->customise_for ($self);
2828 $map = $check->($map, $x, $y, $self) if $check && $map;
2829 } else {
2830 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2831 }
2832
2833 $map
2834 };
2835
2836 if ($@) {
2837 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2838 LOG llevError | logBacktrace, Carp::longmess $@;
2839 }
2840
2841 if ($gen == $self->{_goto_generation}) {
2842 delete $self->{_goto_generation};
2843 $self->leave_link ($map, $x, $y);
2844 }
2845
2846 $done->($self) if $done;
2847 })->prio (1);
2848}
2849
2850=item $player_object->enter_exit ($exit_object)
2851
2852=cut
2853
2854sub parse_random_map_params {
2855 my ($spec) = @_;
2856
2857 my $rmp = { # defaults
2858 xsize => (cf::rndm 15, 40),
2859 ysize => (cf::rndm 15, 40),
2860 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
2861 #layout => string,
2862 };
2863
2864 for (split /\n/, $spec) {
2865 my ($k, $v) = split /\s+/, $_, 2;
2866
2867 $rmp->{lc $k} = $v if (length $k) && (length $v);
2868 }
2869
2870 $rmp
2871}
2872
2873sub prepare_random_map {
2874 my ($exit) = @_;
2875
2876 # all this does is basically replace the /! path by
2877 # a new random map path (?random/...) with a seed
2878 # that depends on the exit object
2879
2880 my $rmp = parse_random_map_params $exit->msg;
2881
2882 if ($exit->map) {
2883 $rmp->{region} = $exit->region->name;
2884 $rmp->{origin_map} = $exit->map->path;
2885 $rmp->{origin_x} = $exit->x;
2886 $rmp->{origin_y} = $exit->y;
2887
2888 $exit->map->touch;
2889 }
2890
2891 $rmp->{random_seed} ||= $exit->random_seed;
2892
2893 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2894 my $md5 = Digest::MD5::md5_hex $data;
2895 my $meta = "$RANDOMDIR/$md5.meta";
2896
2897 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2898 aio_write $fh, 0, (length $data), $data, 0;
2899 undef $fh;
2900 aio_rename "$meta~", $meta;
2901
2902 my $slaying = "?random/$md5";
2903
2904 if ($exit->valid) {
2905 $exit->slaying ("?random/$md5");
2906 $exit->msg (undef);
2907 }
2908 }
2909}
2910
2911sub cf::object::player::enter_exit {
2912 my ($self, $exit) = @_;
2913
2914 return unless $self->type == cf::PLAYER;
2915
2916 $self->enter_link;
2917
2918 (async {
2919 $Coro::current->{desc} = "enter_exit";
2920
2921 unless (eval {
2922 $self->deactivate_recursive; # just to be sure
2923
2924 my $map = cf::map::normalise $exit->slaying, $exit->map;
2925 my $x = $exit->stats->hp;
2926 my $y = $exit->stats->sp;
2927
2928 # special map handling
2929 my $slaying = $exit->slaying;
2930
2931 # special map handling
2932 if ($slaying eq "/!") {
2933 my $guard = cf::lock_acquire "exit_prepare:$exit";
2934
2935 prepare_random_map $exit
2936 if $slaying eq "/!"; # need to re-check after getting the lock
2937
2938 } elsif ($slaying eq '!up') {
2939 $map = $exit->map->tile_path (cf::TILE_UP);
2940 $x = $exit->x;
2941 $y = $exit->y;
2942
2943 } elsif ($slaying eq '!down') {
2944 $map = $exit->map->tile_path (cf::TILE_DOWN);
2945 $x = $exit->x;
2946 $y = $exit->y;
2947 }
2948
2949 $self->goto ($map, $x, $y);
2950
2951 # if exit is damned, update players death & WoR home-position
2952 $self->contr->savebed ($map, $x, $y)
2953 if $exit->flag (cf::FLAG_DAMNED);
2954
2955 1
2956 }) {
2957 $self->message ("Something went wrong deep within the deliantra server. "
2958 . "I'll try to bring you back to the map you were before. "
2959 . "Please report this to the dungeon master!",
2960 cf::NDI_UNIQUE | cf::NDI_RED);
2961
2962 error "ERROR in enter_exit: $@";
2963 $self->leave_link;
2964 }
2965 })->prio (1);
2966}
2967
829=head3 cf::client 2968=head3 cf::client
830 2969
831=over 4 2970=over 4
832 2971
833=item $client->send_drawinfo ($text, $flags) 2972=item $client->send_drawinfo ($text, $flags)
… …
839 2978
840sub cf::client::send_drawinfo { 2979sub cf::client::send_drawinfo {
841 my ($self, $text, $flags) = @_; 2980 my ($self, $text, $flags) = @_;
842 2981
843 utf8::encode $text; 2982 utf8::encode $text;
844 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 2983 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
845} 2984}
846 2985
2986=item $client->send_big_packet ($pkt)
2987
2988Like C<send_packet>, but tries to compress large packets, and fragments
2989them as required.
2990
2991=cut
2992
2993our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
2994
2995sub cf::client::send_big_packet {
2996 my ($self, $pkt) = @_;
2997
2998 # try lzf for large packets
2999 $pkt = "lzf " . Compress::LZF::compress $pkt
3000 if 1024 <= length $pkt and $self->{can_lzf};
3001
3002 # split very large packets
3003 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
3004 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
3005 $pkt = "frag";
3006 }
3007
3008 $self->send_packet ($pkt);
3009}
3010
3011=item $client->send_msg ($channel, $msg, $color, [extra...])
3012
3013Send a drawinfo or msg packet to the client, formatting the msg for the
3014client if neccessary. C<$type> should be a string identifying the type of
3015the message, with C<log> being the default. If C<$color> is negative, suppress
3016the message unless the client supports the msg packet.
3017
3018=cut
3019
3020# non-persistent channels (usually the info channel)
3021our %CHANNEL = (
3022 "c/motd" => {
3023 id => "infobox",
3024 title => "MOTD",
3025 reply => undef,
3026 tooltip => "The message of the day",
3027 },
3028 "c/identify" => {
3029 id => "infobox",
3030 title => "Identify",
3031 reply => undef,
3032 tooltip => "Items recently identified",
3033 },
3034 "c/examine" => {
3035 id => "infobox",
3036 title => "Examine",
3037 reply => undef,
3038 tooltip => "Signs and other items you examined",
3039 },
3040 "c/shopinfo" => {
3041 id => "infobox",
3042 title => "Shop Info",
3043 reply => undef,
3044 tooltip => "What your bargaining skill tells you about the shop",
3045 },
3046 "c/book" => {
3047 id => "infobox",
3048 title => "Book",
3049 reply => undef,
3050 tooltip => "The contents of a note or book",
3051 },
3052 "c/lookat" => {
3053 id => "infobox",
3054 title => "Look",
3055 reply => undef,
3056 tooltip => "What you saw there",
3057 },
3058 "c/who" => {
3059 id => "infobox",
3060 title => "Players",
3061 reply => undef,
3062 tooltip => "Shows players who are currently online",
3063 },
3064 "c/body" => {
3065 id => "infobox",
3066 title => "Body Parts",
3067 reply => undef,
3068 tooltip => "Shows which body parts you posess and are available",
3069 },
3070 "c/statistics" => {
3071 id => "infobox",
3072 title => "Statistics",
3073 reply => undef,
3074 tooltip => "Shows your primary statistics",
3075 },
3076 "c/skills" => {
3077 id => "infobox",
3078 title => "Skills",
3079 reply => undef,
3080 tooltip => "Shows your experience per skill and item power",
3081 },
3082 "c/shopitems" => {
3083 id => "infobox",
3084 title => "Shop Items",
3085 reply => undef,
3086 tooltip => "Shows the items currently for sale in this shop",
3087 },
3088 "c/resistances" => {
3089 id => "infobox",
3090 title => "Resistances",
3091 reply => undef,
3092 tooltip => "Shows your resistances",
3093 },
3094 "c/pets" => {
3095 id => "infobox",
3096 title => "Pets",
3097 reply => undef,
3098 tooltip => "Shows information abotu your pets/a specific pet",
3099 },
3100 "c/perceiveself" => {
3101 id => "infobox",
3102 title => "Perceive Self",
3103 reply => undef,
3104 tooltip => "You gained detailed knowledge about yourself",
3105 },
3106 "c/uptime" => {
3107 id => "infobox",
3108 title => "Uptime",
3109 reply => undef,
3110 tooltip => "How long the server has been running since last restart",
3111 },
3112 "c/mapinfo" => {
3113 id => "infobox",
3114 title => "Map Info",
3115 reply => undef,
3116 tooltip => "Information related to the maps",
3117 },
3118 "c/party" => {
3119 id => "party",
3120 title => "Party",
3121 reply => "gsay ",
3122 tooltip => "Messages and chat related to your party",
3123 },
3124 "c/death" => {
3125 id => "death",
3126 title => "Death",
3127 reply => undef,
3128 tooltip => "Reason for and more info about your most recent death",
3129 },
3130 "c/say" => $SAY_CHANNEL,
3131 "c/chat" => $CHAT_CHANNEL,
3132);
3133
3134sub cf::client::send_msg {
3135 my ($self, $channel, $msg, $color, @extra) = @_;
3136
3137 $msg = $self->pl->expand_cfpod ($msg)
3138 unless $color & cf::NDI_VERBATIM;
3139
3140 $color &= cf::NDI_CLIENT_MASK; # just in case...
3141
3142 # check predefined channels, for the benefit of C
3143 if ($CHANNEL{$channel}) {
3144 $channel = $CHANNEL{$channel};
3145
3146 $self->ext_msg (channel_info => $channel);
3147 $channel = $channel->{id};
3148
3149 } elsif (ref $channel) {
3150 # send meta info to client, if not yet sent
3151 unless (exists $self->{channel}{$channel->{id}}) {
3152 $self->{channel}{$channel->{id}} = $channel;
3153 $self->ext_msg (channel_info => $channel);
3154 }
3155
3156 $channel = $channel->{id};
3157 }
3158
3159 return unless @extra || length $msg;
3160
3161 # default colour, mask it out
3162 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
3163 if $color & cf::NDI_DEF;
3164
3165 my $pkt = "msg "
3166 . $self->{json_coder}->encode (
3167 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
3168 );
3169
3170 $self->send_big_packet ($pkt);
3171}
3172
3173=item $client->ext_msg ($type, @msg)
3174
3175Sends an ext event to the client.
3176
3177=cut
3178
3179sub cf::client::ext_msg($$@) {
3180 my ($self, $type, @msg) = @_;
3181
3182 if ($self->extcmd == 2) {
3183 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
3184 } elsif ($self->extcmd == 1) { # TODO: remove
3185 push @msg, msgtype => "event_$type";
3186 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3187 }
3188}
3189
3190=item $client->ext_reply ($msgid, @msg)
3191
3192Sends an ext reply to the client.
3193
3194=cut
3195
3196sub cf::client::ext_reply($$@) {
3197 my ($self, $id, @msg) = @_;
3198
3199 if ($self->extcmd == 2) {
3200 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
3201 } elsif ($self->extcmd == 1) {
3202 #TODO: version 1, remove
3203 unshift @msg, msgtype => "reply", msgid => $id;
3204 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3205 }
3206}
847 3207
848=item $success = $client->query ($flags, "text", \&cb) 3208=item $success = $client->query ($flags, "text", \&cb)
849 3209
850Queues a query to the client, calling the given callback with 3210Queues a query to the client, calling the given callback with
851the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 3211the 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>. 3212C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
853 3213
854Queries can fail, so check the return code. Or don't, as queries will become 3214Queries can fail, so check the return code. Or don't, as queries will
855reliable at some point in the future. 3215become reliable at some point in the future.
856 3216
857=cut 3217=cut
858 3218
859sub cf::client::query { 3219sub cf::client::query {
860 my ($self, $flags, $text, $cb) = @_; 3220 my ($self, $flags, $text, $cb) = @_;
… …
868 utf8::encode $text; 3228 utf8::encode $text;
869 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 3229 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
870 3230
871 $self->send_packet ($self->{query_queue}[0][0]) 3231 $self->send_packet ($self->{query_queue}[0][0])
872 if @{ $self->{query_queue} } == 1; 3232 if @{ $self->{query_queue} } == 1;
3233
3234 1
873} 3235}
874 3236
875cf::client->attach ( 3237cf::client->attach (
3238 on_connect => sub {
3239 my ($ns) = @_;
3240
3241 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
3242 },
876 on_reply => sub { 3243 on_reply => sub {
877 my ($ns, $msg) = @_; 3244 my ($ns, $msg) = @_;
878 3245
879 # this weird shuffling is so that direct followup queries 3246 # this weird shuffling is so that direct followup queries
880 # get handled first 3247 # get handled first
881 my $queue = delete $ns->{query_queue}; 3248 my $queue = delete $ns->{query_queue}
3249 or return; # be conservative, not sure how that can happen, but we saw a crash here
882 3250
883 (shift @$queue)->[1]->($msg); 3251 (shift @$queue)->[1]->($msg);
3252 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
884 3253
885 push @{ $ns->{query_queue} }, @$queue; 3254 push @{ $ns->{query_queue} }, @$queue;
886 3255
887 if (@{ $ns->{query_queue} } == @$queue) { 3256 if (@{ $ns->{query_queue} } == @$queue) {
888 if (@$queue) { 3257 if (@$queue) {
889 $ns->send_packet ($ns->{query_queue}[0][0]); 3258 $ns->send_packet ($ns->{query_queue}[0][0]);
890 } else { 3259 } else {
891 $ns->state (ST_PLAYING); 3260 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
892 } 3261 }
893 } 3262 }
3263 },
3264 on_exticmd => sub {
3265 my ($ns, $buf) = @_;
3266
3267 my $msg = eval { $ns->{json_coder}->decode ($buf) };
3268
3269 if (ref $msg) {
3270 my ($type, $reply, @payload) =
3271 "ARRAY" eq ref $msg
3272 ? @$msg
3273 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
3274
3275 my @reply;
3276
3277 if (my $cb = $EXTICMD{$type}) {
3278 @reply = $cb->($ns, @payload);
3279 }
3280
3281 $ns->ext_reply ($reply, @reply)
3282 if $reply;
3283
3284 } else {
3285 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3286 }
3287
3288 cf::override;
894 }, 3289 },
895); 3290);
896 3291
897=item $client->coro (\&cb) 3292=item $client->async (\&cb)
898 3293
899Create a new coroutine, running the specified callback. The coroutine will 3294Create a new coroutine, running the specified callback. The coroutine will
900be automatically cancelled when the client gets destroyed (e.g. on logout, 3295be automatically cancelled when the client gets destroyed (e.g. on logout,
901or loss of connection). 3296or loss of connection).
902 3297
903=cut 3298=cut
904 3299
905sub cf::client::coro { 3300sub cf::client::async {
906 my ($self, $cb) = @_; 3301 my ($self, $cb) = @_;
907 3302
908 my $coro; $coro = async { 3303 my $coro = &Coro::async ($cb);
909 eval { 3304
910 $cb->(); 3305 $coro->on_destroy (sub {
911 };
912 warn $@ if $@;
913 warn "cancel myself\n";#d#
914 delete $self->{_coro}{$coro+0}; 3306 delete $self->{_coro}{$coro+0};
915 }; 3307 });
916 3308
917 $self->{_coro}{$coro+0} = $coro; 3309 $self->{_coro}{$coro+0} = $coro;
3310
3311 $coro
918} 3312}
919 3313
920cf::client->attach ( 3314cf::client->attach (
921 on_destroy => sub { 3315 on_client_destroy => sub {
922 my ($ns) = @_; 3316 my ($ns) = @_;
923 3317
924 warn "cancel $_" for values %{ $ns->{_coro} || {} };#d#
925 $_->cancel for values %{ $ns->{_coro} || {} }; 3318 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
926 }, 3319 },
927); 3320);
928 3321
929=back 3322=back
930 3323
… …
942our $safe = new Safe "safe"; 3335our $safe = new Safe "safe";
943our $safe_hole = new Safe::Hole; 3336our $safe_hole = new Safe::Hole;
944 3337
945$SIG{FPE} = 'IGNORE'; 3338$SIG{FPE} = 'IGNORE';
946 3339
947$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 3340$safe->permit_only (Opcode::opset qw(
3341 :base_core :base_mem :base_orig :base_math :base_loop
3342 grepstart grepwhile mapstart mapwhile
3343 sort time
3344));
948 3345
949# here we export the classes and methods available to script code 3346# here we export the classes and methods available to script code
950 3347
951=pod 3348=pod
952 3349
953The following fucntions and emthods are available within a safe environment: 3350The following functions and methods are available within a safe environment:
954 3351
955 cf::object contr pay_amount pay_player map 3352 cf::object
3353 contr pay_amount pay_player map x y force_find force_add destroy
3354 insert remove name archname title slaying race decrease split
3355 value
3356
956 cf::object::player player 3357 cf::object::player
957 cf::player peaceful 3358 player
958 cf::map trigger 3359
3360 cf::player
3361 peaceful
3362
3363 cf::map
3364 trigger
959 3365
960=cut 3366=cut
961 3367
962for ( 3368for (
963 ["cf::object" => qw(contr pay_amount pay_player map)], 3369 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3370 insert remove inv nrof name archname title slaying race
3371 decrease split destroy change_exp value msg lore send_msg)],
964 ["cf::object::player" => qw(player)], 3372 ["cf::object::player" => qw(player)],
965 ["cf::player" => qw(peaceful)], 3373 ["cf::player" => qw(peaceful send_msg)],
966 ["cf::map" => qw(trigger)], 3374 ["cf::map" => qw(trigger)],
967) { 3375) {
968 no strict 'refs';
969 my ($pkg, @funs) = @$_; 3376 my ($pkg, @funs) = @$_;
970 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3377 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
971 for @funs; 3378 for @funs;
972} 3379}
973 3380
… …
988 3395
989 my $qcode = $code; 3396 my $qcode = $code;
990 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3397 $qcode =~ s/"/‟/g; # not allowed in #line filenames
991 $qcode =~ s/\n/\\n/g; 3398 $qcode =~ s/\n/\\n/g;
992 3399
3400 %vars = (_dummy => 0) unless %vars;
3401
3402 my @res;
993 local $_; 3403 local $_;
994 local @safe::cf::_safe_eval_args = values %vars;
995 3404
996 my $eval = 3405 my $eval =
997 "do {\n" 3406 "do {\n"
998 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3407 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
999 . "#line 0 \"{$qcode}\"\n" 3408 . "#line 0 \"{$qcode}\"\n"
1000 . $code 3409 . $code
1001 . "\n}" 3410 . "\n}"
1002 ; 3411 ;
1003 3412
3413 if ($CFG{safe_eval}) {
1004 sub_generation_inc; 3414 sub_generation_inc;
3415 local @safe::cf::_safe_eval_args = values %vars;
1005 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3416 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
1006 sub_generation_inc; 3417 sub_generation_inc;
3418 } else {
3419 local @cf::_safe_eval_args = values %vars;
3420 @res = wantarray ? eval eval : scalar eval $eval;
3421 }
1007 3422
1008 if ($@) { 3423 if ($@) {
1009 warn "$@"; 3424 warn "$@",
1010 warn "while executing safe code '$code'\n"; 3425 "while executing safe code '$code'\n",
1011 warn "with arguments " . (join " ", %vars) . "\n"; 3426 "with arguments " . (join " ", %vars) . "\n";
1012 } 3427 }
1013 3428
1014 wantarray ? @res : $res[0] 3429 wantarray ? @res : $res[0]
1015} 3430}
1016 3431
… …
1030=cut 3445=cut
1031 3446
1032sub register_script_function { 3447sub register_script_function {
1033 my ($fun, $cb) = @_; 3448 my ($fun, $cb) = @_;
1034 3449
1035 no strict 'refs'; 3450 $fun = "safe::$fun" if $CFG{safe_eval};
1036 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3451 *$fun = $safe_hole->wrap ($cb);
1037} 3452}
1038 3453
1039=back 3454=back
1040 3455
1041=cut 3456=cut
1042 3457
1043############################################################################# 3458#############################################################################
3459# the server's init and main functions
1044 3460
1045=head2 EXTENSION DATABASE SUPPORT 3461sub load_facedata($) {
3462 my ($path) = @_;
1046 3463
1047Crossfire maintains a very simple database for extension use. It can 3464 # HACK to clear player env face cache, we need some signal framework
1048currently store anything that can be serialised using Storable, which 3465 # for this (global event?)
1049excludes objects. 3466 %ext::player_env::MUSIC_FACE_CACHE = ();
1050 3467
1051The parameter C<$family> should best start with the name of the extension 3468 my $enc = JSON::XS->new->utf8->canonical->relaxed;
1052using it, it should be unique.
1053 3469
1054=over 4 3470 trace "loading facedata from $path\n";
1055 3471
1056=item $hashref = cf::db_get $family 3472 my $facedata = decode_storable load_file $path;
1057 3473
1058Return a hashref for use by the extension C<$family>, which can be 3474 $facedata->{version} == 2
1059modified. After modifications, you have to call C<cf::db_dirty> or 3475 or cf::cleanup "$path: version mismatch, cannot proceed.";
1060C<cf::db_sync>.
1061 3476
1062=item $value = cf::db_get $family => $key 3477 # patch in the exptable
3478 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3479 $facedata->{resource}{"res/exp_table"} = {
3480 type => FT_RSRC,
3481 data => $exp_table,
3482 hash => (Digest::MD5::md5 $exp_table),
3483 };
3484 cf::cede_to_tick;
1063 3485
1064Returns a single value from the database 3486 {
3487 my $faces = $facedata->{faceinfo};
1065 3488
1066=item cf::db_put $family => $hashref 3489 while (my ($face, $info) = each %$faces) {
3490 my $idx = (cf::face::find $face) || cf::face::alloc $face;
1067 3491
1068Stores the given family hashref into the database. Updates are delayed, if 3492 cf::face::set_visibility $idx, $info->{visibility};
1069you want the data to be synced to disk immediately, use C<cf::db_sync>. 3493 cf::face::set_magicmap $idx, $info->{magicmap};
3494 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3495 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3496 cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph} ;
1070 3497
1071=item cf::db_put $family => $key => $value 3498 cf::cede_to_tick;
3499 }
1072 3500
1073Stores the given C<$value> in the family hash. Updates are delayed, if you 3501 while (my ($face, $info) = each %$faces) {
1074want the data to be synced to disk immediately, use C<cf::db_sync>. 3502 next unless $info->{smooth};
1075 3503
1076=item cf::db_dirty 3504 my $idx = cf::face::find $face
3505 or next;
1077 3506
1078Marks the database as dirty, to be updated at a later time. 3507 if (my $smooth = cf::face::find $info->{smooth}) {
3508 cf::face::set_smooth $idx, $smooth;
3509 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3510 } else {
3511 error "smooth face '$info->{smooth}' not found for face '$face'";
3512 }
1079 3513
1080=item cf::db_sync 3514 cf::cede_to_tick;
3515 }
3516 }
1081 3517
1082Immediately write the database to disk I<if it is dirty>. 3518 {
3519 my $anims = $facedata->{animinfo};
1083 3520
1084=cut 3521 while (my ($anim, $info) = each %$anims) {
3522 cf::anim::set $anim, $info->{frames}, $info->{facings};
3523 cf::cede_to_tick;
3524 }
1085 3525
1086our $DB; 3526 cf::anim::invalidate_all; # d'oh
3527 }
3528
3529 {
3530 my $res = $facedata->{resource};
3531
3532 while (my ($name, $info) = each %$res) {
3533 if (defined $info->{type}) {
3534 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3535
3536 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3537 cf::face::set_type $idx, $info->{type};
3538 } else {
3539 $RESOURCE{$name} = $info; # unused
3540 }
3541
3542 cf::cede_to_tick;
3543 }
3544 }
3545
3546 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3547
3548 1
3549}
3550
3551register_exticmd fx_want => sub {
3552 my ($ns, $want) = @_;
3553
3554 while (my ($k, $v) = each %$want) {
3555 $ns->fx_want ($k, $v);
3556 }
3557};
3558
3559sub load_resource_file($) {
3560 my $guard = lock_acquire "load_resource_file";
3561
3562 my $status = load_resource_file_ $_[0];
3563 get_slot 0.1, 100;
3564 cf::arch::commit_load;
3565
3566 $status
3567}
3568
3569sub reload_regions {
3570 # HACK to clear player env face cache, we need some signal framework
3571 # for this (global event?)
3572 %ext::player_env::MUSIC_FACE_CACHE = ();
3573
3574 load_resource_file "$MAPDIR/regions"
3575 or die "unable to load regions file\n";
3576
3577 for (cf::region::list) {
3578 $_->{match} = qr/$_->{match}/
3579 if exists $_->{match};
3580 }
3581}
3582
3583sub reload_facedata {
3584 load_facedata "$DATADIR/facedata"
3585 or die "unable to load facedata\n";
3586}
3587
3588sub reload_archetypes {
3589 load_resource_file "$DATADIR/archetypes"
3590 or die "unable to load archetypes\n";
3591}
3592
3593sub reload_treasures {
3594 load_resource_file "$DATADIR/treasures"
3595 or die "unable to load treasurelists\n";
3596}
3597
3598sub reload_sound {
3599 trace "loading sound config from $DATADIR/sound\n";
3600
3601 my $soundconf = JSON::XS->new->utf8->relaxed->decode (load_file "$DATADIR/sound");
3602
3603 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3604 my $sound = $soundconf->{compat}[$_]
3605 or next;
3606
3607 my $face = cf::face::find "sound/$sound->[1]";
3608 cf::sound::set $sound->[0] => $face;
3609 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3610 }
3611
3612 while (my ($k, $v) = each %{$soundconf->{event}}) {
3613 my $face = cf::face::find "sound/$v";
3614 cf::sound::set $k => $face;
3615 }
3616}
3617
3618sub reload_resources {
3619 trace "reloading resource files...\n";
3620
3621 reload_exp_table;
3622 reload_materials;
3623 reload_facedata;
3624 reload_sound;
3625 reload_archetypes;
3626 reload_regions;
3627 reload_treasures;
3628
3629 trace "finished reloading resource files\n";
3630}
3631
3632sub reload_config {
3633 trace "reloading config file...\n";
3634
3635 my $config = load_file "$CONFDIR/config";
3636 utf8::decode $config;
3637 *CFG = decode_yaml $config;
3638
3639 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3640
3641 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3642 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3643
3644 if (exists $CFG{mlockall}) {
3645 eval {
3646 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3647 and die "WARNING: m(un)lockall failed: $!\n";
3648 };
3649 warn $@ if $@;
3650 }
3651}
3652
3653sub pidfile() {
3654 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3655 or die "$PIDFILE: $!";
3656 flock $fh, &Fcntl::LOCK_EX
3657 or die "$PIDFILE: flock: $!";
3658 $fh
3659}
3660
3661# make sure only one server instance is running at any one time
3662sub atomic {
3663 my $fh = pidfile;
3664
3665 my $pid = <$fh>;
3666 kill 9, $pid if $pid > 0;
3667
3668 seek $fh, 0, 0;
3669 print $fh $$;
3670}
3671
3672sub main_loop {
3673 trace "EV::loop starting\n";
3674 if (1) {
3675 EV::loop;
3676 }
3677 trace "EV::loop returned\n";
3678 goto &main_loop unless $REALLY_UNLOOP;
3679}
3680
3681sub main {
3682 cf::init_globals; # initialise logging
3683
3684 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3685 LOG llevInfo, "Copyright (C) 2005-2011 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3686 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3687 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3688
3689 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3690
3691 # we must not ever block the main coroutine
3692 local $Coro::idle = sub {
3693 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3694 (async {
3695 $Coro::current->{desc} = "IDLE BUG HANDLER";
3696 EV::loop EV::LOOP_ONESHOT;
3697 })->prio (Coro::PRIO_MAX);
3698 };
3699
3700 evthread_start IO::AIO::poll_fileno;
3701
3702 cf::sync_job {
3703 cf::incloader::init ();
3704
3705 cf::init_anim;
3706 cf::init_attackmess;
3707 cf::init_dynamic;
3708
3709 cf::load_settings;
3710
3711 reload_resources;
3712 reload_config;
3713 db_init;
3714
3715 cf::init_uuid;
3716 cf::init_signals;
3717 cf::init_skills;
3718
3719 cf::init_beforeplay;
3720
3721 atomic;
3722
3723 load_extensions;
3724
3725 utime time, time, $RUNTIMEFILE;
3726
3727 # no (long-running) fork's whatsoever before this point(!)
3728 use POSIX ();
3729 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3730
3731 cf::_post_init 0;
3732 };
3733
3734 cf::object::thawer::errors_are_fatal 0;
3735 info "parse errors in files are no longer fatal from this point on.\n";
3736
3737 my $free_main; $free_main = EV::idle sub {
3738 undef $free_main;
3739 undef &main; # free gobs of memory :)
3740 };
3741
3742 goto &main_loop;
3743}
3744
3745#############################################################################
3746# initialisation and cleanup
3747
3748# install some emergency cleanup handlers
3749BEGIN {
3750 our %SIGWATCHER = ();
3751 for my $signal (qw(INT HUP TERM)) {
3752 $SIGWATCHER{$signal} = AE::signal $signal, sub {
3753 cf::cleanup "SIG$signal";
3754 };
3755 }
3756}
3757
3758sub write_runtime_sync {
3759 my $t0 = AE::time;
3760
3761 # first touch the runtime file to show we are still running:
3762 # the fsync below can take a very very long time.
3763
3764 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3765
3766 my $guard = cf::lock_acquire "write_runtime";
3767
3768 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3769 or return;
3770
3771 my $value = $cf::RUNTIME + 90 + 10;
3772 # 10 is the runtime save interval, for a monotonic clock
3773 # 60 allows for the watchdog to kill the server.
3774
3775 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3776 and return;
3777
3778 # always fsync - this file is important
3779 aio_fsync $fh
3780 and return;
3781
3782 # touch it again to show we are up-to-date
3783 aio_utime $fh, undef, undef;
3784
3785 close $fh
3786 or return;
3787
3788 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3789 and return;
3790
3791 trace sprintf "runtime file written (%gs).\n", AE::time - $t0;
3792
3793 1
3794}
3795
3796our $uuid_lock;
3797our $uuid_skip;
3798
3799sub write_uuid_sync($) {
3800 $uuid_skip ||= $_[0];
3801
3802 return if $uuid_lock;
3803 local $uuid_lock = 1;
3804
3805 my $uuid = "$LOCALDIR/uuid";
3806
3807 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3808 or return;
3809
3810 my $value = uuid_seq uuid_cur;
3811
3812 unless ($value) {
3813 info "cowardly refusing to write zero uuid value!\n";
3814 return;
3815 }
3816
3817 my $value = uuid_str $value + $uuid_skip;
3818 $uuid_skip = 0;
3819
3820 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3821 and return;
3822
3823 # always fsync - this file is important
3824 aio_fsync $fh
3825 and return;
3826
3827 close $fh
3828 or return;
3829
3830 aio_rename "$uuid~", $uuid
3831 and return;
3832
3833 trace "uuid file written ($value).\n";
3834
3835 1
3836
3837}
3838
3839sub write_uuid($$) {
3840 my ($skip, $sync) = @_;
3841
3842 $sync ? write_uuid_sync $skip
3843 : async { write_uuid_sync $skip };
3844}
3845
3846sub emergency_save() {
3847 my $freeze_guard = cf::freeze_mainloop;
3848
3849 info "emergency_perl_save: enter\n";
3850
3851 # this is a trade-off: we want to be very quick here, so
3852 # save all maps without fsync, and later call a global sync
3853 # (which in turn might be very very slow)
3854 local $USE_FSYNC = 0;
3855
3856 cf::sync_job {
3857 cf::write_runtime_sync; # external watchdog should not bark
3858
3859 # use a peculiar iteration method to avoid tripping on perl
3860 # refcount bugs in for. also avoids problems with players
3861 # and maps saved/destroyed asynchronously.
3862 info "emergency_perl_save: begin player save\n";
3863 for my $login (keys %cf::PLAYER) {
3864 my $pl = $cf::PLAYER{$login} or next;
3865 $pl->valid or next;
3866 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3867 $pl->save;
3868 }
3869 info "emergency_perl_save: end player save\n";
3870
3871 cf::write_runtime_sync; # external watchdog should not bark
3872
3873 info "emergency_perl_save: begin map save\n";
3874 for my $path (keys %cf::MAP) {
3875 my $map = $cf::MAP{$path} or next;
3876 $map->valid or next;
3877 $map->save;
3878 }
3879 info "emergency_perl_save: end map save\n";
3880
3881 cf::write_runtime_sync; # external watchdog should not bark
3882
3883 info "emergency_perl_save: begin database checkpoint\n";
3884 BDB::db_env_txn_checkpoint $DB_ENV;
3885 info "emergency_perl_save: end database checkpoint\n";
3886
3887 info "emergency_perl_save: begin write uuid\n";
3888 write_uuid_sync 1;
3889 info "emergency_perl_save: end write uuid\n";
3890
3891 cf::write_runtime_sync; # external watchdog should not bark
3892
3893 trace "emergency_perl_save: syncing database to disk";
3894 BDB::db_env_txn_checkpoint $DB_ENV;
3895
3896 info "emergency_perl_save: starting sync\n";
3897 IO::AIO::aio_sync sub {
3898 info "emergency_perl_save: finished sync\n";
3899 };
3900
3901 cf::write_runtime_sync; # external watchdog should not bark
3902
3903 trace "emergency_perl_save: flushing outstanding aio requests";
3904 while (IO::AIO::nreqs || BDB::nreqs) {
3905 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3906 }
3907
3908 cf::write_runtime_sync; # external watchdog should not bark
3909 };
3910
3911 info "emergency_perl_save: leave\n";
3912}
3913
3914sub post_cleanup {
3915 my ($make_core) = @_;
3916
3917 IO::AIO::flush;
3918
3919 error Carp::longmess "post_cleanup backtrace"
3920 if $make_core;
3921
3922 my $fh = pidfile;
3923 unlink $PIDFILE if <$fh> == $$;
3924}
3925
3926# a safer delete_package, copied from Symbol
3927sub clear_package($) {
3928 my $pkg = shift;
3929
3930 # expand to full symbol table name if needed
3931 unless ($pkg =~ /^main::.*::$/) {
3932 $pkg = "main$pkg" if $pkg =~ /^::/;
3933 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3934 $pkg .= '::' unless $pkg =~ /::$/;
3935 }
3936
3937 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3938 my $stem_symtab = *{$stem}{HASH};
3939
3940 defined $stem_symtab and exists $stem_symtab->{$leaf}
3941 or return;
3942
3943 # clear all symbols
3944 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3945 for my $name (keys %$leaf_symtab) {
3946 _gv_clear *{"$pkg$name"};
3947# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3948 }
3949}
3950
3951sub do_reload_perl() {
3952 # can/must only be called in main
3953 unless (in_main) {
3954 error "can only reload from main coroutine";
3955 return;
3956 }
3957
3958 return if $RELOAD++;
3959
3960 my $t1 = AE::time;
3961
3962 while ($RELOAD) {
3963 cf::get_slot 0.1, -1, "reload_perl";
3964 info "perl_reload: reloading...";
3965
3966 trace "perl_reload: entering sync_job";
3967
3968 cf::sync_job {
3969 #cf::emergency_save;
3970
3971 trace "perl_reload: cancelling all extension coros";
3972 $_->cancel for values %EXT_CORO;
3973 %EXT_CORO = ();
3974
3975 trace "perl_reload: removing commands";
3976 %COMMAND = ();
3977
3978 trace "perl_reload: removing ext/exti commands";
3979 %EXTCMD = ();
3980 %EXTICMD = ();
3981
3982 trace "perl_reload: unloading/nuking all extensions";
3983 for my $pkg (@EXTS) {
3984 trace "... unloading $pkg";
3985
3986 if (my $cb = $pkg->can ("unload")) {
3987 eval {
3988 $cb->($pkg);
3989 1
3990 } or error "$pkg unloaded, but with errors: $@";
3991 }
3992
3993 trace "... clearing $pkg";
3994 clear_package $pkg;
3995 }
3996
3997 trace "perl_reload: unloading all perl modules loaded from $LIBDIR";
3998 while (my ($k, $v) = each %INC) {
3999 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
4000
4001 trace "... unloading $k";
4002 delete $INC{$k};
4003
4004 $k =~ s/\.pm$//;
4005 $k =~ s/\//::/g;
4006
4007 if (my $cb = $k->can ("unload_module")) {
4008 $cb->();
4009 }
4010
4011 clear_package $k;
4012 }
4013
4014 trace "perl_reload: getting rid of safe::, as good as possible";
4015 clear_package "safe::$_"
4016 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
4017
4018 trace "perl_reload: unloading cf.pm \"a bit\"";
4019 delete $INC{"cf.pm"};
4020 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
4021
4022 # don't, removes xs symbols, too,
4023 # and global variables created in xs
4024 #clear_package __PACKAGE__;
4025
4026 info "perl_reload: unload completed, starting to reload now";
4027
4028 trace "perl_reload: reloading cf.pm";
4029 require cf;
4030 cf::_connect_to_perl_1;
4031
4032 trace "perl_reload: loading config and database again";
4033 cf::reload_config;
4034
4035 trace "perl_reload: loading extensions";
4036 cf::load_extensions;
4037
4038 if ($REATTACH_ON_RELOAD) {
4039 trace "perl_reload: reattaching attachments to objects/players";
4040 _global_reattach; # objects, sockets
4041 trace "perl_reload: reattaching attachments to maps";
4042 reattach $_ for values %MAP;
4043 trace "perl_reload: reattaching attachments to players";
4044 reattach $_ for values %PLAYER;
4045 }
4046
4047 cf::_post_init 1;
4048
4049 trace "perl_reload: leaving sync_job";
4050
4051 1
4052 } or do {
4053 error $@;
4054 cf::cleanup "perl_reload: error, exiting.";
4055 };
4056
4057 --$RELOAD;
4058 }
4059
4060 $t1 = AE::time - $t1;
4061 info "perl_reload: completed in ${t1}s\n";
4062};
4063
4064our $RELOAD_WATCHER; # used only during reload
4065
4066sub reload_perl() {
4067 # doing reload synchronously and two reloads happen back-to-back,
4068 # coro crashes during coro_state_free->destroy here.
4069
4070 $RELOAD_WATCHER ||= cf::async {
4071 Coro::AIO::aio_wait cache_extensions;
4072
4073 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
4074 do_reload_perl;
4075 undef $RELOAD_WATCHER;
4076 };
4077 };
4078}
4079
4080register_command "reload" => sub {
4081 my ($who, $arg) = @_;
4082
4083 if ($who->flag (FLAG_WIZ)) {
4084 $who->message ("reloading server.");
4085 async {
4086 $Coro::current->{desc} = "perl_reload";
4087 reload_perl;
4088 };
4089 }
4090};
4091
4092#############################################################################
4093
4094my $bug_warning = 0;
4095
4096our @WAIT_FOR_TICK;
4097our @WAIT_FOR_TICK_BEGIN;
4098
4099sub wait_for_tick() {
4100 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
4101
4102 my $signal = new Coro::Signal;
4103 push @WAIT_FOR_TICK, $signal;
4104 $signal->wait;
4105}
4106
4107sub wait_for_tick_begin() {
4108 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
4109
4110 my $signal = new Coro::Signal;
4111 push @WAIT_FOR_TICK_BEGIN, $signal;
4112 $signal->wait;
4113}
4114
4115sub tick {
4116 if ($Coro::current != $Coro::main) {
4117 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
4118 unless ++$bug_warning > 10;
4119 return;
4120 }
4121
4122 cf::server_tick; # one server iteration
4123
4124 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
4125
4126 if ($NOW >= $NEXT_RUNTIME_WRITE) {
4127 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
4128 Coro::async_pool {
4129 $Coro::current->{desc} = "runtime saver";
4130 write_runtime_sync
4131 or error "ERROR: unable to write runtime file: $!";
4132 };
4133 }
4134
4135 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
4136 $sig->send;
4137 }
4138 while (my $sig = shift @WAIT_FOR_TICK) {
4139 $sig->send;
4140 }
4141
4142 $LOAD = ($NOW - $TICK_START) / $TICK;
4143 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
4144
4145 if (0) {
4146 if ($NEXT_TICK) {
4147 my $jitter = $TICK_START - $NEXT_TICK;
4148 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
4149 debug "jitter $JITTER\n";#d#
4150 }
4151 }
4152}
1087 4153
1088{ 4154{
1089 my $path = cf::localdir . "/database.pst"; 4155 # configure BDB
1090 4156
1091 sub db_load() { 4157 BDB::min_parallel 16;
1092 warn "loading database $path\n";#d# remove later 4158 BDB::max_poll_reqs $TICK * 0.1;
1093 $DB = stat $path ? Storable::retrieve $path : { }; 4159 $AnyEvent::BDB::WATCHER->priority (1);
1094 }
1095 4160
1096 my $pid; 4161 unless ($DB_ENV) {
4162 $DB_ENV = BDB::db_env_create;
4163 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
4164 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
4165 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
4166 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
4167 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
1097 4168
1098 sub db_save() { 4169 cf::sync_job {
1099 warn "saving database $path\n";#d# remove later
1100 waitpid $pid, 0 if $pid;
1101 if (0 == ($pid = fork)) {
1102 $DB->{_meta}{version} = 1;
1103 Storable::nstore $DB, "$path~";
1104 rename "$path~", $path;
1105 cf::_exit 0 if defined $pid;
1106 }
1107 }
1108
1109 my $dirty;
1110
1111 sub db_sync() {
1112 db_save if $dirty;
1113 undef $dirty;
1114 }
1115
1116 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
1117 db_sync;
1118 });
1119
1120 sub db_dirty() {
1121 $dirty = 1;
1122 $idle->start;
1123 }
1124
1125 sub db_get($;$) {
1126 @_ >= 2
1127 ? $DB->{$_[0]}{$_[1]}
1128 : ($DB->{$_[0]} ||= { })
1129 }
1130
1131 sub db_put($$;$) {
1132 if (@_ >= 3) {
1133 $DB->{$_[0]}{$_[1]} = $_[2];
1134 } else { 4170 eval {
1135 $DB->{$_[0]} = $_[1]; 4171 BDB::db_env_open
1136 } 4172 $DB_ENV,
1137 db_dirty; 4173 $BDBDIR,
1138 } 4174 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
4175 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
4176 0666;
1139 4177
1140 cf::global->attach ( 4178 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
1141 prio => 10000,
1142 on_cleanup => sub {
1143 db_sync;
1144 },
1145 );
1146}
1147
1148#############################################################################
1149# the server's main()
1150
1151sub cfg_load {
1152 open my $fh, "<:utf8", cf::confdir . "/config"
1153 or return;
1154
1155 local $/;
1156 *CFG = YAML::Syck::Load <$fh>;
1157}
1158
1159sub main {
1160 cfg_load;
1161 db_load;
1162 load_extensions;
1163 Event::loop;
1164}
1165
1166#############################################################################
1167# initialisation
1168
1169sub _perl_reload(&) {
1170 my ($msg) = @_;
1171
1172 $msg->("reloading...");
1173
1174 eval {
1175 # cancel all watchers
1176 for (Event::all_watchers) {
1177 $_->cancel if $_->data & WF_AUTOCANCEL;
1178 }
1179
1180 # unload all extensions
1181 for (@exts) {
1182 $msg->("unloading <$_>");
1183 unload_extension $_;
1184 }
1185
1186 # unload all modules loaded from $LIBDIR
1187 while (my ($k, $v) = each %INC) {
1188 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
1189
1190 $msg->("removing <$k>");
1191 delete $INC{$k};
1192
1193 $k =~ s/\.pm$//;
1194 $k =~ s/\//::/g;
1195
1196 if (my $cb = $k->can ("unload_module")) {
1197 $cb->();
1198 } 4179 };
1199 4180
1200 Symbol::delete_package $k; 4181 cf::cleanup "db_env_open(db): $@" if $@;
1201 } 4182 };
4183 }
1202 4184
1203 # sync database to disk 4185 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
1204 cf::db_sync; 4186 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
1205
1206 # get rid of safe::, as good as possible
1207 Symbol::delete_package "safe::$_"
1208 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
1209
1210 # remove register_script_function callbacks
1211 # TODO
1212
1213 # unload cf.pm "a bit"
1214 delete $INC{"cf.pm"};
1215
1216 # don't, removes xs symbols, too,
1217 # and global variables created in xs
1218 #Symbol::delete_package __PACKAGE__;
1219
1220 # reload cf.pm
1221 $msg->("reloading cf.pm");
1222 require cf;
1223
1224 # load config and database again
1225 cf::cfg_load;
1226 cf::db_load;
1227
1228 # load extensions
1229 $msg->("load extensions");
1230 cf::load_extensions;
1231
1232 # reattach attachments to objects
1233 $msg->("reattach");
1234 _global_reattach;
1235 }; 4187 };
1236 $msg->($@) if $@; 4188 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
1237 4189 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
1238 $msg->("reloaded");
1239};
1240
1241sub perl_reload() {
1242 _perl_reload {
1243 warn $_[0];
1244 print "$_[0]\n";
1245 }; 4190 };
4191 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
4192 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
4193 };
1246} 4194}
1247 4195
1248register "<global>", __PACKAGE__; 4196{
4197 # configure IO::AIO
1249 4198
1250register_command "perl-reload" => sub { 4199 IO::AIO::min_parallel 8;
4200 IO::AIO::max_poll_time $TICK * 0.1;
4201 undef $AnyEvent::AIO::WATCHER;
4202}
4203
4204our $_log_backtrace;
4205our $_log_backtrace_last;
4206
4207sub _log_backtrace {
1251 my ($who, $arg) = @_; 4208 my ($msg, @addr) = @_;
1252 4209
1253 if ($who->flag (FLAG_WIZ)) { 4210 $msg =~ s/\n$//;
1254 _perl_reload { 4211
1255 warn $_[0]; 4212 if ($_log_backtrace_last eq $msg) {
1256 $who->message ($_[0]); 4213 LOG llevInfo, "[ABT] $msg\n";
4214 LOG llevInfo, "[ABT] [duplicate, suppressed]\n";
4215 # limit the # of concurrent backtraces
4216 } elsif ($_log_backtrace < 2) {
4217 $_log_backtrace_last = $msg;
4218 ++$_log_backtrace;
4219 my $perl_bt = Carp::longmess $msg;
4220 async {
4221 $Coro::current->{desc} = "abt $msg";
4222
4223 my @bt = fork_call {
4224 @addr = map { sprintf "%x", $_ } @addr;
4225 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
4226 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
4227 or die "addr2line: $!";
4228
4229 my @funcs;
4230 my @res = <$fh>;
4231 chomp for @res;
4232 while (@res) {
4233 my ($func, $line) = splice @res, 0, 2, ();
4234 push @funcs, "[$func] $line";
4235 }
4236
4237 @funcs
4238 };
4239
4240 LOG llevInfo, "[ABT] $perl_bt\n";
4241 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
4242 LOG llevInfo, "[ABT] $_\n" for @bt;
4243 --$_log_backtrace;
1257 }; 4244 };
1258 } 4245 } else {
1259}; 4246 LOG llevInfo, "[ABT] $msg\n";
1260 4247 LOG llevInfo, "[ABT] [overload, suppressed]\n";
1261unshift @INC, $LIBDIR;
1262
1263$TICK_WATCHER = Event->timer (
1264 prio => 0,
1265 at => $NEXT_TICK || 1,
1266 data => WF_AUTOCANCEL,
1267 cb => sub {
1268 cf::server_tick; # one server iteration
1269
1270 my $NOW = Event::time;
1271 $NEXT_TICK += $TICK;
1272
1273 # if we are delayed by four ticks or more, skip them all
1274 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
1275
1276 $TICK_WATCHER->at ($NEXT_TICK);
1277 $TICK_WATCHER->start;
1278 }, 4248 }
1279); 4249}
1280 4250
1281IO::AIO::max_poll_time $TICK * 0.2; 4251# load additional modules
4252require "cf/$_.pm" for @EXTRA_MODULES;
4253cf::_connect_to_perl_2;
1282 4254
1283Event->io (fd => IO::AIO::poll_fileno, 4255END { cf::emergency_save }
1284 poll => 'r',
1285 prio => 5,
1286 data => WF_AUTOCANCEL,
1287 cb => \&IO::AIO::poll_cb);
1288 4256
12891 42571
1290 4258

Diff Legend

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