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

Diff Legend

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