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.373 by root, Sat Sep 15 15:58:06 2007 UTC vs.
Revision 1.448 by root, Fri Sep 19 05:30:23 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 Socket; 30use Socket;
9use Storable; 31use EV;
10use Event;
11use Opcode; 32use Opcode;
12use Safe; 33use Safe;
13use Safe::Hole; 34use Safe::Hole;
35use Storable ();
14 36
15use Coro 3.64 (); 37use Coro ();
16use Coro::State; 38use Coro::State;
17use Coro::Handle; 39use Coro::Handle;
40use Coro::EV;
18use Coro::Event; 41use Coro::AnyEvent;
19use Coro::Timer; 42use Coro::Timer;
20use Coro::Signal; 43use Coro::Signal;
21use Coro::Semaphore; 44use Coro::Semaphore;
45use Coro::AnyEvent;
22use Coro::AIO; 46use Coro::AIO;
47use Coro::BDB 1.6;
23use Coro::Storable; 48use Coro::Storable;
24use Coro::Util (); 49use Coro::Util ();
25 50
26use JSON::XS (); 51use JSON::XS 2.01 ();
27use BDB (); 52use BDB ();
28use Data::Dumper; 53use Data::Dumper;
29use Digest::MD5; 54use Digest::MD5;
30use Fcntl; 55use Fcntl;
31use YAML::Syck (); 56use YAML ();
32use IO::AIO 2.32 (); 57use IO::AIO ();
33use Time::HiRes; 58use Time::HiRes;
34use Compress::LZF; 59use Compress::LZF;
35use Digest::MD5 (); 60use Digest::MD5 ();
61
62AnyEvent::detect;
36 63
37# configure various modules to our taste 64# configure various modules to our taste
38# 65#
39$Storable::canonical = 1; # reduce rsync transfers 66$Storable::canonical = 1; # reduce rsync transfers
40Coro::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
41Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
42
43$Event::Eval = 1; # no idea why this is required, but it is
44
45# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
46$YAML::Syck::ImplicitUnicode = 1;
47 68
48$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 69$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
70
71{
72 # very ugly, but ensure we acquire the storable lock
73
74 sub net_mstore {
75 my $guard = Coro::Storable::guard;
76 &Storable::net_mstore
77 }
78
79 sub mretrieve {
80 my $guard = Coro::Storable::guard;
81 &Storable::mretrieve
82 }
83
84 Compress::LZF::set_serializer "Coro::Storable", "cf::net_mstore", "cf::mretrieve";
85 Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
86}
49 87
50sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 88sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
51 89
52our %COMMAND = (); 90our %COMMAND = ();
53our %COMMAND_TIME = (); 91our %COMMAND_TIME = ();
59our %EXT_MAP = (); # pluggable maps 97our %EXT_MAP = (); # pluggable maps
60 98
61our $RELOAD; # number of reloads so far 99our $RELOAD; # number of reloads so far
62our @EVENT; 100our @EVENT;
63 101
64our $CONFDIR = confdir; 102our $CONFDIR = confdir;
65our $DATADIR = datadir; 103our $DATADIR = datadir;
66our $LIBDIR = "$DATADIR/ext"; 104our $LIBDIR = "$DATADIR/ext";
67our $PODDIR = "$DATADIR/pod"; 105our $PODDIR = "$DATADIR/pod";
68our $MAPDIR = "$DATADIR/" . mapdir; 106our $MAPDIR = "$DATADIR/" . mapdir;
69our $LOCALDIR = localdir; 107our $LOCALDIR = localdir;
70our $TMPDIR = "$LOCALDIR/" . tmpdir; 108our $TMPDIR = "$LOCALDIR/" . tmpdir;
71our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 109our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
72our $PLAYERDIR = "$LOCALDIR/" . playerdir; 110our $PLAYERDIR = "$LOCALDIR/" . playerdir;
73our $RANDOMDIR = "$LOCALDIR/random"; 111our $RANDOMDIR = "$LOCALDIR/random";
74our $BDBDIR = "$LOCALDIR/db"; 112our $BDBDIR = "$LOCALDIR/db";
113our $PIDFILE = "$LOCALDIR/pid";
114our $RUNTIMEFILE = "$LOCALDIR/runtime";
115
116our %RESOURCE;
75 117
76our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 118our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
77our $TICK_WATCHER;
78our $AIO_POLL_WATCHER;
79our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 119our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
80our $NEXT_TICK; 120our $NEXT_TICK;
81our $NOW;
82our $USE_FSYNC = 1; # use fsync to write maps - default off 121our $USE_FSYNC = 1; # use fsync to write maps - default off
83 122
84our $BDB_POLL_WATCHER;
85our $BDB_DEADLOCK_WATCHER; 123our $BDB_DEADLOCK_WATCHER;
86our $BDB_CHECKPOINT_WATCHER; 124our $BDB_CHECKPOINT_WATCHER;
87our $BDB_TRICKLE_WATCHER; 125our $BDB_TRICKLE_WATCHER;
88our $DB_ENV; 126our $DB_ENV;
89 127
90our %CFG; 128our %CFG;
91 129
92our $UPTIME; $UPTIME ||= time; 130our $UPTIME; $UPTIME ||= time;
93our $RUNTIME; 131our $RUNTIME;
132our $NOW;
94 133
95our (%PLAYER, %PLAYER_LOADING); # all users 134our (%PLAYER, %PLAYER_LOADING); # all users
96our (%MAP, %MAP_LOADING ); # all maps 135our (%MAP, %MAP_LOADING ); # all maps
97our $LINK_MAP; # the special {link} map, which is always available 136our $LINK_MAP; # the special {link} map, which is always available
98 137
99# used to convert map paths into valid unix filenames by replacing / by ∕ 138# used to convert map paths into valid unix filenames by replacing / by ∕
100our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 139our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
101 140
102our $LOAD; # a number between 0 (idle) and 1 (too many objects) 141our $LOAD; # a number between 0 (idle) and 1 (too many objects)
103our $LOADAVG; # same thing, but with alpha-smoothing 142our $LOADAVG; # same thing, but with alpha-smoothing
143our $JITTER; # average jitter
104our $tick_start; # for load detecting purposes 144our $TICK_START; # for load detecting purposes
105 145
106binmode STDOUT; 146binmode STDOUT;
107binmode STDERR; 147binmode STDERR;
108 148
109# read virtual server time, if available 149# read virtual server time, if available
110unless ($RUNTIME || !-e "$LOCALDIR/runtime") { 150unless ($RUNTIME || !-e $RUNTIMEFILE) {
111 open my $fh, "<", "$LOCALDIR/runtime" 151 open my $fh, "<", $RUNTIMEFILE
112 or die "unable to read runtime file: $!"; 152 or die "unable to read $RUNTIMEFILE file: $!";
113 $RUNTIME = <$fh> + 0.; 153 $RUNTIME = <$fh> + 0.;
114} 154}
115 155
116mkdir $_ 156mkdir $_
117 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR; 157 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
162 202
163The raw value load value from the last tick. 203The raw value load value from the last tick.
164 204
165=item %cf::CFG 205=item %cf::CFG
166 206
167Configuration for the server, loaded from C</etc/crossfire/config>, or 207Configuration for the server, loaded from C</etc/deliantra-server/config>, or
168from wherever your confdir points to. 208from wherever your confdir points to.
169 209
170=item cf::wait_for_tick, cf::wait_for_tick_begin 210=item cf::wait_for_tick, cf::wait_for_tick_begin
171 211
172These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 212These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
193 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 233 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
194 234
195 LOG llevError, $msg; 235 LOG llevError, $msg;
196 }; 236 };
197} 237}
238
239$Coro::State::DIEHOOK = sub {
240 return unless $^S eq 0; # "eq", not "=="
241
242 if ($Coro::current == $Coro::main) {#d#
243 warn "DIEHOOK called in main context, Coro bug?\n";#d#
244 return;#d#
245 }#d#
246
247 # kill coroutine otherwise
248 warn Carp::longmess $_[0];
249 Coro::terminate
250};
251
252$SIG{__DIE__} = sub { }; #d#?
198 253
199@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 254@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
200@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 255@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
201@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 256@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
202@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 257@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
209for my $pkg (qw( 264for my $pkg (qw(
210 cf::global cf::attachable 265 cf::global cf::attachable
211 cf::object cf::object::player 266 cf::object cf::object::player
212 cf::client cf::player 267 cf::client cf::player
213 cf::arch cf::living 268 cf::arch cf::living
269 cf::map cf::mapspace
214 cf::map cf::party cf::region 270 cf::party cf::region
215)) { 271)) {
216 no strict 'refs';
217 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 272 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
218} 273}
219 274
220$Event::DIED = sub { 275$EV::DIED = sub {
221 warn "error in event callback: @_"; 276 warn "error in event callback: @_";
222}; 277};
223 278
224############################################################################# 279#############################################################################
225 280
248 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 303 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
249 $d 304 $d
250 } || "[unable to dump $_[0]: '$@']"; 305 } || "[unable to dump $_[0]: '$@']";
251} 306}
252 307
253=item $ref = cf::from_json $json 308=item $ref = cf::decode_json $json
254 309
255Converts a JSON string into the corresponding perl data structure. 310Converts a JSON string into the corresponding perl data structure.
256 311
257=item $json = cf::to_json $ref 312=item $json = cf::encode_json $ref
258 313
259Converts a perl data structure into its JSON representation. 314Converts a perl data structure into its JSON representation.
260 315
261=cut 316=cut
262 317
263our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max 318our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
264 319
265sub to_json ($) { $json_coder->encode ($_[0]) } 320sub encode_json($) { $json_coder->encode ($_[0]) }
266sub from_json ($) { $json_coder->decode ($_[0]) } 321sub decode_json($) { $json_coder->decode ($_[0]) }
267 322
268=item cf::lock_wait $string 323=item cf::lock_wait $string
269 324
270Wait until the given lock is available. See cf::lock_acquire. 325Wait until the given lock is available. See cf::lock_acquire.
271 326
327 382
328 ! ! $LOCK{$key} 383 ! ! $LOCK{$key}
329} 384}
330 385
331sub freeze_mainloop { 386sub freeze_mainloop {
332 return unless $TICK_WATCHER->is_active; 387 tick_inhibit_inc;
333 388
334 my $guard = Coro::guard { 389 Coro::guard \&tick_inhibit_dec;
335 $TICK_WATCHER->start; 390}
336 }; 391
337 $TICK_WATCHER->stop; 392=item cf::periodic $interval, $cb
338 $guard 393
394Like EV::periodic, but randomly selects a starting point so that the actions
395get spread over timer.
396
397=cut
398
399sub periodic($$) {
400 my ($interval, $cb) = @_;
401
402 my $start = rand List::Util::min 180, $interval;
403
404 EV::periodic $start, $interval, 0, $cb
339} 405}
340 406
341=item cf::get_slot $time[, $priority[, $name]] 407=item cf::get_slot $time[, $priority[, $name]]
342 408
343Allocate $time seconds of blocking CPU time at priority C<$priority>: 409Allocate $time seconds of blocking CPU time at priority C<$priority>:
354our @SLOT_QUEUE; 420our @SLOT_QUEUE;
355our $SLOT_QUEUE; 421our $SLOT_QUEUE;
356 422
357$SLOT_QUEUE->cancel if $SLOT_QUEUE; 423$SLOT_QUEUE->cancel if $SLOT_QUEUE;
358$SLOT_QUEUE = Coro::async { 424$SLOT_QUEUE = Coro::async {
425 $Coro::current->desc ("timeslot manager");
426
359 my $signal = new Coro::Signal; 427 my $signal = new Coro::Signal;
360 428
361 while () { 429 while () {
362 next_job: 430 next_job:
363 my $avail = cf::till_tick; 431 my $avail = cf::till_tick;
371 } 439 }
372 } 440 }
373 } 441 }
374 442
375 if (@SLOT_QUEUE) { 443 if (@SLOT_QUEUE) {
376 # we do not use wait_For_tick() as it returns immediately when tick is inactive 444 # we do not use wait_for_tick() as it returns immediately when tick is inactive
377 push @cf::WAIT_FOR_TICK, $signal; 445 push @cf::WAIT_FOR_TICK, $signal;
378 $signal->wait; 446 $signal->wait;
379 } else { 447 } else {
380 Coro::schedule; 448 Coro::schedule;
381 } 449 }
382 } 450 }
383}; 451};
384 452
385sub get_slot($;$$) { 453sub get_slot($;$$) {
454 return if tick_inhibit || $Coro::current == $Coro::main;
455
386 my ($time, $pri, $name) = @_; 456 my ($time, $pri, $name) = @_;
387 457
388 $time = $TICK * .6 if $time > $TICK * .6; 458 $time = $TICK * .6 if $time > $TICK * .6;
389 my $sig = new Coro::Signal; 459 my $sig = new Coro::Signal;
390 460
404 474
405BEGIN { *async = \&Coro::async_pool } 475BEGIN { *async = \&Coro::async_pool }
406 476
407=item cf::sync_job { BLOCK } 477=item cf::sync_job { BLOCK }
408 478
409The design of Crossfire TRT requires that the main coroutine ($Coro::main) 479The design of Deliantra requires that the main coroutine ($Coro::main)
410is always able to handle events or runnable, as Crossfire TRT is only 480is always able to handle events or runnable, as Deliantra is only
411partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not 481partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
412acceptable. 482acceptable.
413 483
414If it must be done, put the blocking parts into C<sync_job>. This will run 484If it must be done, put the blocking parts into C<sync_job>. This will run
415the given BLOCK in another coroutine while waiting for the result. The 485the given BLOCK in another coroutine while waiting for the result. The
420 490
421sub sync_job(&) { 491sub sync_job(&) {
422 my ($job) = @_; 492 my ($job) = @_;
423 493
424 if ($Coro::current == $Coro::main) { 494 if ($Coro::current == $Coro::main) {
425 my $time = Event::time; 495 my $time = EV::time;
426 496
427 # this is the main coro, too bad, we have to block 497 # this is the main coro, too bad, we have to block
428 # till the operation succeeds, freezing the server :/ 498 # till the operation succeeds, freezing the server :/
429 499
430 # TODO: use suspend/resume instead 500 LOG llevError, Carp::longmess "sync job";#d#
431 # (but this is cancel-safe) 501
432 my $freeze_guard = freeze_mainloop; 502 my $freeze_guard = freeze_mainloop;
433 503
434 my $busy = 1; 504 my $busy = 1;
435 my @res; 505 my @res;
436 506
437 (async { 507 (async {
508 $Coro::current->desc ("sync job coro");
438 @res = eval { $job->() }; 509 @res = eval { $job->() };
439 warn $@ if $@; 510 warn $@ if $@;
440 undef $busy; 511 undef $busy;
441 })->prio (Coro::PRIO_MAX); 512 })->prio (Coro::PRIO_MAX);
442 513
443 while ($busy) { 514 while ($busy) {
444 Coro::cede or Event::one_event; 515 if (Coro::nready) {
516 Coro::cede_notself;
517 } else {
518 EV::loop EV::LOOP_ONESHOT;
445 } 519 }
520 }
446 521
447 $time = Event::time - $time; 522 my $time = EV::time - $time;
448 523
449 LOG llevError | logBacktrace, Carp::longmess "long sync job"
450 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
451
452 $tick_start += $time; # do not account sync jobs to server load 524 $TICK_START += $time; # do not account sync jobs to server load
453 525
454 wantarray ? @res : $res[0] 526 wantarray ? @res : $res[0]
455 } else { 527 } else {
456 # we are in another coroutine, how wonderful, everything just works 528 # we are in another coroutine, how wonderful, everything just works
457 529
482=item fork_call { }, $args 554=item fork_call { }, $args
483 555
484Executes the given code block with the given arguments in a seperate 556Executes the given code block with the given arguments in a seperate
485process, returning the results. Everything must be serialisable with 557process, returning the results. Everything must be serialisable with
486Coro::Storable. May, of course, block. Note that the executed sub may 558Coro::Storable. May, of course, block. Note that the executed sub may
487never block itself or use any form of Event handling. 559never block itself or use any form of event handling.
488 560
489=cut 561=cut
490 562
491sub fork_call(&@) { 563sub fork_call(&@) {
492 my ($cb, @args) = @_; 564 my ($cb, @args) = @_;
499 reset_signals; 571 reset_signals;
500 &$cb 572 &$cb
501 }, @args; 573 }, @args;
502 574
503 wantarray ? @res : $res[-1] 575 wantarray ? @res : $res[-1]
576}
577
578=item $coin = coin_from_name $name
579
580=cut
581
582our %coin_alias = (
583 "silver" => "silvercoin",
584 "silvercoin" => "silvercoin",
585 "silvercoins" => "silvercoin",
586 "gold" => "goldcoin",
587 "goldcoin" => "goldcoin",
588 "goldcoins" => "goldcoin",
589 "platinum" => "platinacoin",
590 "platinumcoin" => "platinacoin",
591 "platinumcoins" => "platinacoin",
592 "platina" => "platinacoin",
593 "platinacoin" => "platinacoin",
594 "platinacoins" => "platinacoin",
595 "royalty" => "royalty",
596 "royalties" => "royalty",
597);
598
599sub coin_from_name($) {
600 $coin_alias{$_[0]}
601 ? cf::arch::find $coin_alias{$_[0]}
602 : undef
504} 603}
505 604
506=item $value = cf::db_get $family => $key 605=item $value = cf::db_get $family => $key
507 606
508Returns a single value from the environment database. 607Returns a single value from the environment database.
647 746
648############################################################################# 747#############################################################################
649 748
650=head2 ATTACHABLE OBJECTS 749=head2 ATTACHABLE OBJECTS
651 750
652Many objects in crossfire are so-called attachable objects. That means you can 751Many objects in deliantra are so-called attachable objects. That means you can
653attach callbacks/event handlers (a collection of which is called an "attachment") 752attach callbacks/event handlers (a collection of which is called an "attachment")
654to it. All such attachable objects support the following methods. 753to it. All such attachable objects support the following methods.
655 754
656In the following description, CLASS can be any of C<global>, C<object> 755In the following description, CLASS can be any of C<global>, C<object>
657C<player>, C<client> or C<map> (i.e. the attachable objects in 756C<player>, C<client> or C<map> (i.e. the attachable objects in
658Crossfire TRT). 757Deliantra).
659 758
660=over 4 759=over 4
661 760
662=item $attachable->attach ($attachment, key => $value...) 761=item $attachable->attach ($attachment, key => $value...)
663 762
707=item cf::CLASS::attachment $name, ... 806=item cf::CLASS::attachment $name, ...
708 807
709Register an attachment by C<$name> through which attachable objects of the 808Register an attachment by C<$name> through which attachable objects of the
710given CLASS can refer to this attachment. 809given CLASS can refer to this attachment.
711 810
712Some classes such as crossfire maps and objects can specify attachments 811Some classes such as deliantra maps and objects can specify attachments
713that are attached at load/instantiate time, thus the need for a name. 812that are attached at load/instantiate time, thus the need for a name.
714 813
715These calls expect any number of the following handler/hook descriptions: 814These calls expect any number of the following handler/hook descriptions:
716 815
717=over 4 816=over 4
945 } 1044 }
946 1045
947 0 1046 0
948} 1047}
949 1048
950=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 1049=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
951 1050
952=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 1051=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
953 1052
954Generate an object-specific event with the given arguments. 1053Generate an object-specific event with the given arguments.
955 1054
961 1060
962=cut 1061=cut
963 1062
964############################################################################# 1063#############################################################################
965# object support 1064# object support
966#
967 1065
1066sub _object_equal($$);
1067sub _object_equal($$) {
1068 my ($a, $b) = @_;
1069
1070 return 0 unless (ref $a) eq (ref $b);
1071
1072 if ("HASH" eq ref $a) {
1073 my @ka = keys %$a;
1074 my @kb = keys %$b;
1075
1076 return 0 if @ka != @kb;
1077
1078 for (0 .. $#ka) {
1079 return 0 unless $ka[$_] eq $kb[$_];
1080 return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
1081 }
1082
1083 } elsif ("ARRAY" eq ref $a) {
1084
1085 return 0 if @$a != @$b;
1086
1087 for (0 .. $#$a) {
1088 return 0 unless _object_equal $a->[$_], $b->[$_];
1089 }
1090
1091 } elsif ($a ne $b) {
1092 return 0;
1093 }
1094
1095 1
1096}
1097
1098our $SLOW_MERGES;#d#
968sub _can_merge { 1099sub _can_merge {
969 my ($ob1, $ob2) = @_; 1100 my ($ob1, $ob2) = @_;
970 1101
971 local $Storable::canonical = 1; 1102 ++$SLOW_MERGES;#d#
972 my $fob1 = Storable::freeze $ob1;
973 my $fob2 = Storable::freeze $ob2;
974 1103
975 $fob1 eq $fob2 1104 # we do the slow way here
1105 return _object_equal $ob1, $ob2
976} 1106}
977 1107
978sub reattach { 1108sub reattach {
979 # basically do the same as instantiate, without calling instantiate 1109 # basically do the same as instantiate, without calling instantiate
980 my ($obj) = @_; 1110 my ($obj) = @_;
981 1111
1112 # no longer needed after getting rid of delete_package?
982 bless $obj, ref $obj; # re-bless in case extensions have been reloaded 1113 #bless $obj, ref $obj; # re-bless in case extensions have been reloaded
983 1114
984 my $registry = $obj->registry; 1115 my $registry = $obj->registry;
985 1116
986 @$registry = (); 1117 @$registry = ();
987 1118
1002cf::attachable->attach ( 1133cf::attachable->attach (
1003 prio => -1000000, 1134 prio => -1000000,
1004 on_instantiate => sub { 1135 on_instantiate => sub {
1005 my ($obj, $data) = @_; 1136 my ($obj, $data) = @_;
1006 1137
1007 $data = from_json $data; 1138 $data = decode_json $data;
1008 1139
1009 for (@$data) { 1140 for (@$data) {
1010 my ($name, $args) = @$_; 1141 my ($name, $args) = @$_;
1011 1142
1012 $obj->attach ($name, %{$args || {} }); 1143 $obj->attach ($name, %{$args || {} });
1033 utf8::decode (my $decname = $filename); 1164 utf8::decode (my $decname = $filename);
1034 warn sprintf "saving %s (%d,%d)\n", 1165 warn sprintf "saving %s (%d,%d)\n",
1035 $decname, length $$rdata, scalar @$objs; 1166 $decname, length $$rdata, scalar @$objs;
1036 1167
1037 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1168 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1038 chmod SAVE_MODE, $fh; 1169 aio_chmod $fh, SAVE_MODE;
1039 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1170 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1040 aio_fsync $fh if $cf::USE_FSYNC; 1171 aio_fsync $fh if $cf::USE_FSYNC;
1041 close $fh; 1172 aio_close $fh;
1042 1173
1043 if (@$objs) { 1174 if (@$objs) {
1044 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1175 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1045 chmod SAVE_MODE, $fh; 1176 aio_chmod $fh, SAVE_MODE;
1046 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1177 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1047 aio_write $fh, 0, (length $data), $data, 0; 1178 aio_write $fh, 0, (length $data), $data, 0;
1048 aio_fsync $fh if $cf::USE_FSYNC; 1179 aio_fsync $fh if $cf::USE_FSYNC;
1049 close $fh; 1180 aio_close $fh;
1050 aio_rename "$filename.pst~", "$filename.pst"; 1181 aio_rename "$filename.pst~", "$filename.pst";
1051 } 1182 }
1052 } else { 1183 } else {
1053 aio_unlink "$filename.pst"; 1184 aio_unlink "$filename.pst";
1054 } 1185 }
1082 1213
1083 unless (aio_stat "$filename.pst") { 1214 unless (aio_stat "$filename.pst") {
1084 (aio_load "$filename.pst", $av) >= 0 1215 (aio_load "$filename.pst", $av) >= 0
1085 or return; 1216 or return;
1086 1217
1087 $av = eval { (Storable::thaw $av)->{objs} }; 1218 my $st = eval { Coro::Storable::thaw $av };
1219 $av = $st->{objs};
1088 } 1220 }
1089 1221
1090 utf8::decode (my $decname = $filename); 1222 utf8::decode (my $decname = $filename);
1091 warn sprintf "loading %s (%d,%d)\n", 1223 warn sprintf "loading %s (%d,%d)\n",
1092 $decname, length $data, scalar @{$av || []}; 1224 $decname, length $data, scalar @{$av || []};
1222 1354
1223 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 } 1355 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1224 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; 1356 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1225 1357
1226 $ext{source} = 1358 $ext{source} =
1227 "package $pkg; use strict; use utf8;\n" 1359 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n"
1228 . "#line 1 \"$path\"\n{\n" 1360 . "#line 1 \"$path\"\n{\n"
1229 . $source 1361 . $source
1230 . "\n};\n1"; 1362 . "\n};\n1";
1231 1363
1232 $todo{$base} = \%ext; 1364 $todo{$base} = \%ext;
1248 my $msg = $@ ? "$v->{path}: $@\n" 1380 my $msg = $@ ? "$v->{path}: $@\n"
1249 : "$v->{base}: extension inactive.\n"; 1381 : "$v->{base}: extension inactive.\n";
1250 1382
1251 if (exists $v->{meta}{mandatory}) { 1383 if (exists $v->{meta}{mandatory}) {
1252 warn $msg; 1384 warn $msg;
1253 warn "mandatory extension failed to load, exiting.\n"; 1385 cf::cleanup "mandatory extension failed to load, exiting.";
1254 exit 1;
1255 } 1386 }
1256 1387
1257 warn $msg; 1388 warn $msg;
1258 } 1389 }
1259 1390
1273 1404
1274=back 1405=back
1275 1406
1276=head2 CORE EXTENSIONS 1407=head2 CORE EXTENSIONS
1277 1408
1278Functions and methods that extend core crossfire objects. 1409Functions and methods that extend core deliantra objects.
1279 1410
1280=cut 1411=cut
1281 1412
1282package cf::player; 1413package cf::player;
1283 1414
1348 my $f = new_from_file cf::object::thawer path $login 1479 my $f = new_from_file cf::object::thawer path $login
1349 or return; 1480 or return;
1350 1481
1351 my $pl = cf::player::load_pl $f 1482 my $pl = cf::player::load_pl $f
1352 or return; 1483 or return;
1484
1353 local $cf::PLAYER_LOADING{$login} = $pl; 1485 local $cf::PLAYER_LOADING{$login} = $pl;
1354 $f->resolve_delayed_derefs; 1486 $f->resolve_delayed_derefs;
1355 $cf::PLAYER{$login} = $pl 1487 $cf::PLAYER{$login} = $pl
1356 } 1488 }
1357 } 1489 }
1367 1499
1368 return if $pl->{deny_save}; 1500 return if $pl->{deny_save};
1369 1501
1370 aio_mkdir playerdir $pl, 0770; 1502 aio_mkdir playerdir $pl, 0770;
1371 $pl->{last_save} = $cf::RUNTIME; 1503 $pl->{last_save} = $cf::RUNTIME;
1504
1505 cf::get_slot 0.01;
1372 1506
1373 $pl->save_pl ($path); 1507 $pl->save_pl ($path);
1374 cf::cede_to_tick; 1508 cf::cede_to_tick;
1375} 1509}
1376 1510
1408 my ($pl) = @_; 1542 my ($pl) = @_;
1409 1543
1410 my $name = $pl->ob->name; 1544 my $name = $pl->ob->name;
1411 1545
1412 $pl->{deny_save} = 1; 1546 $pl->{deny_save} = 1;
1413 $pl->password ("*"); # this should lock out the player until we nuked the dir 1547 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1414 1548
1415 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1549 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1416 $pl->deactivate; 1550 $pl->deactivate;
1551 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1552 $pl->ob->check_score;
1417 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1553 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1418 $pl->ns->destroy if $pl->ns; 1554 $pl->ns->destroy if $pl->ns;
1419 1555
1420 my $path = playerdir $pl; 1556 my $path = playerdir $pl;
1421 my $temp = "$path~$cf::RUNTIME~deleting~"; 1557 my $temp = "$path~$cf::RUNTIME~deleting~";
1460 1596
1461 for my $login (@$dirs) { 1597 for my $login (@$dirs) {
1462 my $path = path $login; 1598 my $path = path $login;
1463 1599
1464 # a .pst is a dead give-away for a valid player 1600 # a .pst is a dead give-away for a valid player
1465 unless (-e "$path.pst") { 1601 # if no pst file found, open and chekc for blocked users
1602 if (aio_stat "$path.pst") {
1466 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next; 1603 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1467 aio_read $fh, 0, 512, my $buf, 0 or next; 1604 aio_read $fh, 0, 512, my $buf, 0 or next;
1468 $buf !~ /^password -------------$/m or next; # official not-valid tag 1605 $buf !~ /^password -------------$/m or next; # official not-valid tag
1469 } 1606 }
1470 1607
1501 } 1638 }
1502 1639
1503 \@paths 1640 \@paths
1504} 1641}
1505 1642
1506=item $protocol_xml = $player->expand_cfpod ($crossfire_pod) 1643=item $protocol_xml = $player->expand_cfpod ($cfpod)
1507 1644
1508Expand crossfire pod fragments into protocol xml. 1645Expand deliantra pod fragments into protocol xml.
1509
1510=cut
1511
1512sub expand_cfpod {
1513 ((my $self), (local $_)) = @_;
1514
1515 # escape & and <
1516 s/&/&amp;/g;
1517 s/(?<![BIUGHT])</&lt;/g;
1518
1519 # this is buggy, it needs to properly take care of nested <'s
1520
1521 1 while
1522 # replace B<>, I<>, U<> etc.
1523 s/B<([^\>]*)>/<b>$1<\/b>/
1524 || s/I<([^\>]*)>/<i>$1<\/i>/
1525 || s/U<([^\>]*)>/<u>$1<\/u>/
1526 || s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/
1527 # replace G<male|female> tags
1528 || s{G<([^>|]*)\|([^>]*)>}{
1529 $self->gender ? $2 : $1
1530 }ge
1531 # replace H<hint text>
1532 || s{H<([^\>]*)>}
1533 {
1534 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
1535 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1536 "")
1537 [$self->{hintmode}]
1538 }ge;
1539
1540 # create single paragraphs (very hackish)
1541 s/(?<=\S)\n(?=\w)/ /g;
1542
1543 # compress some whitespace
1544 s/\s+\n/\n/g; # ws line-ends
1545 s/\n\n+/\n/g; # double lines
1546 s/^\n+//; # beginning lines
1547 s/\n+$//; # ending lines
1548
1549 $_
1550}
1551
1552sub hintmode {
1553 $_[0]{hintmode} = $_[1] if @_ > 1;
1554 $_[0]{hintmode}
1555}
1556 1646
1557=item $player->ext_reply ($msgid, @msg) 1647=item $player->ext_reply ($msgid, @msg)
1558 1648
1559Sends an ext reply to the player. 1649Sends an ext reply to the player.
1560 1650
1627our $MAX_RESET = 3600; 1717our $MAX_RESET = 3600;
1628our $DEFAULT_RESET = 3000; 1718our $DEFAULT_RESET = 3000;
1629 1719
1630sub generate_random_map { 1720sub generate_random_map {
1631 my ($self, $rmp) = @_; 1721 my ($self, $rmp) = @_;
1722
1723 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1724
1632 # mit "rum" bekleckern, nicht 1725 # mit "rum" bekleckern, nicht
1633 $self->_create_random_map ( 1726 $self->_create_random_map (
1634 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1727 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1635 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1728 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1636 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1729 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1758 1851
1759# the temporary/swap location 1852# the temporary/swap location
1760sub save_path { 1853sub save_path {
1761 my ($self) = @_; 1854 my ($self) = @_;
1762 1855
1763 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1856 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1764 "$TMPDIR/$path.map" 1857 "$TMPDIR/$path.map"
1765} 1858}
1766 1859
1767# the unique path, undef == no special unique path 1860# the unique path, undef == no special unique path
1768sub uniq_path { 1861sub uniq_path {
1769 my ($self) = @_; 1862 my ($self) = @_;
1770 1863
1771 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1864 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1772 "$UNIQUEDIR/$path" 1865 "$UNIQUEDIR/$path"
1773} 1866}
1774 1867
1775# and all this just because we cannot iterate over 1868# and all this just because we cannot iterate over
1776# all maps in C++... 1869# all maps in C++...
1874 1967
1875 cf::lock_wait "map_data:$path";#d#remove 1968 cf::lock_wait "map_data:$path";#d#remove
1876 cf::lock_wait "map_find:$path"; 1969 cf::lock_wait "map_find:$path";
1877 1970
1878 $cf::MAP{$path} || do { 1971 $cf::MAP{$path} || do {
1879 my $guard1 = cf::lock_acquire "map_find:$path";
1880 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it 1972 my $guard1 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1973 my $guard2 = cf::lock_acquire "map_find:$path";
1881 1974
1882 my $map = new_from_path cf::map $path 1975 my $map = new_from_path cf::map $path
1883 or return; 1976 or return;
1884 1977
1885 $map->{last_save} = $cf::RUNTIME; 1978 $map->{last_save} = $cf::RUNTIME;
1888 or return; 1981 or return;
1889 1982
1890 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 1983 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1891 # doing this can freeze the server in a sync job, obviously 1984 # doing this can freeze the server in a sync job, obviously
1892 #$cf::WAIT_FOR_TICK->wait; 1985 #$cf::WAIT_FOR_TICK->wait;
1986 undef $guard2;
1893 undef $guard1; 1987 undef $guard1;
1894 undef $guard2;
1895 $map->reset; 1988 $map->reset;
1896 return find $path; 1989 return find $path;
1897 } 1990 }
1898 1991
1899 $cf::MAP{$path} = $map 1992 $cf::MAP{$path} = $map
1926 my $f = new_from_file cf::object::thawer $self->{load_path}; 2019 my $f = new_from_file cf::object::thawer $self->{load_path};
1927 $f->skip_block; 2020 $f->skip_block;
1928 $self->_load_objects ($f) 2021 $self->_load_objects ($f)
1929 or return; 2022 or return;
1930 2023
1931 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2024 $self->post_load_original
1932 if delete $self->{load_original}; 2025 if delete $self->{load_original};
1933 2026
1934 if (my $uniq = $self->uniq_path) { 2027 if (my $uniq = $self->uniq_path) {
1935 utf8::encode $uniq; 2028 utf8::encode $uniq;
1936 unless (aio_stat $uniq) { 2029 unless (aio_stat $uniq) {
1962 } 2055 }
1963 2056
1964 $self->{last_save} = $cf::RUNTIME; 2057 $self->{last_save} = $cf::RUNTIME;
1965 $self->last_access ($cf::RUNTIME); 2058 $self->last_access ($cf::RUNTIME);
1966 2059
1967 $self->in_memory (cf::MAP_IN_MEMORY); 2060 $self->in_memory (cf::MAP_ACTIVE);
1968 } 2061 }
1969 2062
1970 $self->post_load; 2063 $self->post_load;
1971} 2064}
1972 2065
2030 my ($path, $origin, $load) = @_; 2123 my ($path, $origin, $load) = @_;
2031 2124
2032 $path = normalise $path, $origin && $origin->{path}; 2125 $path = normalise $path, $origin && $origin->{path};
2033 2126
2034 if (my $map = $cf::MAP{$path}) { 2127 if (my $map = $cf::MAP{$path}) {
2035 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY; 2128 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
2036 } 2129 }
2037 2130
2038 $MAP_PREFETCH{$path} |= $load; 2131 $MAP_PREFETCH{$path} |= $load;
2039 2132
2040 $MAP_PREFETCHER ||= cf::async { 2133 $MAP_PREFETCHER ||= cf::async {
2134 $Coro::current->{desc} = "map prefetcher";
2135
2041 while (%MAP_PREFETCH) { 2136 while (%MAP_PREFETCH) {
2042 while (my ($k, $v) = each %MAP_PREFETCH) { 2137 while (my ($k, $v) = each %MAP_PREFETCH) {
2043 if (my $map = find $k) { 2138 if (my $map = find $k) {
2044 $map->load if $v; 2139 $map->load if $v;
2045 } 2140 }
2071 return if $self->{deny_save}; 2166 return if $self->{deny_save};
2072 2167
2073 local $self->{last_access} = $self->last_access;#d# 2168 local $self->{last_access} = $self->last_access;#d#
2074 2169
2075 cf::async { 2170 cf::async {
2171 $Coro::current->{desc} = "map player save";
2076 $_->contr->save for $self->players; 2172 $_->contr->save for $self->players;
2077 }; 2173 };
2174
2175 cf::get_slot 0.02;
2078 2176
2079 if ($uniq) { 2177 if ($uniq) {
2080 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2178 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
2081 $self->_save_objects ($uniq, cf::IO_UNIQUES); 2179 $self->_save_objects ($uniq, cf::IO_UNIQUES);
2082 } else { 2180 } else {
2091 $self->save; 2189 $self->save;
2092 2190
2093 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2191 my $lock = cf::lock_acquire "map_data:$self->{path}";
2094 2192
2095 return if $self->players; 2193 return if $self->players;
2096 return if $self->in_memory != cf::MAP_IN_MEMORY; 2194 return if $self->in_memory != cf::MAP_ACTIVE;
2097 return if $self->{deny_save}; 2195 return if $self->{deny_save};
2098 2196
2099 $self->in_memory (cf::MAP_SWAPPED); 2197 $self->in_memory (cf::MAP_SWAPPED);
2100 2198
2101 $self->deactivate; 2199 $self->deactivate;
2219 2317
2220sub unique_maps() { 2318sub unique_maps() {
2221 [ 2319 [
2222 map { 2320 map {
2223 utf8::decode $_; 2321 utf8::decode $_;
2224 /\.map$/ 2322 s/\.map$//; # TODO future compatibility hack
2323 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
2324 ? ()
2225 ? normalise $_ 2325 : normalise $_
2226 : ()
2227 } @{ aio_readdir $UNIQUEDIR or [] } 2326 } @{ aio_readdir $UNIQUEDIR or [] }
2228 ] 2327 ]
2229} 2328}
2230 2329
2231package cf;
2232
2233=back 2330=back
2234 2331
2235=head3 cf::object 2332=head3 cf::object
2236 2333
2237=cut 2334=cut
2240 2337
2241=over 4 2338=over 4
2242 2339
2243=item $ob->inv_recursive 2340=item $ob->inv_recursive
2244 2341
2245Returns the inventory of the object _and_ their inventories, recursively. 2342Returns the inventory of the object I<and> their inventories, recursively,
2343but I<not> the object itself.
2246 2344
2247=cut 2345=cut
2248 2346
2249sub inv_recursive_; 2347sub inv_recursive_;
2250sub inv_recursive_ { 2348sub inv_recursive_ {
2255 inv_recursive_ inv $_[0] 2353 inv_recursive_ inv $_[0]
2256} 2354}
2257 2355
2258=item $ref = $ob->ref 2356=item $ref = $ob->ref
2259 2357
2260creates and returns a persistent reference to an objetc that can be stored as a string. 2358Creates and returns a persistent reference to an object that can be stored as a string.
2261 2359
2262=item $ob = cf::object::deref ($refstring) 2360=item $ob = cf::object::deref ($refstring)
2263 2361
2264returns the objetc referenced by refstring. may return undef when it cnanot find the object, 2362returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2265even if the object actually exists. May block. 2363even if the object actually exists. May block.
2267=cut 2365=cut
2268 2366
2269sub deref { 2367sub deref {
2270 my ($ref) = @_; 2368 my ($ref) = @_;
2271 2369
2272 # temporary compatibility#TODO#remove
2273 $ref =~ s{^<}{player/<};
2274
2275 if ($ref =~ m{^player\/(<1\.\d+>)/(.*)$}) { 2370 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2276 my ($uuid, $name) = ($1, $2); 2371 my ($uuid, $name) = ($1, $2);
2277 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name 2372 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2278 or return; 2373 or return;
2279 $pl->ob->uuid eq $uuid 2374 $pl->ob->uuid eq $uuid
2280 or return; 2375 or return;
2300can be C<undef>. Does the right thing when the player is currently in a 2395can be C<undef>. Does the right thing when the player is currently in a
2301dialogue with the given NPC character. 2396dialogue with the given NPC character.
2302 2397
2303=cut 2398=cut
2304 2399
2400our $SAY_CHANNEL = {
2401 id => "say",
2402 title => "Map",
2403 reply => "say ",
2404 tooltip => "Things said to and replied from npcs near you and other players on the same map only.",
2405};
2406
2407our $CHAT_CHANNEL = {
2408 id => "chat",
2409 title => "Chat",
2410 reply => "chat ",
2411 tooltip => "Player chat and shouts, global to the server.",
2412};
2413
2305# rough implementation of a future "reply" method that works 2414# rough implementation of a future "reply" method that works
2306# with dialog boxes. 2415# with dialog boxes.
2307#TODO: the first argument must go, split into a $npc->reply_to ( method 2416#TODO: the first argument must go, split into a $npc->reply_to ( method
2308sub cf::object::player::reply($$$;$) { 2417sub cf::object::player::reply($$$;$) {
2309 my ($self, $npc, $msg, $flags) = @_; 2418 my ($self, $npc, $msg, $flags) = @_;
2320 my $dialog = $pl->{npc_dialog}; 2429 my $dialog = $pl->{npc_dialog};
2321 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg)); 2430 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2322 2431
2323 } else { 2432 } else {
2324 $msg = $npc->name . " says: $msg" if $npc; 2433 $msg = $npc->name . " says: $msg" if $npc;
2325 $self->message ($msg, $flags); 2434 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2326 } 2435 }
2327 } 2436 }
2328} 2437}
2329 2438
2330=item $object->send_msg ($channel, $msg, $color, [extra...]) 2439=item $object->send_msg ($channel, $msg, $color, [extra...])
2355 2464
2356=item $player_object->enter_link 2465=item $player_object->enter_link
2357 2466
2358Freezes the player and moves him/her to a special map (C<{link}>). 2467Freezes the player and moves him/her to a special map (C<{link}>).
2359 2468
2360The player should be reasonably safe there for short amounts of time. You 2469The player should be reasonably safe there for short amounts of time (e.g.
2361I<MUST> call C<leave_link> as soon as possible, though. 2470for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2471though, as the palyer cannot control the character while it is on the link
2472map.
2362 2473
2363Will never block. 2474Will never block.
2364 2475
2365=item $player_object->leave_link ($map, $x, $y) 2476=item $player_object->leave_link ($map, $x, $y)
2366 2477
2424 2535
2425 $map->load; 2536 $map->load;
2426 $map->load_neighbours; 2537 $map->load_neighbours;
2427 2538
2428 return unless $self->contr->active; 2539 return unless $self->contr->active;
2540 $self->flag (cf::FLAG_DEBUG, 0);#d# temp
2429 $self->activate_recursive; 2541 $self->activate_recursive;
2430 2542
2431 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2543 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2432 $self->enter_map ($map, $x, $y); 2544 $self->enter_map ($map, $x, $y);
2433} 2545}
2438her, loading and preparing them map, calling the provided $check callback 2550her, loading and preparing them map, calling the provided $check callback
2439that has to return the map if sucecssful, and then unfreezes the player on 2551that has to return the map if sucecssful, and then unfreezes the player on
2440the new (success) or old (failed) map position. In either case, $done will 2552the new (success) or old (failed) map position. In either case, $done will
2441be called at the end of this process. 2553be called at the end of this process.
2442 2554
2555Note that $check will be called with a potentially non-loaded map, so if
2556it needs a loaded map it has to call C<< ->load >>.
2557
2443=cut 2558=cut
2444 2559
2445our $GOTOGEN; 2560our $GOTOGEN;
2446 2561
2447sub cf::object::player::goto { 2562sub cf::object::player::goto {
2451 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2566 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2452 2567
2453 $self->enter_link; 2568 $self->enter_link;
2454 2569
2455 (async { 2570 (async {
2571 $Coro::current->{desc} = "player::goto $path $x $y";
2572
2456 # *tag paths override both path and x|y 2573 # *tag paths override both path and x|y
2457 if ($path =~ /^\*(.*)$/) { 2574 if ($path =~ /^\*(.*)$/) {
2458 if (my @obs = grep $_->map, ext::map_tags::find $1) { 2575 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2459 my $ob = $obs[rand @obs]; 2576 my $ob = $obs[rand @obs];
2460 2577
2523} 2640}
2524 2641
2525sub prepare_random_map { 2642sub prepare_random_map {
2526 my ($exit) = @_; 2643 my ($exit) = @_;
2527 2644
2528 my $guard = cf::lock_acquire "exit_prepare:$exit";
2529
2530 # all this does is basically replace the /! path by 2645 # all this does is basically replace the /! path by
2531 # a new random map path (?random/...) with a seed 2646 # a new random map path (?random/...) with a seed
2532 # that depends on the exit object 2647 # that depends on the exit object
2533 2648
2534 my $rmp = parse_random_map_params $exit->msg; 2649 my $rmp = parse_random_map_params $exit->msg;
2536 if ($exit->map) { 2651 if ($exit->map) {
2537 $rmp->{region} = $exit->region->name; 2652 $rmp->{region} = $exit->region->name;
2538 $rmp->{origin_map} = $exit->map->path; 2653 $rmp->{origin_map} = $exit->map->path;
2539 $rmp->{origin_x} = $exit->x; 2654 $rmp->{origin_x} = $exit->x;
2540 $rmp->{origin_y} = $exit->y; 2655 $rmp->{origin_y} = $exit->y;
2656
2657 $exit->map->touch;
2541 } 2658 }
2542 2659
2543 $rmp->{random_seed} ||= $exit->random_seed; 2660 $rmp->{random_seed} ||= $exit->random_seed;
2544 2661
2545 my $data = cf::to_json $rmp; 2662 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2546 my $md5 = Digest::MD5::md5_hex $data; 2663 my $md5 = Digest::MD5::md5_hex $data;
2547 my $meta = "$RANDOMDIR/$md5.meta"; 2664 my $meta = "$RANDOMDIR/$md5.meta";
2548 2665
2549 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2666 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2550 aio_write $fh, 0, (length $data), $data, 0; 2667 aio_write $fh, 0, (length $data), $data, 0;
2551 undef $fh; 2668 undef $fh;
2552 aio_rename "$meta~", $meta; 2669 aio_rename "$meta~", $meta;
2553 2670
2671 my $slaying = "?random/$md5";
2672
2673 if ($exit->valid) {
2554 $exit->slaying ("?random/$md5"); 2674 $exit->slaying ("?random/$md5");
2555 $exit->msg (undef); 2675 $exit->msg (undef);
2676 }
2556 } 2677 }
2557} 2678}
2558 2679
2559sub cf::object::player::enter_exit { 2680sub cf::object::player::enter_exit {
2560 my ($self, $exit) = @_; 2681 my ($self, $exit) = @_;
2561 2682
2562 return unless $self->type == cf::PLAYER; 2683 return unless $self->type == cf::PLAYER;
2563 2684
2564 if ($exit->slaying eq "/!") {
2565 #TODO: this should de-fi-ni-te-ly not be a sync-job
2566 # the problem is that $exit might not survive long enough
2567 # so it needs to be done right now, right here
2568 cf::sync_job { prepare_random_map $exit };
2569 }
2570
2571 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2572 my $hp = $exit->stats->hp;
2573 my $sp = $exit->stats->sp;
2574
2575 $self->enter_link; 2685 $self->enter_link;
2576 2686
2577 # if exit is damned, update players death & WoR home-position
2578 $self->contr->savebed ($slaying, $hp, $sp)
2579 if $exit->flag (FLAG_DAMNED);
2580
2581 (async { 2687 (async {
2582 $self->deactivate_recursive; # just to be sure 2688 $Coro::current->{desc} = "enter_exit";
2689
2583 unless (eval { 2690 unless (eval {
2691 $self->deactivate_recursive; # just to be sure
2692
2693 # random map handling
2694 {
2695 my $guard = cf::lock_acquire "exit_prepare:$exit";
2696
2697 prepare_random_map $exit
2698 if $exit->slaying eq "/!";
2699 }
2700
2701 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2702 my $x = $exit->stats->hp;
2703 my $y = $exit->stats->sp;
2704
2584 $self->goto ($slaying, $hp, $sp); 2705 $self->goto ($map, $x, $y);
2585 2706
2707 # if exit is damned, update players death & WoR home-position
2708 $self->contr->savebed ($map, $x, $y)
2709 if $exit->flag (cf::FLAG_DAMNED);
2710
2586 1; 2711 1
2587 }) { 2712 }) {
2588 $self->message ("Something went wrong deep within the crossfire server. " 2713 $self->message ("Something went wrong deep within the deliantra server. "
2589 . "I'll try to bring you back to the map you were before. " 2714 . "I'll try to bring you back to the map you were before. "
2590 . "Please report this to the dungeon master!", 2715 . "Please report this to the dungeon master!",
2591 cf::NDI_UNIQUE | cf::NDI_RED); 2716 cf::NDI_UNIQUE | cf::NDI_RED);
2592 2717
2593 warn "ERROR in enter_exit: $@"; 2718 warn "ERROR in enter_exit: $@";
2621the message, with C<log> being the default. If C<$color> is negative, suppress 2746the message, with C<log> being the default. If C<$color> is negative, suppress
2622the message unless the client supports the msg packet. 2747the message unless the client supports the msg packet.
2623 2748
2624=cut 2749=cut
2625 2750
2751# non-persistent channels (usually the info channel)
2626our %CHANNEL = ( 2752our %CHANNEL = (
2627 "c/identify" => { 2753 "c/identify" => {
2628 id => "identify", 2754 id => "infobox",
2629 title => "Identify", 2755 title => "Identify",
2630 reply => undef, 2756 reply => undef,
2631 tooltip => "Items recently identified", 2757 tooltip => "Items recently identified",
2632 }, 2758 },
2633 "c/examine" => { 2759 "c/examine" => {
2634 id => "examine", 2760 id => "infobox",
2635 title => "Examine", 2761 title => "Examine",
2636 reply => undef, 2762 reply => undef,
2637 tooltip => "Signs and other items you examined", 2763 tooltip => "Signs and other items you examined",
2638 }, 2764 },
2765 "c/book" => {
2766 id => "infobox",
2767 title => "Book",
2768 reply => undef,
2769 tooltip => "The contents of a note or book",
2770 },
2771 "c/lookat" => {
2772 id => "infobox",
2773 title => "Look",
2774 reply => undef,
2775 tooltip => "What you saw there",
2776 },
2777 "c/who" => {
2778 id => "infobox",
2779 title => "Players",
2780 reply => undef,
2781 tooltip => "Shows players who are currently online",
2782 },
2783 "c/body" => {
2784 id => "infobox",
2785 title => "Body Parts",
2786 reply => undef,
2787 tooltip => "Shows which body parts you posess and are available",
2788 },
2789 "c/uptime" => {
2790 id => "infobox",
2791 title => "Uptime",
2792 reply => undef,
2793 tooltip => "How long the server has been running since last restart",
2794 },
2795 "c/mapinfo" => {
2796 id => "infobox",
2797 title => "Map Info",
2798 reply => undef,
2799 tooltip => "Information related to the maps",
2800 },
2801 "c/party" => {
2802 id => "party",
2803 title => "Party",
2804 reply => "gsay ",
2805 tooltip => "Messages and chat related to your party",
2806 },
2639); 2807);
2640 2808
2641sub cf::client::send_msg { 2809sub cf::client::send_msg {
2642 my ($self, $channel, $msg, $color, @extra) = @_; 2810 my ($self, $channel, $msg, $color, @extra) = @_;
2643 2811
2644 $msg = $self->pl->expand_cfpod ($msg); 2812 $msg = $self->pl->expand_cfpod ($msg)
2813 unless $color & cf::NDI_VERBATIM;
2645 2814
2646 $color &= cf::NDI_CLIENT_MASK; # just in case... 2815 $color &= cf::NDI_CLIENT_MASK; # just in case...
2647 2816
2648 # check predefined channels, for the benefit of C 2817 # check predefined channels, for the benefit of C
2649 $channel = $CHANNEL{$channel} if $CHANNEL{$channel}; 2818 if ($CHANNEL{$channel}) {
2819 $channel = $CHANNEL{$channel};
2650 2820
2821 $self->ext_msg (channel_info => $channel)
2822 if $self->can_msg;
2823
2824 $channel = $channel->{id};
2825
2651 if (ref $channel) { 2826 } elsif (ref $channel) {
2652 # send meta info to client, if not yet sent 2827 # send meta info to client, if not yet sent
2653 unless (exists $self->{channel}{$channel->{id}}) { 2828 unless (exists $self->{channel}{$channel->{id}}) {
2654 $self->{channel}{$channel->{id}} = $channel; 2829 $self->{channel}{$channel->{id}} = $channel;
2655 $self->ext_msg (channel_info => $channel) 2830 $self->ext_msg (channel_info => $channel)
2656 if $self->can_msg; 2831 if $self->can_msg;
2664 if ($self->can_msg) { 2839 if ($self->can_msg) {
2665 # default colour, mask it out 2840 # default colour, mask it out
2666 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF) 2841 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2667 if $color & cf::NDI_DEF; 2842 if $color & cf::NDI_DEF;
2668 2843
2669 $self->send_packet ("msg " . $self->{json_coder}->encode ( 2844 my $pkt = "msg "
2845 . $self->{json_coder}->encode (
2670 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra])); 2846 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2847 );
2848
2849 # try lzf for large packets
2850 $pkt = "lzf " . Compress::LZF::compress $pkt
2851 if 1024 <= length $pkt and $self->{can_lzf};
2852
2853 # split very large packets
2854 if (8192 < length $pkt and $self->{can_lzf}) {
2855 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2856 $pkt = "frag";
2857 }
2858
2859 $self->send_packet ($pkt);
2671 } else { 2860 } else {
2672 if ($color >= 0) { 2861 if ($color >= 0) {
2673 # replace some tags by gcfclient-compatible ones 2862 # replace some tags by gcfclient-compatible ones
2674 for ($msg) { 2863 for ($msg) {
2675 1 while 2864 1 while
2873=pod 3062=pod
2874 3063
2875The following functions and methods are available within a safe environment: 3064The following functions and methods are available within a safe environment:
2876 3065
2877 cf::object 3066 cf::object
2878 contr pay_amount pay_player map x y force_find force_add 3067 contr pay_amount pay_player map x y force_find force_add destroy
2879 insert remove name archname title slaying race decrease_ob_nr 3068 insert remove name archname title slaying race decrease split
2880 3069
2881 cf::object::player 3070 cf::object::player
2882 player 3071 player
2883 3072
2884 cf::player 3073 cf::player
2889 3078
2890=cut 3079=cut
2891 3080
2892for ( 3081for (
2893 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3082 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2894 insert remove inv name archname title slaying race 3083 insert remove inv nrof name archname title slaying race
2895 decrease_ob_nr)], 3084 decrease split destroy change_exp)],
2896 ["cf::object::player" => qw(player)], 3085 ["cf::object::player" => qw(player)],
2897 ["cf::player" => qw(peaceful)], 3086 ["cf::player" => qw(peaceful)],
2898 ["cf::map" => qw(trigger)], 3087 ["cf::map" => qw(trigger)],
2899) { 3088) {
2900 no strict 'refs'; 3089 no strict 'refs';
3005 { 3194 {
3006 my $faces = $facedata->{faceinfo}; 3195 my $faces = $facedata->{faceinfo};
3007 3196
3008 while (my ($face, $info) = each %$faces) { 3197 while (my ($face, $info) = each %$faces) {
3009 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3198 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3199
3010 cf::face::set_visibility $idx, $info->{visibility}; 3200 cf::face::set_visibility $idx, $info->{visibility};
3011 cf::face::set_magicmap $idx, $info->{magicmap}; 3201 cf::face::set_magicmap $idx, $info->{magicmap};
3012 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3202 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
3013 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3203 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
3014 3204
3015 cf::cede_to_tick; 3205 cf::cede_to_tick;
3016 } 3206 }
3017 3207
3018 while (my ($face, $info) = each %$faces) { 3208 while (my ($face, $info) = each %$faces) {
3019 next unless $info->{smooth}; 3209 next unless $info->{smooth};
3210
3020 my $idx = cf::face::find $face 3211 my $idx = cf::face::find $face
3021 or next; 3212 or next;
3213
3022 if (my $smooth = cf::face::find $info->{smooth}) { 3214 if (my $smooth = cf::face::find $info->{smooth}) {
3023 cf::face::set_smooth $idx, $smooth; 3215 cf::face::set_smooth $idx, $smooth;
3024 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3216 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3025 } else { 3217 } else {
3026 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3218 warn "smooth face '$info->{smooth}' not found for face '$face'";
3044 { 3236 {
3045 # TODO: for gcfclient pleasure, we should give resources 3237 # TODO: for gcfclient pleasure, we should give resources
3046 # that gcfclient doesn't grok a >10000 face index. 3238 # that gcfclient doesn't grok a >10000 face index.
3047 my $res = $facedata->{resource}; 3239 my $res = $facedata->{resource};
3048 3240
3049 my $soundconf = delete $res->{"res/sound.conf"};
3050
3051 while (my ($name, $info) = each %$res) { 3241 while (my ($name, $info) = each %$res) {
3242 if (defined $info->{type}) {
3052 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3243 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3053 my $data; 3244 my $data;
3054 3245
3055 if ($info->{type} & 1) { 3246 if ($info->{type} & 1) {
3056 # prepend meta info 3247 # prepend meta info
3057 3248
3058 my $meta = $enc->encode ({ 3249 my $meta = $enc->encode ({
3059 name => $name, 3250 name => $name,
3060 %{ $info->{meta} || {} }, 3251 %{ $info->{meta} || {} },
3061 }); 3252 });
3062 3253
3063 $data = pack "(w/a*)*", $meta, $info->{data}; 3254 $data = pack "(w/a*)*", $meta, $info->{data};
3255 } else {
3256 $data = $info->{data};
3257 }
3258
3259 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3260 cf::face::set_type $idx, $info->{type};
3064 } else { 3261 } else {
3065 $data = $info->{data}; 3262 $RESOURCE{$name} = $info;
3066 } 3263 }
3067 3264
3068 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3069 cf::face::set_type $idx, $info->{type};
3070
3071 cf::cede_to_tick; 3265 cf::cede_to_tick;
3072 } 3266 }
3073
3074 if ($soundconf) {
3075 $soundconf = $enc->decode (delete $soundconf->{data});
3076
3077 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3078 my $sound = $soundconf->{compat}[$_]
3079 or next;
3080
3081 my $face = cf::face::find "sound/$sound->[1]";
3082 cf::sound::set $sound->[0] => $face;
3083 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3084 }
3085
3086 while (my ($k, $v) = each %{$soundconf->{event}}) {
3087 my $face = cf::face::find "sound/$v";
3088 cf::sound::set $k => $face;
3089 }
3090 }
3091 } 3267 }
3268
3269 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3092 3270
3093 1 3271 1
3094} 3272}
3273
3274cf::global->attach (on_resource_update => sub {
3275 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3276 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3277
3278 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3279 my $sound = $soundconf->{compat}[$_]
3280 or next;
3281
3282 my $face = cf::face::find "sound/$sound->[1]";
3283 cf::sound::set $sound->[0] => $face;
3284 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3285 }
3286
3287 while (my ($k, $v) = each %{$soundconf->{event}}) {
3288 my $face = cf::face::find "sound/$v";
3289 cf::sound::set $k => $face;
3290 }
3291 }
3292});
3095 3293
3096register_exticmd fx_want => sub { 3294register_exticmd fx_want => sub {
3097 my ($ns, $want) = @_; 3295 my ($ns, $want) = @_;
3098 3296
3099 while (my ($k, $v) = each %$want) { 3297 while (my ($k, $v) = each %$want) {
3100 $ns->fx_want ($k, $v); 3298 $ns->fx_want ($k, $v);
3101 } 3299 }
3102}; 3300};
3301
3302sub load_resource_file($) {
3303 my $guard = lock_acquire "load_resource_file";
3304
3305 my $status = load_resource_file_ $_[0];
3306 get_slot 0.1, 100;
3307 cf::arch::commit_load;
3308
3309 $status
3310}
3103 3311
3104sub reload_regions { 3312sub reload_regions {
3105 # HACK to clear player env face cache, we need some signal framework 3313 # HACK to clear player env face cache, we need some signal framework
3106 # for this (global event?) 3314 # for this (global event?)
3107 %ext::player_env::MUSIC_FACE_CACHE = (); 3315 %ext::player_env::MUSIC_FACE_CACHE = ();
3121} 3329}
3122 3330
3123sub reload_archetypes { 3331sub reload_archetypes {
3124 load_resource_file "$DATADIR/archetypes" 3332 load_resource_file "$DATADIR/archetypes"
3125 or die "unable to load archetypes\n"; 3333 or die "unable to load archetypes\n";
3126 #d# NEED to laod twice to resolve forward references
3127 # this really needs to be done in an extra post-pass
3128 # (which needs to be synchronous, so solve it differently)
3129 load_resource_file "$DATADIR/archetypes"
3130 or die "unable to load archetypes\n";
3131} 3334}
3132 3335
3133sub reload_treasures { 3336sub reload_treasures {
3134 load_resource_file "$DATADIR/treasures" 3337 load_resource_file "$DATADIR/treasures"
3135 or die "unable to load treasurelists\n"; 3338 or die "unable to load treasurelists\n";
3136} 3339}
3137 3340
3138sub reload_resources { 3341sub reload_resources {
3139 warn "reloading resource files...\n"; 3342 warn "reloading resource files...\n";
3140 3343
3344 reload_facedata;
3345 reload_archetypes;
3141 reload_regions; 3346 reload_regions;
3142 reload_facedata;
3143 #reload_archetypes;#d#
3144 reload_archetypes;
3145 reload_treasures; 3347 reload_treasures;
3146 3348
3147 warn "finished reloading resource files\n"; 3349 warn "finished reloading resource files\n";
3148} 3350}
3149 3351
3150sub init { 3352sub init {
3353 my $guard = freeze_mainloop;
3354
3355 evthread_start IO::AIO::poll_fileno;
3356
3151 reload_resources; 3357 reload_resources;
3152} 3358}
3153 3359
3154sub reload_config { 3360sub reload_config {
3155 open my $fh, "<:utf8", "$CONFDIR/config" 3361 open my $fh, "<:utf8", "$CONFDIR/config"
3156 or return; 3362 or return;
3157 3363
3158 local $/; 3364 local $/;
3159 *CFG = YAML::Syck::Load <$fh>; 3365 *CFG = YAML::Load <$fh>;
3160 3366
3161 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3367 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
3162 3368
3163 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3369 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3164 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3370 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3170 }; 3376 };
3171 warn $@ if $@; 3377 warn $@ if $@;
3172 } 3378 }
3173} 3379}
3174 3380
3381sub pidfile() {
3382 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3383 or die "$PIDFILE: $!";
3384 flock $fh, &Fcntl::LOCK_EX
3385 or die "$PIDFILE: flock: $!";
3386 $fh
3387}
3388
3389# make sure only one server instance is running at any one time
3390sub atomic {
3391 my $fh = pidfile;
3392
3393 my $pid = <$fh>;
3394 kill 9, $pid if $pid > 0;
3395
3396 seek $fh, 0, 0;
3397 print $fh $$;
3398}
3399
3175sub main { 3400sub main {
3401 atomic;
3402
3176 # we must not ever block the main coroutine 3403 # we must not ever block the main coroutine
3177 local $Coro::idle = sub { 3404 local $Coro::idle = sub {
3178 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3405 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3179 (async { 3406 (async {
3180 Event::one_event; 3407 $Coro::current->{desc} = "IDLE BUG HANDLER";
3408 EV::loop EV::LOOP_ONESHOT;
3181 })->prio (Coro::PRIO_MAX); 3409 })->prio (Coro::PRIO_MAX);
3182 }; 3410 };
3183 3411
3412 {
3413 my $guard = freeze_mainloop;
3184 reload_config; 3414 reload_config;
3185 db_init; 3415 db_init;
3186 load_extensions; 3416 load_extensions;
3187 3417
3188 $TICK_WATCHER->start; 3418 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3419 }
3420
3421 utime time, time, $RUNTIMEFILE;
3422
3423 # no (long-running) fork's whatsoever before this point(!)
3424 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3425
3189 Event::loop; 3426 EV::loop;
3190} 3427}
3191 3428
3192############################################################################# 3429#############################################################################
3193# initialisation and cleanup 3430# initialisation and cleanup
3194 3431
3195# install some emergency cleanup handlers 3432# install some emergency cleanup handlers
3196BEGIN { 3433BEGIN {
3434 our %SIGWATCHER = ();
3197 for my $signal (qw(INT HUP TERM)) { 3435 for my $signal (qw(INT HUP TERM)) {
3198 Event->signal ( 3436 $SIGWATCHER{$signal} = EV::signal $signal, sub {
3199 reentrant => 0,
3200 data => WF_AUTOCANCEL,
3201 signal => $signal,
3202 prio => 0,
3203 cb => sub {
3204 cf::cleanup "SIG$signal"; 3437 cf::cleanup "SIG$signal";
3205 },
3206 ); 3438 };
3207 } 3439 }
3208} 3440}
3209 3441
3210sub write_runtime { 3442sub write_runtime_sync {
3211 my $runtime = "$LOCALDIR/runtime";
3212
3213 # first touch the runtime file to show we are still running: 3443 # first touch the runtime file to show we are still running:
3214 # the fsync below can take a very very long time. 3444 # the fsync below can take a very very long time.
3215 3445
3216 IO::AIO::aio_utime $runtime, undef, undef; 3446 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3217 3447
3218 my $guard = cf::lock_acquire "write_runtime"; 3448 my $guard = cf::lock_acquire "write_runtime";
3219 3449
3220 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 3450 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644
3221 or return; 3451 or return;
3222 3452
3223 my $value = $cf::RUNTIME + 90 + 10; 3453 my $value = $cf::RUNTIME + 90 + 10;
3224 # 10 is the runtime save interval, for a monotonic clock 3454 # 10 is the runtime save interval, for a monotonic clock
3225 # 60 allows for the watchdog to kill the server. 3455 # 60 allows for the watchdog to kill the server.
3235 aio_utime $fh, undef, undef; 3465 aio_utime $fh, undef, undef;
3236 3466
3237 close $fh 3467 close $fh
3238 or return; 3468 or return;
3239 3469
3240 aio_rename "$runtime~", $runtime 3470 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3241 and return; 3471 and return;
3242 3472
3243 warn "runtime file written.\n"; 3473 warn "runtime file written.\n";
3244 3474
3245 1 3475 1
3476}
3477
3478our $uuid_lock;
3479our $uuid_skip;
3480
3481sub write_uuid_sync($) {
3482 $uuid_skip ||= $_[0];
3483
3484 return if $uuid_lock;
3485 local $uuid_lock = 1;
3486
3487 my $uuid = "$LOCALDIR/uuid";
3488
3489 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3490 or return;
3491
3492 my $value = uuid_str $uuid_skip + uuid_seq uuid_cur;
3493 $uuid_skip = 0;
3494
3495 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3496 and return;
3497
3498 # always fsync - this file is important
3499 aio_fsync $fh
3500 and return;
3501
3502 close $fh
3503 or return;
3504
3505 aio_rename "$uuid~", $uuid
3506 and return;
3507
3508 warn "uuid file written ($value).\n";
3509
3510 1
3511
3512}
3513
3514sub write_uuid($$) {
3515 my ($skip, $sync) = @_;
3516
3517 $sync ? write_uuid_sync $skip
3518 : async { write_uuid_sync $skip };
3246} 3519}
3247 3520
3248sub emergency_save() { 3521sub emergency_save() {
3249 my $freeze_guard = cf::freeze_mainloop; 3522 my $freeze_guard = cf::freeze_mainloop;
3250 3523
3256 # and maps saved/destroyed asynchronously. 3529 # and maps saved/destroyed asynchronously.
3257 warn "begin emergency player save\n"; 3530 warn "begin emergency player save\n";
3258 for my $login (keys %cf::PLAYER) { 3531 for my $login (keys %cf::PLAYER) {
3259 my $pl = $cf::PLAYER{$login} or next; 3532 my $pl = $cf::PLAYER{$login} or next;
3260 $pl->valid or next; 3533 $pl->valid or next;
3534 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3261 $pl->save; 3535 $pl->save;
3262 } 3536 }
3263 warn "end emergency player save\n"; 3537 warn "end emergency player save\n";
3264 3538
3265 warn "begin emergency map save\n"; 3539 warn "begin emergency map save\n";
3271 warn "end emergency map save\n"; 3545 warn "end emergency map save\n";
3272 3546
3273 warn "begin emergency database checkpoint\n"; 3547 warn "begin emergency database checkpoint\n";
3274 BDB::db_env_txn_checkpoint $DB_ENV; 3548 BDB::db_env_txn_checkpoint $DB_ENV;
3275 warn "end emergency database checkpoint\n"; 3549 warn "end emergency database checkpoint\n";
3550
3551 warn "begin write uuid\n";
3552 write_uuid_sync 1;
3553 warn "end write uuid\n";
3276 }; 3554 };
3277 3555
3278 warn "leave emergency perl save\n"; 3556 warn "leave emergency perl save\n";
3279} 3557}
3280 3558
3281sub post_cleanup { 3559sub post_cleanup {
3282 my ($make_core) = @_; 3560 my ($make_core) = @_;
3283 3561
3284 warn Carp::longmess "post_cleanup backtrace" 3562 warn Carp::longmess "post_cleanup backtrace"
3285 if $make_core; 3563 if $make_core;
3564
3565 my $fh = pidfile;
3566 unlink $PIDFILE if <$fh> == $$;
3286} 3567}
3568
3569# a safer delete_package, copied from Symbol
3570sub clear_package($) {
3571 my $pkg = shift;
3572
3573 # expand to full symbol table name if needed
3574 unless ($pkg =~ /^main::.*::$/) {
3575 $pkg = "main$pkg" if $pkg =~ /^::/;
3576 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3577 $pkg .= '::' unless $pkg =~ /::$/;
3578 }
3579
3580 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3581 my $stem_symtab = *{$stem}{HASH};
3582
3583 defined $stem_symtab and exists $stem_symtab->{$leaf}
3584 or return;
3585
3586 # clear all symbols
3587 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3588 for my $name (keys %$leaf_symtab) {
3589 _gv_clear *{"$pkg$name"};
3590# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3591 }
3592 warn "cleared package #$pkg\n";#d#
3593}
3594
3595our $RELOAD; # how many times to reload
3287 3596
3288sub do_reload_perl() { 3597sub do_reload_perl() {
3289 # can/must only be called in main 3598 # can/must only be called in main
3290 if ($Coro::current != $Coro::main) { 3599 if ($Coro::current != $Coro::main) {
3291 warn "can only reload from main coroutine"; 3600 warn "can only reload from main coroutine";
3292 return; 3601 return;
3293 } 3602 }
3294 3603
3604 return if $RELOAD++;
3605
3606 while ($RELOAD) {
3295 warn "reloading..."; 3607 warn "reloading...";
3296 3608
3297 warn "entering sync_job"; 3609 warn "entering sync_job";
3298 3610
3299 cf::sync_job { 3611 cf::sync_job {
3300 cf::write_runtime; # external watchdog should not bark 3612 cf::write_runtime_sync; # external watchdog should not bark
3301 cf::emergency_save; 3613 cf::emergency_save;
3302 cf::write_runtime; # external watchdog should not bark 3614 cf::write_runtime_sync; # external watchdog should not bark
3303 3615
3304 warn "syncing database to disk"; 3616 warn "syncing database to disk";
3305 BDB::db_env_txn_checkpoint $DB_ENV; 3617 BDB::db_env_txn_checkpoint $DB_ENV;
3306 3618
3307 # if anything goes wrong in here, we should simply crash as we already saved 3619 # if anything goes wrong in here, we should simply crash as we already saved
3308 3620
3309 warn "cancelling all WF_AUTOCANCEL watchers";
3310 for (Event::all_watchers) {
3311 $_->cancel if $_->data & WF_AUTOCANCEL;
3312 }
3313
3314 warn "flushing outstanding aio requests"; 3621 warn "flushing outstanding aio requests";
3315 for (;;) {
3316 BDB::flush;
3317 IO::AIO::flush;
3318 Coro::cede;
3319 last unless IO::AIO::nreqs || BDB::nreqs; 3622 while (IO::AIO::nreqs || BDB::nreqs) {
3320 warn "iterate..."; 3623 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3321 }
3322
3323 ++$RELOAD;
3324
3325 warn "cancelling all extension coros";
3326 $_->cancel for values %EXT_CORO;
3327 %EXT_CORO = ();
3328
3329 warn "removing commands";
3330 %COMMAND = ();
3331
3332 warn "removing ext/exti commands";
3333 %EXTCMD = ();
3334 %EXTICMD = ();
3335
3336 warn "unloading/nuking all extensions";
3337 for my $pkg (@EXTS) {
3338 warn "... unloading $pkg";
3339
3340 if (my $cb = $pkg->can ("unload")) {
3341 eval {
3342 $cb->($pkg);
3343 1
3344 } or warn "$pkg unloaded, but with errors: $@";
3345 } 3624 }
3346 3625
3347 warn "... nuking $pkg"; 3626 warn "cancelling all extension coros";
3348 Symbol::delete_package $pkg; 3627 $_->cancel for values %EXT_CORO;
3349 } 3628 %EXT_CORO = ();
3350 3629
3351 warn "unloading all perl modules loaded from $LIBDIR"; 3630 warn "removing commands";
3352 while (my ($k, $v) = each %INC) { 3631 %COMMAND = ();
3353 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3354 3632
3633 warn "removing ext/exti commands";
3634 %EXTCMD = ();
3635 %EXTICMD = ();
3636
3637 warn "unloading/nuking all extensions";
3638 for my $pkg (@EXTS) {
3355 warn "... unloading $k"; 3639 warn "... unloading $pkg";
3356 delete $INC{$k};
3357 3640
3358 $k =~ s/\.pm$//;
3359 $k =~ s/\//::/g;
3360
3361 if (my $cb = $k->can ("unload_module")) { 3641 if (my $cb = $pkg->can ("unload")) {
3642 eval {
3362 $cb->(); 3643 $cb->($pkg);
3644 1
3645 } or warn "$pkg unloaded, but with errors: $@";
3646 }
3647
3648 warn "... clearing $pkg";
3649 clear_package $pkg;
3363 } 3650 }
3364 3651
3365 Symbol::delete_package $k; 3652 warn "unloading all perl modules loaded from $LIBDIR";
3653 while (my ($k, $v) = each %INC) {
3654 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3655
3656 warn "... unloading $k";
3657 delete $INC{$k};
3658
3659 $k =~ s/\.pm$//;
3660 $k =~ s/\//::/g;
3661
3662 if (my $cb = $k->can ("unload_module")) {
3663 $cb->();
3664 }
3665
3666 clear_package $k;
3366 } 3667 }
3367 3668
3368 warn "getting rid of safe::, as good as possible"; 3669 warn "getting rid of safe::, as good as possible";
3369 Symbol::delete_package "safe::$_" 3670 clear_package "safe::$_"
3370 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3671 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3371 3672
3372 warn "unloading cf.pm \"a bit\""; 3673 warn "unloading cf.pm \"a bit\"";
3373 delete $INC{"cf.pm"}; 3674 delete $INC{"cf.pm"};
3374 delete $INC{"cf/pod.pm"}; 3675 delete $INC{"cf/pod.pm"};
3375 3676
3376 # don't, removes xs symbols, too, 3677 # don't, removes xs symbols, too,
3377 # and global variables created in xs 3678 # and global variables created in xs
3378 #Symbol::delete_package __PACKAGE__; 3679 #clear_package __PACKAGE__;
3379 3680
3380 warn "unload completed, starting to reload now"; 3681 warn "unload completed, starting to reload now";
3381 3682
3382 warn "reloading cf.pm"; 3683 warn "reloading cf.pm";
3383 require cf; 3684 require cf;
3384 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3685 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3385 3686
3386 warn "loading config and database again"; 3687 warn "loading config and database again";
3387 cf::reload_config; 3688 cf::reload_config;
3388 3689
3389 warn "loading extensions"; 3690 warn "loading extensions";
3390 cf::load_extensions; 3691 cf::load_extensions;
3391 3692
3392 warn "reattaching attachments to objects/players"; 3693 warn "reattaching attachments to objects/players";
3393 _global_reattach; # objects, sockets 3694 _global_reattach; # objects, sockets
3394 warn "reattaching attachments to maps"; 3695 warn "reattaching attachments to maps";
3395 reattach $_ for values %MAP; 3696 reattach $_ for values %MAP;
3396 warn "reattaching attachments to players"; 3697 warn "reattaching attachments to players";
3397 reattach $_ for values %PLAYER; 3698 reattach $_ for values %PLAYER;
3398 3699
3399 warn "leaving sync_job"; 3700 warn "leaving sync_job";
3400 3701
3401 1 3702 1
3402 } or do { 3703 } or do {
3403 warn $@; 3704 warn $@;
3404 warn "error while reloading, exiting."; 3705 cf::cleanup "error while reloading, exiting.";
3405 exit 1;
3406 }; 3706 };
3407 3707
3408 warn "reloaded"; 3708 warn "reloaded";
3709 --$RELOAD;
3710 }
3409}; 3711};
3410 3712
3411our $RELOAD_WATCHER; # used only during reload 3713our $RELOAD_WATCHER; # used only during reload
3412 3714
3413sub reload_perl() { 3715sub reload_perl() {
3414 # doing reload synchronously and two reloads happen back-to-back, 3716 # doing reload synchronously and two reloads happen back-to-back,
3415 # coro crashes during coro_state_free->destroy here. 3717 # coro crashes during coro_state_free->destroy here.
3416 3718
3417 $RELOAD_WATCHER ||= Event->timer ( 3719 $RELOAD_WATCHER ||= EV::timer 0, 0, sub {
3418 reentrant => 0,
3419 after => 0,
3420 data => WF_AUTOCANCEL,
3421 cb => sub {
3422 do_reload_perl; 3720 do_reload_perl;
3423 undef $RELOAD_WATCHER; 3721 undef $RELOAD_WATCHER;
3424 },
3425 ); 3722 };
3426} 3723}
3427 3724
3428register_command "reload" => sub { 3725register_command "reload" => sub {
3429 my ($who, $arg) = @_; 3726 my ($who, $arg) = @_;
3430 3727
3431 if ($who->flag (FLAG_WIZ)) { 3728 if ($who->flag (FLAG_WIZ)) {
3432 $who->message ("reloading server."); 3729 $who->message ("reloading server.");
3730 async {
3731 $Coro::current->{desc} = "perl_reload";
3433 async { reload_perl }; 3732 reload_perl;
3733 };
3434 } 3734 }
3435}; 3735};
3436 3736
3437unshift @INC, $LIBDIR; 3737unshift @INC, $LIBDIR;
3438 3738
3440 3740
3441our @WAIT_FOR_TICK; 3741our @WAIT_FOR_TICK;
3442our @WAIT_FOR_TICK_BEGIN; 3742our @WAIT_FOR_TICK_BEGIN;
3443 3743
3444sub wait_for_tick { 3744sub wait_for_tick {
3445 return unless $TICK_WATCHER->is_active;
3446 return if $Coro::current == $Coro::main; 3745 return if tick_inhibit || $Coro::current == $Coro::main;
3447 3746
3448 my $signal = new Coro::Signal; 3747 my $signal = new Coro::Signal;
3449 push @WAIT_FOR_TICK, $signal; 3748 push @WAIT_FOR_TICK, $signal;
3450 $signal->wait; 3749 $signal->wait;
3451} 3750}
3452 3751
3453sub wait_for_tick_begin { 3752sub wait_for_tick_begin {
3454 return unless $TICK_WATCHER->is_active;
3455 return if $Coro::current == $Coro::main; 3753 return if tick_inhibit || $Coro::current == $Coro::main;
3456 3754
3457 my $signal = new Coro::Signal; 3755 my $signal = new Coro::Signal;
3458 push @WAIT_FOR_TICK_BEGIN, $signal; 3756 push @WAIT_FOR_TICK_BEGIN, $signal;
3459 $signal->wait; 3757 $signal->wait;
3460} 3758}
3461 3759
3462$TICK_WATCHER = Event->timer ( 3760sub tick {
3463 reentrant => 0,
3464 parked => 1,
3465 prio => 0,
3466 at => $NEXT_TICK || $TICK,
3467 data => WF_AUTOCANCEL,
3468 cb => sub {
3469 if ($Coro::current != $Coro::main) { 3761 if ($Coro::current != $Coro::main) {
3470 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3762 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3471 unless ++$bug_warning > 10; 3763 unless ++$bug_warning > 10;
3472 return; 3764 return;
3473 } 3765 }
3474 3766
3475 $NOW = $tick_start = Event::time;
3476
3477 cf::server_tick; # one server iteration 3767 cf::server_tick; # one server iteration
3478 3768
3479 $RUNTIME += $TICK;
3480 $NEXT_TICK += $TICK;
3481
3482 if ($NOW >= $NEXT_RUNTIME_WRITE) { 3769 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3483 $NEXT_RUNTIME_WRITE = $NOW + 10; 3770 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3484 Coro::async_pool { 3771 Coro::async_pool {
3772 $Coro::current->{desc} = "runtime saver";
3485 write_runtime 3773 write_runtime_sync
3486 or warn "ERROR: unable to write runtime file: $!"; 3774 or warn "ERROR: unable to write runtime file: $!";
3487 };
3488 } 3775 };
3776 }
3489 3777
3490 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3778 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3491 $sig->send; 3779 $sig->send;
3492 } 3780 }
3493 while (my $sig = shift @WAIT_FOR_TICK) { 3781 while (my $sig = shift @WAIT_FOR_TICK) {
3494 $sig->send; 3782 $sig->send;
3495 } 3783 }
3496 3784
3497 $NOW = Event::time; 3785 $LOAD = ($NOW - $TICK_START) / $TICK;
3498
3499 # if we are delayed by four ticks or more, skip them all
3500 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3501
3502 $TICK_WATCHER->at ($NEXT_TICK);
3503 $TICK_WATCHER->start;
3504
3505 $LOAD = ($NOW - $tick_start) / $TICK;
3506 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3786 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3507 3787
3508 _post_tick; 3788 if (0) {
3789 if ($NEXT_TICK) {
3790 my $jitter = $TICK_START - $NEXT_TICK;
3791 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3792 warn "jitter $JITTER\n";#d#
3793 }
3509 }, 3794 }
3510); 3795}
3511 3796
3512{ 3797{
3798 # configure BDB
3799
3513 BDB::min_parallel 8; 3800 BDB::min_parallel 8;
3514 BDB::max_poll_time $TICK * 0.1; 3801 BDB::max_poll_reqs $TICK * 0.1;
3515 $BDB_POLL_WATCHER = Event->io ( 3802 $AnyEvent::BDB::WATCHER->priority (1);
3516 reentrant => 0,
3517 fd => BDB::poll_fileno,
3518 poll => 'r',
3519 prio => 0,
3520 data => WF_AUTOCANCEL,
3521 cb => \&BDB::poll_cb,
3522 );
3523
3524 BDB::set_sync_prepare {
3525 my $status;
3526 my $current = $Coro::current;
3527 (
3528 sub {
3529 $status = $!;
3530 $current->ready; undef $current;
3531 },
3532 sub {
3533 Coro::schedule while defined $current;
3534 $! = $status;
3535 },
3536 )
3537 };
3538 3803
3539 unless ($DB_ENV) { 3804 unless ($DB_ENV) {
3540 $DB_ENV = BDB::db_env_create; 3805 $DB_ENV = BDB::db_env_create;
3541 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC 3806 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3542 | BDB::LOG_AUTOREMOVE, 1); 3807 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
3808 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
3543 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT); 3809 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3544 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT); 3810 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3545 3811
3546 cf::sync_job { 3812 cf::sync_job {
3547 eval { 3813 eval {
3557 3823
3558 cf::cleanup "db_env_open(db): $@" if $@; 3824 cf::cleanup "db_env_open(db): $@" if $@;
3559 }; 3825 };
3560 } 3826 }
3561 3827
3562 $BDB_DEADLOCK_WATCHER = Event->timer ( 3828 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3563 after => 3,
3564 interval => 1,
3565 hard => 1,
3566 prio => 0,
3567 data => WF_AUTOCANCEL,
3568 cb => sub {
3569 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { }; 3829 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3570 },
3571 ); 3830 };
3572 $BDB_CHECKPOINT_WATCHER = Event->timer ( 3831 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3573 after => 11,
3574 interval => 60,
3575 hard => 1,
3576 prio => 0,
3577 data => WF_AUTOCANCEL,
3578 cb => sub {
3579 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { }; 3832 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3580 },
3581 ); 3833 };
3582 $BDB_TRICKLE_WATCHER = Event->timer ( 3834 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3583 after => 5,
3584 interval => 10,
3585 hard => 1,
3586 prio => 0,
3587 data => WF_AUTOCANCEL,
3588 cb => sub {
3589 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { }; 3835 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3590 },
3591 ); 3836 };
3592} 3837}
3593 3838
3594{ 3839{
3840 # configure IO::AIO
3841
3595 IO::AIO::min_parallel 8; 3842 IO::AIO::min_parallel 8;
3596
3597 undef $Coro::AIO::WATCHER;
3598 IO::AIO::max_poll_time $TICK * 0.1; 3843 IO::AIO::max_poll_time $TICK * 0.1;
3599 $AIO_POLL_WATCHER = Event->io ( 3844 undef $AnyEvent::AIO::WATCHER;
3600 reentrant => 0,
3601 data => WF_AUTOCANCEL,
3602 fd => IO::AIO::poll_fileno,
3603 poll => 'r',
3604 prio => 6,
3605 cb => \&IO::AIO::poll_cb,
3606 );
3607} 3845}
3608 3846
3609my $_log_backtrace; 3847my $_log_backtrace;
3610 3848
3611sub _log_backtrace { 3849sub _log_backtrace {
3614 $msg =~ s/\n//; 3852 $msg =~ s/\n//;
3615 3853
3616 # limit the # of concurrent backtraces 3854 # limit the # of concurrent backtraces
3617 if ($_log_backtrace < 2) { 3855 if ($_log_backtrace < 2) {
3618 ++$_log_backtrace; 3856 ++$_log_backtrace;
3857 my $perl_bt = Carp::longmess $msg;
3619 async { 3858 async {
3859 $Coro::current->{desc} = "abt $msg";
3860
3620 my @bt = fork_call { 3861 my @bt = fork_call {
3621 @addr = map { sprintf "%x", $_ } @addr; 3862 @addr = map { sprintf "%x", $_ } @addr;
3622 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X; 3863 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3623 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |" 3864 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3624 or die "addr2line: $!"; 3865 or die "addr2line: $!";
3632 } 3873 }
3633 3874
3634 @funcs 3875 @funcs
3635 }; 3876 };
3636 3877
3637 LOG llevInfo, "[ABT] $msg\n"; 3878 LOG llevInfo, "[ABT] $perl_bt\n";
3879 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
3638 LOG llevInfo, "[ABT] $_\n" for @bt; 3880 LOG llevInfo, "[ABT] $_\n" for @bt;
3639 --$_log_backtrace; 3881 --$_log_backtrace;
3640 }; 3882 };
3641 } else { 3883 } else {
3642 LOG llevInfo, "[ABT] $msg\n"; 3884 LOG llevInfo, "[ABT] $msg\n";

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines