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.383 by root, Thu Oct 11 21:09:29 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 4.1 (); 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.51 (); 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>:
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 LOG llevError | logBacktrace, Carp::longmess "sync job";#d# 489 LOG llevError, Carp::longmess "sync job";#d#
433 490
434 # TODO: use suspend/resume instead
435 # (but this is cancel-safe)
436 my $freeze_guard = freeze_mainloop; 491 my $freeze_guard = freeze_mainloop;
437 492
438 my $busy = 1; 493 my $busy = 1;
439 my @res; 494 my @res;
440 495
444 warn $@ if $@; 499 warn $@ if $@;
445 undef $busy; 500 undef $busy;
446 })->prio (Coro::PRIO_MAX); 501 })->prio (Coro::PRIO_MAX);
447 502
448 while ($busy) { 503 while ($busy) {
449 Coro::cede or Event::one_event; 504 if (Coro::nready) {
505 Coro::cede_notself;
506 } else {
507 EV::loop EV::LOOP_ONESHOT;
450 } 508 }
509 }
451 510
452 $time = Event::time - $time; 511 my $time = EV::time - $time;
453 512
454 LOG llevError | logBacktrace, Carp::longmess "long sync job"
455 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
456
457 $tick_start += $time; # do not account sync jobs to server load 513 $TICK_START += $time; # do not account sync jobs to server load
458 514
459 wantarray ? @res : $res[0] 515 wantarray ? @res : $res[0]
460 } else { 516 } else {
461 # we are in another coroutine, how wonderful, everything just works 517 # we are in another coroutine, how wonderful, everything just works
462 518
487=item fork_call { }, $args 543=item fork_call { }, $args
488 544
489Executes the given code block with the given arguments in a seperate 545Executes the given code block with the given arguments in a seperate
490process, returning the results. Everything must be serialisable with 546process, returning the results. Everything must be serialisable with
491Coro::Storable. May, of course, block. Note that the executed sub may 547Coro::Storable. May, of course, block. Note that the executed sub may
492never block itself or use any form of Event handling. 548never block itself or use any form of event handling.
493 549
494=cut 550=cut
495 551
496sub fork_call(&@) { 552sub fork_call(&@) {
497 my ($cb, @args) = @_; 553 my ($cb, @args) = @_;
504 reset_signals; 560 reset_signals;
505 &$cb 561 &$cb
506 }, @args; 562 }, @args;
507 563
508 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
509} 592}
510 593
511=item $value = cf::db_get $family => $key 594=item $value = cf::db_get $family => $key
512 595
513Returns a single value from the environment database. 596Returns a single value from the environment database.
652 735
653############################################################################# 736#############################################################################
654 737
655=head2 ATTACHABLE OBJECTS 738=head2 ATTACHABLE OBJECTS
656 739
657Many 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
658attach callbacks/event handlers (a collection of which is called an "attachment") 741attach callbacks/event handlers (a collection of which is called an "attachment")
659to it. All such attachable objects support the following methods. 742to it. All such attachable objects support the following methods.
660 743
661In 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>
662C<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
663Crossfire TRT). 746Deliantra).
664 747
665=over 4 748=over 4
666 749
667=item $attachable->attach ($attachment, key => $value...) 750=item $attachable->attach ($attachment, key => $value...)
668 751
712=item cf::CLASS::attachment $name, ... 795=item cf::CLASS::attachment $name, ...
713 796
714Register an attachment by C<$name> through which attachable objects of the 797Register an attachment by C<$name> through which attachable objects of the
715given CLASS can refer to this attachment. 798given CLASS can refer to this attachment.
716 799
717Some classes such as crossfire maps and objects can specify attachments 800Some classes such as deliantra maps and objects can specify attachments
718that 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.
719 802
720These calls expect any number of the following handler/hook descriptions: 803These calls expect any number of the following handler/hook descriptions:
721 804
722=over 4 805=over 4
950 } 1033 }
951 1034
952 0 1035 0
953} 1036}
954 1037
955=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 1038=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
956 1039
957=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 1040=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
958 1041
959Generate an object-specific event with the given arguments. 1042Generate an object-specific event with the given arguments.
960 1043
966 1049
967=cut 1050=cut
968 1051
969############################################################################# 1052#############################################################################
970# object support 1053# object support
971#
972 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#
973sub _can_merge { 1088sub _can_merge {
974 my ($ob1, $ob2) = @_; 1089 my ($ob1, $ob2) = @_;
975 1090
976 local $Storable::canonical = 1; 1091 ++$SLOW_MERGES;#d#
977 my $fob1 = Storable::freeze $ob1;
978 my $fob2 = Storable::freeze $ob2;
979 1092
980 $fob1 eq $fob2 1093 # we do the slow way here
1094 return _object_equal $ob1, $ob2
981} 1095}
982 1096
983sub reattach { 1097sub reattach {
984 # basically do the same as instantiate, without calling instantiate 1098 # basically do the same as instantiate, without calling instantiate
985 my ($obj) = @_; 1099 my ($obj) = @_;
986 1100
1101 # no longer needed after getting rid of delete_package?
987 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
988 1103
989 my $registry = $obj->registry; 1104 my $registry = $obj->registry;
990 1105
991 @$registry = (); 1106 @$registry = ();
992 1107
1007cf::attachable->attach ( 1122cf::attachable->attach (
1008 prio => -1000000, 1123 prio => -1000000,
1009 on_instantiate => sub { 1124 on_instantiate => sub {
1010 my ($obj, $data) = @_; 1125 my ($obj, $data) = @_;
1011 1126
1012 $data = from_json $data; 1127 $data = decode_json $data;
1013 1128
1014 for (@$data) { 1129 for (@$data) {
1015 my ($name, $args) = @$_; 1130 my ($name, $args) = @$_;
1016 1131
1017 $obj->attach ($name, %{$args || {} }); 1132 $obj->attach ($name, %{$args || {} });
1038 utf8::decode (my $decname = $filename); 1153 utf8::decode (my $decname = $filename);
1039 warn sprintf "saving %s (%d,%d)\n", 1154 warn sprintf "saving %s (%d,%d)\n",
1040 $decname, length $$rdata, scalar @$objs; 1155 $decname, length $$rdata, scalar @$objs;
1041 1156
1042 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1157 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1043 chmod SAVE_MODE, $fh; 1158 aio_chmod $fh, SAVE_MODE;
1044 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1159 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1045 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 }
1046 close $fh; 1164 aio_close $fh;
1047 1165
1048 if (@$objs) { 1166 if (@$objs) {
1049 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) {
1050 chmod SAVE_MODE, $fh; 1168 aio_chmod $fh, SAVE_MODE;
1051 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs }; 1169 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1052 aio_write $fh, 0, (length $data), $data, 0; 1170 aio_write $fh, 0, (length $data), $data, 0;
1053 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 }
1054 close $fh; 1175 aio_close $fh;
1055 aio_rename "$filename.pst~", "$filename.pst"; 1176 aio_rename "$filename.pst~", "$filename.pst";
1056 } 1177 }
1057 } else { 1178 } else {
1058 aio_unlink "$filename.pst"; 1179 aio_unlink "$filename.pst";
1059 } 1180 }
1060 1181
1061 aio_rename "$filename~", $filename; 1182 aio_rename "$filename~", $filename;
1183
1184 $filename =~ s%/[^/]+$%%;
1185 aio_pathsync $filename if $cf::USE_FSYNC;
1062 } else { 1186 } else {
1063 warn "FATAL: $filename~: $!\n"; 1187 warn "unable to save objects: $filename~: $!\n";
1064 } 1188 }
1065 } else { 1189 } else {
1066 aio_unlink $filename; 1190 aio_unlink $filename;
1067 aio_unlink "$filename.pst"; 1191 aio_unlink "$filename.pst";
1068 } 1192 }
1087 1211
1088 unless (aio_stat "$filename.pst") { 1212 unless (aio_stat "$filename.pst") {
1089 (aio_load "$filename.pst", $av) >= 0 1213 (aio_load "$filename.pst", $av) >= 0
1090 or return; 1214 or return;
1091 1215
1092 my $st = eval { Coro::Storable::thaw $av } 1216 my $st = eval { Coro::Storable::thaw $av };
1093 || eval { my $guard = Coro::Storable::guard; Storable::thaw $av }; #d# compatibility, remove
1094 $av = $st->{objs}; 1217 $av = $st->{objs};
1095 } 1218 }
1096 1219
1097 utf8::decode (my $decname = $filename); 1220 utf8::decode (my $decname = $filename);
1098 warn sprintf "loading %s (%d,%d)\n", 1221 warn sprintf "loading %s (%d,%d)\n",
1160 my ($name, $cb) = @_; 1283 my ($name, $cb) = @_;
1161 1284
1162 $EXTICMD{$name} = $cb; 1285 $EXTICMD{$name} = $cb;
1163} 1286}
1164 1287
1288use File::Glob ();
1289
1165cf::player->attach ( 1290cf::player->attach (
1166 on_command => sub { 1291 on_command => sub {
1167 my ($pl, $name, $params) = @_; 1292 my ($pl, $name, $params) = @_;
1168 1293
1169 my $cb = $COMMAND{$name} 1294 my $cb = $COMMAND{$name}
1201 1326
1202 cf::override; 1327 cf::override;
1203 }, 1328 },
1204); 1329);
1205 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
1206sub load_extensions { 1344sub load_extensions {
1207 cf::sync_job { 1345 cf::sync_job {
1208 my %todo; 1346 my %todo;
1209 1347
1210 for my $path (<$LIBDIR/*.ext>) { 1348 for my $path (<$LIBDIR/*.ext>) {
1229 1367
1230 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 } 1368 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1231 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; 1369 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1232 1370
1233 $ext{source} = 1371 $ext{source} =
1234 "package $pkg; use strict; use utf8;\n" 1372 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n"
1235 . "#line 1 \"$path\"\n{\n" 1373 . "#line 1 \"$path\"\n{\n"
1236 . $source 1374 . $source
1237 . "\n};\n1"; 1375 . "\n};\n1";
1238 1376
1239 $todo{$base} = \%ext; 1377 $todo{$base} = \%ext;
1255 my $msg = $@ ? "$v->{path}: $@\n" 1393 my $msg = $@ ? "$v->{path}: $@\n"
1256 : "$v->{base}: extension inactive.\n"; 1394 : "$v->{base}: extension inactive.\n";
1257 1395
1258 if (exists $v->{meta}{mandatory}) { 1396 if (exists $v->{meta}{mandatory}) {
1259 warn $msg; 1397 warn $msg;
1260 warn "mandatory extension failed to load, exiting.\n"; 1398 cf::cleanup "mandatory extension failed to load, exiting.";
1261 exit 1;
1262 } 1399 }
1263 1400
1264 warn $msg; 1401 warn $msg;
1265 } 1402 }
1266 1403
1280 1417
1281=back 1418=back
1282 1419
1283=head2 CORE EXTENSIONS 1420=head2 CORE EXTENSIONS
1284 1421
1285Functions and methods that extend core crossfire objects. 1422Functions and methods that extend core deliantra objects.
1286 1423
1287=cut 1424=cut
1288 1425
1289package cf::player; 1426package cf::player;
1290 1427
1333 1470
1334sub exists($) { 1471sub exists($) {
1335 my ($login) = @_; 1472 my ($login) = @_;
1336 1473
1337 $cf::PLAYER{$login} 1474 $cf::PLAYER{$login}
1338 or cf::sync_job { !aio_stat path $login } 1475 or !aio_stat path $login
1339} 1476}
1340 1477
1341sub find($) { 1478sub find($) {
1342 return $cf::PLAYER{$_[0]} || do { 1479 return $cf::PLAYER{$_[0]} || do {
1343 my $login = $_[0]; 1480 my $login = $_[0];
1355 my $f = new_from_file cf::object::thawer path $login 1492 my $f = new_from_file cf::object::thawer path $login
1356 or return; 1493 or return;
1357 1494
1358 my $pl = cf::player::load_pl $f 1495 my $pl = cf::player::load_pl $f
1359 or return; 1496 or return;
1497
1360 local $cf::PLAYER_LOADING{$login} = $pl; 1498 local $cf::PLAYER_LOADING{$login} = $pl;
1361 $f->resolve_delayed_derefs; 1499 $f->resolve_delayed_derefs;
1362 $cf::PLAYER{$login} = $pl 1500 $cf::PLAYER{$login} = $pl
1363 } 1501 }
1364 } 1502 }
1374 1512
1375 return if $pl->{deny_save}; 1513 return if $pl->{deny_save};
1376 1514
1377 aio_mkdir playerdir $pl, 0770; 1515 aio_mkdir playerdir $pl, 0770;
1378 $pl->{last_save} = $cf::RUNTIME; 1516 $pl->{last_save} = $cf::RUNTIME;
1517
1518 cf::get_slot 0.01;
1379 1519
1380 $pl->save_pl ($path); 1520 $pl->save_pl ($path);
1381 cf::cede_to_tick; 1521 cf::cede_to_tick;
1382} 1522}
1383 1523
1415 my ($pl) = @_; 1555 my ($pl) = @_;
1416 1556
1417 my $name = $pl->ob->name; 1557 my $name = $pl->ob->name;
1418 1558
1419 $pl->{deny_save} = 1; 1559 $pl->{deny_save} = 1;
1420 $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
1421 1561
1422 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1562 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1423 $pl->deactivate; 1563 $pl->deactivate;
1564 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1565 $pl->ob->check_score;
1424 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1566 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1425 $pl->ns->destroy if $pl->ns; 1567 $pl->ns->destroy if $pl->ns;
1426 1568
1427 my $path = playerdir $pl; 1569 my $path = playerdir $pl;
1428 my $temp = "$path~$cf::RUNTIME~deleting~"; 1570 my $temp = "$path~$cf::RUNTIME~deleting~";
1467 1609
1468 for my $login (@$dirs) { 1610 for my $login (@$dirs) {
1469 my $path = path $login; 1611 my $path = path $login;
1470 1612
1471 # a .pst is a dead give-away for a valid player 1613 # a .pst is a dead give-away for a valid player
1472 unless (-e "$path.pst") { 1614 # if no pst file found, open and chekc for blocked users
1615 if (aio_stat "$path.pst") {
1473 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next; 1616 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1474 aio_read $fh, 0, 512, my $buf, 0 or next; 1617 aio_read $fh, 0, 512, my $buf, 0 or next;
1475 $buf !~ /^password -------------$/m or next; # official not-valid tag 1618 $buf !~ /^password -------------$/m or next; # official not-valid tag
1476 } 1619 }
1477 1620
1508 } 1651 }
1509 1652
1510 \@paths 1653 \@paths
1511} 1654}
1512 1655
1513=item $protocol_xml = $player->expand_cfpod ($crossfire_pod) 1656=item $protocol_xml = $player->expand_cfpod ($cfpod)
1514 1657
1515Expand crossfire pod fragments into protocol xml. 1658Expand deliantra pod fragments into protocol xml.
1516
1517=cut
1518
1519sub expand_cfpod {
1520 ((my $self), (local $_)) = @_;
1521
1522 # escape & and <
1523 s/&/&amp;/g;
1524 s/(?<![BIUGHT])</&lt;/g;
1525
1526 # this is buggy, it needs to properly take care of nested <'s
1527
1528 1 while
1529 # replace B<>, I<>, U<> etc.
1530 s/B<([^\>]*)>/<b>$1<\/b>/
1531 || s/I<([^\>]*)>/<i>$1<\/i>/
1532 || s/U<([^\>]*)>/<u>$1<\/u>/
1533 || s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/
1534 # replace G<male|female> tags
1535 || s{G<([^>|]*)\|([^>]*)>}{
1536 $self->gender ? $2 : $1
1537 }ge
1538 # replace H<hint text>
1539 || s{H<([^\>]*)>}
1540 {
1541 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
1542 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1543 "")
1544 [$self->{hintmode}]
1545 }ge;
1546
1547 # create single paragraphs (very hackish)
1548 s/(?<=\S)\n(?=\w)/ /g;
1549
1550 # compress some whitespace
1551 s/\s+\n/\n/g; # ws line-ends
1552 s/\n\n+/\n/g; # double lines
1553 s/^\n+//; # beginning lines
1554 s/\n+$//; # ending lines
1555
1556 $_
1557}
1558
1559sub hintmode {
1560 $_[0]{hintmode} = $_[1] if @_ > 1;
1561 $_[0]{hintmode}
1562}
1563 1659
1564=item $player->ext_reply ($msgid, @msg) 1660=item $player->ext_reply ($msgid, @msg)
1565 1661
1566Sends an ext reply to the player. 1662Sends an ext reply to the player.
1567 1663
1634our $MAX_RESET = 3600; 1730our $MAX_RESET = 3600;
1635our $DEFAULT_RESET = 3000; 1731our $DEFAULT_RESET = 3000;
1636 1732
1637sub generate_random_map { 1733sub generate_random_map {
1638 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
1639 # mit "rum" bekleckern, nicht 1738 # mit "rum" bekleckern, nicht
1640 $self->_create_random_map ( 1739 $self->_create_random_map (
1641 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1740 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1642 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1741 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1643 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1742 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1765 1864
1766# the temporary/swap location 1865# the temporary/swap location
1767sub save_path { 1866sub save_path {
1768 my ($self) = @_; 1867 my ($self) = @_;
1769 1868
1770 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1869 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1771 "$TMPDIR/$path.map" 1870 "$TMPDIR/$path.map"
1772} 1871}
1773 1872
1774# the unique path, undef == no special unique path 1873# the unique path, undef == no special unique path
1775sub uniq_path { 1874sub uniq_path {
1776 my ($self) = @_; 1875 my ($self) = @_;
1777 1876
1778 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1877 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1779 "$UNIQUEDIR/$path" 1878 "$UNIQUEDIR/$path"
1780}
1781
1782# and all this just because we cannot iterate over
1783# all maps in C++...
1784sub change_all_map_light {
1785 my ($change) = @_;
1786
1787 $_->change_map_light ($change)
1788 for grep $_->outdoor, values %cf::MAP;
1789} 1879}
1790 1880
1791sub decay_objects { 1881sub decay_objects {
1792 my ($self) = @_; 1882 my ($self) = @_;
1793 1883
1877sub find { 1967sub find {
1878 my ($path, $origin) = @_; 1968 my ($path, $origin) = @_;
1879 1969
1880 $path = normalise $path, $origin && $origin->path; 1970 $path = normalise $path, $origin && $origin->path;
1881 1971
1882 cf::lock_wait "map_data:$path";#d#remove 1972 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1883 cf::lock_wait "map_find:$path"; 1973 my $guard2 = cf::lock_acquire "map_find:$path";
1884 1974
1885 $cf::MAP{$path} || do { 1975 $cf::MAP{$path} || do {
1886 my $guard1 = cf::lock_acquire "map_find:$path";
1887 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1888
1889 my $map = new_from_path cf::map $path 1976 my $map = new_from_path cf::map $path
1890 or return; 1977 or return;
1891 1978
1892 $map->{last_save} = $cf::RUNTIME; 1979 $map->{last_save} = $cf::RUNTIME;
1893 1980
1895 or return; 1982 or return;
1896 1983
1897 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 1984 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1898 # doing this can freeze the server in a sync job, obviously 1985 # doing this can freeze the server in a sync job, obviously
1899 #$cf::WAIT_FOR_TICK->wait; 1986 #$cf::WAIT_FOR_TICK->wait;
1987 undef $guard2;
1900 undef $guard1; 1988 undef $guard1;
1901 undef $guard2;
1902 $map->reset; 1989 $map->reset;
1903 return find $path; 1990 return find $path;
1904 } 1991 }
1905 1992
1906 $cf::MAP{$path} = $map 1993 $cf::MAP{$path} = $map
1933 my $f = new_from_file cf::object::thawer $self->{load_path}; 2020 my $f = new_from_file cf::object::thawer $self->{load_path};
1934 $f->skip_block; 2021 $f->skip_block;
1935 $self->_load_objects ($f) 2022 $self->_load_objects ($f)
1936 or return; 2023 or return;
1937 2024
1938 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2025 $self->post_load_original
1939 if delete $self->{load_original}; 2026 if delete $self->{load_original};
1940 2027
1941 if (my $uniq = $self->uniq_path) { 2028 if (my $uniq = $self->uniq_path) {
1942 utf8::encode $uniq; 2029 utf8::encode $uniq;
1943 unless (aio_stat $uniq) { 2030 unless (aio_stat $uniq) {
1961 unless ($self->{deny_activate}) { 2048 unless ($self->{deny_activate}) {
1962 $self->decay_objects; 2049 $self->decay_objects;
1963 $self->fix_auto_apply; 2050 $self->fix_auto_apply;
1964 $self->update_buttons; 2051 $self->update_buttons;
1965 cf::cede_to_tick; 2052 cf::cede_to_tick;
1966 $self->set_darkness_map;
1967 cf::cede_to_tick;
1968 $self->activate; 2053 $self->activate;
1969 } 2054 }
1970 2055
1971 $self->{last_save} = $cf::RUNTIME; 2056 $self->{last_save} = $cf::RUNTIME;
1972 $self->last_access ($cf::RUNTIME); 2057 $self->last_access ($cf::RUNTIME);
1973 2058
1974 $self->in_memory (cf::MAP_IN_MEMORY); 2059 $self->in_memory (cf::MAP_ACTIVE);
1975 } 2060 }
1976 2061
1977 $self->post_load; 2062 $self->post_load;
1978} 2063}
1979 2064
2037 my ($path, $origin, $load) = @_; 2122 my ($path, $origin, $load) = @_;
2038 2123
2039 $path = normalise $path, $origin && $origin->{path}; 2124 $path = normalise $path, $origin && $origin->{path};
2040 2125
2041 if (my $map = $cf::MAP{$path}) { 2126 if (my $map = $cf::MAP{$path}) {
2042 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY; 2127 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
2043 } 2128 }
2044 2129
2045 $MAP_PREFETCH{$path} |= $load; 2130 $MAP_PREFETCH{$path} |= $load;
2046 2131
2047 $MAP_PREFETCHER ||= cf::async { 2132 $MAP_PREFETCHER ||= cf::async {
2084 cf::async { 2169 cf::async {
2085 $Coro::current->{desc} = "map player save"; 2170 $Coro::current->{desc} = "map player save";
2086 $_->contr->save for $self->players; 2171 $_->contr->save for $self->players;
2087 }; 2172 };
2088 2173
2174 cf::get_slot 0.02;
2175
2089 if ($uniq) { 2176 if ($uniq) {
2090 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2177 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
2091 $self->_save_objects ($uniq, cf::IO_UNIQUES); 2178 $self->_save_objects ($uniq, cf::IO_UNIQUES);
2092 } else { 2179 } else {
2093 $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);
2101 $self->save; 2188 $self->save;
2102 2189
2103 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2190 my $lock = cf::lock_acquire "map_data:$self->{path}";
2104 2191
2105 return if $self->players; 2192 return if $self->players;
2106 return if $self->in_memory != cf::MAP_IN_MEMORY; 2193 return if $self->in_memory != cf::MAP_ACTIVE;
2107 return if $self->{deny_save}; 2194 return if $self->{deny_save};
2108 2195
2109 $self->in_memory (cf::MAP_SWAPPED); 2196 $self->in_memory (cf::MAP_SWAPPED);
2110 2197
2111 $self->deactivate; 2198 $self->deactivate;
2229 2316
2230sub unique_maps() { 2317sub unique_maps() {
2231 [ 2318 [
2232 map { 2319 map {
2233 utf8::decode $_; 2320 utf8::decode $_;
2234 /\.map$/ 2321 s/\.map$//; # TODO future compatibility hack
2322 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
2323 ? ()
2235 ? normalise $_ 2324 : normalise $_
2236 : ()
2237 } @{ aio_readdir $UNIQUEDIR or [] } 2325 } @{ aio_readdir $UNIQUEDIR or [] }
2238 ] 2326 ]
2239} 2327}
2240 2328
2241package cf;
2242
2243=back 2329=back
2244 2330
2245=head3 cf::object 2331=head3 cf::object
2246 2332
2247=cut 2333=cut
2250 2336
2251=over 4 2337=over 4
2252 2338
2253=item $ob->inv_recursive 2339=item $ob->inv_recursive
2254 2340
2255Returns 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.
2256 2343
2257=cut 2344=cut
2258 2345
2259sub inv_recursive_; 2346sub inv_recursive_;
2260sub inv_recursive_ { 2347sub inv_recursive_ {
2265 inv_recursive_ inv $_[0] 2352 inv_recursive_ inv $_[0]
2266} 2353}
2267 2354
2268=item $ref = $ob->ref 2355=item $ref = $ob->ref
2269 2356
2270creates 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.
2271 2358
2272=item $ob = cf::object::deref ($refstring) 2359=item $ob = cf::object::deref ($refstring)
2273 2360
2274returns 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,
2275even if the object actually exists. May block. 2362even if the object actually exists. May block.
2307can 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
2308dialogue with the given NPC character. 2395dialogue with the given NPC character.
2309 2396
2310=cut 2397=cut
2311 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
2312# rough implementation of a future "reply" method that works 2413# rough implementation of a future "reply" method that works
2313# with dialog boxes. 2414# with dialog boxes.
2314#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
2315sub cf::object::player::reply($$$;$) { 2416sub cf::object::player::reply($$$;$) {
2316 my ($self, $npc, $msg, $flags) = @_; 2417 my ($self, $npc, $msg, $flags) = @_;
2327 my $dialog = $pl->{npc_dialog}; 2428 my $dialog = $pl->{npc_dialog};
2328 $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));
2329 2430
2330 } else { 2431 } else {
2331 $msg = $npc->name . " says: $msg" if $npc; 2432 $msg = $npc->name . " says: $msg" if $npc;
2332 $self->message ($msg, $flags); 2433 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2333 } 2434 }
2334 } 2435 }
2335} 2436}
2336 2437
2337=item $object->send_msg ($channel, $msg, $color, [extra...]) 2438=item $object->send_msg ($channel, $msg, $color, [extra...])
2362 2463
2363=item $player_object->enter_link 2464=item $player_object->enter_link
2364 2465
2365Freezes 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}>).
2366 2467
2367The 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.
2368I<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.
2369 2472
2370Will never block. 2473Will never block.
2371 2474
2372=item $player_object->leave_link ($map, $x, $y) 2475=item $player_object->leave_link ($map, $x, $y)
2373 2476
2431 2534
2432 $map->load; 2535 $map->load;
2433 $map->load_neighbours; 2536 $map->load_neighbours;
2434 2537
2435 return unless $self->contr->active; 2538 return unless $self->contr->active;
2436 $self->activate_recursive;
2437 2539
2438 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2540 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2439 $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;
2440} 2545}
2441 2546
2442=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]]) 2547=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2443 2548
2444Moves 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
2445her, loading and preparing them map, calling the provided $check callback 2550her, loading and preparing them map, calling the provided $check callback
2446that 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
2447the 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
2448be 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 >>.
2449 2557
2450=cut 2558=cut
2451 2559
2452our $GOTOGEN; 2560our $GOTOGEN;
2453 2561
2532} 2640}
2533 2641
2534sub prepare_random_map { 2642sub prepare_random_map {
2535 my ($exit) = @_; 2643 my ($exit) = @_;
2536 2644
2537 my $guard = cf::lock_acquire "exit_prepare:$exit";
2538
2539 # all this does is basically replace the /! path by 2645 # all this does is basically replace the /! path by
2540 # a new random map path (?random/...) with a seed 2646 # a new random map path (?random/...) with a seed
2541 # that depends on the exit object 2647 # that depends on the exit object
2542 2648
2543 my $rmp = parse_random_map_params $exit->msg; 2649 my $rmp = parse_random_map_params $exit->msg;
2545 if ($exit->map) { 2651 if ($exit->map) {
2546 $rmp->{region} = $exit->region->name; 2652 $rmp->{region} = $exit->region->name;
2547 $rmp->{origin_map} = $exit->map->path; 2653 $rmp->{origin_map} = $exit->map->path;
2548 $rmp->{origin_x} = $exit->x; 2654 $rmp->{origin_x} = $exit->x;
2549 $rmp->{origin_y} = $exit->y; 2655 $rmp->{origin_y} = $exit->y;
2656
2657 $exit->map->touch;
2550 } 2658 }
2551 2659
2552 $rmp->{random_seed} ||= $exit->random_seed; 2660 $rmp->{random_seed} ||= $exit->random_seed;
2553 2661
2554 my $data = cf::to_json $rmp; 2662 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2555 my $md5 = Digest::MD5::md5_hex $data; 2663 my $md5 = Digest::MD5::md5_hex $data;
2556 my $meta = "$RANDOMDIR/$md5.meta"; 2664 my $meta = "$RANDOMDIR/$md5.meta";
2557 2665
2558 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2666 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2559 aio_write $fh, 0, (length $data), $data, 0; 2667 aio_write $fh, 0, (length $data), $data, 0;
2560 undef $fh; 2668 undef $fh;
2561 aio_rename "$meta~", $meta; 2669 aio_rename "$meta~", $meta;
2562 2670
2671 my $slaying = "?random/$md5";
2672
2673 if ($exit->valid) {
2563 $exit->slaying ("?random/$md5"); 2674 $exit->slaying ("?random/$md5");
2564 $exit->msg (undef); 2675 $exit->msg (undef);
2676 }
2565 } 2677 }
2566} 2678}
2567 2679
2568sub cf::object::player::enter_exit { 2680sub cf::object::player::enter_exit {
2569 my ($self, $exit) = @_; 2681 my ($self, $exit) = @_;
2570 2682
2571 return unless $self->type == cf::PLAYER; 2683 return unless $self->type == cf::PLAYER;
2572 2684
2573 if ($exit->slaying eq "/!") {
2574 #TODO: this should de-fi-ni-te-ly not be a sync-job
2575 # the problem is that $exit might not survive long enough
2576 # so it needs to be done right now, right here
2577 cf::sync_job { prepare_random_map $exit };
2578 }
2579
2580 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2581 my $hp = $exit->stats->hp;
2582 my $sp = $exit->stats->sp;
2583
2584 $self->enter_link; 2685 $self->enter_link;
2585 2686
2586 # if exit is damned, update players death & WoR home-position
2587 $self->contr->savebed ($slaying, $hp, $sp)
2588 if $exit->flag (FLAG_DAMNED);
2589
2590 (async { 2687 (async {
2591 $Coro::current->{desc} = "enter_exit $slaying $hp $sp"; 2688 $Coro::current->{desc} = "enter_exit";
2592 2689
2593 $self->deactivate_recursive; # just to be sure
2594 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
2595 $self->goto ($slaying, $hp, $sp); 2705 $self->goto ($map, $x, $y);
2596 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
2597 1; 2711 1
2598 }) { 2712 }) {
2599 $self->message ("Something went wrong deep within the crossfire server. " 2713 $self->message ("Something went wrong deep within the deliantra server. "
2600 . "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. "
2601 . "Please report this to the dungeon master!", 2715 . "Please report this to the dungeon master!",
2602 cf::NDI_UNIQUE | cf::NDI_RED); 2716 cf::NDI_UNIQUE | cf::NDI_RED);
2603 2717
2604 warn "ERROR in enter_exit: $@"; 2718 warn "ERROR in enter_exit: $@";
2632the 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
2633the message unless the client supports the msg packet. 2747the message unless the client supports the msg packet.
2634 2748
2635=cut 2749=cut
2636 2750
2751# non-persistent channels (usually the info channel)
2637our %CHANNEL = ( 2752our %CHANNEL = (
2638 "c/identify" => { 2753 "c/identify" => {
2639 id => "infobox", 2754 id => "infobox",
2640 title => "Identify", 2755 title => "Identify",
2641 reply => undef, 2756 reply => undef,
2645 id => "infobox", 2760 id => "infobox",
2646 title => "Examine", 2761 title => "Examine",
2647 reply => undef, 2762 reply => undef,
2648 tooltip => "Signs and other items you examined", 2763 tooltip => "Signs and other items you examined",
2649 }, 2764 },
2765 "c/book" => {
2766 id => "infobox",
2767 title => "Book",
2768 reply => undef,
2769 tooltip => "The contents of a note or book",
2770 },
2650 "c/lookat" => { 2771 "c/lookat" => {
2651 id => "infobox", 2772 id => "infobox",
2652 title => "Look", 2773 title => "Look",
2653 reply => undef, 2774 reply => undef,
2654 tooltip => "What you saw there", 2775 tooltip => "What you saw there",
2655 }, 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,
2656); 2851);
2657 2852
2658sub cf::client::send_msg { 2853sub cf::client::send_msg {
2659 my ($self, $channel, $msg, $color, @extra) = @_; 2854 my ($self, $channel, $msg, $color, @extra) = @_;
2660 2855
2661 $msg = $self->pl->expand_cfpod ($msg); 2856 $msg = $self->pl->expand_cfpod ($msg)
2857 unless $color & cf::NDI_VERBATIM;
2662 2858
2663 $color &= cf::NDI_CLIENT_MASK; # just in case... 2859 $color &= cf::NDI_CLIENT_MASK; # just in case...
2664 2860
2665 # check predefined channels, for the benefit of C 2861 # check predefined channels, for the benefit of C
2666 if ($CHANNEL{$channel}) { 2862 if ($CHANNEL{$channel}) {
2667 $channel = $CHANNEL{$channel}; 2863 $channel = $CHANNEL{$channel};
2668 2864
2669 $self->ext_msg (channel_info => $channel) 2865 $self->ext_msg (channel_info => $channel);
2670 if $self->can_msg;
2671
2672 $channel = $channel->{id}; 2866 $channel = $channel->{id};
2673 2867
2674 } elsif (ref $channel) { 2868 } elsif (ref $channel) {
2675 # send meta info to client, if not yet sent 2869 # send meta info to client, if not yet sent
2676 unless (exists $self->{channel}{$channel->{id}}) { 2870 unless (exists $self->{channel}{$channel->{id}}) {
2677 $self->{channel}{$channel->{id}} = $channel; 2871 $self->{channel}{$channel->{id}} = $channel;
2678 $self->ext_msg (channel_info => $channel) 2872 $self->ext_msg (channel_info => $channel);
2679 if $self->can_msg;
2680 } 2873 }
2681 2874
2682 $channel = $channel->{id}; 2875 $channel = $channel->{id};
2683 } 2876 }
2684 2877
2685 return unless @extra || length $msg; 2878 return unless @extra || length $msg;
2686 2879
2687 if ($self->can_msg) {
2688 # default colour, mask it out 2880 # default colour, mask it out
2689 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF) 2881 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2690 if $color & cf::NDI_DEF; 2882 if $color & cf::NDI_DEF;
2691 2883
2692 $self->send_packet ("msg " . $self->{json_coder}->encode ( 2884 my $pkt = "msg "
2885 . $self->{json_coder}->encode (
2693 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra])); 2886 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2694 } else { 2887 );
2695 if ($color >= 0) {
2696 # replace some tags by gcfclient-compatible ones
2697 for ($msg) {
2698 1 while
2699 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2700 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2701 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2702 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2703 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2704 }
2705 2888
2706 $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};
2707 2892
2708 utf8::encode $msg; 2893 # split very large packets
2709 2894 if (8192 < length $pkt and $self->{can_lzf}) {
2710 if (0 && $msg =~ /\[/) { 2895 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2711 # COMMAND/INFO 2896 $pkt = "frag";
2712 $self->send_packet ("drawextinfo $color 10 8 $msg")
2713 } else {
2714 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2715 $self->send_packet ("drawinfo $color $msg")
2716 }
2717 }
2718 } 2897 }
2898
2899 $self->send_packet ($pkt);
2719} 2900}
2720 2901
2721=item $client->ext_msg ($type, @msg) 2902=item $client->ext_msg ($type, @msg)
2722 2903
2723Sends an ext event to the client. 2904Sends an ext event to the client.
2897 3078
2898The following functions and methods are available within a safe environment: 3079The following functions and methods are available within a safe environment:
2899 3080
2900 cf::object 3081 cf::object
2901 contr pay_amount pay_player map x y force_find force_add destroy 3082 contr pay_amount pay_player map x y force_find force_add destroy
2902 insert remove name archname title slaying race decrease_ob_nr 3083 insert remove name archname title slaying race decrease split
3084 value
2903 3085
2904 cf::object::player 3086 cf::object::player
2905 player 3087 player
2906 3088
2907 cf::player 3089 cf::player
2912 3094
2913=cut 3095=cut
2914 3096
2915for ( 3097for (
2916 ["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
2917 insert remove inv name archname title slaying race 3099 insert remove inv nrof name archname title slaying race
2918 decrease_ob_nr destroy)], 3100 decrease split destroy change_exp value msg lore send_msg)],
2919 ["cf::object::player" => qw(player)], 3101 ["cf::object::player" => qw(player)],
2920 ["cf::player" => qw(peaceful)], 3102 ["cf::player" => qw(peaceful send_msg)],
2921 ["cf::map" => qw(trigger)], 3103 ["cf::map" => qw(trigger)],
2922) { 3104) {
2923 no strict 'refs'; 3105 no strict 'refs';
2924 my ($pkg, @funs) = @$_; 3106 my ($pkg, @funs) = @$_;
2925 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3107 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
2942 my ($code, %vars) = @_; 3124 my ($code, %vars) = @_;
2943 3125
2944 my $qcode = $code; 3126 my $qcode = $code;
2945 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3127 $qcode =~ s/"/‟/g; # not allowed in #line filenames
2946 $qcode =~ s/\n/\\n/g; 3128 $qcode =~ s/\n/\\n/g;
3129
3130 %vars = (_dummy => 0) unless %vars;
2947 3131
2948 local $_; 3132 local $_;
2949 local @safe::cf::_safe_eval_args = values %vars; 3133 local @safe::cf::_safe_eval_args = values %vars;
2950 3134
2951 my $eval = 3135 my $eval =
3028 { 3212 {
3029 my $faces = $facedata->{faceinfo}; 3213 my $faces = $facedata->{faceinfo};
3030 3214
3031 while (my ($face, $info) = each %$faces) { 3215 while (my ($face, $info) = each %$faces) {
3032 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3216 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3217
3033 cf::face::set_visibility $idx, $info->{visibility}; 3218 cf::face::set_visibility $idx, $info->{visibility};
3034 cf::face::set_magicmap $idx, $info->{magicmap}; 3219 cf::face::set_magicmap $idx, $info->{magicmap};
3035 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};
3036 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};
3037 3222
3038 cf::cede_to_tick; 3223 cf::cede_to_tick;
3039 } 3224 }
3040 3225
3041 while (my ($face, $info) = each %$faces) { 3226 while (my ($face, $info) = each %$faces) {
3042 next unless $info->{smooth}; 3227 next unless $info->{smooth};
3228
3043 my $idx = cf::face::find $face 3229 my $idx = cf::face::find $face
3044 or next; 3230 or next;
3231
3045 if (my $smooth = cf::face::find $info->{smooth}) { 3232 if (my $smooth = cf::face::find $info->{smooth}) {
3046 cf::face::set_smooth $idx, $smooth; 3233 cf::face::set_smooth $idx, $smooth;
3047 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3234 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3048 } else { 3235 } else {
3049 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3236 warn "smooth face '$info->{smooth}' not found for face '$face'";
3067 { 3254 {
3068 # TODO: for gcfclient pleasure, we should give resources 3255 # TODO: for gcfclient pleasure, we should give resources
3069 # that gcfclient doesn't grok a >10000 face index. 3256 # that gcfclient doesn't grok a >10000 face index.
3070 my $res = $facedata->{resource}; 3257 my $res = $facedata->{resource};
3071 3258
3072 my $soundconf = delete $res->{"res/sound.conf"};
3073
3074 while (my ($name, $info) = each %$res) { 3259 while (my ($name, $info) = each %$res) {
3260 if (defined $info->{type}) {
3075 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3261 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3076 my $data; 3262 my $data;
3077 3263
3078 if ($info->{type} & 1) { 3264 if ($info->{type} & 1) {
3079 # prepend meta info 3265 # prepend meta info
3080 3266
3081 my $meta = $enc->encode ({ 3267 my $meta = $enc->encode ({
3082 name => $name, 3268 name => $name,
3083 %{ $info->{meta} || {} }, 3269 %{ $info->{meta} || {} },
3084 }); 3270 });
3085 3271
3086 $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};
3087 } else { 3279 } else {
3088 $data = $info->{data}; 3280 $RESOURCE{$name} = $info;
3089 } 3281 }
3090 3282
3091 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3092 cf::face::set_type $idx, $info->{type};
3093
3094 cf::cede_to_tick; 3283 cf::cede_to_tick;
3095 } 3284 }
3096
3097 if ($soundconf) {
3098 $soundconf = $enc->decode (delete $soundconf->{data});
3099
3100 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3101 my $sound = $soundconf->{compat}[$_]
3102 or next;
3103
3104 my $face = cf::face::find "sound/$sound->[1]";
3105 cf::sound::set $sound->[0] => $face;
3106 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3107 }
3108
3109 while (my ($k, $v) = each %{$soundconf->{event}}) {
3110 my $face = cf::face::find "sound/$v";
3111 cf::sound::set $k => $face;
3112 }
3113 }
3114 } 3285 }
3286
3287 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3115 3288
3116 1 3289 1
3117} 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});
3118 3311
3119register_exticmd fx_want => sub { 3312register_exticmd fx_want => sub {
3120 my ($ns, $want) = @_; 3313 my ($ns, $want) = @_;
3121 3314
3122 while (my ($k, $v) = each %$want) { 3315 while (my ($k, $v) = each %$want) {
3123 $ns->fx_want ($k, $v); 3316 $ns->fx_want ($k, $v);
3124 } 3317 }
3125}; 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}
3126 3329
3127sub reload_regions { 3330sub reload_regions {
3128 # 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
3129 # for this (global event?) 3332 # for this (global event?)
3130 %ext::player_env::MUSIC_FACE_CACHE = (); 3333 %ext::player_env::MUSIC_FACE_CACHE = ();
3144} 3347}
3145 3348
3146sub reload_archetypes { 3349sub reload_archetypes {
3147 load_resource_file "$DATADIR/archetypes" 3350 load_resource_file "$DATADIR/archetypes"
3148 or die "unable to load archetypes\n"; 3351 or die "unable to load archetypes\n";
3149 #d# NEED to laod twice to resolve forward references
3150 # this really needs to be done in an extra post-pass
3151 # (which needs to be synchronous, so solve it differently)
3152 load_resource_file "$DATADIR/archetypes"
3153 or die "unable to load archetypes\n";
3154} 3352}
3155 3353
3156sub reload_treasures { 3354sub reload_treasures {
3157 load_resource_file "$DATADIR/treasures" 3355 load_resource_file "$DATADIR/treasures"
3158 or die "unable to load treasurelists\n"; 3356 or die "unable to load treasurelists\n";
3159} 3357}
3160 3358
3161sub reload_resources { 3359sub reload_resources {
3162 warn "reloading resource files...\n"; 3360 warn "reloading resource files...\n";
3163 3361
3362 reload_facedata;
3363 reload_archetypes;
3164 reload_regions; 3364 reload_regions;
3165 reload_facedata;
3166 #reload_archetypes;#d#
3167 reload_archetypes;
3168 reload_treasures; 3365 reload_treasures;
3169 3366
3170 warn "finished reloading resource files\n"; 3367 warn "finished reloading resource files\n";
3171}
3172
3173sub init {
3174 reload_resources;
3175} 3368}
3176 3369
3177sub reload_config { 3370sub reload_config {
3178 open my $fh, "<:utf8", "$CONFDIR/config" 3371 open my $fh, "<:utf8", "$CONFDIR/config"
3179 or return; 3372 or return;
3180 3373
3181 local $/; 3374 local $/;
3182 *CFG = YAML::Syck::Load <$fh>; 3375 *CFG = YAML::Load <$fh>;
3183 3376
3184 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3377 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
3185 3378
3186 $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};
3187 $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};
3193 }; 3386 };
3194 warn $@ if $@; 3387 warn $@ if $@;
3195 } 3388 }
3196} 3389}
3197 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
3198sub 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
3199 # we must not ever block the main coroutine 3434 # we must not ever block the main coroutine
3200 local $Coro::idle = sub { 3435 local $Coro::idle = sub {
3201 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#
3202 (async { 3437 (async {
3203 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3438 $Coro::current->{desc} = "IDLE BUG HANDLER";
3204 Event::one_event; 3439 EV::loop EV::LOOP_ONESHOT;
3205 })->prio (Coro::PRIO_MAX); 3440 })->prio (Coro::PRIO_MAX);
3206 }; 3441 };
3207 3442
3443 evthread_start IO::AIO::poll_fileno;
3444
3445 cf::sync_job {
3446 reload_resources;
3208 reload_config; 3447 reload_config;
3209 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
3210 load_extensions; 3461 load_extensions;
3211 3462
3212 $TICK_WATCHER->start; 3463 utime time, time, $RUNTIMEFILE;
3213 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;
3214} 3473}
3215 3474
3216############################################################################# 3475#############################################################################
3217# initialisation and cleanup 3476# initialisation and cleanup
3218 3477
3219# install some emergency cleanup handlers 3478# install some emergency cleanup handlers
3220BEGIN { 3479BEGIN {
3480 our %SIGWATCHER = ();
3221 for my $signal (qw(INT HUP TERM)) { 3481 for my $signal (qw(INT HUP TERM)) {
3222 Event->signal ( 3482 $SIGWATCHER{$signal} = EV::signal $signal, sub {
3223 reentrant => 0,
3224 data => WF_AUTOCANCEL,
3225 signal => $signal,
3226 prio => 0,
3227 cb => sub {
3228 cf::cleanup "SIG$signal"; 3483 cf::cleanup "SIG$signal";
3229 },
3230 ); 3484 };
3231 } 3485 }
3232} 3486}
3233 3487
3234sub write_runtime { 3488sub write_runtime_sync {
3235 my $runtime = "$LOCALDIR/runtime";
3236
3237 # first touch the runtime file to show we are still running: 3489 # first touch the runtime file to show we are still running:
3238 # the fsync below can take a very very long time. 3490 # the fsync below can take a very very long time.
3239 3491
3240 IO::AIO::aio_utime $runtime, undef, undef; 3492 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3241 3493
3242 my $guard = cf::lock_acquire "write_runtime"; 3494 my $guard = cf::lock_acquire "write_runtime";
3243 3495
3244 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 3496 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644
3245 or return; 3497 or return;
3246 3498
3247 my $value = $cf::RUNTIME + 90 + 10; 3499 my $value = $cf::RUNTIME + 90 + 10;
3248 # 10 is the runtime save interval, for a monotonic clock 3500 # 10 is the runtime save interval, for a monotonic clock
3249 # 60 allows for the watchdog to kill the server. 3501 # 60 allows for the watchdog to kill the server.
3259 aio_utime $fh, undef, undef; 3511 aio_utime $fh, undef, undef;
3260 3512
3261 close $fh 3513 close $fh
3262 or return; 3514 or return;
3263 3515
3264 aio_rename "$runtime~", $runtime 3516 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3265 and return; 3517 and return;
3266 3518
3267 warn "runtime file written.\n"; 3519 warn "runtime file written.\n";
3268 3520
3269 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 };
3270} 3572}
3271 3573
3272sub emergency_save() { 3574sub emergency_save() {
3273 my $freeze_guard = cf::freeze_mainloop; 3575 my $freeze_guard = cf::freeze_mainloop;
3274 3576
3275 warn "enter emergency perl save\n"; 3577 warn "emergency_perl_save: enter\n";
3276 3578
3277 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
3278 # use a peculiar iteration method to avoid tripping on perl 3585 # use a peculiar iteration method to avoid tripping on perl
3279 # refcount bugs in for. also avoids problems with players 3586 # refcount bugs in for. also avoids problems with players
3280 # and maps saved/destroyed asynchronously. 3587 # and maps saved/destroyed asynchronously.
3281 warn "begin emergency player save\n"; 3588 warn "emergency_perl_save: begin player save\n";
3282 for my $login (keys %cf::PLAYER) { 3589 for my $login (keys %cf::PLAYER) {
3283 my $pl = $cf::PLAYER{$login} or next; 3590 my $pl = $cf::PLAYER{$login} or next;
3284 $pl->valid or next; 3591 $pl->valid or next;
3285 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt 3592 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3286 $pl->save; 3593 $pl->save;
3287 } 3594 }
3288 warn "end emergency player save\n"; 3595 warn "emergency_perl_save: end player save\n";
3289 3596
3290 warn "begin emergency map save\n"; 3597 warn "emergency_perl_save: begin map save\n";
3291 for my $path (keys %cf::MAP) { 3598 for my $path (keys %cf::MAP) {
3292 my $map = $cf::MAP{$path} or next; 3599 my $map = $cf::MAP{$path} or next;
3293 $map->valid or next; 3600 $map->valid or next;
3294 $map->save; 3601 $map->save;
3295 } 3602 }
3296 warn "end emergency map save\n"; 3603 warn "emergency_perl_save: end map save\n";
3297 3604
3298 warn "begin emergency database checkpoint\n"; 3605 warn "emergency_perl_save: begin database checkpoint\n";
3299 BDB::db_env_txn_checkpoint $DB_ENV; 3606 BDB::db_env_txn_checkpoint $DB_ENV;
3300 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";
3301 }; 3612 };
3302 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
3303 warn "leave emergency perl save\n"; 3619 warn "emergency_perl_save: leave\n";
3304} 3620}
3305 3621
3306sub post_cleanup { 3622sub post_cleanup {
3307 my ($make_core) = @_; 3623 my ($make_core) = @_;
3308 3624
3309 warn Carp::longmess "post_cleanup backtrace" 3625 warn Carp::longmess "post_cleanup backtrace"
3310 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#
3311} 3656}
3312 3657
3313sub do_reload_perl() { 3658sub do_reload_perl() {
3314 # can/must only be called in main 3659 # can/must only be called in main
3315 if ($Coro::current != $Coro::main) { 3660 if ($Coro::current != $Coro::main) {
3316 warn "can only reload from main coroutine"; 3661 warn "can only reload from main coroutine";
3317 return; 3662 return;
3318 } 3663 }
3319 3664
3665 return if $RELOAD++;
3666
3667 my $t1 = EV::time;
3668
3669 while ($RELOAD) {
3320 warn "reloading..."; 3670 warn "reloading...";
3321 3671
3322 warn "entering sync_job"; 3672 warn "entering sync_job";
3323 3673
3324 cf::sync_job { 3674 cf::sync_job {
3325 cf::write_runtime; # external watchdog should not bark 3675 cf::write_runtime_sync; # external watchdog should not bark
3326 cf::emergency_save; 3676 cf::emergency_save;
3327 cf::write_runtime; # external watchdog should not bark 3677 cf::write_runtime_sync; # external watchdog should not bark
3328 3678
3329 warn "syncing database to disk"; 3679 warn "syncing database to disk";
3330 BDB::db_env_txn_checkpoint $DB_ENV; 3680 BDB::db_env_txn_checkpoint $DB_ENV;
3331 3681
3332 # 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
3333 3683
3334 warn "cancelling all WF_AUTOCANCEL watchers";
3335 for (Event::all_watchers) {
3336 $_->cancel if $_->data & WF_AUTOCANCEL;
3337 }
3338
3339 warn "flushing outstanding aio requests"; 3684 warn "flushing outstanding aio requests";
3340 for (;;) {
3341 BDB::flush;
3342 IO::AIO::flush;
3343 Coro::cede;
3344 last unless IO::AIO::nreqs || BDB::nreqs; 3685 while (IO::AIO::nreqs || BDB::nreqs) {
3345 warn "iterate..."; 3686 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3346 }
3347
3348 ++$RELOAD;
3349
3350 warn "cancelling all extension coros";
3351 $_->cancel for values %EXT_CORO;
3352 %EXT_CORO = ();
3353
3354 warn "removing commands";
3355 %COMMAND = ();
3356
3357 warn "removing ext/exti commands";
3358 %EXTCMD = ();
3359 %EXTICMD = ();
3360
3361 warn "unloading/nuking all extensions";
3362 for my $pkg (@EXTS) {
3363 warn "... unloading $pkg";
3364
3365 if (my $cb = $pkg->can ("unload")) {
3366 eval {
3367 $cb->($pkg);
3368 1
3369 } or warn "$pkg unloaded, but with errors: $@";
3370 } 3687 }
3371 3688
3372 warn "... nuking $pkg"; 3689 warn "cancelling all extension coros";
3373 Symbol::delete_package $pkg; 3690 $_->cancel for values %EXT_CORO;
3374 } 3691 %EXT_CORO = ();
3375 3692
3376 warn "unloading all perl modules loaded from $LIBDIR"; 3693 warn "removing commands";
3377 while (my ($k, $v) = each %INC) { 3694 %COMMAND = ();
3378 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3379 3695
3696 warn "removing ext/exti commands";
3697 %EXTCMD = ();
3698 %EXTICMD = ();
3699
3700 warn "unloading/nuking all extensions";
3701 for my $pkg (@EXTS) {
3380 warn "... unloading $k"; 3702 warn "... unloading $pkg";
3381 delete $INC{$k};
3382 3703
3383 $k =~ s/\.pm$//;
3384 $k =~ s/\//::/g;
3385
3386 if (my $cb = $k->can ("unload_module")) { 3704 if (my $cb = $pkg->can ("unload")) {
3705 eval {
3387 $cb->(); 3706 $cb->($pkg);
3707 1
3708 } or warn "$pkg unloaded, but with errors: $@";
3709 }
3710
3711 warn "... clearing $pkg";
3712 clear_package $pkg;
3388 } 3713 }
3389 3714
3390 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;
3391 } 3730 }
3392 3731
3393 warn "getting rid of safe::, as good as possible"; 3732 warn "getting rid of safe::, as good as possible";
3394 Symbol::delete_package "safe::$_" 3733 clear_package "safe::$_"
3395 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);
3396 3735
3397 warn "unloading cf.pm \"a bit\""; 3736 warn "unloading cf.pm \"a bit\"";
3398 delete $INC{"cf.pm"}; 3737 delete $INC{"cf.pm"};
3399 delete $INC{"cf/pod.pm"}; 3738 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3400 3739
3401 # don't, removes xs symbols, too, 3740 # don't, removes xs symbols, too,
3402 # and global variables created in xs 3741 # and global variables created in xs
3403 #Symbol::delete_package __PACKAGE__; 3742 #clear_package __PACKAGE__;
3404 3743
3405 warn "unload completed, starting to reload now"; 3744 warn "unload completed, starting to reload now";
3406 3745
3407 warn "reloading cf.pm"; 3746 warn "reloading cf.pm";
3408 require cf; 3747 require cf;
3409 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3748 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3410 3749
3411 warn "loading config and database again"; 3750 warn "loading config and database again";
3412 cf::reload_config; 3751 cf::reload_config;
3413 3752
3414 warn "loading extensions"; 3753 warn "loading extensions";
3415 cf::load_extensions; 3754 cf::load_extensions;
3416 3755
3756 if ($REATTACH_ON_RELOAD) {
3417 warn "reattaching attachments to objects/players"; 3757 warn "reattaching attachments to objects/players";
3418 _global_reattach; # objects, sockets 3758 _global_reattach; # objects, sockets
3419 warn "reattaching attachments to maps"; 3759 warn "reattaching attachments to maps";
3420 reattach $_ for values %MAP; 3760 reattach $_ for values %MAP;
3421 warn "reattaching attachments to players"; 3761 warn "reattaching attachments to players";
3422 reattach $_ for values %PLAYER; 3762 reattach $_ for values %PLAYER;
3763 }
3423 3764
3765 warn "running post_init jobs";
3766 (pop @POST_INIT)->(1) while @POST_INIT;
3767
3424 warn "leaving sync_job"; 3768 warn "leaving sync_job";
3425 3769
3426 1 3770 1
3427 } or do { 3771 } or do {
3428 warn $@; 3772 warn $@;
3429 warn "error while reloading, exiting."; 3773 cf::cleanup "error while reloading, exiting.";
3430 exit 1;
3431 }; 3774 };
3432 3775
3433 warn "reloaded"; 3776 warn "reloaded";
3777 --$RELOAD;
3778 }
3779
3780 $t1 = EV::time - $t1;
3781 warn "reload completed in ${t1}s\n";
3434}; 3782};
3435 3783
3436our $RELOAD_WATCHER; # used only during reload 3784our $RELOAD_WATCHER; # used only during reload
3437 3785
3438sub reload_perl() { 3786sub reload_perl() {
3439 # doing reload synchronously and two reloads happen back-to-back, 3787 # doing reload synchronously and two reloads happen back-to-back,
3440 # coro crashes during coro_state_free->destroy here. 3788 # coro crashes during coro_state_free->destroy here.
3441 3789
3442 $RELOAD_WATCHER ||= Event->timer ( 3790 $RELOAD_WATCHER ||= cf::async {
3443 reentrant => 0, 3791 Coro::AIO::aio_wait cache_extensions;
3444 after => 0, 3792
3445 data => WF_AUTOCANCEL, 3793 $RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub {
3446 cb => sub {
3447 do_reload_perl; 3794 do_reload_perl;
3448 undef $RELOAD_WATCHER; 3795 undef $RELOAD_WATCHER;
3449 }, 3796 };
3450 ); 3797 };
3451} 3798}
3452 3799
3453register_command "reload" => sub { 3800register_command "reload" => sub {
3454 my ($who, $arg) = @_; 3801 my ($who, $arg) = @_;
3455 3802
3468 3815
3469our @WAIT_FOR_TICK; 3816our @WAIT_FOR_TICK;
3470our @WAIT_FOR_TICK_BEGIN; 3817our @WAIT_FOR_TICK_BEGIN;
3471 3818
3472sub wait_for_tick { 3819sub wait_for_tick {
3473 return unless $TICK_WATCHER->is_active;
3474 return if $Coro::current == $Coro::main; 3820 return if tick_inhibit || $Coro::current == $Coro::main;
3475 3821
3476 my $signal = new Coro::Signal; 3822 my $signal = new Coro::Signal;
3477 push @WAIT_FOR_TICK, $signal; 3823 push @WAIT_FOR_TICK, $signal;
3478 $signal->wait; 3824 $signal->wait;
3479} 3825}
3480 3826
3481sub wait_for_tick_begin { 3827sub wait_for_tick_begin {
3482 return unless $TICK_WATCHER->is_active;
3483 return if $Coro::current == $Coro::main; 3828 return if tick_inhibit || $Coro::current == $Coro::main;
3484 3829
3485 my $signal = new Coro::Signal; 3830 my $signal = new Coro::Signal;
3486 push @WAIT_FOR_TICK_BEGIN, $signal; 3831 push @WAIT_FOR_TICK_BEGIN, $signal;
3487 $signal->wait; 3832 $signal->wait;
3488} 3833}
3489 3834
3490$TICK_WATCHER = Event->timer ( 3835sub tick {
3491 reentrant => 0,
3492 parked => 1,
3493 prio => 0,
3494 at => $NEXT_TICK || $TICK,
3495 data => WF_AUTOCANCEL,
3496 cb => sub {
3497 if ($Coro::current != $Coro::main) { 3836 if ($Coro::current != $Coro::main) {
3498 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"
3499 unless ++$bug_warning > 10; 3838 unless ++$bug_warning > 10;
3500 return; 3839 return;
3501 } 3840 }
3502 3841
3503 $NOW = $tick_start = Event::time;
3504
3505 cf::server_tick; # one server iteration 3842 cf::server_tick; # one server iteration
3506 3843
3507 $RUNTIME += $TICK;
3508 $NEXT_TICK += $TICK;
3509
3510 if ($NOW >= $NEXT_RUNTIME_WRITE) { 3844 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3511 $NEXT_RUNTIME_WRITE = $NOW + 10; 3845 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3512 Coro::async_pool { 3846 Coro::async_pool {
3513 $Coro::current->{desc} = "runtime saver"; 3847 $Coro::current->{desc} = "runtime saver";
3514 write_runtime 3848 write_runtime_sync
3515 or warn "ERROR: unable to write runtime file: $!"; 3849 or warn "ERROR: unable to write runtime file: $!";
3516 };
3517 } 3850 };
3851 }
3518 3852
3519 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3853 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3520 $sig->send; 3854 $sig->send;
3521 } 3855 }
3522 while (my $sig = shift @WAIT_FOR_TICK) { 3856 while (my $sig = shift @WAIT_FOR_TICK) {
3523 $sig->send; 3857 $sig->send;
3524 } 3858 }
3525 3859
3526 $NOW = Event::time; 3860 $LOAD = ($NOW - $TICK_START) / $TICK;
3527
3528 # if we are delayed by four ticks or more, skip them all
3529 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3530
3531 $TICK_WATCHER->at ($NEXT_TICK);
3532 $TICK_WATCHER->start;
3533
3534 $LOAD = ($NOW - $tick_start) / $TICK;
3535 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3861 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3536 3862
3537 _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 }
3538 }, 3869 }
3539); 3870}
3540 3871
3541{ 3872{
3873 # configure BDB
3874
3542 BDB::min_parallel 8; 3875 BDB::min_parallel 8;
3543 BDB::max_poll_time $TICK * 0.1; 3876 BDB::max_poll_reqs $TICK * 0.1;
3544 $BDB_POLL_WATCHER = Event->io ( 3877 $AnyEvent::BDB::WATCHER->priority (1);
3545 reentrant => 0,
3546 fd => BDB::poll_fileno,
3547 poll => 'r',
3548 prio => 0,
3549 data => WF_AUTOCANCEL,
3550 cb => \&BDB::poll_cb,
3551 );
3552
3553 BDB::set_sync_prepare {
3554 my $status;
3555 my $current = $Coro::current;
3556 (
3557 sub {
3558 $status = $!;
3559 $current->ready; undef $current;
3560 },
3561 sub {
3562 Coro::schedule while defined $current;
3563 $! = $status;
3564 },
3565 )
3566 };
3567 3878
3568 unless ($DB_ENV) { 3879 unless ($DB_ENV) {
3569 $DB_ENV = BDB::db_env_create; 3880 $DB_ENV = BDB::db_env_create;
3570 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC 3881 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3571 | 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;
3572 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT); 3884 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3573 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT); 3885 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3574 3886
3575 cf::sync_job { 3887 cf::sync_job {
3576 eval { 3888 eval {
3586 3898
3587 cf::cleanup "db_env_open(db): $@" if $@; 3899 cf::cleanup "db_env_open(db): $@" if $@;
3588 }; 3900 };
3589 } 3901 }
3590 3902
3591 $BDB_DEADLOCK_WATCHER = Event->timer ( 3903 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3592 after => 3,
3593 interval => 1,
3594 hard => 1,
3595 prio => 0,
3596 data => WF_AUTOCANCEL,
3597 cb => sub {
3598 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 { };
3599 },
3600 ); 3905 };
3601 $BDB_CHECKPOINT_WATCHER = Event->timer ( 3906 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3602 after => 11,
3603 interval => 60,
3604 hard => 1,
3605 prio => 0,
3606 data => WF_AUTOCANCEL,
3607 cb => sub {
3608 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { }; 3907 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3609 },
3610 ); 3908 };
3611 $BDB_TRICKLE_WATCHER = Event->timer ( 3909 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3612 after => 5,
3613 interval => 10,
3614 hard => 1,
3615 prio => 0,
3616 data => WF_AUTOCANCEL,
3617 cb => sub {
3618 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { }; 3910 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3619 },
3620 ); 3911 };
3621} 3912}
3622 3913
3623{ 3914{
3915 # configure IO::AIO
3916
3624 IO::AIO::min_parallel 8; 3917 IO::AIO::min_parallel 8;
3625
3626 undef $Coro::AIO::WATCHER;
3627 IO::AIO::max_poll_time $TICK * 0.1; 3918 IO::AIO::max_poll_time $TICK * 0.1;
3628 $AIO_POLL_WATCHER = Event->io ( 3919 undef $AnyEvent::AIO::WATCHER;
3629 reentrant => 0,
3630 data => WF_AUTOCANCEL,
3631 fd => IO::AIO::poll_fileno,
3632 poll => 'r',
3633 prio => 0,
3634 cb => \&IO::AIO::poll_cb,
3635 );
3636} 3920}
3637 3921
3638my $_log_backtrace; 3922my $_log_backtrace;
3639 3923
3640sub _log_backtrace { 3924sub _log_backtrace {
3643 $msg =~ s/\n//; 3927 $msg =~ s/\n//;
3644 3928
3645 # limit the # of concurrent backtraces 3929 # limit the # of concurrent backtraces
3646 if ($_log_backtrace < 2) { 3930 if ($_log_backtrace < 2) {
3647 ++$_log_backtrace; 3931 ++$_log_backtrace;
3932 my $perl_bt = Carp::longmess $msg;
3648 async { 3933 async {
3649 $Coro::current->{desc} = "abt $msg"; 3934 $Coro::current->{desc} = "abt $msg";
3650 3935
3651 my @bt = fork_call { 3936 my @bt = fork_call {
3652 @addr = map { sprintf "%x", $_ } @addr; 3937 @addr = map { sprintf "%x", $_ } @addr;
3663 } 3948 }
3664 3949
3665 @funcs 3950 @funcs
3666 }; 3951 };
3667 3952
3668 LOG llevInfo, "[ABT] $msg\n"; 3953 LOG llevInfo, "[ABT] $perl_bt\n";
3954 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
3669 LOG llevInfo, "[ABT] $_\n" for @bt; 3955 LOG llevInfo, "[ABT] $_\n" for @bt;
3670 --$_log_backtrace; 3956 --$_log_backtrace;
3671 }; 3957 };
3672 } else { 3958 } else {
3673 LOG llevInfo, "[ABT] $msg\n"; 3959 LOG llevInfo, "[ABT] $msg\n";
3674 LOG llevInfo, "[ABT] [suppressed]\n"; 3960 LOG llevInfo, "[ABT] [suppressed]\n";
3675 } 3961 }
3676} 3962}
3677 3963
3678# load additional modules 3964# load additional modules
3679use cf::pod; 3965require "cf/$_.pm" for @EXTRA_MODULES;
3680 3966
3681END { cf::emergency_save } 3967END { cf::emergency_save }
3682 3968
36831 39691
3684 3970

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines