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.310 by elmex, Mon Jul 16 15:43:49 2007 UTC vs.
Revision 1.407 by root, Sun Jan 13 09:53:53 2008 UTC

… …
4use strict; 4use strict;
5 5
6use Symbol; 6use Symbol;
7use List::Util; 7use List::Util;
8use Socket; 8use Socket;
9use Storable; 9use EV 1.86;
10use Event;
11use Opcode; 10use Opcode;
12use Safe; 11use Safe;
13use Safe::Hole; 12use Safe::Hole;
13use Storable ();
14 14
15use Coro 3.61 (); 15use Coro 4.32 ();
16use Coro::State; 16use Coro::State;
17use Coro::Handle; 17use Coro::Handle;
18use Coro::Event; 18use Coro::EV;
19use Coro::Timer; 19use Coro::Timer;
20use Coro::Signal; 20use Coro::Signal;
21use Coro::Semaphore; 21use Coro::Semaphore;
22use Coro::AIO; 22use Coro::AIO;
23use Coro::BDB;
23use Coro::Storable; 24use Coro::Storable;
25use Coro::Util ();
24 26
25use JSON::XS 1.4 (); 27use JSON::XS 2.01 ();
26use BDB (); 28use BDB ();
27use Data::Dumper; 29use Data::Dumper;
28use Digest::MD5; 30use Digest::MD5;
29use Fcntl; 31use Fcntl;
30use YAML::Syck (); 32use YAML::Syck ();
31use IO::AIO 2.32 (); 33use IO::AIO 2.51 ();
32use Time::HiRes; 34use Time::HiRes;
33use Compress::LZF; 35use Compress::LZF;
34use Digest::MD5 (); 36use Digest::MD5 ();
35 37
36# configure various modules to our taste 38# configure various modules to our taste
37# 39#
38$Storable::canonical = 1; # reduce rsync transfers 40$Storable::canonical = 1; # reduce rsync transfers
39Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 41Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
40Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 42Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
41
42$Event::Eval = 1; # no idea why this is required, but it is
43 43
44# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 44# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
45$YAML::Syck::ImplicitUnicode = 1; 45$YAML::Syck::ImplicitUnicode = 1;
46 46
47$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 47$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
… …
69our $TMPDIR = "$LOCALDIR/" . tmpdir; 69our $TMPDIR = "$LOCALDIR/" . tmpdir;
70our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 70our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
71our $PLAYERDIR = "$LOCALDIR/" . playerdir; 71our $PLAYERDIR = "$LOCALDIR/" . playerdir;
72our $RANDOMDIR = "$LOCALDIR/random"; 72our $RANDOMDIR = "$LOCALDIR/random";
73our $BDBDIR = "$LOCALDIR/db"; 73our $BDBDIR = "$LOCALDIR/db";
74our %RESOURCE;
74 75
75our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 76our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
76our $TICK_WATCHER; 77our $TICK_WATCHER;
77our $AIO_POLL_WATCHER; 78our $AIO_POLL_WATCHER;
78our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 79our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
79our $NEXT_TICK; 80our $NEXT_TICK;
80our $NOW;
81our $USE_FSYNC = 1; # use fsync to write maps - default off 81our $USE_FSYNC = 1; # use fsync to write maps - default off
82 82
83our $BDB_POLL_WATCHER; 83our $BDB_POLL_WATCHER;
84our $BDB_DEADLOCK_WATCHER;
85our $BDB_CHECKPOINT_WATCHER;
86our $BDB_TRICKLE_WATCHER;
84our $DB_ENV; 87our $DB_ENV;
85 88
86our %CFG; 89our %CFG;
87 90
88our $UPTIME; $UPTIME ||= time; 91our $UPTIME; $UPTIME ||= time;
89our $RUNTIME; 92our $RUNTIME;
93our $NOW;
90 94
91our %PLAYER; # all users 95our (%PLAYER, %PLAYER_LOADING); # all users
92our %MAP; # all maps 96our (%MAP, %MAP_LOADING ); # all maps
93our $LINK_MAP; # the special {link} map, which is always available 97our $LINK_MAP; # the special {link} map, which is always available
94 98
95# used to convert map paths into valid unix filenames by replacing / by ∕ 99# used to convert map paths into valid unix filenames by replacing / by ∕
96our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 100our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
97 101
… …
158 162
159The raw value load value from the last tick. 163The raw value load value from the last tick.
160 164
161=item %cf::CFG 165=item %cf::CFG
162 166
163Configuration for the server, loaded from C</etc/crossfire/config>, or 167Configuration for the server, loaded from C</etc/deliantra-server/config>, or
164from wherever your confdir points to. 168from wherever your confdir points to.
165 169
166=item cf::wait_for_tick, cf::wait_for_tick_begin 170=item cf::wait_for_tick, cf::wait_for_tick_begin
167 171
168These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 172These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
… …
186 $msg .= "\n" 190 $msg .= "\n"
187 unless $msg =~ /\n$/; 191 unless $msg =~ /\n$/;
188 192
189 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 193 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
190 194
191 utf8::encode $msg;
192 LOG llevError, $msg; 195 LOG llevError, $msg;
193 }; 196 };
194} 197}
198
199$Coro::State::DIEHOOK = sub {
200 warn Carp::longmess $_[0];
201 Coro::terminate;
202};
195 203
196@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 204@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
197@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 205@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
198@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 206@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
199@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 207@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
… …
212)) { 220)) {
213 no strict 'refs'; 221 no strict 'refs';
214 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 222 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
215} 223}
216 224
217$Event::DIED = sub { 225$EV::DIED = sub {
218 warn "error in event callback: @_"; 226 warn "error in event callback: @_";
219}; 227};
220 228
221############################################################################# 229#############################################################################
222 230
… …
245 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 253 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
246 $d 254 $d
247 } || "[unable to dump $_[0]: '$@']"; 255 } || "[unable to dump $_[0]: '$@']";
248} 256}
249 257
250=item $ref = cf::from_json $json 258=item $ref = cf::decode_json $json
251 259
252Converts a JSON string into the corresponding perl data structure. 260Converts a JSON string into the corresponding perl data structure.
253 261
254=item $json = cf::to_json $ref 262=item $json = cf::encode_json $ref
255 263
256Converts a perl data structure into its JSON representation. 264Converts a perl data structure into its JSON representation.
257 265
258=cut 266=cut
259 267
260our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max 268our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
261 269
262sub to_json ($) { $json_coder->encode ($_[0]) } 270sub encode_json($) { $json_coder->encode ($_[0]) }
263sub from_json ($) { $json_coder->decode ($_[0]) } 271sub decode_json($) { $json_coder->decode ($_[0]) }
264 272
265=item cf::lock_wait $string 273=item cf::lock_wait $string
266 274
267Wait until the given lock is available. See cf::lock_acquire. 275Wait until the given lock is available. See cf::lock_acquire.
268 276
… …
271Wait until the given lock is available and then acquires it and returns 279Wait until the given lock is available and then acquires it and returns
272a Coro::guard object. If the guard object gets destroyed (goes out of scope, 280a Coro::guard object. If the guard object gets destroyed (goes out of scope,
273for example when the coroutine gets canceled), the lock is automatically 281for example when the coroutine gets canceled), the lock is automatically
274returned. 282returned.
275 283
284Locks are *not* recursive, locking from the same coro twice results in a
285deadlocked coro.
286
276Lock names should begin with a unique identifier (for example, cf::map::find 287Lock names should begin with a unique identifier (for example, cf::map::find
277uses map_find and cf::map::load uses map_load). 288uses map_find and cf::map::load uses map_load).
278 289
279=item $locked = cf::lock_active $string 290=item $locked = cf::lock_active $string
280 291
281Return true if the lock is currently active, i.e. somebody has locked it. 292Return true if the lock is currently active, i.e. somebody has locked it.
282 293
283=cut 294=cut
284 295
285our %LOCK; 296our %LOCK;
297our %LOCKER;#d#
286 298
287sub lock_wait($) { 299sub lock_wait($) {
288 my ($key) = @_; 300 my ($key) = @_;
301
302 if ($LOCKER{$key} == $Coro::current) {#d#
303 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
304 return;#d#
305 }#d#
289 306
290 # wait for lock, if any 307 # wait for lock, if any
291 while ($LOCK{$key}) { 308 while ($LOCK{$key}) {
292 push @{ $LOCK{$key} }, $Coro::current; 309 push @{ $LOCK{$key} }, $Coro::current;
293 Coro::schedule; 310 Coro::schedule;
… …
299 316
300 # wait, to be sure we are not locked 317 # wait, to be sure we are not locked
301 lock_wait $key; 318 lock_wait $key;
302 319
303 $LOCK{$key} = []; 320 $LOCK{$key} = [];
321 $LOCKER{$key} = $Coro::current;#d#
304 322
305 Coro::guard { 323 Coro::guard {
324 delete $LOCKER{$key};#d#
306 # wake up all waiters, to be on the safe side 325 # wake up all waiters, to be on the safe side
307 $_->ready for @{ delete $LOCK{$key} }; 326 $_->ready for @{ delete $LOCK{$key} };
308 } 327 }
309} 328}
310 329
… …
322 }; 341 };
323 $TICK_WATCHER->stop; 342 $TICK_WATCHER->stop;
324 $guard 343 $guard
325} 344}
326 345
346=item cf::periodic $interval, $cb
347
348Like EV::periodic, but randomly selects a starting point so that the actions
349get spread over timer.
350
351=cut
352
353sub periodic($$) {
354 my ($interval, $cb) = @_;
355
356 my $start = rand List::Util::min 180, $interval;
357
358 EV::periodic $start, $interval, 0, $cb
359}
360
361=item cf::get_slot $time[, $priority[, $name]]
362
363Allocate $time seconds of blocking CPU time at priority C<$priority>:
364This call blocks and returns only when you have at least C<$time> seconds
365of cpu time till the next tick. The slot is only valid till the next cede.
366
367The optional C<$name> can be used to identify the job to run. It might be
368used for statistical purposes and should identify the same time-class.
369
370Useful for short background jobs.
371
372=cut
373
374our @SLOT_QUEUE;
375our $SLOT_QUEUE;
376
377$SLOT_QUEUE->cancel if $SLOT_QUEUE;
378$SLOT_QUEUE = Coro::async {
379 $Coro::current->desc ("timeslot manager");
380
381 my $signal = new Coro::Signal;
382
383 while () {
384 next_job:
385 my $avail = cf::till_tick;
386 if ($avail > 0.01) {
387 for (0 .. $#SLOT_QUEUE) {
388 if ($SLOT_QUEUE[$_][0] < $avail) {
389 my $job = splice @SLOT_QUEUE, $_, 1, ();
390 $job->[2]->send;
391 Coro::cede;
392 goto next_job;
393 }
394 }
395 }
396
397 if (@SLOT_QUEUE) {
398 # we do not use wait_for_tick() as it returns immediately when tick is inactive
399 push @cf::WAIT_FOR_TICK, $signal;
400 $signal->wait;
401 } else {
402 Coro::schedule;
403 }
404 }
405};
406
407sub get_slot($;$$) {
408 my ($time, $pri, $name) = @_;
409
410 $time = $TICK * .6 if $time > $TICK * .6;
411 my $sig = new Coro::Signal;
412
413 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
414 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
415 $SLOT_QUEUE->ready;
416 $sig->wait;
417}
418
327=item cf::async { BLOCK } 419=item cf::async { BLOCK }
328 420
329Currently the same as Coro::async_pool, meaning you cannot use 421Currently the same as Coro::async_pool, meaning you cannot use
330C<on_destroy>, C<join> or other gimmicks on these coroutines. The only 422C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
331thing you are allowed to do is call C<prio> on it. 423thing you are allowed to do is call C<prio> on it.
… …
334 426
335BEGIN { *async = \&Coro::async_pool } 427BEGIN { *async = \&Coro::async_pool }
336 428
337=item cf::sync_job { BLOCK } 429=item cf::sync_job { BLOCK }
338 430
339The design of Crossfire TRT requires that the main coroutine ($Coro::main) 431The design of Deliantra requires that the main coroutine ($Coro::main)
340is always able to handle events or runnable, as Crossfire TRT is only 432is always able to handle events or runnable, as Deliantra is only
341partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not 433partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
342acceptable. 434acceptable.
343 435
344If it must be done, put the blocking parts into C<sync_job>. This will run 436If it must be done, put the blocking parts into C<sync_job>. This will run
345the given BLOCK in another coroutine while waiting for the result. The 437the given BLOCK in another coroutine while waiting for the result. The
… …
350 442
351sub sync_job(&) { 443sub sync_job(&) {
352 my ($job) = @_; 444 my ($job) = @_;
353 445
354 if ($Coro::current == $Coro::main) { 446 if ($Coro::current == $Coro::main) {
355 my $time = Event::time; 447 my $time = EV::time;
356 448
357 # this is the main coro, too bad, we have to block 449 # this is the main coro, too bad, we have to block
358 # till the operation succeeds, freezing the server :/ 450 # till the operation succeeds, freezing the server :/
359 451
452 LOG llevError, Carp::longmess "sync job";#d#
453
360 # TODO: use suspend/resume instead 454 # TODO: use suspend/resume instead
361 # (but this is cancel-safe) 455 # (but this is cancel-safe)
362 my $freeze_guard = freeze_mainloop; 456 my $freeze_guard = freeze_mainloop;
363 457
364 my $busy = 1; 458 my $busy = 1;
365 my @res; 459 my @res;
366 460
367 (async { 461 (async {
462 $Coro::current->desc ("sync job coro");
368 @res = eval { $job->() }; 463 @res = eval { $job->() };
369 warn $@ if $@; 464 warn $@ if $@;
370 undef $busy; 465 undef $busy;
371 })->prio (Coro::PRIO_MAX); 466 })->prio (Coro::PRIO_MAX);
372 467
373 while ($busy) { 468 while ($busy) {
374 Coro::cede or Event::one_event; 469 if (Coro::nready) {
470 Coro::cede_notself;
471 } else {
472 EV::loop EV::LOOP_ONESHOT;
375 } 473 }
474 }
376 475
377 $time = Event::time - $time; 476 $time = EV::time - $time;
378 477
379 LOG llevError | logBacktrace, Carp::longmess "long sync job" 478 LOG llevError | logBacktrace, Carp::longmess "long sync job"
380 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active; 479 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
381 480
382 $tick_start += $time; # do not account sync jobs to server load 481 $tick_start += $time; # do not account sync jobs to server load
… …
412=item fork_call { }, $args 511=item fork_call { }, $args
413 512
414Executes the given code block with the given arguments in a seperate 513Executes the given code block with the given arguments in a seperate
415process, returning the results. Everything must be serialisable with 514process, returning the results. Everything must be serialisable with
416Coro::Storable. May, of course, block. Note that the executed sub may 515Coro::Storable. May, of course, block. Note that the executed sub may
417never block itself or use any form of Event handling. 516never block itself or use any form of event handling.
418 517
419=cut 518=cut
420
421sub _store_scalar {
422 open my $fh, ">", \my $buf
423 or die "fork_call: cannot open fh-to-buf in child : $!";
424 Storable::store_fd $_[0], $fh;
425 close $fh;
426
427 $buf
428}
429 519
430sub fork_call(&@) { 520sub fork_call(&@) {
431 my ($cb, @args) = @_; 521 my ($cb, @args) = @_;
432 522
433# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC 523 # we seemingly have to make a local copy of the whole thing,
434# or die "socketpair: $!"; 524 # otherwise perl prematurely frees the stuff :/
435 pipe my $fh1, my $fh2 525 # TODO: investigate and fix (likely this will be rather laborious)
436 or die "pipe: $!";
437 526
438 if (my $pid = fork) { 527 my @res = Coro::Util::fork_eval {
439 close $fh2;
440
441 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
442 warn "pst<$res>" unless $res =~ /^pst/;
443 $res = Coro::Storable::thaw $res;
444
445 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
446
447 Carp::confess $$res unless "ARRAY" eq ref $res;
448
449 return wantarray ? @$res : $res->[-1];
450 } else {
451 reset_signals; 528 reset_signals;
452 local $SIG{__WARN__}; 529 &$cb
453 local $SIG{__DIE__}; 530 }, @args;
454 # just in case, this hack effectively disables event
455 # in the child. cleaner and slower would be canceling all watchers,
456 # but this works for the time being.
457 local $Coro::idle;
458 $Coro::current->prio (Coro::PRIO_MAX);
459 531
460 eval { 532 wantarray ? @res : $res[-1]
461 close $fh1;
462
463 my @res = eval { $cb->(@args) };
464
465 syswrite $fh2, _store_scalar $@ ? \"$@" : \@res;
466 close $fh2;
467 };
468
469 warn $@ if $@;
470 _exit 0;
471 }
472} 533}
473 534
474=item $value = cf::db_get $family => $key 535=item $value = cf::db_get $family => $key
475 536
476Returns a single value from the environment database. 537Returns a single value from the environment database.
… …
478=item cf::db_put $family => $key => $value 539=item cf::db_put $family => $key => $value
479 540
480Stores the given C<$value> in the family. It can currently store binary 541Stores the given C<$value> in the family. It can currently store binary
481data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary). 542data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
482 543
544=item $db = cf::db_table "name"
545
546Create and/or open a new database table. The string must not be "db" and must be unique
547within each server.
548
483=cut 549=cut
550
551sub db_table($) {
552 my ($name) = @_;
553 my $db = BDB::db_create $DB_ENV;
554
555 eval {
556 $db->set_flags (BDB::CHKSUM);
557
558 utf8::encode $name;
559 BDB::db_open $db, undef, $name, undef, BDB::BTREE,
560 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
561 cf::cleanup "db_open(db): $!" if $!;
562 };
563 cf::cleanup "db_open(db): $@" if $@;
564
565 $db
566}
484 567
485our $DB; 568our $DB;
486 569
487sub db_init { 570sub db_init {
488 unless ($DB) {
489 $DB = BDB::db_create $DB_ENV;
490
491 cf::sync_job { 571 cf::sync_job {
492 eval { 572 $DB ||= db_table "db";
493 $DB->set_flags (BDB::CHKSUM);
494
495 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
496 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
497 cf::cleanup "db_open(db): $!" if $!;
498 };
499 cf::cleanup "db_open(db): $@" if $@;
500 };
501 } 573 };
502} 574}
503 575
504sub db_get($$) { 576sub db_get($$) {
505 my $key = "$_[0]/$_[1]"; 577 my $key = "$_[0]/$_[1]";
506 578
… …
556 if (1) { 628 if (1) {
557 $md5 = 629 $md5 =
558 join "\x00", 630 join "\x00",
559 $processversion, 631 $processversion,
560 map { 632 map {
561 Coro::cede; 633 cf::cede_to_tick;
562 ($src->[$_], Digest::MD5::md5_hex $data[$_]) 634 ($src->[$_], Digest::MD5::md5_hex $data[$_])
563 } 0.. $#$src; 635 } 0.. $#$src;
564 636
565 637
566 my $dbmd5 = db_get cache => "$id/md5"; 638 my $dbmd5 = db_get cache => "$id/md5";
… …
610attach callbacks/event handlers (a collection of which is called an "attachment") 682attach callbacks/event handlers (a collection of which is called an "attachment")
611to it. All such attachable objects support the following methods. 683to it. All such attachable objects support the following methods.
612 684
613In the following description, CLASS can be any of C<global>, C<object> 685In the following description, CLASS can be any of C<global>, C<object>
614C<player>, C<client> or C<map> (i.e. the attachable objects in 686C<player>, C<client> or C<map> (i.e. the attachable objects in
615Crossfire TRT). 687Deliantra).
616 688
617=over 4 689=over 4
618 690
619=item $attachable->attach ($attachment, key => $value...) 691=item $attachable->attach ($attachment, key => $value...)
620 692
… …
902 } 974 }
903 975
904 0 976 0
905} 977}
906 978
907=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 979=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
908 980
909=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 981=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
910 982
911Generate an object-specific event with the given arguments. 983Generate an object-specific event with the given arguments.
912 984
… …
918 990
919=cut 991=cut
920 992
921############################################################################# 993#############################################################################
922# object support 994# object support
995
996sub _object_equal($$);
997sub _object_equal($$) {
998 my ($a, $b) = @_;
999
1000 return 0 unless (ref $a) eq (ref $b);
1001
1002 if ("HASH" eq ref $a) {
1003 my @ka = keys %$a;
1004 my @kb = keys %$b;
1005
1006 return 0 if @ka != @kb;
1007
1008 for (0 .. $#ka) {
1009 return 0 unless $ka[$_] eq $kb[$_];
1010 return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
1011 }
1012
1013 } elsif ("ARRAY" eq ref $a) {
1014
1015 return 0 if @$a != @$b;
1016
1017 for (0 .. $#$a) {
1018 return 0 unless _object_equal $a->[$_], $b->[$_];
1019 }
1020
1021 } elsif ($a ne $b) {
1022 return 0;
1023 }
1024
1025 1
1026}
1027
1028our $SLOW_MERGES;#d#
1029sub _can_merge {
1030 my ($ob1, $ob2) = @_;
1031
1032 ++$SLOW_MERGES;#d#
1033
1034 # we do the slow way here
1035 return _object_equal $ob1, $ob2
1036}
923 1037
924sub reattach { 1038sub reattach {
925 # basically do the same as instantiate, without calling instantiate 1039 # basically do the same as instantiate, without calling instantiate
926 my ($obj) = @_; 1040 my ($obj) = @_;
927 1041
… …
948cf::attachable->attach ( 1062cf::attachable->attach (
949 prio => -1000000, 1063 prio => -1000000,
950 on_instantiate => sub { 1064 on_instantiate => sub {
951 my ($obj, $data) = @_; 1065 my ($obj, $data) = @_;
952 1066
953 $data = from_json $data; 1067 $data = decode_json $data;
954 1068
955 for (@$data) { 1069 for (@$data) {
956 my ($name, $args) = @$_; 1070 my ($name, $args) = @$_;
957 1071
958 $obj->attach ($name, %{$args || {} }); 1072 $obj->attach ($name, %{$args || {} });
… …
974sub object_freezer_save { 1088sub object_freezer_save {
975 my ($filename, $rdata, $objs) = @_; 1089 my ($filename, $rdata, $objs) = @_;
976 1090
977 sync_job { 1091 sync_job {
978 if (length $$rdata) { 1092 if (length $$rdata) {
1093 utf8::decode (my $decname = $filename);
979 warn sprintf "saving %s (%d,%d)\n", 1094 warn sprintf "saving %s (%d,%d)\n",
980 $filename, length $$rdata, scalar @$objs; 1095 $decname, length $$rdata, scalar @$objs;
981 1096
982 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1097 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
983 chmod SAVE_MODE, $fh; 1098 chmod SAVE_MODE, $fh;
984 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1099 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
985 aio_fsync $fh if $cf::USE_FSYNC; 1100 aio_fsync $fh if $cf::USE_FSYNC;
986 close $fh; 1101 close $fh;
987 1102
988 if (@$objs) { 1103 if (@$objs) {
989 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1104 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
990 chmod SAVE_MODE, $fh; 1105 chmod SAVE_MODE, $fh;
991 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1106 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
992 aio_write $fh, 0, (length $data), $data, 0; 1107 aio_write $fh, 0, (length $data), $data, 0;
993 aio_fsync $fh if $cf::USE_FSYNC; 1108 aio_fsync $fh if $cf::USE_FSYNC;
994 close $fh; 1109 close $fh;
995 aio_rename "$filename.pst~", "$filename.pst"; 1110 aio_rename "$filename.pst~", "$filename.pst";
996 } 1111 }
… …
1004 } 1119 }
1005 } else { 1120 } else {
1006 aio_unlink $filename; 1121 aio_unlink $filename;
1007 aio_unlink "$filename.pst"; 1122 aio_unlink "$filename.pst";
1008 } 1123 }
1009 } 1124 };
1010} 1125}
1011 1126
1012sub object_freezer_as_string { 1127sub object_freezer_as_string {
1013 my ($rdata, $objs) = @_; 1128 my ($rdata, $objs) = @_;
1014 1129
… …
1026 or return; 1141 or return;
1027 1142
1028 unless (aio_stat "$filename.pst") { 1143 unless (aio_stat "$filename.pst") {
1029 (aio_load "$filename.pst", $av) >= 0 1144 (aio_load "$filename.pst", $av) >= 0
1030 or return; 1145 or return;
1146
1031 $av = eval { (Storable::thaw $av)->{objs} }; 1147 my $st = eval { Coro::Storable::thaw $av };
1148 $av = $st->{objs};
1032 } 1149 }
1033 1150
1151 utf8::decode (my $decname = $filename);
1034 warn sprintf "loading %s (%d)\n", 1152 warn sprintf "loading %s (%d,%d)\n",
1035 $filename, length $data, scalar @{$av || []}; 1153 $decname, length $data, scalar @{$av || []};
1154
1036 return ($data, $av); 1155 ($data, $av)
1037} 1156}
1038 1157
1039=head2 COMMAND CALLBACKS 1158=head2 COMMAND CALLBACKS
1040 1159
1041=over 4 1160=over 4
… …
1114 my ($pl, $buf) = @_; 1233 my ($pl, $buf) = @_;
1115 1234
1116 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) }; 1235 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1117 1236
1118 if (ref $msg) { 1237 if (ref $msg) {
1238 my ($type, $reply, @payload) =
1239 "ARRAY" eq ref $msg
1240 ? @$msg
1241 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1242
1243 my @reply;
1244
1119 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1245 if (my $cb = $EXTCMD{$type}) {
1120 if (my %reply = $cb->($pl, $msg)) { 1246 @reply = $cb->($pl, @payload);
1121 $pl->ext_reply ($msg->{msgid}, %reply);
1122 }
1123 } 1247 }
1248
1249 $pl->ext_reply ($reply, @reply)
1250 if $reply;
1251
1124 } else { 1252 } else {
1125 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1253 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1126 } 1254 }
1127 1255
1128 cf::override; 1256 cf::override;
… …
1218 1346
1219=head3 cf::player 1347=head3 cf::player
1220 1348
1221=over 4 1349=over 4
1222 1350
1351=item cf::player::num_playing
1352
1353Returns the official number of playing players, as per the Crossfire metaserver rules.
1354
1355=cut
1356
1357sub num_playing {
1358 scalar grep
1359 $_->ob->map
1360 && !$_->hidden
1361 && !$_->ob->flag (cf::FLAG_WIZ),
1362 cf::player::list
1363}
1364
1223=item cf::player::find $login 1365=item cf::player::find $login
1224 1366
1225Returns the given player object, loading it if necessary (might block). 1367Returns the given player object, loading it if necessary (might block).
1226 1368
1227=cut 1369=cut
… …
1262 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst"; 1404 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1263 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata"; 1405 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1264 aio_unlink +(playerdir $login) . "/$login.pl.pst"; 1406 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1265 aio_unlink +(playerdir $login) . "/$login.pl"; 1407 aio_unlink +(playerdir $login) . "/$login.pl";
1266 1408
1267 my $pl = load_pl path $login 1409 my $f = new_from_file cf::object::thawer path $login
1268 or return; 1410 or return;
1411
1412 my $pl = cf::player::load_pl $f
1413 or return;
1414 local $cf::PLAYER_LOADING{$login} = $pl;
1415 $f->resolve_delayed_derefs;
1269 $cf::PLAYER{$login} = $pl 1416 $cf::PLAYER{$login} = $pl
1270 } 1417 }
1271 } 1418 }
1272} 1419}
1273 1420
… …
1283 1430
1284 aio_mkdir playerdir $pl, 0770; 1431 aio_mkdir playerdir $pl, 0770;
1285 $pl->{last_save} = $cf::RUNTIME; 1432 $pl->{last_save} = $cf::RUNTIME;
1286 1433
1287 $pl->save_pl ($path); 1434 $pl->save_pl ($path);
1288 Coro::cede; 1435 cf::cede_to_tick;
1289} 1436}
1290 1437
1291sub new($) { 1438sub new($) {
1292 my ($login) = @_; 1439 my ($login) = @_;
1293 1440
… …
1297 $self->{deny_save} = 1; 1444 $self->{deny_save} = 1;
1298 1445
1299 $cf::PLAYER{$login} = $self; 1446 $cf::PLAYER{$login} = $self;
1300 1447
1301 $self 1448 $self
1449}
1450
1451=item $player->send_msg ($channel, $msg, $color, [extra...])
1452
1453=cut
1454
1455sub send_msg {
1456 my $ns = shift->ns
1457 or return;
1458 $ns->send_msg (@_);
1302} 1459}
1303 1460
1304=item $pl->quit_character 1461=item $pl->quit_character
1305 1462
1306Nukes the player without looking back. If logged in, the connection will 1463Nukes the player without looking back. If logged in, the connection will
… …
1361 or return []; 1518 or return [];
1362 1519
1363 my @logins; 1520 my @logins;
1364 1521
1365 for my $login (@$dirs) { 1522 for my $login (@$dirs) {
1523 my $path = path $login;
1524
1525 # a .pst is a dead give-away for a valid player
1526 unless (-e "$path.pst") {
1366 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1527 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1367 aio_read $fh, 0, 512, my $buf, 0 or next; 1528 aio_read $fh, 0, 512, my $buf, 0 or next;
1368 $buf !~ /^password -------------$/m or next; # official not-valid tag 1529 $buf !~ /^password -------------$/m or next; # official not-valid tag
1530 }
1369 1531
1370 utf8::decode $login; 1532 utf8::decode $login;
1371 push @logins, $login; 1533 push @logins, $login;
1372 } 1534 }
1373 1535
… …
1406 1568
1407Expand crossfire pod fragments into protocol xml. 1569Expand crossfire pod fragments into protocol xml.
1408 1570
1409=cut 1571=cut
1410 1572
1573use re 'eval';
1574
1575my $group;
1576my $interior; $interior = qr{
1577 # match a pod interior sequence sans C<< >>
1578 (?:
1579 \ (.*?)\ (?{ $group = $^N })
1580 | < (??{$interior}) >
1581 )
1582}x;
1583
1411sub expand_cfpod { 1584sub expand_cfpod {
1412 ((my $self), (local $_)) = @_; 1585 my ($self, $pod) = @_;
1413 1586
1414 # escape & and < 1587 my $xml;
1415 s/&/&amp;/g;
1416 s/(?<![BIUGH])</&lt;/g;
1417 1588
1418 # this is buggy, it needs to properly take care of nested <'s 1589 while () {
1590 if ($pod =~ /\G( (?: [^BCGHITU]+ | .(?!<) )+ )/xgcs) {
1591 $group = $1;
1419 1592
1420 1 while 1593 $group =~ s/&/&amp;/g;
1421 # replace B<>, I<>, U<> etc. 1594 $group =~ s/</&lt;/g;
1422 s/B<([^\>]*)>/<b>$1<\/b>/ 1595
1423 || s/I<([^\>]*)>/<i>$1<\/i>/ 1596 $xml .= $group;
1424 || s/U<([^\>]*)>/<u>$1<\/u>/ 1597 } elsif ($pod =~ m%\G
1425 # replace G<male|female> tags 1598 ([BCGHITU])
1426 || s{G<([^>|]*)\|([^>]*)>}{ 1599 <
1427 $self->gender ? $2 : $1 1600 (?:
1428 }ge 1601 ([^<>]*) (?{ $group = $^N })
1429 # replace H<hint text> 1602 | < $interior >
1430 || s{H<([^\>]*)>} 1603 )
1604 >
1605 %gcsx
1431 { 1606 ) {
1607 my ($code, $data) = ($1, $group);
1608
1609 if ($code eq "B") {
1610 $xml .= "<b>" . expand_cfpod ($self, $data) . "</b>";
1611 } elsif ($code eq "I") {
1612 $xml .= "<i>" . expand_cfpod ($self, $data) . "</i>";
1613 } elsif ($code eq "U") {
1614 $xml .= "<u>" . expand_cfpod ($self, $data) . "</u>";
1615 } elsif ($code eq "C") {
1616 $xml .= "<tt>" . expand_cfpod ($self, $data) . "</tt>";
1617 } elsif ($code eq "T") {
1618 $xml .= "<big><b>" . expand_cfpod ($self, $data) . "</b></big>";
1619 } elsif ($code eq "G") {
1620 my ($male, $female) = split /\|/, $data;
1621 $data = $self->gender ? $female : $male;
1622 $xml .= expand_cfpod ($self, $data);
1623 } elsif ($code eq "H") {
1432 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>", 1624 $xml .= ("<fg name=\"lightblue\">[" . expand_cfpod ($self, $data) . " (Use hintmode to suppress hints)]</fg>",
1433 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>", 1625 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1434 "") 1626 "")
1435 [$self->{hintmode}] 1627 [$self->{hintmode}];
1628 } else {
1629 $xml .= "error processing '$code($data)' directive";
1436 }ge; 1630 }
1631 } else {
1632 if ($pod =~ /\G(.+)/) {
1633 warn "parse error while expanding $pod (at $1)";
1634 }
1635 last;
1636 }
1637 }
1437 1638
1639 for ($xml) {
1438 # create single paragraphs (very hackish) 1640 # create single paragraphs (very hackish)
1439 s/(?<=\S)\n(?=\w)/ /g; 1641 s/(?<=\S)\n(?=\w)/ /g;
1440 1642
1441 # compress some whitespace 1643 # compress some whitespace
1442 s/\s+\n/\n/g; # ws line-ends 1644 s/\s+\n/\n/g; # ws line-ends
1443 s/\n\n+/\n/g; # double lines 1645 s/\n\n+/\n/g; # double lines
1444 s/^\n+//; # beginning lines 1646 s/^\n+//; # beginning lines
1445 s/\n+$//; # ending lines 1647 s/\n+$//; # ending lines
1648 }
1446 1649
1447 $_ 1650 $xml
1448} 1651}
1652
1653no re 'eval';
1449 1654
1450sub hintmode { 1655sub hintmode {
1451 $_[0]{hintmode} = $_[1] if @_ > 1; 1656 $_[0]{hintmode} = $_[1] if @_ > 1;
1452 $_[0]{hintmode} 1657 $_[0]{hintmode}
1453} 1658}
1454 1659
1455=item $player->ext_reply ($msgid, %msg) 1660=item $player->ext_reply ($msgid, @msg)
1456 1661
1457Sends an ext reply to the player. 1662Sends an ext reply to the player.
1458 1663
1459=cut 1664=cut
1460 1665
1461sub ext_reply($$%) { 1666sub ext_reply($$@) {
1462 my ($self, $id, %msg) = @_; 1667 my ($self, $id, @msg) = @_;
1463 1668
1464 $msg{msgid} = $id; 1669 $self->ns->ext_reply ($id, @msg)
1465 $self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));
1466} 1670}
1467 1671
1468=item $player->ext_event ($type, %msg) 1672=item $player->ext_msg ($type, @msg)
1469 1673
1470Sends an ext event to the client. 1674Sends an ext event to the client.
1471 1675
1472=cut 1676=cut
1473 1677
1474sub ext_event($$%) { 1678sub ext_msg($$@) {
1475 my ($self, $type, %msg) = @_; 1679 my ($self, $type, @msg) = @_;
1476 1680
1477 $self->ns->ext_event ($type, %msg); 1681 $self->ns->ext_msg ($type, @msg);
1478} 1682}
1479 1683
1480=head3 cf::region 1684=head3 cf::region
1481 1685
1482=over 4 1686=over 4
… …
1698 1902
1699sub load_header_from($) { 1903sub load_header_from($) {
1700 my ($self, $path) = @_; 1904 my ($self, $path) = @_;
1701 1905
1702 utf8::encode $path; 1906 utf8::encode $path;
1703 #aio_open $path, O_RDONLY, 0 1907 my $f = new_from_file cf::object::thawer $path
1704 # or return;
1705
1706 $self->_load_header ($path)
1707 or return; 1908 or return;
1909
1910 $self->_load_header ($f)
1911 or return;
1912
1913 local $MAP_LOADING{$self->{path}} = $self;
1914 $f->resolve_delayed_derefs;
1708 1915
1709 $self->{load_path} = $path; 1916 $self->{load_path} = $path;
1710 1917
1711 1 1918 1
1712} 1919}
… …
1766sub find { 1973sub find {
1767 my ($path, $origin) = @_; 1974 my ($path, $origin) = @_;
1768 1975
1769 $path = normalise $path, $origin && $origin->path; 1976 $path = normalise $path, $origin && $origin->path;
1770 1977
1978 cf::lock_wait "map_data:$path";#d#remove
1771 cf::lock_wait "map_find:$path"; 1979 cf::lock_wait "map_find:$path";
1772 1980
1773 $cf::MAP{$path} || do { 1981 $cf::MAP{$path} || do {
1774 my $guard = cf::lock_acquire "map_find:$path"; 1982 my $guard1 = cf::lock_acquire "map_find:$path";
1983 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1984
1775 my $map = new_from_path cf::map $path 1985 my $map = new_from_path cf::map $path
1776 or return; 1986 or return;
1777 1987
1778 $map->{last_save} = $cf::RUNTIME; 1988 $map->{last_save} = $cf::RUNTIME;
1779 1989
… …
1781 or return; 1991 or return;
1782 1992
1783 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 1993 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1784 # doing this can freeze the server in a sync job, obviously 1994 # doing this can freeze the server in a sync job, obviously
1785 #$cf::WAIT_FOR_TICK->wait; 1995 #$cf::WAIT_FOR_TICK->wait;
1996 undef $guard1;
1997 undef $guard2;
1786 $map->reset; 1998 $map->reset;
1787 undef $guard;
1788 return find $path; 1999 return find $path;
1789 } 2000 }
1790 2001
1791 $cf::MAP{$path} = $map 2002 $cf::MAP{$path} = $map
1792 } 2003 }
… …
1801 local $self->{deny_reset} = 1; # loading can take a long time 2012 local $self->{deny_reset} = 1; # loading can take a long time
1802 2013
1803 my $path = $self->{path}; 2014 my $path = $self->{path};
1804 2015
1805 { 2016 {
1806 my $guard = cf::lock_acquire "map_load:$path"; 2017 my $guard = cf::lock_acquire "map_data:$path";
1807 2018
2019 return unless $self->valid;
1808 return if $self->in_memory != cf::MAP_SWAPPED; 2020 return unless $self->in_memory == cf::MAP_SWAPPED;
1809 2021
1810 $self->in_memory (cf::MAP_LOADING); 2022 $self->in_memory (cf::MAP_LOADING);
1811 2023
1812 $self->alloc; 2024 $self->alloc;
1813 2025
1814 $self->pre_load; 2026 $self->pre_load;
1815 Coro::cede; 2027 cf::cede_to_tick;
1816 2028
2029 my $f = new_from_file cf::object::thawer $self->{load_path};
2030 $f->skip_block;
1817 $self->_load_objects ($self->{load_path}, 1) 2031 $self->_load_objects ($f)
1818 or return; 2032 or return;
1819 2033
1820 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2034 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1821 if delete $self->{load_original}; 2035 if delete $self->{load_original};
1822 2036
1823 if (my $uniq = $self->uniq_path) { 2037 if (my $uniq = $self->uniq_path) {
1824 utf8::encode $uniq; 2038 utf8::encode $uniq;
1825 if (aio_open $uniq, O_RDONLY, 0) { 2039 unless (aio_stat $uniq) {
2040 if (my $f = new_from_file cf::object::thawer $uniq) {
1826 $self->clear_unique_items; 2041 $self->clear_unique_items;
1827 $self->_load_objects ($uniq, 0); 2042 $self->_load_objects ($f);
2043 $f->resolve_delayed_derefs;
2044 }
1828 } 2045 }
1829 } 2046 }
1830 2047
1831 Coro::cede; 2048 $f->resolve_delayed_derefs;
2049
2050 cf::cede_to_tick;
1832 # now do the right thing for maps 2051 # now do the right thing for maps
1833 $self->link_multipart_objects; 2052 $self->link_multipart_objects;
1834 $self->difficulty ($self->estimate_difficulty) 2053 $self->difficulty ($self->estimate_difficulty)
1835 unless $self->difficulty; 2054 unless $self->difficulty;
1836 Coro::cede; 2055 cf::cede_to_tick;
1837 2056
1838 unless ($self->{deny_activate}) { 2057 unless ($self->{deny_activate}) {
1839 $self->decay_objects; 2058 $self->decay_objects;
1840 $self->fix_auto_apply; 2059 $self->fix_auto_apply;
1841 $self->update_buttons; 2060 $self->update_buttons;
1842 Coro::cede; 2061 cf::cede_to_tick;
1843 $self->set_darkness_map; 2062 $self->set_darkness_map;
1844 Coro::cede; 2063 cf::cede_to_tick;
1845 $self->activate; 2064 $self->activate;
1846 } 2065 }
2066
2067 $self->{last_save} = $cf::RUNTIME;
2068 $self->last_access ($cf::RUNTIME);
1847 2069
1848 $self->in_memory (cf::MAP_IN_MEMORY); 2070 $self->in_memory (cf::MAP_IN_MEMORY);
1849 } 2071 }
1850 2072
1851 $self->post_load; 2073 $self->post_load;
… …
1862 2084
1863 $self 2085 $self
1864} 2086}
1865 2087
1866# find and load all maps in the 3x3 area around a map 2088# find and load all maps in the 3x3 area around a map
1867sub load_diag { 2089sub load_neighbours {
1868 my ($map) = @_; 2090 my ($map) = @_;
1869 2091
1870 my @diag; # diagonal neighbours 2092 my @neigh; # diagonal neighbours
1871 2093
1872 for (0 .. 3) { 2094 for (0 .. 3) {
1873 my $neigh = $map->tile_path ($_) 2095 my $neigh = $map->tile_path ($_)
1874 or next; 2096 or next;
1875 $neigh = find $neigh, $map 2097 $neigh = find $neigh, $map
1876 or next; 2098 or next;
1877 $neigh->load; 2099 $neigh->load;
1878 2100
2101 push @neigh,
1879 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 2102 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1880 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2103 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1881 } 2104 }
1882 2105
1883 for (@diag) { 2106 for (grep defined $_->[0], @neigh) {
2107 my ($path, $origin) = @$_;
1884 my $neigh = find @$_ 2108 my $neigh = find $path, $origin
1885 or next; 2109 or next;
1886 $neigh->load; 2110 $neigh->load;
1887 } 2111 }
1888} 2112}
1889 2113
… …
1894} 2118}
1895 2119
1896sub do_load_sync { 2120sub do_load_sync {
1897 my ($map) = @_; 2121 my ($map) = @_;
1898 2122
2123 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
2124 if $Coro::current == $Coro::main;
2125
1899 cf::sync_job { $map->load }; 2126 cf::sync_job { $map->load };
1900} 2127}
1901 2128
1902our %MAP_PREFETCH; 2129our %MAP_PREFETCH;
1903our $MAP_PREFETCHER = undef; 2130our $MAP_PREFETCHER = undef;
1904 2131
1905sub find_async { 2132sub find_async {
1906 my ($path, $origin) = @_; 2133 my ($path, $origin, $load) = @_;
1907 2134
1908 $path = normalise $path, $origin && $origin->{path}; 2135 $path = normalise $path, $origin && $origin->{path};
1909 2136
1910 if (my $map = $cf::MAP{$path}) { 2137 if (my $map = $cf::MAP{$path}) {
1911 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 2138 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY;
1912 } 2139 }
1913 2140
1914 undef $MAP_PREFETCH{$path}; 2141 $MAP_PREFETCH{$path} |= $load;
2142
1915 $MAP_PREFETCHER ||= cf::async { 2143 $MAP_PREFETCHER ||= cf::async {
2144 $Coro::current->{desc} = "map prefetcher";
2145
1916 while (%MAP_PREFETCH) { 2146 while (%MAP_PREFETCH) {
1917 for my $path (keys %MAP_PREFETCH) { 2147 while (my ($k, $v) = each %MAP_PREFETCH) {
1918 if (my $map = find $path) { 2148 if (my $map = find $k) {
1919 $map->load; 2149 $map->load if $v;
1920 } 2150 }
1921 2151
1922 delete $MAP_PREFETCH{$path}; 2152 delete $MAP_PREFETCH{$k};
1923 } 2153 }
1924 } 2154 }
1925 undef $MAP_PREFETCHER; 2155 undef $MAP_PREFETCHER;
1926 }; 2156 };
1927 $MAP_PREFETCHER->prio (6); 2157 $MAP_PREFETCHER->prio (6);
… …
1930} 2160}
1931 2161
1932sub save { 2162sub save {
1933 my ($self) = @_; 2163 my ($self) = @_;
1934 2164
1935 my $lock = cf::lock_acquire "map_data:" . $self->path; 2165 my $lock = cf::lock_acquire "map_data:$self->{path}";
1936 2166
1937 $self->{last_save} = $cf::RUNTIME; 2167 $self->{last_save} = $cf::RUNTIME;
1938 2168
1939 return unless $self->dirty; 2169 return unless $self->dirty;
1940 2170
… …
1946 return if $self->{deny_save}; 2176 return if $self->{deny_save};
1947 2177
1948 local $self->{last_access} = $self->last_access;#d# 2178 local $self->{last_access} = $self->last_access;#d#
1949 2179
1950 cf::async { 2180 cf::async {
2181 $Coro::current->{desc} = "map player save";
1951 $_->contr->save for $self->players; 2182 $_->contr->save for $self->players;
1952 }; 2183 };
1953 2184
1954 if ($uniq) { 2185 if ($uniq) {
1955 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2186 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
… …
1963 my ($self) = @_; 2194 my ($self) = @_;
1964 2195
1965 # save first because save cedes 2196 # save first because save cedes
1966 $self->save; 2197 $self->save;
1967 2198
1968 my $lock = cf::lock_acquire "map_data:" . $self->path; 2199 my $lock = cf::lock_acquire "map_data:$self->{path}";
1969 2200
1970 return if $self->players; 2201 return if $self->players;
1971 return if $self->in_memory != cf::MAP_IN_MEMORY; 2202 return if $self->in_memory != cf::MAP_IN_MEMORY;
1972 return if $self->{deny_save}; 2203 return if $self->{deny_save};
1973 2204
2205 $self->in_memory (cf::MAP_SWAPPED);
2206
2207 $self->deactivate;
2208 $_->clear_links_to ($self) for values %cf::MAP;
1974 $self->clear; 2209 $self->clear;
1975 $self->in_memory (cf::MAP_SWAPPED);
1976} 2210}
1977 2211
1978sub reset_at { 2212sub reset_at {
1979 my ($self) = @_; 2213 my ($self) = @_;
1980 2214
… …
2012 if $uniq; 2246 if $uniq;
2013 } 2247 }
2014 2248
2015 delete $cf::MAP{$self->path}; 2249 delete $cf::MAP{$self->path};
2016 2250
2251 $self->deactivate;
2252 $_->clear_links_to ($self) for values %cf::MAP;
2017 $self->clear; 2253 $self->clear;
2018
2019 $_->clear_links_to ($self) for values %cf::MAP;
2020 2254
2021 $self->unlink_save; 2255 $self->unlink_save;
2022 $self->destroy; 2256 $self->destroy;
2023} 2257}
2024 2258
2025my $nuke_counter = "aaaa"; 2259my $nuke_counter = "aaaa";
2026 2260
2027sub nuke { 2261sub nuke {
2028 my ($self) = @_; 2262 my ($self) = @_;
2029 2263
2264 {
2265 my $lock = cf::lock_acquire "map_data:$self->{path}";
2266
2030 delete $cf::MAP{$self->path}; 2267 delete $cf::MAP{$self->path};
2031 2268
2032 $self->unlink_save; 2269 $self->unlink_save;
2033 2270
2034 bless $self, "cf::map"; 2271 bless $self, "cf::map";
2035 delete $self->{deny_reset}; 2272 delete $self->{deny_reset};
2036 $self->{deny_save} = 1; 2273 $self->{deny_save} = 1;
2037 $self->reset_timeout (1); 2274 $self->reset_timeout (1);
2038 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2275 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2039 2276
2040 $cf::MAP{$self->path} = $self; 2277 $cf::MAP{$self->path} = $self;
2278 }
2041 2279
2042 $self->reset; # polite request, might not happen 2280 $self->reset; # polite request, might not happen
2043} 2281}
2044 2282
2045=item $maps = cf::map::tmp_maps 2283=item $maps = cf::map::tmp_maps
… …
2121 2359
2122sub inv_recursive { 2360sub inv_recursive {
2123 inv_recursive_ inv $_[0] 2361 inv_recursive_ inv $_[0]
2124} 2362}
2125 2363
2364=item $ref = $ob->ref
2365
2366creates and returns a persistent reference to an objetc that can be stored as a string.
2367
2368=item $ob = cf::object::deref ($refstring)
2369
2370returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2371even if the object actually exists. May block.
2372
2373=cut
2374
2375sub deref {
2376 my ($ref) = @_;
2377
2378 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2379 my ($uuid, $name) = ($1, $2);
2380 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2381 or return;
2382 $pl->ob->uuid eq $uuid
2383 or return;
2384
2385 $pl->ob
2386 } else {
2387 warn "$ref: cannot resolve object reference\n";
2388 undef
2389 }
2390}
2391
2126package cf; 2392package cf;
2127 2393
2128=back 2394=back
2129 2395
2130=head3 cf::object::player 2396=head3 cf::object::player
… …
2152 2418
2153 } else { 2419 } else {
2154 my $pl = $self->contr; 2420 my $pl = $self->contr;
2155 2421
2156 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) { 2422 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2157 my $diag = $pl->{npc_dialog}; 2423 my $dialog = $pl->{npc_dialog};
2158 $diag->{pl}->ext_reply ( 2424 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2159 $diag->{id},
2160 msgtype => "reply",
2161 msg => $diag->{pl}->expand_cfpod ($msg),
2162 add_topics => []
2163 );
2164 2425
2165 } else { 2426 } else {
2166 $msg = $npc->name . " says: $msg" if $npc; 2427 $msg = $npc->name . " says: $msg" if $npc;
2167 $self->message ($msg, $flags); 2428 $self->message ($msg, $flags);
2168 } 2429 }
2169 } 2430 }
2431}
2432
2433=item $object->send_msg ($channel, $msg, $color, [extra...])
2434
2435=cut
2436
2437sub cf::object::send_msg {
2438 my $pl = shift->contr
2439 or return;
2440 $pl->send_msg (@_);
2170} 2441}
2171 2442
2172=item $player_object->may ("access") 2443=item $player_object->may ("access")
2173 2444
2174Returns wether the given player is authorized to access resource "access" 2445Returns wether the given player is authorized to access resource "access"
… …
2253 # use -1 or undef as default coordinates, not 0, 0 2524 # use -1 or undef as default coordinates, not 0, 0
2254 ($x, $y) = ($map->enter_x, $map->enter_y) 2525 ($x, $y) = ($map->enter_x, $map->enter_y)
2255 if $x <=0 && $y <= 0; 2526 if $x <=0 && $y <= 0;
2256 2527
2257 $map->load; 2528 $map->load;
2258 $map->load_diag; 2529 $map->load_neighbours;
2259 2530
2260 return unless $self->contr->active; 2531 return unless $self->contr->active;
2261 $self->activate_recursive; 2532 $self->activate_recursive;
2262 2533
2263 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2534 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
… …
2283 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2554 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2284 2555
2285 $self->enter_link; 2556 $self->enter_link;
2286 2557
2287 (async { 2558 (async {
2559 $Coro::current->{desc} = "player::goto $path $x $y";
2560
2561 # *tag paths override both path and x|y
2562 if ($path =~ /^\*(.*)$/) {
2563 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2564 my $ob = $obs[rand @obs];
2565
2566 # see if we actually can go there
2567 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2568 $ob = $obs[rand @obs];
2569 } else {
2570 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2571 }
2572 # else put us there anyways for now #d#
2573
2574 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2575 } else {
2576 ($path, $x, $y) = (undef, undef, undef);
2577 }
2578 }
2579
2288 my $map = eval { 2580 my $map = eval {
2289 my $map = cf::map::find $path; 2581 my $map = defined $path ? cf::map::find $path : undef;
2290 2582
2291 if ($map) { 2583 if ($map) {
2292 $map = $map->customise_for ($self); 2584 $map = $map->customise_for ($self);
2293 $map = $check->($map) if $check && $map; 2585 $map = $check->($map) if $check && $map;
2294 } else { 2586 } else {
2295 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED); 2587 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2296 } 2588 }
2297 2589
2298 $map 2590 $map
2299 }; 2591 };
2300 2592
… …
2353 $rmp->{origin_y} = $exit->y; 2645 $rmp->{origin_y} = $exit->y;
2354 } 2646 }
2355 2647
2356 $rmp->{random_seed} ||= $exit->random_seed; 2648 $rmp->{random_seed} ||= $exit->random_seed;
2357 2649
2358 my $data = cf::to_json $rmp; 2650 my $data = cf::encode_json $rmp;
2359 my $md5 = Digest::MD5::md5_hex $data; 2651 my $md5 = Digest::MD5::md5_hex $data;
2360 my $meta = "$RANDOMDIR/$md5.meta"; 2652 my $meta = "$RANDOMDIR/$md5.meta";
2361 2653
2362 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2654 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2363 aio_write $fh, 0, (length $data), $data, 0; 2655 aio_write $fh, 0, (length $data), $data, 0;
… …
2390 # if exit is damned, update players death & WoR home-position 2682 # if exit is damned, update players death & WoR home-position
2391 $self->contr->savebed ($slaying, $hp, $sp) 2683 $self->contr->savebed ($slaying, $hp, $sp)
2392 if $exit->flag (FLAG_DAMNED); 2684 if $exit->flag (FLAG_DAMNED);
2393 2685
2394 (async { 2686 (async {
2687 $Coro::current->{desc} = "enter_exit $slaying $hp $sp";
2688
2395 $self->deactivate_recursive; # just to be sure 2689 $self->deactivate_recursive; # just to be sure
2396 unless (eval { 2690 unless (eval {
2397 $self->goto ($slaying, $hp, $sp); 2691 $self->goto ($slaying, $hp, $sp);
2398 2692
2399 1; 2693 1;
… …
2425 2719
2426 utf8::encode $text; 2720 utf8::encode $text;
2427 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2721 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2428} 2722}
2429 2723
2430=item $client->send_msg ($color, $type, $msg, [extra...]) 2724=item $client->send_msg ($channel, $msg, $color, [extra...])
2431 2725
2432Send a drawinfo or msg packet to the client, formatting the msg for the 2726Send a drawinfo or msg packet to the client, formatting the msg for the
2433client if neccessary. C<$type> should be a string identifying the type of 2727client if neccessary. C<$type> should be a string identifying the type of
2434the message, with C<log> being the default. If C<$color> is negative, suppress 2728the message, with C<log> being the default. If C<$color> is negative, suppress
2435the message unless the client supports the msg packet. 2729the message unless the client supports the msg packet.
2436 2730
2437=cut 2731=cut
2438 2732
2733# non-persistent channels (usually the info channel)
2734our %CHANNEL = (
2735 "c/identify" => {
2736 id => "infobox",
2737 title => "Identify",
2738 reply => undef,
2739 tooltip => "Items recently identified",
2740 },
2741 "c/examine" => {
2742 id => "infobox",
2743 title => "Examine",
2744 reply => undef,
2745 tooltip => "Signs and other items you examined",
2746 },
2747 "c/book" => {
2748 id => "infobox",
2749 title => "Book",
2750 reply => undef,
2751 tooltip => "The contents of a note or book",
2752 },
2753 "c/lookat" => {
2754 id => "infobox",
2755 title => "Look",
2756 reply => undef,
2757 tooltip => "What you saw there",
2758 },
2759 "c/who" => {
2760 id => "infobox",
2761 title => "Players",
2762 reply => undef,
2763 tooltip => "Shows players who are currently online",
2764 },
2765 "c/body" => {
2766 id => "infobox",
2767 title => "Body Parts",
2768 reply => undef,
2769 tooltip => "Shows which body parts you posess and are available",
2770 },
2771 "c/uptime" => {
2772 id => "infobox",
2773 title => "Uptime",
2774 reply => undef,
2775 tooltip => "How long the server has been running since last restart",
2776 },
2777 "c/mapinfo" => {
2778 id => "infobox",
2779 title => "Map Info",
2780 reply => undef,
2781 tooltip => "Information related to the maps",
2782 },
2783);
2784
2439sub cf::client::send_msg { 2785sub cf::client::send_msg {
2440 my ($self, $color, $type, $msg, @extra) = @_; 2786 my ($self, $channel, $msg, $color, @extra) = @_;
2441 2787
2442 $msg = $self->pl->expand_cfpod ($msg); 2788 $msg = $self->pl->expand_cfpod ($msg);
2443 2789
2790 $color &= cf::NDI_CLIENT_MASK; # just in case...
2791
2792 # check predefined channels, for the benefit of C
2793 if ($CHANNEL{$channel}) {
2794 $channel = $CHANNEL{$channel};
2795
2796 $self->ext_msg (channel_info => $channel)
2797 if $self->can_msg;
2798
2799 $channel = $channel->{id};
2800
2801 } elsif (ref $channel) {
2802 # send meta info to client, if not yet sent
2803 unless (exists $self->{channel}{$channel->{id}}) {
2804 $self->{channel}{$channel->{id}} = $channel;
2805 $self->ext_msg (channel_info => $channel)
2806 if $self->can_msg;
2807 }
2808
2809 $channel = $channel->{id};
2810 }
2811
2444 return unless @extra || length $msg; 2812 return unless @extra || length $msg;
2445 2813
2446 if ($self->can_msg) { 2814 if ($self->can_msg) {
2815 # default colour, mask it out
2816 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2817 if $color & cf::NDI_DEF;
2818
2447 $self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $type, $msg, @extra])); 2819 $self->send_packet ("msg " . $self->{json_coder}->encode (
2820 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2448 } else { 2821 } else {
2449 # replace some tags by gcfclient-compatible ones
2450 for ($msg) {
2451 1 while
2452 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2453 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2454 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2455 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2456 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2457 }
2458
2459 if ($color >= 0) { 2822 if ($color >= 0) {
2823 # replace some tags by gcfclient-compatible ones
2824 for ($msg) {
2825 1 while
2826 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2827 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2828 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2829 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2830 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2831 }
2832
2833 $color &= cf::NDI_COLOR_MASK;
2834
2835 utf8::encode $msg;
2836
2460 if (0 && $msg =~ /\[/) { 2837 if (0 && $msg =~ /\[/) {
2838 # COMMAND/INFO
2461 $self->send_packet ("drawextinfo $color 4 0 $msg") 2839 $self->send_packet ("drawextinfo $color 10 8 $msg")
2462 } else { 2840 } else {
2463 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g; 2841 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2464 $self->send_packet ("drawinfo $color $msg") 2842 $self->send_packet ("drawinfo $color $msg")
2465 } 2843 }
2466 } 2844 }
2467 } 2845 }
2468} 2846}
2469 2847
2470=item $client->ext_event ($type, %msg) 2848=item $client->ext_msg ($type, @msg)
2471 2849
2472Sends an ext event to the client. 2850Sends an ext event to the client.
2473 2851
2474=cut 2852=cut
2475 2853
2476sub cf::client::ext_event($$%) { 2854sub cf::client::ext_msg($$@) {
2477 my ($self, $type, %msg) = @_; 2855 my ($self, $type, @msg) = @_;
2478 2856
2479 return unless $self->extcmd; 2857 if ($self->extcmd == 2) {
2480 2858 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2859 } elsif ($self->extcmd == 1) { # TODO: remove
2481 $msg{msgtype} = "event_$type"; 2860 push @msg, msgtype => "event_$type";
2482 $self->send_packet ("ext " . $self->{json_coder}->encode (\%msg)); 2861 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2862 }
2863}
2864
2865=item $client->ext_reply ($msgid, @msg)
2866
2867Sends an ext reply to the client.
2868
2869=cut
2870
2871sub cf::client::ext_reply($$@) {
2872 my ($self, $id, @msg) = @_;
2873
2874 if ($self->extcmd == 2) {
2875 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2876 } elsif ($self->extcmd == 1) {
2877 #TODO: version 1, remove
2878 unshift @msg, msgtype => "reply", msgid => $id;
2879 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2880 }
2483} 2881}
2484 2882
2485=item $success = $client->query ($flags, "text", \&cb) 2883=item $success = $client->query ($flags, "text", \&cb)
2486 2884
2487Queues a query to the client, calling the given callback with 2885Queues a query to the client, calling the given callback with
… …
2542 my ($ns, $buf) = @_; 2940 my ($ns, $buf) = @_;
2543 2941
2544 my $msg = eval { $ns->{json_coder}->decode ($buf) }; 2942 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2545 2943
2546 if (ref $msg) { 2944 if (ref $msg) {
2945 my ($type, $reply, @payload) =
2946 "ARRAY" eq ref $msg
2947 ? @$msg
2948 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
2949
2950 my @reply;
2951
2547 if (my $cb = $EXTICMD{$msg->{msgtype}}) { 2952 if (my $cb = $EXTICMD{$type}) {
2548 if (my %reply = $cb->($ns, $msg)) { 2953 @reply = $cb->($ns, @payload);
2549 $reply{msgid} = $msg->{msgid};
2550 $ns->send ("ext " . $ns->{json_coder}->encode (\%reply));
2551 }
2552 } 2954 }
2955
2956 $ns->ext_reply ($reply, @reply)
2957 if $reply;
2958
2553 } else { 2959 } else {
2554 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 2960 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2555 } 2961 }
2556 2962
2557 cf::override; 2963 cf::override;
… …
2604our $safe = new Safe "safe"; 3010our $safe = new Safe "safe";
2605our $safe_hole = new Safe::Hole; 3011our $safe_hole = new Safe::Hole;
2606 3012
2607$SIG{FPE} = 'IGNORE'; 3013$SIG{FPE} = 'IGNORE';
2608 3014
2609$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 3015$safe->permit_only (Opcode::opset qw(
3016 :base_core :base_mem :base_orig :base_math
3017 grepstart grepwhile mapstart mapwhile
3018 sort time
3019));
2610 3020
2611# here we export the classes and methods available to script code 3021# here we export the classes and methods available to script code
2612 3022
2613=pod 3023=pod
2614 3024
2615The following functions and methods are available within a safe environment: 3025The following functions and methods are available within a safe environment:
2616 3026
2617 cf::object 3027 cf::object
2618 contr pay_amount pay_player map x y force_find force_add 3028 contr pay_amount pay_player map x y force_find force_add destroy
2619 insert remove 3029 insert remove name archname title slaying race decrease_ob_nr
2620 3030
2621 cf::object::player 3031 cf::object::player
2622 player 3032 player
2623 3033
2624 cf::player 3034 cf::player
… …
2629 3039
2630=cut 3040=cut
2631 3041
2632for ( 3042for (
2633 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3043 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3044 insert remove inv name archname title slaying race
2634 insert remove)], 3045 decrease_ob_nr destroy)],
2635 ["cf::object::player" => qw(player)], 3046 ["cf::object::player" => qw(player)],
2636 ["cf::player" => qw(peaceful)], 3047 ["cf::player" => qw(peaceful)],
2637 ["cf::map" => qw(trigger)], 3048 ["cf::map" => qw(trigger)],
2638) { 3049) {
2639 no strict 'refs'; 3050 no strict 'refs';
… …
2715# the server's init and main functions 3126# the server's init and main functions
2716 3127
2717sub load_facedata($) { 3128sub load_facedata($) {
2718 my ($path) = @_; 3129 my ($path) = @_;
2719 3130
3131 # HACK to clear player env face cache, we need some signal framework
3132 # for this (global event?)
3133 %ext::player_env::MUSIC_FACE_CACHE = ();
3134
3135 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3136
2720 warn "loading facedata from $path\n"; 3137 warn "loading facedata from $path\n";
2721 3138
2722 my $facedata; 3139 my $facedata;
2723 0 < aio_load $path, $facedata 3140 0 < aio_load $path, $facedata
2724 or die "$path: $!"; 3141 or die "$path: $!";
… …
2726 $facedata = Coro::Storable::thaw $facedata; 3143 $facedata = Coro::Storable::thaw $facedata;
2727 3144
2728 $facedata->{version} == 2 3145 $facedata->{version} == 2
2729 or cf::cleanup "$path: version mismatch, cannot proceed."; 3146 or cf::cleanup "$path: version mismatch, cannot proceed.";
2730 3147
3148 # patch in the exptable
3149 $facedata->{resource}{"res/exp_table"} = {
3150 type => FT_RSRC,
3151 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
3152 };
3153 cf::cede_to_tick;
3154
2731 { 3155 {
2732 my $faces = $facedata->{faceinfo}; 3156 my $faces = $facedata->{faceinfo};
2733 3157
2734 while (my ($face, $info) = each %$faces) { 3158 while (my ($face, $info) = each %$faces) {
2735 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3159 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3160
2736 cf::face::set_visibility $idx, $info->{visibility}; 3161 cf::face::set_visibility $idx, $info->{visibility};
2737 cf::face::set_magicmap $idx, $info->{magicmap}; 3162 cf::face::set_magicmap $idx, $info->{magicmap};
2738 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 3163 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2739 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 3164 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2740 3165
2741 cf::cede_to_tick; 3166 cf::cede_to_tick;
2742 } 3167 }
2743 3168
2744 while (my ($face, $info) = each %$faces) { 3169 while (my ($face, $info) = each %$faces) {
2745 next unless $info->{smooth}; 3170 next unless $info->{smooth};
3171
2746 my $idx = cf::face::find $face 3172 my $idx = cf::face::find $face
2747 or next; 3173 or next;
3174
2748 if (my $smooth = cf::face::find $info->{smooth}) { 3175 if (my $smooth = cf::face::find $info->{smooth}) {
2749 cf::face::set_smooth $idx, $smooth; 3176 cf::face::set_smooth $idx, $smooth;
2750 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3177 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2751 } else { 3178 } else {
2752 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3179 warn "smooth face '$info->{smooth}' not found for face '$face'";
… …
2769 3196
2770 { 3197 {
2771 # TODO: for gcfclient pleasure, we should give resources 3198 # TODO: for gcfclient pleasure, we should give resources
2772 # that gcfclient doesn't grok a >10000 face index. 3199 # that gcfclient doesn't grok a >10000 face index.
2773 my $res = $facedata->{resource}; 3200 my $res = $facedata->{resource};
2774 my $enc = JSON::XS->new->utf8->canonical;
2775 3201
2776 while (my ($name, $info) = each %$res) { 3202 while (my ($name, $info) = each %$res) {
2777 my $meta = $enc->encode ({ 3203 if (defined $info->{type}) {
2778 name => $name,
2779 type => $info->{type},
2780 copyright => $info->{copyright}, #TODO#
2781 });
2782
2783 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3204 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3205 my $data;
2784 3206
2785 if ($name =~ /\.jpg$/) { 3207 if ($info->{type} & 1) {
2786 cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};#d# temp hack 3208 # prepend meta info
2787 cf::face::set_data $idx, 1, $info->{data}, $info->{chksum};#d# temp hack 3209
3210 my $meta = $enc->encode ({
3211 name => $name,
3212 %{ $info->{meta} || {} },
3213 });
3214
3215 $data = pack "(w/a*)*", $meta, $info->{data};
3216 } else {
3217 $data = $info->{data};
3218 }
3219
3220 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3221 cf::face::set_type $idx, $info->{type};
2788 } else { 3222 } else {
2789 my $data = pack "(w/a*)*", $meta, $info->{data}; 3223 $RESOURCE{$name} = $info;
2790 my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
2791
2792 cf::face::set_type $idx, 1;
2793 cf::face::set_data $idx, 0, $data, $chk;
2794 } 3224 }
2795 3225
2796 cf::cede_to_tick; 3226 cf::cede_to_tick;
2797 } 3227 }
2798 } 3228 }
2799 3229
3230 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3231
2800 1 3232 1
2801} 3233}
2802 3234
3235cf::global->attach (on_resource_update => sub {
3236 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3237 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3238
3239 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3240 my $sound = $soundconf->{compat}[$_]
3241 or next;
3242
3243 my $face = cf::face::find "sound/$sound->[1]";
3244 cf::sound::set $sound->[0] => $face;
3245 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3246 }
3247
3248 while (my ($k, $v) = each %{$soundconf->{event}}) {
3249 my $face = cf::face::find "sound/$v";
3250 cf::sound::set $k => $face;
3251 }
3252 }
3253});
3254
3255register_exticmd fx_want => sub {
3256 my ($ns, $want) = @_;
3257
3258 while (my ($k, $v) = each %$want) {
3259 $ns->fx_want ($k, $v);
3260 }
3261};
3262
2803sub reload_regions { 3263sub reload_regions {
3264 # HACK to clear player env face cache, we need some signal framework
3265 # for this (global event?)
3266 %ext::player_env::MUSIC_FACE_CACHE = ();
3267
2804 load_resource_file "$MAPDIR/regions" 3268 load_resource_file "$MAPDIR/regions"
2805 or die "unable to load regions file\n"; 3269 or die "unable to load regions file\n";
2806 3270
2807 for (cf::region::list) { 3271 for (cf::region::list) {
2808 $_->{match} = qr/$_->{match}/ 3272 $_->{match} = qr/$_->{match}/
… …
2844 3308
2845sub init { 3309sub init {
2846 reload_resources; 3310 reload_resources;
2847} 3311}
2848 3312
2849sub cfg_load { 3313sub reload_config {
2850 open my $fh, "<:utf8", "$CONFDIR/config" 3314 open my $fh, "<:utf8", "$CONFDIR/config"
2851 or return; 3315 or return;
2852 3316
2853 local $/; 3317 local $/;
2854 *CFG = YAML::Syck::Load <$fh>; 3318 *CFG = YAML::Syck::Load <$fh>;
… …
2870sub main { 3334sub main {
2871 # we must not ever block the main coroutine 3335 # we must not ever block the main coroutine
2872 local $Coro::idle = sub { 3336 local $Coro::idle = sub {
2873 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3337 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2874 (async { 3338 (async {
2875 Event::one_event; 3339 $Coro::current->{desc} = "IDLE BUG HANDLER";
3340 EV::loop EV::LOOP_ONESHOT;
2876 })->prio (Coro::PRIO_MAX); 3341 })->prio (Coro::PRIO_MAX);
2877 }; 3342 };
2878 3343
2879 cfg_load; 3344 reload_config;
2880 db_init; 3345 db_init;
2881 load_extensions; 3346 load_extensions;
2882 3347
2883 $TICK_WATCHER->start; 3348 $TICK_WATCHER->start;
3349 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
2884 Event::loop; 3350 EV::loop;
2885} 3351}
2886 3352
2887############################################################################# 3353#############################################################################
2888# initialisation and cleanup 3354# initialisation and cleanup
2889 3355
2890# install some emergency cleanup handlers 3356# install some emergency cleanup handlers
2891BEGIN { 3357BEGIN {
3358 our %SIGWATCHER = ();
2892 for my $signal (qw(INT HUP TERM)) { 3359 for my $signal (qw(INT HUP TERM)) {
2893 Event->signal ( 3360 $SIGWATCHER{$signal} = EV::signal $signal, sub {
2894 reentrant => 0,
2895 data => WF_AUTOCANCEL,
2896 signal => $signal,
2897 prio => 0,
2898 cb => sub {
2899 cf::cleanup "SIG$signal"; 3361 cf::cleanup "SIG$signal";
2900 },
2901 ); 3362 };
2902 } 3363 }
2903} 3364}
2904 3365
2905sub write_runtime { 3366sub write_runtime {
2906 my $runtime = "$LOCALDIR/runtime"; 3367 my $runtime = "$LOCALDIR/runtime";
… …
2951 # and maps saved/destroyed asynchronously. 3412 # and maps saved/destroyed asynchronously.
2952 warn "begin emergency player save\n"; 3413 warn "begin emergency player save\n";
2953 for my $login (keys %cf::PLAYER) { 3414 for my $login (keys %cf::PLAYER) {
2954 my $pl = $cf::PLAYER{$login} or next; 3415 my $pl = $cf::PLAYER{$login} or next;
2955 $pl->valid or next; 3416 $pl->valid or next;
3417 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
2956 $pl->save; 3418 $pl->save;
2957 } 3419 }
2958 warn "end emergency player save\n"; 3420 warn "end emergency player save\n";
2959 3421
2960 warn "begin emergency map save\n"; 3422 warn "begin emergency map save\n";
… …
2999 warn "syncing database to disk"; 3461 warn "syncing database to disk";
3000 BDB::db_env_txn_checkpoint $DB_ENV; 3462 BDB::db_env_txn_checkpoint $DB_ENV;
3001 3463
3002 # if anything goes wrong in here, we should simply crash as we already saved 3464 # if anything goes wrong in here, we should simply crash as we already saved
3003 3465
3004 warn "cancelling all WF_AUTOCANCEL watchers";
3005 for (Event::all_watchers) {
3006 $_->cancel if $_->data & WF_AUTOCANCEL;
3007 }
3008
3009 warn "flushing outstanding aio requests"; 3466 warn "flushing outstanding aio requests";
3010 for (;;) { 3467 for (;;) {
3011 BDB::flush; 3468 BDB::flush;
3012 IO::AIO::flush; 3469 IO::AIO::flush;
3013 Coro::cede; 3470 Coro::cede_notself;
3014 last unless IO::AIO::nreqs || BDB::nreqs; 3471 last unless IO::AIO::nreqs || BDB::nreqs;
3015 warn "iterate..."; 3472 warn "iterate...";
3016 } 3473 }
3017 3474
3018 ++$RELOAD; 3475 ++$RELOAD;
… …
3077 warn "reloading cf.pm"; 3534 warn "reloading cf.pm";
3078 require cf; 3535 require cf;
3079 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3536 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3080 3537
3081 warn "loading config and database again"; 3538 warn "loading config and database again";
3082 cf::cfg_load; 3539 cf::reload_config;
3083 3540
3084 warn "loading extensions"; 3541 warn "loading extensions";
3085 cf::load_extensions; 3542 cf::load_extensions;
3086 3543
3087 warn "reattaching attachments to objects/players"; 3544 warn "reattaching attachments to objects/players";
… …
3107 3564
3108sub reload_perl() { 3565sub reload_perl() {
3109 # doing reload synchronously and two reloads happen back-to-back, 3566 # doing reload synchronously and two reloads happen back-to-back,
3110 # coro crashes during coro_state_free->destroy here. 3567 # coro crashes during coro_state_free->destroy here.
3111 3568
3112 $RELOAD_WATCHER ||= Event->timer ( 3569 $RELOAD_WATCHER ||= EV::timer 0, 0, sub {
3113 reentrant => 0,
3114 after => 0,
3115 data => WF_AUTOCANCEL,
3116 cb => sub {
3117 do_reload_perl;
3118 undef $RELOAD_WATCHER; 3570 undef $RELOAD_WATCHER;
3119 }, 3571 do_reload_perl;
3120 ); 3572 };
3121} 3573}
3122 3574
3123register_command "reload" => sub { 3575register_command "reload" => sub {
3124 my ($who, $arg) = @_; 3576 my ($who, $arg) = @_;
3125 3577
3126 if ($who->flag (FLAG_WIZ)) { 3578 if ($who->flag (FLAG_WIZ)) {
3127 $who->message ("reloading server."); 3579 $who->message ("reloading server.");
3580 async {
3581 $Coro::current->{desc} = "perl_reload";
3128 async { reload_perl }; 3582 reload_perl;
3583 };
3129 } 3584 }
3130}; 3585};
3131 3586
3132unshift @INC, $LIBDIR; 3587unshift @INC, $LIBDIR;
3133 3588
… …
3152 my $signal = new Coro::Signal; 3607 my $signal = new Coro::Signal;
3153 push @WAIT_FOR_TICK_BEGIN, $signal; 3608 push @WAIT_FOR_TICK_BEGIN, $signal;
3154 $signal->wait; 3609 $signal->wait;
3155} 3610}
3156 3611
3157 my $min = 1e6;#d# 3612$TICK_WATCHER = EV::periodic_ns 0, $TICK, 0, sub {
3158 my $avg = 10;
3159$TICK_WATCHER = Event->timer (
3160 reentrant => 0,
3161 parked => 1,
3162 prio => 0,
3163 at => $NEXT_TICK || $TICK,
3164 data => WF_AUTOCANCEL,
3165 cb => sub {
3166 if ($Coro::current != $Coro::main) { 3613 if ($Coro::current != $Coro::main) {
3167 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3614 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3168 unless ++$bug_warning > 10; 3615 unless ++$bug_warning > 10;
3169 return; 3616 return;
3170 } 3617 }
3171 3618
3172 $NOW = $tick_start = Event::time; 3619 $NOW = $tick_start = EV::now;
3173 3620
3174 cf::server_tick; # one server iteration 3621 cf::server_tick; # one server iteration
3175 3622
3176 0 && sync_job {#d# 3623 $RUNTIME += $TICK;
3177 for(1..10) { 3624 $NEXT_TICK = $_[0]->at;
3178 my $t = Event::time;
3179 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3180 or die;
3181 3625
3182 $map->width (50); 3626 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3183 $map->height (50); 3627 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3184 $map->alloc; 3628 Coro::async_pool {
3185 $map->_load_objects ("/tmp/x.map", 1); 3629 $Coro::current->{desc} = "runtime saver";
3186 my $t = Event::time - $t; 3630 write_runtime
3187 3631 or warn "ERROR: unable to write runtime file: $!";
3188 #next unless $t < 0.0013;#d#
3189 if ($t < $min) {
3190 $min = $t;
3191 }
3192 $avg = $avg * 0.99 + $t * 0.01;
3193 }
3194 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3195 exit 0;
3196 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3197 }; 3632 };
3633 }
3198 3634
3199 $RUNTIME += $TICK;
3200 $NEXT_TICK += $TICK;
3201
3202 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3203 $NEXT_RUNTIME_WRITE = $NOW + 10;
3204 Coro::async_pool {
3205 write_runtime
3206 or warn "ERROR: unable to write runtime file: $!";
3207 };
3208 }
3209
3210# my $AFTER = Event::time;
3211# warn $AFTER - $NOW;#d#
3212
3213 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3635 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3214 $sig->send; 3636 $sig->send;
3215 } 3637 }
3216 while (my $sig = shift @WAIT_FOR_TICK) { 3638 while (my $sig = shift @WAIT_FOR_TICK) {
3217 $sig->send; 3639 $sig->send;
3218 } 3640 }
3219 3641
3220 $NOW = Event::time;
3221
3222 # if we are delayed by four ticks or more, skip them all
3223 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3224
3225 $TICK_WATCHER->at ($NEXT_TICK);
3226 $TICK_WATCHER->start;
3227
3228 $LOAD = ($NOW - $tick_start) / $TICK; 3642 $LOAD = ($NOW - $tick_start) / $TICK;
3229 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3643 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3230 3644
3231 _post_tick; 3645 _post_tick;
3232 3646};
3233 3647$TICK_WATCHER->priority (EV::MAXPRI);
3234 },
3235);
3236 3648
3237{ 3649{
3238 BDB::max_poll_time $TICK * 0.1; 3650 # configure BDB
3239 $BDB_POLL_WATCHER = Event->io ( 3651
3240 reentrant => 0,
3241 fd => BDB::poll_fileno,
3242 poll => 'r',
3243 prio => 0,
3244 data => WF_AUTOCANCEL,
3245 cb => \&BDB::poll_cb,
3246 );
3247 BDB::min_parallel 8; 3652 BDB::min_parallel 8;
3248 3653 BDB::max_poll_reqs $TICK * 0.1;
3249 BDB::set_sync_prepare { 3654 $Coro::BDB::WATCHER->priority (1);
3250 my $status;
3251 my $current = $Coro::current;
3252 (
3253 sub {
3254 $status = $!;
3255 $current->ready; undef $current;
3256 },
3257 sub {
3258 Coro::schedule while defined $current;
3259 $! = $status;
3260 },
3261 )
3262 };
3263 3655
3264 unless ($DB_ENV) { 3656 unless ($DB_ENV) {
3265 $DB_ENV = BDB::db_env_create; 3657 $DB_ENV = BDB::db_env_create;
3658 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC
3659 | BDB::LOG_AUTOREMOVE, 1);
3660 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3661 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3266 3662
3267 cf::sync_job { 3663 cf::sync_job {
3268 eval { 3664 eval {
3269 BDB::db_env_open 3665 BDB::db_env_open
3270 $DB_ENV, 3666 $DB_ENV,
… …
3272 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3668 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3273 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3669 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3274 0666; 3670 0666;
3275 3671
3276 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 3672 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3277
3278 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3279 $DB_ENV->set_lk_detect;
3280 }; 3673 };
3281 3674
3282 cf::cleanup "db_env_open(db): $@" if $@; 3675 cf::cleanup "db_env_open(db): $@" if $@;
3283 }; 3676 };
3284 } 3677 }
3678
3679 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3680 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3681 };
3682 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3683 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3684 };
3685 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3686 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3687 };
3285} 3688}
3286 3689
3287{ 3690{
3691 # configure IO::AIO
3692
3288 IO::AIO::min_parallel 8; 3693 IO::AIO::min_parallel 8;
3289
3290 undef $Coro::AIO::WATCHER;
3291 IO::AIO::max_poll_time $TICK * 0.1; 3694 IO::AIO::max_poll_time $TICK * 0.1;
3292 $AIO_POLL_WATCHER = Event->io ( 3695 $Coro::AIO::WATCHER->priority (1);
3293 reentrant => 0,
3294 data => WF_AUTOCANCEL,
3295 fd => IO::AIO::poll_fileno,
3296 poll => 'r',
3297 prio => 6,
3298 cb => \&IO::AIO::poll_cb,
3299 );
3300} 3696}
3301 3697
3302my $_log_backtrace; 3698my $_log_backtrace;
3303 3699
3304sub _log_backtrace { 3700sub _log_backtrace {
… …
3308 3704
3309 # limit the # of concurrent backtraces 3705 # limit the # of concurrent backtraces
3310 if ($_log_backtrace < 2) { 3706 if ($_log_backtrace < 2) {
3311 ++$_log_backtrace; 3707 ++$_log_backtrace;
3312 async { 3708 async {
3709 $Coro::current->{desc} = "abt $msg";
3710
3313 my @bt = fork_call { 3711 my @bt = fork_call {
3314 @addr = map { sprintf "%x", $_ } @addr; 3712 @addr = map { sprintf "%x", $_ } @addr;
3315 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X; 3713 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3316 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |" 3714 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3317 or die "addr2line: $!"; 3715 or die "addr2line: $!";

Diff Legend

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