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.387 by root, Mon Oct 15 23:49:10 2007 UTC vs.
Revision 1.529 by root, Wed Apr 28 11:28:22 2010 UTC

1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3#
4# Copyright (©) 2006,2007,2008,2009,2010 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5#
6# Deliantra is free software: you can redistribute it and/or modify it under
7# the terms of the Affero GNU General Public License as published by the
8# Free Software Foundation, either version 3 of the License, or (at your
9# 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 Affero GNU General Public License
17# and the GNU General Public License along with this program. If not, see
18# <http://www.gnu.org/licenses/>.
19#
20# The authors can be reached via e-mail to <support@deliantra.net>
21#
22
1package cf; 23package cf;
2 24
25use 5.10.0;
3use utf8; 26use utf8;
4use strict; 27use strict qw(vars subs);
5 28
6use Symbol; 29use Symbol;
7use List::Util; 30use List::Util;
8use Socket; 31use Socket;
9use Event; 32use EV;
10use Opcode; 33use Opcode;
11use Safe; 34use Safe;
12use Safe::Hole; 35use Safe::Hole;
13use Storable (); 36use Storable ();
37use Carp ();
14 38
39use Guard ();
15use Coro 4.1 (); 40use Coro ();
16use Coro::State; 41use Coro::State;
17use Coro::Handle; 42use Coro::Handle;
43use Coro::EV;
18use Coro::Event; 44use Coro::AnyEvent;
19use Coro::Timer; 45use Coro::Timer;
20use Coro::Signal; 46use Coro::Signal;
21use Coro::Semaphore; 47use Coro::Semaphore;
48use Coro::SemaphoreSet;
49use Coro::AnyEvent;
22use Coro::AIO; 50use Coro::AIO;
51use Coro::BDB 1.6;
23use Coro::Storable; 52use Coro::Storable;
24use Coro::Util (); 53use Coro::Util ();
25 54
26use JSON::XS (); 55use JSON::XS 2.01 ();
27use BDB (); 56use BDB ();
28use Data::Dumper; 57use Data::Dumper;
29use Digest::MD5;
30use Fcntl; 58use Fcntl;
31use YAML::Syck (); 59use YAML::XS ();
32use IO::AIO 2.51 (); 60use IO::AIO ();
33use Time::HiRes; 61use Time::HiRes;
34use Compress::LZF; 62use Compress::LZF;
35use Digest::MD5 (); 63use Digest::MD5 ();
64
65AnyEvent::detect;
36 66
37# configure various modules to our taste 67# configure various modules to our taste
38# 68#
39$Storable::canonical = 1; # reduce rsync transfers 69$Storable::canonical = 1; # reduce rsync transfers
40Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 70Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
71
72$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
73
74# make sure c-lzf reinitialises itself
75Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";
41Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 76Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
42 77
43$Event::Eval = 1; # no idea why this is required, but it is 78# strictly for debugging
44 79$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 80
50sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 81sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
51 82
52our %COMMAND = (); 83our %COMMAND = ();
53our %COMMAND_TIME = (); 84our %COMMAND_TIME = ();
… …
56our %EXTCMD = (); 87our %EXTCMD = ();
57our %EXTICMD = (); 88our %EXTICMD = ();
58our %EXT_CORO = (); # coroutines bound to extensions 89our %EXT_CORO = (); # coroutines bound to extensions
59our %EXT_MAP = (); # pluggable maps 90our %EXT_MAP = (); # pluggable maps
60 91
61our $RELOAD; # number of reloads so far 92our $RELOAD; # number of reloads so far, non-zero while in reload
62our @EVENT; 93our @EVENT;
94our @REFLECT; # set by XS
95our %REFLECT; # set by us
63 96
64our $CONFDIR = confdir; 97our $CONFDIR = confdir;
65our $DATADIR = datadir; 98our $DATADIR = datadir;
66our $LIBDIR = "$DATADIR/ext"; 99our $LIBDIR = "$DATADIR/ext";
67our $PODDIR = "$DATADIR/pod"; 100our $PODDIR = "$DATADIR/pod";
68our $MAPDIR = "$DATADIR/" . mapdir; 101our $MAPDIR = "$DATADIR/" . mapdir;
69our $LOCALDIR = localdir; 102our $LOCALDIR = localdir;
70our $TMPDIR = "$LOCALDIR/" . tmpdir; 103our $TMPDIR = "$LOCALDIR/" . tmpdir;
71our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 104our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
72our $PLAYERDIR = "$LOCALDIR/" . playerdir; 105our $PLAYERDIR = "$LOCALDIR/" . playerdir;
73our $RANDOMDIR = "$LOCALDIR/random"; 106our $RANDOMDIR = "$LOCALDIR/random";
74our $BDBDIR = "$LOCALDIR/db"; 107our $BDBDIR = "$LOCALDIR/db";
108our $PIDFILE = "$LOCALDIR/pid";
109our $RUNTIMEFILE = "$LOCALDIR/runtime";
110
111our %RESOURCE;
112
113our $OUTPUT_RATE_MIN = 3000;
114our $OUTPUT_RATE_MAX = 1000000;
115
116our $MAX_LINKS = 32; # how many chained exits to follow
117our $VERBOSE_IO = 1;
75 118
76our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 119our $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 120our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
80our $NEXT_TICK; 121our $NEXT_TICK;
81our $NOW;
82our $USE_FSYNC = 1; # use fsync to write maps - default off 122our $USE_FSYNC = 1; # use fsync to write maps - default on
83 123
84our $BDB_POLL_WATCHER;
85our $BDB_DEADLOCK_WATCHER; 124our $BDB_DEADLOCK_WATCHER;
86our $BDB_CHECKPOINT_WATCHER; 125our $BDB_CHECKPOINT_WATCHER;
87our $BDB_TRICKLE_WATCHER; 126our $BDB_TRICKLE_WATCHER;
88our $DB_ENV; 127our $DB_ENV;
89 128
129our @EXTRA_MODULES = qw(pod match mapscript);
130
90our %CFG; 131our %CFG;
91 132
92our $UPTIME; $UPTIME ||= time; 133our $UPTIME; $UPTIME ||= time;
93our $RUNTIME; 134our $RUNTIME;
135our $NOW;
94 136
95our (%PLAYER, %PLAYER_LOADING); # all users 137our (%PLAYER, %PLAYER_LOADING); # all users
96our (%MAP, %MAP_LOADING ); # all maps 138our (%MAP, %MAP_LOADING ); # all maps
97our $LINK_MAP; # the special {link} map, which is always available 139our $LINK_MAP; # the special {link} map, which is always available
98 140
99# used to convert map paths into valid unix filenames by replacing / by ∕ 141# used to convert map paths into valid unix filenames by replacing / by ∕
100our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 142our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
101 143
102our $LOAD; # a number between 0 (idle) and 1 (too many objects) 144our $LOAD; # a number between 0 (idle) and 1 (too many objects)
103our $LOADAVG; # same thing, but with alpha-smoothing 145our $LOADAVG; # same thing, but with alpha-smoothing
146our $JITTER; # average jitter
104our $tick_start; # for load detecting purposes 147our $TICK_START; # for load detecting purposes
148
149our @POST_INIT;
150
151our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
152our $REALLY_UNLOOP; # never set to true, please :)
105 153
106binmode STDOUT; 154binmode STDOUT;
107binmode STDERR; 155binmode STDERR;
108 156
109# read virtual server time, if available 157# read virtual server time, if available
110unless ($RUNTIME || !-e "$LOCALDIR/runtime") { 158unless ($RUNTIME || !-e $RUNTIMEFILE) {
111 open my $fh, "<", "$LOCALDIR/runtime" 159 open my $fh, "<", $RUNTIMEFILE
112 or die "unable to read runtime file: $!"; 160 or die "unable to read $RUNTIMEFILE file: $!";
113 $RUNTIME = <$fh> + 0.; 161 $RUNTIME = <$fh> + 0.;
114} 162}
163
164eval "sub TICK() { $TICK } 1" or die;
115 165
116mkdir $_ 166mkdir $_
117 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR; 167 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
118 168
119our $EMERGENCY_POSITION; 169our $EMERGENCY_POSITION;
120 170
121sub cf::map::normalise; 171sub cf::map::normalise;
172
173sub in_main() {
174 $Coro::current == $Coro::main
175}
176
177#############################################################################
178
179%REFLECT = ();
180for (@REFLECT) {
181 my $reflect = JSON::XS::decode_json $_;
182 $REFLECT{$reflect->{class}} = $reflect;
183}
184
185# this is decidedly evil
186$REFLECT{object}{flags} = { map +($_ => undef), grep $_, map /^FLAG_([A-Z0-9_]+)$/ && lc $1, keys %{"cf::"} };
122 187
123############################################################################# 188#############################################################################
124 189
125=head2 GLOBAL VARIABLES 190=head2 GLOBAL VARIABLES
126 191
… …
162 227
163The raw value load value from the last tick. 228The raw value load value from the last tick.
164 229
165=item %cf::CFG 230=item %cf::CFG
166 231
167Configuration for the server, loaded from C</etc/crossfire/config>, or 232Configuration for the server, loaded from C</etc/deliantra-server/config>, or
168from wherever your confdir points to. 233from wherever your confdir points to.
169 234
170=item cf::wait_for_tick, cf::wait_for_tick_begin 235=item cf::wait_for_tick, cf::wait_for_tick_begin
171 236
172These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 237These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
173returns directly I<after> the tick processing (and consequently, can only wake one process 238returns directly I<after> the tick processing (and consequently, can only wake one process
174per tick), while cf::wait_for_tick wakes up all waiters after tick processing. 239per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
175 240
176=item @cf::INVOKE_RESULTS 241=item @cf::INVOKE_RESULTS
177 242
178This array contains the results of the last C<invoke ()> call. When 243This array contains the results of the last C<invoke ()> call. When
179C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of 244C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
180that call. 245that call.
181 246
247=item %cf::REFLECT
248
249Contains, for each (C++) class name, a hash reference with information
250about object members (methods, scalars, arrays and flags) and other
251metadata, which is useful for introspection.
252
182=back 253=back
183 254
184=cut 255=cut
185 256
186BEGIN { 257$Coro::State::WARNHOOK = sub {
187 *CORE::GLOBAL::warn = sub {
188 my $msg = join "", @_; 258 my $msg = join "", @_;
189 259
190 $msg .= "\n" 260 $msg .= "\n"
191 unless $msg =~ /\n$/; 261 unless $msg =~ /\n$/;
192 262
193 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 263 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
194 264
195 LOG llevError, $msg; 265 LOG llevError, $msg;
196 }; 266};
197} 267
268$Coro::State::DIEHOOK = sub {
269 return unless $^S eq 0; # "eq", not "=="
270
271 warn Carp::longmess $_[0];
272
273 if (in_main) {#d#
274 warn "DIEHOOK called in main context, Coro bug?\n";#d#
275 return;#d#
276 }#d#
277
278 # kill coroutine otherwise
279 Coro::terminate
280};
198 281
199@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 282@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
200@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 283@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
201@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 284@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
202@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 285@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
… …
209for my $pkg (qw( 292for my $pkg (qw(
210 cf::global cf::attachable 293 cf::global cf::attachable
211 cf::object cf::object::player 294 cf::object cf::object::player
212 cf::client cf::player 295 cf::client cf::player
213 cf::arch cf::living 296 cf::arch cf::living
297 cf::map cf::mapspace
214 cf::map cf::party cf::region 298 cf::party cf::region
215)) { 299)) {
216 no strict 'refs';
217 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 300 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
218} 301}
219 302
220$Event::DIED = sub { 303$EV::DIED = sub {
221 warn "error in event callback: @_"; 304 Carp::cluck "error in event callback: @_";
222}; 305};
223 306
224############################################################################# 307#############################################################################
225 308
226=head2 UTILITY FUNCTIONS 309=head2 UTILITY FUNCTIONS
… …
248 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 331 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
249 $d 332 $d
250 } || "[unable to dump $_[0]: '$@']"; 333 } || "[unable to dump $_[0]: '$@']";
251} 334}
252 335
253=item $ref = cf::from_json $json 336=item $ref = cf::decode_json $json
254 337
255Converts a JSON string into the corresponding perl data structure. 338Converts a JSON string into the corresponding perl data structure.
256 339
257=item $json = cf::to_json $ref 340=item $json = cf::encode_json $ref
258 341
259Converts a perl data structure into its JSON representation. 342Converts a perl data structure into its JSON representation.
260 343
261=cut 344=cut
262 345
263our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max 346our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
264 347
265sub to_json ($) { $json_coder->encode ($_[0]) } 348sub encode_json($) { $json_coder->encode ($_[0]) }
266sub from_json ($) { $json_coder->decode ($_[0]) } 349sub decode_json($) { $json_coder->decode ($_[0]) }
350
351=item cf::post_init { BLOCK }
352
353Execute the given codeblock, I<after> all extensions have been (re-)loaded,
354but I<before> the server starts ticking again.
355
356The cdoeblock will have a single boolean argument to indicate whether this
357is a reload or not.
358
359=cut
360
361sub post_init(&) {
362 push @POST_INIT, shift;
363}
267 364
268=item cf::lock_wait $string 365=item cf::lock_wait $string
269 366
270Wait until the given lock is available. See cf::lock_acquire. 367Wait until the given lock is available. See cf::lock_acquire.
271 368
272=item my $lock = cf::lock_acquire $string 369=item my $lock = cf::lock_acquire $string
273 370
274Wait until the given lock is available and then acquires it and returns 371Wait 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, 372a L<Guard> object. If the guard object gets destroyed (goes out of scope,
276for example when the coroutine gets canceled), the lock is automatically 373for example when the coroutine gets canceled), the lock is automatically
277returned. 374returned.
278 375
279Locks are *not* recursive, locking from the same coro twice results in a 376Locks are *not* recursive, locking from the same coro twice results in a
280deadlocked coro. 377deadlocked coro.
… …
286 383
287Return true if the lock is currently active, i.e. somebody has locked it. 384Return true if the lock is currently active, i.e. somebody has locked it.
288 385
289=cut 386=cut
290 387
291our %LOCK; 388our $LOCKS = new Coro::SemaphoreSet;
292our %LOCKER;#d#
293 389
294sub lock_wait($) { 390sub lock_wait($) {
295 my ($key) = @_; 391 $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} 392}
308 393
309sub lock_acquire($) { 394sub lock_acquire($) {
310 my ($key) = @_; 395 $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} 396}
324 397
325sub lock_active($) { 398sub lock_active($) {
326 my ($key) = @_; 399 $LOCKS->count ($_[0]) < 1
327
328 ! ! $LOCK{$key}
329} 400}
330 401
331sub freeze_mainloop { 402sub freeze_mainloop {
332 return unless $TICK_WATCHER->is_active; 403 tick_inhibit_inc;
333 404
334 my $guard = Coro::guard { 405 &Guard::guard (\&tick_inhibit_dec);
335 $TICK_WATCHER->start; 406}
336 }; 407
337 $TICK_WATCHER->stop; 408=item cf::periodic $interval, $cb
338 $guard 409
410Like EV::periodic, but randomly selects a starting point so that the actions
411get spread over time.
412
413=cut
414
415sub periodic($$) {
416 my ($interval, $cb) = @_;
417
418 my $start = rand List::Util::min 180, $interval;
419
420 EV::periodic $start, $interval, 0, $cb
339} 421}
340 422
341=item cf::get_slot $time[, $priority[, $name]] 423=item cf::get_slot $time[, $priority[, $name]]
342 424
343Allocate $time seconds of blocking CPU time at priority C<$priority>: 425Allocate $time seconds of blocking CPU time at priority C<$priority>:
… …
351 433
352=cut 434=cut
353 435
354our @SLOT_QUEUE; 436our @SLOT_QUEUE;
355our $SLOT_QUEUE; 437our $SLOT_QUEUE;
438our $SLOT_DECAY = 0.9;
356 439
357$SLOT_QUEUE->cancel if $SLOT_QUEUE; 440$SLOT_QUEUE->cancel if $SLOT_QUEUE;
358$SLOT_QUEUE = Coro::async { 441$SLOT_QUEUE = Coro::async {
359 $Coro::current->desc ("timeslot manager"); 442 $Coro::current->desc ("timeslot manager");
360 443
361 my $signal = new Coro::Signal; 444 my $signal = new Coro::Signal;
445 my $busy;
362 446
363 while () { 447 while () {
364 next_job: 448 next_job:
449
365 my $avail = cf::till_tick; 450 my $avail = cf::till_tick;
366 if ($avail > 0.01) { 451
367 for (0 .. $#SLOT_QUEUE) { 452 for (0 .. $#SLOT_QUEUE) {
368 if ($SLOT_QUEUE[$_][0] < $avail) { 453 if ($SLOT_QUEUE[$_][0] <= $avail) {
454 $busy = 0;
369 my $job = splice @SLOT_QUEUE, $_, 1, (); 455 my $job = splice @SLOT_QUEUE, $_, 1, ();
370 $job->[2]->send; 456 $job->[2]->send;
371 Coro::cede; 457 Coro::cede;
372 goto next_job; 458 goto next_job;
373 } 459 } else {
460 $SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
374 } 461 }
375 } 462 }
376 463
377 if (@SLOT_QUEUE) { 464 if (@SLOT_QUEUE) {
378 # we do not use wait_for_tick() as it returns immediately when tick is inactive 465 # we do not use wait_for_tick() as it returns immediately when tick is inactive
379 push @cf::WAIT_FOR_TICK, $signal; 466 push @cf::WAIT_FOR_TICK, $signal;
380 $signal->wait; 467 $signal->wait;
381 } else { 468 } else {
469 $busy = 0;
382 Coro::schedule; 470 Coro::schedule;
383 } 471 }
384 } 472 }
385}; 473};
386 474
387sub get_slot($;$$) { 475sub get_slot($;$$) {
476 return if tick_inhibit || $Coro::current == $Coro::main;
477
388 my ($time, $pri, $name) = @_; 478 my ($time, $pri, $name) = @_;
389 479
390 $time = $TICK * .6 if $time > $TICK * .6; 480 $time = clamp $time, 0.01, $TICK * .6;
481
391 my $sig = new Coro::Signal; 482 my $sig = new Coro::Signal;
392 483
393 push @SLOT_QUEUE, [$time, $pri, $sig, $name]; 484 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
394 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE; 485 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
395 $SLOT_QUEUE->ready; 486 $SLOT_QUEUE->ready;
… …
406 497
407BEGIN { *async = \&Coro::async_pool } 498BEGIN { *async = \&Coro::async_pool }
408 499
409=item cf::sync_job { BLOCK } 500=item cf::sync_job { BLOCK }
410 501
411The design of Crossfire TRT requires that the main coroutine ($Coro::main) 502The design of Deliantra requires that the main coroutine ($Coro::main)
412is always able to handle events or runnable, as Crossfire TRT is only 503is 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 504partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
414acceptable. 505acceptable.
415 506
416If it must be done, put the blocking parts into C<sync_job>. This will run 507If 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 508the given BLOCK in another coroutine while waiting for the result. The
… …
422 513
423sub sync_job(&) { 514sub sync_job(&) {
424 my ($job) = @_; 515 my ($job) = @_;
425 516
426 if ($Coro::current == $Coro::main) { 517 if ($Coro::current == $Coro::main) {
427 my $time = Event::time; 518 my $time = AE::time;
428 519
429 # this is the main coro, too bad, we have to block 520 # this is the main coro, too bad, we have to block
430 # till the operation succeeds, freezing the server :/ 521 # till the operation succeeds, freezing the server :/
431 522
432 LOG llevError, Carp::longmess "sync job";#d# 523 LOG llevError, Carp::longmess "sync job";#d#
433 524
434 # TODO: use suspend/resume instead
435 # (but this is cancel-safe)
436 my $freeze_guard = freeze_mainloop; 525 my $freeze_guard = freeze_mainloop;
437 526
438 my $busy = 1; 527 my $busy = 1;
439 my @res; 528 my @res;
440 529
… …
447 536
448 while ($busy) { 537 while ($busy) {
449 if (Coro::nready) { 538 if (Coro::nready) {
450 Coro::cede_notself; 539 Coro::cede_notself;
451 } else { 540 } else {
452 Event::one_event; 541 EV::loop EV::LOOP_ONESHOT;
453 } 542 }
454 } 543 }
455 544
456 $time = Event::time - $time; 545 my $time = AE::time - $time;
457 546
458 LOG llevError | logBacktrace, Carp::longmess "long sync job"
459 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
460
461 $tick_start += $time; # do not account sync jobs to server load 547 $TICK_START += $time; # do not account sync jobs to server load
462 548
463 wantarray ? @res : $res[0] 549 wantarray ? @res : $res[0]
464 } else { 550 } else {
465 # we are in another coroutine, how wonderful, everything just works 551 # we are in another coroutine, how wonderful, everything just works
466 552
… …
491=item fork_call { }, $args 577=item fork_call { }, $args
492 578
493Executes the given code block with the given arguments in a seperate 579Executes the given code block with the given arguments in a seperate
494process, returning the results. Everything must be serialisable with 580process, returning the results. Everything must be serialisable with
495Coro::Storable. May, of course, block. Note that the executed sub may 581Coro::Storable. May, of course, block. Note that the executed sub may
496never block itself or use any form of Event handling. 582never block itself or use any form of event handling.
497 583
498=cut 584=cut
499 585
500sub fork_call(&@) { 586sub fork_call(&@) {
501 my ($cb, @args) = @_; 587 my ($cb, @args) = @_;
… …
508 reset_signals; 594 reset_signals;
509 &$cb 595 &$cb
510 }, @args; 596 }, @args;
511 597
512 wantarray ? @res : $res[-1] 598 wantarray ? @res : $res[-1]
599}
600
601sub objinfo {
602 (
603 "counter value" => cf::object::object_count,
604 "objects created" => cf::object::create_count,
605 "objects destroyed" => cf::object::destroy_count,
606 "freelist size" => cf::object::free_count,
607 "allocated objects" => cf::object::objects_size,
608 "active objects" => cf::object::actives_size,
609 )
610}
611
612=item $coin = coin_from_name $name
613
614=cut
615
616our %coin_alias = (
617 "silver" => "silvercoin",
618 "silvercoin" => "silvercoin",
619 "silvercoins" => "silvercoin",
620 "gold" => "goldcoin",
621 "goldcoin" => "goldcoin",
622 "goldcoins" => "goldcoin",
623 "platinum" => "platinacoin",
624 "platinumcoin" => "platinacoin",
625 "platinumcoins" => "platinacoin",
626 "platina" => "platinacoin",
627 "platinacoin" => "platinacoin",
628 "platinacoins" => "platinacoin",
629 "royalty" => "royalty",
630 "royalties" => "royalty",
631);
632
633sub coin_from_name($) {
634 $coin_alias{$_[0]}
635 ? cf::arch::find $coin_alias{$_[0]}
636 : undef
513} 637}
514 638
515=item $value = cf::db_get $family => $key 639=item $value = cf::db_get $family => $key
516 640
517Returns a single value from the environment database. 641Returns a single value from the environment database.
… …
656 780
657############################################################################# 781#############################################################################
658 782
659=head2 ATTACHABLE OBJECTS 783=head2 ATTACHABLE OBJECTS
660 784
661Many objects in crossfire are so-called attachable objects. That means you can 785Many objects in deliantra are so-called attachable objects. That means you can
662attach callbacks/event handlers (a collection of which is called an "attachment") 786attach callbacks/event handlers (a collection of which is called an "attachment")
663to it. All such attachable objects support the following methods. 787to it. All such attachable objects support the following methods.
664 788
665In the following description, CLASS can be any of C<global>, C<object> 789In the following description, CLASS can be any of C<global>, C<object>
666C<player>, C<client> or C<map> (i.e. the attachable objects in 790C<player>, C<client> or C<map> (i.e. the attachable objects in
667Crossfire TRT). 791Deliantra).
668 792
669=over 4 793=over 4
670 794
671=item $attachable->attach ($attachment, key => $value...) 795=item $attachable->attach ($attachment, key => $value...)
672 796
… …
716=item cf::CLASS::attachment $name, ... 840=item cf::CLASS::attachment $name, ...
717 841
718Register an attachment by C<$name> through which attachable objects of the 842Register an attachment by C<$name> through which attachable objects of the
719given CLASS can refer to this attachment. 843given CLASS can refer to this attachment.
720 844
721Some classes such as crossfire maps and objects can specify attachments 845Some classes such as deliantra maps and objects can specify attachments
722that are attached at load/instantiate time, thus the need for a name. 846that are attached at load/instantiate time, thus the need for a name.
723 847
724These calls expect any number of the following handler/hook descriptions: 848These calls expect any number of the following handler/hook descriptions:
725 849
726=over 4 850=over 4
… …
954 } 1078 }
955 1079
956 0 1080 0
957} 1081}
958 1082
959=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 1083=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
960 1084
961=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 1085=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
962 1086
963Generate an object-specific event with the given arguments. 1087Generate an object-specific event with the given arguments.
964 1088
… …
1017 1141
1018sub reattach { 1142sub reattach {
1019 # basically do the same as instantiate, without calling instantiate 1143 # basically do the same as instantiate, without calling instantiate
1020 my ($obj) = @_; 1144 my ($obj) = @_;
1021 1145
1146 # no longer needed after getting rid of delete_package?
1022 bless $obj, ref $obj; # re-bless in case extensions have been reloaded 1147 #bless $obj, ref $obj; # re-bless in case extensions have been reloaded
1023 1148
1024 my $registry = $obj->registry; 1149 my $registry = $obj->registry;
1025 1150
1026 @$registry = (); 1151 @$registry = ();
1027 1152
… …
1042cf::attachable->attach ( 1167cf::attachable->attach (
1043 prio => -1000000, 1168 prio => -1000000,
1044 on_instantiate => sub { 1169 on_instantiate => sub {
1045 my ($obj, $data) = @_; 1170 my ($obj, $data) = @_;
1046 1171
1047 $data = from_json $data; 1172 $data = decode_json $data;
1048 1173
1049 for (@$data) { 1174 for (@$data) {
1050 my ($name, $args) = @$_; 1175 my ($name, $args) = @$_;
1051 1176
1052 $obj->attach ($name, %{$args || {} }); 1177 $obj->attach ($name, %{$args || {} });
… …
1070 1195
1071 sync_job { 1196 sync_job {
1072 if (length $$rdata) { 1197 if (length $$rdata) {
1073 utf8::decode (my $decname = $filename); 1198 utf8::decode (my $decname = $filename);
1074 warn sprintf "saving %s (%d,%d)\n", 1199 warn sprintf "saving %s (%d,%d)\n",
1075 $decname, length $$rdata, scalar @$objs; 1200 $decname, length $$rdata, scalar @$objs
1201 if $VERBOSE_IO;
1076 1202
1077 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1203 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1078 chmod SAVE_MODE, $fh; 1204 aio_chmod $fh, SAVE_MODE;
1079 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1205 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1080 aio_fsync $fh if $cf::USE_FSYNC; 1206 if ($cf::USE_FSYNC) {
1207 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;
1208 aio_fsync $fh;
1209 }
1081 close $fh; 1210 aio_close $fh;
1082 1211
1083 if (@$objs) { 1212 if (@$objs) {
1084 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1213 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1085 chmod SAVE_MODE, $fh; 1214 aio_chmod $fh, SAVE_MODE;
1086 my $data = Coro::Storable::blocking_nfreeze { version => 1, objs => $objs }; 1215 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1087 aio_write $fh, 0, (length $data), $data, 0; 1216 aio_write $fh, 0, (length $data), $data, 0;
1088 aio_fsync $fh if $cf::USE_FSYNC; 1217 if ($cf::USE_FSYNC) {
1218 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;
1219 aio_fsync $fh;
1220 }
1089 close $fh; 1221 aio_close $fh;
1090 aio_rename "$filename.pst~", "$filename.pst"; 1222 aio_rename "$filename.pst~", "$filename.pst";
1091 } 1223 }
1092 } else { 1224 } else {
1093 aio_unlink "$filename.pst"; 1225 aio_unlink "$filename.pst";
1094 } 1226 }
1095 1227
1096 aio_rename "$filename~", $filename; 1228 aio_rename "$filename~", $filename;
1229
1230 $filename =~ s%/[^/]+$%%;
1231 aio_pathsync $filename if $cf::USE_FSYNC;
1097 } else { 1232 } else {
1098 warn "FATAL: $filename~: $!\n"; 1233 warn "unable to save objects: $filename~: $!\n";
1099 } 1234 }
1100 } else { 1235 } else {
1101 aio_unlink $filename; 1236 aio_unlink $filename;
1102 aio_unlink "$filename.pst"; 1237 aio_unlink "$filename.pst";
1103 } 1238 }
… …
1122 1257
1123 unless (aio_stat "$filename.pst") { 1258 unless (aio_stat "$filename.pst") {
1124 (aio_load "$filename.pst", $av) >= 0 1259 (aio_load "$filename.pst", $av) >= 0
1125 or return; 1260 or return;
1126 1261
1127 my $st = eval { Coro::Storable::thaw $av } 1262 my $st = eval { Coro::Storable::thaw $av };
1128 || eval { my $guard = Coro::Storable::guard; Storable::thaw $av }; #d# compatibility, remove
1129 $av = $st->{objs}; 1263 $av = $st->{objs};
1130 } 1264 }
1131 1265
1132 utf8::decode (my $decname = $filename); 1266 utf8::decode (my $decname = $filename);
1133 warn sprintf "loading %s (%d,%d)\n", 1267 warn sprintf "loading %s (%d,%d)\n",
1134 $decname, length $data, scalar @{$av || []}; 1268 $decname, length $data, scalar @{$av || []}
1269 if $VERBOSE_IO;
1135 1270
1136 ($data, $av) 1271 ($data, $av)
1137} 1272}
1138 1273
1139=head2 COMMAND CALLBACKS 1274=head2 COMMAND CALLBACKS
… …
1195 my ($name, $cb) = @_; 1330 my ($name, $cb) = @_;
1196 1331
1197 $EXTICMD{$name} = $cb; 1332 $EXTICMD{$name} = $cb;
1198} 1333}
1199 1334
1335use File::Glob ();
1336
1200cf::player->attach ( 1337cf::player->attach (
1201 on_command => sub { 1338 on_unknown_command => sub {
1202 my ($pl, $name, $params) = @_; 1339 my ($pl, $name, $params) = @_;
1203 1340
1204 my $cb = $COMMAND{$name} 1341 my $cb = $COMMAND{$name}
1205 or return; 1342 or return;
1206 1343
… …
1236 1373
1237 cf::override; 1374 cf::override;
1238 }, 1375 },
1239); 1376);
1240 1377
1378# "readahead" all extensions
1379sub cache_extensions {
1380 my $grp = IO::AIO::aio_group;
1381
1382 add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
1383 for (grep /\.ext$/, @{$_[0]}) {
1384 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
1385 }
1386 };
1387
1388 $grp
1389}
1390
1241sub load_extensions { 1391sub load_extensions {
1242 cf::sync_job { 1392 cf::sync_job {
1243 my %todo; 1393 my %todo;
1244 1394
1245 for my $path (<$LIBDIR/*.ext>) { 1395 for my $path (<$LIBDIR/*.ext>) {
… …
1264 1414
1265 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 } 1415 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1266 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; 1416 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1267 1417
1268 $ext{source} = 1418 $ext{source} =
1269 "package $pkg; use strict; use utf8;\n" 1419 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n"
1270 . "#line 1 \"$path\"\n{\n" 1420 . "#line 1 \"$path\"\n{\n"
1271 . $source 1421 . $source
1272 . "\n};\n1"; 1422 . "\n};\n1";
1273 1423
1274 $todo{$base} = \%ext; 1424 $todo{$base} = \%ext;
1275 } 1425 }
1276 1426
1427 my $pass = 0;
1277 my %done; 1428 my %done;
1278 while (%todo) { 1429 while (%todo) {
1279 my $progress; 1430 my $progress;
1280 1431
1432 ++$pass;
1433
1434 ext:
1281 while (my ($k, $v) = each %todo) { 1435 while (my ($k, $v) = each %todo) {
1282 for (split /,\s*/, $v->{meta}{depends}) { 1436 for (split /,\s*/, $v->{meta}{depends}) {
1283 goto skip 1437 next ext
1284 unless exists $done{$_}; 1438 unless exists $done{$_};
1285 } 1439 }
1286 1440
1287 warn "... loading '$k' into '$v->{pkg}'\n"; 1441 warn "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1288 1442
1289 unless (eval $v->{source}) { 1443 my $active = eval $v->{source};
1444
1445 if (length $@) {
1290 my $msg = $@ ? "$v->{path}: $@\n" 1446 warn "$v->{path}: $@\n";
1291 : "$v->{base}: extension inactive.\n";
1292 1447
1448 cf::cleanup "mandatory extension '$k' failed to load, exiting."
1293 if (exists $v->{meta}{mandatory}) { 1449 if exists $v->{meta}{mandatory};
1294 warn $msg; 1450
1295 warn "mandatory extension failed to load, exiting.\n"; 1451 warn "$v->{base}: optional extension cannot be loaded, skipping.\n";
1296 exit 1; 1452 delete $todo{$k};
1297 } 1453 } else {
1298 1454 $done{$k} = delete $todo{$k};
1299 warn $msg; 1455 push @EXTS, $v->{pkg};
1456 $progress = 1;
1457
1458 warn "$v->{base}: extension inactive.\n"
1459 unless $active;
1300 } 1460 }
1301
1302 $done{$k} = delete $todo{$k};
1303 push @EXTS, $v->{pkg};
1304 $progress = 1;
1305 } 1461 }
1306 1462
1307 skip: 1463 unless ($progress) {
1308 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n" 1464 warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
1309 unless $progress; 1465
1466 while (my ($k, $v) = each %todo) {
1467 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
1468 if exists $v->{meta}{mandatory};
1469 }
1470 }
1310 } 1471 }
1311 }; 1472 };
1312} 1473}
1313 1474
1314############################################################################# 1475#############################################################################
1315 1476
1316=back 1477=back
1317 1478
1318=head2 CORE EXTENSIONS 1479=head2 CORE EXTENSIONS
1319 1480
1320Functions and methods that extend core crossfire objects. 1481Functions and methods that extend core deliantra objects.
1321 1482
1322=cut 1483=cut
1323 1484
1324package cf::player; 1485package cf::player;
1325 1486
… …
1368 1529
1369sub exists($) { 1530sub exists($) {
1370 my ($login) = @_; 1531 my ($login) = @_;
1371 1532
1372 $cf::PLAYER{$login} 1533 $cf::PLAYER{$login}
1373 or cf::sync_job { !aio_stat path $login } 1534 or !aio_stat path $login
1374} 1535}
1375 1536
1376sub find($) { 1537sub find($) {
1377 return $cf::PLAYER{$_[0]} || do { 1538 return $cf::PLAYER{$_[0]} || do {
1378 my $login = $_[0]; 1539 my $login = $_[0];
… …
1390 my $f = new_from_file cf::object::thawer path $login 1551 my $f = new_from_file cf::object::thawer path $login
1391 or return; 1552 or return;
1392 1553
1393 my $pl = cf::player::load_pl $f 1554 my $pl = cf::player::load_pl $f
1394 or return; 1555 or return;
1556
1395 local $cf::PLAYER_LOADING{$login} = $pl; 1557 local $cf::PLAYER_LOADING{$login} = $pl;
1396 $f->resolve_delayed_derefs; 1558 $f->resolve_delayed_derefs;
1397 $cf::PLAYER{$login} = $pl 1559 $cf::PLAYER{$login} = $pl
1398 } 1560 }
1399 } 1561 }
1400} 1562}
1401 1563
1564cf::player->attach (
1565 on_load => sub {
1566 my ($pl, $path) = @_;
1567
1568 # restore slots saved in save, below
1569 my $slots = delete $pl->{_slots};
1570
1571 $pl->ob->current_weapon ($slots->[0]);
1572 $pl->combat_ob ($slots->[1]);
1573 $pl->ranged_ob ($slots->[2]);
1574 },
1575);
1576
1402sub save($) { 1577sub save($) {
1403 my ($pl) = @_; 1578 my ($pl) = @_;
1404 1579
1405 return if $pl->{deny_save}; 1580 return if $pl->{deny_save};
1406 1581
… …
1409 1584
1410 return if $pl->{deny_save}; 1585 return if $pl->{deny_save};
1411 1586
1412 aio_mkdir playerdir $pl, 0770; 1587 aio_mkdir playerdir $pl, 0770;
1413 $pl->{last_save} = $cf::RUNTIME; 1588 $pl->{last_save} = $cf::RUNTIME;
1589
1590 cf::get_slot 0.01;
1591
1592 # save slots, to be restored later
1593 local $pl->{_slots} = [$pl->ob->current_weapon, $pl->combat_ob, $pl->ranged_ob];
1414 1594
1415 $pl->save_pl ($path); 1595 $pl->save_pl ($path);
1416 cf::cede_to_tick; 1596 cf::cede_to_tick;
1417} 1597}
1418 1598
… …
1450 my ($pl) = @_; 1630 my ($pl) = @_;
1451 1631
1452 my $name = $pl->ob->name; 1632 my $name = $pl->ob->name;
1453 1633
1454 $pl->{deny_save} = 1; 1634 $pl->{deny_save} = 1;
1455 $pl->password ("*"); # this should lock out the player until we nuked the dir 1635 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1456 1636
1457 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1637 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1458 $pl->deactivate; 1638 $pl->deactivate;
1639 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1459 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1640 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1460 $pl->ns->destroy if $pl->ns; 1641 $pl->ns->destroy if $pl->ns;
1461 1642
1462 my $path = playerdir $pl; 1643 my $path = playerdir $pl;
1463 my $temp = "$path~$cf::RUNTIME~deleting~"; 1644 my $temp = "$path~$cf::RUNTIME~deleting~";
… …
1502 1683
1503 for my $login (@$dirs) { 1684 for my $login (@$dirs) {
1504 my $path = path $login; 1685 my $path = path $login;
1505 1686
1506 # a .pst is a dead give-away for a valid player 1687 # a .pst is a dead give-away for a valid player
1507 unless (-e "$path.pst") { 1688 # if no pst file found, open and chekc for blocked users
1689 if (aio_stat "$path.pst") {
1508 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next; 1690 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1509 aio_read $fh, 0, 512, my $buf, 0 or next; 1691 aio_read $fh, 0, 512, my $buf, 0 or next;
1510 $buf !~ /^password -------------$/m or next; # official not-valid tag 1692 $buf !~ /^password -------------$/m or next; # official not-valid tag
1511 } 1693 }
1512 1694
… …
1516 1698
1517 \@logins 1699 \@logins
1518} 1700}
1519 1701
1520=item $player->maps 1702=item $player->maps
1703
1704=item cf::player::maps $login
1521 1705
1522Returns an arrayref of map paths that are private for this 1706Returns an arrayref of map paths that are private for this
1523player. May block. 1707player. May block.
1524 1708
1525=cut 1709=cut
… …
1543 } 1727 }
1544 1728
1545 \@paths 1729 \@paths
1546} 1730}
1547 1731
1548=item $protocol_xml = $player->expand_cfpod ($crossfire_pod) 1732=item $protocol_xml = $player->expand_cfpod ($cfpod)
1549 1733
1550Expand crossfire pod fragments into protocol xml. 1734Expand deliantra pod fragments into protocol xml.
1551
1552=cut
1553
1554sub expand_cfpod {
1555 ((my $self), (local $_)) = @_;
1556
1557 # escape & and <
1558 s/&/&amp;/g;
1559 s/(?<![BIUGHT])</&lt;/g;
1560
1561 # this is buggy, it needs to properly take care of nested <'s
1562
1563 1 while
1564 # replace B<>, I<>, U<> etc.
1565 s/B<([^\>]*)>/<b>$1<\/b>/
1566 || s/I<([^\>]*)>/<i>$1<\/i>/
1567 || s/U<([^\>]*)>/<u>$1<\/u>/
1568 || s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/
1569 # replace G<male|female> tags
1570 || s{G<([^>|]*)\|([^>]*)>}{
1571 $self->gender ? $2 : $1
1572 }ge
1573 # replace H<hint text>
1574 || s{H<([^\>]*)>}
1575 {
1576 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
1577 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1578 "")
1579 [$self->{hintmode}]
1580 }ge;
1581
1582 # create single paragraphs (very hackish)
1583 s/(?<=\S)\n(?=\w)/ /g;
1584
1585 # compress some whitespace
1586 s/\s+\n/\n/g; # ws line-ends
1587 s/\n\n+/\n/g; # double lines
1588 s/^\n+//; # beginning lines
1589 s/\n+$//; # ending lines
1590
1591 $_
1592}
1593
1594sub hintmode {
1595 $_[0]{hintmode} = $_[1] if @_ > 1;
1596 $_[0]{hintmode}
1597}
1598 1735
1599=item $player->ext_reply ($msgid, @msg) 1736=item $player->ext_reply ($msgid, @msg)
1600 1737
1601Sends an ext reply to the player. 1738Sends an ext reply to the player.
1602 1739
… …
1634 1771
1635=cut 1772=cut
1636 1773
1637sub find_by_path($) { 1774sub find_by_path($) {
1638 my ($path) = @_; 1775 my ($path) = @_;
1776
1777 $path =~ s/^~[^\/]*//; # skip ~login
1639 1778
1640 my ($match, $specificity); 1779 my ($match, $specificity);
1641 1780
1642 for my $region (list) { 1781 for my $region (list) {
1643 if ($region->{match} && $path =~ $region->{match}) { 1782 if ($region->{match} && $path =~ $region->{match}) {
… …
1669our $MAX_RESET = 3600; 1808our $MAX_RESET = 3600;
1670our $DEFAULT_RESET = 3000; 1809our $DEFAULT_RESET = 3000;
1671 1810
1672sub generate_random_map { 1811sub generate_random_map {
1673 my ($self, $rmp) = @_; 1812 my ($self, $rmp) = @_;
1813
1814 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1815
1674 # mit "rum" bekleckern, nicht 1816 # mit "rum" bekleckern, nicht
1675 $self->_create_random_map ( 1817 $self->_create_random_map (
1676 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1818 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1677 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1819 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, $rmp->{miningstyle},
1678 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1820 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1679 $rmp->{exit_on_final_map}, 1821 $rmp->{exit_on_final_map},
1680 $rmp->{xsize}, $rmp->{ysize}, 1822 $rmp->{xsize}, $rmp->{ysize},
1681 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1823 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1682 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1824 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
… …
1704 1846
1705 $EXT_MAP{$pkg} = [$prio, qr<$regex>]; 1847 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1706} 1848}
1707 1849
1708# also paths starting with '/' 1850# also paths starting with '/'
1709$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}]; 1851$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1710 1852
1711sub thawer_merge { 1853sub thawer_merge {
1712 my ($self, $merge) = @_; 1854 my ($self, $merge) = @_;
1713 1855
1714 # we have to keep some variables in memory intact 1856 # we have to keep some variables in memory intact
… …
1800 1942
1801# the temporary/swap location 1943# the temporary/swap location
1802sub save_path { 1944sub save_path {
1803 my ($self) = @_; 1945 my ($self) = @_;
1804 1946
1805 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1947 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1806 "$TMPDIR/$path.map" 1948 "$TMPDIR/$path.map"
1807} 1949}
1808 1950
1809# the unique path, undef == no special unique path 1951# the unique path, undef == no special unique path
1810sub uniq_path { 1952sub uniq_path {
1811 my ($self) = @_; 1953 my ($self) = @_;
1812 1954
1813 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1955 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1814 "$UNIQUEDIR/$path" 1956 "$UNIQUEDIR/$path"
1815}
1816
1817# and all this just because we cannot iterate over
1818# all maps in C++...
1819sub change_all_map_light {
1820 my ($change) = @_;
1821
1822 $_->change_map_light ($change)
1823 for grep $_->outdoor, values %cf::MAP;
1824} 1957}
1825 1958
1826sub decay_objects { 1959sub decay_objects {
1827 my ($self) = @_; 1960 my ($self) = @_;
1828 1961
… …
1912sub find { 2045sub find {
1913 my ($path, $origin) = @_; 2046 my ($path, $origin) = @_;
1914 2047
1915 $path = normalise $path, $origin && $origin->path; 2048 $path = normalise $path, $origin && $origin->path;
1916 2049
1917 cf::lock_wait "map_data:$path";#d#remove 2050 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1918 cf::lock_wait "map_find:$path"; 2051 my $guard2 = cf::lock_acquire "map_find:$path";
1919 2052
1920 $cf::MAP{$path} || do { 2053 $cf::MAP{$path} || do {
1921 my $guard1 = cf::lock_acquire "map_find:$path";
1922 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1923
1924 my $map = new_from_path cf::map $path 2054 my $map = new_from_path cf::map $path
1925 or return; 2055 or return;
1926 2056
1927 $map->{last_save} = $cf::RUNTIME; 2057 $map->{last_save} = $cf::RUNTIME;
1928 2058
… …
1930 or return; 2060 or return;
1931 2061
1932 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 2062 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1933 # doing this can freeze the server in a sync job, obviously 2063 # doing this can freeze the server in a sync job, obviously
1934 #$cf::WAIT_FOR_TICK->wait; 2064 #$cf::WAIT_FOR_TICK->wait;
2065 undef $guard2;
1935 undef $guard1; 2066 undef $guard1;
1936 undef $guard2;
1937 $map->reset; 2067 $map->reset;
1938 return find $path; 2068 return find $path;
1939 } 2069 }
1940 2070
1941 $cf::MAP{$path} = $map 2071 $cf::MAP{$path} = $map
1942 } 2072 }
1943} 2073}
1944 2074
1945sub pre_load { } 2075sub pre_load { }
1946sub post_load { } 2076#sub post_load { } # XS
1947 2077
1948sub load { 2078sub load {
1949 my ($self) = @_; 2079 my ($self) = @_;
1950 2080
1951 local $self->{deny_reset} = 1; # loading can take a long time 2081 local $self->{deny_reset} = 1; # loading can take a long time
… …
1968 my $f = new_from_file cf::object::thawer $self->{load_path}; 2098 my $f = new_from_file cf::object::thawer $self->{load_path};
1969 $f->skip_block; 2099 $f->skip_block;
1970 $self->_load_objects ($f) 2100 $self->_load_objects ($f)
1971 or return; 2101 or return;
1972 2102
1973 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2103 $self->post_load_original
1974 if delete $self->{load_original}; 2104 if delete $self->{load_original};
1975 2105
1976 if (my $uniq = $self->uniq_path) { 2106 if (my $uniq = $self->uniq_path) {
1977 utf8::encode $uniq; 2107 utf8::encode $uniq;
1978 unless (aio_stat $uniq) { 2108 unless (aio_stat $uniq) {
… …
1996 unless ($self->{deny_activate}) { 2126 unless ($self->{deny_activate}) {
1997 $self->decay_objects; 2127 $self->decay_objects;
1998 $self->fix_auto_apply; 2128 $self->fix_auto_apply;
1999 $self->update_buttons; 2129 $self->update_buttons;
2000 cf::cede_to_tick; 2130 cf::cede_to_tick;
2001 $self->set_darkness_map;
2002 cf::cede_to_tick;
2003 $self->activate; 2131 $self->activate;
2004 } 2132 }
2005 2133
2006 $self->{last_save} = $cf::RUNTIME; 2134 $self->{last_save} = $cf::RUNTIME;
2007 $self->last_access ($cf::RUNTIME); 2135 $self->last_access ($cf::RUNTIME);
2008 2136
2009 $self->in_memory (cf::MAP_IN_MEMORY); 2137 $self->in_memory (cf::MAP_ACTIVE);
2010 } 2138 }
2011 2139
2012 $self->post_load; 2140 $self->post_load;
2013} 2141}
2014 2142
2143# customize the map for a given player, i.e.
2144# return the _real_ map. used by e.g. per-player
2145# maps to change the path to ~playername/mappath
2015sub customise_for { 2146sub customise_for {
2016 my ($self, $ob) = @_; 2147 my ($self, $ob) = @_;
2017 2148
2018 return find "~" . $ob->name . "/" . $self->{path} 2149 return find "~" . $ob->name . "/" . $self->{path}
2019 if $self->per_player; 2150 if $self->per_player;
… …
2035 or next; 2166 or next;
2036 $neigh = find $neigh, $map 2167 $neigh = find $neigh, $map
2037 or next; 2168 or next;
2038 $neigh->load; 2169 $neigh->load;
2039 2170
2171 # now find the diagonal neighbours
2040 push @neigh, 2172 push @neigh,
2041 [$neigh->tile_path (($_ + 3) % 4), $neigh], 2173 [$neigh->tile_path (($_ + 3) % 4), $neigh],
2042 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2174 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2043 } 2175 }
2044 2176
… …
2072 my ($path, $origin, $load) = @_; 2204 my ($path, $origin, $load) = @_;
2073 2205
2074 $path = normalise $path, $origin && $origin->{path}; 2206 $path = normalise $path, $origin && $origin->{path};
2075 2207
2076 if (my $map = $cf::MAP{$path}) { 2208 if (my $map = $cf::MAP{$path}) {
2077 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY; 2209 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
2078 } 2210 }
2079 2211
2080 $MAP_PREFETCH{$path} |= $load; 2212 $MAP_PREFETCH{$path} |= $load;
2081 2213
2082 $MAP_PREFETCHER ||= cf::async { 2214 $MAP_PREFETCHER ||= cf::async {
… …
2096 $MAP_PREFETCHER->prio (6); 2228 $MAP_PREFETCHER->prio (6);
2097 2229
2098 () 2230 ()
2099} 2231}
2100 2232
2233# common code, used by both ->save and ->swapout
2101sub save { 2234sub _save {
2102 my ($self) = @_; 2235 my ($self) = @_;
2103
2104 my $lock = cf::lock_acquire "map_data:$self->{path}";
2105 2236
2106 $self->{last_save} = $cf::RUNTIME; 2237 $self->{last_save} = $cf::RUNTIME;
2107 2238
2108 return unless $self->dirty; 2239 return unless $self->dirty;
2109 2240
… …
2118 2249
2119 cf::async { 2250 cf::async {
2120 $Coro::current->{desc} = "map player save"; 2251 $Coro::current->{desc} = "map player save";
2121 $_->contr->save for $self->players; 2252 $_->contr->save for $self->players;
2122 }; 2253 };
2254
2255 cf::get_slot 0.02;
2123 2256
2124 if ($uniq) { 2257 if ($uniq) {
2125 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2258 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
2126 $self->_save_objects ($uniq, cf::IO_UNIQUES); 2259 $self->_save_objects ($uniq, cf::IO_UNIQUES);
2127 } else { 2260 } else {
2128 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 2261 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
2129 } 2262 }
2130} 2263}
2131 2264
2265sub save {
2266 my ($self) = @_;
2267
2268 my $lock = cf::lock_acquire "map_data:$self->{path}";
2269
2270 $self->_save;
2271}
2272
2132sub swap_out { 2273sub swap_out {
2133 my ($self) = @_; 2274 my ($self) = @_;
2134 2275
2135 # save first because save cedes
2136 $self->save;
2137
2138 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2276 my $lock = cf::lock_acquire "map_data:$self->{path}";
2139 2277
2278 return if $self->in_memory != cf::MAP_ACTIVE;
2279 return if $self->{deny_save};
2140 return if $self->players; 2280 return if $self->players;
2141 return if $self->in_memory != cf::MAP_IN_MEMORY;
2142 return if $self->{deny_save};
2143 2281
2282 # first deactivate the map and "unlink" it from the core
2283 $self->deactivate;
2284 $_->clear_links_to ($self) for values %cf::MAP;
2144 $self->in_memory (cf::MAP_SWAPPED); 2285 $self->in_memory (cf::MAP_SWAPPED);
2286
2287 # then atomically save
2288 $self->_save;
2289
2290 # then free the map
2291 $self->clear;
2292}
2293
2294sub reset_at {
2295 my ($self) = @_;
2296
2297 # TODO: safety, remove and allow resettable per-player maps
2298 return 1e99 if $self->{deny_reset};
2299
2300 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2301 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2302
2303 $time + $to
2304}
2305
2306sub should_reset {
2307 my ($self) = @_;
2308
2309 $self->reset_at <= $cf::RUNTIME
2310}
2311
2312sub reset {
2313 my ($self) = @_;
2314
2315 my $lock = cf::lock_acquire "map_data:$self->{path}";
2316
2317 return if $self->players;
2318
2319 warn "resetting map ", $self->path, "\n";
2320
2321 $self->in_memory (cf::MAP_SWAPPED);
2322
2323 # need to save uniques path
2324 unless ($self->{deny_save}) {
2325 my $uniq = $self->uniq_path; utf8::encode $uniq;
2326
2327 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2328 if $uniq;
2329 }
2330
2331 delete $cf::MAP{$self->path};
2145 2332
2146 $self->deactivate; 2333 $self->deactivate;
2147 $_->clear_links_to ($self) for values %cf::MAP; 2334 $_->clear_links_to ($self) for values %cf::MAP;
2148 $self->clear; 2335 $self->clear;
2149}
2150
2151sub reset_at {
2152 my ($self) = @_;
2153
2154 # TODO: safety, remove and allow resettable per-player maps
2155 return 1e99 if $self->{deny_reset};
2156
2157 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2158 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2159
2160 $time + $to
2161}
2162
2163sub should_reset {
2164 my ($self) = @_;
2165
2166 $self->reset_at <= $cf::RUNTIME
2167}
2168
2169sub reset {
2170 my ($self) = @_;
2171
2172 my $lock = cf::lock_acquire "map_data:$self->{path}";
2173
2174 return if $self->players;
2175
2176 warn "resetting map ", $self->path;
2177
2178 $self->in_memory (cf::MAP_SWAPPED);
2179
2180 # need to save uniques path
2181 unless ($self->{deny_save}) {
2182 my $uniq = $self->uniq_path; utf8::encode $uniq;
2183
2184 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2185 if $uniq;
2186 }
2187
2188 delete $cf::MAP{$self->path};
2189
2190 $self->deactivate;
2191 $_->clear_links_to ($self) for values %cf::MAP;
2192 $self->clear;
2193 2336
2194 $self->unlink_save; 2337 $self->unlink_save;
2195 $self->destroy; 2338 $self->destroy;
2196} 2339}
2197 2340
… …
2205 2348
2206 delete $cf::MAP{$self->path}; 2349 delete $cf::MAP{$self->path};
2207 2350
2208 $self->unlink_save; 2351 $self->unlink_save;
2209 2352
2210 bless $self, "cf::map"; 2353 bless $self, "cf::map::wrap";
2211 delete $self->{deny_reset}; 2354 delete $self->{deny_reset};
2212 $self->{deny_save} = 1; 2355 $self->{deny_save} = 1;
2213 $self->reset_timeout (1); 2356 $self->reset_timeout (1);
2214 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2357 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2215 2358
… …
2264 2407
2265sub unique_maps() { 2408sub unique_maps() {
2266 [ 2409 [
2267 map { 2410 map {
2268 utf8::decode $_; 2411 utf8::decode $_;
2269 /\.map$/ 2412 s/\.map$//; # TODO future compatibility hack
2413 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
2414 ? ()
2270 ? normalise $_ 2415 : normalise $_
2271 : ()
2272 } @{ aio_readdir $UNIQUEDIR or [] } 2416 } @{ aio_readdir $UNIQUEDIR or [] }
2273 ] 2417 ]
2274} 2418}
2275 2419
2276package cf; 2420=item cf::map::static_maps
2421
2422Returns an arrayref if paths of all static maps (all preinstalled F<.map>
2423file in the shared directory excluding F</styles> and F</editor>). May
2424block.
2425
2426=cut
2427
2428sub static_maps() {
2429 my @dirs = "";
2430 my @maps;
2431
2432 while (@dirs) {
2433 my $dir = shift @dirs;
2434
2435 next if $dir eq "/styles" || $dir eq "/editor";
2436
2437 my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
2438 or return;
2439
2440 for (@$files) {
2441 s/\.map$// or next;
2442 utf8::decode $_;
2443 push @maps, "$dir/$_";
2444 }
2445
2446 push @dirs, map "$dir/$_", @$dirs;
2447 }
2448
2449 \@maps
2450}
2277 2451
2278=back 2452=back
2279 2453
2280=head3 cf::object 2454=head3 cf::object
2281 2455
… …
2285 2459
2286=over 4 2460=over 4
2287 2461
2288=item $ob->inv_recursive 2462=item $ob->inv_recursive
2289 2463
2290Returns the inventory of the object _and_ their inventories, recursively. 2464Returns the inventory of the object I<and> their inventories, recursively,
2465but I<not> the object itself.
2291 2466
2292=cut 2467=cut
2293 2468
2294sub inv_recursive_; 2469sub inv_recursive_;
2295sub inv_recursive_ { 2470sub inv_recursive_ {
… …
2300 inv_recursive_ inv $_[0] 2475 inv_recursive_ inv $_[0]
2301} 2476}
2302 2477
2303=item $ref = $ob->ref 2478=item $ref = $ob->ref
2304 2479
2305creates and returns a persistent reference to an objetc that can be stored as a string. 2480Creates and returns a persistent reference to an object that can be stored as a string.
2306 2481
2307=item $ob = cf::object::deref ($refstring) 2482=item $ob = cf::object::deref ($refstring)
2308 2483
2309returns the objetc referenced by refstring. may return undef when it cnanot find the object, 2484returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2310even if the object actually exists. May block. 2485even if the object actually exists. May block.
… …
2342can be C<undef>. Does the right thing when the player is currently in a 2517can be C<undef>. Does the right thing when the player is currently in a
2343dialogue with the given NPC character. 2518dialogue with the given NPC character.
2344 2519
2345=cut 2520=cut
2346 2521
2522our $SAY_CHANNEL = {
2523 id => "say",
2524 title => "Map",
2525 reply => "say ",
2526 tooltip => "Things said to and replied from NPCs near you and other players on the same map only.",
2527};
2528
2529our $CHAT_CHANNEL = {
2530 id => "chat",
2531 title => "Chat",
2532 reply => "chat ",
2533 tooltip => "Player chat and shouts, global to the server.",
2534};
2535
2347# rough implementation of a future "reply" method that works 2536# rough implementation of a future "reply" method that works
2348# with dialog boxes. 2537# with dialog boxes.
2349#TODO: the first argument must go, split into a $npc->reply_to ( method 2538#TODO: the first argument must go, split into a $npc->reply_to ( method
2350sub cf::object::player::reply($$$;$) { 2539sub cf::object::player::reply($$$;$) {
2351 my ($self, $npc, $msg, $flags) = @_; 2540 my ($self, $npc, $msg, $flags) = @_;
… …
2362 my $dialog = $pl->{npc_dialog}; 2551 my $dialog = $pl->{npc_dialog};
2363 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg)); 2552 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2364 2553
2365 } else { 2554 } else {
2366 $msg = $npc->name . " says: $msg" if $npc; 2555 $msg = $npc->name . " says: $msg" if $npc;
2367 $self->message ($msg, $flags); 2556 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2368 } 2557 }
2369 } 2558 }
2370} 2559}
2371 2560
2372=item $object->send_msg ($channel, $msg, $color, [extra...]) 2561=item $object->send_msg ($channel, $msg, $color, [extra...])
… …
2397 2586
2398=item $player_object->enter_link 2587=item $player_object->enter_link
2399 2588
2400Freezes the player and moves him/her to a special map (C<{link}>). 2589Freezes the player and moves him/her to a special map (C<{link}>).
2401 2590
2402The player should be reasonably safe there for short amounts of time. You 2591The player should be reasonably safe there for short amounts of time (e.g.
2403I<MUST> call C<leave_link> as soon as possible, though. 2592for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2593though, as the player cannot control the character while it is on the link
2594map.
2404 2595
2405Will never block. 2596Will never block.
2406 2597
2407=item $player_object->leave_link ($map, $x, $y) 2598=item $player_object->leave_link ($map, $x, $y)
2408 2599
… …
2428sub cf::object::player::enter_link { 2619sub cf::object::player::enter_link {
2429 my ($self) = @_; 2620 my ($self) = @_;
2430 2621
2431 $self->deactivate_recursive; 2622 $self->deactivate_recursive;
2432 2623
2624 ++$self->{_link_recursion};
2625
2433 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2626 return if UNIVERSAL::isa $self->map, "ext::map_link";
2434 2627
2435 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2628 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2436 if $self->map && $self->map->{path} ne "{link}"; 2629 if $self->map && $self->map->{path} ne "{link}";
2437 2630
2438 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2631 $self->enter_map ($LINK_MAP || link_map, 3, 3);
2439} 2632}
2440 2633
2441sub cf::object::player::leave_link { 2634sub cf::object::player::leave_link {
2442 my ($self, $map, $x, $y) = @_; 2635 my ($self, $map, $x, $y) = @_;
2443 2636
… …
2460 ($x, $y) = (-1, -1) 2653 ($x, $y) = (-1, -1)
2461 unless (defined $x) && (defined $y); 2654 unless (defined $x) && (defined $y);
2462 2655
2463 # use -1 or undef as default coordinates, not 0, 0 2656 # use -1 or undef as default coordinates, not 0, 0
2464 ($x, $y) = ($map->enter_x, $map->enter_y) 2657 ($x, $y) = ($map->enter_x, $map->enter_y)
2465 if $x <=0 && $y <= 0; 2658 if $x <= 0 && $y <= 0;
2466 2659
2467 $map->load; 2660 $map->load;
2468 $map->load_neighbours; 2661 $map->load_neighbours;
2469 2662
2470 return unless $self->contr->active; 2663 return unless $self->contr->active;
2471 $self->activate_recursive;
2472 2664
2473 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2665 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2474 $self->enter_map ($map, $x, $y); 2666 if ($self->enter_map ($map, $x, $y)) {
2475} 2667 # entering was successful
2668 delete $self->{_link_recursion};
2669 # only activate afterwards, to support waiting in hooks
2670 $self->activate_recursive;
2671 }
2476 2672
2673}
2674
2477=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]]) 2675=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
2478 2676
2479Moves the player to the given map-path and coordinates by first freezing 2677Moves the player to the given map-path and coordinates by first freezing
2480her, loading and preparing them map, calling the provided $check callback 2678her, loading and preparing them map, calling the provided $check callback
2481that has to return the map if sucecssful, and then unfreezes the player on 2679that has to return the map if sucecssful, and then unfreezes the player on
2482the new (success) or old (failed) map position. In either case, $done will 2680the new (success) or old (failed) map position. In either case, $done will
2483be called at the end of this process. 2681be called at the end of this process.
2484 2682
2683Note that $check will be called with a potentially non-loaded map, so if
2684it needs a loaded map it has to call C<< ->load >>.
2685
2485=cut 2686=cut
2486 2687
2487our $GOTOGEN; 2688our $GOTOGEN;
2488 2689
2489sub cf::object::player::goto { 2690sub cf::object::player::goto {
2490 my ($self, $path, $x, $y, $check, $done) = @_; 2691 my ($self, $path, $x, $y, $check, $done) = @_;
2692
2693 if ($self->{_link_recursion} >= $MAX_LINKS) {
2694 warn "FATAL: link recursion exceeded, ", $self->name, " goto $path $x $y, redirecting.";
2695 $self->failmsg ("Something went wrong inside the server - please contact an administrator!");
2696 ($path, $x, $y) = @$EMERGENCY_POSITION;
2697 }
2491 2698
2492 # do generation counting so two concurrent goto's will be executed in-order 2699 # do generation counting so two concurrent goto's will be executed in-order
2493 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2700 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2494 2701
2495 $self->enter_link; 2702 $self->enter_link;
… …
2519 my $map = eval { 2726 my $map = eval {
2520 my $map = defined $path ? cf::map::find $path : undef; 2727 my $map = defined $path ? cf::map::find $path : undef;
2521 2728
2522 if ($map) { 2729 if ($map) {
2523 $map = $map->customise_for ($self); 2730 $map = $map->customise_for ($self);
2524 $map = $check->($map) if $check && $map; 2731 $map = $check->($map, $x, $y, $self) if $check && $map;
2525 } else { 2732 } else {
2526 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED); 2733 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2527 } 2734 }
2528 2735
2529 $map 2736 $map
… …
2537 if ($gen == $self->{_goto_generation}) { 2744 if ($gen == $self->{_goto_generation}) {
2538 delete $self->{_goto_generation}; 2745 delete $self->{_goto_generation};
2539 $self->leave_link ($map, $x, $y); 2746 $self->leave_link ($map, $x, $y);
2540 } 2747 }
2541 2748
2542 $done->() if $done; 2749 $done->($self) if $done;
2543 })->prio (1); 2750 })->prio (1);
2544} 2751}
2545 2752
2546=item $player_object->enter_exit ($exit_object) 2753=item $player_object->enter_exit ($exit_object)
2547 2754
… …
2567} 2774}
2568 2775
2569sub prepare_random_map { 2776sub prepare_random_map {
2570 my ($exit) = @_; 2777 my ($exit) = @_;
2571 2778
2572 my $guard = cf::lock_acquire "exit_prepare:$exit";
2573
2574 # all this does is basically replace the /! path by 2779 # all this does is basically replace the /! path by
2575 # a new random map path (?random/...) with a seed 2780 # a new random map path (?random/...) with a seed
2576 # that depends on the exit object 2781 # that depends on the exit object
2577 2782
2578 my $rmp = parse_random_map_params $exit->msg; 2783 my $rmp = parse_random_map_params $exit->msg;
… …
2580 if ($exit->map) { 2785 if ($exit->map) {
2581 $rmp->{region} = $exit->region->name; 2786 $rmp->{region} = $exit->region->name;
2582 $rmp->{origin_map} = $exit->map->path; 2787 $rmp->{origin_map} = $exit->map->path;
2583 $rmp->{origin_x} = $exit->x; 2788 $rmp->{origin_x} = $exit->x;
2584 $rmp->{origin_y} = $exit->y; 2789 $rmp->{origin_y} = $exit->y;
2790
2791 $exit->map->touch;
2585 } 2792 }
2586 2793
2587 $rmp->{random_seed} ||= $exit->random_seed; 2794 $rmp->{random_seed} ||= $exit->random_seed;
2588 2795
2589 my $data = cf::to_json $rmp; 2796 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2590 my $md5 = Digest::MD5::md5_hex $data; 2797 my $md5 = Digest::MD5::md5_hex $data;
2591 my $meta = "$RANDOMDIR/$md5.meta"; 2798 my $meta = "$RANDOMDIR/$md5.meta";
2592 2799
2593 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2800 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2594 aio_write $fh, 0, (length $data), $data, 0; 2801 aio_write $fh, 0, (length $data), $data, 0;
2595 undef $fh; 2802 undef $fh;
2596 aio_rename "$meta~", $meta; 2803 aio_rename "$meta~", $meta;
2597 2804
2805 my $slaying = "?random/$md5";
2806
2807 if ($exit->valid) {
2598 $exit->slaying ("?random/$md5"); 2808 $exit->slaying ("?random/$md5");
2599 $exit->msg (undef); 2809 $exit->msg (undef);
2810 }
2600 } 2811 }
2601} 2812}
2602 2813
2603sub cf::object::player::enter_exit { 2814sub cf::object::player::enter_exit {
2604 my ($self, $exit) = @_; 2815 my ($self, $exit) = @_;
2605 2816
2606 return unless $self->type == cf::PLAYER; 2817 return unless $self->type == cf::PLAYER;
2607 2818
2608 if ($exit->slaying eq "/!") {
2609 #TODO: this should de-fi-ni-te-ly not be a sync-job
2610 # the problem is that $exit might not survive long enough
2611 # so it needs to be done right now, right here
2612 cf::sync_job { prepare_random_map $exit };
2613 }
2614
2615 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2616 my $hp = $exit->stats->hp;
2617 my $sp = $exit->stats->sp;
2618
2619 $self->enter_link; 2819 $self->enter_link;
2620 2820
2621 # if exit is damned, update players death & WoR home-position
2622 $self->contr->savebed ($slaying, $hp, $sp)
2623 if $exit->flag (FLAG_DAMNED);
2624
2625 (async { 2821 (async {
2626 $Coro::current->{desc} = "enter_exit $slaying $hp $sp"; 2822 $Coro::current->{desc} = "enter_exit";
2627 2823
2628 $self->deactivate_recursive; # just to be sure
2629 unless (eval { 2824 unless (eval {
2825 $self->deactivate_recursive; # just to be sure
2826
2827 # random map handling
2828 {
2829 my $guard = cf::lock_acquire "exit_prepare:$exit";
2830
2831 prepare_random_map $exit
2832 if $exit->slaying eq "/!";
2833 }
2834
2835 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2836 my $x = $exit->stats->hp;
2837 my $y = $exit->stats->sp;
2838
2630 $self->goto ($slaying, $hp, $sp); 2839 $self->goto ($map, $x, $y);
2631 2840
2841 # if exit is damned, update players death & WoR home-position
2842 $self->contr->savebed ($map, $x, $y)
2843 if $exit->flag (cf::FLAG_DAMNED);
2844
2632 1; 2845 1
2633 }) { 2846 }) {
2634 $self->message ("Something went wrong deep within the crossfire server. " 2847 $self->message ("Something went wrong deep within the deliantra server. "
2635 . "I'll try to bring you back to the map you were before. " 2848 . "I'll try to bring you back to the map you were before. "
2636 . "Please report this to the dungeon master!", 2849 . "Please report this to the dungeon master!",
2637 cf::NDI_UNIQUE | cf::NDI_RED); 2850 cf::NDI_UNIQUE | cf::NDI_RED);
2638 2851
2639 warn "ERROR in enter_exit: $@"; 2852 warn "ERROR in enter_exit: $@";
… …
2656sub cf::client::send_drawinfo { 2869sub cf::client::send_drawinfo {
2657 my ($self, $text, $flags) = @_; 2870 my ($self, $text, $flags) = @_;
2658 2871
2659 utf8::encode $text; 2872 utf8::encode $text;
2660 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2873 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2874}
2875
2876=item $client->send_big_packet ($pkt)
2877
2878Like C<send_packet>, but tries to compress large packets, and fragments
2879them as required.
2880
2881=cut
2882
2883our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
2884
2885sub cf::client::send_big_packet {
2886 my ($self, $pkt) = @_;
2887
2888 # try lzf for large packets
2889 $pkt = "lzf " . Compress::LZF::compress $pkt
2890 if 1024 <= length $pkt and $self->{can_lzf};
2891
2892 # split very large packets
2893 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
2894 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
2895 $pkt = "frag";
2896 }
2897
2898 $self->send_packet ($pkt);
2661} 2899}
2662 2900
2663=item $client->send_msg ($channel, $msg, $color, [extra...]) 2901=item $client->send_msg ($channel, $msg, $color, [extra...])
2664 2902
2665Send a drawinfo or msg packet to the client, formatting the msg for the 2903Send a drawinfo or msg packet to the client, formatting the msg for the
… …
2667the message, with C<log> being the default. If C<$color> is negative, suppress 2905the message, with C<log> being the default. If C<$color> is negative, suppress
2668the message unless the client supports the msg packet. 2906the message unless the client supports the msg packet.
2669 2907
2670=cut 2908=cut
2671 2909
2910# non-persistent channels (usually the info channel)
2672our %CHANNEL = ( 2911our %CHANNEL = (
2912 "c/motd" => {
2913 id => "infobox",
2914 title => "MOTD",
2915 reply => undef,
2916 tooltip => "The message of the day",
2917 },
2673 "c/identify" => { 2918 "c/identify" => {
2674 id => "infobox", 2919 id => "infobox",
2675 title => "Identify", 2920 title => "Identify",
2676 reply => undef, 2921 reply => undef,
2677 tooltip => "Items recently identified", 2922 tooltip => "Items recently identified",
… …
2680 id => "infobox", 2925 id => "infobox",
2681 title => "Examine", 2926 title => "Examine",
2682 reply => undef, 2927 reply => undef,
2683 tooltip => "Signs and other items you examined", 2928 tooltip => "Signs and other items you examined",
2684 }, 2929 },
2930 "c/shopinfo" => {
2931 id => "infobox",
2932 title => "Shop Info",
2933 reply => undef,
2934 tooltip => "What your bargaining skill tells you about the shop",
2935 },
2936 "c/book" => {
2937 id => "infobox",
2938 title => "Book",
2939 reply => undef,
2940 tooltip => "The contents of a note or book",
2941 },
2685 "c/lookat" => { 2942 "c/lookat" => {
2686 id => "infobox", 2943 id => "infobox",
2687 title => "Look", 2944 title => "Look",
2688 reply => undef, 2945 reply => undef,
2689 tooltip => "What you saw there", 2946 tooltip => "What you saw there",
2690 }, 2947 },
2948 "c/who" => {
2949 id => "infobox",
2950 title => "Players",
2951 reply => undef,
2952 tooltip => "Shows players who are currently online",
2953 },
2954 "c/body" => {
2955 id => "infobox",
2956 title => "Body Parts",
2957 reply => undef,
2958 tooltip => "Shows which body parts you posess and are available",
2959 },
2960 "c/statistics" => {
2961 id => "infobox",
2962 title => "Statistics",
2963 reply => undef,
2964 tooltip => "Shows your primary statistics",
2965 },
2966 "c/skills" => {
2967 id => "infobox",
2968 title => "Skills",
2969 reply => undef,
2970 tooltip => "Shows your experience per skill and item power",
2971 },
2972 "c/shopitems" => {
2973 id => "infobox",
2974 title => "Shop Items",
2975 reply => undef,
2976 tooltip => "Shows the items currently for sale in this shop",
2977 },
2978 "c/resistances" => {
2979 id => "infobox",
2980 title => "Resistances",
2981 reply => undef,
2982 tooltip => "Shows your resistances",
2983 },
2984 "c/pets" => {
2985 id => "infobox",
2986 title => "Pets",
2987 reply => undef,
2988 tooltip => "Shows information abotu your pets/a specific pet",
2989 },
2990 "c/perceiveself" => {
2991 id => "infobox",
2992 title => "Perceive Self",
2993 reply => undef,
2994 tooltip => "You gained detailed knowledge about yourself",
2995 },
2996 "c/uptime" => {
2997 id => "infobox",
2998 title => "Uptime",
2999 reply => undef,
3000 tooltip => "How long the server has been running since last restart",
3001 },
3002 "c/mapinfo" => {
3003 id => "infobox",
3004 title => "Map Info",
3005 reply => undef,
3006 tooltip => "Information related to the maps",
3007 },
3008 "c/party" => {
3009 id => "party",
3010 title => "Party",
3011 reply => "gsay ",
3012 tooltip => "Messages and chat related to your party",
3013 },
3014 "c/death" => {
3015 id => "death",
3016 title => "Death",
3017 reply => undef,
3018 tooltip => "Reason for and more info about your most recent death",
3019 },
3020 "c/say" => $SAY_CHANNEL,
3021 "c/chat" => $CHAT_CHANNEL,
2691); 3022);
2692 3023
2693sub cf::client::send_msg { 3024sub cf::client::send_msg {
2694 my ($self, $channel, $msg, $color, @extra) = @_; 3025 my ($self, $channel, $msg, $color, @extra) = @_;
2695 3026
2696 $msg = $self->pl->expand_cfpod ($msg); 3027 $msg = $self->pl->expand_cfpod ($msg)
3028 unless $color & cf::NDI_VERBATIM;
2697 3029
2698 $color &= cf::NDI_CLIENT_MASK; # just in case... 3030 $color &= cf::NDI_CLIENT_MASK; # just in case...
2699 3031
2700 # check predefined channels, for the benefit of C 3032 # check predefined channels, for the benefit of C
2701 if ($CHANNEL{$channel}) { 3033 if ($CHANNEL{$channel}) {
2702 $channel = $CHANNEL{$channel}; 3034 $channel = $CHANNEL{$channel};
2703 3035
2704 $self->ext_msg (channel_info => $channel) 3036 $self->ext_msg (channel_info => $channel);
2705 if $self->can_msg;
2706
2707 $channel = $channel->{id}; 3037 $channel = $channel->{id};
2708 3038
2709 } elsif (ref $channel) { 3039 } elsif (ref $channel) {
2710 # send meta info to client, if not yet sent 3040 # send meta info to client, if not yet sent
2711 unless (exists $self->{channel}{$channel->{id}}) { 3041 unless (exists $self->{channel}{$channel->{id}}) {
2712 $self->{channel}{$channel->{id}} = $channel; 3042 $self->{channel}{$channel->{id}} = $channel;
2713 $self->ext_msg (channel_info => $channel) 3043 $self->ext_msg (channel_info => $channel);
2714 if $self->can_msg;
2715 } 3044 }
2716 3045
2717 $channel = $channel->{id}; 3046 $channel = $channel->{id};
2718 } 3047 }
2719 3048
2720 return unless @extra || length $msg; 3049 return unless @extra || length $msg;
2721 3050
2722 if ($self->can_msg) {
2723 # default colour, mask it out 3051 # default colour, mask it out
2724 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF) 3052 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2725 if $color & cf::NDI_DEF; 3053 if $color & cf::NDI_DEF;
2726 3054
2727 $self->send_packet ("msg " . $self->{json_coder}->encode ( 3055 my $pkt = "msg "
3056 . $self->{json_coder}->encode (
2728 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra])); 3057 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2729 } else { 3058 );
2730 if ($color >= 0) {
2731 # replace some tags by gcfclient-compatible ones
2732 for ($msg) {
2733 1 while
2734 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2735 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2736 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2737 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2738 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2739 }
2740 3059
2741 $color &= cf::NDI_COLOR_MASK; 3060 $self->send_big_packet ($pkt);
2742
2743 utf8::encode $msg;
2744
2745 if (0 && $msg =~ /\[/) {
2746 # COMMAND/INFO
2747 $self->send_packet ("drawextinfo $color 10 8 $msg")
2748 } else {
2749 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2750 $self->send_packet ("drawinfo $color $msg")
2751 }
2752 }
2753 }
2754} 3061}
2755 3062
2756=item $client->ext_msg ($type, @msg) 3063=item $client->ext_msg ($type, @msg)
2757 3064
2758Sends an ext event to the client. 3065Sends an ext event to the client.
… …
2761 3068
2762sub cf::client::ext_msg($$@) { 3069sub cf::client::ext_msg($$@) {
2763 my ($self, $type, @msg) = @_; 3070 my ($self, $type, @msg) = @_;
2764 3071
2765 if ($self->extcmd == 2) { 3072 if ($self->extcmd == 2) {
2766 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 3073 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2767 } elsif ($self->extcmd == 1) { # TODO: remove 3074 } elsif ($self->extcmd == 1) { # TODO: remove
2768 push @msg, msgtype => "event_$type"; 3075 push @msg, msgtype => "event_$type";
2769 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3076 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2770 } 3077 }
2771} 3078}
2772 3079
2773=item $client->ext_reply ($msgid, @msg) 3080=item $client->ext_reply ($msgid, @msg)
2774 3081
… …
2778 3085
2779sub cf::client::ext_reply($$@) { 3086sub cf::client::ext_reply($$@) {
2780 my ($self, $id, @msg) = @_; 3087 my ($self, $id, @msg) = @_;
2781 3088
2782 if ($self->extcmd == 2) { 3089 if ($self->extcmd == 2) {
2783 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg])); 3090 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2784 } elsif ($self->extcmd == 1) { 3091 } elsif ($self->extcmd == 1) {
2785 #TODO: version 1, remove 3092 #TODO: version 1, remove
2786 unshift @msg, msgtype => "reply", msgid => $id; 3093 unshift @msg, msgtype => "reply", msgid => $id;
2787 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3094 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2788 } 3095 }
2789} 3096}
2790 3097
2791=item $success = $client->query ($flags, "text", \&cb) 3098=item $success = $client->query ($flags, "text", \&cb)
2792 3099
… …
2893 3200
2894 $coro 3201 $coro
2895} 3202}
2896 3203
2897cf::client->attach ( 3204cf::client->attach (
2898 on_destroy => sub { 3205 on_client_destroy => sub {
2899 my ($ns) = @_; 3206 my ($ns) = @_;
2900 3207
2901 $_->cancel for values %{ (delete $ns->{_coro}) || {} }; 3208 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
2902 }, 3209 },
2903); 3210);
… …
2919our $safe_hole = new Safe::Hole; 3226our $safe_hole = new Safe::Hole;
2920 3227
2921$SIG{FPE} = 'IGNORE'; 3228$SIG{FPE} = 'IGNORE';
2922 3229
2923$safe->permit_only (Opcode::opset qw( 3230$safe->permit_only (Opcode::opset qw(
2924 :base_core :base_mem :base_orig :base_math 3231 :base_core :base_mem :base_orig :base_math :base_loop
2925 grepstart grepwhile mapstart mapwhile 3232 grepstart grepwhile mapstart mapwhile
2926 sort time 3233 sort time
2927)); 3234));
2928 3235
2929# here we export the classes and methods available to script code 3236# here we export the classes and methods available to script code
… …
2932 3239
2933The following functions and methods are available within a safe environment: 3240The following functions and methods are available within a safe environment:
2934 3241
2935 cf::object 3242 cf::object
2936 contr pay_amount pay_player map x y force_find force_add destroy 3243 contr pay_amount pay_player map x y force_find force_add destroy
2937 insert remove name archname title slaying race decrease_ob_nr 3244 insert remove name archname title slaying race decrease split
3245 value
2938 3246
2939 cf::object::player 3247 cf::object::player
2940 player 3248 player
2941 3249
2942 cf::player 3250 cf::player
… …
2947 3255
2948=cut 3256=cut
2949 3257
2950for ( 3258for (
2951 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3259 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2952 insert remove inv name archname title slaying race 3260 insert remove inv nrof name archname title slaying race
2953 decrease_ob_nr destroy)], 3261 decrease split destroy change_exp value msg lore send_msg)],
2954 ["cf::object::player" => qw(player)], 3262 ["cf::object::player" => qw(player)],
2955 ["cf::player" => qw(peaceful)], 3263 ["cf::player" => qw(peaceful send_msg)],
2956 ["cf::map" => qw(trigger)], 3264 ["cf::map" => qw(trigger)],
2957) { 3265) {
2958 no strict 'refs'; 3266 no strict 'refs';
2959 my ($pkg, @funs) = @$_; 3267 my ($pkg, @funs) = @$_;
2960 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3268 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
… …
2978 3286
2979 my $qcode = $code; 3287 my $qcode = $code;
2980 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3288 $qcode =~ s/"/‟/g; # not allowed in #line filenames
2981 $qcode =~ s/\n/\\n/g; 3289 $qcode =~ s/\n/\\n/g;
2982 3290
3291 %vars = (_dummy => 0) unless %vars;
3292
3293 my @res;
2983 local $_; 3294 local $_;
2984 local @safe::cf::_safe_eval_args = values %vars;
2985 3295
2986 my $eval = 3296 my $eval =
2987 "do {\n" 3297 "do {\n"
2988 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3298 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
2989 . "#line 0 \"{$qcode}\"\n" 3299 . "#line 0 \"{$qcode}\"\n"
2990 . $code 3300 . $code
2991 . "\n}" 3301 . "\n}"
2992 ; 3302 ;
2993 3303
3304 if ($CFG{safe_eval}) {
2994 sub_generation_inc; 3305 sub_generation_inc;
3306 local @safe::cf::_safe_eval_args = values %vars;
2995 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3307 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
2996 sub_generation_inc; 3308 sub_generation_inc;
3309 } else {
3310 local @cf::_safe_eval_args = values %vars;
3311 @res = wantarray ? eval eval : scalar eval $eval;
3312 }
2997 3313
2998 if ($@) { 3314 if ($@) {
2999 warn "$@"; 3315 warn "$@";
3000 warn "while executing safe code '$code'\n"; 3316 warn "while executing safe code '$code'\n";
3001 warn "with arguments " . (join " ", %vars) . "\n"; 3317 warn "with arguments " . (join " ", %vars) . "\n";
… …
3020=cut 3336=cut
3021 3337
3022sub register_script_function { 3338sub register_script_function {
3023 my ($fun, $cb) = @_; 3339 my ($fun, $cb) = @_;
3024 3340
3025 no strict 'refs'; 3341 $fun = "safe::$fun" if $CFG{safe_eval};
3026 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3342 *$fun = $safe_hole->wrap ($cb);
3027} 3343}
3028 3344
3029=back 3345=back
3030 3346
3031=cut 3347=cut
… …
3052 3368
3053 $facedata->{version} == 2 3369 $facedata->{version} == 2
3054 or cf::cleanup "$path: version mismatch, cannot proceed."; 3370 or cf::cleanup "$path: version mismatch, cannot proceed.";
3055 3371
3056 # patch in the exptable 3372 # patch in the exptable
3373 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3057 $facedata->{resource}{"res/exp_table"} = { 3374 $facedata->{resource}{"res/exp_table"} = {
3058 type => FT_RSRC, 3375 type => FT_RSRC,
3059 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]), 3376 data => $exp_table,
3377 hash => (Digest::MD5::md5 $exp_table),
3060 }; 3378 };
3061 cf::cede_to_tick; 3379 cf::cede_to_tick;
3062 3380
3063 { 3381 {
3064 my $faces = $facedata->{faceinfo}; 3382 my $faces = $facedata->{faceinfo};
3065 3383
3066 while (my ($face, $info) = each %$faces) { 3384 while (my ($face, $info) = each %$faces) {
3067 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3385 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3386
3068 cf::face::set_visibility $idx, $info->{visibility}; 3387 cf::face::set_visibility $idx, $info->{visibility};
3069 cf::face::set_magicmap $idx, $info->{magicmap}; 3388 cf::face::set_magicmap $idx, $info->{magicmap};
3070 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3389 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3071 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3390 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3072 3391
3073 cf::cede_to_tick; 3392 cf::cede_to_tick;
3074 } 3393 }
3075 3394
3076 while (my ($face, $info) = each %$faces) { 3395 while (my ($face, $info) = each %$faces) {
3077 next unless $info->{smooth}; 3396 next unless $info->{smooth};
3397
3078 my $idx = cf::face::find $face 3398 my $idx = cf::face::find $face
3079 or next; 3399 or next;
3400
3080 if (my $smooth = cf::face::find $info->{smooth}) { 3401 if (my $smooth = cf::face::find $info->{smooth}) {
3081 cf::face::set_smooth $idx, $smooth; 3402 cf::face::set_smooth $idx, $smooth;
3082 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3403 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3083 } else { 3404 } else {
3084 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3405 warn "smooth face '$info->{smooth}' not found for face '$face'";
… …
3098 3419
3099 cf::anim::invalidate_all; # d'oh 3420 cf::anim::invalidate_all; # d'oh
3100 } 3421 }
3101 3422
3102 { 3423 {
3103 # TODO: for gcfclient pleasure, we should give resources
3104 # that gcfclient doesn't grok a >10000 face index.
3105 my $res = $facedata->{resource}; 3424 my $res = $facedata->{resource};
3106 3425
3107 my $soundconf = delete $res->{"res/sound.conf"};
3108
3109 while (my ($name, $info) = each %$res) { 3426 while (my ($name, $info) = each %$res) {
3427 if (defined $info->{type}) {
3110 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3428 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3111 my $data;
3112 3429
3113 if ($info->{type} & 1) { 3430 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3114 # prepend meta info 3431 cf::face::set_type $idx, $info->{type};
3115
3116 my $meta = $enc->encode ({
3117 name => $name,
3118 %{ $info->{meta} || {} },
3119 });
3120
3121 $data = pack "(w/a*)*", $meta, $info->{data};
3122 } else { 3432 } else {
3123 $data = $info->{data}; 3433 $RESOURCE{$name} = $info;
3124 } 3434 }
3125 3435
3126 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3127 cf::face::set_type $idx, $info->{type};
3128
3129 cf::cede_to_tick; 3436 cf::cede_to_tick;
3130 } 3437 }
3131
3132 if ($soundconf) {
3133 $soundconf = $enc->decode (delete $soundconf->{data});
3134
3135 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3136 my $sound = $soundconf->{compat}[$_]
3137 or next;
3138
3139 my $face = cf::face::find "sound/$sound->[1]";
3140 cf::sound::set $sound->[0] => $face;
3141 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3142 }
3143
3144 while (my ($k, $v) = each %{$soundconf->{event}}) {
3145 my $face = cf::face::find "sound/$v";
3146 cf::sound::set $k => $face;
3147 }
3148 }
3149 } 3438 }
3439
3440 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3150 3441
3151 1 3442 1
3152} 3443}
3444
3445cf::global->attach (on_resource_update => sub {
3446 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3447 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3448
3449 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3450 my $sound = $soundconf->{compat}[$_]
3451 or next;
3452
3453 my $face = cf::face::find "sound/$sound->[1]";
3454 cf::sound::set $sound->[0] => $face;
3455 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3456 }
3457
3458 while (my ($k, $v) = each %{$soundconf->{event}}) {
3459 my $face = cf::face::find "sound/$v";
3460 cf::sound::set $k => $face;
3461 }
3462 }
3463});
3153 3464
3154register_exticmd fx_want => sub { 3465register_exticmd fx_want => sub {
3155 my ($ns, $want) = @_; 3466 my ($ns, $want) = @_;
3156 3467
3157 while (my ($k, $v) = each %$want) { 3468 while (my ($k, $v) = each %$want) {
3158 $ns->fx_want ($k, $v); 3469 $ns->fx_want ($k, $v);
3159 } 3470 }
3160}; 3471};
3472
3473sub load_resource_file($) {
3474 my $guard = lock_acquire "load_resource_file";
3475
3476 my $status = load_resource_file_ $_[0];
3477 get_slot 0.1, 100;
3478 cf::arch::commit_load;
3479
3480 $status
3481}
3161 3482
3162sub reload_regions { 3483sub reload_regions {
3163 # HACK to clear player env face cache, we need some signal framework 3484 # HACK to clear player env face cache, we need some signal framework
3164 # for this (global event?) 3485 # for this (global event?)
3165 %ext::player_env::MUSIC_FACE_CACHE = (); 3486 %ext::player_env::MUSIC_FACE_CACHE = ();
… …
3179} 3500}
3180 3501
3181sub reload_archetypes { 3502sub reload_archetypes {
3182 load_resource_file "$DATADIR/archetypes" 3503 load_resource_file "$DATADIR/archetypes"
3183 or die "unable to load archetypes\n"; 3504 or die "unable to load archetypes\n";
3184 #d# NEED to laod twice to resolve forward references
3185 # this really needs to be done in an extra post-pass
3186 # (which needs to be synchronous, so solve it differently)
3187 load_resource_file "$DATADIR/archetypes"
3188 or die "unable to load archetypes\n";
3189} 3505}
3190 3506
3191sub reload_treasures { 3507sub reload_treasures {
3192 load_resource_file "$DATADIR/treasures" 3508 load_resource_file "$DATADIR/treasures"
3193 or die "unable to load treasurelists\n"; 3509 or die "unable to load treasurelists\n";
3194} 3510}
3195 3511
3196sub reload_resources { 3512sub reload_resources {
3197 warn "reloading resource files...\n"; 3513 warn "reloading resource files...\n";
3198 3514
3515 reload_facedata;
3516 reload_archetypes;
3199 reload_regions; 3517 reload_regions;
3200 reload_facedata;
3201 #reload_archetypes;#d#
3202 reload_archetypes;
3203 reload_treasures; 3518 reload_treasures;
3204 3519
3205 warn "finished reloading resource files\n"; 3520 warn "finished reloading resource files\n";
3206} 3521}
3207 3522
3208sub init {
3209 reload_resources;
3210}
3211
3212sub reload_config { 3523sub reload_config {
3524 warn "reloading config file...\n";
3525
3213 open my $fh, "<:utf8", "$CONFDIR/config" 3526 open my $fh, "<:utf8", "$CONFDIR/config"
3214 or return; 3527 or return;
3215 3528
3216 local $/; 3529 local $/;
3217 *CFG = YAML::Syck::Load <$fh>; 3530 *CFG = YAML::XS::Load scalar <$fh>;
3218 3531
3219 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3532 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3220 3533
3221 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3534 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3222 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3535 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3223 3536
3224 if (exists $CFG{mlockall}) { 3537 if (exists $CFG{mlockall}) {
… …
3226 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 3539 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3227 and die "WARNING: m(un)lockall failed: $!\n"; 3540 and die "WARNING: m(un)lockall failed: $!\n";
3228 }; 3541 };
3229 warn $@ if $@; 3542 warn $@ if $@;
3230 } 3543 }
3544
3545 warn "finished reloading resource files\n";
3546}
3547
3548sub pidfile() {
3549 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3550 or die "$PIDFILE: $!";
3551 flock $fh, &Fcntl::LOCK_EX
3552 or die "$PIDFILE: flock: $!";
3553 $fh
3554}
3555
3556# make sure only one server instance is running at any one time
3557sub atomic {
3558 my $fh = pidfile;
3559
3560 my $pid = <$fh>;
3561 kill 9, $pid if $pid > 0;
3562
3563 seek $fh, 0, 0;
3564 print $fh $$;
3565}
3566
3567sub main_loop {
3568 warn "EV::loop starting\n";
3569 if (1) {
3570 EV::loop;
3571 }
3572 warn "EV::loop returned\n";
3573 goto &main_loop unless $REALLY_UNLOOP;
3231} 3574}
3232 3575
3233sub main { 3576sub main {
3577 cf::init_globals; # initialise logging
3578
3579 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3580 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3581 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3582 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3583
3584 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3585
3234 # we must not ever block the main coroutine 3586 # we must not ever block the main coroutine
3235 local $Coro::idle = sub { 3587 local $Coro::idle = sub {
3236 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3588 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3237 (async { 3589 (async {
3238 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3590 $Coro::current->{desc} = "IDLE BUG HANDLER";
3239 Event::one_event; 3591 EV::loop EV::LOOP_ONESHOT;
3240 })->prio (Coro::PRIO_MAX); 3592 })->prio (Coro::PRIO_MAX);
3241 }; 3593 };
3242 3594
3595 evthread_start IO::AIO::poll_fileno;
3596
3597 cf::sync_job {
3598 cf::init_experience;
3599 cf::init_anim;
3600 cf::init_attackmess;
3601 cf::init_dynamic;
3602
3603 cf::load_settings;
3604 cf::load_materials;
3605
3606 reload_resources;
3243 reload_config; 3607 reload_config;
3244 db_init; 3608 db_init;
3609
3610 cf::init_uuid;
3611 cf::init_signals;
3612 cf::init_skills;
3613
3614 cf::init_beforeplay;
3615
3616 atomic;
3617
3245 load_extensions; 3618 load_extensions;
3246 3619
3247 $TICK_WATCHER->start; 3620 utime time, time, $RUNTIMEFILE;
3248 Event::loop; 3621
3622 # no (long-running) fork's whatsoever before this point(!)
3623 use POSIX ();
3624 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3625
3626 (pop @POST_INIT)->(0) while @POST_INIT;
3627 };
3628
3629 cf::object::thawer::errors_are_fatal 0;
3630 warn "parse errors in files are no longer fatal from this point on.\n";
3631
3632 main_loop;
3249} 3633}
3250 3634
3251############################################################################# 3635#############################################################################
3252# initialisation and cleanup 3636# initialisation and cleanup
3253 3637
3254# install some emergency cleanup handlers 3638# install some emergency cleanup handlers
3255BEGIN { 3639BEGIN {
3640 our %SIGWATCHER = ();
3256 for my $signal (qw(INT HUP TERM)) { 3641 for my $signal (qw(INT HUP TERM)) {
3257 Event->signal ( 3642 $SIGWATCHER{$signal} = AE::signal $signal, sub {
3258 reentrant => 0,
3259 data => WF_AUTOCANCEL,
3260 signal => $signal,
3261 prio => 0,
3262 cb => sub {
3263 cf::cleanup "SIG$signal"; 3643 cf::cleanup "SIG$signal";
3264 },
3265 ); 3644 };
3266 } 3645 }
3267} 3646}
3268 3647
3269sub write_runtime { 3648sub write_runtime_sync {
3270 my $runtime = "$LOCALDIR/runtime"; 3649 my $t0 = AE::time;
3271 3650
3272 # first touch the runtime file to show we are still running: 3651 # first touch the runtime file to show we are still running:
3273 # the fsync below can take a very very long time. 3652 # the fsync below can take a very very long time.
3274 3653
3275 IO::AIO::aio_utime $runtime, undef, undef; 3654 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3276 3655
3277 my $guard = cf::lock_acquire "write_runtime"; 3656 my $guard = cf::lock_acquire "write_runtime";
3278 3657
3279 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 3658 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3280 or return; 3659 or return;
3281 3660
3282 my $value = $cf::RUNTIME + 90 + 10; 3661 my $value = $cf::RUNTIME + 90 + 10;
3283 # 10 is the runtime save interval, for a monotonic clock 3662 # 10 is the runtime save interval, for a monotonic clock
3284 # 60 allows for the watchdog to kill the server. 3663 # 60 allows for the watchdog to kill the server.
… …
3294 aio_utime $fh, undef, undef; 3673 aio_utime $fh, undef, undef;
3295 3674
3296 close $fh 3675 close $fh
3297 or return; 3676 or return;
3298 3677
3299 aio_rename "$runtime~", $runtime 3678 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3300 and return; 3679 and return;
3301 3680
3302 warn "runtime file written.\n"; 3681 warn sprintf "runtime file written (%gs).\n", AE::time - $t0;
3303 3682
3304 1 3683 1
3684}
3685
3686our $uuid_lock;
3687our $uuid_skip;
3688
3689sub write_uuid_sync($) {
3690 $uuid_skip ||= $_[0];
3691
3692 return if $uuid_lock;
3693 local $uuid_lock = 1;
3694
3695 my $uuid = "$LOCALDIR/uuid";
3696
3697 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3698 or return;
3699
3700 my $value = uuid_seq uuid_cur;
3701
3702 unless ($value) {
3703 warn "cowardly refusing to write zero uuid value!\n";
3704 return;
3705 }
3706
3707 my $value = uuid_str $value + $uuid_skip;
3708 $uuid_skip = 0;
3709
3710 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3711 and return;
3712
3713 # always fsync - this file is important
3714 aio_fsync $fh
3715 and return;
3716
3717 close $fh
3718 or return;
3719
3720 aio_rename "$uuid~", $uuid
3721 and return;
3722
3723 warn "uuid file written ($value).\n";
3724
3725 1
3726
3727}
3728
3729sub write_uuid($$) {
3730 my ($skip, $sync) = @_;
3731
3732 $sync ? write_uuid_sync $skip
3733 : async { write_uuid_sync $skip };
3305} 3734}
3306 3735
3307sub emergency_save() { 3736sub emergency_save() {
3308 my $freeze_guard = cf::freeze_mainloop; 3737 my $freeze_guard = cf::freeze_mainloop;
3309 3738
3310 warn "enter emergency perl save\n"; 3739 warn "emergency_perl_save: enter\n";
3311 3740
3312 cf::sync_job { 3741 cf::sync_job {
3742 # this is a trade-off: we want to be very quick here, so
3743 # save all maps without fsync, and later call a global sync
3744 # (which in turn might be very very slow)
3745 local $USE_FSYNC = 0;
3746
3313 # use a peculiar iteration method to avoid tripping on perl 3747 # use a peculiar iteration method to avoid tripping on perl
3314 # refcount bugs in for. also avoids problems with players 3748 # refcount bugs in for. also avoids problems with players
3315 # and maps saved/destroyed asynchronously. 3749 # and maps saved/destroyed asynchronously.
3316 warn "begin emergency player save\n"; 3750 warn "emergency_perl_save: begin player save\n";
3317 for my $login (keys %cf::PLAYER) { 3751 for my $login (keys %cf::PLAYER) {
3318 my $pl = $cf::PLAYER{$login} or next; 3752 my $pl = $cf::PLAYER{$login} or next;
3319 $pl->valid or next; 3753 $pl->valid or next;
3320 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt 3754 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3321 $pl->save; 3755 $pl->save;
3322 } 3756 }
3323 warn "end emergency player save\n"; 3757 warn "emergency_perl_save: end player save\n";
3324 3758
3325 warn "begin emergency map save\n"; 3759 warn "emergency_perl_save: begin map save\n";
3326 for my $path (keys %cf::MAP) { 3760 for my $path (keys %cf::MAP) {
3327 my $map = $cf::MAP{$path} or next; 3761 my $map = $cf::MAP{$path} or next;
3328 $map->valid or next; 3762 $map->valid or next;
3329 $map->save; 3763 $map->save;
3330 } 3764 }
3331 warn "end emergency map save\n"; 3765 warn "emergency_perl_save: end map save\n";
3332 3766
3333 warn "begin emergency database checkpoint\n"; 3767 warn "emergency_perl_save: begin database checkpoint\n";
3334 BDB::db_env_txn_checkpoint $DB_ENV; 3768 BDB::db_env_txn_checkpoint $DB_ENV;
3335 warn "end emergency database checkpoint\n"; 3769 warn "emergency_perl_save: end database checkpoint\n";
3770
3771 warn "emergency_perl_save: begin write uuid\n";
3772 write_uuid_sync 1;
3773 warn "emergency_perl_save: end write uuid\n";
3336 }; 3774 };
3337 3775
3776 warn "emergency_perl_save: starting sync()\n";
3777 IO::AIO::aio_sync sub {
3778 warn "emergency_perl_save: finished sync()\n";
3779 };
3780
3338 warn "leave emergency perl save\n"; 3781 warn "emergency_perl_save: leave\n";
3339} 3782}
3340 3783
3341sub post_cleanup { 3784sub post_cleanup {
3342 my ($make_core) = @_; 3785 my ($make_core) = @_;
3343 3786
3344 warn Carp::longmess "post_cleanup backtrace" 3787 warn Carp::longmess "post_cleanup backtrace"
3345 if $make_core; 3788 if $make_core;
3789
3790 my $fh = pidfile;
3791 unlink $PIDFILE if <$fh> == $$;
3792}
3793
3794# a safer delete_package, copied from Symbol
3795sub clear_package($) {
3796 my $pkg = shift;
3797
3798 # expand to full symbol table name if needed
3799 unless ($pkg =~ /^main::.*::$/) {
3800 $pkg = "main$pkg" if $pkg =~ /^::/;
3801 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3802 $pkg .= '::' unless $pkg =~ /::$/;
3803 }
3804
3805 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3806 my $stem_symtab = *{$stem}{HASH};
3807
3808 defined $stem_symtab and exists $stem_symtab->{$leaf}
3809 or return;
3810
3811 # clear all symbols
3812 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3813 for my $name (keys %$leaf_symtab) {
3814 _gv_clear *{"$pkg$name"};
3815# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3816 }
3346} 3817}
3347 3818
3348sub do_reload_perl() { 3819sub do_reload_perl() {
3349 # can/must only be called in main 3820 # can/must only be called in main
3350 if ($Coro::current != $Coro::main) { 3821 if (in_main) {
3351 warn "can only reload from main coroutine"; 3822 warn "can only reload from main coroutine";
3352 return; 3823 return;
3353 } 3824 }
3354 3825
3826 return if $RELOAD++;
3827
3828 my $t1 = AE::time;
3829
3830 while ($RELOAD) {
3355 warn "reloading..."; 3831 warn "reloading...";
3356 3832
3357 warn "entering sync_job"; 3833 warn "entering sync_job";
3358 3834
3359 cf::sync_job { 3835 cf::sync_job {
3360 cf::write_runtime; # external watchdog should not bark 3836 cf::write_runtime_sync; # external watchdog should not bark
3361 cf::emergency_save; 3837 cf::emergency_save;
3362 cf::write_runtime; # external watchdog should not bark 3838 cf::write_runtime_sync; # external watchdog should not bark
3363 3839
3364 warn "syncing database to disk"; 3840 warn "syncing database to disk";
3365 BDB::db_env_txn_checkpoint $DB_ENV; 3841 BDB::db_env_txn_checkpoint $DB_ENV;
3366 3842
3367 # if anything goes wrong in here, we should simply crash as we already saved 3843 # if anything goes wrong in here, we should simply crash as we already saved
3368 3844
3369 warn "cancelling all WF_AUTOCANCEL watchers";
3370 for (Event::all_watchers) {
3371 $_->cancel if $_->data & WF_AUTOCANCEL;
3372 }
3373
3374 warn "flushing outstanding aio requests"; 3845 warn "flushing outstanding aio requests";
3375 for (;;) {
3376 BDB::flush;
3377 IO::AIO::flush;
3378 Coro::cede_notself;
3379 last unless IO::AIO::nreqs || BDB::nreqs; 3846 while (IO::AIO::nreqs || BDB::nreqs) {
3380 warn "iterate..."; 3847 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3381 }
3382
3383 ++$RELOAD;
3384
3385 warn "cancelling all extension coros";
3386 $_->cancel for values %EXT_CORO;
3387 %EXT_CORO = ();
3388
3389 warn "removing commands";
3390 %COMMAND = ();
3391
3392 warn "removing ext/exti commands";
3393 %EXTCMD = ();
3394 %EXTICMD = ();
3395
3396 warn "unloading/nuking all extensions";
3397 for my $pkg (@EXTS) {
3398 warn "... unloading $pkg";
3399
3400 if (my $cb = $pkg->can ("unload")) {
3401 eval {
3402 $cb->($pkg);
3403 1
3404 } or warn "$pkg unloaded, but with errors: $@";
3405 } 3848 }
3406 3849
3407 warn "... nuking $pkg"; 3850 warn "cancelling all extension coros";
3408 Symbol::delete_package $pkg; 3851 $_->cancel for values %EXT_CORO;
3409 } 3852 %EXT_CORO = ();
3410 3853
3411 warn "unloading all perl modules loaded from $LIBDIR"; 3854 warn "removing commands";
3412 while (my ($k, $v) = each %INC) { 3855 %COMMAND = ();
3413 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3414 3856
3857 warn "removing ext/exti commands";
3858 %EXTCMD = ();
3859 %EXTICMD = ();
3860
3861 warn "unloading/nuking all extensions";
3862 for my $pkg (@EXTS) {
3415 warn "... unloading $k"; 3863 warn "... unloading $pkg";
3416 delete $INC{$k};
3417 3864
3418 $k =~ s/\.pm$//;
3419 $k =~ s/\//::/g;
3420
3421 if (my $cb = $k->can ("unload_module")) { 3865 if (my $cb = $pkg->can ("unload")) {
3866 eval {
3422 $cb->(); 3867 $cb->($pkg);
3868 1
3869 } or warn "$pkg unloaded, but with errors: $@";
3870 }
3871
3872 warn "... clearing $pkg";
3873 clear_package $pkg;
3423 } 3874 }
3424 3875
3425 Symbol::delete_package $k; 3876 warn "unloading all perl modules loaded from $LIBDIR";
3877 while (my ($k, $v) = each %INC) {
3878 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3879
3880 warn "... unloading $k";
3881 delete $INC{$k};
3882
3883 $k =~ s/\.pm$//;
3884 $k =~ s/\//::/g;
3885
3886 if (my $cb = $k->can ("unload_module")) {
3887 $cb->();
3888 }
3889
3890 clear_package $k;
3426 } 3891 }
3427 3892
3428 warn "getting rid of safe::, as good as possible"; 3893 warn "getting rid of safe::, as good as possible";
3429 Symbol::delete_package "safe::$_" 3894 clear_package "safe::$_"
3430 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3895 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3431 3896
3432 warn "unloading cf.pm \"a bit\""; 3897 warn "unloading cf.pm \"a bit\"";
3433 delete $INC{"cf.pm"}; 3898 delete $INC{"cf.pm"};
3434 delete $INC{"cf/pod.pm"}; 3899 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3435 3900
3436 # don't, removes xs symbols, too, 3901 # don't, removes xs symbols, too,
3437 # and global variables created in xs 3902 # and global variables created in xs
3438 #Symbol::delete_package __PACKAGE__; 3903 #clear_package __PACKAGE__;
3439 3904
3440 warn "unload completed, starting to reload now"; 3905 warn "unload completed, starting to reload now";
3441 3906
3442 warn "reloading cf.pm"; 3907 warn "reloading cf.pm";
3443 require cf; 3908 require cf;
3444 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3909 cf::_connect_to_perl_1;
3445 3910
3446 warn "loading config and database again"; 3911 warn "loading config and database again";
3447 cf::reload_config; 3912 cf::reload_config;
3448 3913
3449 warn "loading extensions"; 3914 warn "loading extensions";
3450 cf::load_extensions; 3915 cf::load_extensions;
3451 3916
3917 if ($REATTACH_ON_RELOAD) {
3452 warn "reattaching attachments to objects/players"; 3918 warn "reattaching attachments to objects/players";
3453 _global_reattach; # objects, sockets 3919 _global_reattach; # objects, sockets
3454 warn "reattaching attachments to maps"; 3920 warn "reattaching attachments to maps";
3455 reattach $_ for values %MAP; 3921 reattach $_ for values %MAP;
3456 warn "reattaching attachments to players"; 3922 warn "reattaching attachments to players";
3457 reattach $_ for values %PLAYER; 3923 reattach $_ for values %PLAYER;
3924 }
3458 3925
3926 warn "running post_init jobs";
3927 (pop @POST_INIT)->(1) while @POST_INIT;
3928
3459 warn "leaving sync_job"; 3929 warn "leaving sync_job";
3460 3930
3461 1 3931 1
3462 } or do { 3932 } or do {
3463 warn $@; 3933 warn $@;
3464 warn "error while reloading, exiting."; 3934 cf::cleanup "error while reloading, exiting.";
3465 exit 1;
3466 }; 3935 };
3467 3936
3468 warn "reloaded"; 3937 warn "reloaded";
3938 --$RELOAD;
3939 }
3940
3941 $t1 = AE::time - $t1;
3942 warn "reload completed in ${t1}s\n";
3469}; 3943};
3470 3944
3471our $RELOAD_WATCHER; # used only during reload 3945our $RELOAD_WATCHER; # used only during reload
3472 3946
3473sub reload_perl() { 3947sub reload_perl() {
3474 # doing reload synchronously and two reloads happen back-to-back, 3948 # doing reload synchronously and two reloads happen back-to-back,
3475 # coro crashes during coro_state_free->destroy here. 3949 # coro crashes during coro_state_free->destroy here.
3476 3950
3477 $RELOAD_WATCHER ||= Event->timer ( 3951 $RELOAD_WATCHER ||= cf::async {
3478 reentrant => 0, 3952 Coro::AIO::aio_wait cache_extensions;
3479 after => 0, 3953
3480 data => WF_AUTOCANCEL, 3954 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
3481 cb => sub {
3482 do_reload_perl; 3955 do_reload_perl;
3483 undef $RELOAD_WATCHER; 3956 undef $RELOAD_WATCHER;
3484 }, 3957 };
3485 ); 3958 };
3486} 3959}
3487 3960
3488register_command "reload" => sub { 3961register_command "reload" => sub {
3489 my ($who, $arg) = @_; 3962 my ($who, $arg) = @_;
3490 3963
… …
3503 3976
3504our @WAIT_FOR_TICK; 3977our @WAIT_FOR_TICK;
3505our @WAIT_FOR_TICK_BEGIN; 3978our @WAIT_FOR_TICK_BEGIN;
3506 3979
3507sub wait_for_tick { 3980sub wait_for_tick {
3508 return unless $TICK_WATCHER->is_active;
3509 return if $Coro::current == $Coro::main; 3981 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3510 3982
3511 my $signal = new Coro::Signal; 3983 my $signal = new Coro::Signal;
3512 push @WAIT_FOR_TICK, $signal; 3984 push @WAIT_FOR_TICK, $signal;
3513 $signal->wait; 3985 $signal->wait;
3514} 3986}
3515 3987
3516sub wait_for_tick_begin { 3988sub wait_for_tick_begin {
3517 return unless $TICK_WATCHER->is_active;
3518 return if $Coro::current == $Coro::main; 3989 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3519 3990
3520 my $signal = new Coro::Signal; 3991 my $signal = new Coro::Signal;
3521 push @WAIT_FOR_TICK_BEGIN, $signal; 3992 push @WAIT_FOR_TICK_BEGIN, $signal;
3522 $signal->wait; 3993 $signal->wait;
3523} 3994}
3524 3995
3525$TICK_WATCHER = Event->timer ( 3996sub tick {
3526 reentrant => 0,
3527 parked => 1,
3528 prio => 0,
3529 at => $NEXT_TICK || $TICK,
3530 data => WF_AUTOCANCEL,
3531 cb => sub {
3532 if ($Coro::current != $Coro::main) { 3997 if ($Coro::current != $Coro::main) {
3533 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3998 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3534 unless ++$bug_warning > 10; 3999 unless ++$bug_warning > 10;
3535 return; 4000 return;
3536 } 4001 }
3537 4002
3538 $NOW = $tick_start = Event::time;
3539
3540 cf::server_tick; # one server iteration 4003 cf::server_tick; # one server iteration
3541 4004
3542 $RUNTIME += $TICK; 4005 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
3543 $NEXT_TICK += $TICK;
3544 4006
3545 if ($NOW >= $NEXT_RUNTIME_WRITE) { 4007 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3546 $NEXT_RUNTIME_WRITE = $NOW + 10; 4008 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3547 Coro::async_pool { 4009 Coro::async_pool {
3548 $Coro::current->{desc} = "runtime saver"; 4010 $Coro::current->{desc} = "runtime saver";
3549 write_runtime 4011 write_runtime_sync
3550 or warn "ERROR: unable to write runtime file: $!"; 4012 or warn "ERROR: unable to write runtime file: $!";
3551 };
3552 } 4013 };
4014 }
3553 4015
3554 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 4016 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3555 $sig->send; 4017 $sig->send;
3556 } 4018 }
3557 while (my $sig = shift @WAIT_FOR_TICK) { 4019 while (my $sig = shift @WAIT_FOR_TICK) {
3558 $sig->send; 4020 $sig->send;
3559 } 4021 }
3560 4022
3561 $NOW = Event::time; 4023 $LOAD = ($NOW - $TICK_START) / $TICK;
3562
3563 # if we are delayed by four ticks or more, skip them all
3564 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3565
3566 $TICK_WATCHER->at ($NEXT_TICK);
3567 $TICK_WATCHER->start;
3568
3569 $LOAD = ($NOW - $tick_start) / $TICK;
3570 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 4024 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3571 4025
3572 _post_tick; 4026 if (0) {
4027 if ($NEXT_TICK) {
4028 my $jitter = $TICK_START - $NEXT_TICK;
4029 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
4030 warn "jitter $JITTER\n";#d#
4031 }
3573 }, 4032 }
3574); 4033}
3575 4034
3576{ 4035{
4036 # configure BDB
4037
3577 BDB::min_parallel 8; 4038 BDB::min_parallel 16;
3578 BDB::max_poll_time $TICK * 0.1; 4039 BDB::max_poll_reqs $TICK * 0.1;
3579 $BDB_POLL_WATCHER = Event->io ( 4040 $AnyEvent::BDB::WATCHER->priority (1);
3580 reentrant => 0,
3581 fd => BDB::poll_fileno,
3582 poll => 'r',
3583 prio => 0,
3584 data => WF_AUTOCANCEL,
3585 cb => \&BDB::poll_cb,
3586 );
3587
3588 BDB::set_sync_prepare {
3589 my $status;
3590 my $current = $Coro::current;
3591 (
3592 sub {
3593 $status = $!;
3594 $current->ready; undef $current;
3595 },
3596 sub {
3597 Coro::schedule while defined $current;
3598 $! = $status;
3599 },
3600 )
3601 };
3602 4041
3603 unless ($DB_ENV) { 4042 unless ($DB_ENV) {
3604 $DB_ENV = BDB::db_env_create; 4043 $DB_ENV = BDB::db_env_create;
3605 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC 4044 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3606 | BDB::LOG_AUTOREMOVE, 1); 4045 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
4046 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
3607 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT); 4047 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3608 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT); 4048 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3609 4049
3610 cf::sync_job { 4050 cf::sync_job {
3611 eval { 4051 eval {
… …
3621 4061
3622 cf::cleanup "db_env_open(db): $@" if $@; 4062 cf::cleanup "db_env_open(db): $@" if $@;
3623 }; 4063 };
3624 } 4064 }
3625 4065
3626 $BDB_DEADLOCK_WATCHER = Event->timer ( 4066 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3627 after => 3,
3628 interval => 1,
3629 hard => 1,
3630 prio => 0,
3631 data => WF_AUTOCANCEL,
3632 cb => sub {
3633 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { }; 4067 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3634 },
3635 ); 4068 };
3636 $BDB_CHECKPOINT_WATCHER = Event->timer ( 4069 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3637 after => 11,
3638 interval => 60,
3639 hard => 1,
3640 prio => 0,
3641 data => WF_AUTOCANCEL,
3642 cb => sub {
3643 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { }; 4070 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3644 },
3645 ); 4071 };
3646 $BDB_TRICKLE_WATCHER = Event->timer ( 4072 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3647 after => 5,
3648 interval => 10,
3649 hard => 1,
3650 prio => 0,
3651 data => WF_AUTOCANCEL,
3652 cb => sub {
3653 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { }; 4073 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3654 },
3655 ); 4074 };
3656} 4075}
3657 4076
3658{ 4077{
4078 # configure IO::AIO
4079
3659 IO::AIO::min_parallel 8; 4080 IO::AIO::min_parallel 8;
3660
3661 undef $Coro::AIO::WATCHER;
3662 IO::AIO::max_poll_time $TICK * 0.1; 4081 IO::AIO::max_poll_time $TICK * 0.1;
3663 $AIO_POLL_WATCHER = Event->io ( 4082 undef $AnyEvent::AIO::WATCHER;
3664 reentrant => 0,
3665 data => WF_AUTOCANCEL,
3666 fd => IO::AIO::poll_fileno,
3667 poll => 'r',
3668 prio => 0,
3669 cb => \&IO::AIO::poll_cb,
3670 );
3671} 4083}
3672 4084
3673my $_log_backtrace; 4085my $_log_backtrace;
3674 4086
3675sub _log_backtrace { 4087sub _log_backtrace {
… …
3678 $msg =~ s/\n//; 4090 $msg =~ s/\n//;
3679 4091
3680 # limit the # of concurrent backtraces 4092 # limit the # of concurrent backtraces
3681 if ($_log_backtrace < 2) { 4093 if ($_log_backtrace < 2) {
3682 ++$_log_backtrace; 4094 ++$_log_backtrace;
4095 my $perl_bt = Carp::longmess $msg;
3683 async { 4096 async {
3684 $Coro::current->{desc} = "abt $msg"; 4097 $Coro::current->{desc} = "abt $msg";
3685 4098
3686 my @bt = fork_call { 4099 my @bt = fork_call {
3687 @addr = map { sprintf "%x", $_ } @addr; 4100 @addr = map { sprintf "%x", $_ } @addr;
… …
3698 } 4111 }
3699 4112
3700 @funcs 4113 @funcs
3701 }; 4114 };
3702 4115
3703 LOG llevInfo, "[ABT] $msg\n"; 4116 LOG llevInfo, "[ABT] $perl_bt\n";
4117 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
3704 LOG llevInfo, "[ABT] $_\n" for @bt; 4118 LOG llevInfo, "[ABT] $_\n" for @bt;
3705 --$_log_backtrace; 4119 --$_log_backtrace;
3706 }; 4120 };
3707 } else { 4121 } else {
3708 LOG llevInfo, "[ABT] $msg\n"; 4122 LOG llevInfo, "[ABT] $msg\n";
3709 LOG llevInfo, "[ABT] [suppressed]\n"; 4123 LOG llevInfo, "[ABT] [suppressed]\n";
3710 } 4124 }
3711} 4125}
3712 4126
3713# load additional modules 4127# load additional modules
3714use cf::pod; 4128require "cf/$_.pm" for @EXTRA_MODULES;
4129cf::_connect_to_perl_2;
3715 4130
3716END { cf::emergency_save } 4131END { cf::emergency_save }
3717 4132
37181 41331
3719 4134

Diff Legend

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