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.223 by root, Sun Mar 11 02:12:44 2007 UTC vs.
Revision 1.447 by root, Fri Sep 19 01:39:45 2008 UTC

1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3#
4# Copyright (©) 2006,2007,2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5#
6# Deliantra is free software: you can redistribute it and/or modify
7# it under the terms of the GNU General Public License as published by
8# the Free Software Foundation, either version 3 of the License, or
9# (at your 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 GNU General Public License
17# along with this program. If not, see <http://www.gnu.org/licenses/>.
18#
19# The authors can be reached via e-mail to <support@deliantra.net>
20#
21
1package cf; 22package cf;
2 23
24use 5.10.0;
3use utf8; 25use utf8;
4use strict; 26use strict "vars", "subs";
5 27
6use Symbol; 28use Symbol;
7use List::Util; 29use List::Util;
8use Storable; 30use Socket;
31use EV;
9use Opcode; 32use Opcode;
10use Safe; 33use Safe;
11use Safe::Hole; 34use Safe::Hole;
35use Storable ();
12 36
13use Coro 3.5 (); 37use Coro ();
38use Coro::State;
39use Coro::Handle;
40use Coro::EV;
14use Coro::Event; 41use Coro::AnyEvent;
15use Coro::Timer; 42use Coro::Timer;
16use Coro::Signal; 43use Coro::Signal;
17use Coro::Semaphore; 44use Coro::Semaphore;
45use Coro::AnyEvent;
18use Coro::AIO; 46use Coro::AIO;
47use Coro::BDB 1.6;
48use Coro::Storable;
49use Coro::Util ();
19 50
51use JSON::XS 2.01 ();
20use BDB (); 52use BDB ();
21use Data::Dumper; 53use Data::Dumper;
22use Digest::MD5; 54use Digest::MD5;
23use Fcntl; 55use Fcntl;
56use YAML ();
24use IO::AIO 2.32 (); 57use IO::AIO ();
25use YAML::Syck ();
26use Time::HiRes; 58use Time::HiRes;
27use Compress::LZF; 59use Compress::LZF;
60use Digest::MD5 ();
28 61
62AnyEvent::detect;
63
64# configure various modules to our taste
65#
66$Storable::canonical = 1; # reduce rsync transfers
67Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
29Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 68Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
30 69
31use Event; $Event::Eval = 1; # no idea why this is required, but it is 70$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
32 71
33sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 72sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
34
35# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
36$YAML::Syck::ImplicitUnicode = 1;
37
38$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
39 73
40our %COMMAND = (); 74our %COMMAND = ();
41our %COMMAND_TIME = (); 75our %COMMAND_TIME = ();
42 76
43our @EXTS = (); # list of extension package names 77our @EXTS = (); # list of extension package names
44our %EXTCMD = (); 78our %EXTCMD = ();
79our %EXTICMD = ();
45our %EXT_CORO = (); # coroutines bound to extensions 80our %EXT_CORO = (); # coroutines bound to extensions
46our %EXT_MAP = (); # pluggable maps 81our %EXT_MAP = (); # pluggable maps
47 82
48our $RELOAD; # number of reloads so far 83our $RELOAD; # number of reloads so far
49our @EVENT; 84our @EVENT;
50our $LIBDIR = datadir . "/ext";
51 85
52our $TICK = MAX_TIME * 1e-6; 86our $CONFDIR = confdir;
53our $TICK_WATCHER; 87our $DATADIR = datadir;
54our $AIO_POLL_WATCHER; 88our $LIBDIR = "$DATADIR/ext";
89our $PODDIR = "$DATADIR/pod";
90our $MAPDIR = "$DATADIR/" . mapdir;
91our $LOCALDIR = localdir;
92our $TMPDIR = "$LOCALDIR/" . tmpdir;
93our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
94our $PLAYERDIR = "$LOCALDIR/" . playerdir;
95our $RANDOMDIR = "$LOCALDIR/random";
96our $BDBDIR = "$LOCALDIR/db";
97our $PIDFILE = "$LOCALDIR/pid";
98our $RUNTIMEFILE = "$LOCALDIR/runtime";
99
100our %RESOURCE;
101
102our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
55our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 103our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
56our $NEXT_TICK; 104our $NEXT_TICK;
57our $NOW;
58our $USE_FSYNC = 1; # use fsync to write maps - default off 105our $USE_FSYNC = 1; # use fsync to write maps - default off
59 106
107our $BDB_DEADLOCK_WATCHER;
108our $BDB_CHECKPOINT_WATCHER;
60our $BDB_POLL_WATCHER; 109our $BDB_TRICKLE_WATCHER;
61our $DB_ENV; 110our $DB_ENV;
62 111
63our %CFG; 112our %CFG;
64 113
65our $UPTIME; $UPTIME ||= time; 114our $UPTIME; $UPTIME ||= time;
66our $RUNTIME; 115our $RUNTIME;
116our $NOW;
67 117
68our %PLAYER; # all users 118our (%PLAYER, %PLAYER_LOADING); # all users
69our %MAP; # all maps 119our (%MAP, %MAP_LOADING ); # all maps
70our $LINK_MAP; # the special {link} map, which is always available 120our $LINK_MAP; # the special {link} map, which is always available
71our $RANDOM_MAPS = cf::localdir . "/random";
72our $BDB_ENV_DIR = cf::localdir . "/db";
73
74our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal;
75our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal;
76 121
77# used to convert map paths into valid unix filenames by replacing / by ∕ 122# used to convert map paths into valid unix filenames by replacing / by ∕
78our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 123our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
79 124
125our $LOAD; # a number between 0 (idle) and 1 (too many objects)
126our $LOADAVG; # same thing, but with alpha-smoothing
127our $JITTER; # average jitter
128our $TICK_START; # for load detecting purposes
129
80binmode STDOUT; 130binmode STDOUT;
81binmode STDERR; 131binmode STDERR;
82 132
83# read virtual server time, if available 133# read virtual server time, if available
84unless ($RUNTIME || !-e cf::localdir . "/runtime") { 134unless ($RUNTIME || !-e $RUNTIMEFILE) {
85 open my $fh, "<", cf::localdir . "/runtime" 135 open my $fh, "<", $RUNTIMEFILE
86 or die "unable to read runtime file: $!"; 136 or die "unable to read $RUNTIMEFILE file: $!";
87 $RUNTIME = <$fh> + 0.; 137 $RUNTIME = <$fh> + 0.;
88} 138}
89 139
90mkdir cf::localdir; 140mkdir $_
91mkdir cf::localdir . "/" . cf::playerdir; 141 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
92mkdir cf::localdir . "/" . cf::tmpdir;
93mkdir cf::localdir . "/" . cf::uniquedir;
94mkdir $RANDOM_MAPS;
95mkdir $BDB_ENV_DIR;
96 142
97our $EMERGENCY_POSITION; 143our $EMERGENCY_POSITION;
98 144
99sub cf::map::normalise; 145sub cf::map::normalise;
100 146
111=item $cf::RUNTIME 157=item $cf::RUNTIME
112 158
113The time this server has run, starts at 0 and is increased by $cf::TICK on 159The time this server has run, starts at 0 and is increased by $cf::TICK on
114every server tick. 160every server tick.
115 161
116=item $cf::LIBDIR 162=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
163$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
164$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
117 165
118The perl library directory, where extensions and cf-specific modules can 166Various directories - "/etc", read-only install directory, perl-library
119be found. It will be added to C<@INC> automatically. 167directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
168unique-items directory, player file directory, random maps directory and
169database environment.
120 170
121=item $cf::NOW 171=item $cf::NOW
122 172
123The time of the last (current) server tick. 173The time of the last (current) server tick.
124 174
125=item $cf::TICK 175=item $cf::TICK
126 176
127The interval between server ticks, in seconds. 177The interval between server ticks, in seconds.
128 178
179=item $cf::LOADAVG
180
181The current CPU load on the server (alpha-smoothed), as a value between 0
182(none) and 1 (overloaded), indicating how much time is spent on processing
183objects per tick. Healthy values are < 0.5.
184
185=item $cf::LOAD
186
187The raw value load value from the last tick.
188
129=item %cf::CFG 189=item %cf::CFG
130 190
131Configuration for the server, loaded from C</etc/crossfire/config>, or 191Configuration for the server, loaded from C</etc/deliantra-server/config>, or
132from wherever your confdir points to. 192from wherever your confdir points to.
133 193
134=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE 194=item cf::wait_for_tick, cf::wait_for_tick_begin
135 195
136These are Coro::Signal objects that are C<< ->broadcast >> (WAIT_FOR_TICK) 196These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
137or C<< ->send >> (WAIT_FOR_TICK_ONE) on after normal server tick 197returns directly I<after> the tick processing (and consequently, can only wake one process
138processing has been done. Call C<< ->wait >> on them to maximise the 198per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
139window of cpu time available, or simply to synchronise to the server tick. 199
200=item @cf::INVOKE_RESULTS
201
202This array contains the results of the last C<invoke ()> call. When
203C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
204that call.
140 205
141=back 206=back
142 207
143=cut 208=cut
144 209
145BEGIN { 210BEGIN {
146 *CORE::GLOBAL::warn = sub { 211 *CORE::GLOBAL::warn = sub {
147 my $msg = join "", @_; 212 my $msg = join "", @_;
148 utf8::encode $msg;
149 213
150 $msg .= "\n" 214 $msg .= "\n"
151 unless $msg =~ /\n$/; 215 unless $msg =~ /\n$/;
152 216
217 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
218
153 LOG llevError, $msg; 219 LOG llevError, $msg;
154 }; 220 };
155} 221}
222
223$Coro::State::DIEHOOK = sub {
224 return unless $^S eq 0; # "eq", not "=="
225
226 if ($Coro::current == $Coro::main) {#d#
227 warn "DIEHOOK called in main context, Coro bug?\n";#d#
228 return;#d#
229 }#d#
230
231 # kill coroutine otherwise
232 warn Carp::longmess $_[0];
233 Coro::terminate
234};
235
236$SIG{__DIE__} = sub { }; #d#?
156 237
157@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 238@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
158@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 239@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
159@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 240@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
160@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 241@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
161@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable'; 242@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
243@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
162@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 244@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
163 245
164# we bless all objects into (empty) derived classes to force a method lookup 246# we bless all objects into (empty) derived classes to force a method lookup
165# within the Safe compartment. 247# within the Safe compartment.
166for my $pkg (qw( 248for my $pkg (qw(
167 cf::global cf::attachable 249 cf::global cf::attachable
168 cf::object cf::object::player 250 cf::object cf::object::player
169 cf::client cf::player 251 cf::client cf::player
170 cf::arch cf::living 252 cf::arch cf::living
253 cf::map cf::mapspace
171 cf::map cf::party cf::region 254 cf::party cf::region
172)) { 255)) {
173 no strict 'refs';
174 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 256 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
175} 257}
176 258
177$Event::DIED = sub { 259$EV::DIED = sub {
178 warn "error in event callback: @_"; 260 warn "error in event callback: @_";
179}; 261};
262
263#############################################################################
180 264
181=head2 UTILITY FUNCTIONS 265=head2 UTILITY FUNCTIONS
182 266
183=over 4 267=over 4
184 268
203 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 287 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
204 $d 288 $d
205 } || "[unable to dump $_[0]: '$@']"; 289 } || "[unable to dump $_[0]: '$@']";
206} 290}
207 291
208use JSON::Syck (); # TODO# replace by JSON::PC once working
209
210=item $ref = cf::from_json $json 292=item $ref = cf::decode_json $json
211 293
212Converts a JSON string into the corresponding perl data structure. 294Converts a JSON string into the corresponding perl data structure.
213 295
214=cut
215
216sub from_json($) {
217 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
218 JSON::Syck::Load $_[0]
219}
220
221=item $json = cf::to_json $ref 296=item $json = cf::encode_json $ref
222 297
223Converts a perl data structure into its JSON representation. 298Converts a perl data structure into its JSON representation.
224 299
225=cut 300=cut
226 301
227sub to_json($) { 302our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
228 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 303
229 JSON::Syck::Dump $_[0] 304sub encode_json($) { $json_coder->encode ($_[0]) }
230} 305sub decode_json($) { $json_coder->decode ($_[0]) }
231 306
232=item cf::lock_wait $string 307=item cf::lock_wait $string
233 308
234Wait until the given lock is available. See cf::lock_acquire. 309Wait until the given lock is available. See cf::lock_acquire.
235 310
238Wait until the given lock is available and then acquires it and returns 313Wait until the given lock is available and then acquires it and returns
239a Coro::guard object. If the guard object gets destroyed (goes out of scope, 314a Coro::guard object. If the guard object gets destroyed (goes out of scope,
240for example when the coroutine gets canceled), the lock is automatically 315for example when the coroutine gets canceled), the lock is automatically
241returned. 316returned.
242 317
318Locks are *not* recursive, locking from the same coro twice results in a
319deadlocked coro.
320
243Lock names should begin with a unique identifier (for example, cf::map::find 321Lock names should begin with a unique identifier (for example, cf::map::find
244uses map_find and cf::map::load uses map_load). 322uses map_find and cf::map::load uses map_load).
245 323
324=item $locked = cf::lock_active $string
325
326Return true if the lock is currently active, i.e. somebody has locked it.
327
246=cut 328=cut
247 329
248our %LOCK; 330our %LOCK;
331our %LOCKER;#d#
249 332
250sub lock_wait($) { 333sub lock_wait($) {
251 my ($key) = @_; 334 my ($key) = @_;
335
336 if ($LOCKER{$key} == $Coro::current) {#d#
337 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
338 return;#d#
339 }#d#
252 340
253 # wait for lock, if any 341 # wait for lock, if any
254 while ($LOCK{$key}) { 342 while ($LOCK{$key}) {
255 push @{ $LOCK{$key} }, $Coro::current; 343 push @{ $LOCK{$key} }, $Coro::current;
256 Coro::schedule; 344 Coro::schedule;
262 350
263 # wait, to be sure we are not locked 351 # wait, to be sure we are not locked
264 lock_wait $key; 352 lock_wait $key;
265 353
266 $LOCK{$key} = []; 354 $LOCK{$key} = [];
355 $LOCKER{$key} = $Coro::current;#d#
267 356
268 Coro::guard { 357 Coro::guard {
358 delete $LOCKER{$key};#d#
269 # wake up all waiters, to be on the safe side 359 # wake up all waiters, to be on the safe side
270 $_->ready for @{ delete $LOCK{$key} }; 360 $_->ready for @{ delete $LOCK{$key} };
271 } 361 }
272} 362}
273 363
364sub lock_active($) {
365 my ($key) = @_;
366
367 ! ! $LOCK{$key}
368}
369
274sub freeze_mainloop { 370sub freeze_mainloop {
275 return unless $TICK_WATCHER->is_active; 371 tick_inhibit_inc;
276 372
277 my $guard = Coro::guard { 373 Coro::guard \&tick_inhibit_dec;
278 $TICK_WATCHER->start; 374}
375
376=item cf::periodic $interval, $cb
377
378Like EV::periodic, but randomly selects a starting point so that the actions
379get spread over timer.
380
381=cut
382
383sub periodic($$) {
384 my ($interval, $cb) = @_;
385
386 my $start = rand List::Util::min 180, $interval;
387
388 EV::periodic $start, $interval, 0, $cb
389}
390
391=item cf::get_slot $time[, $priority[, $name]]
392
393Allocate $time seconds of blocking CPU time at priority C<$priority>:
394This call blocks and returns only when you have at least C<$time> seconds
395of cpu time till the next tick. The slot is only valid till the next cede.
396
397The optional C<$name> can be used to identify the job to run. It might be
398used for statistical purposes and should identify the same time-class.
399
400Useful for short background jobs.
401
402=cut
403
404our @SLOT_QUEUE;
405our $SLOT_QUEUE;
406
407$SLOT_QUEUE->cancel if $SLOT_QUEUE;
408$SLOT_QUEUE = Coro::async {
409 $Coro::current->desc ("timeslot manager");
410
411 my $signal = new Coro::Signal;
412
413 while () {
414 next_job:
415 my $avail = cf::till_tick;
416 if ($avail > 0.01) {
417 for (0 .. $#SLOT_QUEUE) {
418 if ($SLOT_QUEUE[$_][0] < $avail) {
419 my $job = splice @SLOT_QUEUE, $_, 1, ();
420 $job->[2]->send;
421 Coro::cede;
422 goto next_job;
423 }
424 }
425 }
426
427 if (@SLOT_QUEUE) {
428 # we do not use wait_for_tick() as it returns immediately when tick is inactive
429 push @cf::WAIT_FOR_TICK, $signal;
430 $signal->wait;
431 } else {
432 Coro::schedule;
433 }
279 }; 434 }
280 $TICK_WATCHER->stop; 435};
281 $guard 436
437sub get_slot($;$$) {
438 return if tick_inhibit || $Coro::current == $Coro::main;
439
440 my ($time, $pri, $name) = @_;
441
442 $time = $TICK * .6 if $time > $TICK * .6;
443 my $sig = new Coro::Signal;
444
445 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
446 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
447 $SLOT_QUEUE->ready;
448 $sig->wait;
282} 449}
283 450
284=item cf::async { BLOCK } 451=item cf::async { BLOCK }
285 452
286Currently the same as Coro::async_pool, meaning you cannot use 453Currently the same as Coro::async_pool, meaning you cannot use
291 458
292BEGIN { *async = \&Coro::async_pool } 459BEGIN { *async = \&Coro::async_pool }
293 460
294=item cf::sync_job { BLOCK } 461=item cf::sync_job { BLOCK }
295 462
296The design of crossfire+ requires that the main coro ($Coro::main) is 463The design of Deliantra requires that the main coroutine ($Coro::main)
297always able to handle events or runnable, as crossfire+ is only partly 464is always able to handle events or runnable, as Deliantra is only
298reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable. 465partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
466acceptable.
299 467
300If it must be done, put the blocking parts into C<sync_job>. This will run 468If it must be done, put the blocking parts into C<sync_job>. This will run
301the given BLOCK in another coroutine while waiting for the result. The 469the given BLOCK in another coroutine while waiting for the result. The
302server will be frozen during this time, so the block should either finish 470server will be frozen during this time, so the block should either finish
303fast or be very important. 471fast or be very important.
306 474
307sub sync_job(&) { 475sub sync_job(&) {
308 my ($job) = @_; 476 my ($job) = @_;
309 477
310 if ($Coro::current == $Coro::main) { 478 if ($Coro::current == $Coro::main) {
479 my $time = EV::time;
480
311 # this is the main coro, too bad, we have to block 481 # this is the main coro, too bad, we have to block
312 # till the operation succeeds, freezing the server :/ 482 # till the operation succeeds, freezing the server :/
313 483
314 # TODO: use suspend/resume instead 484 LOG llevError, Carp::longmess "sync job";#d#
315 # (but this is cancel-safe) 485
316 my $freeze_guard = freeze_mainloop; 486 my $freeze_guard = freeze_mainloop;
317 487
318 my $busy = 1; 488 my $busy = 1;
319 my @res; 489 my @res;
320 490
321 (async { 491 (async {
492 $Coro::current->desc ("sync job coro");
322 @res = eval { $job->() }; 493 @res = eval { $job->() };
323 warn $@ if $@; 494 warn $@ if $@;
324 undef $busy; 495 undef $busy;
325 })->prio (Coro::PRIO_MAX); 496 })->prio (Coro::PRIO_MAX);
326 497
327 while ($busy) { 498 while ($busy) {
328 Coro::cede or Event::one_event; 499 if (Coro::nready) {
500 Coro::cede_notself;
501 } else {
502 EV::loop EV::LOOP_ONESHOT;
329 } 503 }
504 }
505
506 my $time = EV::time - $time;
507
508 $TICK_START += $time; # do not account sync jobs to server load
330 509
331 wantarray ? @res : $res[0] 510 wantarray ? @res : $res[0]
332 } else { 511 } else {
333 # we are in another coroutine, how wonderful, everything just works 512 # we are in another coroutine, how wonderful, everything just works
334 513
354 $EXT_CORO{$coro+0} = $coro; 533 $EXT_CORO{$coro+0} = $coro;
355 534
356 $coro 535 $coro
357} 536}
358 537
359sub write_runtime { 538=item fork_call { }, $args
360 my $guard = cf::lock_acquire "write_runtime";
361 539
362 my $runtime = cf::localdir . "/runtime"; 540Executes the given code block with the given arguments in a seperate
541process, returning the results. Everything must be serialisable with
542Coro::Storable. May, of course, block. Note that the executed sub may
543never block itself or use any form of event handling.
363 544
364 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 545=cut
365 or return;
366 546
367 my $value = $cf::RUNTIME + 90 + 10; 547sub fork_call(&@) {
368 # 10 is the runtime save interval, for a monotonic clock 548 my ($cb, @args) = @_;
369 # 60 allows for the watchdog to kill the server.
370 549
371 (aio_write $fh, 0, (length $value), $value, 0) <= 0 550 # we seemingly have to make a local copy of the whole thing,
372 and return; 551 # otherwise perl prematurely frees the stuff :/
552 # TODO: investigate and fix (likely this will be rather laborious)
373 553
374 # always fsync - this file is important 554 my @res = Coro::Util::fork_eval {
375 aio_fsync $fh 555 reset_signals;
376 and return; 556 &$cb
557 }, @args;
377 558
378 close $fh 559 wantarray ? @res : $res[-1]
379 or return; 560}
380 561
381 aio_rename "$runtime~", $runtime 562=item $coin = coin_from_name $name
382 and return;
383 563
564=cut
565
566our %coin_alias = (
567 "silver" => "silvercoin",
568 "silvercoin" => "silvercoin",
569 "silvercoins" => "silvercoin",
570 "gold" => "goldcoin",
571 "goldcoin" => "goldcoin",
572 "goldcoins" => "goldcoin",
573 "platinum" => "platinacoin",
574 "platinumcoin" => "platinacoin",
575 "platinumcoins" => "platinacoin",
576 "platina" => "platinacoin",
577 "platinacoin" => "platinacoin",
578 "platinacoins" => "platinacoin",
579 "royalty" => "royalty",
580 "royalties" => "royalty",
581);
582
583sub coin_from_name($) {
584 $coin_alias{$_[0]}
585 ? cf::arch::find $coin_alias{$_[0]}
586 : undef
587}
588
589=item $value = cf::db_get $family => $key
590
591Returns a single value from the environment database.
592
593=item cf::db_put $family => $key => $value
594
595Stores the given C<$value> in the family. It can currently store binary
596data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
597
598=item $db = cf::db_table "name"
599
600Create and/or open a new database table. The string must not be "db" and must be unique
601within each server.
602
603=cut
604
605sub db_table($) {
606 my ($name) = @_;
607 my $db = BDB::db_create $DB_ENV;
608
609 eval {
610 $db->set_flags (BDB::CHKSUM);
611
612 utf8::encode $name;
613 BDB::db_open $db, undef, $name, undef, BDB::BTREE,
614 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
615 cf::cleanup "db_open(db): $!" if $!;
616 };
617 cf::cleanup "db_open(db): $@" if $@;
618
619 $db
620}
621
622our $DB;
623
624sub db_init {
625 cf::sync_job {
626 $DB ||= db_table "db";
627 };
628}
629
630sub db_get($$) {
631 my $key = "$_[0]/$_[1]";
632
633 cf::sync_job {
634 BDB::db_get $DB, undef, $key, my $data;
635
636 $! ? ()
637 : $data
384 1 638 }
639}
640
641sub db_put($$$) {
642 BDB::dbreq_pri 4;
643 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
644}
645
646=item cf::cache $id => [$paths...], $processversion => $process
647
648Generic caching function that returns the value of the resource $id,
649caching and regenerating as required.
650
651This function can block.
652
653=cut
654
655sub cache {
656 my ($id, $src, $processversion, $process) = @_;
657
658 my $meta =
659 join "\x00",
660 $processversion,
661 map {
662 aio_stat $_
663 and Carp::croak "$_: $!";
664
665 ($_, (stat _)[7,9])
666 } @$src;
667
668 my $dbmeta = db_get cache => "$id/meta";
669 if ($dbmeta ne $meta) {
670 # changed, we may need to process
671
672 my @data;
673 my $md5;
674
675 for (0 .. $#$src) {
676 0 <= aio_load $src->[$_], $data[$_]
677 or Carp::croak "$src->[$_]: $!";
678 }
679
680 # if processing is expensive, check
681 # checksum first
682 if (1) {
683 $md5 =
684 join "\x00",
685 $processversion,
686 map {
687 cf::cede_to_tick;
688 ($src->[$_], Digest::MD5::md5_hex $data[$_])
689 } 0.. $#$src;
690
691
692 my $dbmd5 = db_get cache => "$id/md5";
693 if ($dbmd5 eq $md5) {
694 db_put cache => "$id/meta", $meta;
695
696 return db_get cache => "$id/data";
697 }
698 }
699
700 my $t1 = Time::HiRes::time;
701 my $data = $process->(\@data);
702 my $t2 = Time::HiRes::time;
703
704 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
705
706 db_put cache => "$id/data", $data;
707 db_put cache => "$id/md5" , $md5;
708 db_put cache => "$id/meta", $meta;
709
710 return $data;
711 }
712
713 db_get cache => "$id/data"
714}
715
716=item cf::datalog type => key => value, ...
717
718Log a datalog packet of the given type with the given key-value pairs.
719
720=cut
721
722sub datalog($@) {
723 my ($type, %kv) = @_;
724 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
385} 725}
386 726
387=back 727=back
388 728
389=cut 729=cut
390 730
391############################################################################# 731#############################################################################
392 732
393=head2 ATTACHABLE OBJECTS 733=head2 ATTACHABLE OBJECTS
394 734
395Many objects in crossfire are so-called attachable objects. That means you can 735Many objects in deliantra are so-called attachable objects. That means you can
396attach callbacks/event handlers (a collection of which is called an "attachment") 736attach callbacks/event handlers (a collection of which is called an "attachment")
397to it. All such attachable objects support the following methods. 737to it. All such attachable objects support the following methods.
398 738
399In the following description, CLASS can be any of C<global>, C<object> 739In the following description, CLASS can be any of C<global>, C<object>
400C<player>, C<client> or C<map> (i.e. the attachable objects in 740C<player>, C<client> or C<map> (i.e. the attachable objects in
401crossfire+). 741Deliantra).
402 742
403=over 4 743=over 4
404 744
405=item $attachable->attach ($attachment, key => $value...) 745=item $attachable->attach ($attachment, key => $value...)
406 746
450=item cf::CLASS::attachment $name, ... 790=item cf::CLASS::attachment $name, ...
451 791
452Register an attachment by C<$name> through which attachable objects of the 792Register an attachment by C<$name> through which attachable objects of the
453given CLASS can refer to this attachment. 793given CLASS can refer to this attachment.
454 794
455Some classes such as crossfire maps and objects can specify attachments 795Some classes such as deliantra maps and objects can specify attachments
456that are attached at load/instantiate time, thus the need for a name. 796that are attached at load/instantiate time, thus the need for a name.
457 797
458These calls expect any number of the following handler/hook descriptions: 798These calls expect any number of the following handler/hook descriptions:
459 799
460=over 4 800=over 4
569 $registry = $CB_TYPE[$object_type] ||= []; 909 $registry = $CB_TYPE[$object_type] ||= [];
570 910
571 } elsif ($type eq "subtype") { 911 } elsif ($type eq "subtype") {
572 defined $object_type or Carp::croak "subtype specified without type"; 912 defined $object_type or Carp::croak "subtype specified without type";
573 my $object_subtype = shift @arg; 913 my $object_subtype = shift @arg;
574 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 914 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
575 915
576 } elsif ($type eq "package") { 916 } elsif ($type eq "package") {
577 my $pkg = shift @arg; 917 my $pkg = shift @arg;
578 918
579 while (my ($name, $id) = each %cb_id) { 919 while (my ($name, $id) = each %cb_id) {
608 _attach $registry, $klass, @attach; 948 _attach $registry, $klass, @attach;
609 } 949 }
610 950
611 $obj->{$name} = \%arg; 951 $obj->{$name} = \%arg;
612 } else { 952 } else {
613 warn "object uses attachment '$name' that is not available, postponing.\n"; 953 warn "object uses attachment '$name' which is not available, postponing.\n";
614 } 954 }
615 955
616 $obj->{_attachment}{$name} = undef; 956 $obj->{_attachment}{$name} = undef;
617} 957}
618 958
620 if (ref $_[0]) { 960 if (ref $_[0]) {
621 _object_attach @_; 961 _object_attach @_;
622 } else { 962 } else {
623 _attach shift->_attach_registry, @_; 963 _attach shift->_attach_registry, @_;
624 } 964 }
965 _recalc_want;
625}; 966};
626 967
627# all those should be optimised 968# all those should be optimised
628sub cf::attachable::detach { 969sub cf::attachable::detach {
629 my ($obj, $name) = @_; 970 my ($obj, $name) = @_;
632 delete $obj->{_attachment}{$name}; 973 delete $obj->{_attachment}{$name};
633 reattach ($obj); 974 reattach ($obj);
634 } else { 975 } else {
635 Carp::croak "cannot, currently, detach class attachments"; 976 Carp::croak "cannot, currently, detach class attachments";
636 } 977 }
978 _recalc_want;
637}; 979};
638 980
639sub cf::attachable::attached { 981sub cf::attachable::attached {
640 my ($obj, $name) = @_; 982 my ($obj, $name) = @_;
641 983
656 "; 998 ";
657 die if $@; 999 die if $@;
658} 1000}
659 1001
660our $override; 1002our $override;
661our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 1003our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
662 1004
663sub override { 1005sub override {
664 $override = 1; 1006 $override = 1;
665 @invoke_results = (); 1007 @INVOKE_RESULTS = (@_);
666} 1008}
667 1009
668sub do_invoke { 1010sub do_invoke {
669 my $event = shift; 1011 my $event = shift;
670 my $callbacks = shift; 1012 my $callbacks = shift;
671 1013
672 @invoke_results = (); 1014 @INVOKE_RESULTS = ();
673 1015
674 local $override; 1016 local $override;
675 1017
676 for (@$callbacks) { 1018 for (@$callbacks) {
677 eval { &{$_->[1]} }; 1019 eval { &{$_->[1]} };
686 } 1028 }
687 1029
688 0 1030 0
689} 1031}
690 1032
691=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 1033=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
692 1034
693=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 1035=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
694 1036
695Generate an object-specific event with the given arguments. 1037Generate an object-specific event with the given arguments.
696 1038
697This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be 1039This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
698removed in future versions), and there is no public API to access override 1040removed in future versions), and there is no public API to access override
699results (if you must, access C<@cf::invoke_results> directly). 1041results (if you must, access C<@cf::INVOKE_RESULTS> directly).
700 1042
701=back 1043=back
702 1044
703=cut 1045=cut
704 1046
705############################################################################# 1047#############################################################################
706# object support 1048# object support
1049
1050sub _object_equal($$);
1051sub _object_equal($$) {
1052 my ($a, $b) = @_;
1053
1054 return 0 unless (ref $a) eq (ref $b);
1055
1056 if ("HASH" eq ref $a) {
1057 my @ka = keys %$a;
1058 my @kb = keys %$b;
1059
1060 return 0 if @ka != @kb;
1061
1062 for (0 .. $#ka) {
1063 return 0 unless $ka[$_] eq $kb[$_];
1064 return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
1065 }
1066
1067 } elsif ("ARRAY" eq ref $a) {
1068
1069 return 0 if @$a != @$b;
1070
1071 for (0 .. $#$a) {
1072 return 0 unless _object_equal $a->[$_], $b->[$_];
1073 }
1074
1075 } elsif ($a ne $b) {
1076 return 0;
1077 }
1078
1079 1
1080}
1081
1082our $SLOW_MERGES;#d#
1083sub _can_merge {
1084 my ($ob1, $ob2) = @_;
1085
1086 ++$SLOW_MERGES;#d#
1087
1088 # we do the slow way here
1089 return _object_equal $ob1, $ob2
1090}
707 1091
708sub reattach { 1092sub reattach {
709 # basically do the same as instantiate, without calling instantiate 1093 # basically do the same as instantiate, without calling instantiate
710 my ($obj) = @_; 1094 my ($obj) = @_;
711 1095
1096 # no longer needed after getting rid of delete_package?
712 bless $obj, ref $obj; # re-bless in case extensions have been reloaded 1097 #bless $obj, ref $obj; # re-bless in case extensions have been reloaded
713 1098
714 my $registry = $obj->registry; 1099 my $registry = $obj->registry;
715 1100
716 @$registry = (); 1101 @$registry = ();
717 1102
732cf::attachable->attach ( 1117cf::attachable->attach (
733 prio => -1000000, 1118 prio => -1000000,
734 on_instantiate => sub { 1119 on_instantiate => sub {
735 my ($obj, $data) = @_; 1120 my ($obj, $data) = @_;
736 1121
737 $data = from_json $data; 1122 $data = decode_json $data;
738 1123
739 for (@$data) { 1124 for (@$data) {
740 my ($name, $args) = @$_; 1125 my ($name, $args) = @$_;
741 1126
742 $obj->attach ($name, %{$args || {} }); 1127 $obj->attach ($name, %{$args || {} });
758sub object_freezer_save { 1143sub object_freezer_save {
759 my ($filename, $rdata, $objs) = @_; 1144 my ($filename, $rdata, $objs) = @_;
760 1145
761 sync_job { 1146 sync_job {
762 if (length $$rdata) { 1147 if (length $$rdata) {
1148 utf8::decode (my $decname = $filename);
763 warn sprintf "saving %s (%d,%d)\n", 1149 warn sprintf "saving %s (%d,%d)\n",
764 $filename, length $$rdata, scalar @$objs; 1150 $decname, length $$rdata, scalar @$objs;
765 1151
766 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1152 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
767 chmod SAVE_MODE, $fh; 1153 aio_chmod $fh, SAVE_MODE;
768 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1154 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
769 aio_fsync $fh if $cf::USE_FSYNC; 1155 aio_fsync $fh if $cf::USE_FSYNC;
770 close $fh; 1156 aio_close $fh;
771 1157
772 if (@$objs) { 1158 if (@$objs) {
773 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1159 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
774 chmod SAVE_MODE, $fh; 1160 aio_chmod $fh, SAVE_MODE;
775 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1161 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
776 aio_write $fh, 0, (length $data), $data, 0; 1162 aio_write $fh, 0, (length $data), $data, 0;
777 aio_fsync $fh if $cf::USE_FSYNC; 1163 aio_fsync $fh if $cf::USE_FSYNC;
778 close $fh; 1164 aio_close $fh;
779 aio_rename "$filename.pst~", "$filename.pst"; 1165 aio_rename "$filename.pst~", "$filename.pst";
780 } 1166 }
781 } else { 1167 } else {
782 aio_unlink "$filename.pst"; 1168 aio_unlink "$filename.pst";
783 } 1169 }
788 } 1174 }
789 } else { 1175 } else {
790 aio_unlink $filename; 1176 aio_unlink $filename;
791 aio_unlink "$filename.pst"; 1177 aio_unlink "$filename.pst";
792 } 1178 }
793 } 1179 };
794} 1180}
795 1181
796sub object_freezer_as_string { 1182sub object_freezer_as_string {
797 my ($rdata, $objs) = @_; 1183 my ($rdata, $objs) = @_;
798 1184
810 or return; 1196 or return;
811 1197
812 unless (aio_stat "$filename.pst") { 1198 unless (aio_stat "$filename.pst") {
813 (aio_load "$filename.pst", $av) >= 0 1199 (aio_load "$filename.pst", $av) >= 0
814 or return; 1200 or return;
1201
815 $av = eval { (Storable::thaw $av)->{objs} }; 1202 my $st = eval { Coro::Storable::thaw $av };
1203 $av = $st->{objs};
816 } 1204 }
817 1205
1206 utf8::decode (my $decname = $filename);
818 warn sprintf "loading %s (%d)\n", 1207 warn sprintf "loading %s (%d,%d)\n",
819 $filename, length $data, scalar @{$av || []};#d# 1208 $decname, length $data, scalar @{$av || []};
1209
820 return ($data, $av); 1210 ($data, $av)
821} 1211}
1212
1213=head2 COMMAND CALLBACKS
1214
1215=over 4
1216
1217=cut
822 1218
823############################################################################# 1219#############################################################################
824# command handling &c 1220# command handling &c
825 1221
826=item cf::register_command $name => \&callback($ob,$args); 1222=item cf::register_command $name => \&callback($ob,$args);
839 push @{ $COMMAND{$name} }, [$caller, $cb]; 1235 push @{ $COMMAND{$name} }, [$caller, $cb];
840} 1236}
841 1237
842=item cf::register_extcmd $name => \&callback($pl,$packet); 1238=item cf::register_extcmd $name => \&callback($pl,$packet);
843 1239
844Register a callbackf ro execution when the client sends an extcmd packet. 1240Register a callback for execution when the client sends an (synchronous)
1241extcmd packet. Ext commands will be processed in the order they are
1242received by the server, like other user commands. The first argument is
1243the logged-in player. Ext commands can only be processed after a player
1244has logged in successfully.
845 1245
846If the callback returns something, it is sent back as if reply was being 1246If the callback returns something, it is sent back as if reply was being
847called. 1247called.
848 1248
1249=item cf::register_exticmd $name => \&callback($ns,$packet);
1250
1251Register a callback for execution when the client sends an (asynchronous)
1252exticmd packet. Exti commands are processed by the server as soon as they
1253are received, i.e. out of order w.r.t. other commands. The first argument
1254is a client socket. Exti commands can be received anytime, even before
1255log-in.
1256
1257If the callback returns something, it is sent back as if reply was being
1258called.
1259
849=cut 1260=cut
850 1261
851sub register_extcmd { 1262sub register_extcmd {
852 my ($name, $cb) = @_; 1263 my ($name, $cb) = @_;
853 1264
854 $EXTCMD{$name} = $cb; 1265 $EXTCMD{$name} = $cb;
1266}
1267
1268sub register_exticmd {
1269 my ($name, $cb) = @_;
1270
1271 $EXTICMD{$name} = $cb;
855} 1272}
856 1273
857cf::player->attach ( 1274cf::player->attach (
858 on_command => sub { 1275 on_command => sub {
859 my ($pl, $name, $params) = @_; 1276 my ($pl, $name, $params) = @_;
868 cf::override; 1285 cf::override;
869 }, 1286 },
870 on_extcmd => sub { 1287 on_extcmd => sub {
871 my ($pl, $buf) = @_; 1288 my ($pl, $buf) = @_;
872 1289
873 my $msg = eval { from_json $buf }; 1290 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
874 1291
875 if (ref $msg) { 1292 if (ref $msg) {
1293 my ($type, $reply, @payload) =
1294 "ARRAY" eq ref $msg
1295 ? @$msg
1296 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1297
1298 my @reply;
1299
876 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1300 if (my $cb = $EXTCMD{$type}) {
877 if (my %reply = $cb->($pl, $msg)) { 1301 @reply = $cb->($pl, @payload);
878 $pl->ext_reply ($msg->{msgid}, %reply);
879 }
880 } 1302 }
1303
1304 $pl->ext_reply ($reply, @reply)
1305 if $reply;
1306
881 } else { 1307 } else {
882 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1308 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
883 } 1309 }
884 1310
885 cf::override; 1311 cf::override;
886 }, 1312 },
887); 1313);
888 1314
889sub load_extension {
890 my ($path) = @_;
891
892 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
893 my $base = $1;
894 my $pkg = $1;
895 $pkg =~ s/[^[:word:]]/_/g;
896 $pkg = "ext::$pkg";
897
898 warn "... loading '$path' into '$pkg'\n";
899
900 open my $fh, "<:utf8", $path
901 or die "$path: $!";
902
903 my $source =
904 "package $pkg; use strict; use utf8;\n"
905 . "#line 1 \"$path\"\n{\n"
906 . (do { local $/; <$fh> })
907 . "\n};\n1";
908
909 unless (eval $source) {
910 my $msg = $@ ? "$path: $@\n"
911 : "extension disabled.\n";
912 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
913 warn $@;
914 warn "mandatory extension failed to load, exiting.\n";
915 exit 1;
916 }
917 die $@;
918 }
919
920 push @EXTS, $pkg;
921}
922
923sub load_extensions { 1315sub load_extensions {
1316 cf::sync_job {
1317 my %todo;
1318
924 for my $ext (<$LIBDIR/*.ext>) { 1319 for my $path (<$LIBDIR/*.ext>) {
925 next unless -r $ext; 1320 next unless -r $path;
926 eval { 1321
927 load_extension $ext; 1322 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1323 my $base = $1;
1324 my $pkg = $1;
1325 $pkg =~ s/[^[:word:]]/_/g;
1326 $pkg = "ext::$pkg";
1327
1328 open my $fh, "<:utf8", $path
1329 or die "$path: $!";
1330
1331 my $source = do { local $/; <$fh> };
1332
1333 my %ext = (
1334 path => $path,
1335 base => $base,
1336 pkg => $pkg,
1337 );
1338
1339 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1340 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1341
1342 $ext{source} =
1343 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n"
1344 . "#line 1 \"$path\"\n{\n"
1345 . $source
1346 . "\n};\n1";
1347
1348 $todo{$base} = \%ext;
1349 }
1350
1351 my %done;
1352 while (%todo) {
1353 my $progress;
1354
1355 while (my ($k, $v) = each %todo) {
1356 for (split /,\s*/, $v->{meta}{depends}) {
1357 goto skip
1358 unless exists $done{$_};
1359 }
1360
1361 warn "... loading '$k' into '$v->{pkg}'\n";
1362
1363 unless (eval $v->{source}) {
1364 my $msg = $@ ? "$v->{path}: $@\n"
1365 : "$v->{base}: extension inactive.\n";
1366
1367 if (exists $v->{meta}{mandatory}) {
1368 warn $msg;
1369 cf::cleanup "mandatory extension failed to load, exiting.";
1370 }
1371
1372 warn $msg;
1373 }
1374
1375 $done{$k} = delete $todo{$k};
1376 push @EXTS, $v->{pkg};
1377 $progress = 1;
928 1 1378 }
929 } or warn "$ext not loaded: $@"; 1379
1380 skip:
1381 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1382 unless $progress;
1383 }
930 } 1384 };
931} 1385}
932 1386
933############################################################################# 1387#############################################################################
934 1388
1389=back
1390
935=head2 CORE EXTENSIONS 1391=head2 CORE EXTENSIONS
936 1392
937Functions and methods that extend core crossfire objects. 1393Functions and methods that extend core deliantra objects.
938 1394
939=cut 1395=cut
940 1396
941package cf::player; 1397package cf::player;
942 1398
944 1400
945=head3 cf::player 1401=head3 cf::player
946 1402
947=over 4 1403=over 4
948 1404
1405=item cf::player::num_playing
1406
1407Returns the official number of playing players, as per the Crossfire metaserver rules.
1408
1409=cut
1410
1411sub num_playing {
1412 scalar grep
1413 $_->ob->map
1414 && !$_->hidden
1415 && !$_->ob->flag (cf::FLAG_WIZ),
1416 cf::player::list
1417}
1418
949=item cf::player::find $login 1419=item cf::player::find $login
950 1420
951Returns the given player object, loading it if necessary (might block). 1421Returns the given player object, loading it if necessary (might block).
952 1422
953=cut 1423=cut
954 1424
955sub playerdir($) { 1425sub playerdir($) {
956 cf::localdir 1426 "$PLAYERDIR/"
957 . "/"
958 . cf::playerdir
959 . "/"
960 . (ref $_[0] ? $_[0]->ob->name : $_[0]) 1427 . (ref $_[0] ? $_[0]->ob->name : $_[0])
961} 1428}
962 1429
963sub path($) { 1430sub path($) {
964 my $login = ref $_[0] ? $_[0]->ob->name : $_[0]; 1431 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
965 1432
966 (playerdir $login) . "/$login.pl" 1433 (playerdir $login) . "/playerdata"
967} 1434}
968 1435
969sub find_active($) { 1436sub find_active($) {
970 $cf::PLAYER{$_[0]} 1437 $cf::PLAYER{$_[0]}
971 and $cf::PLAYER{$_[0]}->active 1438 and $cf::PLAYER{$_[0]}->active
984 my $login = $_[0]; 1451 my $login = $_[0];
985 1452
986 my $guard = cf::lock_acquire "user_find:$login"; 1453 my $guard = cf::lock_acquire "user_find:$login";
987 1454
988 $cf::PLAYER{$_[0]} || do { 1455 $cf::PLAYER{$_[0]} || do {
989 my $pl = load_pl path $login 1456 # rename old playerfiles to new ones
1457 #TODO: remove when no longer required
1458 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1459 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1460 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1461 aio_unlink +(playerdir $login) . "/$login.pl";
1462
1463 my $f = new_from_file cf::object::thawer path $login
990 or return; 1464 or return;
1465
1466 my $pl = cf::player::load_pl $f
1467 or return;
1468
1469 local $cf::PLAYER_LOADING{$login} = $pl;
1470 $f->resolve_delayed_derefs;
991 $cf::PLAYER{$login} = $pl 1471 $cf::PLAYER{$login} = $pl
992 } 1472 }
993 } 1473 }
994} 1474}
995 1475
1004 return if $pl->{deny_save}; 1484 return if $pl->{deny_save};
1005 1485
1006 aio_mkdir playerdir $pl, 0770; 1486 aio_mkdir playerdir $pl, 0770;
1007 $pl->{last_save} = $cf::RUNTIME; 1487 $pl->{last_save} = $cf::RUNTIME;
1008 1488
1489 cf::get_slot 0.01;
1490
1009 $pl->save_pl ($path); 1491 $pl->save_pl ($path);
1010 Coro::cede; 1492 cf::cede_to_tick;
1011} 1493}
1012 1494
1013sub new($) { 1495sub new($) {
1014 my ($login) = @_; 1496 my ($login) = @_;
1015 1497
1021 $cf::PLAYER{$login} = $self; 1503 $cf::PLAYER{$login} = $self;
1022 1504
1023 $self 1505 $self
1024} 1506}
1025 1507
1508=item $player->send_msg ($channel, $msg, $color, [extra...])
1509
1510=cut
1511
1512sub send_msg {
1513 my $ns = shift->ns
1514 or return;
1515 $ns->send_msg (@_);
1516}
1517
1026=item $pl->quit_character 1518=item $pl->quit_character
1027 1519
1028Nukes the player without looking back. If logged in, the connection will 1520Nukes the player without looking back. If logged in, the connection will
1029be destroyed. May block for a long time. 1521be destroyed. May block for a long time.
1030 1522
1034 my ($pl) = @_; 1526 my ($pl) = @_;
1035 1527
1036 my $name = $pl->ob->name; 1528 my $name = $pl->ob->name;
1037 1529
1038 $pl->{deny_save} = 1; 1530 $pl->{deny_save} = 1;
1039 $pl->password ("*"); # this should lock out the player until we nuked the dir 1531 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1040 1532
1041 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1533 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1042 $pl->deactivate; 1534 $pl->deactivate;
1535 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1536 $pl->ob->check_score;
1043 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1537 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1044 $pl->ns->destroy if $pl->ns; 1538 $pl->ns->destroy if $pl->ns;
1045 1539
1046 my $path = playerdir $pl; 1540 my $path = playerdir $pl;
1047 my $temp = "$path~$cf::RUNTIME~deleting~"; 1541 my $temp = "$path~$cf::RUNTIME~deleting~";
1077while and may block, so not sync_job-capable, ever. 1571while and may block, so not sync_job-capable, ever.
1078 1572
1079=cut 1573=cut
1080 1574
1081sub list_logins { 1575sub list_logins {
1082 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir 1576 my $dirs = aio_readdir $PLAYERDIR
1083 or return []; 1577 or return [];
1084 1578
1085 my @logins; 1579 my @logins;
1086 1580
1087 for my $login (@$dirs) { 1581 for my $login (@$dirs) {
1582 my $path = path $login;
1583
1584 # a .pst is a dead give-away for a valid player
1585 # if no pst file found, open and chekc for blocked users
1586 if (aio_stat "$path.pst") {
1088 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1587 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1089 aio_read $fh, 0, 512, my $buf, 0 or next; 1588 aio_read $fh, 0, 512, my $buf, 0 or next;
1090 $buf !~ /^password -------------$/m or next; # official not-valid tag 1589 $buf !~ /^password -------------$/m or next; # official not-valid tag
1590 }
1091 1591
1092 utf8::decode $login; 1592 utf8::decode $login;
1093 push @logins, $login; 1593 push @logins, $login;
1094 } 1594 }
1095 1595
1122 } 1622 }
1123 1623
1124 \@paths 1624 \@paths
1125} 1625}
1126 1626
1627=item $protocol_xml = $player->expand_cfpod ($cfpod)
1628
1629Expand deliantra pod fragments into protocol xml.
1630
1127=item $player->ext_reply ($msgid, $msgtype, %msg) 1631=item $player->ext_reply ($msgid, @msg)
1128 1632
1129Sends an ext reply to the player. 1633Sends an ext reply to the player.
1130 1634
1131=cut 1635=cut
1132 1636
1133sub ext_reply($$$%) { 1637sub ext_reply($$@) {
1134 my ($self, $id, %msg) = @_; 1638 my ($self, $id, @msg) = @_;
1135 1639
1136 $msg{msgid} = $id; 1640 $self->ns->ext_reply ($id, @msg)
1137
1138 $self->send ("ext " . cf::to_json \%msg);
1139} 1641}
1140 1642
1141package cf; 1643=item $player->ext_msg ($type, @msg)
1644
1645Sends an ext event to the client.
1646
1647=cut
1648
1649sub ext_msg($$@) {
1650 my ($self, $type, @msg) = @_;
1651
1652 $self->ns->ext_msg ($type, @msg);
1653}
1654
1655=head3 cf::region
1656
1657=over 4
1658
1659=cut
1660
1661package cf::region;
1662
1663=item cf::region::find_by_path $path
1664
1665Tries to decuce the likely region for a map knowing only its path.
1666
1667=cut
1668
1669sub find_by_path($) {
1670 my ($path) = @_;
1671
1672 my ($match, $specificity);
1673
1674 for my $region (list) {
1675 if ($region->{match} && $path =~ $region->{match}) {
1676 ($match, $specificity) = ($region, $region->specificity)
1677 if $region->specificity > $specificity;
1678 }
1679 }
1680
1681 $match
1682}
1142 1683
1143=back 1684=back
1144
1145 1685
1146=head3 cf::map 1686=head3 cf::map
1147 1687
1148=over 4 1688=over 4
1149 1689
1161our $MAX_RESET = 3600; 1701our $MAX_RESET = 3600;
1162our $DEFAULT_RESET = 3000; 1702our $DEFAULT_RESET = 3000;
1163 1703
1164sub generate_random_map { 1704sub generate_random_map {
1165 my ($self, $rmp) = @_; 1705 my ($self, $rmp) = @_;
1706
1707 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1708
1166 # mit "rum" bekleckern, nicht 1709 # mit "rum" bekleckern, nicht
1167 $self->_create_random_map ( 1710 $self->_create_random_map (
1168 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1711 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1169 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1712 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1170 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1713 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1204 my ($self, $merge) = @_; 1747 my ($self, $merge) = @_;
1205 1748
1206 # we have to keep some variables in memory intact 1749 # we have to keep some variables in memory intact
1207 local $self->{path}; 1750 local $self->{path};
1208 local $self->{load_path}; 1751 local $self->{load_path};
1209 local $self->{deny_save};
1210 local $self->{deny_reset};
1211 1752
1212 $self->SUPER::thawer_merge ($merge); 1753 $self->SUPER::thawer_merge ($merge);
1213} 1754}
1214 1755
1215sub normalise { 1756sub normalise {
1262 $self->init; # pass $1 etc. 1803 $self->init; # pass $1 etc.
1263 return $self; 1804 return $self;
1264 } 1805 }
1265 } 1806 }
1266 1807
1267 Carp::carp "unable to resolve path '$path' (base '$base')."; 1808 Carp::cluck "unable to resolve path '$path' (base '$base').";
1268 () 1809 ()
1269} 1810}
1270 1811
1271sub init { 1812sub init {
1272 my ($self) = @_; 1813 my ($self) = @_;
1287 1828
1288# the original (read-only) location 1829# the original (read-only) location
1289sub load_path { 1830sub load_path {
1290 my ($self) = @_; 1831 my ($self) = @_;
1291 1832
1292 sprintf "%s/%s/%s.map", cf::datadir, cf::mapdir, $self->{path} 1833 "$MAPDIR/$self->{path}.map"
1293} 1834}
1294 1835
1295# the temporary/swap location 1836# the temporary/swap location
1296sub save_path { 1837sub save_path {
1297 my ($self) = @_; 1838 my ($self) = @_;
1298 1839
1299 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1840 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1300 sprintf "%s/%s/%s.map", cf::localdir, cf::tmpdir, $path 1841 "$TMPDIR/$path.map"
1301} 1842}
1302 1843
1303# the unique path, undef == no special unique path 1844# the unique path, undef == no special unique path
1304sub uniq_path { 1845sub uniq_path {
1305 my ($self) = @_; 1846 my ($self) = @_;
1306 1847
1307 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1848 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1308 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $path 1849 "$UNIQUEDIR/$path"
1309} 1850}
1310 1851
1311# and all this just because we cannot iterate over 1852# and all this just because we cannot iterate over
1312# all maps in C++... 1853# all maps in C++...
1313sub change_all_map_light { 1854sub change_all_map_light {
1315 1856
1316 $_->change_map_light ($change) 1857 $_->change_map_light ($change)
1317 for grep $_->outdoor, values %cf::MAP; 1858 for grep $_->outdoor, values %cf::MAP;
1318} 1859}
1319 1860
1861sub decay_objects {
1862 my ($self) = @_;
1863
1864 return if $self->{deny_reset};
1865
1866 $self->do_decay_objects;
1867}
1868
1320sub unlink_save { 1869sub unlink_save {
1321 my ($self) = @_; 1870 my ($self) = @_;
1322 1871
1323 utf8::encode (my $save = $self->save_path); 1872 utf8::encode (my $save = $self->save_path);
1324 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save; 1873 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
1327 1876
1328sub load_header_from($) { 1877sub load_header_from($) {
1329 my ($self, $path) = @_; 1878 my ($self, $path) = @_;
1330 1879
1331 utf8::encode $path; 1880 utf8::encode $path;
1332 #aio_open $path, O_RDONLY, 0 1881 my $f = new_from_file cf::object::thawer $path
1333 # or return;
1334
1335 $self->_load_header ($path)
1336 or return; 1882 or return;
1883
1884 $self->_load_header ($f)
1885 or return;
1886
1887 local $MAP_LOADING{$self->{path}} = $self;
1888 $f->resolve_delayed_derefs;
1337 1889
1338 $self->{load_path} = $path; 1890 $self->{load_path} = $path;
1339 1891
1340 1 1892 1
1341} 1893}
1380 $self->load_header_orig 1932 $self->load_header_orig
1381 or return; 1933 or return;
1382 $self->prepare_orig; 1934 $self->prepare_orig;
1383 } 1935 }
1384 1936
1937 $self->{deny_reset} = 1
1938 if $self->no_reset;
1939
1940 $self->default_region (cf::region::find_by_path $self->{path})
1941 unless $self->default_region;
1942
1385 1 1943 1
1386} 1944}
1387 1945
1388sub find; 1946sub find;
1389sub find { 1947sub find {
1390 my ($path, $origin) = @_; 1948 my ($path, $origin) = @_;
1391 1949
1392 $path = normalise $path, $origin && $origin->path; 1950 $path = normalise $path, $origin && $origin->path;
1393 1951
1952 cf::lock_wait "map_data:$path";#d#remove
1394 cf::lock_wait "map_find:$path"; 1953 cf::lock_wait "map_find:$path";
1395 1954
1396 $cf::MAP{$path} || do { 1955 $cf::MAP{$path} || do {
1956 my $guard1 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1397 my $guard = cf::lock_acquire "map_find:$path"; 1957 my $guard2 = cf::lock_acquire "map_find:$path";
1958
1398 my $map = new_from_path cf::map $path 1959 my $map = new_from_path cf::map $path
1399 or return; 1960 or return;
1400 1961
1401 $map->{last_save} = $cf::RUNTIME; 1962 $map->{last_save} = $cf::RUNTIME;
1402 1963
1403 $map->load_header 1964 $map->load_header
1404 or return; 1965 or return;
1405 1966
1406 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?) 1967 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1407 # doing this can freeze the server in a sync job, obviously 1968 # doing this can freeze the server in a sync job, obviously
1408 #$cf::WAIT_FOR_TICK->wait; 1969 #$cf::WAIT_FOR_TICK->wait;
1970 undef $guard2;
1971 undef $guard1;
1409 $map->reset; 1972 $map->reset;
1410 undef $guard;
1411 return find $path; 1973 return find $path;
1412 } 1974 }
1413 1975
1414 $cf::MAP{$path} = $map 1976 $cf::MAP{$path} = $map
1415 } 1977 }
1422 my ($self) = @_; 1984 my ($self) = @_;
1423 1985
1424 local $self->{deny_reset} = 1; # loading can take a long time 1986 local $self->{deny_reset} = 1; # loading can take a long time
1425 1987
1426 my $path = $self->{path}; 1988 my $path = $self->{path};
1989
1990 {
1427 my $guard = cf::lock_acquire "map_load:$path"; 1991 my $guard = cf::lock_acquire "map_data:$path";
1428 1992
1993 return unless $self->valid;
1429 return if $self->in_memory != cf::MAP_SWAPPED; 1994 return unless $self->in_memory == cf::MAP_SWAPPED;
1430 1995
1431 $self->in_memory (cf::MAP_LOADING); 1996 $self->in_memory (cf::MAP_LOADING);
1432 1997
1433 $self->alloc; 1998 $self->alloc;
1434 1999
1435 $self->pre_load; 2000 $self->pre_load;
2001 cf::cede_to_tick;
1436 2002
1437 $self->_load_objects ($self->{load_path}, 1) 2003 my $f = new_from_file cf::object::thawer $self->{load_path};
2004 $f->skip_block;
2005 $self->_load_objects ($f)
1438 or return; 2006 or return;
1439 2007
1440 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2008 $self->post_load_original
1441 if delete $self->{load_original}; 2009 if delete $self->{load_original};
1442 2010
1443 if (my $uniq = $self->uniq_path) { 2011 if (my $uniq = $self->uniq_path) {
1444 utf8::encode $uniq; 2012 utf8::encode $uniq;
1445 if (aio_open $uniq, O_RDONLY, 0) { 2013 unless (aio_stat $uniq) {
2014 if (my $f = new_from_file cf::object::thawer $uniq) {
1446 $self->clear_unique_items; 2015 $self->clear_unique_items;
1447 $self->_load_objects ($uniq, 0); 2016 $self->_load_objects ($f);
2017 $f->resolve_delayed_derefs;
2018 }
1448 } 2019 }
1449 } 2020 }
1450 2021
1451 Coro::cede; 2022 $f->resolve_delayed_derefs;
1452 2023
2024 cf::cede_to_tick;
1453 # now do the right thing for maps 2025 # now do the right thing for maps
1454 $self->link_multipart_objects; 2026 $self->link_multipart_objects;
1455
1456 unless ($self->{deny_activate}) {
1457 $self->decay_objects;
1458 $self->fix_auto_apply;
1459 $self->update_buttons;
1460 Coro::cede;
1461 $self->set_darkness_map;
1462 $self->difficulty ($self->estimate_difficulty) 2027 $self->difficulty ($self->estimate_difficulty)
1463 unless $self->difficulty; 2028 unless $self->difficulty;
1464 Coro::cede; 2029 cf::cede_to_tick;
2030
2031 unless ($self->{deny_activate}) {
2032 $self->decay_objects;
2033 $self->fix_auto_apply;
2034 $self->update_buttons;
2035 cf::cede_to_tick;
2036 $self->set_darkness_map;
2037 cf::cede_to_tick;
1465 $self->activate; 2038 $self->activate;
2039 }
2040
2041 $self->{last_save} = $cf::RUNTIME;
2042 $self->last_access ($cf::RUNTIME);
2043
2044 $self->in_memory (cf::MAP_ACTIVE);
1466 } 2045 }
1467 2046
1468 $self->post_load; 2047 $self->post_load;
1469
1470 $self->in_memory (cf::MAP_IN_MEMORY);
1471} 2048}
1472 2049
1473sub customise_for { 2050sub customise_for {
1474 my ($self, $ob) = @_; 2051 my ($self, $ob) = @_;
1475 2052
1476 return find "~" . $ob->name . "/" . $self->{path} 2053 return find "~" . $ob->name . "/" . $self->{path}
1477 if $self->per_player; 2054 if $self->per_player;
1478 2055
2056# return find "?party/" . $ob->name . "/" . $self->{path}
2057# if $self->per_party;
2058
1479 $self 2059 $self
1480} 2060}
1481 2061
1482# find and load all maps in the 3x3 area around a map 2062# find and load all maps in the 3x3 area around a map
1483sub load_diag { 2063sub load_neighbours {
1484 my ($map) = @_; 2064 my ($map) = @_;
1485 2065
1486 my @diag; # diagonal neighbours 2066 my @neigh; # diagonal neighbours
1487 2067
1488 for (0 .. 3) { 2068 for (0 .. 3) {
1489 my $neigh = $map->tile_path ($_) 2069 my $neigh = $map->tile_path ($_)
1490 or next; 2070 or next;
1491 $neigh = find $neigh, $map 2071 $neigh = find $neigh, $map
1492 or next; 2072 or next;
1493 $neigh->load; 2073 $neigh->load;
1494 2074
2075 push @neigh,
1495 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 2076 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1496 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2077 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1497 } 2078 }
1498 2079
1499 for (@diag) { 2080 for (grep defined $_->[0], @neigh) {
2081 my ($path, $origin) = @$_;
1500 my $neigh = find @$_ 2082 my $neigh = find $path, $origin
1501 or next; 2083 or next;
1502 $neigh->load; 2084 $neigh->load;
1503 } 2085 }
1504} 2086}
1505 2087
1510} 2092}
1511 2093
1512sub do_load_sync { 2094sub do_load_sync {
1513 my ($map) = @_; 2095 my ($map) = @_;
1514 2096
2097 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
2098 if $Coro::current == $Coro::main;
2099
1515 cf::sync_job { $map->load }; 2100 cf::sync_job { $map->load };
1516} 2101}
1517 2102
1518our %MAP_PREFETCH; 2103our %MAP_PREFETCH;
1519our $MAP_PREFETCHER = undef; 2104our $MAP_PREFETCHER = undef;
1520 2105
1521sub find_async { 2106sub find_async {
1522 my ($path, $origin) = @_; 2107 my ($path, $origin, $load) = @_;
1523 2108
1524 $path = normalise $path, $origin && $origin->{path}; 2109 $path = normalise $path, $origin && $origin->{path};
1525 2110
1526 if (my $map = $cf::MAP{$path}) { 2111 if (my $map = $cf::MAP{$path}) {
1527 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 2112 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
1528 } 2113 }
1529 2114
1530 undef $MAP_PREFETCH{$path}; 2115 $MAP_PREFETCH{$path} |= $load;
2116
1531 $MAP_PREFETCHER ||= cf::async { 2117 $MAP_PREFETCHER ||= cf::async {
2118 $Coro::current->{desc} = "map prefetcher";
2119
1532 while (%MAP_PREFETCH) { 2120 while (%MAP_PREFETCH) {
1533 for my $path (keys %MAP_PREFETCH) { 2121 while (my ($k, $v) = each %MAP_PREFETCH) {
1534 my $map = find $path 2122 if (my $map = find $k) {
1535 or next;
1536 $map->load; 2123 $map->load if $v;
2124 }
1537 2125
1538 delete $MAP_PREFETCH{$path}; 2126 delete $MAP_PREFETCH{$k};
1539 } 2127 }
1540 } 2128 }
1541 undef $MAP_PREFETCHER; 2129 undef $MAP_PREFETCHER;
1542 }; 2130 };
1543 $MAP_PREFETCHER->prio (6); 2131 $MAP_PREFETCHER->prio (6);
1546} 2134}
1547 2135
1548sub save { 2136sub save {
1549 my ($self) = @_; 2137 my ($self) = @_;
1550 2138
1551 my $lock = cf::lock_acquire "map_data:" . $self->path; 2139 my $lock = cf::lock_acquire "map_data:$self->{path}";
1552 2140
1553 $self->{last_save} = $cf::RUNTIME; 2141 $self->{last_save} = $cf::RUNTIME;
1554 2142
1555 return unless $self->dirty; 2143 return unless $self->dirty;
1556 2144
1562 return if $self->{deny_save}; 2150 return if $self->{deny_save};
1563 2151
1564 local $self->{last_access} = $self->last_access;#d# 2152 local $self->{last_access} = $self->last_access;#d#
1565 2153
1566 cf::async { 2154 cf::async {
2155 $Coro::current->{desc} = "map player save";
1567 $_->contr->save for $self->players; 2156 $_->contr->save for $self->players;
1568 }; 2157 };
2158
2159 cf::get_slot 0.02;
1569 2160
1570 if ($uniq) { 2161 if ($uniq) {
1571 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2162 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1572 $self->_save_objects ($uniq, cf::IO_UNIQUES); 2163 $self->_save_objects ($uniq, cf::IO_UNIQUES);
1573 } else { 2164 } else {
1579 my ($self) = @_; 2170 my ($self) = @_;
1580 2171
1581 # save first because save cedes 2172 # save first because save cedes
1582 $self->save; 2173 $self->save;
1583 2174
1584 my $lock = cf::lock_acquire "map_data:" . $self->path; 2175 my $lock = cf::lock_acquire "map_data:$self->{path}";
1585 2176
1586 return if $self->players; 2177 return if $self->players;
1587 return if $self->in_memory != cf::MAP_IN_MEMORY; 2178 return if $self->in_memory != cf::MAP_ACTIVE;
1588 return if $self->{deny_save}; 2179 return if $self->{deny_save};
1589 2180
2181 $self->in_memory (cf::MAP_SWAPPED);
2182
2183 $self->deactivate;
2184 $_->clear_links_to ($self) for values %cf::MAP;
1590 $self->clear; 2185 $self->clear;
1591 $self->in_memory (cf::MAP_SWAPPED);
1592} 2186}
1593 2187
1594sub reset_at { 2188sub reset_at {
1595 my ($self) = @_; 2189 my ($self) = @_;
1596 2190
1597 # TODO: safety, remove and allow resettable per-player maps 2191 # TODO: safety, remove and allow resettable per-player maps
1598 return 1e99 if $self->isa ("ext::map_per_player");#d#
1599 return 1e99 if $self->{deny_reset}; 2192 return 1e99 if $self->{deny_reset};
1600 2193
1601 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 2194 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1602 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 2195 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1603 2196
1614 my ($self) = @_; 2207 my ($self) = @_;
1615 2208
1616 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2209 my $lock = cf::lock_acquire "map_data:$self->{path}";
1617 2210
1618 return if $self->players; 2211 return if $self->players;
1619 return if $self->isa ("ext::map_per_player");#d#
1620 2212
1621 warn "resetting map ", $self->path;#d# 2213 warn "resetting map ", $self->path;
1622 2214
1623 $self->in_memory (cf::MAP_SWAPPED); 2215 $self->in_memory (cf::MAP_SWAPPED);
1624 2216
1625 # need to save uniques path 2217 # need to save uniques path
1626 unless ($self->{deny_save}) { 2218 unless ($self->{deny_save}) {
1630 if $uniq; 2222 if $uniq;
1631 } 2223 }
1632 2224
1633 delete $cf::MAP{$self->path}; 2225 delete $cf::MAP{$self->path};
1634 2226
2227 $self->deactivate;
2228 $_->clear_links_to ($self) for values %cf::MAP;
1635 $self->clear; 2229 $self->clear;
1636
1637 $_->clear_links_to ($self) for values %cf::MAP;
1638 2230
1639 $self->unlink_save; 2231 $self->unlink_save;
1640 $self->destroy; 2232 $self->destroy;
1641} 2233}
1642 2234
1643my $nuke_counter = "aaaa"; 2235my $nuke_counter = "aaaa";
1644 2236
1645sub nuke { 2237sub nuke {
1646 my ($self) = @_; 2238 my ($self) = @_;
1647 2239
2240 {
2241 my $lock = cf::lock_acquire "map_data:$self->{path}";
2242
1648 delete $cf::MAP{$self->path}; 2243 delete $cf::MAP{$self->path};
1649 2244
1650 $self->unlink_save; 2245 $self->unlink_save;
1651 2246
1652 bless $self, "cf::map"; 2247 bless $self, "cf::map";
1653 delete $self->{deny_reset}; 2248 delete $self->{deny_reset};
1654 $self->{deny_save} = 1; 2249 $self->{deny_save} = 1;
1655 $self->reset_timeout (1); 2250 $self->reset_timeout (1);
1656 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2251 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1657 2252
1658 $cf::MAP{$self->path} = $self; 2253 $cf::MAP{$self->path} = $self;
2254 }
1659 2255
1660 $self->reset; # polite request, might not happen 2256 $self->reset; # polite request, might not happen
2257}
2258
2259=item $maps = cf::map::tmp_maps
2260
2261Returns an arrayref with all map paths of currently instantiated and saved
2262maps. May block.
2263
2264=cut
2265
2266sub tmp_maps() {
2267 [
2268 map {
2269 utf8::decode $_;
2270 /\.map$/
2271 ? normalise $_
2272 : ()
2273 } @{ aio_readdir $TMPDIR or [] }
2274 ]
2275}
2276
2277=item $maps = cf::map::random_maps
2278
2279Returns an arrayref with all map paths of currently instantiated and saved
2280random maps. May block.
2281
2282=cut
2283
2284sub random_maps() {
2285 [
2286 map {
2287 utf8::decode $_;
2288 /\.map$/
2289 ? normalise "?random/$_"
2290 : ()
2291 } @{ aio_readdir $RANDOMDIR or [] }
2292 ]
1661} 2293}
1662 2294
1663=item cf::map::unique_maps 2295=item cf::map::unique_maps
1664 2296
1665Returns an arrayref of paths of all shared maps that have 2297Returns an arrayref of paths of all shared maps that have
1666instantiated unique items. May block. 2298instantiated unique items. May block.
1667 2299
1668=cut 2300=cut
1669 2301
1670sub unique_maps() { 2302sub unique_maps() {
1671 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir 2303 [
1672 or return; 2304 map {
1673
1674 my @paths;
1675
1676 for (@$files) {
1677 utf8::decode $_; 2305 utf8::decode $_;
1678 next if /\.pst$/; 2306 s/\.map$//; # TODO future compatibility hack
1679 next unless /^$PATH_SEP/o; 2307 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
1680 2308 ? ()
1681 push @paths, cf::map::normalise $_; 2309 : normalise $_
2310 } @{ aio_readdir $UNIQUEDIR or [] }
1682 } 2311 ]
1683
1684 \@paths
1685} 2312}
1686
1687package cf;
1688 2313
1689=back 2314=back
1690 2315
1691=head3 cf::object 2316=head3 cf::object
1692 2317
1696 2321
1697=over 4 2322=over 4
1698 2323
1699=item $ob->inv_recursive 2324=item $ob->inv_recursive
1700 2325
1701Returns the inventory of the object _and_ their inventories, recursively. 2326Returns the inventory of the object I<and> their inventories, recursively,
2327but I<not> the object itself.
1702 2328
1703=cut 2329=cut
1704 2330
1705sub inv_recursive_; 2331sub inv_recursive_;
1706sub inv_recursive_ { 2332sub inv_recursive_ {
1709 2335
1710sub inv_recursive { 2336sub inv_recursive {
1711 inv_recursive_ inv $_[0] 2337 inv_recursive_ inv $_[0]
1712} 2338}
1713 2339
2340=item $ref = $ob->ref
2341
2342Creates and returns a persistent reference to an object that can be stored as a string.
2343
2344=item $ob = cf::object::deref ($refstring)
2345
2346returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2347even if the object actually exists. May block.
2348
2349=cut
2350
2351sub deref {
2352 my ($ref) = @_;
2353
2354 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2355 my ($uuid, $name) = ($1, $2);
2356 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2357 or return;
2358 $pl->ob->uuid eq $uuid
2359 or return;
2360
2361 $pl->ob
2362 } else {
2363 warn "$ref: cannot resolve object reference\n";
2364 undef
2365 }
2366}
2367
1714package cf; 2368package cf;
1715 2369
1716=back 2370=back
1717 2371
1718=head3 cf::object::player 2372=head3 cf::object::player
1724Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 2378Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
1725can be C<undef>. Does the right thing when the player is currently in a 2379can be C<undef>. Does the right thing when the player is currently in a
1726dialogue with the given NPC character. 2380dialogue with the given NPC character.
1727 2381
1728=cut 2382=cut
2383
2384our $SAY_CHANNEL = {
2385 id => "say",
2386 title => "Map",
2387 reply => "say ",
2388 tooltip => "Things said to and replied from npcs near you and other players on the same map only.",
2389};
2390
2391our $CHAT_CHANNEL = {
2392 id => "chat",
2393 title => "Chat",
2394 reply => "chat ",
2395 tooltip => "Player chat and shouts, global to the server.",
2396};
1729 2397
1730# rough implementation of a future "reply" method that works 2398# rough implementation of a future "reply" method that works
1731# with dialog boxes. 2399# with dialog boxes.
1732#TODO: the first argument must go, split into a $npc->reply_to ( method 2400#TODO: the first argument must go, split into a $npc->reply_to ( method
1733sub cf::object::player::reply($$$;$) { 2401sub cf::object::player::reply($$$;$) {
1735 2403
1736 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2404 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1737 2405
1738 if ($self->{record_replies}) { 2406 if ($self->{record_replies}) {
1739 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2407 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2408
1740 } else { 2409 } else {
2410 my $pl = $self->contr;
2411
2412 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2413 my $dialog = $pl->{npc_dialog};
2414 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2415
2416 } else {
1741 $msg = $npc->name . " says: $msg" if $npc; 2417 $msg = $npc->name . " says: $msg" if $npc;
1742 $self->message ($msg, $flags); 2418 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2419 }
1743 } 2420 }
2421}
2422
2423=item $object->send_msg ($channel, $msg, $color, [extra...])
2424
2425=cut
2426
2427sub cf::object::send_msg {
2428 my $pl = shift->contr
2429 or return;
2430 $pl->send_msg (@_);
1744} 2431}
1745 2432
1746=item $player_object->may ("access") 2433=item $player_object->may ("access")
1747 2434
1748Returns wether the given player is authorized to access resource "access" 2435Returns wether the given player is authorized to access resource "access"
1761 2448
1762=item $player_object->enter_link 2449=item $player_object->enter_link
1763 2450
1764Freezes the player and moves him/her to a special map (C<{link}>). 2451Freezes the player and moves him/her to a special map (C<{link}>).
1765 2452
1766The player should be reasonably safe there for short amounts of time. You 2453The player should be reasonably safe there for short amounts of time (e.g.
1767I<MUST> call C<leave_link> as soon as possible, though. 2454for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2455though, as the palyer cannot control the character while it is on the link
2456map.
1768 2457
1769Will never block. 2458Will never block.
1770 2459
1771=item $player_object->leave_link ($map, $x, $y) 2460=item $player_object->leave_link ($map, $x, $y)
1772 2461
1795 $self->deactivate_recursive; 2484 $self->deactivate_recursive;
1796 2485
1797 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2486 return if UNIVERSAL::isa $self->map, "ext::map_link";
1798 2487
1799 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2488 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1800 if $self->map; 2489 if $self->map && $self->map->{path} ne "{link}";
1801 2490
1802 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2491 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1803} 2492}
1804 2493
1805sub cf::object::player::leave_link { 2494sub cf::object::player::leave_link {
1806 my ($self, $map, $x, $y) = @_; 2495 my ($self, $map, $x, $y) = @_;
2496
2497 return unless $self->contr->active;
1807 2498
1808 my $link_pos = delete $self->{_link_pos}; 2499 my $link_pos = delete $self->{_link_pos};
1809 2500
1810 unless ($map) { 2501 unless ($map) {
1811 # restore original map position 2502 # restore original map position
1825 # use -1 or undef as default coordinates, not 0, 0 2516 # use -1 or undef as default coordinates, not 0, 0
1826 ($x, $y) = ($map->enter_x, $map->enter_y) 2517 ($x, $y) = ($map->enter_x, $map->enter_y)
1827 if $x <=0 && $y <= 0; 2518 if $x <=0 && $y <= 0;
1828 2519
1829 $map->load; 2520 $map->load;
1830 $map->load_diag; 2521 $map->load_neighbours;
1831 2522
1832 return unless $self->contr->active; 2523 return unless $self->contr->active;
2524 $self->flag (cf::FLAG_DEBUG, 0);#d# temp
1833 $self->activate_recursive; 2525 $self->activate_recursive;
1834 2526
1835 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2527 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1836 $self->enter_map ($map, $x, $y); 2528 $self->enter_map ($map, $x, $y);
1837} 2529}
1838 2530
1839cf::player->attach ( 2531=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
1840 on_logout => sub {
1841 my ($pl) = @_;
1842 2532
1843 # abort map switching before logout 2533Moves the player to the given map-path and coordinates by first freezing
1844 if ($pl->ob->{_link_pos}) { 2534her, loading and preparing them map, calling the provided $check callback
1845 cf::sync_job { 2535that has to return the map if sucecssful, and then unfreezes the player on
1846 $pl->ob->leave_link 2536the new (success) or old (failed) map position. In either case, $done will
1847 }; 2537be called at the end of this process.
1848 }
1849 },
1850 on_login => sub {
1851 my ($pl) = @_;
1852 2538
1853 # try to abort aborted map switching on player login :) 2539Note that $check will be called with a potentially non-loaded map, so if
1854 # should happen only on crashes 2540it needs a loaded map it has to call C<< ->load >>.
1855 if ($pl->ob->{_link_pos}) {
1856 $pl->ob->enter_link;
1857 (async {
1858 $pl->ob->reply (undef,
1859 "There was an internal problem at your last logout, "
1860 . "the server will try to bring you to your intended destination in a second.",
1861 cf::NDI_RED);
1862 # we need this sleep as the login has a concurrent enter_exit running
1863 # and this sleep increases chances of the player not ending up in scorn
1864 Coro::Timer::sleep 1;
1865 $pl->ob->leave_link;
1866 })->prio (2);
1867 }
1868 },
1869);
1870 2541
1871=item $player_object->goto ($path, $x, $y)
1872
1873=cut 2542=cut
2543
2544our $GOTOGEN;
1874 2545
1875sub cf::object::player::goto { 2546sub cf::object::player::goto {
1876 my ($self, $path, $x, $y) = @_; 2547 my ($self, $path, $x, $y, $check, $done) = @_;
2548
2549 # do generation counting so two concurrent goto's will be executed in-order
2550 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1877 2551
1878 $self->enter_link; 2552 $self->enter_link;
1879 2553
1880 (async { 2554 (async {
2555 $Coro::current->{desc} = "player::goto $path $x $y";
2556
2557 # *tag paths override both path and x|y
2558 if ($path =~ /^\*(.*)$/) {
2559 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2560 my $ob = $obs[rand @obs];
2561
2562 # see if we actually can go there
2563 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2564 $ob = $obs[rand @obs];
2565 } else {
2566 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2567 }
2568 # else put us there anyways for now #d#
2569
2570 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2571 } else {
2572 ($path, $x, $y) = (undef, undef, undef);
2573 }
2574 }
2575
1881 my $map = eval { 2576 my $map = eval {
1882 my $map = cf::map::find $path; 2577 my $map = defined $path ? cf::map::find $path : undef;
2578
2579 if ($map) {
1883 $map = $map->customise_for ($self) if $map; 2580 $map = $map->customise_for ($self);
2581 $map = $check->($map) if $check && $map;
2582 } else {
2583 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2584 }
2585
1884 $map 2586 $map
2587 };
2588
2589 if ($@) {
2590 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2591 LOG llevError | logBacktrace, Carp::longmess $@;
1885 } or 2592 }
1886 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1887 2593
2594 if ($gen == $self->{_goto_generation}) {
2595 delete $self->{_goto_generation};
1888 $self->leave_link ($map, $x, $y); 2596 $self->leave_link ($map, $x, $y);
2597 }
2598
2599 $done->() if $done;
1889 })->prio (1); 2600 })->prio (1);
1890} 2601}
1891 2602
1892=item $player_object->enter_exit ($exit_object) 2603=item $player_object->enter_exit ($exit_object)
1893 2604
1913} 2624}
1914 2625
1915sub prepare_random_map { 2626sub prepare_random_map {
1916 my ($exit) = @_; 2627 my ($exit) = @_;
1917 2628
1918 my $guard = cf::lock_acquire "exit_prepare:$exit";
1919
1920 # all this does is basically replace the /! path by 2629 # all this does is basically replace the /! path by
1921 # a new random map path (?random/...) with a seed 2630 # a new random map path (?random/...) with a seed
1922 # that depends on the exit object 2631 # that depends on the exit object
1923 2632
1924 my $rmp = parse_random_map_params $exit->msg; 2633 my $rmp = parse_random_map_params $exit->msg;
1926 if ($exit->map) { 2635 if ($exit->map) {
1927 $rmp->{region} = $exit->region->name; 2636 $rmp->{region} = $exit->region->name;
1928 $rmp->{origin_map} = $exit->map->path; 2637 $rmp->{origin_map} = $exit->map->path;
1929 $rmp->{origin_x} = $exit->x; 2638 $rmp->{origin_x} = $exit->x;
1930 $rmp->{origin_y} = $exit->y; 2639 $rmp->{origin_y} = $exit->y;
2640
2641 $exit->map->touch;
1931 } 2642 }
1932 2643
1933 $rmp->{random_seed} ||= $exit->random_seed; 2644 $rmp->{random_seed} ||= $exit->random_seed;
1934 2645
1935 my $data = cf::to_json $rmp; 2646 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
1936 my $md5 = Digest::MD5::md5_hex $data; 2647 my $md5 = Digest::MD5::md5_hex $data;
1937 my $meta = "$cf::RANDOM_MAPS/$md5.meta"; 2648 my $meta = "$RANDOMDIR/$md5.meta";
1938 2649
1939 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2650 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1940 aio_write $fh, 0, (length $data), $data, 0; 2651 aio_write $fh, 0, (length $data), $data, 0;
1941 undef $fh; 2652 undef $fh;
1942 aio_rename "$meta~", $meta; 2653 aio_rename "$meta~", $meta;
1943 2654
2655 my $slaying = "?random/$md5";
2656
2657 if ($exit->valid) {
1944 $exit->slaying ("?random/$md5"); 2658 $exit->slaying ("?random/$md5");
1945 $exit->msg (undef); 2659 $exit->msg (undef);
2660 }
1946 } 2661 }
1947} 2662}
1948 2663
1949sub cf::object::player::enter_exit { 2664sub cf::object::player::enter_exit {
1950 my ($self, $exit) = @_; 2665 my ($self, $exit) = @_;
1951 2666
1952 return unless $self->type == cf::PLAYER; 2667 return unless $self->type == cf::PLAYER;
1953 2668
1954 if ($exit->slaying eq "/!") {
1955 #TODO: this should de-fi-ni-te-ly not be a sync-job
1956 cf::sync_job { prepare_random_map $exit };
1957 }
1958
1959 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
1960 my $hp = $exit->stats->hp;
1961 my $sp = $exit->stats->sp;
1962
1963 $self->enter_link; 2669 $self->enter_link;
1964 2670
1965 (async { 2671 (async {
1966 $self->deactivate_recursive; # just to be sure 2672 $Coro::current->{desc} = "enter_exit";
2673
1967 unless (eval { 2674 unless (eval {
2675 $self->deactivate_recursive; # just to be sure
2676
2677 # random map handling
2678 {
2679 my $guard = cf::lock_acquire "exit_prepare:$exit";
2680
2681 prepare_random_map $exit
2682 if $exit->slaying eq "/!";
2683 }
2684
2685 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2686 my $x = $exit->stats->hp;
2687 my $y = $exit->stats->sp;
2688
1968 $self->goto ($slaying, $hp, $sp); 2689 $self->goto ($map, $x, $y);
1969 2690
2691 # if exit is damned, update players death & WoR home-position
2692 $self->contr->savebed ($map, $x, $y)
2693 if $exit->flag (cf::FLAG_DAMNED);
2694
1970 1; 2695 1
1971 }) { 2696 }) {
1972 $self->message ("Something went wrong deep within the crossfire server. " 2697 $self->message ("Something went wrong deep within the deliantra server. "
1973 . "I'll try to bring you back to the map you were before. " 2698 . "I'll try to bring you back to the map you were before. "
1974 . "Please report this to the dungeon master!", 2699 . "Please report this to the dungeon master!",
1975 cf::NDI_UNIQUE | cf::NDI_RED); 2700 cf::NDI_UNIQUE | cf::NDI_RED);
1976 2701
1977 warn "ERROR in enter_exit: $@"; 2702 warn "ERROR in enter_exit: $@";
1978 $self->leave_link; 2703 $self->leave_link;
1979 } 2704 }
1980 })->prio (1); 2705 })->prio (1);
1993 2718
1994sub cf::client::send_drawinfo { 2719sub cf::client::send_drawinfo {
1995 my ($self, $text, $flags) = @_; 2720 my ($self, $text, $flags) = @_;
1996 2721
1997 utf8::encode $text; 2722 utf8::encode $text;
1998 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 2723 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
1999} 2724}
2000 2725
2726=item $client->send_msg ($channel, $msg, $color, [extra...])
2727
2728Send a drawinfo or msg packet to the client, formatting the msg for the
2729client if neccessary. C<$type> should be a string identifying the type of
2730the message, with C<log> being the default. If C<$color> is negative, suppress
2731the message unless the client supports the msg packet.
2732
2733=cut
2734
2735# non-persistent channels (usually the info channel)
2736our %CHANNEL = (
2737 "c/identify" => {
2738 id => "infobox",
2739 title => "Identify",
2740 reply => undef,
2741 tooltip => "Items recently identified",
2742 },
2743 "c/examine" => {
2744 id => "infobox",
2745 title => "Examine",
2746 reply => undef,
2747 tooltip => "Signs and other items you examined",
2748 },
2749 "c/book" => {
2750 id => "infobox",
2751 title => "Book",
2752 reply => undef,
2753 tooltip => "The contents of a note or book",
2754 },
2755 "c/lookat" => {
2756 id => "infobox",
2757 title => "Look",
2758 reply => undef,
2759 tooltip => "What you saw there",
2760 },
2761 "c/who" => {
2762 id => "infobox",
2763 title => "Players",
2764 reply => undef,
2765 tooltip => "Shows players who are currently online",
2766 },
2767 "c/body" => {
2768 id => "infobox",
2769 title => "Body Parts",
2770 reply => undef,
2771 tooltip => "Shows which body parts you posess and are available",
2772 },
2773 "c/uptime" => {
2774 id => "infobox",
2775 title => "Uptime",
2776 reply => undef,
2777 tooltip => "How long the server has been running since last restart",
2778 },
2779 "c/mapinfo" => {
2780 id => "infobox",
2781 title => "Map Info",
2782 reply => undef,
2783 tooltip => "Information related to the maps",
2784 },
2785 "c/party" => {
2786 id => "party",
2787 title => "Party",
2788 reply => "gsay ",
2789 tooltip => "Messages and chat related to your party",
2790 },
2791);
2792
2793sub cf::client::send_msg {
2794 my ($self, $channel, $msg, $color, @extra) = @_;
2795
2796 $msg = $self->pl->expand_cfpod ($msg)
2797 unless $color & cf::NDI_VERBATIM;
2798
2799 $color &= cf::NDI_CLIENT_MASK; # just in case...
2800
2801 # check predefined channels, for the benefit of C
2802 if ($CHANNEL{$channel}) {
2803 $channel = $CHANNEL{$channel};
2804
2805 $self->ext_msg (channel_info => $channel)
2806 if $self->can_msg;
2807
2808 $channel = $channel->{id};
2809
2810 } elsif (ref $channel) {
2811 # send meta info to client, if not yet sent
2812 unless (exists $self->{channel}{$channel->{id}}) {
2813 $self->{channel}{$channel->{id}} = $channel;
2814 $self->ext_msg (channel_info => $channel)
2815 if $self->can_msg;
2816 }
2817
2818 $channel = $channel->{id};
2819 }
2820
2821 return unless @extra || length $msg;
2822
2823 if ($self->can_msg) {
2824 # default colour, mask it out
2825 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2826 if $color & cf::NDI_DEF;
2827
2828 my $pkt = "msg "
2829 . $self->{json_coder}->encode (
2830 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2831 );
2832
2833 # try lzf for large packets
2834 $pkt = "lzf " . Compress::LZF::compress $pkt
2835 if 1024 <= length $pkt and $self->{can_lzf};
2836
2837 # split very large packets
2838 if (8192 < length $pkt and $self->{can_lzf}) {
2839 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2840 $pkt = "frag";
2841 }
2842
2843 $self->send_packet ($pkt);
2844 } else {
2845 if ($color >= 0) {
2846 # replace some tags by gcfclient-compatible ones
2847 for ($msg) {
2848 1 while
2849 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2850 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2851 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2852 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2853 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2854 }
2855
2856 $color &= cf::NDI_COLOR_MASK;
2857
2858 utf8::encode $msg;
2859
2860 if (0 && $msg =~ /\[/) {
2861 # COMMAND/INFO
2862 $self->send_packet ("drawextinfo $color 10 8 $msg")
2863 } else {
2864 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2865 $self->send_packet ("drawinfo $color $msg")
2866 }
2867 }
2868 }
2869}
2870
2871=item $client->ext_msg ($type, @msg)
2872
2873Sends an ext event to the client.
2874
2875=cut
2876
2877sub cf::client::ext_msg($$@) {
2878 my ($self, $type, @msg) = @_;
2879
2880 if ($self->extcmd == 2) {
2881 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2882 } elsif ($self->extcmd == 1) { # TODO: remove
2883 push @msg, msgtype => "event_$type";
2884 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2885 }
2886}
2887
2888=item $client->ext_reply ($msgid, @msg)
2889
2890Sends an ext reply to the client.
2891
2892=cut
2893
2894sub cf::client::ext_reply($$@) {
2895 my ($self, $id, @msg) = @_;
2896
2897 if ($self->extcmd == 2) {
2898 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2899 } elsif ($self->extcmd == 1) {
2900 #TODO: version 1, remove
2901 unshift @msg, msgtype => "reply", msgid => $id;
2902 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2903 }
2904}
2001 2905
2002=item $success = $client->query ($flags, "text", \&cb) 2906=item $success = $client->query ($flags, "text", \&cb)
2003 2907
2004Queues a query to the client, calling the given callback with 2908Queues a query to the client, calling the given callback with
2005the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2909the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
2006C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 2910C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2007 2911
2008Queries can fail, so check the return code. Or don't, as queries will become 2912Queries can fail, so check the return code. Or don't, as queries will
2009reliable at some point in the future. 2913become reliable at some point in the future.
2010 2914
2011=cut 2915=cut
2012 2916
2013sub cf::client::query { 2917sub cf::client::query {
2014 my ($self, $flags, $text, $cb) = @_; 2918 my ($self, $flags, $text, $cb) = @_;
2022 utf8::encode $text; 2926 utf8::encode $text;
2023 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2927 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2024 2928
2025 $self->send_packet ($self->{query_queue}[0][0]) 2929 $self->send_packet ($self->{query_queue}[0][0])
2026 if @{ $self->{query_queue} } == 1; 2930 if @{ $self->{query_queue} } == 1;
2931
2932 1
2027} 2933}
2028 2934
2029cf::client->attach ( 2935cf::client->attach (
2936 on_connect => sub {
2937 my ($ns) = @_;
2938
2939 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2940 },
2030 on_reply => sub { 2941 on_reply => sub {
2031 my ($ns, $msg) = @_; 2942 my ($ns, $msg) = @_;
2032 2943
2033 # this weird shuffling is so that direct followup queries 2944 # this weird shuffling is so that direct followup queries
2034 # get handled first 2945 # get handled first
2046 } else { 2957 } else {
2047 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 2958 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2048 } 2959 }
2049 } 2960 }
2050 }, 2961 },
2962 on_exticmd => sub {
2963 my ($ns, $buf) = @_;
2964
2965 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2966
2967 if (ref $msg) {
2968 my ($type, $reply, @payload) =
2969 "ARRAY" eq ref $msg
2970 ? @$msg
2971 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
2972
2973 my @reply;
2974
2975 if (my $cb = $EXTICMD{$type}) {
2976 @reply = $cb->($ns, @payload);
2977 }
2978
2979 $ns->ext_reply ($reply, @reply)
2980 if $reply;
2981
2982 } else {
2983 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2984 }
2985
2986 cf::override;
2987 },
2051); 2988);
2052 2989
2053=item $client->async (\&cb) 2990=item $client->async (\&cb)
2054 2991
2055Create a new coroutine, running the specified callback. The coroutine will 2992Create a new coroutine, running the specified callback. The coroutine will
2096our $safe = new Safe "safe"; 3033our $safe = new Safe "safe";
2097our $safe_hole = new Safe::Hole; 3034our $safe_hole = new Safe::Hole;
2098 3035
2099$SIG{FPE} = 'IGNORE'; 3036$SIG{FPE} = 'IGNORE';
2100 3037
2101$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 3038$safe->permit_only (Opcode::opset qw(
3039 :base_core :base_mem :base_orig :base_math
3040 grepstart grepwhile mapstart mapwhile
3041 sort time
3042));
2102 3043
2103# here we export the classes and methods available to script code 3044# here we export the classes and methods available to script code
2104 3045
2105=pod 3046=pod
2106 3047
2107The following fucntions and emthods are available within a safe environment: 3048The following functions and methods are available within a safe environment:
2108 3049
2109 cf::object contr pay_amount pay_player map 3050 cf::object
3051 contr pay_amount pay_player map x y force_find force_add destroy
3052 insert remove name archname title slaying race decrease split
3053
2110 cf::object::player player 3054 cf::object::player
2111 cf::player peaceful 3055 player
2112 cf::map trigger 3056
3057 cf::player
3058 peaceful
3059
3060 cf::map
3061 trigger
2113 3062
2114=cut 3063=cut
2115 3064
2116for ( 3065for (
2117 ["cf::object" => qw(contr pay_amount pay_player map)], 3066 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3067 insert remove inv nrof name archname title slaying race
3068 decrease split destroy change_exp)],
2118 ["cf::object::player" => qw(player)], 3069 ["cf::object::player" => qw(player)],
2119 ["cf::player" => qw(peaceful)], 3070 ["cf::player" => qw(peaceful)],
2120 ["cf::map" => qw(trigger)], 3071 ["cf::map" => qw(trigger)],
2121) { 3072) {
2122 no strict 'refs'; 3073 no strict 'refs';
2193=back 3144=back
2194 3145
2195=cut 3146=cut
2196 3147
2197############################################################################# 3148#############################################################################
2198
2199=head2 EXTENSION DATABASE SUPPORT
2200
2201Crossfire maintains a very simple database for extension use. It can
2202currently store anything that can be serialised using Storable, which
2203excludes objects.
2204
2205The parameter C<$family> should best start with the name of the extension
2206using it, it should be unique.
2207
2208=over 4
2209
2210=item $value = cf::db_get $family => $key
2211
2212Returns a single value from the database.
2213
2214=item cf::db_put $family => $key => $value
2215
2216Stores the given C<$value> in the family.
2217
2218=cut
2219
2220our $DB;
2221
2222sub db_init {
2223 unless ($DB) {
2224 $DB = BDB::db_create $DB_ENV;
2225
2226 cf::sync_job {
2227 eval {
2228 $DB->set_flags (BDB::CHKSUM);
2229
2230 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2231 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2232 cf::cleanup "db_open(db): $!" if $!;
2233 };
2234 cf::cleanup "db_open(db): $@" if $@;
2235 };
2236
2237 my $path = cf::localdir . "/database.pst";
2238 if (stat $path) {
2239 cf::sync_job {
2240 my $pst = Storable::retrieve $path;
2241
2242 cf::db_put (board => data => $pst->{board});
2243 cf::db_put (guildrules => data => $pst->{guildrules});
2244 cf::db_put (rent => balance => $pst->{rent}{balance});
2245 BDB::db_env_txn_checkpoint $DB_ENV;
2246
2247 unlink $path;
2248 };
2249 }
2250 }
2251}
2252
2253sub db_get($$) {
2254 my $key = "$_[0]/$_[1]";
2255
2256 cf::sync_job {
2257 BDB::db_get $DB, undef, $key, my $data;
2258
2259 $! ? ()
2260 : Compress::LZF::sthaw $data
2261 }
2262}
2263
2264sub db_put($$$) {
2265 BDB::dbreq_pri 4;
2266 BDB::db_put $DB, undef, "$_[0]/$_[1]", Compress::LZF::sfreeze_cr $_[2], 0, sub { };
2267}
2268
2269#############################################################################
2270# the server's init and main functions 3149# the server's init and main functions
2271 3150
2272sub load_faces { 3151sub load_facedata($) {
2273 my $path = sprintf "%s/faces", cf::datadir; 3152 my ($path) = @_;
2274 3153
3154 # HACK to clear player env face cache, we need some signal framework
3155 # for this (global event?)
3156 %ext::player_env::MUSIC_FACE_CACHE = ();
3157
3158 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3159
2275 warn "loading faces from $path\n"; 3160 warn "loading facedata from $path\n";
2276 3161
2277 my $faces; 3162 my $facedata;
2278 0 < aio_load $path, $faces 3163 0 < aio_load $path, $facedata
2279 or die "$path: $!"; 3164 or die "$path: $!";
2280 3165
2281 Coro::cede;
2282 $faces = Storable::thaw $faces; 3166 $facedata = Coro::Storable::thaw $facedata;
2283 Coro::cede;
2284 3167
3168 $facedata->{version} == 2
3169 or cf::cleanup "$path: version mismatch, cannot proceed.";
3170
3171 # patch in the exptable
3172 $facedata->{resource}{"res/exp_table"} = {
3173 type => FT_RSRC,
3174 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
3175 };
3176 cf::cede_to_tick;
3177
3178 {
3179 my $faces = $facedata->{faceinfo};
3180
2285 while (my ($face, $info) = each %$faces) { 3181 while (my ($face, $info) = each %$faces) {
2286 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3182 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2287 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 3183
3184 cf::face::set_visibility $idx, $info->{visibility};
3185 cf::face::set_magicmap $idx, $info->{magicmap};
2288 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 3186 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2289 Coro::cede; 3187 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
3188
3189 cf::cede_to_tick;
3190 }
3191
3192 while (my ($face, $info) = each %$faces) {
3193 next unless $info->{smooth};
3194
3195 my $idx = cf::face::find $face
3196 or next;
3197
3198 if (my $smooth = cf::face::find $info->{smooth}) {
3199 cf::face::set_smooth $idx, $smooth;
3200 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3201 } else {
3202 warn "smooth face '$info->{smooth}' not found for face '$face'";
3203 }
3204
3205 cf::cede_to_tick;
3206 }
3207 }
3208
2290 } 3209 {
3210 my $anims = $facedata->{animinfo};
3211
3212 while (my ($anim, $info) = each %$anims) {
3213 cf::anim::set $anim, $info->{frames}, $info->{facings};
3214 cf::cede_to_tick;
3215 }
3216
3217 cf::anim::invalidate_all; # d'oh
3218 }
3219
3220 {
3221 # TODO: for gcfclient pleasure, we should give resources
3222 # that gcfclient doesn't grok a >10000 face index.
3223 my $res = $facedata->{resource};
3224
3225 while (my ($name, $info) = each %$res) {
3226 if (defined $info->{type}) {
3227 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3228 my $data;
3229
3230 if ($info->{type} & 1) {
3231 # prepend meta info
3232
3233 my $meta = $enc->encode ({
3234 name => $name,
3235 %{ $info->{meta} || {} },
3236 });
3237
3238 $data = pack "(w/a*)*", $meta, $info->{data};
3239 } else {
3240 $data = $info->{data};
3241 }
3242
3243 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3244 cf::face::set_type $idx, $info->{type};
3245 } else {
3246 $RESOURCE{$name} = $info;
3247 }
3248
3249 cf::cede_to_tick;
3250 }
3251 }
3252
3253 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
2291 3254
2292 1 3255 1
2293} 3256}
2294 3257
3258cf::global->attach (on_resource_update => sub {
3259 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3260 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3261
3262 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3263 my $sound = $soundconf->{compat}[$_]
3264 or next;
3265
3266 my $face = cf::face::find "sound/$sound->[1]";
3267 cf::sound::set $sound->[0] => $face;
3268 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3269 }
3270
3271 while (my ($k, $v) = each %{$soundconf->{event}}) {
3272 my $face = cf::face::find "sound/$v";
3273 cf::sound::set $k => $face;
3274 }
3275 }
3276});
3277
3278register_exticmd fx_want => sub {
3279 my ($ns, $want) = @_;
3280
3281 while (my ($k, $v) = each %$want) {
3282 $ns->fx_want ($k, $v);
3283 }
3284};
3285
3286sub load_resource_file($) {
3287 my $guard = lock_acquire "load_resource_file";
3288
3289 my $status = load_resource_file_ $_[0];
3290 get_slot 0.1, 100;
3291 cf::arch::commit_load;
3292
3293 $status
3294}
3295
3296sub reload_regions {
3297 # HACK to clear player env face cache, we need some signal framework
3298 # for this (global event?)
3299 %ext::player_env::MUSIC_FACE_CACHE = ();
3300
3301 load_resource_file "$MAPDIR/regions"
3302 or die "unable to load regions file\n";
3303
3304 for (cf::region::list) {
3305 $_->{match} = qr/$_->{match}/
3306 if exists $_->{match};
3307 }
3308}
3309
3310sub reload_facedata {
3311 load_facedata "$DATADIR/facedata"
3312 or die "unable to load facedata\n";
3313}
3314
3315sub reload_archetypes {
3316 load_resource_file "$DATADIR/archetypes"
3317 or die "unable to load archetypes\n";
3318}
3319
3320sub reload_treasures {
3321 load_resource_file "$DATADIR/treasures"
3322 or die "unable to load treasurelists\n";
3323}
3324
2295sub reload_resources { 3325sub reload_resources {
2296 load_resource_file sprintf "%s/%s/regions", cf::datadir, cf::mapdir 3326 warn "reloading resource files...\n";
2297 or die "unable to load regions file\n";#d# 3327
2298 load_faces 3328 reload_facedata;
2299 or die "unable to load faces\n";#d# 3329 reload_archetypes;
3330 reload_regions;
3331 reload_treasures;
3332
3333 warn "finished reloading resource files\n";
2300} 3334}
2301 3335
2302sub init { 3336sub init {
3337 my $guard = freeze_mainloop;
3338
3339 evthread_start IO::AIO::poll_fileno;
3340
2303 reload_resources; 3341 reload_resources;
2304} 3342}
2305 3343
2306sub cfg_load { 3344sub reload_config {
2307 open my $fh, "<:utf8", cf::confdir . "/config" 3345 open my $fh, "<:utf8", "$CONFDIR/config"
2308 or return; 3346 or return;
2309 3347
2310 local $/; 3348 local $/;
2311 *CFG = YAML::Syck::Load <$fh>; 3349 *CFG = YAML::Load <$fh>;
2312 3350
2313 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3351 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
2314 3352
2315 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3353 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2316 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3354 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
2322 }; 3360 };
2323 warn $@ if $@; 3361 warn $@ if $@;
2324 } 3362 }
2325} 3363}
2326 3364
3365sub pidfile() {
3366 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3367 or die "$PIDFILE: $!";
3368 flock $fh, &Fcntl::LOCK_EX
3369 or die "$PIDFILE: flock: $!";
3370 $fh
3371}
3372
3373# make sure only one server instance is running at any one time
3374sub atomic {
3375 my $fh = pidfile;
3376
3377 my $pid = <$fh>;
3378 kill 9, $pid if $pid > 0;
3379
3380 seek $fh, 0, 0;
3381 print $fh $$;
3382}
3383
2327sub main { 3384sub main {
3385 atomic;
3386
2328 # we must not ever block the main coroutine 3387 # we must not ever block the main coroutine
2329 local $Coro::idle = sub { 3388 local $Coro::idle = sub {
2330 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3389 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2331 (async { 3390 (async {
2332 Event::one_event; 3391 $Coro::current->{desc} = "IDLE BUG HANDLER";
3392 EV::loop EV::LOOP_ONESHOT;
2333 })->prio (Coro::PRIO_MAX); 3393 })->prio (Coro::PRIO_MAX);
2334 }; 3394 };
2335 3395
2336 cfg_load; 3396 {
3397 my $guard = freeze_mainloop;
3398 reload_config;
2337 db_init; 3399 db_init;
2338 load_extensions; 3400 load_extensions;
2339 3401
2340 $TICK_WATCHER->start; 3402 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3403 }
3404
3405 utime time, time, $RUNTIMEFILE;
3406
3407 # no (long-running) fork's whatsoever before this point(!)
3408 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3409
2341 Event::loop; 3410 EV::loop;
2342} 3411}
2343 3412
2344############################################################################# 3413#############################################################################
2345# initialisation and cleanup 3414# initialisation and cleanup
2346 3415
2347# install some emergency cleanup handlers 3416# install some emergency cleanup handlers
2348BEGIN { 3417BEGIN {
3418 our %SIGWATCHER = ();
2349 for my $signal (qw(INT HUP TERM)) { 3419 for my $signal (qw(INT HUP TERM)) {
2350 Event->signal ( 3420 $SIGWATCHER{$signal} = EV::signal $signal, sub {
2351 reentrant => 0,
2352 data => WF_AUTOCANCEL,
2353 signal => $signal,
2354 prio => 0,
2355 cb => sub {
2356 cf::cleanup "SIG$signal"; 3421 cf::cleanup "SIG$signal";
2357 },
2358 ); 3422 };
3423 }
3424}
3425
3426sub write_runtime_sync {
3427 # first touch the runtime file to show we are still running:
3428 # the fsync below can take a very very long time.
3429
3430 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3431
3432 my $guard = cf::lock_acquire "write_runtime";
3433
3434 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644
3435 or return;
3436
3437 my $value = $cf::RUNTIME + 90 + 10;
3438 # 10 is the runtime save interval, for a monotonic clock
3439 # 60 allows for the watchdog to kill the server.
3440
3441 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3442 and return;
3443
3444 # always fsync - this file is important
3445 aio_fsync $fh
3446 and return;
3447
3448 # touch it again to show we are up-to-date
3449 aio_utime $fh, undef, undef;
3450
3451 close $fh
3452 or return;
3453
3454 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3455 and return;
3456
3457 warn "runtime file written.\n";
3458
2359 } 3459 1
3460}
3461
3462our $uuid_lock;
3463our $uuid_skip;
3464
3465sub write_uuid_sync($) {
3466 $uuid_skip ||= $_[0];
3467
3468 return if $uuid_lock;
3469 local $uuid_lock = 1;
3470
3471 my $uuid = "$LOCALDIR/uuid";
3472
3473 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3474 or return;
3475
3476 my $value = uuid_str $uuid_skip + uuid_seq uuid_cur;
3477 $uuid_skip = 0;
3478
3479 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3480 and return;
3481
3482 # always fsync - this file is important
3483 aio_fsync $fh
3484 and return;
3485
3486 close $fh
3487 or return;
3488
3489 aio_rename "$uuid~", $uuid
3490 and return;
3491
3492 warn "uuid file written ($value).\n";
3493
3494 1
3495
3496}
3497
3498sub write_uuid($$) {
3499 my ($skip, $sync) = @_;
3500
3501 $sync ? write_uuid_sync $skip
3502 : async { write_uuid_sync $skip };
2360} 3503}
2361 3504
2362sub emergency_save() { 3505sub emergency_save() {
2363 my $freeze_guard = cf::freeze_mainloop; 3506 my $freeze_guard = cf::freeze_mainloop;
2364 3507
2370 # and maps saved/destroyed asynchronously. 3513 # and maps saved/destroyed asynchronously.
2371 warn "begin emergency player save\n"; 3514 warn "begin emergency player save\n";
2372 for my $login (keys %cf::PLAYER) { 3515 for my $login (keys %cf::PLAYER) {
2373 my $pl = $cf::PLAYER{$login} or next; 3516 my $pl = $cf::PLAYER{$login} or next;
2374 $pl->valid or next; 3517 $pl->valid or next;
3518 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
2375 $pl->save; 3519 $pl->save;
2376 } 3520 }
2377 warn "end emergency player save\n"; 3521 warn "end emergency player save\n";
2378 3522
2379 warn "begin emergency map save\n"; 3523 warn "begin emergency map save\n";
2385 warn "end emergency map save\n"; 3529 warn "end emergency map save\n";
2386 3530
2387 warn "begin emergency database checkpoint\n"; 3531 warn "begin emergency database checkpoint\n";
2388 BDB::db_env_txn_checkpoint $DB_ENV; 3532 BDB::db_env_txn_checkpoint $DB_ENV;
2389 warn "end emergency database checkpoint\n"; 3533 warn "end emergency database checkpoint\n";
3534
3535 warn "begin write uuid\n";
3536 write_uuid_sync 1;
3537 warn "end write uuid\n";
2390 }; 3538 };
2391 3539
2392 warn "leave emergency perl save\n"; 3540 warn "leave emergency perl save\n";
2393} 3541}
2394 3542
2395sub post_cleanup { 3543sub post_cleanup {
2396 my ($make_core) = @_; 3544 my ($make_core) = @_;
2397 3545
2398 warn Carp::longmess "post_cleanup backtrace" 3546 warn Carp::longmess "post_cleanup backtrace"
2399 if $make_core; 3547 if $make_core;
2400}
2401 3548
3549 my $fh = pidfile;
3550 unlink $PIDFILE if <$fh> == $$;
3551}
3552
3553# a safer delete_package, copied from Symbol
3554sub clear_package($) {
3555 my $pkg = shift;
3556
3557 # expand to full symbol table name if needed
3558 unless ($pkg =~ /^main::.*::$/) {
3559 $pkg = "main$pkg" if $pkg =~ /^::/;
3560 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3561 $pkg .= '::' unless $pkg =~ /::$/;
3562 }
3563
3564 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3565 my $stem_symtab = *{$stem}{HASH};
3566
3567 defined $stem_symtab and exists $stem_symtab->{$leaf}
3568 or return;
3569
3570 # clear all symbols
3571 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3572 for my $name (keys %$leaf_symtab) {
3573 _gv_clear *{"$pkg$name"};
3574# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3575 }
3576 warn "cleared package #$pkg\n";#d#
3577}
3578
3579our $RELOAD; # how many times to reload
3580
2402sub reload() { 3581sub do_reload_perl() {
2403 # can/must only be called in main 3582 # can/must only be called in main
2404 if ($Coro::current != $Coro::main) { 3583 if ($Coro::current != $Coro::main) {
2405 warn "can only reload from main coroutine"; 3584 warn "can only reload from main coroutine";
2406 return; 3585 return;
2407 } 3586 }
2408 3587
3588 return if $RELOAD++;
3589
3590 while ($RELOAD) {
2409 warn "reloading..."; 3591 warn "reloading...";
2410 3592
2411 warn "entering sync_job"; 3593 warn "entering sync_job";
2412 3594
2413 cf::sync_job { 3595 cf::sync_job {
2414 cf::write_runtime; # external watchdog should not bark 3596 cf::write_runtime_sync; # external watchdog should not bark
2415 cf::emergency_save; 3597 cf::emergency_save;
2416 cf::write_runtime; # external watchdog should not bark 3598 cf::write_runtime_sync; # external watchdog should not bark
2417 3599
2418 warn "syncing database to disk"; 3600 warn "syncing database to disk";
2419 BDB::db_env_txn_checkpoint $DB_ENV; 3601 BDB::db_env_txn_checkpoint $DB_ENV;
2420 3602
2421 # if anything goes wrong in here, we should simply crash as we already saved 3603 # if anything goes wrong in here, we should simply crash as we already saved
2422 3604
2423 warn "cancelling all WF_AUTOCANCEL watchers";
2424 for (Event::all_watchers) {
2425 $_->cancel if $_->data & WF_AUTOCANCEL;
2426 }
2427
2428 warn "flushing outstanding aio requests"; 3605 warn "flushing outstanding aio requests";
2429 for (;;) {
2430 BDB::flush;
2431 IO::AIO::flush;
2432 Coro::cede;
2433 last unless IO::AIO::nreqs || BDB::nreqs; 3606 while (IO::AIO::nreqs || BDB::nreqs) {
2434 warn "iterate..."; 3607 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
2435 }
2436
2437 ++$RELOAD;
2438
2439 warn "cancelling all extension coros";
2440 $_->cancel for values %EXT_CORO;
2441 %EXT_CORO = ();
2442
2443 warn "removing commands";
2444 %COMMAND = ();
2445
2446 warn "removing ext commands";
2447 %EXTCMD = ();
2448
2449 warn "unloading/nuking all extensions";
2450 for my $pkg (@EXTS) {
2451 warn "... unloading $pkg";
2452
2453 if (my $cb = $pkg->can ("unload")) {
2454 eval {
2455 $cb->($pkg);
2456 1
2457 } or warn "$pkg unloaded, but with errors: $@";
2458 } 3608 }
2459 3609
2460 warn "... nuking $pkg"; 3610 warn "cancelling all extension coros";
2461 Symbol::delete_package $pkg; 3611 $_->cancel for values %EXT_CORO;
2462 } 3612 %EXT_CORO = ();
2463 3613
2464 warn "unloading all perl modules loaded from $LIBDIR"; 3614 warn "removing commands";
2465 while (my ($k, $v) = each %INC) { 3615 %COMMAND = ();
2466 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2467 3616
3617 warn "removing ext/exti commands";
3618 %EXTCMD = ();
3619 %EXTICMD = ();
3620
3621 warn "unloading/nuking all extensions";
3622 for my $pkg (@EXTS) {
2468 warn "... unloading $k"; 3623 warn "... unloading $pkg";
2469 delete $INC{$k};
2470 3624
2471 $k =~ s/\.pm$//;
2472 $k =~ s/\//::/g;
2473
2474 if (my $cb = $k->can ("unload_module")) { 3625 if (my $cb = $pkg->can ("unload")) {
3626 eval {
2475 $cb->(); 3627 $cb->($pkg);
3628 1
3629 } or warn "$pkg unloaded, but with errors: $@";
3630 }
3631
3632 warn "... clearing $pkg";
3633 clear_package $pkg;
2476 } 3634 }
2477 3635
2478 Symbol::delete_package $k; 3636 warn "unloading all perl modules loaded from $LIBDIR";
3637 while (my ($k, $v) = each %INC) {
3638 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3639
3640 warn "... unloading $k";
3641 delete $INC{$k};
3642
3643 $k =~ s/\.pm$//;
3644 $k =~ s/\//::/g;
3645
3646 if (my $cb = $k->can ("unload_module")) {
3647 $cb->();
3648 }
3649
3650 clear_package $k;
2479 } 3651 }
2480 3652
2481 warn "getting rid of safe::, as good as possible"; 3653 warn "getting rid of safe::, as good as possible";
2482 Symbol::delete_package "safe::$_" 3654 clear_package "safe::$_"
2483 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3655 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2484 3656
2485 warn "unloading cf.pm \"a bit\""; 3657 warn "unloading cf.pm \"a bit\"";
2486 delete $INC{"cf.pm"}; 3658 delete $INC{"cf.pm"};
3659 delete $INC{"cf/pod.pm"};
2487 3660
2488 # don't, removes xs symbols, too, 3661 # don't, removes xs symbols, too,
2489 # and global variables created in xs 3662 # and global variables created in xs
2490 #Symbol::delete_package __PACKAGE__; 3663 #clear_package __PACKAGE__;
2491 3664
2492 warn "unload completed, starting to reload now"; 3665 warn "unload completed, starting to reload now";
2493 3666
2494 warn "reloading cf.pm"; 3667 warn "reloading cf.pm";
2495 require cf; 3668 require cf;
2496 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3669 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2497 3670
2498 warn "loading config and database again"; 3671 warn "loading config and database again";
2499 cf::cfg_load; 3672 cf::reload_config;
2500 3673
2501 warn "loading extensions"; 3674 warn "loading extensions";
2502 cf::load_extensions; 3675 cf::load_extensions;
2503 3676
2504 warn "reattaching attachments to objects/players"; 3677 warn "reattaching attachments to objects/players";
2505 _global_reattach; # objects, sockets 3678 _global_reattach; # objects, sockets
2506 warn "reattaching attachments to maps"; 3679 warn "reattaching attachments to maps";
2507 reattach $_ for values %MAP; 3680 reattach $_ for values %MAP;
2508 warn "reattaching attachments to players"; 3681 warn "reattaching attachments to players";
2509 reattach $_ for values %PLAYER; 3682 reattach $_ for values %PLAYER;
2510 3683
2511 warn "loading reloadable resources";
2512 reload_resources;
2513
2514 warn "leaving sync_job"; 3684 warn "leaving sync_job";
2515 3685
2516 1 3686 1
2517 } or do { 3687 } or do {
2518 warn $@; 3688 warn $@;
2519 warn "error while reloading, exiting."; 3689 cf::cleanup "error while reloading, exiting.";
2520 exit 1; 3690 };
3691
3692 warn "reloaded";
3693 --$RELOAD;
3694 }
3695};
3696
3697our $RELOAD_WATCHER; # used only during reload
3698
3699sub reload_perl() {
3700 # doing reload synchronously and two reloads happen back-to-back,
3701 # coro crashes during coro_state_free->destroy here.
3702
3703 $RELOAD_WATCHER ||= EV::timer 0, 0, sub {
3704 do_reload_perl;
3705 undef $RELOAD_WATCHER;
2521 }; 3706 };
2522 3707}
2523 warn "reloaded";
2524};
2525
2526our $RELOAD_WATCHER; # used only during reload
2527 3708
2528register_command "reload" => sub { 3709register_command "reload" => sub {
2529 my ($who, $arg) = @_; 3710 my ($who, $arg) = @_;
2530 3711
2531 if ($who->flag (FLAG_WIZ)) { 3712 if ($who->flag (FLAG_WIZ)) {
2532 $who->message ("reloading server."); 3713 $who->message ("reloading server.");
2533 3714 async {
2534 # doing reload synchronously and two reloads happen back-to-back, 3715 $Coro::current->{desc} = "perl_reload";
2535 # coro crashes during coro_state_free->destroy here.
2536
2537 $RELOAD_WATCHER ||= Event->timer (
2538 reentrant => 0,
2539 after => 0,
2540 data => WF_AUTOCANCEL,
2541 cb => sub {
2542 reload; 3716 reload_perl;
2543 undef $RELOAD_WATCHER;
2544 },
2545 ); 3717 };
2546 } 3718 }
2547}; 3719};
2548 3720
2549unshift @INC, $LIBDIR; 3721unshift @INC, $LIBDIR;
2550 3722
2551my $bug_warning = 0; 3723my $bug_warning = 0;
2552 3724
2553$TICK_WATCHER = Event->timer ( 3725our @WAIT_FOR_TICK;
2554 reentrant => 0, 3726our @WAIT_FOR_TICK_BEGIN;
2555 parked => 1, 3727
2556 prio => 0, 3728sub wait_for_tick {
2557 at => $NEXT_TICK || $TICK, 3729 return if tick_inhibit || $Coro::current == $Coro::main;
2558 data => WF_AUTOCANCEL, 3730
2559 cb => sub { 3731 my $signal = new Coro::Signal;
3732 push @WAIT_FOR_TICK, $signal;
3733 $signal->wait;
3734}
3735
3736sub wait_for_tick_begin {
3737 return if tick_inhibit || $Coro::current == $Coro::main;
3738
3739 my $signal = new Coro::Signal;
3740 push @WAIT_FOR_TICK_BEGIN, $signal;
3741 $signal->wait;
3742}
3743
3744sub tick {
2560 if ($Coro::current != $Coro::main) { 3745 if ($Coro::current != $Coro::main) {
2561 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3746 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2562 unless ++$bug_warning > 10; 3747 unless ++$bug_warning > 10;
2563 return; 3748 return;
2564 } 3749 }
2565 3750
2566 $NOW = Event::time;
2567
2568 cf::server_tick; # one server iteration 3751 cf::server_tick; # one server iteration
2569 $RUNTIME += $TICK;
2570 $NEXT_TICK += $TICK;
2571 3752
2572 if ($NOW >= $NEXT_RUNTIME_WRITE) { 3753 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2573 $NEXT_RUNTIME_WRITE = $NOW + 10; 3754 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
2574 Coro::async_pool { 3755 Coro::async_pool {
3756 $Coro::current->{desc} = "runtime saver";
2575 write_runtime 3757 write_runtime_sync
2576 or warn "ERROR: unable to write runtime file: $!"; 3758 or warn "ERROR: unable to write runtime file: $!";
2577 };
2578 } 3759 };
2579
2580 $WAIT_FOR_TICK->broadcast;
2581 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited;
2582
2583# my $AFTER = Event::time;
2584# warn $AFTER - $NOW;#d#
2585
2586 # if we are delayed by four ticks or more, skip them all
2587 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
2588
2589 $TICK_WATCHER->at ($NEXT_TICK);
2590 $TICK_WATCHER->start;
2591 }, 3760 }
2592); 3761
3762 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3763 $sig->send;
3764 }
3765 while (my $sig = shift @WAIT_FOR_TICK) {
3766 $sig->send;
3767 }
3768
3769 $LOAD = ($NOW - $TICK_START) / $TICK;
3770 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3771
3772 if (0) {
3773 if ($NEXT_TICK) {
3774 my $jitter = $TICK_START - $NEXT_TICK;
3775 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3776 warn "jitter $JITTER\n";#d#
3777 }
3778 }
3779}
2593 3780
2594{ 3781{
2595 BDB::max_poll_time $TICK * 0.1; 3782 # configure BDB
2596 $BDB_POLL_WATCHER = Event->io ( 3783
2597 reentrant => 0,
2598 fd => BDB::poll_fileno,
2599 poll => 'r',
2600 prio => 0,
2601 data => WF_AUTOCANCEL,
2602 cb => \&BDB::poll_cb,
2603 );
2604 BDB::min_parallel 8; 3784 BDB::min_parallel 8;
2605 3785 BDB::max_poll_reqs $TICK * 0.1;
2606 BDB::set_sync_prepare { 3786 $AnyEvent::BDB::WATCHER->priority (1);
2607 my $status;
2608 my $current = $Coro::current;
2609 (
2610 sub {
2611 $status = $!;
2612 $current->ready; undef $current;
2613 },
2614 sub {
2615 Coro::schedule while defined $current;
2616 $! = $status;
2617 },
2618 )
2619 };
2620 3787
2621 unless ($DB_ENV) { 3788 unless ($DB_ENV) {
2622 $DB_ENV = BDB::db_env_create; 3789 $DB_ENV = BDB::db_env_create;
3790 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3791 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
3792 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
3793 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3794 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
2623 3795
2624 cf::sync_job { 3796 cf::sync_job {
2625 eval { 3797 eval {
2626 BDB::db_env_open 3798 BDB::db_env_open
2627 $DB_ENV, 3799 $DB_ENV,
2628 $BDB_ENV_DIR, 3800 $BDBDIR,
2629 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3801 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2630 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3802 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2631 0666; 3803 0666;
2632 3804
2633 cf::cleanup "db_env_open($BDB_ENV_DIR): $!" if $!; 3805 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2634
2635 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2636 $DB_ENV->set_lk_detect;
2637 }; 3806 };
2638 3807
2639 cf::cleanup "db_env_open(db): $@" if $@; 3808 cf::cleanup "db_env_open(db): $@" if $@;
2640 }; 3809 };
2641 } 3810 }
3811
3812 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3813 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3814 };
3815 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3816 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3817 };
3818 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3819 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3820 };
2642} 3821}
2643 3822
2644{ 3823{
3824 # configure IO::AIO
3825
2645 IO::AIO::min_parallel 8; 3826 IO::AIO::min_parallel 8;
2646
2647 undef $Coro::AIO::WATCHER;
2648 IO::AIO::max_poll_time $TICK * 0.1; 3827 IO::AIO::max_poll_time $TICK * 0.1;
2649 $AIO_POLL_WATCHER = Event->io ( 3828 undef $AnyEvent::AIO::WATCHER;
2650 reentrant => 0,
2651 data => WF_AUTOCANCEL,
2652 fd => IO::AIO::poll_fileno,
2653 poll => 'r',
2654 prio => 6,
2655 cb => \&IO::AIO::poll_cb,
2656 );
2657} 3829}
3830
3831my $_log_backtrace;
3832
3833sub _log_backtrace {
3834 my ($msg, @addr) = @_;
3835
3836 $msg =~ s/\n//;
3837
3838 # limit the # of concurrent backtraces
3839 if ($_log_backtrace < 2) {
3840 ++$_log_backtrace;
3841 my $perl_bt = Carp::longmess $msg;
3842 async {
3843 $Coro::current->{desc} = "abt $msg";
3844
3845 my @bt = fork_call {
3846 @addr = map { sprintf "%x", $_ } @addr;
3847 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3848 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3849 or die "addr2line: $!";
3850
3851 my @funcs;
3852 my @res = <$fh>;
3853 chomp for @res;
3854 while (@res) {
3855 my ($func, $line) = splice @res, 0, 2, ();
3856 push @funcs, "[$func] $line";
3857 }
3858
3859 @funcs
3860 };
3861
3862 LOG llevInfo, "[ABT] $perl_bt\n";
3863 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
3864 LOG llevInfo, "[ABT] $_\n" for @bt;
3865 --$_log_backtrace;
3866 };
3867 } else {
3868 LOG llevInfo, "[ABT] $msg\n";
3869 LOG llevInfo, "[ABT] [suppressed]\n";
3870 }
3871}
3872
3873# load additional modules
3874use cf::pod;
2658 3875
2659END { cf::emergency_save } 3876END { cf::emergency_save }
2660 3877
26611 38781
2662 3879

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines