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.329 by root, Fri Aug 10 05:38:16 2007 UTC vs.
Revision 1.535 by root, Thu Apr 29 08:21:28 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 Storable; 32use EV;
10use Event;
11use Opcode; 33use Opcode;
12use Safe; 34use Safe;
13use Safe::Hole; 35use Safe::Hole;
36use Storable ();
37use Carp ();
14 38
39use Guard ();
15use Coro 3.61 (); 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;
53use Coro::Util ();
24 54
25use JSON::XS 1.4 (); 55use JSON::XS 2.01 ();
26use BDB (); 56use BDB ();
27use Data::Dumper; 57use Data::Dumper;
28use Digest::MD5;
29use Fcntl; 58use Fcntl;
30use YAML::Syck (); 59use YAML::XS ();
31use IO::AIO 2.32 (); 60use IO::AIO ();
32use Time::HiRes; 61use Time::HiRes;
33use Compress::LZF; 62use Compress::LZF;
34use Digest::MD5 (); 63use Digest::MD5 ();
64
65AnyEvent::detect;
35 66
36# configure various modules to our taste 67# configure various modules to our taste
37# 68#
38$Storable::canonical = 1; # reduce rsync transfers 69$Storable::canonical = 1; # reduce rsync transfers
39Coro::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";
40Compress::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
41 77
42$Event::Eval = 1; # no idea why this is required, but it is 78# strictly for debugging
43 79$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
44# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
45$YAML::Syck::ImplicitUnicode = 1;
46
47$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
48 80
49sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 81sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
50 82
51our %COMMAND = (); 83our %COMMAND = ();
52our %COMMAND_TIME = (); 84our %COMMAND_TIME = ();
… …
55our %EXTCMD = (); 87our %EXTCMD = ();
56our %EXTICMD = (); 88our %EXTICMD = ();
57our %EXT_CORO = (); # coroutines bound to extensions 89our %EXT_CORO = (); # coroutines bound to extensions
58our %EXT_MAP = (); # pluggable maps 90our %EXT_MAP = (); # pluggable maps
59 91
60our $RELOAD; # number of reloads so far 92our $RELOAD; # number of reloads so far, non-zero while in reload
61our @EVENT; 93our @EVENT;
94our @REFLECT; # set by XS
95our %REFLECT; # set by us
62 96
63our $CONFDIR = confdir; 97our $CONFDIR = confdir;
64our $DATADIR = datadir; 98our $DATADIR = datadir;
65our $LIBDIR = "$DATADIR/ext"; 99our $LIBDIR = "$DATADIR/ext";
66our $PODDIR = "$DATADIR/pod"; 100our $PODDIR = "$DATADIR/pod";
67our $MAPDIR = "$DATADIR/" . mapdir; 101our $MAPDIR = "$DATADIR/" . mapdir;
68our $LOCALDIR = localdir; 102our $LOCALDIR = localdir;
69our $TMPDIR = "$LOCALDIR/" . tmpdir; 103our $TMPDIR = "$LOCALDIR/" . tmpdir;
70our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 104our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
71our $PLAYERDIR = "$LOCALDIR/" . playerdir; 105our $PLAYERDIR = "$LOCALDIR/" . playerdir;
72our $RANDOMDIR = "$LOCALDIR/random"; 106our $RANDOMDIR = "$LOCALDIR/random";
73our $BDBDIR = "$LOCALDIR/db"; 107our $BDBDIR = "$LOCALDIR/db";
108our $PIDFILE = "$LOCALDIR/pid";
109our $RUNTIMEFILE = "$LOCALDIR/runtime";
110
111our %RESOURCE; # unused
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;
74 118
75our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 119our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
76our $TICK_WATCHER;
77our $AIO_POLL_WATCHER;
78our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 120our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
79our $NEXT_TICK; 121our $NEXT_TICK;
80our $NOW;
81our $USE_FSYNC = 1; # use fsync to write maps - default off 122our $USE_FSYNC = 1; # use fsync to write maps - default on
82 123
124our $BDB_DEADLOCK_WATCHER;
125our $BDB_CHECKPOINT_WATCHER;
83our $BDB_POLL_WATCHER; 126our $BDB_TRICKLE_WATCHER;
84our $DB_ENV; 127our $DB_ENV;
128
129our @EXTRA_MODULES = qw(pod match mapscript);
85 130
86our %CFG; 131our %CFG;
87 132
88our $UPTIME; $UPTIME ||= time; 133our $UPTIME; $UPTIME ||= time;
89our $RUNTIME; 134our $RUNTIME;
135our $NOW;
90 136
91our %PLAYER; # all users 137our (%PLAYER, %PLAYER_LOADING); # all users
92our %MAP; # all maps 138our (%MAP, %MAP_LOADING ); # all maps
93our $LINK_MAP; # the special {link} map, which is always available 139our $LINK_MAP; # the special {link} map, which is always available
94 140
95# 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 ∕
96our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 142our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
97 143
98our $LOAD; # a number between 0 (idle) and 1 (too many objects) 144our $LOAD; # a number between 0 (idle) and 1 (too many objects)
99our $LOADAVG; # same thing, but with alpha-smoothing 145our $LOADAVG; # same thing, but with alpha-smoothing
146our $JITTER; # average jitter
100our $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 :)
101 153
102binmode STDOUT; 154binmode STDOUT;
103binmode STDERR; 155binmode STDERR;
104 156
105# read virtual server time, if available 157# read virtual server time, if available
106unless ($RUNTIME || !-e "$LOCALDIR/runtime") { 158unless ($RUNTIME || !-e $RUNTIMEFILE) {
107 open my $fh, "<", "$LOCALDIR/runtime" 159 open my $fh, "<", $RUNTIMEFILE
108 or die "unable to read runtime file: $!"; 160 or die "unable to read $RUNTIMEFILE file: $!";
109 $RUNTIME = <$fh> + 0.; 161 $RUNTIME = <$fh> + 0.;
110} 162}
163
164eval "sub TICK() { $TICK } 1" or die;
111 165
112mkdir $_ 166mkdir $_
113 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR; 167 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
114 168
115our $EMERGENCY_POSITION; 169our $EMERGENCY_POSITION;
116 170
117sub 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::"} };
118 187
119############################################################################# 188#############################################################################
120 189
121=head2 GLOBAL VARIABLES 190=head2 GLOBAL VARIABLES
122 191
… …
158 227
159The raw value load value from the last tick. 228The raw value load value from the last tick.
160 229
161=item %cf::CFG 230=item %cf::CFG
162 231
163Configuration for the server, loaded from C</etc/crossfire/config>, or 232Configuration for the server, loaded from C</etc/deliantra-server/config>, or
164from wherever your confdir points to. 233from wherever your confdir points to.
165 234
166=item cf::wait_for_tick, cf::wait_for_tick_begin 235=item cf::wait_for_tick, cf::wait_for_tick_begin
167 236
168These 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
169returns 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
170per 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.
171 240
172=item @cf::INVOKE_RESULTS 241=item @cf::INVOKE_RESULTS
173 242
174This array contains the results of the last C<invoke ()> call. When 243This array contains the results of the last C<invoke ()> call. When
175C<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
176that call. 245that call.
177 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
178=back 253=back
179 254
180=cut 255=cut
181 256
182BEGIN { 257sub error(@) { LOG llevError, join "", @_ }
183 *CORE::GLOBAL::warn = sub { 258sub warn (@) { LOG llevWarn , join "", @_ }
259sub info (@) { LOG llevInfo , join "", @_ }
260sub debug(@) { LOG llevDebug, join "", @_ }
261sub trace(@) { LOG llevTrace, join "", @_ }
262
263$Coro::State::WARNHOOK = sub {
184 my $msg = join "", @_; 264 my $msg = join "", @_;
185 265
186 $msg .= "\n" 266 $msg .= "\n"
187 unless $msg =~ /\n$/; 267 unless $msg =~ /\n$/;
188 268
189 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 269 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
190 270
191 utf8::encode $msg;
192 LOG llevError, $msg; 271 LOG llevWarn, $msg;
193 }; 272};
194} 273
274$Coro::State::DIEHOOK = sub {
275 return unless $^S eq 0; # "eq", not "=="
276
277 error Carp::longmess $_[0];
278
279 if (in_main) {#d#
280 error "DIEHOOK called in main context, Coro bug?\n";#d#
281 return;#d#
282 }#d#
283
284 # kill coroutine otherwise
285 Coro::terminate
286};
195 287
196@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 288@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
197@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 289@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
198@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 290@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
199@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 291@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
… …
206for my $pkg (qw( 298for my $pkg (qw(
207 cf::global cf::attachable 299 cf::global cf::attachable
208 cf::object cf::object::player 300 cf::object cf::object::player
209 cf::client cf::player 301 cf::client cf::player
210 cf::arch cf::living 302 cf::arch cf::living
303 cf::map cf::mapspace
211 cf::map cf::party cf::region 304 cf::party cf::region
212)) { 305)) {
213 no strict 'refs';
214 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 306 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
215} 307}
216 308
217$Event::DIED = sub { 309$EV::DIED = sub {
218 warn "error in event callback: @_"; 310 Carp::cluck "error in event callback: @_";
219}; 311};
220 312
221############################################################################# 313#############################################################################
222 314
223=head2 UTILITY FUNCTIONS 315=head2 UTILITY FUNCTIONS
… …
245 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 337 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
246 $d 338 $d
247 } || "[unable to dump $_[0]: '$@']"; 339 } || "[unable to dump $_[0]: '$@']";
248} 340}
249 341
250=item $ref = cf::from_json $json 342=item $ref = cf::decode_json $json
251 343
252Converts a JSON string into the corresponding perl data structure. 344Converts a JSON string into the corresponding perl data structure.
253 345
254=item $json = cf::to_json $ref 346=item $json = cf::encode_json $ref
255 347
256Converts a perl data structure into its JSON representation. 348Converts a perl data structure into its JSON representation.
257 349
258=cut 350=cut
259 351
260our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max 352our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
261 353
262sub to_json ($) { $json_coder->encode ($_[0]) } 354sub encode_json($) { $json_coder->encode ($_[0]) }
263sub from_json ($) { $json_coder->decode ($_[0]) } 355sub decode_json($) { $json_coder->decode ($_[0]) }
356
357=item cf::post_init { BLOCK }
358
359Execute the given codeblock, I<after> all extensions have been (re-)loaded,
360but I<before> the server starts ticking again.
361
362The cdoeblock will have a single boolean argument to indicate whether this
363is a reload or not.
364
365=cut
366
367sub post_init(&) {
368 push @POST_INIT, shift;
369}
264 370
265=item cf::lock_wait $string 371=item cf::lock_wait $string
266 372
267Wait until the given lock is available. See cf::lock_acquire. 373Wait until the given lock is available. See cf::lock_acquire.
268 374
269=item my $lock = cf::lock_acquire $string 375=item my $lock = cf::lock_acquire $string
270 376
271Wait until the given lock is available and then acquires it and returns 377Wait until the given lock is available and then acquires it and returns
272a Coro::guard object. If the guard object gets destroyed (goes out of scope, 378a L<Guard> object. If the guard object gets destroyed (goes out of scope,
273for example when the coroutine gets canceled), the lock is automatically 379for example when the coroutine gets canceled), the lock is automatically
274returned. 380returned.
275 381
382Locks are *not* recursive, locking from the same coro twice results in a
383deadlocked coro.
384
276Lock names should begin with a unique identifier (for example, cf::map::find 385Lock names should begin with a unique identifier (for example, cf::map::find
277uses map_find and cf::map::load uses map_load). 386uses map_find and cf::map::load uses map_load).
278 387
279=item $locked = cf::lock_active $string 388=item $locked = cf::lock_active $string
280 389
281Return true if the lock is currently active, i.e. somebody has locked it. 390Return true if the lock is currently active, i.e. somebody has locked it.
282 391
283=cut 392=cut
284 393
285our %LOCK; 394our $LOCKS = new Coro::SemaphoreSet;
286 395
287sub lock_wait($) { 396sub lock_wait($) {
288 my ($key) = @_; 397 $LOCKS->wait ($_[0]);
289
290 # wait for lock, if any
291 while ($LOCK{$key}) {
292 push @{ $LOCK{$key} }, $Coro::current;
293 Coro::schedule;
294 }
295} 398}
296 399
297sub lock_acquire($) { 400sub lock_acquire($) {
298 my ($key) = @_; 401 $LOCKS->guard ($_[0])
299
300 # wait, to be sure we are not locked
301 lock_wait $key;
302
303 $LOCK{$key} = [];
304
305 Coro::guard {
306 # wake up all waiters, to be on the safe side
307 $_->ready for @{ delete $LOCK{$key} };
308 }
309} 402}
310 403
311sub lock_active($) { 404sub lock_active($) {
312 my ($key) = @_; 405 $LOCKS->count ($_[0]) < 1
313
314 ! ! $LOCK{$key}
315} 406}
316 407
317sub freeze_mainloop { 408sub freeze_mainloop {
318 return unless $TICK_WATCHER->is_active; 409 tick_inhibit_inc;
319 410
320 my $guard = Coro::guard { 411 &Guard::guard (\&tick_inhibit_dec);
321 $TICK_WATCHER->start; 412}
322 }; 413
323 $TICK_WATCHER->stop; 414=item cf::periodic $interval, $cb
324 $guard 415
416Like EV::periodic, but randomly selects a starting point so that the actions
417get spread over time.
418
419=cut
420
421sub periodic($$) {
422 my ($interval, $cb) = @_;
423
424 my $start = rand List::Util::min 180, $interval;
425
426 EV::periodic $start, $interval, 0, $cb
325} 427}
326 428
327=item cf::get_slot $time[, $priority[, $name]] 429=item cf::get_slot $time[, $priority[, $name]]
328 430
329Allocate $time seconds of blocking CPU time at priority C<$priority>: 431Allocate $time seconds of blocking CPU time at priority C<$priority>:
… …
337 439
338=cut 440=cut
339 441
340our @SLOT_QUEUE; 442our @SLOT_QUEUE;
341our $SLOT_QUEUE; 443our $SLOT_QUEUE;
444our $SLOT_DECAY = 0.9;
342 445
343$SLOT_QUEUE->cancel if $SLOT_QUEUE; 446$SLOT_QUEUE->cancel if $SLOT_QUEUE;
344$SLOT_QUEUE = Coro::async { 447$SLOT_QUEUE = Coro::async {
448 $Coro::current->desc ("timeslot manager");
449
345 my $signal = new Coro::Signal; 450 my $signal = new Coro::Signal;
451 my $busy;
346 452
347 while () { 453 while () {
348 next_job: 454 next_job:
455
349 my $avail = cf::till_tick; 456 my $avail = cf::till_tick;
350 if ($avail > 0.01) { 457
351 for (0 .. $#SLOT_QUEUE) { 458 for (0 .. $#SLOT_QUEUE) {
352 if ($SLOT_QUEUE[$_][0] < $avail) { 459 if ($SLOT_QUEUE[$_][0] <= $avail) {
460 $busy = 0;
353 my $job = splice @SLOT_QUEUE, $_, 1, (); 461 my $job = splice @SLOT_QUEUE, $_, 1, ();
354 $job->[2]->send; 462 $job->[2]->send;
355 Coro::cede; 463 Coro::cede;
356 goto next_job; 464 goto next_job;
357 } 465 } else {
466 $SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
358 } 467 }
359 } 468 }
360 469
361 if (@SLOT_QUEUE) { 470 if (@SLOT_QUEUE) {
362 # we do not use wait_For_tick() as it returns immediately when tick is inactive 471 # we do not use wait_for_tick() as it returns immediately when tick is inactive
363 push @cf::WAIT_FOR_TICK, $signal; 472 push @cf::WAIT_FOR_TICK, $signal;
364 $signal->wait; 473 $signal->wait;
365 } else { 474 } else {
475 $busy = 0;
366 Coro::schedule; 476 Coro::schedule;
367 } 477 }
368 } 478 }
369}; 479};
370 480
371sub get_slot($;$$) { 481sub get_slot($;$$) {
482 return if tick_inhibit || $Coro::current == $Coro::main;
483
372 my ($time, $pri, $name) = @_; 484 my ($time, $pri, $name) = @_;
373 485
374 $time = $TICK * .6 if $time > $TICK * .6; 486 $time = clamp $time, 0.01, $TICK * .6;
487
375 my $sig = new Coro::Signal; 488 my $sig = new Coro::Signal;
376 489
377 push @SLOT_QUEUE, [$time, $pri, $sig, $name]; 490 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
378 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE; 491 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
379 $SLOT_QUEUE->ready; 492 $SLOT_QUEUE->ready;
… …
390 503
391BEGIN { *async = \&Coro::async_pool } 504BEGIN { *async = \&Coro::async_pool }
392 505
393=item cf::sync_job { BLOCK } 506=item cf::sync_job { BLOCK }
394 507
395The design of Crossfire TRT requires that the main coroutine ($Coro::main) 508The design of Deliantra requires that the main coroutine ($Coro::main)
396is always able to handle events or runnable, as Crossfire TRT is only 509is always able to handle events or runnable, as Deliantra is only
397partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not 510partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
398acceptable. 511acceptable.
399 512
400If it must be done, put the blocking parts into C<sync_job>. This will run 513If it must be done, put the blocking parts into C<sync_job>. This will run
401the given BLOCK in another coroutine while waiting for the result. The 514the given BLOCK in another coroutine while waiting for the result. The
… …
405=cut 518=cut
406 519
407sub sync_job(&) { 520sub sync_job(&) {
408 my ($job) = @_; 521 my ($job) = @_;
409 522
410 if ($Coro::current == $Coro::main) { 523 if (in_main) {
411 my $time = Event::time; 524 my $time = AE::time;
412 525
413 # this is the main coro, too bad, we have to block 526 # this is the main coro, too bad, we have to block
414 # till the operation succeeds, freezing the server :/ 527 # till the operation succeeds, freezing the server :/
415 528
416 # TODO: use suspend/resume instead 529 #LOG llevError, Carp::longmess "sync job";#d#
417 # (but this is cancel-safe) 530
418 my $freeze_guard = freeze_mainloop; 531 my $freeze_guard = freeze_mainloop;
419 532
420 my $busy = 1; 533 my $busy = 1;
421 my @res; 534 my @res;
422 535
423 (async { 536 (async {
537 $Coro::current->desc ("sync job coro");
424 @res = eval { $job->() }; 538 @res = eval { $job->() };
425 warn $@ if $@; 539 error $@ if $@;
426 undef $busy; 540 undef $busy;
427 })->prio (Coro::PRIO_MAX); 541 })->prio (Coro::PRIO_MAX);
428 542
429 while ($busy) { 543 while ($busy) {
430 Coro::cede or Event::one_event; 544 if (Coro::nready) {
545 Coro::cede_notself;
546 } else {
547 EV::loop EV::LOOP_ONESHOT;
431 } 548 }
549 }
432 550
433 $time = Event::time - $time; 551 my $time = AE::time - $time;
434 552
435 LOG llevError | logBacktrace, Carp::longmess "long sync job"
436 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
437
438 $tick_start += $time; # do not account sync jobs to server load 553 $TICK_START += $time; # do not account sync jobs to server load
439 554
440 wantarray ? @res : $res[0] 555 wantarray ? @res : $res[0]
441 } else { 556 } else {
442 # we are in another coroutine, how wonderful, everything just works 557 # we are in another coroutine, how wonderful, everything just works
443 558
… …
468=item fork_call { }, $args 583=item fork_call { }, $args
469 584
470Executes the given code block with the given arguments in a seperate 585Executes the given code block with the given arguments in a seperate
471process, returning the results. Everything must be serialisable with 586process, returning the results. Everything must be serialisable with
472Coro::Storable. May, of course, block. Note that the executed sub may 587Coro::Storable. May, of course, block. Note that the executed sub may
473never block itself or use any form of Event handling. 588never block itself or use any form of event handling.
474 589
475=cut 590=cut
476
477sub _store_scalar {
478 open my $fh, ">", \my $buf
479 or die "fork_call: cannot open fh-to-buf in child : $!";
480 Storable::store_fd $_[0], $fh;
481 close $fh;
482
483 $buf
484}
485 591
486sub fork_call(&@) { 592sub fork_call(&@) {
487 my ($cb, @args) = @_; 593 my ($cb, @args) = @_;
488 594
489# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC 595 # we seemingly have to make a local copy of the whole thing,
490# or die "socketpair: $!"; 596 # otherwise perl prematurely frees the stuff :/
491 pipe my $fh1, my $fh2 597 # TODO: investigate and fix (likely this will be rather laborious)
492 or die "pipe: $!";
493 598
494 if (my $pid = fork) { 599 my @res = Coro::Util::fork_eval {
495 close $fh2;
496
497 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
498 warn "pst<$res>" unless $res =~ /^pst/;
499 $res = Coro::Storable::thaw $res;
500
501 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
502
503 Carp::confess $$res unless "ARRAY" eq ref $res;
504
505 return wantarray ? @$res : $res->[-1];
506 } else {
507 reset_signals; 600 reset_signals;
508 local $SIG{__WARN__}; 601 &$cb
509 local $SIG{__DIE__}; 602 }, @args;
510 # just in case, this hack effectively disables event
511 # in the child. cleaner and slower would be canceling all watchers,
512 # but this works for the time being.
513 local $Coro::idle;
514 $Coro::current->prio (Coro::PRIO_MAX);
515 603
516 eval { 604 wantarray ? @res : $res[-1]
517 close $fh1; 605}
518 606
519 my @res = eval { $cb->(@args) }; 607sub objinfo {
520
521 syswrite $fh2, _store_scalar $@ ? \"$@" : \@res;
522 close $fh2;
523 };
524
525 warn $@ if $@;
526 _exit 0;
527 } 608 (
609 "counter value" => cf::object::object_count,
610 "objects created" => cf::object::create_count,
611 "objects destroyed" => cf::object::destroy_count,
612 "freelist size" => cf::object::free_count,
613 "allocated objects" => cf::object::objects_size,
614 "active objects" => cf::object::actives_size,
615 )
616}
617
618=item $coin = coin_from_name $name
619
620=cut
621
622our %coin_alias = (
623 "silver" => "silvercoin",
624 "silvercoin" => "silvercoin",
625 "silvercoins" => "silvercoin",
626 "gold" => "goldcoin",
627 "goldcoin" => "goldcoin",
628 "goldcoins" => "goldcoin",
629 "platinum" => "platinacoin",
630 "platinumcoin" => "platinacoin",
631 "platinumcoins" => "platinacoin",
632 "platina" => "platinacoin",
633 "platinacoin" => "platinacoin",
634 "platinacoins" => "platinacoin",
635 "royalty" => "royalty",
636 "royalties" => "royalty",
637);
638
639sub coin_from_name($) {
640 $coin_alias{$_[0]}
641 ? cf::arch::find $coin_alias{$_[0]}
642 : undef
528} 643}
529 644
530=item $value = cf::db_get $family => $key 645=item $value = cf::db_get $family => $key
531 646
532Returns a single value from the environment database. 647Returns a single value from the environment database.
… …
534=item cf::db_put $family => $key => $value 649=item cf::db_put $family => $key => $value
535 650
536Stores the given C<$value> in the family. It can currently store binary 651Stores the given C<$value> in the family. It can currently store binary
537data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary). 652data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
538 653
654=item $db = cf::db_table "name"
655
656Create and/or open a new database table. The string must not be "db" and must be unique
657within each server.
658
539=cut 659=cut
660
661sub db_table($) {
662 cf::error "db_get called from main context"
663 if $Coro::current == $Coro::main;
664
665 my ($name) = @_;
666 my $db = BDB::db_create $DB_ENV;
667
668 eval {
669 $db->set_flags (BDB::CHKSUM);
670
671 utf8::encode $name;
672 BDB::db_open $db, undef, $name, undef, BDB::BTREE,
673 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
674 cf::cleanup "db_open(db): $!" if $!;
675 };
676 cf::cleanup "db_open(db): $@" if $@;
677
678 $db
679}
540 680
541our $DB; 681our $DB;
542 682
543sub db_init { 683sub db_init {
544 unless ($DB) { 684 $DB ||= db_table "db";
545 $DB = BDB::db_create $DB_ENV;
546
547 cf::sync_job {
548 eval {
549 $DB->set_flags (BDB::CHKSUM);
550
551 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
552 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
553 cf::cleanup "db_open(db): $!" if $!;
554 };
555 cf::cleanup "db_open(db): $@" if $@;
556 };
557 }
558} 685}
559 686
560sub db_get($$) { 687sub db_get($$) {
561 my $key = "$_[0]/$_[1]"; 688 my $key = "$_[0]/$_[1]";
562 689
563 cf::sync_job { 690 cf::error "db_get called from main context"
691 if $Coro::current == $Coro::main;
692
564 BDB::db_get $DB, undef, $key, my $data; 693 BDB::db_get $DB, undef, $key, my $data;
565 694
566 $! ? () 695 $! ? ()
567 : $data 696 : $data
568 }
569} 697}
570 698
571sub db_put($$$) { 699sub db_put($$$) {
572 BDB::dbreq_pri 4; 700 BDB::dbreq_pri 4;
573 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { }; 701 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
… …
612 if (1) { 740 if (1) {
613 $md5 = 741 $md5 =
614 join "\x00", 742 join "\x00",
615 $processversion, 743 $processversion,
616 map { 744 map {
617 Coro::cede; 745 cf::cede_to_tick;
618 ($src->[$_], Digest::MD5::md5_hex $data[$_]) 746 ($src->[$_], Digest::MD5::md5_hex $data[$_])
619 } 0.. $#$src; 747 } 0.. $#$src;
620 748
621 749
622 my $dbmd5 = db_get cache => "$id/md5"; 750 my $dbmd5 = db_get cache => "$id/md5";
… …
629 757
630 my $t1 = Time::HiRes::time; 758 my $t1 = Time::HiRes::time;
631 my $data = $process->(\@data); 759 my $data = $process->(\@data);
632 my $t2 = Time::HiRes::time; 760 my $t2 = Time::HiRes::time;
633 761
634 warn "cache: '$id' processed in ", $t2 - $t1, "s\n"; 762 info "cache: '$id' processed in ", $t2 - $t1, "s\n";
635 763
636 db_put cache => "$id/data", $data; 764 db_put cache => "$id/data", $data;
637 db_put cache => "$id/md5" , $md5; 765 db_put cache => "$id/md5" , $md5;
638 db_put cache => "$id/meta", $meta; 766 db_put cache => "$id/meta", $meta;
639 767
… …
649 777
650=cut 778=cut
651 779
652sub datalog($@) { 780sub datalog($@) {
653 my ($type, %kv) = @_; 781 my ($type, %kv) = @_;
654 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type }); 782 info "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
655} 783}
656 784
657=back 785=back
658 786
659=cut 787=cut
660 788
661############################################################################# 789#############################################################################
662 790
663=head2 ATTACHABLE OBJECTS 791=head2 ATTACHABLE OBJECTS
664 792
665Many objects in crossfire are so-called attachable objects. That means you can 793Many objects in deliantra are so-called attachable objects. That means you can
666attach callbacks/event handlers (a collection of which is called an "attachment") 794attach callbacks/event handlers (a collection of which is called an "attachment")
667to it. All such attachable objects support the following methods. 795to it. All such attachable objects support the following methods.
668 796
669In the following description, CLASS can be any of C<global>, C<object> 797In the following description, CLASS can be any of C<global>, C<object>
670C<player>, C<client> or C<map> (i.e. the attachable objects in 798C<player>, C<client> or C<map> (i.e. the attachable objects in
671Crossfire TRT). 799Deliantra).
672 800
673=over 4 801=over 4
674 802
675=item $attachable->attach ($attachment, key => $value...) 803=item $attachable->attach ($attachment, key => $value...)
676 804
… …
720=item cf::CLASS::attachment $name, ... 848=item cf::CLASS::attachment $name, ...
721 849
722Register an attachment by C<$name> through which attachable objects of the 850Register an attachment by C<$name> through which attachable objects of the
723given CLASS can refer to this attachment. 851given CLASS can refer to this attachment.
724 852
725Some classes such as crossfire maps and objects can specify attachments 853Some classes such as deliantra maps and objects can specify attachments
726that are attached at load/instantiate time, thus the need for a name. 854that are attached at load/instantiate time, thus the need for a name.
727 855
728These calls expect any number of the following handler/hook descriptions: 856These calls expect any number of the following handler/hook descriptions:
729 857
730=over 4 858=over 4
… …
854 982
855 } elsif (exists $cb_id{$type}) { 983 } elsif (exists $cb_id{$type}) {
856 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg; 984 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
857 985
858 } elsif (ref $type) { 986 } elsif (ref $type) {
859 warn "attaching objects not supported, ignoring.\n"; 987 error "attaching objects not supported, ignoring.\n";
860 988
861 } else { 989 } else {
862 shift @arg; 990 shift @arg;
863 warn "attach argument '$type' not supported, ignoring.\n"; 991 error "attach argument '$type' not supported, ignoring.\n";
864 } 992 }
865 } 993 }
866} 994}
867 995
868sub _object_attach { 996sub _object_attach {
… …
878 _attach $registry, $klass, @attach; 1006 _attach $registry, $klass, @attach;
879 } 1007 }
880 1008
881 $obj->{$name} = \%arg; 1009 $obj->{$name} = \%arg;
882 } else { 1010 } else {
883 warn "object uses attachment '$name' which is not available, postponing.\n"; 1011 info "object uses attachment '$name' which is not available, postponing.\n";
884 } 1012 }
885 1013
886 $obj->{_attachment}{$name} = undef; 1014 $obj->{_attachment}{$name} = undef;
887} 1015}
888 1016
… …
947 1075
948 for (@$callbacks) { 1076 for (@$callbacks) {
949 eval { &{$_->[1]} }; 1077 eval { &{$_->[1]} };
950 1078
951 if ($@) { 1079 if ($@) {
952 warn "$@";
953 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n"; 1080 error "$@", "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
954 override; 1081 override;
955 } 1082 }
956 1083
957 return 1 if $override; 1084 return 1 if $override;
958 } 1085 }
959 1086
960 0 1087 0
961} 1088}
962 1089
963=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 1090=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
964 1091
965=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 1092=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
966 1093
967Generate an object-specific event with the given arguments. 1094Generate an object-specific event with the given arguments.
968 1095
… …
974 1101
975=cut 1102=cut
976 1103
977############################################################################# 1104#############################################################################
978# object support 1105# object support
979#
980 1106
1107sub _object_equal($$);
1108sub _object_equal($$) {
1109 my ($a, $b) = @_;
1110
1111 return 0 unless (ref $a) eq (ref $b);
1112
1113 if ("HASH" eq ref $a) {
1114 my @ka = keys %$a;
1115 my @kb = keys %$b;
1116
1117 return 0 if @ka != @kb;
1118
1119 for (0 .. $#ka) {
1120 return 0 unless $ka[$_] eq $kb[$_];
1121 return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
1122 }
1123
1124 } elsif ("ARRAY" eq ref $a) {
1125
1126 return 0 if @$a != @$b;
1127
1128 for (0 .. $#$a) {
1129 return 0 unless _object_equal $a->[$_], $b->[$_];
1130 }
1131
1132 } elsif ($a ne $b) {
1133 return 0;
1134 }
1135
1136 1
1137}
1138
1139our $SLOW_MERGES;#d#
981sub _can_merge { 1140sub _can_merge {
982 my ($ob1, $ob2) = @_; 1141 my ($ob1, $ob2) = @_;
983 1142
984 local $Storable::canonical = 1; 1143 ++$SLOW_MERGES;#d#
985 my $fob1 = Storable::freeze $ob1;
986 my $fob2 = Storable::freeze $ob2;
987 1144
988 $fob1 eq $fob2 1145 # we do the slow way here
1146 return _object_equal $ob1, $ob2
989} 1147}
990 1148
991sub reattach { 1149sub reattach {
992 # basically do the same as instantiate, without calling instantiate 1150 # basically do the same as instantiate, without calling instantiate
993 my ($obj) = @_; 1151 my ($obj) = @_;
994 1152
1153 # no longer needed after getting rid of delete_package?
995 bless $obj, ref $obj; # re-bless in case extensions have been reloaded 1154 #bless $obj, ref $obj; # re-bless in case extensions have been reloaded
996 1155
997 my $registry = $obj->registry; 1156 my $registry = $obj->registry;
998 1157
999 @$registry = (); 1158 @$registry = ();
1000 1159
… …
1005 for (@$attach) { 1164 for (@$attach) {
1006 my ($klass, @attach) = @$_; 1165 my ($klass, @attach) = @$_;
1007 _attach $registry, $klass, @attach; 1166 _attach $registry, $klass, @attach;
1008 } 1167 }
1009 } else { 1168 } else {
1010 warn "object uses attachment '$name' that is not available, postponing.\n"; 1169 info "object uses attachment '$name' that is not available, postponing.\n";
1011 } 1170 }
1012 } 1171 }
1013} 1172}
1014 1173
1015cf::attachable->attach ( 1174cf::attachable->attach (
1016 prio => -1000000, 1175 prio => -1000000,
1017 on_instantiate => sub { 1176 on_instantiate => sub {
1018 my ($obj, $data) = @_; 1177 my ($obj, $data) = @_;
1019 1178
1020 $data = from_json $data; 1179 $data = decode_json $data;
1021 1180
1022 for (@$data) { 1181 for (@$data) {
1023 my ($name, $args) = @$_; 1182 my ($name, $args) = @$_;
1024 1183
1025 $obj->attach ($name, %{$args || {} }); 1184 $obj->attach ($name, %{$args || {} });
… …
1041sub object_freezer_save { 1200sub object_freezer_save {
1042 my ($filename, $rdata, $objs) = @_; 1201 my ($filename, $rdata, $objs) = @_;
1043 1202
1044 sync_job { 1203 sync_job {
1045 if (length $$rdata) { 1204 if (length $$rdata) {
1205 utf8::decode (my $decname = $filename);
1046 warn sprintf "saving %s (%d,%d)\n", 1206 trace sprintf "saving %s (%d,%d)\n",
1047 $filename, length $$rdata, scalar @$objs; 1207 $decname, length $$rdata, scalar @$objs
1208 if $VERBOSE_IO;
1048 1209
1049 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1210 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1050 chmod SAVE_MODE, $fh; 1211 aio_chmod $fh, SAVE_MODE;
1051 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1212 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1052 aio_fsync $fh if $cf::USE_FSYNC; 1213 if ($cf::USE_FSYNC) {
1214 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;
1215 aio_fsync $fh;
1216 }
1053 close $fh; 1217 aio_close $fh;
1054 1218
1055 if (@$objs) { 1219 if (@$objs) {
1056 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1220 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1057 chmod SAVE_MODE, $fh; 1221 aio_chmod $fh, SAVE_MODE;
1058 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1222 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1059 aio_write $fh, 0, (length $data), $data, 0; 1223 aio_write $fh, 0, (length $data), $data, 0;
1060 aio_fsync $fh if $cf::USE_FSYNC; 1224 if ($cf::USE_FSYNC) {
1225 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;
1226 aio_fsync $fh;
1227 }
1061 close $fh; 1228 aio_close $fh;
1062 aio_rename "$filename.pst~", "$filename.pst"; 1229 aio_rename "$filename.pst~", "$filename.pst";
1063 } 1230 }
1064 } else { 1231 } else {
1065 aio_unlink "$filename.pst"; 1232 aio_unlink "$filename.pst";
1066 } 1233 }
1067 1234
1068 aio_rename "$filename~", $filename; 1235 aio_rename "$filename~", $filename;
1236
1237 $filename =~ s%/[^/]+$%%;
1238 aio_pathsync $filename if $cf::USE_FSYNC;
1069 } else { 1239 } else {
1070 warn "FATAL: $filename~: $!\n"; 1240 error "unable to save objects: $filename~: $!\n";
1071 } 1241 }
1072 } else { 1242 } else {
1073 aio_unlink $filename; 1243 aio_unlink $filename;
1074 aio_unlink "$filename.pst"; 1244 aio_unlink "$filename.pst";
1075 } 1245 }
1076 } 1246 };
1077} 1247}
1078 1248
1079sub object_freezer_as_string { 1249sub object_freezer_as_string {
1080 my ($rdata, $objs) = @_; 1250 my ($rdata, $objs) = @_;
1081 1251
… …
1093 or return; 1263 or return;
1094 1264
1095 unless (aio_stat "$filename.pst") { 1265 unless (aio_stat "$filename.pst") {
1096 (aio_load "$filename.pst", $av) >= 0 1266 (aio_load "$filename.pst", $av) >= 0
1097 or return; 1267 or return;
1268
1098 $av = eval { (Storable::thaw $av)->{objs} }; 1269 my $st = eval { Coro::Storable::thaw $av };
1270 $av = $st->{objs};
1099 } 1271 }
1100 1272
1273 utf8::decode (my $decname = $filename);
1101 warn sprintf "loading %s (%d)\n", 1274 trace sprintf "loading %s (%d,%d)\n",
1102 $filename, length $data, scalar @{$av || []}; 1275 $decname, length $data, scalar @{$av || []}
1276 if $VERBOSE_IO;
1277
1103 return ($data, $av); 1278 ($data, $av)
1104} 1279}
1105 1280
1106=head2 COMMAND CALLBACKS 1281=head2 COMMAND CALLBACKS
1107 1282
1108=over 4 1283=over 4
… …
1162 my ($name, $cb) = @_; 1337 my ($name, $cb) = @_;
1163 1338
1164 $EXTICMD{$name} = $cb; 1339 $EXTICMD{$name} = $cb;
1165} 1340}
1166 1341
1342use File::Glob ();
1343
1167cf::player->attach ( 1344cf::player->attach (
1168 on_command => sub { 1345 on_unknown_command => sub {
1169 my ($pl, $name, $params) = @_; 1346 my ($pl, $name, $params) = @_;
1170 1347
1171 my $cb = $COMMAND{$name} 1348 my $cb = $COMMAND{$name}
1172 or return; 1349 or return;
1173 1350
… …
1186 my ($type, $reply, @payload) = 1363 my ($type, $reply, @payload) =
1187 "ARRAY" eq ref $msg 1364 "ARRAY" eq ref $msg
1188 ? @$msg 1365 ? @$msg
1189 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove 1366 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1190 1367
1368 my @reply;
1369
1191 if (my $cb = $EXTCMD{$type}) { 1370 if (my $cb = $EXTCMD{$type}) {
1192 my @reply = $cb->($pl, @payload); 1371 @reply = $cb->($pl, @payload);
1193
1194 $pl->ext_reply ($reply, @reply)
1195 if $reply;
1196 } 1372 }
1373
1374 $pl->ext_reply ($reply, @reply)
1375 if $reply;
1376
1197 } else { 1377 } else {
1198 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1378 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1199 } 1379 }
1200 1380
1201 cf::override; 1381 cf::override;
1202 }, 1382 },
1203); 1383);
1204 1384
1385# "readahead" all extensions
1386sub cache_extensions {
1387 my $grp = IO::AIO::aio_group;
1388
1389 add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
1390 for (grep /\.ext$/, @{$_[0]}) {
1391 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
1392 }
1393 };
1394
1395 $grp
1396}
1397
1205sub load_extensions { 1398sub load_extensions {
1399 info "loading extensions...";
1400
1206 cf::sync_job { 1401 cf::sync_job {
1207 my %todo; 1402 my %todo;
1208 1403
1209 for my $path (<$LIBDIR/*.ext>) { 1404 for my $path (<$LIBDIR/*.ext>) {
1210 next unless -r $path; 1405 next unless -r $path;
… …
1228 1423
1229 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 } 1424 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1230 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; 1425 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1231 1426
1232 $ext{source} = 1427 $ext{source} =
1233 "package $pkg; use strict; use utf8;\n" 1428 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n"
1234 . "#line 1 \"$path\"\n{\n" 1429 . "#line 1 \"$path\"\n{\n"
1235 . $source 1430 . $source
1236 . "\n};\n1"; 1431 . "\n};\n1";
1237 1432
1238 $todo{$base} = \%ext; 1433 $todo{$base} = \%ext;
1239 } 1434 }
1240 1435
1436 my $pass = 0;
1241 my %done; 1437 my %done;
1242 while (%todo) { 1438 while (%todo) {
1243 my $progress; 1439 my $progress;
1244 1440
1441 ++$pass;
1442
1443 ext:
1245 while (my ($k, $v) = each %todo) { 1444 while (my ($k, $v) = each %todo) {
1246 for (split /,\s*/, $v->{meta}{depends}) { 1445 for (split /,\s*/, $v->{meta}{depends}) {
1247 goto skip 1446 next ext
1248 unless exists $done{$_}; 1447 unless exists $done{$_};
1249 } 1448 }
1250 1449
1251 warn "... loading '$k' into '$v->{pkg}'\n"; 1450 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1252 1451
1253 unless (eval $v->{source}) { 1452 my $active = eval $v->{source};
1453
1454 if (length $@) {
1254 my $msg = $@ ? "$v->{path}: $@\n" 1455 error "$v->{path}: $@\n";
1255 : "$v->{base}: extension inactive.\n";
1256 1456
1457 cf::cleanup "mandatory extension '$k' failed to load, exiting."
1257 if (exists $v->{meta}{mandatory}) { 1458 if exists $v->{meta}{mandatory};
1258 warn $msg; 1459
1259 warn "mandatory extension failed to load, exiting.\n"; 1460 warn "$v->{base}: optional extension cannot be loaded, skipping.\n";
1260 exit 1; 1461 delete $todo{$k};
1261 } 1462 } else {
1262 1463 $done{$k} = delete $todo{$k};
1263 warn $msg; 1464 push @EXTS, $v->{pkg};
1465 $progress = 1;
1466
1467 info "$v->{base}: extension inactive.\n"
1468 unless $active;
1264 } 1469 }
1265
1266 $done{$k} = delete $todo{$k};
1267 push @EXTS, $v->{pkg};
1268 $progress = 1;
1269 } 1470 }
1270 1471
1271 skip: 1472 unless ($progress) {
1272 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n" 1473 warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
1273 unless $progress; 1474
1475 while (my ($k, $v) = each %todo) {
1476 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
1477 if exists $v->{meta}{mandatory};
1478 }
1479 }
1274 } 1480 }
1275 }; 1481 };
1276} 1482}
1277 1483
1278############################################################################# 1484#############################################################################
1279 1485
1280=back 1486=back
1281 1487
1282=head2 CORE EXTENSIONS 1488=head2 CORE EXTENSIONS
1283 1489
1284Functions and methods that extend core crossfire objects. 1490Functions and methods that extend core deliantra objects.
1285 1491
1286=cut 1492=cut
1287 1493
1288package cf::player; 1494package cf::player;
1289 1495
1290use Coro::AIO; 1496use Coro::AIO;
1291 1497
1292=head3 cf::player 1498=head3 cf::player
1293 1499
1294=over 4 1500=over 4
1501
1502=item cf::player::num_playing
1503
1504Returns the official number of playing players, as per the Crossfire metaserver rules.
1505
1506=cut
1507
1508sub num_playing {
1509 scalar grep
1510 $_->ob->map
1511 && !$_->hidden
1512 && !$_->ob->flag (cf::FLAG_WIZ),
1513 cf::player::list
1514}
1295 1515
1296=item cf::player::find $login 1516=item cf::player::find $login
1297 1517
1298Returns the given player object, loading it if necessary (might block). 1518Returns the given player object, loading it if necessary (might block).
1299 1519
… …
1318 1538
1319sub exists($) { 1539sub exists($) {
1320 my ($login) = @_; 1540 my ($login) = @_;
1321 1541
1322 $cf::PLAYER{$login} 1542 $cf::PLAYER{$login}
1323 or cf::sync_job { !aio_stat path $login } 1543 or !aio_stat path $login
1324} 1544}
1325 1545
1326sub find($) { 1546sub find($) {
1327 return $cf::PLAYER{$_[0]} || do { 1547 return $cf::PLAYER{$_[0]} || do {
1328 my $login = $_[0]; 1548 my $login = $_[0];
… …
1335 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst"; 1555 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1336 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata"; 1556 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1337 aio_unlink +(playerdir $login) . "/$login.pl.pst"; 1557 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1338 aio_unlink +(playerdir $login) . "/$login.pl"; 1558 aio_unlink +(playerdir $login) . "/$login.pl";
1339 1559
1340 my $pl = load_pl path $login 1560 my $f = new_from_file cf::object::thawer path $login
1341 or return; 1561 or return;
1562
1563 my $pl = cf::player::load_pl $f
1564 or return;
1565
1566 local $cf::PLAYER_LOADING{$login} = $pl;
1567 $f->resolve_delayed_derefs;
1342 $cf::PLAYER{$login} = $pl 1568 $cf::PLAYER{$login} = $pl
1343 } 1569 }
1344 } 1570 }
1345} 1571}
1572
1573cf::player->attach (
1574 on_load => sub {
1575 my ($pl, $path) = @_;
1576
1577 # restore slots saved in save, below
1578 my $slots = delete $pl->{_slots};
1579
1580 $pl->ob->current_weapon ($slots->[0]);
1581 $pl->combat_ob ($slots->[1]);
1582 $pl->ranged_ob ($slots->[2]);
1583 },
1584);
1346 1585
1347sub save($) { 1586sub save($) {
1348 my ($pl) = @_; 1587 my ($pl) = @_;
1349 1588
1350 return if $pl->{deny_save}; 1589 return if $pl->{deny_save};
… …
1355 return if $pl->{deny_save}; 1594 return if $pl->{deny_save};
1356 1595
1357 aio_mkdir playerdir $pl, 0770; 1596 aio_mkdir playerdir $pl, 0770;
1358 $pl->{last_save} = $cf::RUNTIME; 1597 $pl->{last_save} = $cf::RUNTIME;
1359 1598
1599 cf::get_slot 0.01;
1600
1601 # save slots, to be restored later
1602 local $pl->{_slots} = [$pl->ob->current_weapon, $pl->combat_ob, $pl->ranged_ob];
1603
1360 $pl->save_pl ($path); 1604 $pl->save_pl ($path);
1361 Coro::cede; 1605 cf::cede_to_tick;
1362} 1606}
1363 1607
1364sub new($) { 1608sub new($) {
1365 my ($login) = @_; 1609 my ($login) = @_;
1366 1610
… …
1395 my ($pl) = @_; 1639 my ($pl) = @_;
1396 1640
1397 my $name = $pl->ob->name; 1641 my $name = $pl->ob->name;
1398 1642
1399 $pl->{deny_save} = 1; 1643 $pl->{deny_save} = 1;
1400 $pl->password ("*"); # this should lock out the player until we nuked the dir 1644 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1401 1645
1402 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1646 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1403 $pl->deactivate; 1647 $pl->deactivate;
1648 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1404 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1649 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1405 $pl->ns->destroy if $pl->ns; 1650 $pl->ns->destroy if $pl->ns;
1406 1651
1407 my $path = playerdir $pl; 1652 my $path = playerdir $pl;
1408 my $temp = "$path~$cf::RUNTIME~deleting~"; 1653 my $temp = "$path~$cf::RUNTIME~deleting~";
… …
1444 or return []; 1689 or return [];
1445 1690
1446 my @logins; 1691 my @logins;
1447 1692
1448 for my $login (@$dirs) { 1693 for my $login (@$dirs) {
1694 my $path = path $login;
1695
1696 # a .pst is a dead give-away for a valid player
1697 # if no pst file found, open and chekc for blocked users
1698 if (aio_stat "$path.pst") {
1449 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1699 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1450 aio_read $fh, 0, 512, my $buf, 0 or next; 1700 aio_read $fh, 0, 512, my $buf, 0 or next;
1451 $buf !~ /^password -------------$/m or next; # official not-valid tag 1701 $buf !~ /^password -------------$/m or next; # official not-valid tag
1702 }
1452 1703
1453 utf8::decode $login; 1704 utf8::decode $login;
1454 push @logins, $login; 1705 push @logins, $login;
1455 } 1706 }
1456 1707
1457 \@logins 1708 \@logins
1458} 1709}
1459 1710
1460=item $player->maps 1711=item $player->maps
1712
1713=item cf::player::maps $login
1461 1714
1462Returns an arrayref of map paths that are private for this 1715Returns an arrayref of map paths that are private for this
1463player. May block. 1716player. May block.
1464 1717
1465=cut 1718=cut
… …
1483 } 1736 }
1484 1737
1485 \@paths 1738 \@paths
1486} 1739}
1487 1740
1488=item $protocol_xml = $player->expand_cfpod ($crossfire_pod) 1741=item $protocol_xml = $player->expand_cfpod ($cfpod)
1489 1742
1490Expand crossfire pod fragments into protocol xml. 1743Expand deliantra pod fragments into protocol xml.
1491
1492=cut
1493
1494sub expand_cfpod {
1495 ((my $self), (local $_)) = @_;
1496
1497 # escape & and <
1498 s/&/&amp;/g;
1499 s/(?<![BIUGH])</&lt;/g;
1500
1501 # this is buggy, it needs to properly take care of nested <'s
1502
1503 1 while
1504 # replace B<>, I<>, U<> etc.
1505 s/B<([^\>]*)>/<b>$1<\/b>/
1506 || s/I<([^\>]*)>/<i>$1<\/i>/
1507 || s/U<([^\>]*)>/<u>$1<\/u>/
1508 # replace G<male|female> tags
1509 || s{G<([^>|]*)\|([^>]*)>}{
1510 $self->gender ? $2 : $1
1511 }ge
1512 # replace H<hint text>
1513 || s{H<([^\>]*)>}
1514 {
1515 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
1516 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1517 "")
1518 [$self->{hintmode}]
1519 }ge;
1520
1521 # create single paragraphs (very hackish)
1522 s/(?<=\S)\n(?=\w)/ /g;
1523
1524 # compress some whitespace
1525 s/\s+\n/\n/g; # ws line-ends
1526 s/\n\n+/\n/g; # double lines
1527 s/^\n+//; # beginning lines
1528 s/\n+$//; # ending lines
1529
1530 $_
1531}
1532
1533sub hintmode {
1534 $_[0]{hintmode} = $_[1] if @_ > 1;
1535 $_[0]{hintmode}
1536}
1537 1744
1538=item $player->ext_reply ($msgid, @msg) 1745=item $player->ext_reply ($msgid, @msg)
1539 1746
1540Sends an ext reply to the player. 1747Sends an ext reply to the player.
1541 1748
1542=cut 1749=cut
1543 1750
1544sub ext_reply($$@) { 1751sub ext_reply($$@) {
1545 my ($self, $id, @msg) = @_; 1752 my ($self, $id, @msg) = @_;
1546 1753
1547 if ($self->ns->extcmd == 2) { 1754 $self->ns->ext_reply ($id, @msg)
1548 $self->send ("ext " . $self->ns->{json_coder}->encode (["reply-$id", @msg]));
1549 } elsif ($self->ns->extcmd == 1) {
1550 #TODO: version 1, remove
1551 unshift @msg, msgtype => "reply", msgid => $id;
1552 $self->send ("ext " . $self->ns->{json_coder}->encode ({@msg}));
1553 }
1554} 1755}
1555 1756
1556=item $player->ext_msg ($type, @msg) 1757=item $player->ext_msg ($type, @msg)
1557 1758
1558Sends an ext event to the client. 1759Sends an ext event to the client.
… …
1579 1780
1580=cut 1781=cut
1581 1782
1582sub find_by_path($) { 1783sub find_by_path($) {
1583 my ($path) = @_; 1784 my ($path) = @_;
1785
1786 $path =~ s/^~[^\/]*//; # skip ~login
1584 1787
1585 my ($match, $specificity); 1788 my ($match, $specificity);
1586 1789
1587 for my $region (list) { 1790 for my $region (list) {
1588 if ($region->{match} && $path =~ $region->{match}) { 1791 if ($region->{match} && $path =~ $region->{match}) {
… …
1614our $MAX_RESET = 3600; 1817our $MAX_RESET = 3600;
1615our $DEFAULT_RESET = 3000; 1818our $DEFAULT_RESET = 3000;
1616 1819
1617sub generate_random_map { 1820sub generate_random_map {
1618 my ($self, $rmp) = @_; 1821 my ($self, $rmp) = @_;
1822
1823 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1824
1619 # mit "rum" bekleckern, nicht 1825 # mit "rum" bekleckern, nicht
1620 $self->_create_random_map ( 1826 $self->_create_random_map (
1621 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1827 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1622 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1828 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, $rmp->{miningstyle},
1623 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1829 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1624 $rmp->{exit_on_final_map}, 1830 $rmp->{exit_on_final_map},
1625 $rmp->{xsize}, $rmp->{ysize}, 1831 $rmp->{xsize}, $rmp->{ysize},
1626 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1832 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1627 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1833 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
… …
1649 1855
1650 $EXT_MAP{$pkg} = [$prio, qr<$regex>]; 1856 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1651} 1857}
1652 1858
1653# also paths starting with '/' 1859# also paths starting with '/'
1654$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}]; 1860$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1655 1861
1656sub thawer_merge { 1862sub thawer_merge {
1657 my ($self, $merge) = @_; 1863 my ($self, $merge) = @_;
1658 1864
1659 # we have to keep some variables in memory intact 1865 # we have to keep some variables in memory intact
… …
1745 1951
1746# the temporary/swap location 1952# the temporary/swap location
1747sub save_path { 1953sub save_path {
1748 my ($self) = @_; 1954 my ($self) = @_;
1749 1955
1750 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1956 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1751 "$TMPDIR/$path.map" 1957 "$TMPDIR/$path.map"
1752} 1958}
1753 1959
1754# the unique path, undef == no special unique path 1960# the unique path, undef == no special unique path
1755sub uniq_path { 1961sub uniq_path {
1756 my ($self) = @_; 1962 my ($self) = @_;
1757 1963
1758 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1964 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1759 "$UNIQUEDIR/$path" 1965 "$UNIQUEDIR/$path"
1760}
1761
1762# and all this just because we cannot iterate over
1763# all maps in C++...
1764sub change_all_map_light {
1765 my ($change) = @_;
1766
1767 $_->change_map_light ($change)
1768 for grep $_->outdoor, values %cf::MAP;
1769} 1966}
1770 1967
1771sub decay_objects { 1968sub decay_objects {
1772 my ($self) = @_; 1969 my ($self) = @_;
1773 1970
… …
1786 1983
1787sub load_header_from($) { 1984sub load_header_from($) {
1788 my ($self, $path) = @_; 1985 my ($self, $path) = @_;
1789 1986
1790 utf8::encode $path; 1987 utf8::encode $path;
1791 #aio_open $path, O_RDONLY, 0 1988 my $f = new_from_file cf::object::thawer $path
1792 # or return;
1793
1794 $self->_load_header ($path)
1795 or return; 1989 or return;
1990
1991 $self->_load_header ($f)
1992 or return;
1993
1994 local $MAP_LOADING{$self->{path}} = $self;
1995 $f->resolve_delayed_derefs;
1796 1996
1797 $self->{load_path} = $path; 1997 $self->{load_path} = $path;
1798 1998
1799 1 1999 1
1800} 2000}
… …
1854sub find { 2054sub find {
1855 my ($path, $origin) = @_; 2055 my ($path, $origin) = @_;
1856 2056
1857 $path = normalise $path, $origin && $origin->path; 2057 $path = normalise $path, $origin && $origin->path;
1858 2058
2059 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1859 cf::lock_wait "map_find:$path"; 2060 my $guard2 = cf::lock_acquire "map_find:$path";
1860 2061
1861 $cf::MAP{$path} || do { 2062 $cf::MAP{$path} || do {
1862 my $guard = cf::lock_acquire "map_find:$path";
1863 my $map = new_from_path cf::map $path 2063 my $map = new_from_path cf::map $path
1864 or return; 2064 or return;
1865 2065
1866 $map->{last_save} = $cf::RUNTIME; 2066 $map->{last_save} = $cf::RUNTIME;
1867 2067
… …
1869 or return; 2069 or return;
1870 2070
1871 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 2071 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1872 # doing this can freeze the server in a sync job, obviously 2072 # doing this can freeze the server in a sync job, obviously
1873 #$cf::WAIT_FOR_TICK->wait; 2073 #$cf::WAIT_FOR_TICK->wait;
2074 undef $guard2;
2075 undef $guard1;
1874 $map->reset; 2076 $map->reset;
1875 undef $guard;
1876 return find $path; 2077 return find $path;
1877 } 2078 }
1878 2079
1879 $cf::MAP{$path} = $map 2080 $cf::MAP{$path} = $map
1880 } 2081 }
1881} 2082}
1882 2083
1883sub pre_load { } 2084sub pre_load { }
1884sub post_load { } 2085#sub post_load { } # XS
1885 2086
1886sub load { 2087sub load {
1887 my ($self) = @_; 2088 my ($self) = @_;
1888 2089
1889 local $self->{deny_reset} = 1; # loading can take a long time 2090 local $self->{deny_reset} = 1; # loading can take a long time
1890 2091
1891 my $path = $self->{path}; 2092 my $path = $self->{path};
1892 2093
1893 { 2094 {
1894 my $guard = cf::lock_acquire "map_load:$path"; 2095 my $guard = cf::lock_acquire "map_data:$path";
1895 2096
2097 return unless $self->valid;
1896 return if $self->in_memory != cf::MAP_SWAPPED; 2098 return unless $self->in_memory == cf::MAP_SWAPPED;
1897 2099
1898 $self->in_memory (cf::MAP_LOADING); 2100 $self->in_memory (cf::MAP_LOADING);
1899 2101
1900 $self->alloc; 2102 $self->alloc;
1901 2103
1902 $self->pre_load; 2104 $self->pre_load;
1903 Coro::cede; 2105 cf::cede_to_tick;
1904 2106
2107 my $f = new_from_file cf::object::thawer $self->{load_path};
2108 $f->skip_block;
1905 $self->_load_objects ($self->{load_path}, 1) 2109 $self->_load_objects ($f)
1906 or return; 2110 or return;
1907 2111
1908 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2112 $self->post_load_original
1909 if delete $self->{load_original}; 2113 if delete $self->{load_original};
1910 2114
1911 if (my $uniq = $self->uniq_path) { 2115 if (my $uniq = $self->uniq_path) {
1912 utf8::encode $uniq; 2116 utf8::encode $uniq;
1913 if (aio_open $uniq, O_RDONLY, 0) { 2117 unless (aio_stat $uniq) {
2118 if (my $f = new_from_file cf::object::thawer $uniq) {
1914 $self->clear_unique_items; 2119 $self->clear_unique_items;
1915 $self->_load_objects ($uniq, 0); 2120 $self->_load_objects ($f);
2121 $f->resolve_delayed_derefs;
2122 }
1916 } 2123 }
1917 } 2124 }
1918 2125
1919 Coro::cede; 2126 $f->resolve_delayed_derefs;
2127
2128 cf::cede_to_tick;
1920 # now do the right thing for maps 2129 # now do the right thing for maps
1921 $self->link_multipart_objects; 2130 $self->link_multipart_objects;
1922 $self->difficulty ($self->estimate_difficulty) 2131 $self->difficulty ($self->estimate_difficulty)
1923 unless $self->difficulty; 2132 unless $self->difficulty;
1924 Coro::cede; 2133 cf::cede_to_tick;
1925 2134
1926 unless ($self->{deny_activate}) { 2135 unless ($self->{deny_activate}) {
1927 $self->decay_objects; 2136 $self->decay_objects;
1928 $self->fix_auto_apply; 2137 $self->fix_auto_apply;
1929 $self->update_buttons; 2138 $self->update_buttons;
1930 Coro::cede; 2139 cf::cede_to_tick;
1931 $self->set_darkness_map;
1932 Coro::cede;
1933 $self->activate; 2140 $self->activate;
1934 } 2141 }
1935 2142
1936 $self->{last_save} = $cf::RUNTIME; 2143 $self->{last_save} = $cf::RUNTIME;
1937 $self->last_access ($cf::RUNTIME); 2144 $self->last_access ($cf::RUNTIME);
1938 2145
1939 $self->in_memory (cf::MAP_IN_MEMORY); 2146 $self->in_memory (cf::MAP_ACTIVE);
1940 } 2147 }
1941 2148
1942 $self->post_load; 2149 $self->post_load;
1943} 2150}
1944 2151
2152# customize the map for a given player, i.e.
2153# return the _real_ map. used by e.g. per-player
2154# maps to change the path to ~playername/mappath
1945sub customise_for { 2155sub customise_for {
1946 my ($self, $ob) = @_; 2156 my ($self, $ob) = @_;
1947 2157
1948 return find "~" . $ob->name . "/" . $self->{path} 2158 return find "~" . $ob->name . "/" . $self->{path}
1949 if $self->per_player; 2159 if $self->per_player;
… …
1953 2163
1954 $self 2164 $self
1955} 2165}
1956 2166
1957# find and load all maps in the 3x3 area around a map 2167# find and load all maps in the 3x3 area around a map
1958sub load_diag { 2168sub load_neighbours {
1959 my ($map) = @_; 2169 my ($map) = @_;
1960 2170
1961 my @diag; # diagonal neighbours 2171 my @neigh; # diagonal neighbours
1962 2172
1963 for (0 .. 3) { 2173 for (0 .. 3) {
1964 my $neigh = $map->tile_path ($_) 2174 my $neigh = $map->tile_path ($_)
1965 or next; 2175 or next;
1966 $neigh = find $neigh, $map 2176 $neigh = find $neigh, $map
1967 or next; 2177 or next;
1968 $neigh->load; 2178 $neigh->load;
1969 2179
2180 # now find the diagonal neighbours
2181 push @neigh,
1970 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 2182 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1971 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2183 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1972 } 2184 }
1973 2185
1974 for (@diag) { 2186 for (grep defined $_->[0], @neigh) {
2187 my ($path, $origin) = @$_;
1975 my $neigh = find @$_ 2188 my $neigh = find $path, $origin
1976 or next; 2189 or next;
1977 $neigh->load; 2190 $neigh->load;
1978 } 2191 }
1979} 2192}
1980 2193
1981sub find_sync { 2194sub find_sync {
1982 my ($path, $origin) = @_; 2195 my ($path, $origin) = @_;
1983 2196
1984 cf::sync_job { find $path, $origin } 2197 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync"
2198 if $Coro::current == $Coro::main;
2199
2200 find $path, $origin
1985} 2201}
1986 2202
1987sub do_load_sync { 2203sub do_load_sync {
1988 my ($map) = @_; 2204 my ($map) = @_;
1989 2205
1990 cf::sync_job { $map->load }; 2206 return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync"
2207 if $Coro::current == $Coro::main;
2208
2209 $map->load;
1991} 2210}
1992 2211
1993our %MAP_PREFETCH; 2212our %MAP_PREFETCH;
1994our $MAP_PREFETCHER = undef; 2213our $MAP_PREFETCHER = undef;
1995 2214
1996sub find_async { 2215sub find_async {
1997 my ($path, $origin) = @_; 2216 my ($path, $origin, $load) = @_;
1998 2217
1999 $path = normalise $path, $origin && $origin->{path}; 2218 $path = normalise $path, $origin && $origin->{path};
2000 2219
2001 if (my $map = $cf::MAP{$path}) { 2220 if (my $map = $cf::MAP{$path}) {
2002 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 2221 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
2003 } 2222 }
2004 2223
2005 undef $MAP_PREFETCH{$path}; 2224 $MAP_PREFETCH{$path} |= $load;
2225
2006 $MAP_PREFETCHER ||= cf::async { 2226 $MAP_PREFETCHER ||= cf::async {
2227 $Coro::current->{desc} = "map prefetcher";
2228
2007 while (%MAP_PREFETCH) { 2229 while (%MAP_PREFETCH) {
2008 for my $path (keys %MAP_PREFETCH) { 2230 while (my ($k, $v) = each %MAP_PREFETCH) {
2009 if (my $map = find $path) { 2231 if (my $map = find $k) {
2010 $map->load; 2232 $map->load if $v;
2011 } 2233 }
2012 2234
2013 delete $MAP_PREFETCH{$path}; 2235 delete $MAP_PREFETCH{$k};
2014 } 2236 }
2015 } 2237 }
2016 undef $MAP_PREFETCHER; 2238 undef $MAP_PREFETCHER;
2017 }; 2239 };
2018 $MAP_PREFETCHER->prio (6); 2240 $MAP_PREFETCHER->prio (6);
2019 2241
2020 () 2242 ()
2021} 2243}
2022 2244
2245# common code, used by both ->save and ->swapout
2023sub save { 2246sub _save {
2024 my ($self) = @_; 2247 my ($self) = @_;
2025
2026 my $lock = cf::lock_acquire "map_data:" . $self->path;
2027 2248
2028 $self->{last_save} = $cf::RUNTIME; 2249 $self->{last_save} = $cf::RUNTIME;
2029 2250
2030 return unless $self->dirty; 2251 return unless $self->dirty;
2031 2252
… …
2037 return if $self->{deny_save}; 2258 return if $self->{deny_save};
2038 2259
2039 local $self->{last_access} = $self->last_access;#d# 2260 local $self->{last_access} = $self->last_access;#d#
2040 2261
2041 cf::async { 2262 cf::async {
2263 $Coro::current->{desc} = "map player save";
2042 $_->contr->save for $self->players; 2264 $_->contr->save for $self->players;
2043 }; 2265 };
2266
2267 cf::get_slot 0.02;
2044 2268
2045 if ($uniq) { 2269 if ($uniq) {
2046 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2270 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
2047 $self->_save_objects ($uniq, cf::IO_UNIQUES); 2271 $self->_save_objects ($uniq, cf::IO_UNIQUES);
2048 } else { 2272 } else {
2049 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 2273 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
2050 } 2274 }
2051} 2275}
2052 2276
2277sub save {
2278 my ($self) = @_;
2279
2280 my $lock = cf::lock_acquire "map_data:$self->{path}";
2281
2282 $self->_save;
2283}
2284
2053sub swap_out { 2285sub swap_out {
2054 my ($self) = @_; 2286 my ($self) = @_;
2055 2287
2056 # save first because save cedes
2057 $self->save;
2058
2059 my $lock = cf::lock_acquire "map_data:" . $self->path; 2288 my $lock = cf::lock_acquire "map_data:$self->{path}";
2060 2289
2290 return if $self->in_memory != cf::MAP_ACTIVE;
2291 return if $self->{deny_save};
2061 return if $self->players; 2292 return if $self->players;
2062 return if $self->in_memory != cf::MAP_IN_MEMORY;
2063 return if $self->{deny_save};
2064 2293
2294 # first deactivate the map and "unlink" it from the core
2295 $self->deactivate;
2296 $_->clear_links_to ($self) for values %cf::MAP;
2297 $self->in_memory (cf::MAP_SWAPPED);
2298
2299 # then atomically save
2300 $self->_save;
2301
2302 # then free the map
2065 $self->clear; 2303 $self->clear;
2066 $self->in_memory (cf::MAP_SWAPPED);
2067} 2304}
2068 2305
2069sub reset_at { 2306sub reset_at {
2070 my ($self) = @_; 2307 my ($self) = @_;
2071 2308
… …
2089 2326
2090 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2327 my $lock = cf::lock_acquire "map_data:$self->{path}";
2091 2328
2092 return if $self->players; 2329 return if $self->players;
2093 2330
2094 warn "resetting map ", $self->path; 2331 cf::trace "resetting map ", $self->path, "\n";
2095 2332
2096 $self->in_memory (cf::MAP_SWAPPED); 2333 $self->in_memory (cf::MAP_SWAPPED);
2097 2334
2098 # need to save uniques path 2335 # need to save uniques path
2099 unless ($self->{deny_save}) { 2336 unless ($self->{deny_save}) {
… …
2103 if $uniq; 2340 if $uniq;
2104 } 2341 }
2105 2342
2106 delete $cf::MAP{$self->path}; 2343 delete $cf::MAP{$self->path};
2107 2344
2345 $self->deactivate;
2346 $_->clear_links_to ($self) for values %cf::MAP;
2108 $self->clear; 2347 $self->clear;
2109
2110 $_->clear_links_to ($self) for values %cf::MAP;
2111 2348
2112 $self->unlink_save; 2349 $self->unlink_save;
2113 $self->destroy; 2350 $self->destroy;
2114} 2351}
2115 2352
2116my $nuke_counter = "aaaa"; 2353my $nuke_counter = "aaaa";
2117 2354
2118sub nuke { 2355sub nuke {
2119 my ($self) = @_; 2356 my ($self) = @_;
2120 2357
2358 {
2359 my $lock = cf::lock_acquire "map_data:$self->{path}";
2360
2121 delete $cf::MAP{$self->path}; 2361 delete $cf::MAP{$self->path};
2122 2362
2123 $self->unlink_save; 2363 $self->unlink_save;
2124 2364
2125 bless $self, "cf::map"; 2365 bless $self, "cf::map::wrap";
2126 delete $self->{deny_reset}; 2366 delete $self->{deny_reset};
2127 $self->{deny_save} = 1; 2367 $self->{deny_save} = 1;
2128 $self->reset_timeout (1); 2368 $self->reset_timeout (1);
2129 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2369 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2130 2370
2131 $cf::MAP{$self->path} = $self; 2371 $cf::MAP{$self->path} = $self;
2372 }
2132 2373
2133 $self->reset; # polite request, might not happen 2374 $self->reset; # polite request, might not happen
2134} 2375}
2135 2376
2136=item $maps = cf::map::tmp_maps 2377=item $maps = cf::map::tmp_maps
… …
2178 2419
2179sub unique_maps() { 2420sub unique_maps() {
2180 [ 2421 [
2181 map { 2422 map {
2182 utf8::decode $_; 2423 utf8::decode $_;
2183 /\.map$/ 2424 s/\.map$//; # TODO future compatibility hack
2425 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
2426 ? ()
2184 ? normalise $_ 2427 : normalise $_
2185 : ()
2186 } @{ aio_readdir $UNIQUEDIR or [] } 2428 } @{ aio_readdir $UNIQUEDIR or [] }
2187 ] 2429 ]
2188} 2430}
2189 2431
2190package cf; 2432=item cf::map::static_maps
2433
2434Returns an arrayref if paths of all static maps (all preinstalled F<.map>
2435file in the shared directory excluding F</styles> and F</editor>). May
2436block.
2437
2438=cut
2439
2440sub static_maps() {
2441 my @dirs = "";
2442 my @maps;
2443
2444 while (@dirs) {
2445 my $dir = shift @dirs;
2446
2447 next if $dir eq "/styles" || $dir eq "/editor";
2448
2449 my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
2450 or return;
2451
2452 for (@$files) {
2453 s/\.map$// or next;
2454 utf8::decode $_;
2455 push @maps, "$dir/$_";
2456 }
2457
2458 push @dirs, map "$dir/$_", @$dirs;
2459 }
2460
2461 \@maps
2462}
2191 2463
2192=back 2464=back
2193 2465
2194=head3 cf::object 2466=head3 cf::object
2195 2467
… …
2199 2471
2200=over 4 2472=over 4
2201 2473
2202=item $ob->inv_recursive 2474=item $ob->inv_recursive
2203 2475
2204Returns the inventory of the object _and_ their inventories, recursively. 2476Returns the inventory of the object I<and> their inventories, recursively,
2477but I<not> the object itself.
2205 2478
2206=cut 2479=cut
2207 2480
2208sub inv_recursive_; 2481sub inv_recursive_;
2209sub inv_recursive_ { 2482sub inv_recursive_ {
… …
2212 2485
2213sub inv_recursive { 2486sub inv_recursive {
2214 inv_recursive_ inv $_[0] 2487 inv_recursive_ inv $_[0]
2215} 2488}
2216 2489
2490=item $ref = $ob->ref
2491
2492Creates and returns a persistent reference to an object that can be stored as a string.
2493
2494=item $ob = cf::object::deref ($refstring)
2495
2496returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2497even if the object actually exists. May block.
2498
2499=cut
2500
2501sub deref {
2502 my ($ref) = @_;
2503
2504 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2505 my ($uuid, $name) = ($1, $2);
2506 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2507 or return;
2508 $pl->ob->uuid eq $uuid
2509 or return;
2510
2511 $pl->ob
2512 } else {
2513 warn "$ref: cannot resolve object reference\n";
2514 undef
2515 }
2516}
2517
2217package cf; 2518package cf;
2218 2519
2219=back 2520=back
2220 2521
2221=head3 cf::object::player 2522=head3 cf::object::player
… …
2227Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 2528Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
2228can be C<undef>. Does the right thing when the player is currently in a 2529can be C<undef>. Does the right thing when the player is currently in a
2229dialogue with the given NPC character. 2530dialogue with the given NPC character.
2230 2531
2231=cut 2532=cut
2533
2534our $SAY_CHANNEL = {
2535 id => "say",
2536 title => "Map",
2537 reply => "say ",
2538 tooltip => "Things said to and replied from NPCs near you and other players on the same map only.",
2539};
2540
2541our $CHAT_CHANNEL = {
2542 id => "chat",
2543 title => "Chat",
2544 reply => "chat ",
2545 tooltip => "Player chat and shouts, global to the server.",
2546};
2232 2547
2233# rough implementation of a future "reply" method that works 2548# rough implementation of a future "reply" method that works
2234# with dialog boxes. 2549# with dialog boxes.
2235#TODO: the first argument must go, split into a $npc->reply_to ( method 2550#TODO: the first argument must go, split into a $npc->reply_to ( method
2236sub cf::object::player::reply($$$;$) { 2551sub cf::object::player::reply($$$;$) {
… …
2248 my $dialog = $pl->{npc_dialog}; 2563 my $dialog = $pl->{npc_dialog};
2249 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg)); 2564 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2250 2565
2251 } else { 2566 } else {
2252 $msg = $npc->name . " says: $msg" if $npc; 2567 $msg = $npc->name . " says: $msg" if $npc;
2253 $self->message ($msg, $flags); 2568 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2254 } 2569 }
2255 } 2570 }
2256} 2571}
2257 2572
2258=item $object->send_msg ($channel, $msg, $color, [extra...]) 2573=item $object->send_msg ($channel, $msg, $color, [extra...])
… …
2283 2598
2284=item $player_object->enter_link 2599=item $player_object->enter_link
2285 2600
2286Freezes the player and moves him/her to a special map (C<{link}>). 2601Freezes the player and moves him/her to a special map (C<{link}>).
2287 2602
2288The player should be reasonably safe there for short amounts of time. You 2603The player should be reasonably safe there for short amounts of time (e.g.
2289I<MUST> call C<leave_link> as soon as possible, though. 2604for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2605though, as the player cannot control the character while it is on the link
2606map.
2290 2607
2291Will never block. 2608Will never block.
2292 2609
2293=item $player_object->leave_link ($map, $x, $y) 2610=item $player_object->leave_link ($map, $x, $y)
2294 2611
… …
2314sub cf::object::player::enter_link { 2631sub cf::object::player::enter_link {
2315 my ($self) = @_; 2632 my ($self) = @_;
2316 2633
2317 $self->deactivate_recursive; 2634 $self->deactivate_recursive;
2318 2635
2636 ++$self->{_link_recursion};
2637
2319 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2638 return if UNIVERSAL::isa $self->map, "ext::map_link";
2320 2639
2321 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2640 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2322 if $self->map && $self->map->{path} ne "{link}"; 2641 if $self->map && $self->map->{path} ne "{link}";
2323 2642
2324 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2643 $self->enter_map ($LINK_MAP || link_map, 3, 3);
2325} 2644}
2326 2645
2327sub cf::object::player::leave_link { 2646sub cf::object::player::leave_link {
2328 my ($self, $map, $x, $y) = @_; 2647 my ($self, $map, $x, $y) = @_;
2329 2648
… …
2346 ($x, $y) = (-1, -1) 2665 ($x, $y) = (-1, -1)
2347 unless (defined $x) && (defined $y); 2666 unless (defined $x) && (defined $y);
2348 2667
2349 # use -1 or undef as default coordinates, not 0, 0 2668 # use -1 or undef as default coordinates, not 0, 0
2350 ($x, $y) = ($map->enter_x, $map->enter_y) 2669 ($x, $y) = ($map->enter_x, $map->enter_y)
2351 if $x <=0 && $y <= 0; 2670 if $x <= 0 && $y <= 0;
2352 2671
2353 $map->load; 2672 $map->load;
2354 $map->load_diag; 2673 $map->load_neighbours;
2355 2674
2356 return unless $self->contr->active; 2675 return unless $self->contr->active;
2357 $self->activate_recursive;
2358 2676
2359 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2677 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2360 $self->enter_map ($map, $x, $y); 2678 if ($self->enter_map ($map, $x, $y)) {
2361} 2679 # entering was successful
2680 delete $self->{_link_recursion};
2681 # only activate afterwards, to support waiting in hooks
2682 $self->activate_recursive;
2683 }
2362 2684
2685}
2686
2363=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]]) 2687=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
2364 2688
2365Moves the player to the given map-path and coordinates by first freezing 2689Moves the player to the given map-path and coordinates by first freezing
2366her, loading and preparing them map, calling the provided $check callback 2690her, loading and preparing them map, calling the provided $check callback
2367that has to return the map if sucecssful, and then unfreezes the player on 2691that has to return the map if sucecssful, and then unfreezes the player on
2368the new (success) or old (failed) map position. In either case, $done will 2692the new (success) or old (failed) map position. In either case, $done will
2369be called at the end of this process. 2693be called at the end of this process.
2370 2694
2695Note that $check will be called with a potentially non-loaded map, so if
2696it needs a loaded map it has to call C<< ->load >>.
2697
2371=cut 2698=cut
2372 2699
2373our $GOTOGEN; 2700our $GOTOGEN;
2374 2701
2375sub cf::object::player::goto { 2702sub cf::object::player::goto {
2376 my ($self, $path, $x, $y, $check, $done) = @_; 2703 my ($self, $path, $x, $y, $check, $done) = @_;
2377 2704
2705 if ($self->{_link_recursion} >= $MAX_LINKS) {
2706 error "FATAL: link recursion exceeded, ", $self->name, " goto $path $x $y, redirecting.";
2707 $self->failmsg ("Something went wrong inside the server - please contact an administrator!");
2708 ($path, $x, $y) = @$EMERGENCY_POSITION;
2709 }
2710
2378 # do generation counting so two concurrent goto's will be executed in-order 2711 # do generation counting so two concurrent goto's will be executed in-order
2379 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2712 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2380 2713
2381 $self->enter_link; 2714 $self->enter_link;
2382 2715
2383 (async { 2716 (async {
2717 $Coro::current->{desc} = "player::goto $path $x $y";
2718
2719 # *tag paths override both path and x|y
2720 if ($path =~ /^\*(.*)$/) {
2721 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2722 my $ob = $obs[rand @obs];
2723
2724 # see if we actually can go there
2725 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2726 $ob = $obs[rand @obs];
2727 } else {
2728 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2729 }
2730 # else put us there anyways for now #d#
2731
2732 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2733 } else {
2734 ($path, $x, $y) = (undef, undef, undef);
2735 }
2736 }
2737
2384 my $map = eval { 2738 my $map = eval {
2385 my $map = cf::map::find $path; 2739 my $map = defined $path ? cf::map::find $path : undef;
2386 2740
2387 if ($map) { 2741 if ($map) {
2388 $map = $map->customise_for ($self); 2742 $map = $map->customise_for ($self);
2389 $map = $check->($map) if $check && $map; 2743 $map = $check->($map, $x, $y, $self) if $check && $map;
2390 } else { 2744 } else {
2391 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED); 2745 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2392 } 2746 }
2393 2747
2394 $map 2748 $map
2395 }; 2749 };
2396 2750
… …
2402 if ($gen == $self->{_goto_generation}) { 2756 if ($gen == $self->{_goto_generation}) {
2403 delete $self->{_goto_generation}; 2757 delete $self->{_goto_generation};
2404 $self->leave_link ($map, $x, $y); 2758 $self->leave_link ($map, $x, $y);
2405 } 2759 }
2406 2760
2407 $done->() if $done; 2761 $done->($self) if $done;
2408 })->prio (1); 2762 })->prio (1);
2409} 2763}
2410 2764
2411=item $player_object->enter_exit ($exit_object) 2765=item $player_object->enter_exit ($exit_object)
2412 2766
… …
2432} 2786}
2433 2787
2434sub prepare_random_map { 2788sub prepare_random_map {
2435 my ($exit) = @_; 2789 my ($exit) = @_;
2436 2790
2437 my $guard = cf::lock_acquire "exit_prepare:$exit";
2438
2439 # all this does is basically replace the /! path by 2791 # all this does is basically replace the /! path by
2440 # a new random map path (?random/...) with a seed 2792 # a new random map path (?random/...) with a seed
2441 # that depends on the exit object 2793 # that depends on the exit object
2442 2794
2443 my $rmp = parse_random_map_params $exit->msg; 2795 my $rmp = parse_random_map_params $exit->msg;
… …
2445 if ($exit->map) { 2797 if ($exit->map) {
2446 $rmp->{region} = $exit->region->name; 2798 $rmp->{region} = $exit->region->name;
2447 $rmp->{origin_map} = $exit->map->path; 2799 $rmp->{origin_map} = $exit->map->path;
2448 $rmp->{origin_x} = $exit->x; 2800 $rmp->{origin_x} = $exit->x;
2449 $rmp->{origin_y} = $exit->y; 2801 $rmp->{origin_y} = $exit->y;
2802
2803 $exit->map->touch;
2450 } 2804 }
2451 2805
2452 $rmp->{random_seed} ||= $exit->random_seed; 2806 $rmp->{random_seed} ||= $exit->random_seed;
2453 2807
2454 my $data = cf::to_json $rmp; 2808 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2455 my $md5 = Digest::MD5::md5_hex $data; 2809 my $md5 = Digest::MD5::md5_hex $data;
2456 my $meta = "$RANDOMDIR/$md5.meta"; 2810 my $meta = "$RANDOMDIR/$md5.meta";
2457 2811
2458 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2812 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2459 aio_write $fh, 0, (length $data), $data, 0; 2813 aio_write $fh, 0, (length $data), $data, 0;
2460 undef $fh; 2814 undef $fh;
2461 aio_rename "$meta~", $meta; 2815 aio_rename "$meta~", $meta;
2462 2816
2817 my $slaying = "?random/$md5";
2818
2819 if ($exit->valid) {
2463 $exit->slaying ("?random/$md5"); 2820 $exit->slaying ("?random/$md5");
2464 $exit->msg (undef); 2821 $exit->msg (undef);
2822 }
2465 } 2823 }
2466} 2824}
2467 2825
2468sub cf::object::player::enter_exit { 2826sub cf::object::player::enter_exit {
2469 my ($self, $exit) = @_; 2827 my ($self, $exit) = @_;
2470 2828
2471 return unless $self->type == cf::PLAYER; 2829 return unless $self->type == cf::PLAYER;
2472 2830
2473 if ($exit->slaying eq "/!") {
2474 #TODO: this should de-fi-ni-te-ly not be a sync-job
2475 # the problem is that $exit might not survive long enough
2476 # so it needs to be done right now, right here
2477 cf::sync_job { prepare_random_map $exit };
2478 }
2479
2480 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2481 my $hp = $exit->stats->hp;
2482 my $sp = $exit->stats->sp;
2483
2484 $self->enter_link; 2831 $self->enter_link;
2485 2832
2486 # if exit is damned, update players death & WoR home-position
2487 $self->contr->savebed ($slaying, $hp, $sp)
2488 if $exit->flag (FLAG_DAMNED);
2489
2490 (async { 2833 (async {
2491 $self->deactivate_recursive; # just to be sure 2834 $Coro::current->{desc} = "enter_exit";
2835
2492 unless (eval { 2836 unless (eval {
2837 $self->deactivate_recursive; # just to be sure
2838
2839 # random map handling
2840 {
2841 my $guard = cf::lock_acquire "exit_prepare:$exit";
2842
2843 prepare_random_map $exit
2844 if $exit->slaying eq "/!";
2845 }
2846
2847 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2848 my $x = $exit->stats->hp;
2849 my $y = $exit->stats->sp;
2850
2493 $self->goto ($slaying, $hp, $sp); 2851 $self->goto ($map, $x, $y);
2494 2852
2853 # if exit is damned, update players death & WoR home-position
2854 $self->contr->savebed ($map, $x, $y)
2855 if $exit->flag (cf::FLAG_DAMNED);
2856
2495 1; 2857 1
2496 }) { 2858 }) {
2497 $self->message ("Something went wrong deep within the crossfire server. " 2859 $self->message ("Something went wrong deep within the deliantra server. "
2498 . "I'll try to bring you back to the map you were before. " 2860 . "I'll try to bring you back to the map you were before. "
2499 . "Please report this to the dungeon master!", 2861 . "Please report this to the dungeon master!",
2500 cf::NDI_UNIQUE | cf::NDI_RED); 2862 cf::NDI_UNIQUE | cf::NDI_RED);
2501 2863
2502 warn "ERROR in enter_exit: $@"; 2864 error "ERROR in enter_exit: $@";
2503 $self->leave_link; 2865 $self->leave_link;
2504 } 2866 }
2505 })->prio (1); 2867 })->prio (1);
2506} 2868}
2507 2869
… …
2519sub cf::client::send_drawinfo { 2881sub cf::client::send_drawinfo {
2520 my ($self, $text, $flags) = @_; 2882 my ($self, $text, $flags) = @_;
2521 2883
2522 utf8::encode $text; 2884 utf8::encode $text;
2523 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2885 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2886}
2887
2888=item $client->send_big_packet ($pkt)
2889
2890Like C<send_packet>, but tries to compress large packets, and fragments
2891them as required.
2892
2893=cut
2894
2895our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
2896
2897sub cf::client::send_big_packet {
2898 my ($self, $pkt) = @_;
2899
2900 # try lzf for large packets
2901 $pkt = "lzf " . Compress::LZF::compress $pkt
2902 if 1024 <= length $pkt and $self->{can_lzf};
2903
2904 # split very large packets
2905 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
2906 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
2907 $pkt = "frag";
2908 }
2909
2910 $self->send_packet ($pkt);
2524} 2911}
2525 2912
2526=item $client->send_msg ($channel, $msg, $color, [extra...]) 2913=item $client->send_msg ($channel, $msg, $color, [extra...])
2527 2914
2528Send a drawinfo or msg packet to the client, formatting the msg for the 2915Send a drawinfo or msg packet to the client, formatting the msg for the
… …
2530the message, with C<log> being the default. If C<$color> is negative, suppress 2917the message, with C<log> being the default. If C<$color> is negative, suppress
2531the message unless the client supports the msg packet. 2918the message unless the client supports the msg packet.
2532 2919
2533=cut 2920=cut
2534 2921
2922# non-persistent channels (usually the info channel)
2923our %CHANNEL = (
2924 "c/motd" => {
2925 id => "infobox",
2926 title => "MOTD",
2927 reply => undef,
2928 tooltip => "The message of the day",
2929 },
2930 "c/identify" => {
2931 id => "infobox",
2932 title => "Identify",
2933 reply => undef,
2934 tooltip => "Items recently identified",
2935 },
2936 "c/examine" => {
2937 id => "infobox",
2938 title => "Examine",
2939 reply => undef,
2940 tooltip => "Signs and other items you examined",
2941 },
2942 "c/shopinfo" => {
2943 id => "infobox",
2944 title => "Shop Info",
2945 reply => undef,
2946 tooltip => "What your bargaining skill tells you about the shop",
2947 },
2948 "c/book" => {
2949 id => "infobox",
2950 title => "Book",
2951 reply => undef,
2952 tooltip => "The contents of a note or book",
2953 },
2954 "c/lookat" => {
2955 id => "infobox",
2956 title => "Look",
2957 reply => undef,
2958 tooltip => "What you saw there",
2959 },
2960 "c/who" => {
2961 id => "infobox",
2962 title => "Players",
2963 reply => undef,
2964 tooltip => "Shows players who are currently online",
2965 },
2966 "c/body" => {
2967 id => "infobox",
2968 title => "Body Parts",
2969 reply => undef,
2970 tooltip => "Shows which body parts you posess and are available",
2971 },
2972 "c/statistics" => {
2973 id => "infobox",
2974 title => "Statistics",
2975 reply => undef,
2976 tooltip => "Shows your primary statistics",
2977 },
2978 "c/skills" => {
2979 id => "infobox",
2980 title => "Skills",
2981 reply => undef,
2982 tooltip => "Shows your experience per skill and item power",
2983 },
2984 "c/shopitems" => {
2985 id => "infobox",
2986 title => "Shop Items",
2987 reply => undef,
2988 tooltip => "Shows the items currently for sale in this shop",
2989 },
2990 "c/resistances" => {
2991 id => "infobox",
2992 title => "Resistances",
2993 reply => undef,
2994 tooltip => "Shows your resistances",
2995 },
2996 "c/pets" => {
2997 id => "infobox",
2998 title => "Pets",
2999 reply => undef,
3000 tooltip => "Shows information abotu your pets/a specific pet",
3001 },
3002 "c/perceiveself" => {
3003 id => "infobox",
3004 title => "Perceive Self",
3005 reply => undef,
3006 tooltip => "You gained detailed knowledge about yourself",
3007 },
3008 "c/uptime" => {
3009 id => "infobox",
3010 title => "Uptime",
3011 reply => undef,
3012 tooltip => "How long the server has been running since last restart",
3013 },
3014 "c/mapinfo" => {
3015 id => "infobox",
3016 title => "Map Info",
3017 reply => undef,
3018 tooltip => "Information related to the maps",
3019 },
3020 "c/party" => {
3021 id => "party",
3022 title => "Party",
3023 reply => "gsay ",
3024 tooltip => "Messages and chat related to your party",
3025 },
3026 "c/death" => {
3027 id => "death",
3028 title => "Death",
3029 reply => undef,
3030 tooltip => "Reason for and more info about your most recent death",
3031 },
3032 "c/say" => $SAY_CHANNEL,
3033 "c/chat" => $CHAT_CHANNEL,
3034);
3035
2535sub cf::client::send_msg { 3036sub cf::client::send_msg {
2536 my ($self, $channel, $msg, $color, @extra) = @_; 3037 my ($self, $channel, $msg, $color, @extra) = @_;
2537 3038
2538 $msg = $self->pl->expand_cfpod ($msg); 3039 $msg = $self->pl->expand_cfpod ($msg)
3040 unless $color & cf::NDI_VERBATIM;
2539 3041
2540 $color &= cf::NDI_CLIENT_MASK; # just in case... 3042 $color &= cf::NDI_CLIENT_MASK; # just in case...
2541 3043
3044 # check predefined channels, for the benefit of C
3045 if ($CHANNEL{$channel}) {
3046 $channel = $CHANNEL{$channel};
3047
3048 $self->ext_msg (channel_info => $channel);
3049 $channel = $channel->{id};
3050
2542 if (ref $channel) { 3051 } elsif (ref $channel) {
2543 # send meta info to client, if not yet sent 3052 # send meta info to client, if not yet sent
2544 unless (exists $self->{channel}{$channel->{id}}) { 3053 unless (exists $self->{channel}{$channel->{id}}) {
2545 $self->{channel}{$channel->{id}} = $channel; 3054 $self->{channel}{$channel->{id}} = $channel;
2546 $self->ext_msg (channel_info => $channel); 3055 $self->ext_msg (channel_info => $channel);
2547 } 3056 }
… …
2549 $channel = $channel->{id}; 3058 $channel = $channel->{id};
2550 } 3059 }
2551 3060
2552 return unless @extra || length $msg; 3061 return unless @extra || length $msg;
2553 3062
2554 if ($self->can_msg) {
2555 # default colour, mask it out 3063 # default colour, mask it out
2556 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF) 3064 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2557 if $color & cf::NDI_DEF; 3065 if $color & cf::NDI_DEF;
2558 3066
2559 $self->send_packet ("msg " . $self->{json_coder}->encode ( 3067 my $pkt = "msg "
3068 . $self->{json_coder}->encode (
2560 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra])); 3069 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2561 } else { 3070 );
2562 if ($color >= 0) {
2563 # replace some tags by gcfclient-compatible ones
2564 for ($msg) {
2565 1 while
2566 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2567 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2568 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2569 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2570 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2571 }
2572 3071
2573 $color &= cf::NDI_COLOR_MASK; 3072 $self->send_big_packet ($pkt);
2574
2575 utf8::encode $msg;
2576
2577 if (0 && $msg =~ /\[/) {
2578 $self->send_packet ("drawextinfo $color 4 0 $msg")
2579 } else {
2580 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2581 $self->send_packet ("drawinfo $color $msg")
2582 }
2583 }
2584 }
2585} 3073}
2586 3074
2587=item $client->ext_msg ($type, @msg) 3075=item $client->ext_msg ($type, @msg)
2588 3076
2589Sends an ext event to the client. 3077Sends an ext event to the client.
… …
2591=cut 3079=cut
2592 3080
2593sub cf::client::ext_msg($$@) { 3081sub cf::client::ext_msg($$@) {
2594 my ($self, $type, @msg) = @_; 3082 my ($self, $type, @msg) = @_;
2595 3083
2596 my $extcmd = $self->extcmd;
2597
2598 if ($extcmd == 2) { 3084 if ($self->extcmd == 2) {
2599 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 3085 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2600 } elsif ($extcmd == 1) { # TODO: remove 3086 } elsif ($self->extcmd == 1) { # TODO: remove
2601 push @msg, msgtype => "event_$type"; 3087 push @msg, msgtype => "event_$type";
2602 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3088 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3089 }
3090}
3091
3092=item $client->ext_reply ($msgid, @msg)
3093
3094Sends an ext reply to the client.
3095
3096=cut
3097
3098sub cf::client::ext_reply($$@) {
3099 my ($self, $id, @msg) = @_;
3100
3101 if ($self->extcmd == 2) {
3102 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
3103 } elsif ($self->extcmd == 1) {
3104 #TODO: version 1, remove
3105 unshift @msg, msgtype => "reply", msgid => $id;
3106 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2603 } 3107 }
2604} 3108}
2605 3109
2606=item $success = $client->query ($flags, "text", \&cb) 3110=item $success = $client->query ($flags, "text", \&cb)
2607 3111
… …
2668 my ($type, $reply, @payload) = 3172 my ($type, $reply, @payload) =
2669 "ARRAY" eq ref $msg 3173 "ARRAY" eq ref $msg
2670 ? @$msg 3174 ? @$msg
2671 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove 3175 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
2672 3176
3177 my @reply;
3178
2673 if (my $cb = $EXTICMD{$type}) { 3179 if (my $cb = $EXTICMD{$type}) {
2674 my @reply = $cb->($ns, @payload); 3180 @reply = $cb->($ns, @payload);
2675
2676 $ns->ext_reply ($reply, @reply)
2677 if $reply;
2678 } 3181 }
3182
3183 $ns->ext_reply ($reply, @reply)
3184 if $reply;
3185
2679 } else { 3186 } else {
2680 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 3187 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2681 } 3188 }
2682 3189
2683 cf::override; 3190 cf::override;
2684 }, 3191 },
2685); 3192);
… …
2705 3212
2706 $coro 3213 $coro
2707} 3214}
2708 3215
2709cf::client->attach ( 3216cf::client->attach (
2710 on_destroy => sub { 3217 on_client_destroy => sub {
2711 my ($ns) = @_; 3218 my ($ns) = @_;
2712 3219
2713 $_->cancel for values %{ (delete $ns->{_coro}) || {} }; 3220 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
2714 }, 3221 },
2715); 3222);
… …
2731our $safe_hole = new Safe::Hole; 3238our $safe_hole = new Safe::Hole;
2732 3239
2733$SIG{FPE} = 'IGNORE'; 3240$SIG{FPE} = 'IGNORE';
2734 3241
2735$safe->permit_only (Opcode::opset qw( 3242$safe->permit_only (Opcode::opset qw(
2736 :base_core :base_mem :base_orig :base_math 3243 :base_core :base_mem :base_orig :base_math :base_loop
2737 grepstart grepwhile mapstart mapwhile 3244 grepstart grepwhile mapstart mapwhile
2738 sort time 3245 sort time
2739)); 3246));
2740 3247
2741# here we export the classes and methods available to script code 3248# here we export the classes and methods available to script code
… …
2743=pod 3250=pod
2744 3251
2745The following functions and methods are available within a safe environment: 3252The following functions and methods are available within a safe environment:
2746 3253
2747 cf::object 3254 cf::object
2748 contr pay_amount pay_player map x y force_find force_add 3255 contr pay_amount pay_player map x y force_find force_add destroy
2749 insert remove 3256 insert remove name archname title slaying race decrease split
3257 value
2750 3258
2751 cf::object::player 3259 cf::object::player
2752 player 3260 player
2753 3261
2754 cf::player 3262 cf::player
… …
2759 3267
2760=cut 3268=cut
2761 3269
2762for ( 3270for (
2763 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3271 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2764 insert remove inv)], 3272 insert remove inv nrof name archname title slaying race
3273 decrease split destroy change_exp value msg lore send_msg)],
2765 ["cf::object::player" => qw(player)], 3274 ["cf::object::player" => qw(player)],
2766 ["cf::player" => qw(peaceful)], 3275 ["cf::player" => qw(peaceful send_msg)],
2767 ["cf::map" => qw(trigger)], 3276 ["cf::map" => qw(trigger)],
2768) { 3277) {
2769 no strict 'refs'; 3278 no strict 'refs';
2770 my ($pkg, @funs) = @$_; 3279 my ($pkg, @funs) = @$_;
2771 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3280 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
… …
2789 3298
2790 my $qcode = $code; 3299 my $qcode = $code;
2791 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3300 $qcode =~ s/"/‟/g; # not allowed in #line filenames
2792 $qcode =~ s/\n/\\n/g; 3301 $qcode =~ s/\n/\\n/g;
2793 3302
3303 %vars = (_dummy => 0) unless %vars;
3304
3305 my @res;
2794 local $_; 3306 local $_;
2795 local @safe::cf::_safe_eval_args = values %vars;
2796 3307
2797 my $eval = 3308 my $eval =
2798 "do {\n" 3309 "do {\n"
2799 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3310 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
2800 . "#line 0 \"{$qcode}\"\n" 3311 . "#line 0 \"{$qcode}\"\n"
2801 . $code 3312 . $code
2802 . "\n}" 3313 . "\n}"
2803 ; 3314 ;
2804 3315
3316 if ($CFG{safe_eval}) {
2805 sub_generation_inc; 3317 sub_generation_inc;
3318 local @safe::cf::_safe_eval_args = values %vars;
2806 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3319 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
2807 sub_generation_inc; 3320 sub_generation_inc;
3321 } else {
3322 local @cf::_safe_eval_args = values %vars;
3323 @res = wantarray ? eval eval : scalar eval $eval;
3324 }
2808 3325
2809 if ($@) { 3326 if ($@) {
2810 warn "$@"; 3327 warn "$@",
2811 warn "while executing safe code '$code'\n"; 3328 "while executing safe code '$code'\n",
2812 warn "with arguments " . (join " ", %vars) . "\n"; 3329 "with arguments " . (join " ", %vars) . "\n";
2813 } 3330 }
2814 3331
2815 wantarray ? @res : $res[0] 3332 wantarray ? @res : $res[0]
2816} 3333}
2817 3334
… …
2831=cut 3348=cut
2832 3349
2833sub register_script_function { 3350sub register_script_function {
2834 my ($fun, $cb) = @_; 3351 my ($fun, $cb) = @_;
2835 3352
2836 no strict 'refs'; 3353 $fun = "safe::$fun" if $CFG{safe_eval};
2837 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3354 *$fun = $safe_hole->wrap ($cb);
2838} 3355}
2839 3356
2840=back 3357=back
2841 3358
2842=cut 3359=cut
… …
2845# the server's init and main functions 3362# the server's init and main functions
2846 3363
2847sub load_facedata($) { 3364sub load_facedata($) {
2848 my ($path) = @_; 3365 my ($path) = @_;
2849 3366
3367 # HACK to clear player env face cache, we need some signal framework
3368 # for this (global event?)
3369 %ext::player_env::MUSIC_FACE_CACHE = ();
3370
3371 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3372
2850 warn "loading facedata from $path\n"; 3373 trace "loading facedata from $path\n";
2851 3374
2852 my $facedata; 3375 my $facedata;
2853 0 < aio_load $path, $facedata 3376 0 < aio_load $path, $facedata
2854 or die "$path: $!"; 3377 or die "$path: $!";
2855 3378
2856 $facedata = Coro::Storable::thaw $facedata; 3379 $facedata = Coro::Storable::thaw $facedata;
2857 3380
2858 $facedata->{version} == 2 3381 $facedata->{version} == 2
2859 or cf::cleanup "$path: version mismatch, cannot proceed."; 3382 or cf::cleanup "$path: version mismatch, cannot proceed.";
2860 3383
3384 # patch in the exptable
3385 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3386 $facedata->{resource}{"res/exp_table"} = {
3387 type => FT_RSRC,
3388 data => $exp_table,
3389 hash => (Digest::MD5::md5 $exp_table),
3390 };
3391 cf::cede_to_tick;
3392
2861 { 3393 {
2862 my $faces = $facedata->{faceinfo}; 3394 my $faces = $facedata->{faceinfo};
2863 3395
2864 while (my ($face, $info) = each %$faces) { 3396 while (my ($face, $info) = each %$faces) {
2865 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3397 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3398
2866 cf::face::set_visibility $idx, $info->{visibility}; 3399 cf::face::set_visibility $idx, $info->{visibility};
2867 cf::face::set_magicmap $idx, $info->{magicmap}; 3400 cf::face::set_magicmap $idx, $info->{magicmap};
2868 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 3401 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
2869 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 3402 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
2870 3403
2871 cf::cede_to_tick; 3404 cf::cede_to_tick;
2872 } 3405 }
2873 3406
2874 while (my ($face, $info) = each %$faces) { 3407 while (my ($face, $info) = each %$faces) {
2875 next unless $info->{smooth}; 3408 next unless $info->{smooth};
3409
2876 my $idx = cf::face::find $face 3410 my $idx = cf::face::find $face
2877 or next; 3411 or next;
3412
2878 if (my $smooth = cf::face::find $info->{smooth}) { 3413 if (my $smooth = cf::face::find $info->{smooth}) {
2879 cf::face::set_smooth $idx, $smooth; 3414 cf::face::set_smooth $idx, $smooth;
2880 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3415 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2881 } else { 3416 } else {
2882 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3417 error "smooth face '$info->{smooth}' not found for face '$face'";
2883 } 3418 }
2884 3419
2885 cf::cede_to_tick; 3420 cf::cede_to_tick;
2886 } 3421 }
2887 } 3422 }
… …
2896 3431
2897 cf::anim::invalidate_all; # d'oh 3432 cf::anim::invalidate_all; # d'oh
2898 } 3433 }
2899 3434
2900 { 3435 {
2901 # TODO: for gcfclient pleasure, we should give resources
2902 # that gcfclient doesn't grok a >10000 face index.
2903 my $res = $facedata->{resource}; 3436 my $res = $facedata->{resource};
2904 my $enc = JSON::XS->new->utf8->canonical;
2905
2906 my $soundconf = delete $res->{"res/sound.conf"};
2907 3437
2908 while (my ($name, $info) = each %$res) { 3438 while (my ($name, $info) = each %$res) {
2909 my $meta = $enc->encode ({ 3439 if (defined $info->{type}) {
2910 name => $name,
2911 %{ $info->{meta} || {} },
2912 });
2913
2914 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3440 my $idx = (cf::face::find $name) || cf::face::alloc $name;
2915 3441
2916 if ($info->{type} & 1) {
2917 # prepend meta info
2918
2919 my $data = pack "(w/a*)*", $meta, $info->{data};
2920 my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
2921
2922 cf::face::set_data $idx, 0, $data, $chk; 3442 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3443 cf::face::set_type $idx, $info->{type};
2923 } else { 3444 } else {
2924 cf::face::set_data $idx, 0, $info->{data}, $info->{chksum}; 3445 $RESOURCE{$name} = $info; # unused
2925 } 3446 }
2926 3447
2927 cf::face::set_type $idx, $info->{type};
2928
2929 cf::cede_to_tick; 3448 cf::cede_to_tick;
2930 } 3449 }
2931
2932 if ($soundconf) {
2933 $soundconf = $enc->decode (delete $soundconf->{data});
2934
2935 for (0 .. SOUND_CAST_SPELL_0 - 1) {
2936 my $sound = $soundconf->{compat}[$_]
2937 or next;
2938
2939 my $face = cf::face::find "sound/$sound->[1]";
2940 cf::sound::set $sound->[0] => $face;
2941 cf::sound::old_sound_index $_, $face; # gcfclient-compat
2942 }
2943
2944 while (my ($k, $v) = each %{$soundconf->{event}}) {
2945 my $face = cf::face::find "sound/$v";
2946 cf::sound::set $k => $face;
2947 }
2948 }
2949 } 3450 }
3451
3452 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
2950 3453
2951 1 3454 1
2952} 3455}
2953 3456
2954register_exticmd fx_want => sub { 3457register_exticmd fx_want => sub {
… …
2957 while (my ($k, $v) = each %$want) { 3460 while (my ($k, $v) = each %$want) {
2958 $ns->fx_want ($k, $v); 3461 $ns->fx_want ($k, $v);
2959 } 3462 }
2960}; 3463};
2961 3464
3465sub load_resource_file($) {
3466 my $guard = lock_acquire "load_resource_file";
3467
3468 my $status = load_resource_file_ $_[0];
3469 get_slot 0.1, 100;
3470 cf::arch::commit_load;
3471
3472 $status
3473}
3474
2962sub reload_regions { 3475sub reload_regions {
3476 # HACK to clear player env face cache, we need some signal framework
3477 # for this (global event?)
3478 %ext::player_env::MUSIC_FACE_CACHE = ();
3479
2963 load_resource_file "$MAPDIR/regions" 3480 load_resource_file "$MAPDIR/regions"
2964 or die "unable to load regions file\n"; 3481 or die "unable to load regions file\n";
2965 3482
2966 for (cf::region::list) { 3483 for (cf::region::list) {
2967 $_->{match} = qr/$_->{match}/ 3484 $_->{match} = qr/$_->{match}/
… …
2975} 3492}
2976 3493
2977sub reload_archetypes { 3494sub reload_archetypes {
2978 load_resource_file "$DATADIR/archetypes" 3495 load_resource_file "$DATADIR/archetypes"
2979 or die "unable to load archetypes\n"; 3496 or die "unable to load archetypes\n";
2980 #d# NEED to laod twice to resolve forward references
2981 # this really needs to be done in an extra post-pass
2982 # (which needs to be synchronous, so solve it differently)
2983 load_resource_file "$DATADIR/archetypes"
2984 or die "unable to load archetypes\n";
2985} 3497}
2986 3498
2987sub reload_treasures { 3499sub reload_treasures {
2988 load_resource_file "$DATADIR/treasures" 3500 load_resource_file "$DATADIR/treasures"
2989 or die "unable to load treasurelists\n"; 3501 or die "unable to load treasurelists\n";
2990} 3502}
2991 3503
3504sub reload_sound {
3505 trace "loading sound config from $DATADIR/sound\n";
3506
3507 0 < Coro::AIO::aio_load "$DATADIR/sound", my $data
3508 or die "$DATADIR/sound $!";
3509
3510 my $soundconf = JSON::XS->new->utf8->relaxed->decode ($data);
3511
3512 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3513 my $sound = $soundconf->{compat}[$_]
3514 or next;
3515
3516 my $face = cf::face::find "sound/$sound->[1]";
3517 cf::sound::set $sound->[0] => $face;
3518 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3519 }
3520
3521 while (my ($k, $v) = each %{$soundconf->{event}}) {
3522 my $face = cf::face::find "sound/$v";
3523 cf::sound::set $k => $face;
3524 }
3525}
3526
2992sub reload_resources { 3527sub reload_resources {
2993 warn "reloading resource files...\n"; 3528 trace "reloading resource files...\n";
2994 3529
3530 reload_facedata;
3531 reload_sound;
3532 reload_archetypes;
2995 reload_regions; 3533 reload_regions;
2996 reload_facedata;
2997 #reload_archetypes;#d#
2998 reload_archetypes;
2999 reload_treasures; 3534 reload_treasures;
3000 3535
3001 warn "finished reloading resource files\n"; 3536 trace "finished reloading resource files\n";
3002} 3537}
3003 3538
3004sub init { 3539sub reload_config {
3005 reload_resources; 3540 trace "reloading config file...\n";
3006}
3007 3541
3008sub cfg_load {
3009 open my $fh, "<:utf8", "$CONFDIR/config" 3542 open my $fh, "<:utf8", "$CONFDIR/config"
3010 or return; 3543 or return;
3011 3544
3012 local $/; 3545 local $/;
3013 *CFG = YAML::Syck::Load <$fh>; 3546 *CFG = YAML::XS::Load scalar <$fh>;
3014 3547
3015 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3548 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3016 3549
3017 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3550 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3018 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3551 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3019 3552
3020 if (exists $CFG{mlockall}) { 3553 if (exists $CFG{mlockall}) {
… …
3022 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 3555 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3023 and die "WARNING: m(un)lockall failed: $!\n"; 3556 and die "WARNING: m(un)lockall failed: $!\n";
3024 }; 3557 };
3025 warn $@ if $@; 3558 warn $@ if $@;
3026 } 3559 }
3560
3561 trace "finished reloading resource files\n";
3562}
3563
3564sub pidfile() {
3565 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3566 or die "$PIDFILE: $!";
3567 flock $fh, &Fcntl::LOCK_EX
3568 or die "$PIDFILE: flock: $!";
3569 $fh
3570}
3571
3572# make sure only one server instance is running at any one time
3573sub atomic {
3574 my $fh = pidfile;
3575
3576 my $pid = <$fh>;
3577 kill 9, $pid if $pid > 0;
3578
3579 seek $fh, 0, 0;
3580 print $fh $$;
3581}
3582
3583sub main_loop {
3584 trace "EV::loop starting\n";
3585 if (1) {
3586 EV::loop;
3587 }
3588 trace "EV::loop returned\n";
3589 goto &main_loop unless $REALLY_UNLOOP;
3027} 3590}
3028 3591
3029sub main { 3592sub main {
3593 cf::init_globals; # initialise logging
3594
3595 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3596 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3597 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3598 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3599
3600 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3601
3030 # we must not ever block the main coroutine 3602 # we must not ever block the main coroutine
3031 local $Coro::idle = sub { 3603 local $Coro::idle = sub {
3032 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3604 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3033 (async { 3605 (async {
3034 Event::one_event; 3606 $Coro::current->{desc} = "IDLE BUG HANDLER";
3607 EV::loop EV::LOOP_ONESHOT;
3035 })->prio (Coro::PRIO_MAX); 3608 })->prio (Coro::PRIO_MAX);
3036 }; 3609 };
3037 3610
3038 cfg_load; 3611 evthread_start IO::AIO::poll_fileno;
3612
3613 cf::sync_job {
3614 cf::init_experience;
3615 cf::init_anim;
3616 cf::init_attackmess;
3617 cf::init_dynamic;
3618
3619 cf::load_settings;
3620 cf::load_materials;
3621
3622 reload_resources;
3623 reload_config;
3039 db_init; 3624 db_init;
3625
3626 cf::init_uuid;
3627 cf::init_signals;
3628 cf::init_skills;
3629
3630 cf::init_beforeplay;
3631
3632 atomic;
3633
3040 load_extensions; 3634 load_extensions;
3041 3635
3042 $TICK_WATCHER->start; 3636 utime time, time, $RUNTIMEFILE;
3043 Event::loop; 3637
3638 # no (long-running) fork's whatsoever before this point(!)
3639 use POSIX ();
3640 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3641
3642 (pop @POST_INIT)->(0) while @POST_INIT;
3643 };
3644
3645 cf::object::thawer::errors_are_fatal 0;
3646 info "parse errors in files are no longer fatal from this point on.\n";
3647
3648 main_loop;
3044} 3649}
3045 3650
3046############################################################################# 3651#############################################################################
3047# initialisation and cleanup 3652# initialisation and cleanup
3048 3653
3049# install some emergency cleanup handlers 3654# install some emergency cleanup handlers
3050BEGIN { 3655BEGIN {
3656 our %SIGWATCHER = ();
3051 for my $signal (qw(INT HUP TERM)) { 3657 for my $signal (qw(INT HUP TERM)) {
3052 Event->signal ( 3658 $SIGWATCHER{$signal} = AE::signal $signal, sub {
3053 reentrant => 0,
3054 data => WF_AUTOCANCEL,
3055 signal => $signal,
3056 prio => 0,
3057 cb => sub {
3058 cf::cleanup "SIG$signal"; 3659 cf::cleanup "SIG$signal";
3059 },
3060 ); 3660 };
3061 } 3661 }
3062} 3662}
3063 3663
3064sub write_runtime { 3664sub write_runtime_sync {
3065 my $runtime = "$LOCALDIR/runtime"; 3665 my $t0 = AE::time;
3066 3666
3067 # first touch the runtime file to show we are still running: 3667 # first touch the runtime file to show we are still running:
3068 # the fsync below can take a very very long time. 3668 # the fsync below can take a very very long time.
3069 3669
3070 IO::AIO::aio_utime $runtime, undef, undef; 3670 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3071 3671
3072 my $guard = cf::lock_acquire "write_runtime"; 3672 my $guard = cf::lock_acquire "write_runtime";
3073 3673
3074 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 3674 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3075 or return; 3675 or return;
3076 3676
3077 my $value = $cf::RUNTIME + 90 + 10; 3677 my $value = $cf::RUNTIME + 90 + 10;
3078 # 10 is the runtime save interval, for a monotonic clock 3678 # 10 is the runtime save interval, for a monotonic clock
3079 # 60 allows for the watchdog to kill the server. 3679 # 60 allows for the watchdog to kill the server.
… …
3089 aio_utime $fh, undef, undef; 3689 aio_utime $fh, undef, undef;
3090 3690
3091 close $fh 3691 close $fh
3092 or return; 3692 or return;
3093 3693
3094 aio_rename "$runtime~", $runtime 3694 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3095 and return; 3695 and return;
3096 3696
3097 warn "runtime file written.\n"; 3697 trace sprintf "runtime file written (%gs).\n", AE::time - $t0;
3098 3698
3099 1 3699 1
3700}
3701
3702our $uuid_lock;
3703our $uuid_skip;
3704
3705sub write_uuid_sync($) {
3706 $uuid_skip ||= $_[0];
3707
3708 return if $uuid_lock;
3709 local $uuid_lock = 1;
3710
3711 my $uuid = "$LOCALDIR/uuid";
3712
3713 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3714 or return;
3715
3716 my $value = uuid_seq uuid_cur;
3717
3718 unless ($value) {
3719 info "cowardly refusing to write zero uuid value!\n";
3720 return;
3721 }
3722
3723 my $value = uuid_str $value + $uuid_skip;
3724 $uuid_skip = 0;
3725
3726 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3727 and return;
3728
3729 # always fsync - this file is important
3730 aio_fsync $fh
3731 and return;
3732
3733 close $fh
3734 or return;
3735
3736 aio_rename "$uuid~", $uuid
3737 and return;
3738
3739 trace "uuid file written ($value).\n";
3740
3741 1
3742
3743}
3744
3745sub write_uuid($$) {
3746 my ($skip, $sync) = @_;
3747
3748 $sync ? write_uuid_sync $skip
3749 : async { write_uuid_sync $skip };
3100} 3750}
3101 3751
3102sub emergency_save() { 3752sub emergency_save() {
3103 my $freeze_guard = cf::freeze_mainloop; 3753 my $freeze_guard = cf::freeze_mainloop;
3104 3754
3105 warn "enter emergency perl save\n"; 3755 info "emergency_perl_save: enter\n";
3756
3757 # this is a trade-off: we want to be very quick here, so
3758 # save all maps without fsync, and later call a global sync
3759 # (which in turn might be very very slow)
3760 local $USE_FSYNC = 0;
3106 3761
3107 cf::sync_job { 3762 cf::sync_job {
3763 cf::write_runtime_sync; # external watchdog should not bark
3764
3108 # use a peculiar iteration method to avoid tripping on perl 3765 # use a peculiar iteration method to avoid tripping on perl
3109 # refcount bugs in for. also avoids problems with players 3766 # refcount bugs in for. also avoids problems with players
3110 # and maps saved/destroyed asynchronously. 3767 # and maps saved/destroyed asynchronously.
3111 warn "begin emergency player save\n"; 3768 info "emergency_perl_save: begin player save\n";
3112 for my $login (keys %cf::PLAYER) { 3769 for my $login (keys %cf::PLAYER) {
3113 my $pl = $cf::PLAYER{$login} or next; 3770 my $pl = $cf::PLAYER{$login} or next;
3114 $pl->valid or next; 3771 $pl->valid or next;
3772 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3115 $pl->save; 3773 $pl->save;
3116 } 3774 }
3117 warn "end emergency player save\n"; 3775 info "emergency_perl_save: end player save\n";
3118 3776
3119 warn "begin emergency map save\n"; 3777 cf::write_runtime_sync; # external watchdog should not bark
3778
3779 info "emergency_perl_save: begin map save\n";
3120 for my $path (keys %cf::MAP) { 3780 for my $path (keys %cf::MAP) {
3121 my $map = $cf::MAP{$path} or next; 3781 my $map = $cf::MAP{$path} or next;
3122 $map->valid or next; 3782 $map->valid or next;
3123 $map->save; 3783 $map->save;
3124 } 3784 }
3125 warn "end emergency map save\n"; 3785 info "emergency_perl_save: end map save\n";
3126 3786
3127 warn "begin emergency database checkpoint\n"; 3787 cf::write_runtime_sync; # external watchdog should not bark
3788
3789 info "emergency_perl_save: begin database checkpoint\n";
3128 BDB::db_env_txn_checkpoint $DB_ENV; 3790 BDB::db_env_txn_checkpoint $DB_ENV;
3129 warn "end emergency database checkpoint\n"; 3791 info "emergency_perl_save: end database checkpoint\n";
3792
3793 info "emergency_perl_save: begin write uuid\n";
3794 write_uuid_sync 1;
3795 info "emergency_perl_save: end write uuid\n";
3796
3797 cf::write_runtime_sync; # external watchdog should not bark
3798
3799 trace "emergency_perl_save: syncing database to disk";
3800 BDB::db_env_txn_checkpoint $DB_ENV;
3801
3802 info "emergency_perl_save: starting sync()\n";
3803 IO::AIO::aio_sync sub {
3804 info "emergency_perl_save: finished sync()\n";
3805 };
3806
3807 cf::write_runtime_sync; # external watchdog should not bark
3808
3809 trace "emergency_perl_save: flushing outstanding aio requests";
3810 while (IO::AIO::nreqs || BDB::nreqs) {
3811 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3812 }
3813
3814 cf::write_runtime_sync; # external watchdog should not bark
3130 }; 3815 };
3131 3816
3132 warn "leave emergency perl save\n"; 3817 info "emergency_perl_save: leave\n";
3133} 3818}
3134 3819
3135sub post_cleanup { 3820sub post_cleanup {
3136 my ($make_core) = @_; 3821 my ($make_core) = @_;
3137 3822
3823 IO::AIO::flush;
3824
3825 IO::AIO::flush;
3826
3138 warn Carp::longmess "post_cleanup backtrace" 3827 error Carp::longmess "post_cleanup backtrace"
3139 if $make_core; 3828 if $make_core;
3829
3830 my $fh = pidfile;
3831 unlink $PIDFILE if <$fh> == $$;
3832}
3833
3834# a safer delete_package, copied from Symbol
3835sub clear_package($) {
3836 my $pkg = shift;
3837
3838 # expand to full symbol table name if needed
3839 unless ($pkg =~ /^main::.*::$/) {
3840 $pkg = "main$pkg" if $pkg =~ /^::/;
3841 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3842 $pkg .= '::' unless $pkg =~ /::$/;
3843 }
3844
3845 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3846 my $stem_symtab = *{$stem}{HASH};
3847
3848 defined $stem_symtab and exists $stem_symtab->{$leaf}
3849 or return;
3850
3851 # clear all symbols
3852 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3853 for my $name (keys %$leaf_symtab) {
3854 _gv_clear *{"$pkg$name"};
3855# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3856 }
3140} 3857}
3141 3858
3142sub do_reload_perl() { 3859sub do_reload_perl() {
3143 # can/must only be called in main 3860 # can/must only be called in main
3144 if ($Coro::current != $Coro::main) { 3861 if (in_main) {
3145 warn "can only reload from main coroutine"; 3862 error "can only reload from main coroutine";
3146 return; 3863 return;
3147 } 3864 }
3148 3865
3866 return if $RELOAD++;
3867
3868 my $t1 = AE::time;
3869
3870 while ($RELOAD) {
3149 warn "reloading..."; 3871 info "reloading...";
3150 3872
3151 warn "entering sync_job"; 3873 trace "entering sync_job";
3152 3874
3153 cf::sync_job { 3875 cf::sync_job {
3154 cf::write_runtime; # external watchdog should not bark
3155 cf::emergency_save; 3876 cf::emergency_save;
3156 cf::write_runtime; # external watchdog should not bark
3157 3877
3158 warn "syncing database to disk";
3159 BDB::db_env_txn_checkpoint $DB_ENV;
3160
3161 # if anything goes wrong in here, we should simply crash as we already saved
3162
3163 warn "cancelling all WF_AUTOCANCEL watchers";
3164 for (Event::all_watchers) {
3165 $_->cancel if $_->data & WF_AUTOCANCEL;
3166 }
3167
3168 warn "flushing outstanding aio requests";
3169 for (;;) {
3170 BDB::flush;
3171 IO::AIO::flush;
3172 Coro::cede;
3173 last unless IO::AIO::nreqs || BDB::nreqs;
3174 warn "iterate...";
3175 }
3176
3177 ++$RELOAD;
3178
3179 warn "cancelling all extension coros"; 3878 trace "cancelling all extension coros";
3180 $_->cancel for values %EXT_CORO; 3879 $_->cancel for values %EXT_CORO;
3181 %EXT_CORO = (); 3880 %EXT_CORO = ();
3182 3881
3183 warn "removing commands"; 3882 trace "removing commands";
3184 %COMMAND = (); 3883 %COMMAND = ();
3185 3884
3186 warn "removing ext/exti commands"; 3885 trace "removing ext/exti commands";
3187 %EXTCMD = (); 3886 %EXTCMD = ();
3188 %EXTICMD = (); 3887 %EXTICMD = ();
3189 3888
3190 warn "unloading/nuking all extensions"; 3889 trace "unloading/nuking all extensions";
3191 for my $pkg (@EXTS) { 3890 for my $pkg (@EXTS) {
3192 warn "... unloading $pkg"; 3891 trace "... unloading $pkg";
3193 3892
3194 if (my $cb = $pkg->can ("unload")) { 3893 if (my $cb = $pkg->can ("unload")) {
3195 eval { 3894 eval {
3196 $cb->($pkg); 3895 $cb->($pkg);
3197 1 3896 1
3198 } or warn "$pkg unloaded, but with errors: $@"; 3897 } or error "$pkg unloaded, but with errors: $@";
3898 }
3899
3900 trace "... clearing $pkg";
3901 clear_package $pkg;
3199 } 3902 }
3200 3903
3201 warn "... nuking $pkg";
3202 Symbol::delete_package $pkg;
3203 }
3204
3205 warn "unloading all perl modules loaded from $LIBDIR"; 3904 trace "unloading all perl modules loaded from $LIBDIR";
3206 while (my ($k, $v) = each %INC) { 3905 while (my ($k, $v) = each %INC) {
3207 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 3906 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3208 3907
3209 warn "... unloading $k"; 3908 trace "... unloading $k";
3210 delete $INC{$k}; 3909 delete $INC{$k};
3211 3910
3212 $k =~ s/\.pm$//; 3911 $k =~ s/\.pm$//;
3213 $k =~ s/\//::/g; 3912 $k =~ s/\//::/g;
3214 3913
3215 if (my $cb = $k->can ("unload_module")) { 3914 if (my $cb = $k->can ("unload_module")) {
3216 $cb->(); 3915 $cb->();
3916 }
3917
3918 clear_package $k;
3217 } 3919 }
3218 3920
3219 Symbol::delete_package $k;
3220 }
3221
3222 warn "getting rid of safe::, as good as possible"; 3921 trace "getting rid of safe::, as good as possible";
3223 Symbol::delete_package "safe::$_" 3922 clear_package "safe::$_"
3224 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3923 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3225 3924
3226 warn "unloading cf.pm \"a bit\""; 3925 trace "unloading cf.pm \"a bit\"";
3227 delete $INC{"cf.pm"}; 3926 delete $INC{"cf.pm"};
3228 delete $INC{"cf/pod.pm"}; 3927 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3229 3928
3230 # don't, removes xs symbols, too, 3929 # don't, removes xs symbols, too,
3231 # and global variables created in xs 3930 # and global variables created in xs
3232 #Symbol::delete_package __PACKAGE__; 3931 #clear_package __PACKAGE__;
3233 3932
3234 warn "unload completed, starting to reload now"; 3933 info "unload completed, starting to reload now";
3235 3934
3236 warn "reloading cf.pm"; 3935 trace "reloading cf.pm";
3237 require cf; 3936 require cf;
3238 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3937 cf::_connect_to_perl_1;
3239 3938
3240 warn "loading config and database again"; 3939 trace "loading config and database again";
3241 cf::cfg_load; 3940 cf::reload_config;
3242 3941
3243 warn "loading extensions"; 3942 trace "loading extensions";
3244 cf::load_extensions; 3943 cf::load_extensions;
3245 3944
3945 if ($REATTACH_ON_RELOAD) {
3246 warn "reattaching attachments to objects/players"; 3946 trace "reattaching attachments to objects/players";
3247 _global_reattach; # objects, sockets 3947 _global_reattach; # objects, sockets
3248 warn "reattaching attachments to maps"; 3948 trace "reattaching attachments to maps";
3249 reattach $_ for values %MAP; 3949 reattach $_ for values %MAP;
3250 warn "reattaching attachments to players"; 3950 trace "reattaching attachments to players";
3251 reattach $_ for values %PLAYER; 3951 reattach $_ for values %PLAYER;
3952 }
3252 3953
3954 trace "running post_init jobs";
3955 (pop @POST_INIT)->(1) while @POST_INIT;
3956
3253 warn "leaving sync_job"; 3957 trace "leaving sync_job";
3254 3958
3255 1 3959 1
3256 } or do { 3960 } or do {
3257 warn $@; 3961 error $@;
3258 warn "error while reloading, exiting."; 3962 cf::cleanup "error while reloading, exiting.";
3259 exit 1; 3963 };
3964
3965 info "reloaded";
3966 --$RELOAD;
3260 }; 3967 }
3261 3968
3262 warn "reloaded"; 3969 $t1 = AE::time - $t1;
3970 info "reload completed in ${t1}s\n";
3263}; 3971};
3264 3972
3265our $RELOAD_WATCHER; # used only during reload 3973our $RELOAD_WATCHER; # used only during reload
3266 3974
3267sub reload_perl() { 3975sub reload_perl() {
3268 # doing reload synchronously and two reloads happen back-to-back, 3976 # doing reload synchronously and two reloads happen back-to-back,
3269 # coro crashes during coro_state_free->destroy here. 3977 # coro crashes during coro_state_free->destroy here.
3270 3978
3271 $RELOAD_WATCHER ||= Event->timer ( 3979 $RELOAD_WATCHER ||= cf::async {
3272 reentrant => 0, 3980 Coro::AIO::aio_wait cache_extensions;
3273 after => 0, 3981
3274 data => WF_AUTOCANCEL, 3982 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
3275 cb => sub {
3276 do_reload_perl; 3983 do_reload_perl;
3277 undef $RELOAD_WATCHER; 3984 undef $RELOAD_WATCHER;
3278 }, 3985 };
3279 ); 3986 };
3280} 3987}
3281 3988
3282register_command "reload" => sub { 3989register_command "reload" => sub {
3283 my ($who, $arg) = @_; 3990 my ($who, $arg) = @_;
3284 3991
3285 if ($who->flag (FLAG_WIZ)) { 3992 if ($who->flag (FLAG_WIZ)) {
3286 $who->message ("reloading server."); 3993 $who->message ("reloading server.");
3994 async {
3995 $Coro::current->{desc} = "perl_reload";
3287 async { reload_perl }; 3996 reload_perl;
3997 };
3288 } 3998 }
3289}; 3999};
3290 4000
3291unshift @INC, $LIBDIR; 4001unshift @INC, $LIBDIR;
3292 4002
… …
3294 4004
3295our @WAIT_FOR_TICK; 4005our @WAIT_FOR_TICK;
3296our @WAIT_FOR_TICK_BEGIN; 4006our @WAIT_FOR_TICK_BEGIN;
3297 4007
3298sub wait_for_tick { 4008sub wait_for_tick {
3299 return unless $TICK_WATCHER->is_active;
3300 return if $Coro::current == $Coro::main; 4009 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3301 4010
3302 my $signal = new Coro::Signal; 4011 my $signal = new Coro::Signal;
3303 push @WAIT_FOR_TICK, $signal; 4012 push @WAIT_FOR_TICK, $signal;
3304 $signal->wait; 4013 $signal->wait;
3305} 4014}
3306 4015
3307sub wait_for_tick_begin { 4016sub wait_for_tick_begin {
3308 return unless $TICK_WATCHER->is_active;
3309 return if $Coro::current == $Coro::main; 4017 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3310 4018
3311 my $signal = new Coro::Signal; 4019 my $signal = new Coro::Signal;
3312 push @WAIT_FOR_TICK_BEGIN, $signal; 4020 push @WAIT_FOR_TICK_BEGIN, $signal;
3313 $signal->wait; 4021 $signal->wait;
3314} 4022}
3315 4023
3316 my $min = 1e6;#d# 4024sub tick {
3317 my $avg = 10;
3318$TICK_WATCHER = Event->timer (
3319 reentrant => 0,
3320 parked => 1,
3321 prio => 0,
3322 at => $NEXT_TICK || $TICK,
3323 data => WF_AUTOCANCEL,
3324 cb => sub {
3325 if ($Coro::current != $Coro::main) { 4025 if ($Coro::current != $Coro::main) {
3326 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 4026 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3327 unless ++$bug_warning > 10; 4027 unless ++$bug_warning > 10;
3328 return; 4028 return;
3329 } 4029 }
3330 4030
3331 $NOW = $tick_start = Event::time;
3332
3333 cf::server_tick; # one server iteration 4031 cf::server_tick; # one server iteration
3334 4032
3335 0 && sync_job {#d# 4033 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
3336 for(1..10) {
3337 my $t = Event::time;
3338 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3339 or die;
3340 4034
3341 $map->width (50); 4035 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3342 $map->height (50); 4036 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3343 $map->alloc; 4037 Coro::async_pool {
3344 $map->_load_objects ("/tmp/x.map", 1); 4038 $Coro::current->{desc} = "runtime saver";
3345 my $t = Event::time - $t; 4039 write_runtime_sync
3346 4040 or error "ERROR: unable to write runtime file: $!";
3347 #next unless $t < 0.0013;#d#
3348 if ($t < $min) {
3349 $min = $t;
3350 }
3351 $avg = $avg * 0.99 + $t * 0.01;
3352 }
3353 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3354 exit 0;
3355 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3356 }; 4041 };
4042 }
3357 4043
3358 $RUNTIME += $TICK;
3359 $NEXT_TICK += $TICK;
3360
3361 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3362 $NEXT_RUNTIME_WRITE = $NOW + 10;
3363 Coro::async_pool {
3364 write_runtime
3365 or warn "ERROR: unable to write runtime file: $!";
3366 };
3367 }
3368
3369# my $AFTER = Event::time;
3370# warn $AFTER - $NOW;#d#
3371
3372 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 4044 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3373 $sig->send; 4045 $sig->send;
3374 } 4046 }
3375 while (my $sig = shift @WAIT_FOR_TICK) { 4047 while (my $sig = shift @WAIT_FOR_TICK) {
3376 $sig->send; 4048 $sig->send;
3377 } 4049 }
3378 4050
3379 $NOW = Event::time; 4051 $LOAD = ($NOW - $TICK_START) / $TICK;
3380
3381 # if we are delayed by four ticks or more, skip them all
3382 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3383
3384 $TICK_WATCHER->at ($NEXT_TICK);
3385 $TICK_WATCHER->start;
3386
3387 $LOAD = ($NOW - $tick_start) / $TICK;
3388 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 4052 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3389 4053
3390 _post_tick; 4054 if (0) {
3391 4055 if ($NEXT_TICK) {
3392 4056 my $jitter = $TICK_START - $NEXT_TICK;
4057 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
4058 debug "jitter $JITTER\n";#d#
4059 }
3393 }, 4060 }
3394); 4061}
3395 4062
3396{ 4063{
3397 BDB::max_poll_time $TICK * 0.1; 4064 # configure BDB
3398 $BDB_POLL_WATCHER = Event->io ( 4065
3399 reentrant => 0,
3400 fd => BDB::poll_fileno,
3401 poll => 'r',
3402 prio => 0,
3403 data => WF_AUTOCANCEL,
3404 cb => \&BDB::poll_cb,
3405 );
3406 BDB::min_parallel 8; 4066 BDB::min_parallel 16;
3407 4067 BDB::max_poll_reqs $TICK * 0.1;
3408 BDB::set_sync_prepare { 4068 $AnyEvent::BDB::WATCHER->priority (1);
3409 my $status;
3410 my $current = $Coro::current;
3411 (
3412 sub {
3413 $status = $!;
3414 $current->ready; undef $current;
3415 },
3416 sub {
3417 Coro::schedule while defined $current;
3418 $! = $status;
3419 },
3420 )
3421 };
3422 4069
3423 unless ($DB_ENV) { 4070 unless ($DB_ENV) {
3424 $DB_ENV = BDB::db_env_create; 4071 $DB_ENV = BDB::db_env_create;
4072 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
4073 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
4074 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
4075 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
4076 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3425 4077
3426 cf::sync_job { 4078 cf::sync_job {
3427 eval { 4079 eval {
3428 BDB::db_env_open 4080 BDB::db_env_open
3429 $DB_ENV, 4081 $DB_ENV,
… …
3431 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 4083 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3432 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 4084 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3433 0666; 4085 0666;
3434 4086
3435 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 4087 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3436
3437 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3438 $DB_ENV->set_lk_detect;
3439 }; 4088 };
3440 4089
3441 cf::cleanup "db_env_open(db): $@" if $@; 4090 cf::cleanup "db_env_open(db): $@" if $@;
3442 }; 4091 };
3443 } 4092 }
4093
4094 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
4095 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
4096 };
4097 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
4098 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
4099 };
4100 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
4101 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
4102 };
3444} 4103}
3445 4104
3446{ 4105{
4106 # configure IO::AIO
4107
3447 IO::AIO::min_parallel 8; 4108 IO::AIO::min_parallel 8;
3448
3449 undef $Coro::AIO::WATCHER;
3450 IO::AIO::max_poll_time $TICK * 0.1; 4109 IO::AIO::max_poll_time $TICK * 0.1;
3451 $AIO_POLL_WATCHER = Event->io ( 4110 undef $AnyEvent::AIO::WATCHER;
3452 reentrant => 0,
3453 data => WF_AUTOCANCEL,
3454 fd => IO::AIO::poll_fileno,
3455 poll => 'r',
3456 prio => 6,
3457 cb => \&IO::AIO::poll_cb,
3458 );
3459} 4111}
3460 4112
3461my $_log_backtrace; 4113my $_log_backtrace;
3462 4114
3463sub _log_backtrace { 4115sub _log_backtrace {
… …
3466 $msg =~ s/\n//; 4118 $msg =~ s/\n//;
3467 4119
3468 # limit the # of concurrent backtraces 4120 # limit the # of concurrent backtraces
3469 if ($_log_backtrace < 2) { 4121 if ($_log_backtrace < 2) {
3470 ++$_log_backtrace; 4122 ++$_log_backtrace;
4123 my $perl_bt = Carp::longmess $msg;
3471 async { 4124 async {
4125 $Coro::current->{desc} = "abt $msg";
4126
3472 my @bt = fork_call { 4127 my @bt = fork_call {
3473 @addr = map { sprintf "%x", $_ } @addr; 4128 @addr = map { sprintf "%x", $_ } @addr;
3474 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X; 4129 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3475 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |" 4130 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3476 or die "addr2line: $!"; 4131 or die "addr2line: $!";
… …
3484 } 4139 }
3485 4140
3486 @funcs 4141 @funcs
3487 }; 4142 };
3488 4143
3489 LOG llevInfo, "[ABT] $msg\n"; 4144 LOG llevInfo, "[ABT] $perl_bt\n";
4145 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
3490 LOG llevInfo, "[ABT] $_\n" for @bt; 4146 LOG llevInfo, "[ABT] $_\n" for @bt;
3491 --$_log_backtrace; 4147 --$_log_backtrace;
3492 }; 4148 };
3493 } else { 4149 } else {
3494 LOG llevInfo, "[ABT] $msg\n"; 4150 LOG llevInfo, "[ABT] $msg\n";
3495 LOG llevInfo, "[ABT] [suppressed]\n"; 4151 LOG llevInfo, "[ABT] [suppressed]\n";
3496 } 4152 }
3497} 4153}
3498 4154
3499# load additional modules 4155# load additional modules
3500use cf::pod; 4156require "cf/$_.pm" for @EXTRA_MODULES;
4157cf::_connect_to_perl_2;
3501 4158
3502END { cf::emergency_save } 4159END { cf::emergency_save }
3503 4160
35041 41611
3505 4162

Diff Legend

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