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.100 by root, Mon Dec 25 11:25:49 2006 UTC vs.
Revision 1.623 by root, Wed Aug 30 14:18:51 2017 UTC

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

Diff Legend

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