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.376 by root, Mon Oct 1 00:44:44 2007 UTC vs.
Revision 1.476 by root, Wed Sep 2 16:54:20 2009 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 qw(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
37use Guard ();
15use Coro 3.64 (); 38use Coro ();
16use Coro::State; 39use Coro::State;
17use Coro::Handle; 40use Coro::Handle;
41use Coro::EV;
18use Coro::Event; 42use Coro::AnyEvent;
19use Coro::Timer; 43use Coro::Timer;
20use Coro::Signal; 44use Coro::Signal;
21use Coro::Semaphore; 45use Coro::Semaphore;
46use Coro::SemaphoreSet;
47use Coro::AnyEvent;
22use Coro::AIO; 48use Coro::AIO;
49use Coro::BDB 1.6;
23use Coro::Storable; 50use Coro::Storable;
24use Coro::Util (); 51use Coro::Util ();
25 52
26use JSON::XS (); 53use JSON::XS 2.01 ();
27use BDB (); 54use BDB ();
28use Data::Dumper; 55use Data::Dumper;
29use Digest::MD5; 56use Digest::MD5;
30use Fcntl; 57use Fcntl;
31use YAML::Syck (); 58use YAML ();
32use IO::AIO 2.32 (); 59use IO::AIO ();
33use Time::HiRes; 60use Time::HiRes;
34use Compress::LZF; 61use Compress::LZF;
35use Digest::MD5 (); 62use Digest::MD5 ();
63
64AnyEvent::detect;
36 65
37# configure various modules to our taste 66# configure various modules to our taste
38# 67#
39$Storable::canonical = 1; # reduce rsync transfers 68$Storable::canonical = 1; # reduce rsync transfers
40Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 69Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
70
71$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
72
73# make sure c-lzf reinitialises itself
74Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";
41Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 75Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
42 76
43$Event::Eval = 1; # no idea why this is required, but it is 77# strictly for debugging
44 78$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
45# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
46$YAML::Syck::ImplicitUnicode = 1;
47
48$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
49 79
50sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 80sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
51 81
52our %COMMAND = (); 82our %COMMAND = ();
53our %COMMAND_TIME = (); 83our %COMMAND_TIME = ();
… …
56our %EXTCMD = (); 86our %EXTCMD = ();
57our %EXTICMD = (); 87our %EXTICMD = ();
58our %EXT_CORO = (); # coroutines bound to extensions 88our %EXT_CORO = (); # coroutines bound to extensions
59our %EXT_MAP = (); # pluggable maps 89our %EXT_MAP = (); # pluggable maps
60 90
61our $RELOAD; # number of reloads so far 91our $RELOAD; # number of reloads so far, non-zero while in reload
62our @EVENT; 92our @EVENT;
63 93
64our $CONFDIR = confdir; 94our $CONFDIR = confdir;
65our $DATADIR = datadir; 95our $DATADIR = datadir;
66our $LIBDIR = "$DATADIR/ext"; 96our $LIBDIR = "$DATADIR/ext";
67our $PODDIR = "$DATADIR/pod"; 97our $PODDIR = "$DATADIR/pod";
68our $MAPDIR = "$DATADIR/" . mapdir; 98our $MAPDIR = "$DATADIR/" . mapdir;
69our $LOCALDIR = localdir; 99our $LOCALDIR = localdir;
70our $TMPDIR = "$LOCALDIR/" . tmpdir; 100our $TMPDIR = "$LOCALDIR/" . tmpdir;
71our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 101our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
72our $PLAYERDIR = "$LOCALDIR/" . playerdir; 102our $PLAYERDIR = "$LOCALDIR/" . playerdir;
73our $RANDOMDIR = "$LOCALDIR/random"; 103our $RANDOMDIR = "$LOCALDIR/random";
74our $BDBDIR = "$LOCALDIR/db"; 104our $BDBDIR = "$LOCALDIR/db";
105our $PIDFILE = "$LOCALDIR/pid";
106our $RUNTIMEFILE = "$LOCALDIR/runtime";
107
108our %RESOURCE;
75 109
76our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 110our $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 111our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
80our $NEXT_TICK; 112our $NEXT_TICK;
81our $NOW;
82our $USE_FSYNC = 1; # use fsync to write maps - default off 113our $USE_FSYNC = 1; # use fsync to write maps - default on
83 114
84our $BDB_POLL_WATCHER;
85our $BDB_DEADLOCK_WATCHER; 115our $BDB_DEADLOCK_WATCHER;
86our $BDB_CHECKPOINT_WATCHER; 116our $BDB_CHECKPOINT_WATCHER;
87our $BDB_TRICKLE_WATCHER; 117our $BDB_TRICKLE_WATCHER;
88our $DB_ENV; 118our $DB_ENV;
89 119
120our @EXTRA_MODULES = qw(pod mapscript);
121
90our %CFG; 122our %CFG;
91 123
92our $UPTIME; $UPTIME ||= time; 124our $UPTIME; $UPTIME ||= time;
93our $RUNTIME; 125our $RUNTIME;
126our $NOW;
94 127
95our (%PLAYER, %PLAYER_LOADING); # all users 128our (%PLAYER, %PLAYER_LOADING); # all users
96our (%MAP, %MAP_LOADING ); # all maps 129our (%MAP, %MAP_LOADING ); # all maps
97our $LINK_MAP; # the special {link} map, which is always available 130our $LINK_MAP; # the special {link} map, which is always available
98 131
99# used to convert map paths into valid unix filenames by replacing / by ∕ 132# used to convert map paths into valid unix filenames by replacing / by ∕
100our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 133our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
101 134
102our $LOAD; # a number between 0 (idle) and 1 (too many objects) 135our $LOAD; # a number between 0 (idle) and 1 (too many objects)
103our $LOADAVG; # same thing, but with alpha-smoothing 136our $LOADAVG; # same thing, but with alpha-smoothing
137our $JITTER; # average jitter
104our $tick_start; # for load detecting purposes 138our $TICK_START; # for load detecting purposes
139
140our @POST_INIT;
141
142our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
143our $REALLY_UNLOOP; # never set to true, please :)
105 144
106binmode STDOUT; 145binmode STDOUT;
107binmode STDERR; 146binmode STDERR;
108 147
109# read virtual server time, if available 148# read virtual server time, if available
110unless ($RUNTIME || !-e "$LOCALDIR/runtime") { 149unless ($RUNTIME || !-e $RUNTIMEFILE) {
111 open my $fh, "<", "$LOCALDIR/runtime" 150 open my $fh, "<", $RUNTIMEFILE
112 or die "unable to read runtime file: $!"; 151 or die "unable to read $RUNTIMEFILE file: $!";
113 $RUNTIME = <$fh> + 0.; 152 $RUNTIME = <$fh> + 0.;
114} 153}
154
155eval "sub TICK() { $TICK } 1" or die;
115 156
116mkdir $_ 157mkdir $_
117 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR; 158 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
118 159
119our $EMERGENCY_POSITION; 160our $EMERGENCY_POSITION;
… …
162 203
163The raw value load value from the last tick. 204The raw value load value from the last tick.
164 205
165=item %cf::CFG 206=item %cf::CFG
166 207
167Configuration for the server, loaded from C</etc/crossfire/config>, or 208Configuration for the server, loaded from C</etc/deliantra-server/config>, or
168from wherever your confdir points to. 209from wherever your confdir points to.
169 210
170=item cf::wait_for_tick, cf::wait_for_tick_begin 211=item cf::wait_for_tick, cf::wait_for_tick_begin
171 212
172These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 213These 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; 234 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
194 235
195 LOG llevError, $msg; 236 LOG llevError, $msg;
196 }; 237 };
197} 238}
239
240$Coro::State::DIEHOOK = sub {
241 return unless $^S eq 0; # "eq", not "=="
242
243 if ($Coro::current == $Coro::main) {#d#
244 warn "DIEHOOK called in main context, Coro bug?\n";#d#
245 return;#d#
246 }#d#
247
248 # kill coroutine otherwise
249 warn Carp::longmess $_[0];
250 Coro::terminate
251};
252
253$SIG{__DIE__} = sub { }; #d#?
198 254
199@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 255@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
200@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 256@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
201@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 257@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
202@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 258@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
… …
209for my $pkg (qw( 265for my $pkg (qw(
210 cf::global cf::attachable 266 cf::global cf::attachable
211 cf::object cf::object::player 267 cf::object cf::object::player
212 cf::client cf::player 268 cf::client cf::player
213 cf::arch cf::living 269 cf::arch cf::living
270 cf::map cf::mapspace
214 cf::map cf::party cf::region 271 cf::party cf::region
215)) { 272)) {
216 no strict 'refs';
217 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 273 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
218} 274}
219 275
220$Event::DIED = sub { 276$EV::DIED = sub {
221 warn "error in event callback: @_"; 277 warn "error in event callback: @_";
222}; 278};
223 279
224############################################################################# 280#############################################################################
225 281
… …
248 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 304 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
249 $d 305 $d
250 } || "[unable to dump $_[0]: '$@']"; 306 } || "[unable to dump $_[0]: '$@']";
251} 307}
252 308
253=item $ref = cf::from_json $json 309=item $ref = cf::decode_json $json
254 310
255Converts a JSON string into the corresponding perl data structure. 311Converts a JSON string into the corresponding perl data structure.
256 312
257=item $json = cf::to_json $ref 313=item $json = cf::encode_json $ref
258 314
259Converts a perl data structure into its JSON representation. 315Converts a perl data structure into its JSON representation.
260 316
261=cut 317=cut
262 318
263our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max 319our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
264 320
265sub to_json ($) { $json_coder->encode ($_[0]) } 321sub encode_json($) { $json_coder->encode ($_[0]) }
266sub from_json ($) { $json_coder->decode ($_[0]) } 322sub decode_json($) { $json_coder->decode ($_[0]) }
323
324=item cf::post_init { BLOCK }
325
326Execute the given codeblock, I<after> all extensions have been (re-)loaded,
327but I<before> the server starts ticking again.
328
329The cdoeblock will have a single boolean argument to indicate whether this
330is a reload or not.
331
332=cut
333
334sub post_init(&) {
335 push @POST_INIT, shift;
336}
267 337
268=item cf::lock_wait $string 338=item cf::lock_wait $string
269 339
270Wait until the given lock is available. See cf::lock_acquire. 340Wait until the given lock is available. See cf::lock_acquire.
271 341
272=item my $lock = cf::lock_acquire $string 342=item my $lock = cf::lock_acquire $string
273 343
274Wait until the given lock is available and then acquires it and returns 344Wait until the given lock is available and then acquires it and returns
275a Coro::guard object. If the guard object gets destroyed (goes out of scope, 345a L<Guard> object. If the guard object gets destroyed (goes out of scope,
276for example when the coroutine gets canceled), the lock is automatically 346for example when the coroutine gets canceled), the lock is automatically
277returned. 347returned.
278 348
279Locks are *not* recursive, locking from the same coro twice results in a 349Locks are *not* recursive, locking from the same coro twice results in a
280deadlocked coro. 350deadlocked coro.
… …
286 356
287Return true if the lock is currently active, i.e. somebody has locked it. 357Return true if the lock is currently active, i.e. somebody has locked it.
288 358
289=cut 359=cut
290 360
291our %LOCK; 361our $LOCKS = new Coro::SemaphoreSet;
292our %LOCKER;#d#
293 362
294sub lock_wait($) { 363sub lock_wait($) {
295 my ($key) = @_; 364 $LOCKS->wait ($_[0]);
296
297 if ($LOCKER{$key} == $Coro::current) {#d#
298 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
299 return;#d#
300 }#d#
301
302 # wait for lock, if any
303 while ($LOCK{$key}) {
304 push @{ $LOCK{$key} }, $Coro::current;
305 Coro::schedule;
306 }
307} 365}
308 366
309sub lock_acquire($) { 367sub lock_acquire($) {
310 my ($key) = @_; 368 $LOCKS->guard ($_[0])
311
312 # wait, to be sure we are not locked
313 lock_wait $key;
314
315 $LOCK{$key} = [];
316 $LOCKER{$key} = $Coro::current;#d#
317
318 Coro::guard {
319 delete $LOCKER{$key};#d#
320 # wake up all waiters, to be on the safe side
321 $_->ready for @{ delete $LOCK{$key} };
322 }
323} 369}
324 370
325sub lock_active($) { 371sub lock_active($) {
326 my ($key) = @_; 372 $LOCKS->count ($_[0]) < 1
327
328 ! ! $LOCK{$key}
329} 373}
330 374
331sub freeze_mainloop { 375sub freeze_mainloop {
332 return unless $TICK_WATCHER->is_active; 376 tick_inhibit_inc;
333 377
334 my $guard = Coro::guard { 378 &Guard::guard (\&tick_inhibit_dec);
335 $TICK_WATCHER->start; 379}
336 }; 380
337 $TICK_WATCHER->stop; 381=item cf::periodic $interval, $cb
338 $guard 382
383Like EV::periodic, but randomly selects a starting point so that the actions
384get spread over timer.
385
386=cut
387
388sub periodic($$) {
389 my ($interval, $cb) = @_;
390
391 my $start = rand List::Util::min 180, $interval;
392
393 EV::periodic $start, $interval, 0, $cb
339} 394}
340 395
341=item cf::get_slot $time[, $priority[, $name]] 396=item cf::get_slot $time[, $priority[, $name]]
342 397
343Allocate $time seconds of blocking CPU time at priority C<$priority>: 398Allocate $time seconds of blocking CPU time at priority C<$priority>:
… …
373 } 428 }
374 } 429 }
375 } 430 }
376 431
377 if (@SLOT_QUEUE) { 432 if (@SLOT_QUEUE) {
378 # we do not use wait_For_tick() as it returns immediately when tick is inactive 433 # we do not use wait_for_tick() as it returns immediately when tick is inactive
379 push @cf::WAIT_FOR_TICK, $signal; 434 push @cf::WAIT_FOR_TICK, $signal;
380 $signal->wait; 435 $signal->wait;
381 } else { 436 } else {
382 Coro::schedule; 437 Coro::schedule;
383 } 438 }
384 } 439 }
385}; 440};
386 441
387sub get_slot($;$$) { 442sub get_slot($;$$) {
443 return if tick_inhibit || $Coro::current == $Coro::main;
444
388 my ($time, $pri, $name) = @_; 445 my ($time, $pri, $name) = @_;
389 446
390 $time = $TICK * .6 if $time > $TICK * .6; 447 $time = $TICK * .6 if $time > $TICK * .6;
391 my $sig = new Coro::Signal; 448 my $sig = new Coro::Signal;
392 449
… …
406 463
407BEGIN { *async = \&Coro::async_pool } 464BEGIN { *async = \&Coro::async_pool }
408 465
409=item cf::sync_job { BLOCK } 466=item cf::sync_job { BLOCK }
410 467
411The design of Crossfire TRT requires that the main coroutine ($Coro::main) 468The design of Deliantra requires that the main coroutine ($Coro::main)
412is always able to handle events or runnable, as Crossfire TRT is only 469is always able to handle events or runnable, as Deliantra is only
413partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not 470partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
414acceptable. 471acceptable.
415 472
416If it must be done, put the blocking parts into C<sync_job>. This will run 473If it must be done, put the blocking parts into C<sync_job>. This will run
417the given BLOCK in another coroutine while waiting for the result. The 474the given BLOCK in another coroutine while waiting for the result. The
… …
422 479
423sub sync_job(&) { 480sub sync_job(&) {
424 my ($job) = @_; 481 my ($job) = @_;
425 482
426 if ($Coro::current == $Coro::main) { 483 if ($Coro::current == $Coro::main) {
427 my $time = Event::time; 484 my $time = EV::time;
428 485
429 # this is the main coro, too bad, we have to block 486 # this is the main coro, too bad, we have to block
430 # till the operation succeeds, freezing the server :/ 487 # till the operation succeeds, freezing the server :/
431 488
432 # TODO: use suspend/resume instead 489 LOG llevError, Carp::longmess "sync job";#d#
433 # (but this is cancel-safe) 490
434 my $freeze_guard = freeze_mainloop; 491 my $freeze_guard = freeze_mainloop;
435 492
436 my $busy = 1; 493 my $busy = 1;
437 my @res; 494 my @res;
438 495
… …
442 warn $@ if $@; 499 warn $@ if $@;
443 undef $busy; 500 undef $busy;
444 })->prio (Coro::PRIO_MAX); 501 })->prio (Coro::PRIO_MAX);
445 502
446 while ($busy) { 503 while ($busy) {
447 Coro::cede or Event::one_event; 504 if (Coro::nready) {
505 Coro::cede_notself;
506 } else {
507 EV::loop EV::LOOP_ONESHOT;
448 } 508 }
509 }
449 510
450 $time = Event::time - $time; 511 my $time = EV::time - $time;
451 512
452 LOG llevError | logBacktrace, Carp::longmess "long sync job"
453 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
454
455 $tick_start += $time; # do not account sync jobs to server load 513 $TICK_START += $time; # do not account sync jobs to server load
456 514
457 wantarray ? @res : $res[0] 515 wantarray ? @res : $res[0]
458 } else { 516 } else {
459 # we are in another coroutine, how wonderful, everything just works 517 # we are in another coroutine, how wonderful, everything just works
460 518
… …
485=item fork_call { }, $args 543=item fork_call { }, $args
486 544
487Executes the given code block with the given arguments in a seperate 545Executes the given code block with the given arguments in a seperate
488process, returning the results. Everything must be serialisable with 546process, returning the results. Everything must be serialisable with
489Coro::Storable. May, of course, block. Note that the executed sub may 547Coro::Storable. May, of course, block. Note that the executed sub may
490never block itself or use any form of Event handling. 548never block itself or use any form of event handling.
491 549
492=cut 550=cut
493 551
494sub fork_call(&@) { 552sub fork_call(&@) {
495 my ($cb, @args) = @_; 553 my ($cb, @args) = @_;
… …
502 reset_signals; 560 reset_signals;
503 &$cb 561 &$cb
504 }, @args; 562 }, @args;
505 563
506 wantarray ? @res : $res[-1] 564 wantarray ? @res : $res[-1]
565}
566
567=item $coin = coin_from_name $name
568
569=cut
570
571our %coin_alias = (
572 "silver" => "silvercoin",
573 "silvercoin" => "silvercoin",
574 "silvercoins" => "silvercoin",
575 "gold" => "goldcoin",
576 "goldcoin" => "goldcoin",
577 "goldcoins" => "goldcoin",
578 "platinum" => "platinacoin",
579 "platinumcoin" => "platinacoin",
580 "platinumcoins" => "platinacoin",
581 "platina" => "platinacoin",
582 "platinacoin" => "platinacoin",
583 "platinacoins" => "platinacoin",
584 "royalty" => "royalty",
585 "royalties" => "royalty",
586);
587
588sub coin_from_name($) {
589 $coin_alias{$_[0]}
590 ? cf::arch::find $coin_alias{$_[0]}
591 : undef
507} 592}
508 593
509=item $value = cf::db_get $family => $key 594=item $value = cf::db_get $family => $key
510 595
511Returns a single value from the environment database. 596Returns a single value from the environment database.
… …
650 735
651############################################################################# 736#############################################################################
652 737
653=head2 ATTACHABLE OBJECTS 738=head2 ATTACHABLE OBJECTS
654 739
655Many objects in crossfire are so-called attachable objects. That means you can 740Many objects in deliantra are so-called attachable objects. That means you can
656attach callbacks/event handlers (a collection of which is called an "attachment") 741attach callbacks/event handlers (a collection of which is called an "attachment")
657to it. All such attachable objects support the following methods. 742to it. All such attachable objects support the following methods.
658 743
659In the following description, CLASS can be any of C<global>, C<object> 744In the following description, CLASS can be any of C<global>, C<object>
660C<player>, C<client> or C<map> (i.e. the attachable objects in 745C<player>, C<client> or C<map> (i.e. the attachable objects in
661Crossfire TRT). 746Deliantra).
662 747
663=over 4 748=over 4
664 749
665=item $attachable->attach ($attachment, key => $value...) 750=item $attachable->attach ($attachment, key => $value...)
666 751
… …
710=item cf::CLASS::attachment $name, ... 795=item cf::CLASS::attachment $name, ...
711 796
712Register an attachment by C<$name> through which attachable objects of the 797Register an attachment by C<$name> through which attachable objects of the
713given CLASS can refer to this attachment. 798given CLASS can refer to this attachment.
714 799
715Some classes such as crossfire maps and objects can specify attachments 800Some classes such as deliantra maps and objects can specify attachments
716that are attached at load/instantiate time, thus the need for a name. 801that are attached at load/instantiate time, thus the need for a name.
717 802
718These calls expect any number of the following handler/hook descriptions: 803These calls expect any number of the following handler/hook descriptions:
719 804
720=over 4 805=over 4
… …
948 } 1033 }
949 1034
950 0 1035 0
951} 1036}
952 1037
953=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 1038=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
954 1039
955=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 1040=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
956 1041
957Generate an object-specific event with the given arguments. 1042Generate an object-specific event with the given arguments.
958 1043
… …
964 1049
965=cut 1050=cut
966 1051
967############################################################################# 1052#############################################################################
968# object support 1053# object support
969#
970 1054
1055sub _object_equal($$);
1056sub _object_equal($$) {
1057 my ($a, $b) = @_;
1058
1059 return 0 unless (ref $a) eq (ref $b);
1060
1061 if ("HASH" eq ref $a) {
1062 my @ka = keys %$a;
1063 my @kb = keys %$b;
1064
1065 return 0 if @ka != @kb;
1066
1067 for (0 .. $#ka) {
1068 return 0 unless $ka[$_] eq $kb[$_];
1069 return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
1070 }
1071
1072 } elsif ("ARRAY" eq ref $a) {
1073
1074 return 0 if @$a != @$b;
1075
1076 for (0 .. $#$a) {
1077 return 0 unless _object_equal $a->[$_], $b->[$_];
1078 }
1079
1080 } elsif ($a ne $b) {
1081 return 0;
1082 }
1083
1084 1
1085}
1086
1087our $SLOW_MERGES;#d#
971sub _can_merge { 1088sub _can_merge {
972 my ($ob1, $ob2) = @_; 1089 my ($ob1, $ob2) = @_;
973 1090
974 local $Storable::canonical = 1; 1091 ++$SLOW_MERGES;#d#
975 my $fob1 = Storable::freeze $ob1;
976 my $fob2 = Storable::freeze $ob2;
977 1092
978 $fob1 eq $fob2 1093 # we do the slow way here
1094 return _object_equal $ob1, $ob2
979} 1095}
980 1096
981sub reattach { 1097sub reattach {
982 # basically do the same as instantiate, without calling instantiate 1098 # basically do the same as instantiate, without calling instantiate
983 my ($obj) = @_; 1099 my ($obj) = @_;
984 1100
1101 # no longer needed after getting rid of delete_package?
985 bless $obj, ref $obj; # re-bless in case extensions have been reloaded 1102 #bless $obj, ref $obj; # re-bless in case extensions have been reloaded
986 1103
987 my $registry = $obj->registry; 1104 my $registry = $obj->registry;
988 1105
989 @$registry = (); 1106 @$registry = ();
990 1107
… …
1005cf::attachable->attach ( 1122cf::attachable->attach (
1006 prio => -1000000, 1123 prio => -1000000,
1007 on_instantiate => sub { 1124 on_instantiate => sub {
1008 my ($obj, $data) = @_; 1125 my ($obj, $data) = @_;
1009 1126
1010 $data = from_json $data; 1127 $data = decode_json $data;
1011 1128
1012 for (@$data) { 1129 for (@$data) {
1013 my ($name, $args) = @$_; 1130 my ($name, $args) = @$_;
1014 1131
1015 $obj->attach ($name, %{$args || {} }); 1132 $obj->attach ($name, %{$args || {} });
… …
1036 utf8::decode (my $decname = $filename); 1153 utf8::decode (my $decname = $filename);
1037 warn sprintf "saving %s (%d,%d)\n", 1154 warn sprintf "saving %s (%d,%d)\n",
1038 $decname, length $$rdata, scalar @$objs; 1155 $decname, length $$rdata, scalar @$objs;
1039 1156
1040 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1157 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1041 chmod SAVE_MODE, $fh; 1158 aio_chmod $fh, SAVE_MODE;
1042 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1159 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1043 aio_fsync $fh if $cf::USE_FSYNC; 1160 if ($cf::USE_FSYNC) {
1161 aio_sync_file_range $fh, 0, 0, IO::AIO::SYNC_FILE_RANGE_WAIT_BEFORE | IO::AIO::SYNC_FILE_RANGE_WRITE | IO::AIO::SYNC_FILE_RANGE_WAIT_AFTER;
1162 aio_fsync $fh;
1163 }
1044 close $fh; 1164 aio_close $fh;
1045 1165
1046 if (@$objs) { 1166 if (@$objs) {
1047 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1167 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1048 chmod SAVE_MODE, $fh; 1168 aio_chmod $fh, SAVE_MODE;
1049 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1169 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1050 aio_write $fh, 0, (length $data), $data, 0; 1170 aio_write $fh, 0, (length $data), $data, 0;
1051 aio_fsync $fh if $cf::USE_FSYNC; 1171 if ($cf::USE_FSYNC) {
1172 aio_sync_file_range $fh, 0, 0, IO::AIO::SYNC_FILE_RANGE_WAIT_BEFORE | IO::AIO::SYNC_FILE_RANGE_WRITE | IO::AIO::SYNC_FILE_RANGE_WAIT_AFTER;
1173 aio_fsync $fh;
1174 }
1052 close $fh; 1175 aio_close $fh;
1053 aio_rename "$filename.pst~", "$filename.pst"; 1176 aio_rename "$filename.pst~", "$filename.pst";
1054 } 1177 }
1055 } else { 1178 } else {
1056 aio_unlink "$filename.pst"; 1179 aio_unlink "$filename.pst";
1057 } 1180 }
1058 1181
1059 aio_rename "$filename~", $filename; 1182 aio_rename "$filename~", $filename;
1183
1184 $filename =~ s%/[^/]+$%%;
1185 aio_pathsync $filename if $cf::USE_FSYNC;
1060 } else { 1186 } else {
1061 warn "FATAL: $filename~: $!\n"; 1187 warn "unable to save objects: $filename~: $!\n";
1062 } 1188 }
1063 } else { 1189 } else {
1064 aio_unlink $filename; 1190 aio_unlink $filename;
1065 aio_unlink "$filename.pst"; 1191 aio_unlink "$filename.pst";
1066 } 1192 }
… …
1085 1211
1086 unless (aio_stat "$filename.pst") { 1212 unless (aio_stat "$filename.pst") {
1087 (aio_load "$filename.pst", $av) >= 0 1213 (aio_load "$filename.pst", $av) >= 0
1088 or return; 1214 or return;
1089 1215
1090 $av = eval { (Storable::thaw $av)->{objs} }; 1216 my $st = eval { Coro::Storable::thaw $av };
1217 $av = $st->{objs};
1091 } 1218 }
1092 1219
1093 utf8::decode (my $decname = $filename); 1220 utf8::decode (my $decname = $filename);
1094 warn sprintf "loading %s (%d,%d)\n", 1221 warn sprintf "loading %s (%d,%d)\n",
1095 $decname, length $data, scalar @{$av || []}; 1222 $decname, length $data, scalar @{$av || []};
… …
1156 my ($name, $cb) = @_; 1283 my ($name, $cb) = @_;
1157 1284
1158 $EXTICMD{$name} = $cb; 1285 $EXTICMD{$name} = $cb;
1159} 1286}
1160 1287
1288use File::Glob ();
1289
1161cf::player->attach ( 1290cf::player->attach (
1162 on_command => sub { 1291 on_command => sub {
1163 my ($pl, $name, $params) = @_; 1292 my ($pl, $name, $params) = @_;
1164 1293
1165 my $cb = $COMMAND{$name} 1294 my $cb = $COMMAND{$name}
… …
1197 1326
1198 cf::override; 1327 cf::override;
1199 }, 1328 },
1200); 1329);
1201 1330
1331# "readahead" all extensions
1332sub cache_extensions {
1333 my $grp = IO::AIO::aio_group;
1334
1335 add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
1336 for (grep /\.ext$/, @{$_[0]}) {
1337 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
1338 }
1339 };
1340
1341 $grp
1342}
1343
1202sub load_extensions { 1344sub load_extensions {
1203 cf::sync_job { 1345 cf::sync_job {
1204 my %todo; 1346 my %todo;
1205 1347
1206 for my $path (<$LIBDIR/*.ext>) { 1348 for my $path (<$LIBDIR/*.ext>) {
… …
1225 1367
1226 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 } 1368 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1227 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; 1369 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1228 1370
1229 $ext{source} = 1371 $ext{source} =
1230 "package $pkg; use strict; use utf8;\n" 1372 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n"
1231 . "#line 1 \"$path\"\n{\n" 1373 . "#line 1 \"$path\"\n{\n"
1232 . $source 1374 . $source
1233 . "\n};\n1"; 1375 . "\n};\n1";
1234 1376
1235 $todo{$base} = \%ext; 1377 $todo{$base} = \%ext;
… …
1251 my $msg = $@ ? "$v->{path}: $@\n" 1393 my $msg = $@ ? "$v->{path}: $@\n"
1252 : "$v->{base}: extension inactive.\n"; 1394 : "$v->{base}: extension inactive.\n";
1253 1395
1254 if (exists $v->{meta}{mandatory}) { 1396 if (exists $v->{meta}{mandatory}) {
1255 warn $msg; 1397 warn $msg;
1256 warn "mandatory extension failed to load, exiting.\n"; 1398 cf::cleanup "mandatory extension failed to load, exiting.";
1257 exit 1;
1258 } 1399 }
1259 1400
1260 warn $msg; 1401 warn $msg;
1261 } 1402 }
1262 1403
… …
1276 1417
1277=back 1418=back
1278 1419
1279=head2 CORE EXTENSIONS 1420=head2 CORE EXTENSIONS
1280 1421
1281Functions and methods that extend core crossfire objects. 1422Functions and methods that extend core deliantra objects.
1282 1423
1283=cut 1424=cut
1284 1425
1285package cf::player; 1426package cf::player;
1286 1427
… …
1329 1470
1330sub exists($) { 1471sub exists($) {
1331 my ($login) = @_; 1472 my ($login) = @_;
1332 1473
1333 $cf::PLAYER{$login} 1474 $cf::PLAYER{$login}
1334 or cf::sync_job { !aio_stat path $login } 1475 or !aio_stat path $login
1335} 1476}
1336 1477
1337sub find($) { 1478sub find($) {
1338 return $cf::PLAYER{$_[0]} || do { 1479 return $cf::PLAYER{$_[0]} || do {
1339 my $login = $_[0]; 1480 my $login = $_[0];
… …
1351 my $f = new_from_file cf::object::thawer path $login 1492 my $f = new_from_file cf::object::thawer path $login
1352 or return; 1493 or return;
1353 1494
1354 my $pl = cf::player::load_pl $f 1495 my $pl = cf::player::load_pl $f
1355 or return; 1496 or return;
1497
1356 local $cf::PLAYER_LOADING{$login} = $pl; 1498 local $cf::PLAYER_LOADING{$login} = $pl;
1357 $f->resolve_delayed_derefs; 1499 $f->resolve_delayed_derefs;
1358 $cf::PLAYER{$login} = $pl 1500 $cf::PLAYER{$login} = $pl
1359 } 1501 }
1360 } 1502 }
… …
1370 1512
1371 return if $pl->{deny_save}; 1513 return if $pl->{deny_save};
1372 1514
1373 aio_mkdir playerdir $pl, 0770; 1515 aio_mkdir playerdir $pl, 0770;
1374 $pl->{last_save} = $cf::RUNTIME; 1516 $pl->{last_save} = $cf::RUNTIME;
1517
1518 cf::get_slot 0.01;
1375 1519
1376 $pl->save_pl ($path); 1520 $pl->save_pl ($path);
1377 cf::cede_to_tick; 1521 cf::cede_to_tick;
1378} 1522}
1379 1523
… …
1411 my ($pl) = @_; 1555 my ($pl) = @_;
1412 1556
1413 my $name = $pl->ob->name; 1557 my $name = $pl->ob->name;
1414 1558
1415 $pl->{deny_save} = 1; 1559 $pl->{deny_save} = 1;
1416 $pl->password ("*"); # this should lock out the player until we nuked the dir 1560 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1417 1561
1418 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1562 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1419 $pl->deactivate; 1563 $pl->deactivate;
1564 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1565 $pl->ob->check_score;
1420 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1566 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1421 $pl->ns->destroy if $pl->ns; 1567 $pl->ns->destroy if $pl->ns;
1422 1568
1423 my $path = playerdir $pl; 1569 my $path = playerdir $pl;
1424 my $temp = "$path~$cf::RUNTIME~deleting~"; 1570 my $temp = "$path~$cf::RUNTIME~deleting~";
… …
1463 1609
1464 for my $login (@$dirs) { 1610 for my $login (@$dirs) {
1465 my $path = path $login; 1611 my $path = path $login;
1466 1612
1467 # a .pst is a dead give-away for a valid player 1613 # a .pst is a dead give-away for a valid player
1468 unless (-e "$path.pst") { 1614 # if no pst file found, open and chekc for blocked users
1615 if (aio_stat "$path.pst") {
1469 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next; 1616 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1470 aio_read $fh, 0, 512, my $buf, 0 or next; 1617 aio_read $fh, 0, 512, my $buf, 0 or next;
1471 $buf !~ /^password -------------$/m or next; # official not-valid tag 1618 $buf !~ /^password -------------$/m or next; # official not-valid tag
1472 } 1619 }
1473 1620
… …
1504 } 1651 }
1505 1652
1506 \@paths 1653 \@paths
1507} 1654}
1508 1655
1509=item $protocol_xml = $player->expand_cfpod ($crossfire_pod) 1656=item $protocol_xml = $player->expand_cfpod ($cfpod)
1510 1657
1511Expand crossfire pod fragments into protocol xml. 1658Expand deliantra pod fragments into protocol xml.
1512
1513=cut
1514
1515sub expand_cfpod {
1516 ((my $self), (local $_)) = @_;
1517
1518 # escape & and <
1519 s/&/&amp;/g;
1520 s/(?<![BIUGHT])</&lt;/g;
1521
1522 # this is buggy, it needs to properly take care of nested <'s
1523
1524 1 while
1525 # replace B<>, I<>, U<> etc.
1526 s/B<([^\>]*)>/<b>$1<\/b>/
1527 || s/I<([^\>]*)>/<i>$1<\/i>/
1528 || s/U<([^\>]*)>/<u>$1<\/u>/
1529 || s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/
1530 # replace G<male|female> tags
1531 || s{G<([^>|]*)\|([^>]*)>}{
1532 $self->gender ? $2 : $1
1533 }ge
1534 # replace H<hint text>
1535 || s{H<([^\>]*)>}
1536 {
1537 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
1538 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1539 "")
1540 [$self->{hintmode}]
1541 }ge;
1542
1543 # create single paragraphs (very hackish)
1544 s/(?<=\S)\n(?=\w)/ /g;
1545
1546 # compress some whitespace
1547 s/\s+\n/\n/g; # ws line-ends
1548 s/\n\n+/\n/g; # double lines
1549 s/^\n+//; # beginning lines
1550 s/\n+$//; # ending lines
1551
1552 $_
1553}
1554
1555sub hintmode {
1556 $_[0]{hintmode} = $_[1] if @_ > 1;
1557 $_[0]{hintmode}
1558}
1559 1659
1560=item $player->ext_reply ($msgid, @msg) 1660=item $player->ext_reply ($msgid, @msg)
1561 1661
1562Sends an ext reply to the player. 1662Sends an ext reply to the player.
1563 1663
… …
1630our $MAX_RESET = 3600; 1730our $MAX_RESET = 3600;
1631our $DEFAULT_RESET = 3000; 1731our $DEFAULT_RESET = 3000;
1632 1732
1633sub generate_random_map { 1733sub generate_random_map {
1634 my ($self, $rmp) = @_; 1734 my ($self, $rmp) = @_;
1735
1736 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1737
1635 # mit "rum" bekleckern, nicht 1738 # mit "rum" bekleckern, nicht
1636 $self->_create_random_map ( 1739 $self->_create_random_map (
1637 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1740 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1638 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1741 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1639 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1742 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
… …
1761 1864
1762# the temporary/swap location 1865# the temporary/swap location
1763sub save_path { 1866sub save_path {
1764 my ($self) = @_; 1867 my ($self) = @_;
1765 1868
1766 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1869 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1767 "$TMPDIR/$path.map" 1870 "$TMPDIR/$path.map"
1768} 1871}
1769 1872
1770# the unique path, undef == no special unique path 1873# the unique path, undef == no special unique path
1771sub uniq_path { 1874sub uniq_path {
1772 my ($self) = @_; 1875 my ($self) = @_;
1773 1876
1774 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1877 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1775 "$UNIQUEDIR/$path" 1878 "$UNIQUEDIR/$path"
1776}
1777
1778# and all this just because we cannot iterate over
1779# all maps in C++...
1780sub change_all_map_light {
1781 my ($change) = @_;
1782
1783 $_->change_map_light ($change)
1784 for grep $_->outdoor, values %cf::MAP;
1785} 1879}
1786 1880
1787sub decay_objects { 1881sub decay_objects {
1788 my ($self) = @_; 1882 my ($self) = @_;
1789 1883
… …
1873sub find { 1967sub find {
1874 my ($path, $origin) = @_; 1968 my ($path, $origin) = @_;
1875 1969
1876 $path = normalise $path, $origin && $origin->path; 1970 $path = normalise $path, $origin && $origin->path;
1877 1971
1878 cf::lock_wait "map_data:$path";#d#remove 1972 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1879 cf::lock_wait "map_find:$path"; 1973 my $guard2 = cf::lock_acquire "map_find:$path";
1880 1974
1881 $cf::MAP{$path} || do { 1975 $cf::MAP{$path} || do {
1882 my $guard1 = cf::lock_acquire "map_find:$path";
1883 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1884
1885 my $map = new_from_path cf::map $path 1976 my $map = new_from_path cf::map $path
1886 or return; 1977 or return;
1887 1978
1888 $map->{last_save} = $cf::RUNTIME; 1979 $map->{last_save} = $cf::RUNTIME;
1889 1980
… …
1891 or return; 1982 or return;
1892 1983
1893 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 1984 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1894 # doing this can freeze the server in a sync job, obviously 1985 # doing this can freeze the server in a sync job, obviously
1895 #$cf::WAIT_FOR_TICK->wait; 1986 #$cf::WAIT_FOR_TICK->wait;
1987 undef $guard2;
1896 undef $guard1; 1988 undef $guard1;
1897 undef $guard2;
1898 $map->reset; 1989 $map->reset;
1899 return find $path; 1990 return find $path;
1900 } 1991 }
1901 1992
1902 $cf::MAP{$path} = $map 1993 $cf::MAP{$path} = $map
… …
1929 my $f = new_from_file cf::object::thawer $self->{load_path}; 2020 my $f = new_from_file cf::object::thawer $self->{load_path};
1930 $f->skip_block; 2021 $f->skip_block;
1931 $self->_load_objects ($f) 2022 $self->_load_objects ($f)
1932 or return; 2023 or return;
1933 2024
1934 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2025 $self->post_load_original
1935 if delete $self->{load_original}; 2026 if delete $self->{load_original};
1936 2027
1937 if (my $uniq = $self->uniq_path) { 2028 if (my $uniq = $self->uniq_path) {
1938 utf8::encode $uniq; 2029 utf8::encode $uniq;
1939 unless (aio_stat $uniq) { 2030 unless (aio_stat $uniq) {
… …
1957 unless ($self->{deny_activate}) { 2048 unless ($self->{deny_activate}) {
1958 $self->decay_objects; 2049 $self->decay_objects;
1959 $self->fix_auto_apply; 2050 $self->fix_auto_apply;
1960 $self->update_buttons; 2051 $self->update_buttons;
1961 cf::cede_to_tick; 2052 cf::cede_to_tick;
1962 $self->set_darkness_map;
1963 cf::cede_to_tick;
1964 $self->activate; 2053 $self->activate;
1965 } 2054 }
1966 2055
1967 $self->{last_save} = $cf::RUNTIME; 2056 $self->{last_save} = $cf::RUNTIME;
1968 $self->last_access ($cf::RUNTIME); 2057 $self->last_access ($cf::RUNTIME);
1969 2058
1970 $self->in_memory (cf::MAP_IN_MEMORY); 2059 $self->in_memory (cf::MAP_ACTIVE);
1971 } 2060 }
1972 2061
1973 $self->post_load; 2062 $self->post_load;
1974} 2063}
1975 2064
… …
2033 my ($path, $origin, $load) = @_; 2122 my ($path, $origin, $load) = @_;
2034 2123
2035 $path = normalise $path, $origin && $origin->{path}; 2124 $path = normalise $path, $origin && $origin->{path};
2036 2125
2037 if (my $map = $cf::MAP{$path}) { 2126 if (my $map = $cf::MAP{$path}) {
2038 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY; 2127 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
2039 } 2128 }
2040 2129
2041 $MAP_PREFETCH{$path} |= $load; 2130 $MAP_PREFETCH{$path} |= $load;
2042 2131
2043 $MAP_PREFETCHER ||= cf::async { 2132 $MAP_PREFETCHER ||= cf::async {
… …
2080 cf::async { 2169 cf::async {
2081 $Coro::current->{desc} = "map player save"; 2170 $Coro::current->{desc} = "map player save";
2082 $_->contr->save for $self->players; 2171 $_->contr->save for $self->players;
2083 }; 2172 };
2084 2173
2174 cf::get_slot 0.02;
2175
2085 if ($uniq) { 2176 if ($uniq) {
2086 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2177 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
2087 $self->_save_objects ($uniq, cf::IO_UNIQUES); 2178 $self->_save_objects ($uniq, cf::IO_UNIQUES);
2088 } else { 2179 } else {
2089 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 2180 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
… …
2097 $self->save; 2188 $self->save;
2098 2189
2099 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2190 my $lock = cf::lock_acquire "map_data:$self->{path}";
2100 2191
2101 return if $self->players; 2192 return if $self->players;
2102 return if $self->in_memory != cf::MAP_IN_MEMORY; 2193 return if $self->in_memory != cf::MAP_ACTIVE;
2103 return if $self->{deny_save}; 2194 return if $self->{deny_save};
2104 2195
2105 $self->in_memory (cf::MAP_SWAPPED); 2196 $self->in_memory (cf::MAP_SWAPPED);
2106 2197
2107 $self->deactivate; 2198 $self->deactivate;
… …
2225 2316
2226sub unique_maps() { 2317sub unique_maps() {
2227 [ 2318 [
2228 map { 2319 map {
2229 utf8::decode $_; 2320 utf8::decode $_;
2230 /\.map$/ 2321 s/\.map$//; # TODO future compatibility hack
2322 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
2323 ? ()
2231 ? normalise $_ 2324 : normalise $_
2232 : ()
2233 } @{ aio_readdir $UNIQUEDIR or [] } 2325 } @{ aio_readdir $UNIQUEDIR or [] }
2234 ] 2326 ]
2235} 2327}
2236 2328
2237package cf;
2238
2239=back 2329=back
2240 2330
2241=head3 cf::object 2331=head3 cf::object
2242 2332
2243=cut 2333=cut
… …
2246 2336
2247=over 4 2337=over 4
2248 2338
2249=item $ob->inv_recursive 2339=item $ob->inv_recursive
2250 2340
2251Returns the inventory of the object _and_ their inventories, recursively. 2341Returns the inventory of the object I<and> their inventories, recursively,
2342but I<not> the object itself.
2252 2343
2253=cut 2344=cut
2254 2345
2255sub inv_recursive_; 2346sub inv_recursive_;
2256sub inv_recursive_ { 2347sub inv_recursive_ {
… …
2261 inv_recursive_ inv $_[0] 2352 inv_recursive_ inv $_[0]
2262} 2353}
2263 2354
2264=item $ref = $ob->ref 2355=item $ref = $ob->ref
2265 2356
2266creates and returns a persistent reference to an objetc that can be stored as a string. 2357Creates and returns a persistent reference to an object that can be stored as a string.
2267 2358
2268=item $ob = cf::object::deref ($refstring) 2359=item $ob = cf::object::deref ($refstring)
2269 2360
2270returns the objetc referenced by refstring. may return undef when it cnanot find the object, 2361returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2271even if the object actually exists. May block. 2362even if the object actually exists. May block.
… …
2273=cut 2364=cut
2274 2365
2275sub deref { 2366sub deref {
2276 my ($ref) = @_; 2367 my ($ref) = @_;
2277 2368
2278 # temporary compatibility#TODO#remove
2279 $ref =~ s{^<}{player/<};
2280
2281 if ($ref =~ m{^player\/(<1\.\d+>)/(.*)$}) { 2369 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2282 my ($uuid, $name) = ($1, $2); 2370 my ($uuid, $name) = ($1, $2);
2283 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name 2371 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2284 or return; 2372 or return;
2285 $pl->ob->uuid eq $uuid 2373 $pl->ob->uuid eq $uuid
2286 or return; 2374 or return;
… …
2306can be C<undef>. Does the right thing when the player is currently in a 2394can be C<undef>. Does the right thing when the player is currently in a
2307dialogue with the given NPC character. 2395dialogue with the given NPC character.
2308 2396
2309=cut 2397=cut
2310 2398
2399our $SAY_CHANNEL = {
2400 id => "say",
2401 title => "Map",
2402 reply => "say ",
2403 tooltip => "Things said to and replied from NPCs near you and other players on the same map only.",
2404};
2405
2406our $CHAT_CHANNEL = {
2407 id => "chat",
2408 title => "Chat",
2409 reply => "chat ",
2410 tooltip => "Player chat and shouts, global to the server.",
2411};
2412
2311# rough implementation of a future "reply" method that works 2413# rough implementation of a future "reply" method that works
2312# with dialog boxes. 2414# with dialog boxes.
2313#TODO: the first argument must go, split into a $npc->reply_to ( method 2415#TODO: the first argument must go, split into a $npc->reply_to ( method
2314sub cf::object::player::reply($$$;$) { 2416sub cf::object::player::reply($$$;$) {
2315 my ($self, $npc, $msg, $flags) = @_; 2417 my ($self, $npc, $msg, $flags) = @_;
… …
2326 my $dialog = $pl->{npc_dialog}; 2428 my $dialog = $pl->{npc_dialog};
2327 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg)); 2429 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2328 2430
2329 } else { 2431 } else {
2330 $msg = $npc->name . " says: $msg" if $npc; 2432 $msg = $npc->name . " says: $msg" if $npc;
2331 $self->message ($msg, $flags); 2433 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2332 } 2434 }
2333 } 2435 }
2334} 2436}
2335 2437
2336=item $object->send_msg ($channel, $msg, $color, [extra...]) 2438=item $object->send_msg ($channel, $msg, $color, [extra...])
… …
2361 2463
2362=item $player_object->enter_link 2464=item $player_object->enter_link
2363 2465
2364Freezes the player and moves him/her to a special map (C<{link}>). 2466Freezes the player and moves him/her to a special map (C<{link}>).
2365 2467
2366The player should be reasonably safe there for short amounts of time. You 2468The player should be reasonably safe there for short amounts of time (e.g.
2367I<MUST> call C<leave_link> as soon as possible, though. 2469for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2470though, as the palyer cannot control the character while it is on the link
2471map.
2368 2472
2369Will never block. 2473Will never block.
2370 2474
2371=item $player_object->leave_link ($map, $x, $y) 2475=item $player_object->leave_link ($map, $x, $y)
2372 2476
… …
2430 2534
2431 $map->load; 2535 $map->load;
2432 $map->load_neighbours; 2536 $map->load_neighbours;
2433 2537
2434 return unless $self->contr->active; 2538 return unless $self->contr->active;
2435 $self->activate_recursive;
2436 2539
2437 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2540 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2438 $self->enter_map ($map, $x, $y); 2541 $self->enter_map ($map, $x, $y);
2542
2543 # only activate afterwards, to support waiting in hooks
2544 $self->activate_recursive;
2439} 2545}
2440 2546
2441=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]]) 2547=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2442 2548
2443Moves the player to the given map-path and coordinates by first freezing 2549Moves the player to the given map-path and coordinates by first freezing
2444her, loading and preparing them map, calling the provided $check callback 2550her, loading and preparing them map, calling the provided $check callback
2445that 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
2446the 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
2447be called at the end of this process. 2553be called at the end of this process.
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 >>.
2448 2557
2449=cut 2558=cut
2450 2559
2451our $GOTOGEN; 2560our $GOTOGEN;
2452 2561
… …
2531} 2640}
2532 2641
2533sub prepare_random_map { 2642sub prepare_random_map {
2534 my ($exit) = @_; 2643 my ($exit) = @_;
2535 2644
2536 my $guard = cf::lock_acquire "exit_prepare:$exit";
2537
2538 # all this does is basically replace the /! path by 2645 # all this does is basically replace the /! path by
2539 # a new random map path (?random/...) with a seed 2646 # a new random map path (?random/...) with a seed
2540 # that depends on the exit object 2647 # that depends on the exit object
2541 2648
2542 my $rmp = parse_random_map_params $exit->msg; 2649 my $rmp = parse_random_map_params $exit->msg;
… …
2544 if ($exit->map) { 2651 if ($exit->map) {
2545 $rmp->{region} = $exit->region->name; 2652 $rmp->{region} = $exit->region->name;
2546 $rmp->{origin_map} = $exit->map->path; 2653 $rmp->{origin_map} = $exit->map->path;
2547 $rmp->{origin_x} = $exit->x; 2654 $rmp->{origin_x} = $exit->x;
2548 $rmp->{origin_y} = $exit->y; 2655 $rmp->{origin_y} = $exit->y;
2656
2657 $exit->map->touch;
2549 } 2658 }
2550 2659
2551 $rmp->{random_seed} ||= $exit->random_seed; 2660 $rmp->{random_seed} ||= $exit->random_seed;
2552 2661
2553 my $data = cf::to_json $rmp; 2662 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2554 my $md5 = Digest::MD5::md5_hex $data; 2663 my $md5 = Digest::MD5::md5_hex $data;
2555 my $meta = "$RANDOMDIR/$md5.meta"; 2664 my $meta = "$RANDOMDIR/$md5.meta";
2556 2665
2557 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2666 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2558 aio_write $fh, 0, (length $data), $data, 0; 2667 aio_write $fh, 0, (length $data), $data, 0;
2559 undef $fh; 2668 undef $fh;
2560 aio_rename "$meta~", $meta; 2669 aio_rename "$meta~", $meta;
2561 2670
2671 my $slaying = "?random/$md5";
2672
2673 if ($exit->valid) {
2562 $exit->slaying ("?random/$md5"); 2674 $exit->slaying ("?random/$md5");
2563 $exit->msg (undef); 2675 $exit->msg (undef);
2676 }
2564 } 2677 }
2565} 2678}
2566 2679
2567sub cf::object::player::enter_exit { 2680sub cf::object::player::enter_exit {
2568 my ($self, $exit) = @_; 2681 my ($self, $exit) = @_;
2569 2682
2570 return unless $self->type == cf::PLAYER; 2683 return unless $self->type == cf::PLAYER;
2571 2684
2572 if ($exit->slaying eq "/!") {
2573 #TODO: this should de-fi-ni-te-ly not be a sync-job
2574 # the problem is that $exit might not survive long enough
2575 # so it needs to be done right now, right here
2576 cf::sync_job { prepare_random_map $exit };
2577 }
2578
2579 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2580 my $hp = $exit->stats->hp;
2581 my $sp = $exit->stats->sp;
2582
2583 $self->enter_link; 2685 $self->enter_link;
2584 2686
2585 # if exit is damned, update players death & WoR home-position
2586 $self->contr->savebed ($slaying, $hp, $sp)
2587 if $exit->flag (FLAG_DAMNED);
2588
2589 (async { 2687 (async {
2590 $Coro::current->{desc} = "enter_exit $slaying $hp $sp"; 2688 $Coro::current->{desc} = "enter_exit";
2591 2689
2592 $self->deactivate_recursive; # just to be sure
2593 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
2594 $self->goto ($slaying, $hp, $sp); 2705 $self->goto ($map, $x, $y);
2595 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
2596 1; 2711 1
2597 }) { 2712 }) {
2598 $self->message ("Something went wrong deep within the crossfire server. " 2713 $self->message ("Something went wrong deep within the deliantra server. "
2599 . "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. "
2600 . "Please report this to the dungeon master!", 2715 . "Please report this to the dungeon master!",
2601 cf::NDI_UNIQUE | cf::NDI_RED); 2716 cf::NDI_UNIQUE | cf::NDI_RED);
2602 2717
2603 warn "ERROR in enter_exit: $@"; 2718 warn "ERROR in enter_exit: $@";
… …
2631the 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
2632the message unless the client supports the msg packet. 2747the message unless the client supports the msg packet.
2633 2748
2634=cut 2749=cut
2635 2750
2751# non-persistent channels (usually the info channel)
2636our %CHANNEL = ( 2752our %CHANNEL = (
2637 "c/identify" => { 2753 "c/identify" => {
2638 id => "infobox", 2754 id => "infobox",
2639 title => "Identify", 2755 title => "Identify",
2640 reply => undef, 2756 reply => undef,
… …
2644 id => "infobox", 2760 id => "infobox",
2645 title => "Examine", 2761 title => "Examine",
2646 reply => undef, 2762 reply => undef,
2647 tooltip => "Signs and other items you examined", 2763 tooltip => "Signs and other items you examined",
2648 }, 2764 },
2765 "c/book" => {
2766 id => "infobox",
2767 title => "Book",
2768 reply => undef,
2769 tooltip => "The contents of a note or book",
2770 },
2649 "c/lookat" => { 2771 "c/lookat" => {
2650 id => "infobox", 2772 id => "infobox",
2651 title => "Look", 2773 title => "Look",
2652 reply => undef, 2774 reply => undef,
2653 tooltip => "What you saw there", 2775 tooltip => "What you saw there",
2654 }, 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/statistics" => {
2790 id => "infobox",
2791 title => "Statistics",
2792 reply => undef,
2793 tooltip => "Shows your primary statistics",
2794 },
2795 "c/skills" => {
2796 id => "infobox",
2797 title => "Skills",
2798 reply => undef,
2799 tooltip => "Shows your experience per skill and item power",
2800 },
2801 "c/shopitems" => {
2802 id => "infobox",
2803 title => "Shop Items",
2804 reply => undef,
2805 tooltip => "Shows the items currently for sale in this shop",
2806 },
2807 "c/resistances" => {
2808 id => "infobox",
2809 title => "Resistances",
2810 reply => undef,
2811 tooltip => "Shows your resistances",
2812 },
2813 "c/pets" => {
2814 id => "infobox",
2815 title => "Pets",
2816 reply => undef,
2817 tooltip => "Shows information abotu your pets/a specific pet",
2818 },
2819 "c/perceiveself" => {
2820 id => "infobox",
2821 title => "Perceive Self",
2822 reply => undef,
2823 tooltip => "You gained detailed knowledge about yourself",
2824 },
2825 "c/uptime" => {
2826 id => "infobox",
2827 title => "Uptime",
2828 reply => undef,
2829 tooltip => "How long the server has been running since last restart",
2830 },
2831 "c/mapinfo" => {
2832 id => "infobox",
2833 title => "Map Info",
2834 reply => undef,
2835 tooltip => "Information related to the maps",
2836 },
2837 "c/party" => {
2838 id => "party",
2839 title => "Party",
2840 reply => "gsay ",
2841 tooltip => "Messages and chat related to your party",
2842 },
2843 "c/death" => {
2844 id => "death",
2845 title => "Death",
2846 reply => undef,
2847 tooltip => "Reason for and more info about your most recent death",
2848 },
2849 "c/say" => $SAY_CHANNEL,
2850 "c/chat" => $CHAT_CHANNEL,
2655); 2851);
2656 2852
2657sub cf::client::send_msg { 2853sub cf::client::send_msg {
2658 my ($self, $channel, $msg, $color, @extra) = @_; 2854 my ($self, $channel, $msg, $color, @extra) = @_;
2659 2855
2660 $msg = $self->pl->expand_cfpod ($msg); 2856 $msg = $self->pl->expand_cfpod ($msg)
2857 unless $color & cf::NDI_VERBATIM;
2661 2858
2662 $color &= cf::NDI_CLIENT_MASK; # just in case... 2859 $color &= cf::NDI_CLIENT_MASK; # just in case...
2663 2860
2664 # check predefined channels, for the benefit of C 2861 # check predefined channels, for the benefit of C
2665 if ($CHANNEL{$channel}) { 2862 if ($CHANNEL{$channel}) {
2666 $channel = $CHANNEL{$channel}; 2863 $channel = $CHANNEL{$channel};
2667 2864
2668 $self->ext_msg (channel_info => $channel) 2865 $self->ext_msg (channel_info => $channel);
2669 if $self->can_msg;
2670
2671 $channel = $channel->{id}; 2866 $channel = $channel->{id};
2672 2867
2673 } elsif (ref $channel) { 2868 } elsif (ref $channel) {
2674 # send meta info to client, if not yet sent 2869 # send meta info to client, if not yet sent
2675 unless (exists $self->{channel}{$channel->{id}}) { 2870 unless (exists $self->{channel}{$channel->{id}}) {
2676 $self->{channel}{$channel->{id}} = $channel; 2871 $self->{channel}{$channel->{id}} = $channel;
2677 $self->ext_msg (channel_info => $channel) 2872 $self->ext_msg (channel_info => $channel);
2678 if $self->can_msg;
2679 } 2873 }
2680 2874
2681 $channel = $channel->{id}; 2875 $channel = $channel->{id};
2682 } 2876 }
2683 2877
2684 return unless @extra || length $msg; 2878 return unless @extra || length $msg;
2685 2879
2686 if ($self->can_msg) {
2687 # default colour, mask it out 2880 # default colour, mask it out
2688 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF) 2881 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2689 if $color & cf::NDI_DEF; 2882 if $color & cf::NDI_DEF;
2690 2883
2691 $self->send_packet ("msg " . $self->{json_coder}->encode ( 2884 my $pkt = "msg "
2885 . $self->{json_coder}->encode (
2692 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra])); 2886 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2693 } else { 2887 );
2694 if ($color >= 0) {
2695 # replace some tags by gcfclient-compatible ones
2696 for ($msg) {
2697 1 while
2698 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2699 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2700 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2701 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2702 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2703 }
2704 2888
2705 $color &= cf::NDI_COLOR_MASK; 2889 # try lzf for large packets
2890 $pkt = "lzf " . Compress::LZF::compress $pkt
2891 if 1024 <= length $pkt and $self->{can_lzf};
2706 2892
2707 utf8::encode $msg; 2893 # split very large packets
2708 2894 if (8192 < length $pkt and $self->{can_lzf}) {
2709 if (0 && $msg =~ /\[/) { 2895 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2710 # COMMAND/INFO 2896 $pkt = "frag";
2711 $self->send_packet ("drawextinfo $color 10 8 $msg")
2712 } else {
2713 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2714 $self->send_packet ("drawinfo $color $msg")
2715 }
2716 }
2717 } 2897 }
2898
2899 $self->send_packet ($pkt);
2718} 2900}
2719 2901
2720=item $client->ext_msg ($type, @msg) 2902=item $client->ext_msg ($type, @msg)
2721 2903
2722Sends an ext event to the client. 2904Sends an ext event to the client.
… …
2895=pod 3077=pod
2896 3078
2897The following functions and methods are available within a safe environment: 3079The following functions and methods are available within a safe environment:
2898 3080
2899 cf::object 3081 cf::object
2900 contr pay_amount pay_player map x y force_find force_add 3082 contr pay_amount pay_player map x y force_find force_add destroy
2901 insert remove name archname title slaying race decrease_ob_nr 3083 insert remove name archname title slaying race decrease split
3084 value
2902 3085
2903 cf::object::player 3086 cf::object::player
2904 player 3087 player
2905 3088
2906 cf::player 3089 cf::player
… …
2911 3094
2912=cut 3095=cut
2913 3096
2914for ( 3097for (
2915 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3098 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2916 insert remove inv name archname title slaying race 3099 insert remove inv nrof name archname title slaying race
2917 decrease_ob_nr)], 3100 decrease split destroy change_exp value msg lore send_msg)],
2918 ["cf::object::player" => qw(player)], 3101 ["cf::object::player" => qw(player)],
2919 ["cf::player" => qw(peaceful)], 3102 ["cf::player" => qw(peaceful send_msg)],
2920 ["cf::map" => qw(trigger)], 3103 ["cf::map" => qw(trigger)],
2921) { 3104) {
2922 no strict 'refs'; 3105 no strict 'refs';
2923 my ($pkg, @funs) = @$_; 3106 my ($pkg, @funs) = @$_;
2924 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3107 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
… …
2941 my ($code, %vars) = @_; 3124 my ($code, %vars) = @_;
2942 3125
2943 my $qcode = $code; 3126 my $qcode = $code;
2944 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3127 $qcode =~ s/"/‟/g; # not allowed in #line filenames
2945 $qcode =~ s/\n/\\n/g; 3128 $qcode =~ s/\n/\\n/g;
3129
3130 %vars = (_dummy => 0) unless %vars;
2946 3131
2947 local $_; 3132 local $_;
2948 local @safe::cf::_safe_eval_args = values %vars; 3133 local @safe::cf::_safe_eval_args = values %vars;
2949 3134
2950 my $eval = 3135 my $eval =
… …
3027 { 3212 {
3028 my $faces = $facedata->{faceinfo}; 3213 my $faces = $facedata->{faceinfo};
3029 3214
3030 while (my ($face, $info) = each %$faces) { 3215 while (my ($face, $info) = each %$faces) {
3031 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3216 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3217
3032 cf::face::set_visibility $idx, $info->{visibility}; 3218 cf::face::set_visibility $idx, $info->{visibility};
3033 cf::face::set_magicmap $idx, $info->{magicmap}; 3219 cf::face::set_magicmap $idx, $info->{magicmap};
3034 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3220 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
3035 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3221 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
3036 3222
3037 cf::cede_to_tick; 3223 cf::cede_to_tick;
3038 } 3224 }
3039 3225
3040 while (my ($face, $info) = each %$faces) { 3226 while (my ($face, $info) = each %$faces) {
3041 next unless $info->{smooth}; 3227 next unless $info->{smooth};
3228
3042 my $idx = cf::face::find $face 3229 my $idx = cf::face::find $face
3043 or next; 3230 or next;
3231
3044 if (my $smooth = cf::face::find $info->{smooth}) { 3232 if (my $smooth = cf::face::find $info->{smooth}) {
3045 cf::face::set_smooth $idx, $smooth; 3233 cf::face::set_smooth $idx, $smooth;
3046 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3234 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3047 } else { 3235 } else {
3048 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3236 warn "smooth face '$info->{smooth}' not found for face '$face'";
… …
3066 { 3254 {
3067 # TODO: for gcfclient pleasure, we should give resources 3255 # TODO: for gcfclient pleasure, we should give resources
3068 # that gcfclient doesn't grok a >10000 face index. 3256 # that gcfclient doesn't grok a >10000 face index.
3069 my $res = $facedata->{resource}; 3257 my $res = $facedata->{resource};
3070 3258
3071 my $soundconf = delete $res->{"res/sound.conf"};
3072
3073 while (my ($name, $info) = each %$res) { 3259 while (my ($name, $info) = each %$res) {
3260 if (defined $info->{type}) {
3074 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3261 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3075 my $data; 3262 my $data;
3076 3263
3077 if ($info->{type} & 1) { 3264 if ($info->{type} & 1) {
3078 # prepend meta info 3265 # prepend meta info
3079 3266
3080 my $meta = $enc->encode ({ 3267 my $meta = $enc->encode ({
3081 name => $name, 3268 name => $name,
3082 %{ $info->{meta} || {} }, 3269 %{ $info->{meta} || {} },
3083 }); 3270 });
3084 3271
3085 $data = pack "(w/a*)*", $meta, $info->{data}; 3272 $data = pack "(w/a*)*", $meta, $info->{data};
3273 } else {
3274 $data = $info->{data};
3275 }
3276
3277 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3278 cf::face::set_type $idx, $info->{type};
3086 } else { 3279 } else {
3087 $data = $info->{data}; 3280 $RESOURCE{$name} = $info;
3088 } 3281 }
3089 3282
3090 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3091 cf::face::set_type $idx, $info->{type};
3092
3093 cf::cede_to_tick; 3283 cf::cede_to_tick;
3094 } 3284 }
3095
3096 if ($soundconf) {
3097 $soundconf = $enc->decode (delete $soundconf->{data});
3098
3099 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3100 my $sound = $soundconf->{compat}[$_]
3101 or next;
3102
3103 my $face = cf::face::find "sound/$sound->[1]";
3104 cf::sound::set $sound->[0] => $face;
3105 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3106 }
3107
3108 while (my ($k, $v) = each %{$soundconf->{event}}) {
3109 my $face = cf::face::find "sound/$v";
3110 cf::sound::set $k => $face;
3111 }
3112 }
3113 } 3285 }
3286
3287 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3114 3288
3115 1 3289 1
3116} 3290}
3291
3292cf::global->attach (on_resource_update => sub {
3293 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3294 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3295
3296 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3297 my $sound = $soundconf->{compat}[$_]
3298 or next;
3299
3300 my $face = cf::face::find "sound/$sound->[1]";
3301 cf::sound::set $sound->[0] => $face;
3302 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3303 }
3304
3305 while (my ($k, $v) = each %{$soundconf->{event}}) {
3306 my $face = cf::face::find "sound/$v";
3307 cf::sound::set $k => $face;
3308 }
3309 }
3310});
3117 3311
3118register_exticmd fx_want => sub { 3312register_exticmd fx_want => sub {
3119 my ($ns, $want) = @_; 3313 my ($ns, $want) = @_;
3120 3314
3121 while (my ($k, $v) = each %$want) { 3315 while (my ($k, $v) = each %$want) {
3122 $ns->fx_want ($k, $v); 3316 $ns->fx_want ($k, $v);
3123 } 3317 }
3124}; 3318};
3319
3320sub load_resource_file($) {
3321 my $guard = lock_acquire "load_resource_file";
3322
3323 my $status = load_resource_file_ $_[0];
3324 get_slot 0.1, 100;
3325 cf::arch::commit_load;
3326
3327 $status
3328}
3125 3329
3126sub reload_regions { 3330sub reload_regions {
3127 # HACK to clear player env face cache, we need some signal framework 3331 # HACK to clear player env face cache, we need some signal framework
3128 # for this (global event?) 3332 # for this (global event?)
3129 %ext::player_env::MUSIC_FACE_CACHE = (); 3333 %ext::player_env::MUSIC_FACE_CACHE = ();
… …
3143} 3347}
3144 3348
3145sub reload_archetypes { 3349sub reload_archetypes {
3146 load_resource_file "$DATADIR/archetypes" 3350 load_resource_file "$DATADIR/archetypes"
3147 or die "unable to load archetypes\n"; 3351 or die "unable to load archetypes\n";
3148 #d# NEED to laod twice to resolve forward references
3149 # this really needs to be done in an extra post-pass
3150 # (which needs to be synchronous, so solve it differently)
3151 load_resource_file "$DATADIR/archetypes"
3152 or die "unable to load archetypes\n";
3153} 3352}
3154 3353
3155sub reload_treasures { 3354sub reload_treasures {
3156 load_resource_file "$DATADIR/treasures" 3355 load_resource_file "$DATADIR/treasures"
3157 or die "unable to load treasurelists\n"; 3356 or die "unable to load treasurelists\n";
3158} 3357}
3159 3358
3160sub reload_resources { 3359sub reload_resources {
3161 warn "reloading resource files...\n"; 3360 warn "reloading resource files...\n";
3162 3361
3362 reload_facedata;
3363 reload_archetypes;
3163 reload_regions; 3364 reload_regions;
3164 reload_facedata;
3165 #reload_archetypes;#d#
3166 reload_archetypes;
3167 reload_treasures; 3365 reload_treasures;
3168 3366
3169 warn "finished reloading resource files\n"; 3367 warn "finished reloading resource files\n";
3170}
3171
3172sub init {
3173 reload_resources;
3174} 3368}
3175 3369
3176sub reload_config { 3370sub reload_config {
3177 open my $fh, "<:utf8", "$CONFDIR/config" 3371 open my $fh, "<:utf8", "$CONFDIR/config"
3178 or return; 3372 or return;
3179 3373
3180 local $/; 3374 local $/;
3181 *CFG = YAML::Syck::Load <$fh>; 3375 *CFG = YAML::Load <$fh>;
3182 3376
3183 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3377 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
3184 3378
3185 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3379 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3186 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3380 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
… …
3192 }; 3386 };
3193 warn $@ if $@; 3387 warn $@ if $@;
3194 } 3388 }
3195} 3389}
3196 3390
3391sub pidfile() {
3392 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3393 or die "$PIDFILE: $!";
3394 flock $fh, &Fcntl::LOCK_EX
3395 or die "$PIDFILE: flock: $!";
3396 $fh
3397}
3398
3399# make sure only one server instance is running at any one time
3400sub atomic {
3401 my $fh = pidfile;
3402
3403 my $pid = <$fh>;
3404 kill 9, $pid if $pid > 0;
3405
3406 seek $fh, 0, 0;
3407 print $fh $$;
3408}
3409
3410sub main_loop {
3411 warn "EV::loop starting\n";
3412 if (1) {
3413 EV::loop;
3414 }
3415 warn "EV::loop returned\n";
3416 goto &main_loop unless $REALLY_UNLOOP;
3417}
3418
3197sub main { 3419sub main {
3420 cf::init_globals; # initialise logging
3421
3422 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3423 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3424 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3425 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3426
3427 cf::init_experience;
3428 cf::init_anim;
3429 cf::init_attackmess;
3430 cf::init_dynamic;
3431
3432 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3433
3198 # we must not ever block the main coroutine 3434 # we must not ever block the main coroutine
3199 local $Coro::idle = sub { 3435 local $Coro::idle = sub {
3200 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3436 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3201 (async { 3437 (async {
3202 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3438 $Coro::current->{desc} = "IDLE BUG HANDLER";
3203 Event::one_event; 3439 EV::loop EV::LOOP_ONESHOT;
3204 })->prio (Coro::PRIO_MAX); 3440 })->prio (Coro::PRIO_MAX);
3205 }; 3441 };
3206 3442
3443 evthread_start IO::AIO::poll_fileno;
3444
3445 cf::sync_job {
3446 reload_resources;
3207 reload_config; 3447 reload_config;
3208 db_init; 3448 db_init;
3449
3450 cf::load_settings;
3451 cf::load_materials;
3452 cf::init_uuid;
3453 cf::init_signals;
3454 cf::init_commands;
3455 cf::init_skills;
3456
3457 cf::init_beforeplay;
3458
3459 atomic;
3460
3209 load_extensions; 3461 load_extensions;
3210 3462
3211 $TICK_WATCHER->start; 3463 utime time, time, $RUNTIMEFILE;
3212 Event::loop; 3464
3465 # no (long-running) fork's whatsoever before this point(!)
3466 use POSIX ();
3467 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3468
3469 (pop @POST_INIT)->(0) while @POST_INIT;
3470 };
3471
3472 main_loop;
3213} 3473}
3214 3474
3215############################################################################# 3475#############################################################################
3216# initialisation and cleanup 3476# initialisation and cleanup
3217 3477
3218# install some emergency cleanup handlers 3478# install some emergency cleanup handlers
3219BEGIN { 3479BEGIN {
3480 our %SIGWATCHER = ();
3220 for my $signal (qw(INT HUP TERM)) { 3481 for my $signal (qw(INT HUP TERM)) {
3221 Event->signal ( 3482 $SIGWATCHER{$signal} = EV::signal $signal, sub {
3222 reentrant => 0,
3223 data => WF_AUTOCANCEL,
3224 signal => $signal,
3225 prio => 0,
3226 cb => sub {
3227 cf::cleanup "SIG$signal"; 3483 cf::cleanup "SIG$signal";
3228 },
3229 ); 3484 };
3230 } 3485 }
3231} 3486}
3232 3487
3233sub write_runtime { 3488sub write_runtime_sync {
3234 my $runtime = "$LOCALDIR/runtime";
3235
3236 # first touch the runtime file to show we are still running: 3489 # first touch the runtime file to show we are still running:
3237 # the fsync below can take a very very long time. 3490 # the fsync below can take a very very long time.
3238 3491
3239 IO::AIO::aio_utime $runtime, undef, undef; 3492 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3240 3493
3241 my $guard = cf::lock_acquire "write_runtime"; 3494 my $guard = cf::lock_acquire "write_runtime";
3242 3495
3243 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 3496 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644
3244 or return; 3497 or return;
3245 3498
3246 my $value = $cf::RUNTIME + 90 + 10; 3499 my $value = $cf::RUNTIME + 90 + 10;
3247 # 10 is the runtime save interval, for a monotonic clock 3500 # 10 is the runtime save interval, for a monotonic clock
3248 # 60 allows for the watchdog to kill the server. 3501 # 60 allows for the watchdog to kill the server.
… …
3258 aio_utime $fh, undef, undef; 3511 aio_utime $fh, undef, undef;
3259 3512
3260 close $fh 3513 close $fh
3261 or return; 3514 or return;
3262 3515
3263 aio_rename "$runtime~", $runtime 3516 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3264 and return; 3517 and return;
3265 3518
3266 warn "runtime file written.\n"; 3519 warn "runtime file written.\n";
3267 3520
3268 1 3521 1
3522}
3523
3524our $uuid_lock;
3525our $uuid_skip;
3526
3527sub write_uuid_sync($) {
3528 $uuid_skip ||= $_[0];
3529
3530 return if $uuid_lock;
3531 local $uuid_lock = 1;
3532
3533 my $uuid = "$LOCALDIR/uuid";
3534
3535 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3536 or return;
3537
3538 my $value = uuid_seq uuid_cur;
3539
3540 unless ($value) {
3541 warn "cowardly refusing to write zero uuid value!\n";
3542 return;
3543 }
3544
3545 my $value = uuid_str $value + $uuid_skip;
3546 $uuid_skip = 0;
3547
3548 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3549 and return;
3550
3551 # always fsync - this file is important
3552 aio_fsync $fh
3553 and return;
3554
3555 close $fh
3556 or return;
3557
3558 aio_rename "$uuid~", $uuid
3559 and return;
3560
3561 warn "uuid file written ($value).\n";
3562
3563 1
3564
3565}
3566
3567sub write_uuid($$) {
3568 my ($skip, $sync) = @_;
3569
3570 $sync ? write_uuid_sync $skip
3571 : async { write_uuid_sync $skip };
3269} 3572}
3270 3573
3271sub emergency_save() { 3574sub emergency_save() {
3272 my $freeze_guard = cf::freeze_mainloop; 3575 my $freeze_guard = cf::freeze_mainloop;
3273 3576
3274 warn "enter emergency perl save\n"; 3577 warn "emergency_perl_save: enter\n";
3275 3578
3276 cf::sync_job { 3579 cf::sync_job {
3580 # this is a trade-off: we want to be very quick here, so
3581 # save all maps without fsync, and later call a global sync
3582 # (which in turn might be very very slow)
3583 local $USE_FSYNC = 0;
3584
3277 # use a peculiar iteration method to avoid tripping on perl 3585 # use a peculiar iteration method to avoid tripping on perl
3278 # refcount bugs in for. also avoids problems with players 3586 # refcount bugs in for. also avoids problems with players
3279 # and maps saved/destroyed asynchronously. 3587 # and maps saved/destroyed asynchronously.
3280 warn "begin emergency player save\n"; 3588 warn "emergency_perl_save: begin player save\n";
3281 for my $login (keys %cf::PLAYER) { 3589 for my $login (keys %cf::PLAYER) {
3282 my $pl = $cf::PLAYER{$login} or next; 3590 my $pl = $cf::PLAYER{$login} or next;
3283 $pl->valid or next; 3591 $pl->valid or next;
3592 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3284 $pl->save; 3593 $pl->save;
3285 } 3594 }
3286 warn "end emergency player save\n"; 3595 warn "emergency_perl_save: end player save\n";
3287 3596
3288 warn "begin emergency map save\n"; 3597 warn "emergency_perl_save: begin map save\n";
3289 for my $path (keys %cf::MAP) { 3598 for my $path (keys %cf::MAP) {
3290 my $map = $cf::MAP{$path} or next; 3599 my $map = $cf::MAP{$path} or next;
3291 $map->valid or next; 3600 $map->valid or next;
3292 $map->save; 3601 $map->save;
3293 } 3602 }
3294 warn "end emergency map save\n"; 3603 warn "emergency_perl_save: end map save\n";
3295 3604
3296 warn "begin emergency database checkpoint\n"; 3605 warn "emergency_perl_save: begin database checkpoint\n";
3297 BDB::db_env_txn_checkpoint $DB_ENV; 3606 BDB::db_env_txn_checkpoint $DB_ENV;
3298 warn "end emergency database checkpoint\n"; 3607 warn "emergency_perl_save: end database checkpoint\n";
3608
3609 warn "emergency_perl_save: begin write uuid\n";
3610 write_uuid_sync 1;
3611 warn "emergency_perl_save: end write uuid\n";
3299 }; 3612 };
3300 3613
3614 warn "emergency_perl_save: starting sync()\n";
3615 IO::AIO::aio_sync sub {
3616 warn "emergency_perl_save: finished sync()\n";
3617 };
3618
3301 warn "leave emergency perl save\n"; 3619 warn "emergency_perl_save: leave\n";
3302} 3620}
3303 3621
3304sub post_cleanup { 3622sub post_cleanup {
3305 my ($make_core) = @_; 3623 my ($make_core) = @_;
3306 3624
3307 warn Carp::longmess "post_cleanup backtrace" 3625 warn Carp::longmess "post_cleanup backtrace"
3308 if $make_core; 3626 if $make_core;
3627
3628 my $fh = pidfile;
3629 unlink $PIDFILE if <$fh> == $$;
3630}
3631
3632# a safer delete_package, copied from Symbol
3633sub clear_package($) {
3634 my $pkg = shift;
3635
3636 # expand to full symbol table name if needed
3637 unless ($pkg =~ /^main::.*::$/) {
3638 $pkg = "main$pkg" if $pkg =~ /^::/;
3639 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3640 $pkg .= '::' unless $pkg =~ /::$/;
3641 }
3642
3643 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3644 my $stem_symtab = *{$stem}{HASH};
3645
3646 defined $stem_symtab and exists $stem_symtab->{$leaf}
3647 or return;
3648
3649 # clear all symbols
3650 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3651 for my $name (keys %$leaf_symtab) {
3652 _gv_clear *{"$pkg$name"};
3653# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3654 }
3655 warn "cleared package $pkg\n";#d#
3309} 3656}
3310 3657
3311sub do_reload_perl() { 3658sub do_reload_perl() {
3312 # can/must only be called in main 3659 # can/must only be called in main
3313 if ($Coro::current != $Coro::main) { 3660 if ($Coro::current != $Coro::main) {
3314 warn "can only reload from main coroutine"; 3661 warn "can only reload from main coroutine";
3315 return; 3662 return;
3316 } 3663 }
3317 3664
3665 return if $RELOAD++;
3666
3667 my $t1 = EV::time;
3668
3669 while ($RELOAD) {
3318 warn "reloading..."; 3670 warn "reloading...";
3319 3671
3320 warn "entering sync_job"; 3672 warn "entering sync_job";
3321 3673
3322 cf::sync_job { 3674 cf::sync_job {
3323 cf::write_runtime; # external watchdog should not bark 3675 cf::write_runtime_sync; # external watchdog should not bark
3324 cf::emergency_save; 3676 cf::emergency_save;
3325 cf::write_runtime; # external watchdog should not bark 3677 cf::write_runtime_sync; # external watchdog should not bark
3326 3678
3327 warn "syncing database to disk"; 3679 warn "syncing database to disk";
3328 BDB::db_env_txn_checkpoint $DB_ENV; 3680 BDB::db_env_txn_checkpoint $DB_ENV;
3329 3681
3330 # if anything goes wrong in here, we should simply crash as we already saved 3682 # if anything goes wrong in here, we should simply crash as we already saved
3331 3683
3332 warn "cancelling all WF_AUTOCANCEL watchers";
3333 for (Event::all_watchers) {
3334 $_->cancel if $_->data & WF_AUTOCANCEL;
3335 }
3336
3337 warn "flushing outstanding aio requests"; 3684 warn "flushing outstanding aio requests";
3338 for (;;) {
3339 BDB::flush;
3340 IO::AIO::flush;
3341 Coro::cede;
3342 last unless IO::AIO::nreqs || BDB::nreqs; 3685 while (IO::AIO::nreqs || BDB::nreqs) {
3343 warn "iterate..."; 3686 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3344 }
3345
3346 ++$RELOAD;
3347
3348 warn "cancelling all extension coros";
3349 $_->cancel for values %EXT_CORO;
3350 %EXT_CORO = ();
3351
3352 warn "removing commands";
3353 %COMMAND = ();
3354
3355 warn "removing ext/exti commands";
3356 %EXTCMD = ();
3357 %EXTICMD = ();
3358
3359 warn "unloading/nuking all extensions";
3360 for my $pkg (@EXTS) {
3361 warn "... unloading $pkg";
3362
3363 if (my $cb = $pkg->can ("unload")) {
3364 eval {
3365 $cb->($pkg);
3366 1
3367 } or warn "$pkg unloaded, but with errors: $@";
3368 } 3687 }
3369 3688
3370 warn "... nuking $pkg"; 3689 warn "cancelling all extension coros";
3371 Symbol::delete_package $pkg; 3690 $_->cancel for values %EXT_CORO;
3372 } 3691 %EXT_CORO = ();
3373 3692
3374 warn "unloading all perl modules loaded from $LIBDIR"; 3693 warn "removing commands";
3375 while (my ($k, $v) = each %INC) { 3694 %COMMAND = ();
3376 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3377 3695
3696 warn "removing ext/exti commands";
3697 %EXTCMD = ();
3698 %EXTICMD = ();
3699
3700 warn "unloading/nuking all extensions";
3701 for my $pkg (@EXTS) {
3378 warn "... unloading $k"; 3702 warn "... unloading $pkg";
3379 delete $INC{$k};
3380 3703
3381 $k =~ s/\.pm$//;
3382 $k =~ s/\//::/g;
3383
3384 if (my $cb = $k->can ("unload_module")) { 3704 if (my $cb = $pkg->can ("unload")) {
3705 eval {
3385 $cb->(); 3706 $cb->($pkg);
3707 1
3708 } or warn "$pkg unloaded, but with errors: $@";
3709 }
3710
3711 warn "... clearing $pkg";
3712 clear_package $pkg;
3386 } 3713 }
3387 3714
3388 Symbol::delete_package $k; 3715 warn "unloading all perl modules loaded from $LIBDIR";
3716 while (my ($k, $v) = each %INC) {
3717 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3718
3719 warn "... unloading $k";
3720 delete $INC{$k};
3721
3722 $k =~ s/\.pm$//;
3723 $k =~ s/\//::/g;
3724
3725 if (my $cb = $k->can ("unload_module")) {
3726 $cb->();
3727 }
3728
3729 clear_package $k;
3389 } 3730 }
3390 3731
3391 warn "getting rid of safe::, as good as possible"; 3732 warn "getting rid of safe::, as good as possible";
3392 Symbol::delete_package "safe::$_" 3733 clear_package "safe::$_"
3393 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3734 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3394 3735
3395 warn "unloading cf.pm \"a bit\""; 3736 warn "unloading cf.pm \"a bit\"";
3396 delete $INC{"cf.pm"}; 3737 delete $INC{"cf.pm"};
3397 delete $INC{"cf/pod.pm"}; 3738 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3398 3739
3399 # don't, removes xs symbols, too, 3740 # don't, removes xs symbols, too,
3400 # and global variables created in xs 3741 # and global variables created in xs
3401 #Symbol::delete_package __PACKAGE__; 3742 #clear_package __PACKAGE__;
3402 3743
3403 warn "unload completed, starting to reload now"; 3744 warn "unload completed, starting to reload now";
3404 3745
3405 warn "reloading cf.pm"; 3746 warn "reloading cf.pm";
3406 require cf; 3747 require cf;
3407 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3748 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3408 3749
3409 warn "loading config and database again"; 3750 warn "loading config and database again";
3410 cf::reload_config; 3751 cf::reload_config;
3411 3752
3412 warn "loading extensions"; 3753 warn "loading extensions";
3413 cf::load_extensions; 3754 cf::load_extensions;
3414 3755
3756 if ($REATTACH_ON_RELOAD) {
3415 warn "reattaching attachments to objects/players"; 3757 warn "reattaching attachments to objects/players";
3416 _global_reattach; # objects, sockets 3758 _global_reattach; # objects, sockets
3417 warn "reattaching attachments to maps"; 3759 warn "reattaching attachments to maps";
3418 reattach $_ for values %MAP; 3760 reattach $_ for values %MAP;
3419 warn "reattaching attachments to players"; 3761 warn "reattaching attachments to players";
3420 reattach $_ for values %PLAYER; 3762 reattach $_ for values %PLAYER;
3763 }
3421 3764
3765 warn "running post_init jobs";
3766 (pop @POST_INIT)->(1) while @POST_INIT;
3767
3422 warn "leaving sync_job"; 3768 warn "leaving sync_job";
3423 3769
3424 1 3770 1
3425 } or do { 3771 } or do {
3426 warn $@; 3772 warn $@;
3427 warn "error while reloading, exiting."; 3773 cf::cleanup "error while reloading, exiting.";
3428 exit 1;
3429 }; 3774 };
3430 3775
3431 warn "reloaded"; 3776 warn "reloaded";
3777 --$RELOAD;
3778 }
3779
3780 $t1 = EV::time - $t1;
3781 warn "reload completed in ${t1}s\n";
3432}; 3782};
3433 3783
3434our $RELOAD_WATCHER; # used only during reload 3784our $RELOAD_WATCHER; # used only during reload
3435 3785
3436sub reload_perl() { 3786sub reload_perl() {
3437 # doing reload synchronously and two reloads happen back-to-back, 3787 # doing reload synchronously and two reloads happen back-to-back,
3438 # coro crashes during coro_state_free->destroy here. 3788 # coro crashes during coro_state_free->destroy here.
3439 3789
3440 $RELOAD_WATCHER ||= Event->timer ( 3790 $RELOAD_WATCHER ||= cf::async {
3441 reentrant => 0, 3791 Coro::AIO::aio_wait cache_extensions;
3442 after => 0, 3792
3443 data => WF_AUTOCANCEL, 3793 $RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub {
3444 cb => sub {
3445 do_reload_perl; 3794 do_reload_perl;
3446 undef $RELOAD_WATCHER; 3795 undef $RELOAD_WATCHER;
3447 }, 3796 };
3448 ); 3797 };
3449} 3798}
3450 3799
3451register_command "reload" => sub { 3800register_command "reload" => sub {
3452 my ($who, $arg) = @_; 3801 my ($who, $arg) = @_;
3453 3802
… …
3466 3815
3467our @WAIT_FOR_TICK; 3816our @WAIT_FOR_TICK;
3468our @WAIT_FOR_TICK_BEGIN; 3817our @WAIT_FOR_TICK_BEGIN;
3469 3818
3470sub wait_for_tick { 3819sub wait_for_tick {
3471 return unless $TICK_WATCHER->is_active;
3472 return if $Coro::current == $Coro::main; 3820 return if tick_inhibit || $Coro::current == $Coro::main;
3473 3821
3474 my $signal = new Coro::Signal; 3822 my $signal = new Coro::Signal;
3475 push @WAIT_FOR_TICK, $signal; 3823 push @WAIT_FOR_TICK, $signal;
3476 $signal->wait; 3824 $signal->wait;
3477} 3825}
3478 3826
3479sub wait_for_tick_begin { 3827sub wait_for_tick_begin {
3480 return unless $TICK_WATCHER->is_active;
3481 return if $Coro::current == $Coro::main; 3828 return if tick_inhibit || $Coro::current == $Coro::main;
3482 3829
3483 my $signal = new Coro::Signal; 3830 my $signal = new Coro::Signal;
3484 push @WAIT_FOR_TICK_BEGIN, $signal; 3831 push @WAIT_FOR_TICK_BEGIN, $signal;
3485 $signal->wait; 3832 $signal->wait;
3486} 3833}
3487 3834
3488$TICK_WATCHER = Event->timer ( 3835sub tick {
3489 reentrant => 0,
3490 parked => 1,
3491 prio => 0,
3492 at => $NEXT_TICK || $TICK,
3493 data => WF_AUTOCANCEL,
3494 cb => sub {
3495 if ($Coro::current != $Coro::main) { 3836 if ($Coro::current != $Coro::main) {
3496 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3837 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3497 unless ++$bug_warning > 10; 3838 unless ++$bug_warning > 10;
3498 return; 3839 return;
3499 } 3840 }
3500 3841
3501 $NOW = $tick_start = Event::time;
3502
3503 cf::server_tick; # one server iteration 3842 cf::server_tick; # one server iteration
3504 3843
3505 $RUNTIME += $TICK;
3506 $NEXT_TICK += $TICK;
3507
3508 if ($NOW >= $NEXT_RUNTIME_WRITE) { 3844 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3509 $NEXT_RUNTIME_WRITE = $NOW + 10; 3845 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3510 Coro::async_pool { 3846 Coro::async_pool {
3511 $Coro::current->{desc} = "runtime saver"; 3847 $Coro::current->{desc} = "runtime saver";
3512 write_runtime 3848 write_runtime_sync
3513 or warn "ERROR: unable to write runtime file: $!"; 3849 or warn "ERROR: unable to write runtime file: $!";
3514 };
3515 } 3850 };
3851 }
3516 3852
3517 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3853 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3518 $sig->send; 3854 $sig->send;
3519 } 3855 }
3520 while (my $sig = shift @WAIT_FOR_TICK) { 3856 while (my $sig = shift @WAIT_FOR_TICK) {
3521 $sig->send; 3857 $sig->send;
3522 } 3858 }
3523 3859
3524 $NOW = Event::time; 3860 $LOAD = ($NOW - $TICK_START) / $TICK;
3525
3526 # if we are delayed by four ticks or more, skip them all
3527 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3528
3529 $TICK_WATCHER->at ($NEXT_TICK);
3530 $TICK_WATCHER->start;
3531
3532 $LOAD = ($NOW - $tick_start) / $TICK;
3533 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3861 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3534 3862
3535 _post_tick; 3863 if (0) {
3864 if ($NEXT_TICK) {
3865 my $jitter = $TICK_START - $NEXT_TICK;
3866 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3867 warn "jitter $JITTER\n";#d#
3868 }
3536 }, 3869 }
3537); 3870}
3538 3871
3539{ 3872{
3873 # configure BDB
3874
3540 BDB::min_parallel 8; 3875 BDB::min_parallel 8;
3541 BDB::max_poll_time $TICK * 0.1; 3876 BDB::max_poll_reqs $TICK * 0.1;
3542 $BDB_POLL_WATCHER = Event->io ( 3877 $AnyEvent::BDB::WATCHER->priority (1);
3543 reentrant => 0,
3544 fd => BDB::poll_fileno,
3545 poll => 'r',
3546 prio => 0,
3547 data => WF_AUTOCANCEL,
3548 cb => \&BDB::poll_cb,
3549 );
3550
3551 BDB::set_sync_prepare {
3552 my $status;
3553 my $current = $Coro::current;
3554 (
3555 sub {
3556 $status = $!;
3557 $current->ready; undef $current;
3558 },
3559 sub {
3560 Coro::schedule while defined $current;
3561 $! = $status;
3562 },
3563 )
3564 };
3565 3878
3566 unless ($DB_ENV) { 3879 unless ($DB_ENV) {
3567 $DB_ENV = BDB::db_env_create; 3880 $DB_ENV = BDB::db_env_create;
3568 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC 3881 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3569 | BDB::LOG_AUTOREMOVE, 1); 3882 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
3883 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
3570 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT); 3884 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3571 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT); 3885 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3572 3886
3573 cf::sync_job { 3887 cf::sync_job {
3574 eval { 3888 eval {
… …
3584 3898
3585 cf::cleanup "db_env_open(db): $@" if $@; 3899 cf::cleanup "db_env_open(db): $@" if $@;
3586 }; 3900 };
3587 } 3901 }
3588 3902
3589 $BDB_DEADLOCK_WATCHER = Event->timer ( 3903 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3590 after => 3,
3591 interval => 1,
3592 hard => 1,
3593 prio => 0,
3594 data => WF_AUTOCANCEL,
3595 cb => sub {
3596 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { }; 3904 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3597 },
3598 ); 3905 };
3599 $BDB_CHECKPOINT_WATCHER = Event->timer ( 3906 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3600 after => 11,
3601 interval => 60,
3602 hard => 1,
3603 prio => 0,
3604 data => WF_AUTOCANCEL,
3605 cb => sub {
3606 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { }; 3907 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3607 },
3608 ); 3908 };
3609 $BDB_TRICKLE_WATCHER = Event->timer ( 3909 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3610 after => 5,
3611 interval => 10,
3612 hard => 1,
3613 prio => 0,
3614 data => WF_AUTOCANCEL,
3615 cb => sub {
3616 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { }; 3910 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3617 },
3618 ); 3911 };
3619} 3912}
3620 3913
3621{ 3914{
3915 # configure IO::AIO
3916
3622 IO::AIO::min_parallel 8; 3917 IO::AIO::min_parallel 8;
3623
3624 undef $Coro::AIO::WATCHER;
3625 IO::AIO::max_poll_time $TICK * 0.1; 3918 IO::AIO::max_poll_time $TICK * 0.1;
3626 $AIO_POLL_WATCHER = Event->io ( 3919 undef $AnyEvent::AIO::WATCHER;
3627 reentrant => 0,
3628 data => WF_AUTOCANCEL,
3629 fd => IO::AIO::poll_fileno,
3630 poll => 'r',
3631 prio => 0,
3632 cb => \&IO::AIO::poll_cb,
3633 );
3634} 3920}
3635 3921
3636my $_log_backtrace; 3922my $_log_backtrace;
3637 3923
3638sub _log_backtrace { 3924sub _log_backtrace {
… …
3641 $msg =~ s/\n//; 3927 $msg =~ s/\n//;
3642 3928
3643 # limit the # of concurrent backtraces 3929 # limit the # of concurrent backtraces
3644 if ($_log_backtrace < 2) { 3930 if ($_log_backtrace < 2) {
3645 ++$_log_backtrace; 3931 ++$_log_backtrace;
3932 my $perl_bt = Carp::longmess $msg;
3646 async { 3933 async {
3647 $Coro::current->{desc} = "abt $msg"; 3934 $Coro::current->{desc} = "abt $msg";
3648 3935
3649 my @bt = fork_call { 3936 my @bt = fork_call {
3650 @addr = map { sprintf "%x", $_ } @addr; 3937 @addr = map { sprintf "%x", $_ } @addr;
… …
3661 } 3948 }
3662 3949
3663 @funcs 3950 @funcs
3664 }; 3951 };
3665 3952
3666 LOG llevInfo, "[ABT] $msg\n"; 3953 LOG llevInfo, "[ABT] $perl_bt\n";
3954 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
3667 LOG llevInfo, "[ABT] $_\n" for @bt; 3955 LOG llevInfo, "[ABT] $_\n" for @bt;
3668 --$_log_backtrace; 3956 --$_log_backtrace;
3669 }; 3957 };
3670 } else { 3958 } else {
3671 LOG llevInfo, "[ABT] $msg\n"; 3959 LOG llevInfo, "[ABT] $msg\n";
3672 LOG llevInfo, "[ABT] [suppressed]\n"; 3960 LOG llevInfo, "[ABT] [suppressed]\n";
3673 } 3961 }
3674} 3962}
3675 3963
3676# load additional modules 3964# load additional modules
3677use cf::pod; 3965require "cf/$_.pm" for @EXTRA_MODULES;
3678 3966
3679END { cf::emergency_save } 3967END { cf::emergency_save }
3680 3968
36811 39691
3682 3970

Diff Legend

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