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.101 by root, Mon Dec 25 14:43:23 2006 UTC vs.
Revision 1.581 by root, Fri Feb 3 02:04:11 2012 UTC

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

Diff Legend

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