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.381 by root, Mon Oct 8 18:19:39 2007 UTC vs.
Revision 1.474 by root, Thu Jul 16 21:42:56 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;
2539 $self->flag (cf::FLAG_DEBUG, 0);#d# temp
2436 $self->activate_recursive; 2540 $self->activate_recursive;
2437 2541
2438 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2542 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2439 $self->enter_map ($map, $x, $y); 2543 $self->enter_map ($map, $x, $y);
2440} 2544}
2444Moves the player to the given map-path and coordinates by first freezing 2548Moves the player to the given map-path and coordinates by first freezing
2445her, loading and preparing them map, calling the provided $check callback 2549her, loading and preparing them map, calling the provided $check callback
2446that has to return the map if sucecssful, and then unfreezes the player on 2550that 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 2551the new (success) or old (failed) map position. In either case, $done will
2448be called at the end of this process. 2552be called at the end of this process.
2553
2554Note that $check will be called with a potentially non-loaded map, so if
2555it needs a loaded map it has to call C<< ->load >>.
2449 2556
2450=cut 2557=cut
2451 2558
2452our $GOTOGEN; 2559our $GOTOGEN;
2453 2560
2532} 2639}
2533 2640
2534sub prepare_random_map { 2641sub prepare_random_map {
2535 my ($exit) = @_; 2642 my ($exit) = @_;
2536 2643
2537 my $guard = cf::lock_acquire "exit_prepare:$exit";
2538
2539 # all this does is basically replace the /! path by 2644 # all this does is basically replace the /! path by
2540 # a new random map path (?random/...) with a seed 2645 # a new random map path (?random/...) with a seed
2541 # that depends on the exit object 2646 # that depends on the exit object
2542 2647
2543 my $rmp = parse_random_map_params $exit->msg; 2648 my $rmp = parse_random_map_params $exit->msg;
2545 if ($exit->map) { 2650 if ($exit->map) {
2546 $rmp->{region} = $exit->region->name; 2651 $rmp->{region} = $exit->region->name;
2547 $rmp->{origin_map} = $exit->map->path; 2652 $rmp->{origin_map} = $exit->map->path;
2548 $rmp->{origin_x} = $exit->x; 2653 $rmp->{origin_x} = $exit->x;
2549 $rmp->{origin_y} = $exit->y; 2654 $rmp->{origin_y} = $exit->y;
2655
2656 $exit->map->touch;
2550 } 2657 }
2551 2658
2552 $rmp->{random_seed} ||= $exit->random_seed; 2659 $rmp->{random_seed} ||= $exit->random_seed;
2553 2660
2554 my $data = cf::to_json $rmp; 2661 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2555 my $md5 = Digest::MD5::md5_hex $data; 2662 my $md5 = Digest::MD5::md5_hex $data;
2556 my $meta = "$RANDOMDIR/$md5.meta"; 2663 my $meta = "$RANDOMDIR/$md5.meta";
2557 2664
2558 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2665 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2559 aio_write $fh, 0, (length $data), $data, 0; 2666 aio_write $fh, 0, (length $data), $data, 0;
2560 undef $fh; 2667 undef $fh;
2561 aio_rename "$meta~", $meta; 2668 aio_rename "$meta~", $meta;
2562 2669
2670 my $slaying = "?random/$md5";
2671
2672 if ($exit->valid) {
2563 $exit->slaying ("?random/$md5"); 2673 $exit->slaying ("?random/$md5");
2564 $exit->msg (undef); 2674 $exit->msg (undef);
2675 }
2565 } 2676 }
2566} 2677}
2567 2678
2568sub cf::object::player::enter_exit { 2679sub cf::object::player::enter_exit {
2569 my ($self, $exit) = @_; 2680 my ($self, $exit) = @_;
2570 2681
2571 return unless $self->type == cf::PLAYER; 2682 return unless $self->type == cf::PLAYER;
2572 2683
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; 2684 $self->enter_link;
2585 2685
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 { 2686 (async {
2591 $Coro::current->{desc} = "enter_exit $slaying $hp $sp"; 2687 $Coro::current->{desc} = "enter_exit";
2592 2688
2593 $self->deactivate_recursive; # just to be sure
2594 unless (eval { 2689 unless (eval {
2690 $self->deactivate_recursive; # just to be sure
2691
2692 # random map handling
2693 {
2694 my $guard = cf::lock_acquire "exit_prepare:$exit";
2695
2696 prepare_random_map $exit
2697 if $exit->slaying eq "/!";
2698 }
2699
2700 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2701 my $x = $exit->stats->hp;
2702 my $y = $exit->stats->sp;
2703
2595 $self->goto ($slaying, $hp, $sp); 2704 $self->goto ($map, $x, $y);
2596 2705
2706 # if exit is damned, update players death & WoR home-position
2707 $self->contr->savebed ($map, $x, $y)
2708 if $exit->flag (cf::FLAG_DAMNED);
2709
2597 1; 2710 1
2598 }) { 2711 }) {
2599 $self->message ("Something went wrong deep within the crossfire server. " 2712 $self->message ("Something went wrong deep within the deliantra server. "
2600 . "I'll try to bring you back to the map you were before. " 2713 . "I'll try to bring you back to the map you were before. "
2601 . "Please report this to the dungeon master!", 2714 . "Please report this to the dungeon master!",
2602 cf::NDI_UNIQUE | cf::NDI_RED); 2715 cf::NDI_UNIQUE | cf::NDI_RED);
2603 2716
2604 warn "ERROR in enter_exit: $@"; 2717 warn "ERROR in enter_exit: $@";
2632the message, with C<log> being the default. If C<$color> is negative, suppress 2745the message, with C<log> being the default. If C<$color> is negative, suppress
2633the message unless the client supports the msg packet. 2746the message unless the client supports the msg packet.
2634 2747
2635=cut 2748=cut
2636 2749
2750# non-persistent channels (usually the info channel)
2637our %CHANNEL = ( 2751our %CHANNEL = (
2638 "c/identify" => { 2752 "c/identify" => {
2639 id => "infobox", 2753 id => "infobox",
2640 title => "Identify", 2754 title => "Identify",
2641 reply => undef, 2755 reply => undef,
2645 id => "infobox", 2759 id => "infobox",
2646 title => "Examine", 2760 title => "Examine",
2647 reply => undef, 2761 reply => undef,
2648 tooltip => "Signs and other items you examined", 2762 tooltip => "Signs and other items you examined",
2649 }, 2763 },
2764 "c/book" => {
2765 id => "infobox",
2766 title => "Book",
2767 reply => undef,
2768 tooltip => "The contents of a note or book",
2769 },
2650 "c/lookat" => { 2770 "c/lookat" => {
2651 id => "infobox", 2771 id => "infobox",
2652 title => "Look", 2772 title => "Look",
2653 reply => undef, 2773 reply => undef,
2654 tooltip => "What you saw there", 2774 tooltip => "What you saw there",
2655 }, 2775 },
2776 "c/who" => {
2777 id => "infobox",
2778 title => "Players",
2779 reply => undef,
2780 tooltip => "Shows players who are currently online",
2781 },
2782 "c/body" => {
2783 id => "infobox",
2784 title => "Body Parts",
2785 reply => undef,
2786 tooltip => "Shows which body parts you posess and are available",
2787 },
2788 "c/statistics" => {
2789 id => "infobox",
2790 title => "Statistics",
2791 reply => undef,
2792 tooltip => "Shows your primary statistics",
2793 },
2794 "c/skills" => {
2795 id => "infobox",
2796 title => "Skills",
2797 reply => undef,
2798 tooltip => "Shows your experience per skill and item power",
2799 },
2800 "c/shopitems" => {
2801 id => "infobox",
2802 title => "Shop Items",
2803 reply => undef,
2804 tooltip => "Shows the items currently for sale in this shop",
2805 },
2806 "c/resistances" => {
2807 id => "infobox",
2808 title => "Resistances",
2809 reply => undef,
2810 tooltip => "Shows your resistances",
2811 },
2812 "c/pets" => {
2813 id => "infobox",
2814 title => "Pets",
2815 reply => undef,
2816 tooltip => "Shows information abotu your pets/a specific pet",
2817 },
2818 "c/perceiveself" => {
2819 id => "infobox",
2820 title => "Perceive Self",
2821 reply => undef,
2822 tooltip => "You gained detailed knowledge about yourself",
2823 },
2824 "c/uptime" => {
2825 id => "infobox",
2826 title => "Uptime",
2827 reply => undef,
2828 tooltip => "How long the server has been running since last restart",
2829 },
2830 "c/mapinfo" => {
2831 id => "infobox",
2832 title => "Map Info",
2833 reply => undef,
2834 tooltip => "Information related to the maps",
2835 },
2836 "c/party" => {
2837 id => "party",
2838 title => "Party",
2839 reply => "gsay ",
2840 tooltip => "Messages and chat related to your party",
2841 },
2842 "c/death" => {
2843 id => "death",
2844 title => "Death",
2845 reply => undef,
2846 tooltip => "Reason for and more info about your most recent death",
2847 },
2848 "c/say" => $SAY_CHANNEL,
2849 "c/chat" => $CHAT_CHANNEL,
2656); 2850);
2657 2851
2658sub cf::client::send_msg { 2852sub cf::client::send_msg {
2659 my ($self, $channel, $msg, $color, @extra) = @_; 2853 my ($self, $channel, $msg, $color, @extra) = @_;
2660 2854
2661 $msg = $self->pl->expand_cfpod ($msg); 2855 $msg = $self->pl->expand_cfpod ($msg)
2856 unless $color & cf::NDI_VERBATIM;
2662 2857
2663 $color &= cf::NDI_CLIENT_MASK; # just in case... 2858 $color &= cf::NDI_CLIENT_MASK; # just in case...
2664 2859
2665 # check predefined channels, for the benefit of C 2860 # check predefined channels, for the benefit of C
2666 if ($CHANNEL{$channel}) { 2861 if ($CHANNEL{$channel}) {
2667 $channel = $CHANNEL{$channel}; 2862 $channel = $CHANNEL{$channel};
2668 2863
2669 $self->ext_msg (channel_info => $channel) 2864 $self->ext_msg (channel_info => $channel);
2670 if $self->can_msg;
2671
2672 $channel = $channel->{id}; 2865 $channel = $channel->{id};
2673 2866
2674 } elsif (ref $channel) { 2867 } elsif (ref $channel) {
2675 # send meta info to client, if not yet sent 2868 # send meta info to client, if not yet sent
2676 unless (exists $self->{channel}{$channel->{id}}) { 2869 unless (exists $self->{channel}{$channel->{id}}) {
2677 $self->{channel}{$channel->{id}} = $channel; 2870 $self->{channel}{$channel->{id}} = $channel;
2678 $self->ext_msg (channel_info => $channel) 2871 $self->ext_msg (channel_info => $channel);
2679 if $self->can_msg;
2680 } 2872 }
2681 2873
2682 $channel = $channel->{id}; 2874 $channel = $channel->{id};
2683 } 2875 }
2684 2876
2685 return unless @extra || length $msg; 2877 return unless @extra || length $msg;
2686 2878
2687 if ($self->can_msg) {
2688 # default colour, mask it out 2879 # default colour, mask it out
2689 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF) 2880 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2690 if $color & cf::NDI_DEF; 2881 if $color & cf::NDI_DEF;
2691 2882
2692 $self->send_packet ("msg " . $self->{json_coder}->encode ( 2883 my $pkt = "msg "
2884 . $self->{json_coder}->encode (
2693 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra])); 2885 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2694 } else { 2886 );
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 2887
2706 $color &= cf::NDI_COLOR_MASK; 2888 # try lzf for large packets
2889 $pkt = "lzf " . Compress::LZF::compress $pkt
2890 if 1024 <= length $pkt and $self->{can_lzf};
2707 2891
2708 utf8::encode $msg; 2892 # split very large packets
2709 2893 if (8192 < length $pkt and $self->{can_lzf}) {
2710 if (0 && $msg =~ /\[/) { 2894 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2711 # COMMAND/INFO 2895 $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 } 2896 }
2897
2898 $self->send_packet ($pkt);
2719} 2899}
2720 2900
2721=item $client->ext_msg ($type, @msg) 2901=item $client->ext_msg ($type, @msg)
2722 2902
2723Sends an ext event to the client. 2903Sends an ext event to the client.
2896=pod 3076=pod
2897 3077
2898The following functions and methods are available within a safe environment: 3078The following functions and methods are available within a safe environment:
2899 3079
2900 cf::object 3080 cf::object
2901 contr pay_amount pay_player map x y force_find force_add 3081 contr pay_amount pay_player map x y force_find force_add destroy
2902 insert remove name archname title slaying race decrease_ob_nr 3082 insert remove name archname title slaying race decrease split
3083 value
2903 3084
2904 cf::object::player 3085 cf::object::player
2905 player 3086 player
2906 3087
2907 cf::player 3088 cf::player
2912 3093
2913=cut 3094=cut
2914 3095
2915for ( 3096for (
2916 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3097 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2917 insert remove inv name archname title slaying race 3098 insert remove inv nrof name archname title slaying race
2918 decrease_ob_nr)], 3099 decrease split destroy change_exp value msg lore send_msg)],
2919 ["cf::object::player" => qw(player)], 3100 ["cf::object::player" => qw(player)],
2920 ["cf::player" => qw(peaceful)], 3101 ["cf::player" => qw(peaceful send_msg)],
2921 ["cf::map" => qw(trigger)], 3102 ["cf::map" => qw(trigger)],
2922) { 3103) {
2923 no strict 'refs'; 3104 no strict 'refs';
2924 my ($pkg, @funs) = @$_; 3105 my ($pkg, @funs) = @$_;
2925 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3106 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
2942 my ($code, %vars) = @_; 3123 my ($code, %vars) = @_;
2943 3124
2944 my $qcode = $code; 3125 my $qcode = $code;
2945 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3126 $qcode =~ s/"/‟/g; # not allowed in #line filenames
2946 $qcode =~ s/\n/\\n/g; 3127 $qcode =~ s/\n/\\n/g;
3128
3129 %vars = (_dummy => 0) unless %vars;
2947 3130
2948 local $_; 3131 local $_;
2949 local @safe::cf::_safe_eval_args = values %vars; 3132 local @safe::cf::_safe_eval_args = values %vars;
2950 3133
2951 my $eval = 3134 my $eval =
3028 { 3211 {
3029 my $faces = $facedata->{faceinfo}; 3212 my $faces = $facedata->{faceinfo};
3030 3213
3031 while (my ($face, $info) = each %$faces) { 3214 while (my ($face, $info) = each %$faces) {
3032 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3215 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3216
3033 cf::face::set_visibility $idx, $info->{visibility}; 3217 cf::face::set_visibility $idx, $info->{visibility};
3034 cf::face::set_magicmap $idx, $info->{magicmap}; 3218 cf::face::set_magicmap $idx, $info->{magicmap};
3035 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3219 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}; 3220 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
3037 3221
3038 cf::cede_to_tick; 3222 cf::cede_to_tick;
3039 } 3223 }
3040 3224
3041 while (my ($face, $info) = each %$faces) { 3225 while (my ($face, $info) = each %$faces) {
3042 next unless $info->{smooth}; 3226 next unless $info->{smooth};
3227
3043 my $idx = cf::face::find $face 3228 my $idx = cf::face::find $face
3044 or next; 3229 or next;
3230
3045 if (my $smooth = cf::face::find $info->{smooth}) { 3231 if (my $smooth = cf::face::find $info->{smooth}) {
3046 cf::face::set_smooth $idx, $smooth; 3232 cf::face::set_smooth $idx, $smooth;
3047 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3233 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3048 } else { 3234 } else {
3049 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3235 warn "smooth face '$info->{smooth}' not found for face '$face'";
3067 { 3253 {
3068 # TODO: for gcfclient pleasure, we should give resources 3254 # TODO: for gcfclient pleasure, we should give resources
3069 # that gcfclient doesn't grok a >10000 face index. 3255 # that gcfclient doesn't grok a >10000 face index.
3070 my $res = $facedata->{resource}; 3256 my $res = $facedata->{resource};
3071 3257
3072 my $soundconf = delete $res->{"res/sound.conf"};
3073
3074 while (my ($name, $info) = each %$res) { 3258 while (my ($name, $info) = each %$res) {
3259 if (defined $info->{type}) {
3075 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3260 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3076 my $data; 3261 my $data;
3077 3262
3078 if ($info->{type} & 1) { 3263 if ($info->{type} & 1) {
3079 # prepend meta info 3264 # prepend meta info
3080 3265
3081 my $meta = $enc->encode ({ 3266 my $meta = $enc->encode ({
3082 name => $name, 3267 name => $name,
3083 %{ $info->{meta} || {} }, 3268 %{ $info->{meta} || {} },
3084 }); 3269 });
3085 3270
3086 $data = pack "(w/a*)*", $meta, $info->{data}; 3271 $data = pack "(w/a*)*", $meta, $info->{data};
3272 } else {
3273 $data = $info->{data};
3274 }
3275
3276 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3277 cf::face::set_type $idx, $info->{type};
3087 } else { 3278 } else {
3088 $data = $info->{data}; 3279 $RESOURCE{$name} = $info;
3089 } 3280 }
3090 3281
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; 3282 cf::cede_to_tick;
3095 } 3283 }
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 } 3284 }
3285
3286 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3115 3287
3116 1 3288 1
3117} 3289}
3290
3291cf::global->attach (on_resource_update => sub {
3292 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3293 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3294
3295 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3296 my $sound = $soundconf->{compat}[$_]
3297 or next;
3298
3299 my $face = cf::face::find "sound/$sound->[1]";
3300 cf::sound::set $sound->[0] => $face;
3301 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3302 }
3303
3304 while (my ($k, $v) = each %{$soundconf->{event}}) {
3305 my $face = cf::face::find "sound/$v";
3306 cf::sound::set $k => $face;
3307 }
3308 }
3309});
3118 3310
3119register_exticmd fx_want => sub { 3311register_exticmd fx_want => sub {
3120 my ($ns, $want) = @_; 3312 my ($ns, $want) = @_;
3121 3313
3122 while (my ($k, $v) = each %$want) { 3314 while (my ($k, $v) = each %$want) {
3123 $ns->fx_want ($k, $v); 3315 $ns->fx_want ($k, $v);
3124 } 3316 }
3125}; 3317};
3318
3319sub load_resource_file($) {
3320 my $guard = lock_acquire "load_resource_file";
3321
3322 my $status = load_resource_file_ $_[0];
3323 get_slot 0.1, 100;
3324 cf::arch::commit_load;
3325
3326 $status
3327}
3126 3328
3127sub reload_regions { 3329sub reload_regions {
3128 # HACK to clear player env face cache, we need some signal framework 3330 # HACK to clear player env face cache, we need some signal framework
3129 # for this (global event?) 3331 # for this (global event?)
3130 %ext::player_env::MUSIC_FACE_CACHE = (); 3332 %ext::player_env::MUSIC_FACE_CACHE = ();
3144} 3346}
3145 3347
3146sub reload_archetypes { 3348sub reload_archetypes {
3147 load_resource_file "$DATADIR/archetypes" 3349 load_resource_file "$DATADIR/archetypes"
3148 or die "unable to load archetypes\n"; 3350 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} 3351}
3155 3352
3156sub reload_treasures { 3353sub reload_treasures {
3157 load_resource_file "$DATADIR/treasures" 3354 load_resource_file "$DATADIR/treasures"
3158 or die "unable to load treasurelists\n"; 3355 or die "unable to load treasurelists\n";
3159} 3356}
3160 3357
3161sub reload_resources { 3358sub reload_resources {
3162 warn "reloading resource files...\n"; 3359 warn "reloading resource files...\n";
3163 3360
3361 reload_facedata;
3362 reload_archetypes;
3164 reload_regions; 3363 reload_regions;
3165 reload_facedata;
3166 #reload_archetypes;#d#
3167 reload_archetypes;
3168 reload_treasures; 3364 reload_treasures;
3169 3365
3170 warn "finished reloading resource files\n"; 3366 warn "finished reloading resource files\n";
3171}
3172
3173sub init {
3174 reload_resources;
3175} 3367}
3176 3368
3177sub reload_config { 3369sub reload_config {
3178 open my $fh, "<:utf8", "$CONFDIR/config" 3370 open my $fh, "<:utf8", "$CONFDIR/config"
3179 or return; 3371 or return;
3180 3372
3181 local $/; 3373 local $/;
3182 *CFG = YAML::Syck::Load <$fh>; 3374 *CFG = YAML::Load <$fh>;
3183 3375
3184 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3376 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
3185 3377
3186 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3378 $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}; 3379 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3193 }; 3385 };
3194 warn $@ if $@; 3386 warn $@ if $@;
3195 } 3387 }
3196} 3388}
3197 3389
3390sub pidfile() {
3391 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3392 or die "$PIDFILE: $!";
3393 flock $fh, &Fcntl::LOCK_EX
3394 or die "$PIDFILE: flock: $!";
3395 $fh
3396}
3397
3398# make sure only one server instance is running at any one time
3399sub atomic {
3400 my $fh = pidfile;
3401
3402 my $pid = <$fh>;
3403 kill 9, $pid if $pid > 0;
3404
3405 seek $fh, 0, 0;
3406 print $fh $$;
3407}
3408
3409sub main_loop {
3410 warn "EV::loop starting\n";
3411 if (1) {
3412 EV::loop;
3413 }
3414 warn "EV::loop returned\n";
3415 goto &main_loop unless $REALLY_UNLOOP;
3416}
3417
3198sub main { 3418sub main {
3419 cf::init_globals; # initialise logging
3420
3421 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3422 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3423 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3424 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3425
3426 cf::init_experience;
3427 cf::init_anim;
3428 cf::init_attackmess;
3429 cf::init_dynamic;
3430
3431 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3432
3199 # we must not ever block the main coroutine 3433 # we must not ever block the main coroutine
3200 local $Coro::idle = sub { 3434 local $Coro::idle = sub {
3201 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3435 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3202 (async { 3436 (async {
3203 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3437 $Coro::current->{desc} = "IDLE BUG HANDLER";
3204 Event::one_event; 3438 EV::loop EV::LOOP_ONESHOT;
3205 })->prio (Coro::PRIO_MAX); 3439 })->prio (Coro::PRIO_MAX);
3206 }; 3440 };
3207 3441
3442 evthread_start IO::AIO::poll_fileno;
3443
3444 cf::sync_job {
3445 reload_resources;
3208 reload_config; 3446 reload_config;
3209 db_init; 3447 db_init;
3448
3449 cf::load_settings;
3450 cf::load_materials;
3451 cf::init_uuid;
3452 cf::init_signals;
3453 cf::init_commands;
3454 cf::init_skills;
3455
3456 cf::init_beforeplay;
3457
3458 atomic;
3459
3210 load_extensions; 3460 load_extensions;
3211 3461
3212 $TICK_WATCHER->start; 3462 utime time, time, $RUNTIMEFILE;
3213 Event::loop; 3463
3464 # no (long-running) fork's whatsoever before this point(!)
3465 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3466
3467 (pop @POST_INIT)->(0) while @POST_INIT;
3468 };
3469
3470 main_loop;
3214} 3471}
3215 3472
3216############################################################################# 3473#############################################################################
3217# initialisation and cleanup 3474# initialisation and cleanup
3218 3475
3219# install some emergency cleanup handlers 3476# install some emergency cleanup handlers
3220BEGIN { 3477BEGIN {
3478 our %SIGWATCHER = ();
3221 for my $signal (qw(INT HUP TERM)) { 3479 for my $signal (qw(INT HUP TERM)) {
3222 Event->signal ( 3480 $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"; 3481 cf::cleanup "SIG$signal";
3229 },
3230 ); 3482 };
3231 } 3483 }
3232} 3484}
3233 3485
3234sub write_runtime { 3486sub write_runtime_sync {
3235 my $runtime = "$LOCALDIR/runtime";
3236
3237 # first touch the runtime file to show we are still running: 3487 # first touch the runtime file to show we are still running:
3238 # the fsync below can take a very very long time. 3488 # the fsync below can take a very very long time.
3239 3489
3240 IO::AIO::aio_utime $runtime, undef, undef; 3490 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3241 3491
3242 my $guard = cf::lock_acquire "write_runtime"; 3492 my $guard = cf::lock_acquire "write_runtime";
3243 3493
3244 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 3494 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644
3245 or return; 3495 or return;
3246 3496
3247 my $value = $cf::RUNTIME + 90 + 10; 3497 my $value = $cf::RUNTIME + 90 + 10;
3248 # 10 is the runtime save interval, for a monotonic clock 3498 # 10 is the runtime save interval, for a monotonic clock
3249 # 60 allows for the watchdog to kill the server. 3499 # 60 allows for the watchdog to kill the server.
3259 aio_utime $fh, undef, undef; 3509 aio_utime $fh, undef, undef;
3260 3510
3261 close $fh 3511 close $fh
3262 or return; 3512 or return;
3263 3513
3264 aio_rename "$runtime~", $runtime 3514 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3265 and return; 3515 and return;
3266 3516
3267 warn "runtime file written.\n"; 3517 warn "runtime file written.\n";
3268 3518
3269 1 3519 1
3520}
3521
3522our $uuid_lock;
3523our $uuid_skip;
3524
3525sub write_uuid_sync($) {
3526 $uuid_skip ||= $_[0];
3527
3528 return if $uuid_lock;
3529 local $uuid_lock = 1;
3530
3531 my $uuid = "$LOCALDIR/uuid";
3532
3533 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3534 or return;
3535
3536 my $value = uuid_seq uuid_cur;
3537
3538 unless ($value) {
3539 warn "cowardly refusing to write zero uuid value!\n";
3540 return;
3541 }
3542
3543 my $value = uuid_str $value + $uuid_skip;
3544 $uuid_skip = 0;
3545
3546 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3547 and return;
3548
3549 # always fsync - this file is important
3550 aio_fsync $fh
3551 and return;
3552
3553 close $fh
3554 or return;
3555
3556 aio_rename "$uuid~", $uuid
3557 and return;
3558
3559 warn "uuid file written ($value).\n";
3560
3561 1
3562
3563}
3564
3565sub write_uuid($$) {
3566 my ($skip, $sync) = @_;
3567
3568 $sync ? write_uuid_sync $skip
3569 : async { write_uuid_sync $skip };
3270} 3570}
3271 3571
3272sub emergency_save() { 3572sub emergency_save() {
3273 my $freeze_guard = cf::freeze_mainloop; 3573 my $freeze_guard = cf::freeze_mainloop;
3274 3574
3275 warn "enter emergency perl save\n"; 3575 warn "emergency_perl_save: enter\n";
3276 3576
3277 cf::sync_job { 3577 cf::sync_job {
3578 # this is a trade-off: we want to be very quick here, so
3579 # save all maps without fsync, and later call a global sync
3580 # (which in turn might be very very slow)
3581 local $USE_FSYNC = 0;
3582
3278 # use a peculiar iteration method to avoid tripping on perl 3583 # use a peculiar iteration method to avoid tripping on perl
3279 # refcount bugs in for. also avoids problems with players 3584 # refcount bugs in for. also avoids problems with players
3280 # and maps saved/destroyed asynchronously. 3585 # and maps saved/destroyed asynchronously.
3281 warn "begin emergency player save\n"; 3586 warn "emergency_perl_save: begin player save\n";
3282 for my $login (keys %cf::PLAYER) { 3587 for my $login (keys %cf::PLAYER) {
3283 my $pl = $cf::PLAYER{$login} or next; 3588 my $pl = $cf::PLAYER{$login} or next;
3284 $pl->valid or next; 3589 $pl->valid or next;
3285 delete $pl->{unclean_save}; 3590 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3286 $pl->save; 3591 $pl->save;
3287 } 3592 }
3288 warn "end emergency player save\n"; 3593 warn "emergency_perl_save: end player save\n";
3289 3594
3290 warn "begin emergency map save\n"; 3595 warn "emergency_perl_save: begin map save\n";
3291 for my $path (keys %cf::MAP) { 3596 for my $path (keys %cf::MAP) {
3292 my $map = $cf::MAP{$path} or next; 3597 my $map = $cf::MAP{$path} or next;
3293 $map->valid or next; 3598 $map->valid or next;
3294 $map->save; 3599 $map->save;
3295 } 3600 }
3296 warn "end emergency map save\n"; 3601 warn "emergency_perl_save: end map save\n";
3297 3602
3298 warn "begin emergency database checkpoint\n"; 3603 warn "emergency_perl_save: begin database checkpoint\n";
3299 BDB::db_env_txn_checkpoint $DB_ENV; 3604 BDB::db_env_txn_checkpoint $DB_ENV;
3300 warn "end emergency database checkpoint\n"; 3605 warn "emergency_perl_save: end database checkpoint\n";
3606
3607 warn "emergency_perl_save: begin write uuid\n";
3608 write_uuid_sync 1;
3609 warn "emergency_perl_save: end write uuid\n";
3301 }; 3610 };
3302 3611
3612 warn "emergency_perl_save: starting sync()\n";
3613 IO::AIO::aio_sync sub {
3614 warn "emergency_perl_save: finished sync()\n";
3615 };
3616
3303 warn "leave emergency perl save\n"; 3617 warn "emergency_perl_save: leave\n";
3304} 3618}
3305 3619
3306sub post_cleanup { 3620sub post_cleanup {
3307 my ($make_core) = @_; 3621 my ($make_core) = @_;
3308 3622
3309 warn Carp::longmess "post_cleanup backtrace" 3623 warn Carp::longmess "post_cleanup backtrace"
3310 if $make_core; 3624 if $make_core;
3625
3626 my $fh = pidfile;
3627 unlink $PIDFILE if <$fh> == $$;
3628}
3629
3630# a safer delete_package, copied from Symbol
3631sub clear_package($) {
3632 my $pkg = shift;
3633
3634 # expand to full symbol table name if needed
3635 unless ($pkg =~ /^main::.*::$/) {
3636 $pkg = "main$pkg" if $pkg =~ /^::/;
3637 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3638 $pkg .= '::' unless $pkg =~ /::$/;
3639 }
3640
3641 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3642 my $stem_symtab = *{$stem}{HASH};
3643
3644 defined $stem_symtab and exists $stem_symtab->{$leaf}
3645 or return;
3646
3647 # clear all symbols
3648 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3649 for my $name (keys %$leaf_symtab) {
3650 _gv_clear *{"$pkg$name"};
3651# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3652 }
3653 warn "cleared package $pkg\n";#d#
3311} 3654}
3312 3655
3313sub do_reload_perl() { 3656sub do_reload_perl() {
3314 # can/must only be called in main 3657 # can/must only be called in main
3315 if ($Coro::current != $Coro::main) { 3658 if ($Coro::current != $Coro::main) {
3316 warn "can only reload from main coroutine"; 3659 warn "can only reload from main coroutine";
3317 return; 3660 return;
3318 } 3661 }
3319 3662
3663 return if $RELOAD++;
3664
3665 my $t1 = EV::time;
3666
3667 while ($RELOAD) {
3320 warn "reloading..."; 3668 warn "reloading...";
3321 3669
3322 warn "entering sync_job"; 3670 warn "entering sync_job";
3323 3671
3324 cf::sync_job { 3672 cf::sync_job {
3325 cf::write_runtime; # external watchdog should not bark 3673 cf::write_runtime_sync; # external watchdog should not bark
3326 cf::emergency_save; 3674 cf::emergency_save;
3327 cf::write_runtime; # external watchdog should not bark 3675 cf::write_runtime_sync; # external watchdog should not bark
3328 3676
3329 warn "syncing database to disk"; 3677 warn "syncing database to disk";
3330 BDB::db_env_txn_checkpoint $DB_ENV; 3678 BDB::db_env_txn_checkpoint $DB_ENV;
3331 3679
3332 # if anything goes wrong in here, we should simply crash as we already saved 3680 # if anything goes wrong in here, we should simply crash as we already saved
3333 3681
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"; 3682 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; 3683 while (IO::AIO::nreqs || BDB::nreqs) {
3345 warn "iterate..."; 3684 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 } 3685 }
3371 3686
3372 warn "... nuking $pkg"; 3687 warn "cancelling all extension coros";
3373 Symbol::delete_package $pkg; 3688 $_->cancel for values %EXT_CORO;
3374 } 3689 %EXT_CORO = ();
3375 3690
3376 warn "unloading all perl modules loaded from $LIBDIR"; 3691 warn "removing commands";
3377 while (my ($k, $v) = each %INC) { 3692 %COMMAND = ();
3378 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3379 3693
3694 warn "removing ext/exti commands";
3695 %EXTCMD = ();
3696 %EXTICMD = ();
3697
3698 warn "unloading/nuking all extensions";
3699 for my $pkg (@EXTS) {
3380 warn "... unloading $k"; 3700 warn "... unloading $pkg";
3381 delete $INC{$k};
3382 3701
3383 $k =~ s/\.pm$//;
3384 $k =~ s/\//::/g;
3385
3386 if (my $cb = $k->can ("unload_module")) { 3702 if (my $cb = $pkg->can ("unload")) {
3703 eval {
3387 $cb->(); 3704 $cb->($pkg);
3705 1
3706 } or warn "$pkg unloaded, but with errors: $@";
3707 }
3708
3709 warn "... clearing $pkg";
3710 clear_package $pkg;
3388 } 3711 }
3389 3712
3390 Symbol::delete_package $k; 3713 warn "unloading all perl modules loaded from $LIBDIR";
3714 while (my ($k, $v) = each %INC) {
3715 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3716
3717 warn "... unloading $k";
3718 delete $INC{$k};
3719
3720 $k =~ s/\.pm$//;
3721 $k =~ s/\//::/g;
3722
3723 if (my $cb = $k->can ("unload_module")) {
3724 $cb->();
3725 }
3726
3727 clear_package $k;
3391 } 3728 }
3392 3729
3393 warn "getting rid of safe::, as good as possible"; 3730 warn "getting rid of safe::, as good as possible";
3394 Symbol::delete_package "safe::$_" 3731 clear_package "safe::$_"
3395 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3732 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3396 3733
3397 warn "unloading cf.pm \"a bit\""; 3734 warn "unloading cf.pm \"a bit\"";
3398 delete $INC{"cf.pm"}; 3735 delete $INC{"cf.pm"};
3399 delete $INC{"cf/pod.pm"}; 3736 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3400 3737
3401 # don't, removes xs symbols, too, 3738 # don't, removes xs symbols, too,
3402 # and global variables created in xs 3739 # and global variables created in xs
3403 #Symbol::delete_package __PACKAGE__; 3740 #clear_package __PACKAGE__;
3404 3741
3405 warn "unload completed, starting to reload now"; 3742 warn "unload completed, starting to reload now";
3406 3743
3407 warn "reloading cf.pm"; 3744 warn "reloading cf.pm";
3408 require cf; 3745 require cf;
3409 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3746 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3410 3747
3411 warn "loading config and database again"; 3748 warn "loading config and database again";
3412 cf::reload_config; 3749 cf::reload_config;
3413 3750
3414 warn "loading extensions"; 3751 warn "loading extensions";
3415 cf::load_extensions; 3752 cf::load_extensions;
3416 3753
3754 if ($REATTACH_ON_RELOAD) {
3417 warn "reattaching attachments to objects/players"; 3755 warn "reattaching attachments to objects/players";
3418 _global_reattach; # objects, sockets 3756 _global_reattach; # objects, sockets
3419 warn "reattaching attachments to maps"; 3757 warn "reattaching attachments to maps";
3420 reattach $_ for values %MAP; 3758 reattach $_ for values %MAP;
3421 warn "reattaching attachments to players"; 3759 warn "reattaching attachments to players";
3422 reattach $_ for values %PLAYER; 3760 reattach $_ for values %PLAYER;
3761 }
3423 3762
3763 warn "running post_init jobs";
3764 (pop @POST_INIT)->(1) while @POST_INIT;
3765
3424 warn "leaving sync_job"; 3766 warn "leaving sync_job";
3425 3767
3426 1 3768 1
3427 } or do { 3769 } or do {
3428 warn $@; 3770 warn $@;
3429 warn "error while reloading, exiting."; 3771 cf::cleanup "error while reloading, exiting.";
3430 exit 1;
3431 }; 3772 };
3432 3773
3433 warn "reloaded"; 3774 warn "reloaded";
3775 --$RELOAD;
3776 }
3777
3778 $t1 = EV::time - $t1;
3779 warn "reload completed in ${t1}s\n";
3434}; 3780};
3435 3781
3436our $RELOAD_WATCHER; # used only during reload 3782our $RELOAD_WATCHER; # used only during reload
3437 3783
3438sub reload_perl() { 3784sub reload_perl() {
3439 # doing reload synchronously and two reloads happen back-to-back, 3785 # doing reload synchronously and two reloads happen back-to-back,
3440 # coro crashes during coro_state_free->destroy here. 3786 # coro crashes during coro_state_free->destroy here.
3441 3787
3442 $RELOAD_WATCHER ||= Event->timer ( 3788 $RELOAD_WATCHER ||= cf::async {
3443 reentrant => 0, 3789 Coro::AIO::aio_wait cache_extensions;
3444 after => 0, 3790
3445 data => WF_AUTOCANCEL, 3791 $RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub {
3446 cb => sub {
3447 do_reload_perl; 3792 do_reload_perl;
3448 undef $RELOAD_WATCHER; 3793 undef $RELOAD_WATCHER;
3449 }, 3794 };
3450 ); 3795 };
3451} 3796}
3452 3797
3453register_command "reload" => sub { 3798register_command "reload" => sub {
3454 my ($who, $arg) = @_; 3799 my ($who, $arg) = @_;
3455 3800
3468 3813
3469our @WAIT_FOR_TICK; 3814our @WAIT_FOR_TICK;
3470our @WAIT_FOR_TICK_BEGIN; 3815our @WAIT_FOR_TICK_BEGIN;
3471 3816
3472sub wait_for_tick { 3817sub wait_for_tick {
3473 return unless $TICK_WATCHER->is_active;
3474 return if $Coro::current == $Coro::main; 3818 return if tick_inhibit || $Coro::current == $Coro::main;
3475 3819
3476 my $signal = new Coro::Signal; 3820 my $signal = new Coro::Signal;
3477 push @WAIT_FOR_TICK, $signal; 3821 push @WAIT_FOR_TICK, $signal;
3478 $signal->wait; 3822 $signal->wait;
3479} 3823}
3480 3824
3481sub wait_for_tick_begin { 3825sub wait_for_tick_begin {
3482 return unless $TICK_WATCHER->is_active;
3483 return if $Coro::current == $Coro::main; 3826 return if tick_inhibit || $Coro::current == $Coro::main;
3484 3827
3485 my $signal = new Coro::Signal; 3828 my $signal = new Coro::Signal;
3486 push @WAIT_FOR_TICK_BEGIN, $signal; 3829 push @WAIT_FOR_TICK_BEGIN, $signal;
3487 $signal->wait; 3830 $signal->wait;
3488} 3831}
3489 3832
3490$TICK_WATCHER = Event->timer ( 3833sub 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) { 3834 if ($Coro::current != $Coro::main) {
3498 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3835 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3499 unless ++$bug_warning > 10; 3836 unless ++$bug_warning > 10;
3500 return; 3837 return;
3501 } 3838 }
3502 3839
3503 $NOW = $tick_start = Event::time;
3504
3505 cf::server_tick; # one server iteration 3840 cf::server_tick; # one server iteration
3506 3841
3507 $RUNTIME += $TICK;
3508 $NEXT_TICK += $TICK;
3509
3510 if ($NOW >= $NEXT_RUNTIME_WRITE) { 3842 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3511 $NEXT_RUNTIME_WRITE = $NOW + 10; 3843 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3512 Coro::async_pool { 3844 Coro::async_pool {
3513 $Coro::current->{desc} = "runtime saver"; 3845 $Coro::current->{desc} = "runtime saver";
3514 write_runtime 3846 write_runtime_sync
3515 or warn "ERROR: unable to write runtime file: $!"; 3847 or warn "ERROR: unable to write runtime file: $!";
3516 };
3517 } 3848 };
3849 }
3518 3850
3519 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3851 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3520 $sig->send; 3852 $sig->send;
3521 } 3853 }
3522 while (my $sig = shift @WAIT_FOR_TICK) { 3854 while (my $sig = shift @WAIT_FOR_TICK) {
3523 $sig->send; 3855 $sig->send;
3524 } 3856 }
3525 3857
3526 $NOW = Event::time; 3858 $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; 3859 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3536 3860
3537 _post_tick; 3861 if (0) {
3862 if ($NEXT_TICK) {
3863 my $jitter = $TICK_START - $NEXT_TICK;
3864 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3865 warn "jitter $JITTER\n";#d#
3866 }
3538 }, 3867 }
3539); 3868}
3540 3869
3541{ 3870{
3871 # configure BDB
3872
3542 BDB::min_parallel 8; 3873 BDB::min_parallel 8;
3543 BDB::max_poll_time $TICK * 0.1; 3874 BDB::max_poll_reqs $TICK * 0.1;
3544 $BDB_POLL_WATCHER = Event->io ( 3875 $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 3876
3568 unless ($DB_ENV) { 3877 unless ($DB_ENV) {
3569 $DB_ENV = BDB::db_env_create; 3878 $DB_ENV = BDB::db_env_create;
3570 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC 3879 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3571 | BDB::LOG_AUTOREMOVE, 1); 3880 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
3881 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
3572 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT); 3882 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3573 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT); 3883 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3574 3884
3575 cf::sync_job { 3885 cf::sync_job {
3576 eval { 3886 eval {
3586 3896
3587 cf::cleanup "db_env_open(db): $@" if $@; 3897 cf::cleanup "db_env_open(db): $@" if $@;
3588 }; 3898 };
3589 } 3899 }
3590 3900
3591 $BDB_DEADLOCK_WATCHER = Event->timer ( 3901 $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 { }; 3902 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3599 },
3600 ); 3903 };
3601 $BDB_CHECKPOINT_WATCHER = Event->timer ( 3904 $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 { }; 3905 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3609 },
3610 ); 3906 };
3611 $BDB_TRICKLE_WATCHER = Event->timer ( 3907 $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 { }; 3908 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3619 },
3620 ); 3909 };
3621} 3910}
3622 3911
3623{ 3912{
3913 # configure IO::AIO
3914
3624 IO::AIO::min_parallel 8; 3915 IO::AIO::min_parallel 8;
3625
3626 undef $Coro::AIO::WATCHER;
3627 IO::AIO::max_poll_time $TICK * 0.1; 3916 IO::AIO::max_poll_time $TICK * 0.1;
3628 $AIO_POLL_WATCHER = Event->io ( 3917 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} 3918}
3637 3919
3638my $_log_backtrace; 3920my $_log_backtrace;
3639 3921
3640sub _log_backtrace { 3922sub _log_backtrace {
3643 $msg =~ s/\n//; 3925 $msg =~ s/\n//;
3644 3926
3645 # limit the # of concurrent backtraces 3927 # limit the # of concurrent backtraces
3646 if ($_log_backtrace < 2) { 3928 if ($_log_backtrace < 2) {
3647 ++$_log_backtrace; 3929 ++$_log_backtrace;
3930 my $perl_bt = Carp::longmess $msg;
3648 async { 3931 async {
3649 $Coro::current->{desc} = "abt $msg"; 3932 $Coro::current->{desc} = "abt $msg";
3650 3933
3651 my @bt = fork_call { 3934 my @bt = fork_call {
3652 @addr = map { sprintf "%x", $_ } @addr; 3935 @addr = map { sprintf "%x", $_ } @addr;
3663 } 3946 }
3664 3947
3665 @funcs 3948 @funcs
3666 }; 3949 };
3667 3950
3668 LOG llevInfo, "[ABT] $msg\n"; 3951 LOG llevInfo, "[ABT] $perl_bt\n";
3952 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
3669 LOG llevInfo, "[ABT] $_\n" for @bt; 3953 LOG llevInfo, "[ABT] $_\n" for @bt;
3670 --$_log_backtrace; 3954 --$_log_backtrace;
3671 }; 3955 };
3672 } else { 3956 } else {
3673 LOG llevInfo, "[ABT] $msg\n"; 3957 LOG llevInfo, "[ABT] $msg\n";
3674 LOG llevInfo, "[ABT] [suppressed]\n"; 3958 LOG llevInfo, "[ABT] [suppressed]\n";
3675 } 3959 }
3676} 3960}
3677 3961
3678# load additional modules 3962# load additional modules
3679use cf::pod; 3963require "cf/$_.pm" for @EXTRA_MODULES;
3680 3964
3681END { cf::emergency_save } 3965END { cf::emergency_save }
3682 3966
36831 39671
3684 3968

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines