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.298 by root, Sun Jul 8 14:50:07 2007 UTC vs.
Revision 1.456 by root, Tue Sep 30 04:00:35 2008 UTC

1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3#
4# Copyright (©) 2006,2007,2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5#
6# Deliantra is free software: you can redistribute it and/or modify
7# it under the terms of the GNU General Public License as published by
8# the Free Software Foundation, either version 3 of the License, or
9# (at your option) any later version.
10#
11# This program is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14# GNU General Public License for more details.
15#
16# You should have received a copy of the GNU General Public License
17# along with this program. If not, see <http://www.gnu.org/licenses/>.
18#
19# The authors can be reached via e-mail to <support@deliantra.net>
20#
21
1package cf; 22package cf;
2 23
24use 5.10.0;
3use utf8; 25use utf8;
4use strict; 26use strict "vars", "subs";
5 27
6use Symbol; 28use Symbol;
7use List::Util; 29use List::Util;
8use Socket; 30use Socket;
9use Storable; 31use EV;
10use Event;
11use Opcode; 32use Opcode;
12use Safe; 33use Safe;
13use Safe::Hole; 34use Safe::Hole;
35use Storable ();
14 36
15use Coro 3.61 (); 37use Coro ();
16use Coro::State; 38use Coro::State;
17use Coro::Handle; 39use Coro::Handle;
40use Coro::EV;
18use Coro::Event; 41use Coro::AnyEvent;
19use Coro::Timer; 42use Coro::Timer;
20use Coro::Signal; 43use Coro::Signal;
21use Coro::Semaphore; 44use Coro::Semaphore;
45use Coro::AnyEvent;
22use Coro::AIO; 46use Coro::AIO;
47use Coro::BDB 1.6;
23use Coro::Storable; 48use Coro::Storable;
49use Coro::Util ();
24 50
25use JSON::XS 1.4 (); 51use JSON::XS 2.01 ();
26use BDB (); 52use BDB ();
27use Data::Dumper; 53use Data::Dumper;
28use Digest::MD5; 54use Digest::MD5;
29use Fcntl; 55use Fcntl;
30use YAML::Syck (); 56use YAML ();
31use IO::AIO 2.32 (); 57use IO::AIO ();
32use Time::HiRes; 58use Time::HiRes;
33use Compress::LZF; 59use Compress::LZF;
60use Digest::MD5 ();
61
62AnyEvent::detect;
34 63
35# configure various modules to our taste 64# configure various modules to our taste
36# 65#
37$Storable::canonical = 1; # reduce rsync transfers 66$Storable::canonical = 1; # reduce rsync transfers
38Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 67Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
68
69$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
70
71# make sure c-lzf reinitialises itself
72Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";
39Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 73Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
40
41$Event::Eval = 1; # no idea why this is required, but it is
42
43# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
44$YAML::Syck::ImplicitUnicode = 1;
45
46$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
47 74
48sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 75sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
49 76
50our %COMMAND = (); 77our %COMMAND = ();
51our %COMMAND_TIME = (); 78our %COMMAND_TIME = ();
… …
54our %EXTCMD = (); 81our %EXTCMD = ();
55our %EXTICMD = (); 82our %EXTICMD = ();
56our %EXT_CORO = (); # coroutines bound to extensions 83our %EXT_CORO = (); # coroutines bound to extensions
57our %EXT_MAP = (); # pluggable maps 84our %EXT_MAP = (); # pluggable maps
58 85
59our $RELOAD; # number of reloads so far 86our $RELOAD; # number of reloads so far, non-zero while in reload
60our @EVENT; 87our @EVENT;
61 88
62our $CONFDIR = confdir; 89our $CONFDIR = confdir;
63our $DATADIR = datadir; 90our $DATADIR = datadir;
64our $LIBDIR = "$DATADIR/ext"; 91our $LIBDIR = "$DATADIR/ext";
65our $PODDIR = "$DATADIR/pod"; 92our $PODDIR = "$DATADIR/pod";
66our $MAPDIR = "$DATADIR/" . mapdir; 93our $MAPDIR = "$DATADIR/" . mapdir;
67our $LOCALDIR = localdir; 94our $LOCALDIR = localdir;
68our $TMPDIR = "$LOCALDIR/" . tmpdir; 95our $TMPDIR = "$LOCALDIR/" . tmpdir;
69our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 96our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
70our $PLAYERDIR = "$LOCALDIR/" . playerdir; 97our $PLAYERDIR = "$LOCALDIR/" . playerdir;
71our $RANDOMDIR = "$LOCALDIR/random"; 98our $RANDOMDIR = "$LOCALDIR/random";
72our $BDBDIR = "$LOCALDIR/db"; 99our $BDBDIR = "$LOCALDIR/db";
100our $PIDFILE = "$LOCALDIR/pid";
101our $RUNTIMEFILE = "$LOCALDIR/runtime";
102
103our %RESOURCE;
73 104
74our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 105our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
75our $TICK_WATCHER;
76our $AIO_POLL_WATCHER;
77our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 106our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
78our $NEXT_TICK; 107our $NEXT_TICK;
79our $NOW;
80our $USE_FSYNC = 1; # use fsync to write maps - default off 108our $USE_FSYNC = 1; # use fsync to write maps - default off
81 109
110our $BDB_DEADLOCK_WATCHER;
111our $BDB_CHECKPOINT_WATCHER;
82our $BDB_POLL_WATCHER; 112our $BDB_TRICKLE_WATCHER;
83our $DB_ENV; 113our $DB_ENV;
84 114
85our %CFG; 115our %CFG;
86 116
87our $UPTIME; $UPTIME ||= time; 117our $UPTIME; $UPTIME ||= time;
88our $RUNTIME; 118our $RUNTIME;
119our $NOW;
89 120
90our %PLAYER; # all users 121our (%PLAYER, %PLAYER_LOADING); # all users
91our %MAP; # all maps 122our (%MAP, %MAP_LOADING ); # all maps
92our $LINK_MAP; # the special {link} map, which is always available 123our $LINK_MAP; # the special {link} map, which is always available
93 124
94# used to convert map paths into valid unix filenames by replacing / by ∕ 125# used to convert map paths into valid unix filenames by replacing / by ∕
95our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 126our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
96 127
97our $LOAD; # a number between 0 (idle) and 1 (too many objects) 128our $LOAD; # a number between 0 (idle) and 1 (too many objects)
98our $LOADAVG; # same thing, but with alpha-smoothing 129our $LOADAVG; # same thing, but with alpha-smoothing
130our $JITTER; # average jitter
99our $tick_start; # for load detecting purposes 131our $TICK_START; # for load detecting purposes
132
133our @POST_INIT;
100 134
101binmode STDOUT; 135binmode STDOUT;
102binmode STDERR; 136binmode STDERR;
103 137
104# read virtual server time, if available 138# read virtual server time, if available
105unless ($RUNTIME || !-e "$LOCALDIR/runtime") { 139unless ($RUNTIME || !-e $RUNTIMEFILE) {
106 open my $fh, "<", "$LOCALDIR/runtime" 140 open my $fh, "<", $RUNTIMEFILE
107 or die "unable to read runtime file: $!"; 141 or die "unable to read $RUNTIMEFILE file: $!";
108 $RUNTIME = <$fh> + 0.; 142 $RUNTIME = <$fh> + 0.;
109} 143}
110 144
111mkdir $_ 145mkdir $_
112 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR; 146 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
… …
157 191
158The raw value load value from the last tick. 192The raw value load value from the last tick.
159 193
160=item %cf::CFG 194=item %cf::CFG
161 195
162Configuration for the server, loaded from C</etc/crossfire/config>, or 196Configuration for the server, loaded from C</etc/deliantra-server/config>, or
163from wherever your confdir points to. 197from wherever your confdir points to.
164 198
165=item cf::wait_for_tick, cf::wait_for_tick_begin 199=item cf::wait_for_tick, cf::wait_for_tick_begin
166 200
167These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 201These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
168returns directly I<after> the tick processing (and consequently, can only wake one process 202returns directly I<after> the tick processing (and consequently, can only wake one process
169per tick), while cf::wait_for_tick wakes up all waiters after tick processing. 203per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
170 204
205=item @cf::INVOKE_RESULTS
206
207This array contains the results of the last C<invoke ()> call. When
208C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
209that call.
210
171=back 211=back
172 212
173=cut 213=cut
174 214
175BEGIN { 215BEGIN {
… …
179 $msg .= "\n" 219 $msg .= "\n"
180 unless $msg =~ /\n$/; 220 unless $msg =~ /\n$/;
181 221
182 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 222 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
183 223
184 utf8::encode $msg;
185 LOG llevError, $msg; 224 LOG llevError, $msg;
186 }; 225 };
187} 226}
227
228$Coro::State::DIEHOOK = sub {
229 return unless $^S eq 0; # "eq", not "=="
230
231 if ($Coro::current == $Coro::main) {#d#
232 warn "DIEHOOK called in main context, Coro bug?\n";#d#
233 return;#d#
234 }#d#
235
236 # kill coroutine otherwise
237 warn Carp::longmess $_[0];
238 Coro::terminate
239};
240
241$SIG{__DIE__} = sub { }; #d#?
188 242
189@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 243@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
190@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 244@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
191@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 245@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
192@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 246@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
… …
199for my $pkg (qw( 253for my $pkg (qw(
200 cf::global cf::attachable 254 cf::global cf::attachable
201 cf::object cf::object::player 255 cf::object cf::object::player
202 cf::client cf::player 256 cf::client cf::player
203 cf::arch cf::living 257 cf::arch cf::living
258 cf::map cf::mapspace
204 cf::map cf::party cf::region 259 cf::party cf::region
205)) { 260)) {
206 no strict 'refs';
207 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 261 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
208} 262}
209 263
210$Event::DIED = sub { 264$EV::DIED = sub {
211 warn "error in event callback: @_"; 265 warn "error in event callback: @_";
212}; 266};
213 267
214############################################################################# 268#############################################################################
215 269
… …
238 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 292 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
239 $d 293 $d
240 } || "[unable to dump $_[0]: '$@']"; 294 } || "[unable to dump $_[0]: '$@']";
241} 295}
242 296
243=item $ref = cf::from_json $json 297=item $ref = cf::decode_json $json
244 298
245Converts a JSON string into the corresponding perl data structure. 299Converts a JSON string into the corresponding perl data structure.
246 300
247=item $json = cf::to_json $ref 301=item $json = cf::encode_json $ref
248 302
249Converts a perl data structure into its JSON representation. 303Converts a perl data structure into its JSON representation.
250 304
251=cut 305=cut
252 306
253our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max 307our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
254 308
255sub to_json ($) { $json_coder->encode ($_[0]) } 309sub encode_json($) { $json_coder->encode ($_[0]) }
256sub from_json ($) { $json_coder->decode ($_[0]) } 310sub decode_json($) { $json_coder->decode ($_[0]) }
311
312=item cf::post_init { BLOCK }
313
314Execute the given codeblock, I<after> all extensions have been (re-)loaded,
315but I<before> the server starts ticking again.
316
317The cdoeblock will have a single boolean argument to indicate whether this
318is a reload or not.
319
320=cut
321
322sub post_init(&) {
323 push @POST_INIT, shift;
324}
257 325
258=item cf::lock_wait $string 326=item cf::lock_wait $string
259 327
260Wait until the given lock is available. See cf::lock_acquire. 328Wait until the given lock is available. See cf::lock_acquire.
261 329
… …
264Wait until the given lock is available and then acquires it and returns 332Wait until the given lock is available and then acquires it and returns
265a Coro::guard object. If the guard object gets destroyed (goes out of scope, 333a Coro::guard object. If the guard object gets destroyed (goes out of scope,
266for example when the coroutine gets canceled), the lock is automatically 334for example when the coroutine gets canceled), the lock is automatically
267returned. 335returned.
268 336
337Locks are *not* recursive, locking from the same coro twice results in a
338deadlocked coro.
339
269Lock names should begin with a unique identifier (for example, cf::map::find 340Lock names should begin with a unique identifier (for example, cf::map::find
270uses map_find and cf::map::load uses map_load). 341uses map_find and cf::map::load uses map_load).
271 342
272=item $locked = cf::lock_active $string 343=item $locked = cf::lock_active $string
273 344
274Return true if the lock is currently active, i.e. somebody has locked it. 345Return true if the lock is currently active, i.e. somebody has locked it.
275 346
276=cut 347=cut
277 348
278our %LOCK; 349our %LOCK;
350our %LOCKER;#d#
279 351
280sub lock_wait($) { 352sub lock_wait($) {
281 my ($key) = @_; 353 my ($key) = @_;
282 354
355 if ($LOCKER{$key} == $Coro::current) {#d#
356 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
357 return;#d#
358 }#d#
359
283 # wait for lock, if any 360 # wait for lock, if any
284 while ($LOCK{$key}) { 361 while ($LOCK{$key}) {
362 #local $Coro::current->{desc} = "$Coro::current->{desc} <waiting for lock $key>";
285 push @{ $LOCK{$key} }, $Coro::current; 363 push @{ $LOCK{$key} }, $Coro::current;
286 Coro::schedule; 364 Coro::schedule;
287 } 365 }
288} 366}
289 367
… …
292 370
293 # wait, to be sure we are not locked 371 # wait, to be sure we are not locked
294 lock_wait $key; 372 lock_wait $key;
295 373
296 $LOCK{$key} = []; 374 $LOCK{$key} = [];
375 $LOCKER{$key} = $Coro::current;#d#
297 376
298 Coro::guard { 377 Coro::guard {
378 delete $LOCKER{$key};#d#
299 # wake up all waiters, to be on the safe side 379 # wake up all waiters, to be on the safe side
300 $_->ready for @{ delete $LOCK{$key} }; 380 $_->ready for @{ delete $LOCK{$key} };
301 } 381 }
302} 382}
303 383
… …
306 386
307 ! ! $LOCK{$key} 387 ! ! $LOCK{$key}
308} 388}
309 389
310sub freeze_mainloop { 390sub freeze_mainloop {
311 return unless $TICK_WATCHER->is_active; 391 tick_inhibit_inc;
312 392
313 my $guard = Coro::guard { 393 Coro::guard \&tick_inhibit_dec;
314 $TICK_WATCHER->start; 394}
395
396=item cf::periodic $interval, $cb
397
398Like EV::periodic, but randomly selects a starting point so that the actions
399get spread over timer.
400
401=cut
402
403sub periodic($$) {
404 my ($interval, $cb) = @_;
405
406 my $start = rand List::Util::min 180, $interval;
407
408 EV::periodic $start, $interval, 0, $cb
409}
410
411=item cf::get_slot $time[, $priority[, $name]]
412
413Allocate $time seconds of blocking CPU time at priority C<$priority>:
414This call blocks and returns only when you have at least C<$time> seconds
415of cpu time till the next tick. The slot is only valid till the next cede.
416
417The optional C<$name> can be used to identify the job to run. It might be
418used for statistical purposes and should identify the same time-class.
419
420Useful for short background jobs.
421
422=cut
423
424our @SLOT_QUEUE;
425our $SLOT_QUEUE;
426
427$SLOT_QUEUE->cancel if $SLOT_QUEUE;
428$SLOT_QUEUE = Coro::async {
429 $Coro::current->desc ("timeslot manager");
430
431 my $signal = new Coro::Signal;
432
433 while () {
434 next_job:
435 my $avail = cf::till_tick;
436 if ($avail > 0.01) {
437 for (0 .. $#SLOT_QUEUE) {
438 if ($SLOT_QUEUE[$_][0] < $avail) {
439 my $job = splice @SLOT_QUEUE, $_, 1, ();
440 $job->[2]->send;
441 Coro::cede;
442 goto next_job;
443 }
444 }
445 }
446
447 if (@SLOT_QUEUE) {
448 # we do not use wait_for_tick() as it returns immediately when tick is inactive
449 push @cf::WAIT_FOR_TICK, $signal;
450 $signal->wait;
451 } else {
452 Coro::schedule;
453 }
315 }; 454 }
316 $TICK_WATCHER->stop; 455};
317 $guard 456
457sub get_slot($;$$) {
458 return if tick_inhibit || $Coro::current == $Coro::main;
459
460 my ($time, $pri, $name) = @_;
461
462 $time = $TICK * .6 if $time > $TICK * .6;
463 my $sig = new Coro::Signal;
464
465 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
466 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
467 $SLOT_QUEUE->ready;
468 $sig->wait;
318} 469}
319 470
320=item cf::async { BLOCK } 471=item cf::async { BLOCK }
321 472
322Currently the same as Coro::async_pool, meaning you cannot use 473Currently the same as Coro::async_pool, meaning you cannot use
… …
327 478
328BEGIN { *async = \&Coro::async_pool } 479BEGIN { *async = \&Coro::async_pool }
329 480
330=item cf::sync_job { BLOCK } 481=item cf::sync_job { BLOCK }
331 482
332The design of Crossfire TRT requires that the main coroutine ($Coro::main) 483The design of Deliantra requires that the main coroutine ($Coro::main)
333is always able to handle events or runnable, as Crossfire TRT is only 484is always able to handle events or runnable, as Deliantra is only
334partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not 485partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
335acceptable. 486acceptable.
336 487
337If it must be done, put the blocking parts into C<sync_job>. This will run 488If it must be done, put the blocking parts into C<sync_job>. This will run
338the given BLOCK in another coroutine while waiting for the result. The 489the given BLOCK in another coroutine while waiting for the result. The
… …
343 494
344sub sync_job(&) { 495sub sync_job(&) {
345 my ($job) = @_; 496 my ($job) = @_;
346 497
347 if ($Coro::current == $Coro::main) { 498 if ($Coro::current == $Coro::main) {
348 my $time = Event::time; 499 my $time = EV::time;
349 500
350 # this is the main coro, too bad, we have to block 501 # this is the main coro, too bad, we have to block
351 # till the operation succeeds, freezing the server :/ 502 # till the operation succeeds, freezing the server :/
352 503
353 # TODO: use suspend/resume instead 504 LOG llevError, Carp::longmess "sync job";#d#
354 # (but this is cancel-safe) 505
355 my $freeze_guard = freeze_mainloop; 506 my $freeze_guard = freeze_mainloop;
356 507
357 my $busy = 1; 508 my $busy = 1;
358 my @res; 509 my @res;
359 510
360 (async { 511 (async {
512 $Coro::current->desc ("sync job coro");
361 @res = eval { $job->() }; 513 @res = eval { $job->() };
362 warn $@ if $@; 514 warn $@ if $@;
363 undef $busy; 515 undef $busy;
364 })->prio (Coro::PRIO_MAX); 516 })->prio (Coro::PRIO_MAX);
365 517
366 while ($busy) { 518 while ($busy) {
367 Coro::cede or Event::one_event; 519 if (Coro::nready) {
520 Coro::cede_notself;
521 } else {
522 EV::loop EV::LOOP_ONESHOT;
368 } 523 }
524 }
369 525
370 $time = Event::time - $time; 526 my $time = EV::time - $time;
371 527
372 LOG llevError | logBacktrace, Carp::longmess "long sync job"
373 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
374
375 $tick_start += $time; # do not account sync jobs to server load 528 $TICK_START += $time; # do not account sync jobs to server load
376 529
377 wantarray ? @res : $res[0] 530 wantarray ? @res : $res[0]
378 } else { 531 } else {
379 # we are in another coroutine, how wonderful, everything just works 532 # we are in another coroutine, how wonderful, everything just works
380 533
… …
405=item fork_call { }, $args 558=item fork_call { }, $args
406 559
407Executes the given code block with the given arguments in a seperate 560Executes the given code block with the given arguments in a seperate
408process, returning the results. Everything must be serialisable with 561process, returning the results. Everything must be serialisable with
409Coro::Storable. May, of course, block. Note that the executed sub may 562Coro::Storable. May, of course, block. Note that the executed sub may
410never block itself or use any form of Event handling. 563never block itself or use any form of event handling.
411 564
412=cut 565=cut
413 566
414sub fork_call(&@) { 567sub fork_call(&@) {
415 my ($cb, @args) = @_; 568 my ($cb, @args) = @_;
416 569
417# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC 570 # we seemingly have to make a local copy of the whole thing,
418# or die "socketpair: $!"; 571 # otherwise perl prematurely frees the stuff :/
419 pipe my $fh1, my $fh2 572 # TODO: investigate and fix (likely this will be rather laborious)
420 or die "pipe: $!";
421 573
422 if (my $pid = fork) { 574 my @res = Coro::Util::fork_eval {
423 close $fh2;
424
425 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
426 warn "pst<$res>" unless $res =~ /^pst/;
427 $res = Coro::Storable::thaw $res;
428
429 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
430
431 Carp::confess $$res unless "ARRAY" eq ref $res;
432
433 return wantarray ? @$res : $res->[-1];
434 } else {
435 reset_signals; 575 reset_signals;
436 local $SIG{__WARN__}; 576 &$cb
437 local $SIG{__DIE__}; 577 }, @args;
438 local $Coro::idle;
439 $Coro::current->prio (Coro::PRIO_MAX);
440 eval {
441 close $fh1;
442 578
443 my @res = eval { $cb->(@args) }; 579 wantarray ? @res : $res[-1]
580}
444 581
445 open my $fh, ">", \my $buf 582=item $coin = coin_from_name $name
446 or die "fork_call: cannot open fh-to-buf in child : $!";
447 Storable::store_fd +($@ ? \"$@" : \@res), $fh;
448 close $fh;
449 583
450 warn "writing ", length $buf; 584=cut
451 my $x;
452 (length $buf) == ($x = syswrite $fh2, $buf)
453 or warn "error writing ".(length $buf)." != $x\n";
454 close $fh2;
455 };
456 585
457 warn $@ if $@; 586our %coin_alias = (
458 _exit 0; 587 "silver" => "silvercoin",
459 } 588 "silvercoin" => "silvercoin",
589 "silvercoins" => "silvercoin",
590 "gold" => "goldcoin",
591 "goldcoin" => "goldcoin",
592 "goldcoins" => "goldcoin",
593 "platinum" => "platinacoin",
594 "platinumcoin" => "platinacoin",
595 "platinumcoins" => "platinacoin",
596 "platina" => "platinacoin",
597 "platinacoin" => "platinacoin",
598 "platinacoins" => "platinacoin",
599 "royalty" => "royalty",
600 "royalties" => "royalty",
601);
602
603sub coin_from_name($) {
604 $coin_alias{$_[0]}
605 ? cf::arch::find $coin_alias{$_[0]}
606 : undef
460} 607}
461 608
462=item $value = cf::db_get $family => $key 609=item $value = cf::db_get $family => $key
463 610
464Returns a single value from the environment database. 611Returns a single value from the environment database.
… …
466=item cf::db_put $family => $key => $value 613=item cf::db_put $family => $key => $value
467 614
468Stores the given C<$value> in the family. It can currently store binary 615Stores the given C<$value> in the family. It can currently store binary
469data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary). 616data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
470 617
618=item $db = cf::db_table "name"
619
620Create and/or open a new database table. The string must not be "db" and must be unique
621within each server.
622
471=cut 623=cut
624
625sub db_table($) {
626 my ($name) = @_;
627 my $db = BDB::db_create $DB_ENV;
628
629 eval {
630 $db->set_flags (BDB::CHKSUM);
631
632 utf8::encode $name;
633 BDB::db_open $db, undef, $name, undef, BDB::BTREE,
634 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
635 cf::cleanup "db_open(db): $!" if $!;
636 };
637 cf::cleanup "db_open(db): $@" if $@;
638
639 $db
640}
472 641
473our $DB; 642our $DB;
474 643
475sub db_init { 644sub db_init {
476 unless ($DB) {
477 $DB = BDB::db_create $DB_ENV;
478
479 cf::sync_job { 645 cf::sync_job {
480 eval { 646 $DB ||= db_table "db";
481 $DB->set_flags (BDB::CHKSUM);
482
483 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
484 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
485 cf::cleanup "db_open(db): $!" if $!;
486 };
487 cf::cleanup "db_open(db): $@" if $@;
488 };
489 } 647 };
490} 648}
491 649
492sub db_get($$) { 650sub db_get($$) {
493 my $key = "$_[0]/$_[1]"; 651 my $key = "$_[0]/$_[1]";
494 652
… …
544 if (1) { 702 if (1) {
545 $md5 = 703 $md5 =
546 join "\x00", 704 join "\x00",
547 $processversion, 705 $processversion,
548 map { 706 map {
549 Coro::cede; 707 cf::cede_to_tick;
550 ($src->[$_], Digest::MD5::md5_hex $data[$_]) 708 ($src->[$_], Digest::MD5::md5_hex $data[$_])
551 } 0.. $#$src; 709 } 0.. $#$src;
552 710
553 711
554 my $dbmd5 = db_get cache => "$id/md5"; 712 my $dbmd5 = db_get cache => "$id/md5";
… …
592 750
593############################################################################# 751#############################################################################
594 752
595=head2 ATTACHABLE OBJECTS 753=head2 ATTACHABLE OBJECTS
596 754
597Many objects in crossfire are so-called attachable objects. That means you can 755Many objects in deliantra are so-called attachable objects. That means you can
598attach callbacks/event handlers (a collection of which is called an "attachment") 756attach callbacks/event handlers (a collection of which is called an "attachment")
599to it. All such attachable objects support the following methods. 757to it. All such attachable objects support the following methods.
600 758
601In the following description, CLASS can be any of C<global>, C<object> 759In the following description, CLASS can be any of C<global>, C<object>
602C<player>, C<client> or C<map> (i.e. the attachable objects in 760C<player>, C<client> or C<map> (i.e. the attachable objects in
603Crossfire TRT). 761Deliantra).
604 762
605=over 4 763=over 4
606 764
607=item $attachable->attach ($attachment, key => $value...) 765=item $attachable->attach ($attachment, key => $value...)
608 766
… …
652=item cf::CLASS::attachment $name, ... 810=item cf::CLASS::attachment $name, ...
653 811
654Register an attachment by C<$name> through which attachable objects of the 812Register an attachment by C<$name> through which attachable objects of the
655given CLASS can refer to this attachment. 813given CLASS can refer to this attachment.
656 814
657Some classes such as crossfire maps and objects can specify attachments 815Some classes such as deliantra maps and objects can specify attachments
658that are attached at load/instantiate time, thus the need for a name. 816that are attached at load/instantiate time, thus the need for a name.
659 817
660These calls expect any number of the following handler/hook descriptions: 818These calls expect any number of the following handler/hook descriptions:
661 819
662=over 4 820=over 4
… …
860 "; 1018 ";
861 die if $@; 1019 die if $@;
862} 1020}
863 1021
864our $override; 1022our $override;
865our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 1023our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
866 1024
867sub override { 1025sub override {
868 $override = 1; 1026 $override = 1;
869 @invoke_results = (); 1027 @INVOKE_RESULTS = (@_);
870} 1028}
871 1029
872sub do_invoke { 1030sub do_invoke {
873 my $event = shift; 1031 my $event = shift;
874 my $callbacks = shift; 1032 my $callbacks = shift;
875 1033
876 @invoke_results = (); 1034 @INVOKE_RESULTS = ();
877 1035
878 local $override; 1036 local $override;
879 1037
880 for (@$callbacks) { 1038 for (@$callbacks) {
881 eval { &{$_->[1]} }; 1039 eval { &{$_->[1]} };
… …
890 } 1048 }
891 1049
892 0 1050 0
893} 1051}
894 1052
895=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 1053=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
896 1054
897=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 1055=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
898 1056
899Generate an object-specific event with the given arguments. 1057Generate an object-specific event with the given arguments.
900 1058
901This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be 1059This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
902removed in future versions), and there is no public API to access override 1060removed in future versions), and there is no public API to access override
903results (if you must, access C<@cf::invoke_results> directly). 1061results (if you must, access C<@cf::INVOKE_RESULTS> directly).
904 1062
905=back 1063=back
906 1064
907=cut 1065=cut
908 1066
909############################################################################# 1067#############################################################################
910# object support 1068# object support
1069
1070sub _object_equal($$);
1071sub _object_equal($$) {
1072 my ($a, $b) = @_;
1073
1074 return 0 unless (ref $a) eq (ref $b);
1075
1076 if ("HASH" eq ref $a) {
1077 my @ka = keys %$a;
1078 my @kb = keys %$b;
1079
1080 return 0 if @ka != @kb;
1081
1082 for (0 .. $#ka) {
1083 return 0 unless $ka[$_] eq $kb[$_];
1084 return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
1085 }
1086
1087 } elsif ("ARRAY" eq ref $a) {
1088
1089 return 0 if @$a != @$b;
1090
1091 for (0 .. $#$a) {
1092 return 0 unless _object_equal $a->[$_], $b->[$_];
1093 }
1094
1095 } elsif ($a ne $b) {
1096 return 0;
1097 }
1098
1099 1
1100}
1101
1102our $SLOW_MERGES;#d#
1103sub _can_merge {
1104 my ($ob1, $ob2) = @_;
1105
1106 ++$SLOW_MERGES;#d#
1107
1108 # we do the slow way here
1109 return _object_equal $ob1, $ob2
1110}
911 1111
912sub reattach { 1112sub reattach {
913 # basically do the same as instantiate, without calling instantiate 1113 # basically do the same as instantiate, without calling instantiate
914 my ($obj) = @_; 1114 my ($obj) = @_;
915 1115
1116 # no longer needed after getting rid of delete_package?
916 bless $obj, ref $obj; # re-bless in case extensions have been reloaded 1117 #bless $obj, ref $obj; # re-bless in case extensions have been reloaded
917 1118
918 my $registry = $obj->registry; 1119 my $registry = $obj->registry;
919 1120
920 @$registry = (); 1121 @$registry = ();
921 1122
… …
936cf::attachable->attach ( 1137cf::attachable->attach (
937 prio => -1000000, 1138 prio => -1000000,
938 on_instantiate => sub { 1139 on_instantiate => sub {
939 my ($obj, $data) = @_; 1140 my ($obj, $data) = @_;
940 1141
941 $data = from_json $data; 1142 $data = decode_json $data;
942 1143
943 for (@$data) { 1144 for (@$data) {
944 my ($name, $args) = @$_; 1145 my ($name, $args) = @$_;
945 1146
946 $obj->attach ($name, %{$args || {} }); 1147 $obj->attach ($name, %{$args || {} });
… …
962sub object_freezer_save { 1163sub object_freezer_save {
963 my ($filename, $rdata, $objs) = @_; 1164 my ($filename, $rdata, $objs) = @_;
964 1165
965 sync_job { 1166 sync_job {
966 if (length $$rdata) { 1167 if (length $$rdata) {
1168 utf8::decode (my $decname = $filename);
967 warn sprintf "saving %s (%d,%d)\n", 1169 warn sprintf "saving %s (%d,%d)\n",
968 $filename, length $$rdata, scalar @$objs; 1170 $decname, length $$rdata, scalar @$objs;
969 1171
970 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1172 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
971 chmod SAVE_MODE, $fh; 1173 aio_chmod $fh, SAVE_MODE;
972 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1174 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
973 aio_fsync $fh if $cf::USE_FSYNC; 1175 aio_fsync $fh if $cf::USE_FSYNC;
974 close $fh; 1176 aio_close $fh;
975 1177
976 if (@$objs) { 1178 if (@$objs) {
977 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1179 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
978 chmod SAVE_MODE, $fh; 1180 aio_chmod $fh, SAVE_MODE;
979 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1181 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
980 aio_write $fh, 0, (length $data), $data, 0; 1182 aio_write $fh, 0, (length $data), $data, 0;
981 aio_fsync $fh if $cf::USE_FSYNC; 1183 aio_fsync $fh if $cf::USE_FSYNC;
982 close $fh; 1184 aio_close $fh;
983 aio_rename "$filename.pst~", "$filename.pst"; 1185 aio_rename "$filename.pst~", "$filename.pst";
984 } 1186 }
985 } else { 1187 } else {
986 aio_unlink "$filename.pst"; 1188 aio_unlink "$filename.pst";
987 } 1189 }
988 1190
989 aio_rename "$filename~", $filename; 1191 aio_rename "$filename~", $filename;
1192
1193 $filename =~ s%/[^/]+$%%;
1194 aio_pathsync $filename;
990 } else { 1195 } else {
991 warn "FATAL: $filename~: $!\n"; 1196 warn "FATAL: $filename~: $!\n";
992 } 1197 }
993 } else { 1198 } else {
994 aio_unlink $filename; 1199 aio_unlink $filename;
995 aio_unlink "$filename.pst"; 1200 aio_unlink "$filename.pst";
996 } 1201 }
997 } 1202 };
998} 1203}
999 1204
1000sub object_freezer_as_string { 1205sub object_freezer_as_string {
1001 my ($rdata, $objs) = @_; 1206 my ($rdata, $objs) = @_;
1002 1207
… …
1014 or return; 1219 or return;
1015 1220
1016 unless (aio_stat "$filename.pst") { 1221 unless (aio_stat "$filename.pst") {
1017 (aio_load "$filename.pst", $av) >= 0 1222 (aio_load "$filename.pst", $av) >= 0
1018 or return; 1223 or return;
1224
1019 $av = eval { (Storable::thaw $av)->{objs} }; 1225 my $st = eval { Coro::Storable::thaw $av };
1226 $av = $st->{objs};
1020 } 1227 }
1021 1228
1229 utf8::decode (my $decname = $filename);
1022 warn sprintf "loading %s (%d)\n", 1230 warn sprintf "loading %s (%d,%d)\n",
1023 $filename, length $data, scalar @{$av || []}; 1231 $decname, length $data, scalar @{$av || []};
1232
1024 return ($data, $av); 1233 ($data, $av)
1025} 1234}
1026 1235
1027=head2 COMMAND CALLBACKS 1236=head2 COMMAND CALLBACKS
1028 1237
1029=over 4 1238=over 4
… …
1102 my ($pl, $buf) = @_; 1311 my ($pl, $buf) = @_;
1103 1312
1104 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) }; 1313 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1105 1314
1106 if (ref $msg) { 1315 if (ref $msg) {
1316 my ($type, $reply, @payload) =
1317 "ARRAY" eq ref $msg
1318 ? @$msg
1319 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1320
1321 my @reply;
1322
1107 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1323 if (my $cb = $EXTCMD{$type}) {
1108 if (my %reply = $cb->($pl, $msg)) { 1324 @reply = $cb->($pl, @payload);
1109 $pl->ext_reply ($msg->{msgid}, %reply);
1110 }
1111 } 1325 }
1326
1327 $pl->ext_reply ($reply, @reply)
1328 if $reply;
1329
1112 } else { 1330 } else {
1113 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1331 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1114 } 1332 }
1115 1333
1116 cf::override; 1334 cf::override;
… …
1143 1361
1144 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 } 1362 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1145 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; 1363 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1146 1364
1147 $ext{source} = 1365 $ext{source} =
1148 "package $pkg; use strict; use utf8;\n" 1366 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n"
1149 . "#line 1 \"$path\"\n{\n" 1367 . "#line 1 \"$path\"\n{\n"
1150 . $source 1368 . $source
1151 . "\n};\n1"; 1369 . "\n};\n1";
1152 1370
1153 $todo{$base} = \%ext; 1371 $todo{$base} = \%ext;
… …
1169 my $msg = $@ ? "$v->{path}: $@\n" 1387 my $msg = $@ ? "$v->{path}: $@\n"
1170 : "$v->{base}: extension inactive.\n"; 1388 : "$v->{base}: extension inactive.\n";
1171 1389
1172 if (exists $v->{meta}{mandatory}) { 1390 if (exists $v->{meta}{mandatory}) {
1173 warn $msg; 1391 warn $msg;
1174 warn "mandatory extension failed to load, exiting.\n"; 1392 cf::cleanup "mandatory extension failed to load, exiting.";
1175 exit 1;
1176 } 1393 }
1177 1394
1178 warn $msg; 1395 warn $msg;
1179 } 1396 }
1180 1397
… …
1194 1411
1195=back 1412=back
1196 1413
1197=head2 CORE EXTENSIONS 1414=head2 CORE EXTENSIONS
1198 1415
1199Functions and methods that extend core crossfire objects. 1416Functions and methods that extend core deliantra objects.
1200 1417
1201=cut 1418=cut
1202 1419
1203package cf::player; 1420package cf::player;
1204 1421
1205use Coro::AIO; 1422use Coro::AIO;
1206 1423
1207=head3 cf::player 1424=head3 cf::player
1208 1425
1209=over 4 1426=over 4
1427
1428=item cf::player::num_playing
1429
1430Returns the official number of playing players, as per the Crossfire metaserver rules.
1431
1432=cut
1433
1434sub num_playing {
1435 scalar grep
1436 $_->ob->map
1437 && !$_->hidden
1438 && !$_->ob->flag (cf::FLAG_WIZ),
1439 cf::player::list
1440}
1210 1441
1211=item cf::player::find $login 1442=item cf::player::find $login
1212 1443
1213Returns the given player object, loading it if necessary (might block). 1444Returns the given player object, loading it if necessary (might block).
1214 1445
… …
1233 1464
1234sub exists($) { 1465sub exists($) {
1235 my ($login) = @_; 1466 my ($login) = @_;
1236 1467
1237 $cf::PLAYER{$login} 1468 $cf::PLAYER{$login}
1238 or cf::sync_job { !aio_stat path $login } 1469 or !aio_stat path $login
1239} 1470}
1240 1471
1241sub find($) { 1472sub find($) {
1242 return $cf::PLAYER{$_[0]} || do { 1473 return $cf::PLAYER{$_[0]} || do {
1243 my $login = $_[0]; 1474 my $login = $_[0];
… …
1250 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst"; 1481 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1251 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata"; 1482 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1252 aio_unlink +(playerdir $login) . "/$login.pl.pst"; 1483 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1253 aio_unlink +(playerdir $login) . "/$login.pl"; 1484 aio_unlink +(playerdir $login) . "/$login.pl";
1254 1485
1255 my $pl = load_pl path $login 1486 my $f = new_from_file cf::object::thawer path $login
1256 or return; 1487 or return;
1488
1489 my $pl = cf::player::load_pl $f
1490 or return;
1491
1492 local $cf::PLAYER_LOADING{$login} = $pl;
1493 $f->resolve_delayed_derefs;
1257 $cf::PLAYER{$login} = $pl 1494 $cf::PLAYER{$login} = $pl
1258 } 1495 }
1259 } 1496 }
1260} 1497}
1261 1498
… …
1270 return if $pl->{deny_save}; 1507 return if $pl->{deny_save};
1271 1508
1272 aio_mkdir playerdir $pl, 0770; 1509 aio_mkdir playerdir $pl, 0770;
1273 $pl->{last_save} = $cf::RUNTIME; 1510 $pl->{last_save} = $cf::RUNTIME;
1274 1511
1512 cf::get_slot 0.01;
1513
1275 $pl->save_pl ($path); 1514 $pl->save_pl ($path);
1276 Coro::cede; 1515 cf::cede_to_tick;
1277} 1516}
1278 1517
1279sub new($) { 1518sub new($) {
1280 my ($login) = @_; 1519 my ($login) = @_;
1281 1520
… …
1287 $cf::PLAYER{$login} = $self; 1526 $cf::PLAYER{$login} = $self;
1288 1527
1289 $self 1528 $self
1290} 1529}
1291 1530
1531=item $player->send_msg ($channel, $msg, $color, [extra...])
1532
1533=cut
1534
1535sub send_msg {
1536 my $ns = shift->ns
1537 or return;
1538 $ns->send_msg (@_);
1539}
1540
1292=item $pl->quit_character 1541=item $pl->quit_character
1293 1542
1294Nukes the player without looking back. If logged in, the connection will 1543Nukes the player without looking back. If logged in, the connection will
1295be destroyed. May block for a long time. 1544be destroyed. May block for a long time.
1296 1545
… …
1300 my ($pl) = @_; 1549 my ($pl) = @_;
1301 1550
1302 my $name = $pl->ob->name; 1551 my $name = $pl->ob->name;
1303 1552
1304 $pl->{deny_save} = 1; 1553 $pl->{deny_save} = 1;
1305 $pl->password ("*"); # this should lock out the player until we nuked the dir 1554 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1306 1555
1307 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1556 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1308 $pl->deactivate; 1557 $pl->deactivate;
1558 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1559 $pl->ob->check_score;
1309 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1560 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1310 $pl->ns->destroy if $pl->ns; 1561 $pl->ns->destroy if $pl->ns;
1311 1562
1312 my $path = playerdir $pl; 1563 my $path = playerdir $pl;
1313 my $temp = "$path~$cf::RUNTIME~deleting~"; 1564 my $temp = "$path~$cf::RUNTIME~deleting~";
… …
1349 or return []; 1600 or return [];
1350 1601
1351 my @logins; 1602 my @logins;
1352 1603
1353 for my $login (@$dirs) { 1604 for my $login (@$dirs) {
1605 my $path = path $login;
1606
1607 # a .pst is a dead give-away for a valid player
1608 # if no pst file found, open and chekc for blocked users
1609 if (aio_stat "$path.pst") {
1354 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1610 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1355 aio_read $fh, 0, 512, my $buf, 0 or next; 1611 aio_read $fh, 0, 512, my $buf, 0 or next;
1356 $buf !~ /^password -------------$/m or next; # official not-valid tag 1612 $buf !~ /^password -------------$/m or next; # official not-valid tag
1613 }
1357 1614
1358 utf8::decode $login; 1615 utf8::decode $login;
1359 push @logins, $login; 1616 push @logins, $login;
1360 } 1617 }
1361 1618
… …
1388 } 1645 }
1389 1646
1390 \@paths 1647 \@paths
1391} 1648}
1392 1649
1393=item $protocol_xml = $player->expand_cfpod ($crossfire_pod) 1650=item $protocol_xml = $player->expand_cfpod ($cfpod)
1394 1651
1395Expand crossfire pod fragments into protocol xml. 1652Expand deliantra pod fragments into protocol xml.
1396 1653
1397=cut
1398
1399sub expand_cfpod {
1400 ((my $self), (local $_)) = @_;
1401
1402 # escape & and <
1403 s/&/&amp;/g;
1404 s/(?<![BIUGH])</&lt;/g;
1405
1406 # this is buggy, it needs to properly take care of nested <'s
1407
1408 1 while
1409 # replace B<>, I<>, U<> etc.
1410 s/B<([^\>]*)>/<b>$1<\/b>/
1411 || s/I<([^\>]*)>/<i>$1<\/i>/
1412 || s/U<([^\>]*)>/<u>$1<\/u>/
1413 # replace G<male|female> tags
1414 || s{G<([^>|]*)\|([^>]*)>}{
1415 $self->gender ? $2 : $1
1416 }ge
1417 # replace H<hint text>
1418 || s{H<([^\>]*)>}
1419 {
1420 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
1421 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1422 "")
1423 [$self->{hintmode}]
1424 }ge;
1425
1426 # create single paragraphs (very hackish)
1427 s/(?<=\S)\n(?=\w)/ /g;
1428
1429 # compress some whitespace
1430 s/\s+\n/\n/g; # ws line-ends
1431 s/\n\n+/\n/g; # double lines
1432 s/^\n+//; # beginning lines
1433 s/\n+$//; # ending lines
1434
1435 $_
1436}
1437
1438sub hintmode {
1439 $_[0]{hintmode} = $_[1] if @_ > 1;
1440 $_[0]{hintmode}
1441}
1442
1443=item $player->ext_reply ($msgid, %msg) 1654=item $player->ext_reply ($msgid, @msg)
1444 1655
1445Sends an ext reply to the player. 1656Sends an ext reply to the player.
1446 1657
1447=cut 1658=cut
1448 1659
1449sub ext_reply($$%) { 1660sub ext_reply($$@) {
1450 my ($self, $id, %msg) = @_; 1661 my ($self, $id, @msg) = @_;
1451 1662
1452 $msg{msgid} = $id; 1663 $self->ns->ext_reply ($id, @msg)
1453 $self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));
1454} 1664}
1455 1665
1456=item $player->ext_event ($type, %msg) 1666=item $player->ext_msg ($type, @msg)
1457 1667
1458Sends an ext event to the client. 1668Sends an ext event to the client.
1459 1669
1460=cut 1670=cut
1461 1671
1462sub ext_event($$%) { 1672sub ext_msg($$@) {
1463 my ($self, $type, %msg) = @_; 1673 my ($self, $type, @msg) = @_;
1464 1674
1465 $self->ns->ext_event ($type, %msg); 1675 $self->ns->ext_msg ($type, @msg);
1466} 1676}
1467 1677
1468=head3 cf::region 1678=head3 cf::region
1469 1679
1470=over 4 1680=over 4
… …
1483 my ($path) = @_; 1693 my ($path) = @_;
1484 1694
1485 my ($match, $specificity); 1695 my ($match, $specificity);
1486 1696
1487 for my $region (list) { 1697 for my $region (list) {
1488 if ($region->match && $path =~ $region->match) { 1698 if ($region->{match} && $path =~ $region->{match}) {
1489 ($match, $specificity) = ($region, $region->specificity) 1699 ($match, $specificity) = ($region, $region->specificity)
1490 if $region->specificity > $specificity; 1700 if $region->specificity > $specificity;
1491 } 1701 }
1492 } 1702 }
1493 1703
… …
1514our $MAX_RESET = 3600; 1724our $MAX_RESET = 3600;
1515our $DEFAULT_RESET = 3000; 1725our $DEFAULT_RESET = 3000;
1516 1726
1517sub generate_random_map { 1727sub generate_random_map {
1518 my ($self, $rmp) = @_; 1728 my ($self, $rmp) = @_;
1729
1730 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1731
1519 # mit "rum" bekleckern, nicht 1732 # mit "rum" bekleckern, nicht
1520 $self->_create_random_map ( 1733 $self->_create_random_map (
1521 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1734 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1522 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1735 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1523 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1736 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
… …
1613 $self->init; # pass $1 etc. 1826 $self->init; # pass $1 etc.
1614 return $self; 1827 return $self;
1615 } 1828 }
1616 } 1829 }
1617 1830
1618 Carp::carp "unable to resolve path '$path' (base '$base')."; 1831 Carp::cluck "unable to resolve path '$path' (base '$base').";
1619 () 1832 ()
1620} 1833}
1621 1834
1622sub init { 1835sub init {
1623 my ($self) = @_; 1836 my ($self) = @_;
… …
1645 1858
1646# the temporary/swap location 1859# the temporary/swap location
1647sub save_path { 1860sub save_path {
1648 my ($self) = @_; 1861 my ($self) = @_;
1649 1862
1650 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1863 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1651 "$TMPDIR/$path.map" 1864 "$TMPDIR/$path.map"
1652} 1865}
1653 1866
1654# the unique path, undef == no special unique path 1867# the unique path, undef == no special unique path
1655sub uniq_path { 1868sub uniq_path {
1656 my ($self) = @_; 1869 my ($self) = @_;
1657 1870
1658 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1871 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1659 "$UNIQUEDIR/$path" 1872 "$UNIQUEDIR/$path"
1660} 1873}
1661 1874
1662# and all this just because we cannot iterate over 1875# and all this just because we cannot iterate over
1663# all maps in C++... 1876# all maps in C++...
… …
1686 1899
1687sub load_header_from($) { 1900sub load_header_from($) {
1688 my ($self, $path) = @_; 1901 my ($self, $path) = @_;
1689 1902
1690 utf8::encode $path; 1903 utf8::encode $path;
1691 #aio_open $path, O_RDONLY, 0 1904 my $f = new_from_file cf::object::thawer $path
1692 # or return;
1693
1694 $self->_load_header ($path)
1695 or return; 1905 or return;
1906
1907 $self->_load_header ($f)
1908 or return;
1909
1910 local $MAP_LOADING{$self->{path}} = $self;
1911 $f->resolve_delayed_derefs;
1696 1912
1697 $self->{load_path} = $path; 1913 $self->{load_path} = $path;
1698 1914
1699 1 1915 1
1700} 1916}
… …
1754sub find { 1970sub find {
1755 my ($path, $origin) = @_; 1971 my ($path, $origin) = @_;
1756 1972
1757 $path = normalise $path, $origin && $origin->path; 1973 $path = normalise $path, $origin && $origin->path;
1758 1974
1975 cf::lock_wait "map_data:$path";#d#remove
1759 cf::lock_wait "map_find:$path"; 1976 cf::lock_wait "map_find:$path";
1760 1977
1761 $cf::MAP{$path} || do { 1978 $cf::MAP{$path} || do {
1979 my $guard1 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1762 my $guard = cf::lock_acquire "map_find:$path"; 1980 my $guard2 = cf::lock_acquire "map_find:$path";
1981
1763 my $map = new_from_path cf::map $path 1982 my $map = new_from_path cf::map $path
1764 or return; 1983 or return;
1765 1984
1766 $map->{last_save} = $cf::RUNTIME; 1985 $map->{last_save} = $cf::RUNTIME;
1767 1986
… …
1769 or return; 1988 or return;
1770 1989
1771 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 1990 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1772 # doing this can freeze the server in a sync job, obviously 1991 # doing this can freeze the server in a sync job, obviously
1773 #$cf::WAIT_FOR_TICK->wait; 1992 #$cf::WAIT_FOR_TICK->wait;
1993 undef $guard2;
1994 undef $guard1;
1774 $map->reset; 1995 $map->reset;
1775 undef $guard;
1776 return find $path; 1996 return find $path;
1777 } 1997 }
1778 1998
1779 $cf::MAP{$path} = $map 1999 $cf::MAP{$path} = $map
1780 } 2000 }
… …
1789 local $self->{deny_reset} = 1; # loading can take a long time 2009 local $self->{deny_reset} = 1; # loading can take a long time
1790 2010
1791 my $path = $self->{path}; 2011 my $path = $self->{path};
1792 2012
1793 { 2013 {
1794 my $guard = cf::lock_acquire "map_load:$path"; 2014 my $guard = cf::lock_acquire "map_data:$path";
1795 2015
2016 return unless $self->valid;
1796 return if $self->in_memory != cf::MAP_SWAPPED; 2017 return unless $self->in_memory == cf::MAP_SWAPPED;
1797 2018
1798 $self->in_memory (cf::MAP_LOADING); 2019 $self->in_memory (cf::MAP_LOADING);
1799 2020
1800 $self->alloc; 2021 $self->alloc;
1801 2022
1802 $self->pre_load; 2023 $self->pre_load;
1803 Coro::cede; 2024 cf::cede_to_tick;
1804 2025
2026 my $f = new_from_file cf::object::thawer $self->{load_path};
2027 $f->skip_block;
1805 $self->_load_objects ($self->{load_path}, 1) 2028 $self->_load_objects ($f)
1806 or return; 2029 or return;
1807 2030
1808 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2031 $self->post_load_original
1809 if delete $self->{load_original}; 2032 if delete $self->{load_original};
1810 2033
1811 if (my $uniq = $self->uniq_path) { 2034 if (my $uniq = $self->uniq_path) {
1812 utf8::encode $uniq; 2035 utf8::encode $uniq;
1813 if (aio_open $uniq, O_RDONLY, 0) { 2036 unless (aio_stat $uniq) {
2037 if (my $f = new_from_file cf::object::thawer $uniq) {
1814 $self->clear_unique_items; 2038 $self->clear_unique_items;
1815 $self->_load_objects ($uniq, 0); 2039 $self->_load_objects ($f);
2040 $f->resolve_delayed_derefs;
2041 }
1816 } 2042 }
1817 } 2043 }
1818 2044
1819 Coro::cede; 2045 $f->resolve_delayed_derefs;
2046
2047 cf::cede_to_tick;
1820 # now do the right thing for maps 2048 # now do the right thing for maps
1821 $self->link_multipart_objects; 2049 $self->link_multipart_objects;
1822 $self->difficulty ($self->estimate_difficulty) 2050 $self->difficulty ($self->estimate_difficulty)
1823 unless $self->difficulty; 2051 unless $self->difficulty;
1824 Coro::cede; 2052 cf::cede_to_tick;
1825 2053
1826 unless ($self->{deny_activate}) { 2054 unless ($self->{deny_activate}) {
1827 $self->decay_objects; 2055 $self->decay_objects;
1828 $self->fix_auto_apply; 2056 $self->fix_auto_apply;
1829 $self->update_buttons; 2057 $self->update_buttons;
1830 Coro::cede; 2058 cf::cede_to_tick;
1831 $self->set_darkness_map; 2059 $self->set_darkness_map;
1832 Coro::cede; 2060 cf::cede_to_tick;
1833 $self->activate; 2061 $self->activate;
1834 } 2062 }
1835 2063
2064 $self->{last_save} = $cf::RUNTIME;
2065 $self->last_access ($cf::RUNTIME);
2066
1836 $self->in_memory (cf::MAP_IN_MEMORY); 2067 $self->in_memory (cf::MAP_ACTIVE);
1837 } 2068 }
1838 2069
1839 $self->post_load; 2070 $self->post_load;
1840} 2071}
1841 2072
… …
1850 2081
1851 $self 2082 $self
1852} 2083}
1853 2084
1854# find and load all maps in the 3x3 area around a map 2085# find and load all maps in the 3x3 area around a map
1855sub load_diag { 2086sub load_neighbours {
1856 my ($map) = @_; 2087 my ($map) = @_;
1857 2088
1858 my @diag; # diagonal neighbours 2089 my @neigh; # diagonal neighbours
1859 2090
1860 for (0 .. 3) { 2091 for (0 .. 3) {
1861 my $neigh = $map->tile_path ($_) 2092 my $neigh = $map->tile_path ($_)
1862 or next; 2093 or next;
1863 $neigh = find $neigh, $map 2094 $neigh = find $neigh, $map
1864 or next; 2095 or next;
1865 $neigh->load; 2096 $neigh->load;
1866 2097
2098 push @neigh,
1867 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 2099 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1868 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2100 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1869 } 2101 }
1870 2102
1871 for (@diag) { 2103 for (grep defined $_->[0], @neigh) {
2104 my ($path, $origin) = @$_;
1872 my $neigh = find @$_ 2105 my $neigh = find $path, $origin
1873 or next; 2106 or next;
1874 $neigh->load; 2107 $neigh->load;
1875 } 2108 }
1876} 2109}
1877 2110
… …
1882} 2115}
1883 2116
1884sub do_load_sync { 2117sub do_load_sync {
1885 my ($map) = @_; 2118 my ($map) = @_;
1886 2119
2120 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
2121 if $Coro::current == $Coro::main;
2122
1887 cf::sync_job { $map->load }; 2123 cf::sync_job { $map->load };
1888} 2124}
1889 2125
1890our %MAP_PREFETCH; 2126our %MAP_PREFETCH;
1891our $MAP_PREFETCHER = undef; 2127our $MAP_PREFETCHER = undef;
1892 2128
1893sub find_async { 2129sub find_async {
1894 my ($path, $origin) = @_; 2130 my ($path, $origin, $load) = @_;
1895 2131
1896 $path = normalise $path, $origin && $origin->{path}; 2132 $path = normalise $path, $origin && $origin->{path};
1897 2133
1898 if (my $map = $cf::MAP{$path}) { 2134 if (my $map = $cf::MAP{$path}) {
1899 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 2135 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
1900 } 2136 }
1901 2137
1902 undef $MAP_PREFETCH{$path}; 2138 $MAP_PREFETCH{$path} |= $load;
2139
1903 $MAP_PREFETCHER ||= cf::async { 2140 $MAP_PREFETCHER ||= cf::async {
2141 $Coro::current->{desc} = "map prefetcher";
2142
1904 while (%MAP_PREFETCH) { 2143 while (%MAP_PREFETCH) {
1905 for my $path (keys %MAP_PREFETCH) { 2144 while (my ($k, $v) = each %MAP_PREFETCH) {
1906 my $map = find $path 2145 if (my $map = find $k) {
1907 or next;
1908 $map->load; 2146 $map->load if $v;
2147 }
1909 2148
1910 delete $MAP_PREFETCH{$path}; 2149 delete $MAP_PREFETCH{$k};
1911 } 2150 }
1912 } 2151 }
1913 undef $MAP_PREFETCHER; 2152 undef $MAP_PREFETCHER;
1914 }; 2153 };
1915 $MAP_PREFETCHER->prio (6); 2154 $MAP_PREFETCHER->prio (6);
… …
1918} 2157}
1919 2158
1920sub save { 2159sub save {
1921 my ($self) = @_; 2160 my ($self) = @_;
1922 2161
1923 my $lock = cf::lock_acquire "map_data:" . $self->path; 2162 my $lock = cf::lock_acquire "map_data:$self->{path}";
1924 2163
1925 $self->{last_save} = $cf::RUNTIME; 2164 $self->{last_save} = $cf::RUNTIME;
1926 2165
1927 return unless $self->dirty; 2166 return unless $self->dirty;
1928 2167
… …
1934 return if $self->{deny_save}; 2173 return if $self->{deny_save};
1935 2174
1936 local $self->{last_access} = $self->last_access;#d# 2175 local $self->{last_access} = $self->last_access;#d#
1937 2176
1938 cf::async { 2177 cf::async {
2178 $Coro::current->{desc} = "map player save";
1939 $_->contr->save for $self->players; 2179 $_->contr->save for $self->players;
1940 }; 2180 };
2181
2182 cf::get_slot 0.02;
1941 2183
1942 if ($uniq) { 2184 if ($uniq) {
1943 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2185 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1944 $self->_save_objects ($uniq, cf::IO_UNIQUES); 2186 $self->_save_objects ($uniq, cf::IO_UNIQUES);
1945 } else { 2187 } else {
… …
1951 my ($self) = @_; 2193 my ($self) = @_;
1952 2194
1953 # save first because save cedes 2195 # save first because save cedes
1954 $self->save; 2196 $self->save;
1955 2197
1956 my $lock = cf::lock_acquire "map_data:" . $self->path; 2198 my $lock = cf::lock_acquire "map_data:$self->{path}";
1957 2199
1958 return if $self->players; 2200 return if $self->players;
1959 return if $self->in_memory != cf::MAP_IN_MEMORY; 2201 return if $self->in_memory != cf::MAP_ACTIVE;
1960 return if $self->{deny_save}; 2202 return if $self->{deny_save};
1961 2203
2204 $self->in_memory (cf::MAP_SWAPPED);
2205
2206 $self->deactivate;
2207 $_->clear_links_to ($self) for values %cf::MAP;
1962 $self->clear; 2208 $self->clear;
1963 $self->in_memory (cf::MAP_SWAPPED);
1964} 2209}
1965 2210
1966sub reset_at { 2211sub reset_at {
1967 my ($self) = @_; 2212 my ($self) = @_;
1968 2213
… …
2000 if $uniq; 2245 if $uniq;
2001 } 2246 }
2002 2247
2003 delete $cf::MAP{$self->path}; 2248 delete $cf::MAP{$self->path};
2004 2249
2250 $self->deactivate;
2251 $_->clear_links_to ($self) for values %cf::MAP;
2005 $self->clear; 2252 $self->clear;
2006
2007 $_->clear_links_to ($self) for values %cf::MAP;
2008 2253
2009 $self->unlink_save; 2254 $self->unlink_save;
2010 $self->destroy; 2255 $self->destroy;
2011} 2256}
2012 2257
2013my $nuke_counter = "aaaa"; 2258my $nuke_counter = "aaaa";
2014 2259
2015sub nuke { 2260sub nuke {
2016 my ($self) = @_; 2261 my ($self) = @_;
2017 2262
2263 {
2264 my $lock = cf::lock_acquire "map_data:$self->{path}";
2265
2018 delete $cf::MAP{$self->path}; 2266 delete $cf::MAP{$self->path};
2019 2267
2020 $self->unlink_save; 2268 $self->unlink_save;
2021 2269
2022 bless $self, "cf::map"; 2270 bless $self, "cf::map";
2023 delete $self->{deny_reset}; 2271 delete $self->{deny_reset};
2024 $self->{deny_save} = 1; 2272 $self->{deny_save} = 1;
2025 $self->reset_timeout (1); 2273 $self->reset_timeout (1);
2026 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2274 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2027 2275
2028 $cf::MAP{$self->path} = $self; 2276 $cf::MAP{$self->path} = $self;
2277 }
2029 2278
2030 $self->reset; # polite request, might not happen 2279 $self->reset; # polite request, might not happen
2031} 2280}
2032 2281
2033=item $maps = cf::map::tmp_maps 2282=item $maps = cf::map::tmp_maps
… …
2075 2324
2076sub unique_maps() { 2325sub unique_maps() {
2077 [ 2326 [
2078 map { 2327 map {
2079 utf8::decode $_; 2328 utf8::decode $_;
2080 /\.map$/ 2329 s/\.map$//; # TODO future compatibility hack
2330 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
2331 ? ()
2081 ? normalise $_ 2332 : normalise $_
2082 : ()
2083 } @{ aio_readdir $UNIQUEDIR or [] } 2333 } @{ aio_readdir $UNIQUEDIR or [] }
2084 ] 2334 ]
2085} 2335}
2086 2336
2087package cf;
2088
2089=back 2337=back
2090 2338
2091=head3 cf::object 2339=head3 cf::object
2092 2340
2093=cut 2341=cut
… …
2096 2344
2097=over 4 2345=over 4
2098 2346
2099=item $ob->inv_recursive 2347=item $ob->inv_recursive
2100 2348
2101Returns the inventory of the object _and_ their inventories, recursively. 2349Returns the inventory of the object I<and> their inventories, recursively,
2350but I<not> the object itself.
2102 2351
2103=cut 2352=cut
2104 2353
2105sub inv_recursive_; 2354sub inv_recursive_;
2106sub inv_recursive_ { 2355sub inv_recursive_ {
… …
2109 2358
2110sub inv_recursive { 2359sub inv_recursive {
2111 inv_recursive_ inv $_[0] 2360 inv_recursive_ inv $_[0]
2112} 2361}
2113 2362
2363=item $ref = $ob->ref
2364
2365Creates and returns a persistent reference to an object that can be stored as a string.
2366
2367=item $ob = cf::object::deref ($refstring)
2368
2369returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2370even if the object actually exists. May block.
2371
2372=cut
2373
2374sub deref {
2375 my ($ref) = @_;
2376
2377 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2378 my ($uuid, $name) = ($1, $2);
2379 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2380 or return;
2381 $pl->ob->uuid eq $uuid
2382 or return;
2383
2384 $pl->ob
2385 } else {
2386 warn "$ref: cannot resolve object reference\n";
2387 undef
2388 }
2389}
2390
2114package cf; 2391package cf;
2115 2392
2116=back 2393=back
2117 2394
2118=head3 cf::object::player 2395=head3 cf::object::player
… …
2124Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 2401Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
2125can be C<undef>. Does the right thing when the player is currently in a 2402can be C<undef>. Does the right thing when the player is currently in a
2126dialogue with the given NPC character. 2403dialogue with the given NPC character.
2127 2404
2128=cut 2405=cut
2406
2407our $SAY_CHANNEL = {
2408 id => "say",
2409 title => "Map",
2410 reply => "say ",
2411 tooltip => "Things said to and replied from npcs near you and other players on the same map only.",
2412};
2413
2414our $CHAT_CHANNEL = {
2415 id => "chat",
2416 title => "Chat",
2417 reply => "chat ",
2418 tooltip => "Player chat and shouts, global to the server.",
2419};
2129 2420
2130# rough implementation of a future "reply" method that works 2421# rough implementation of a future "reply" method that works
2131# with dialog boxes. 2422# with dialog boxes.
2132#TODO: the first argument must go, split into a $npc->reply_to ( method 2423#TODO: the first argument must go, split into a $npc->reply_to ( method
2133sub cf::object::player::reply($$$;$) { 2424sub cf::object::player::reply($$$;$) {
… …
2140 2431
2141 } else { 2432 } else {
2142 my $pl = $self->contr; 2433 my $pl = $self->contr;
2143 2434
2144 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) { 2435 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2145 my $diag = $pl->{npc_dialog}; 2436 my $dialog = $pl->{npc_dialog};
2146 $diag->{pl}->ext_reply ( 2437 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2147 $diag->{id},
2148 msgtype => "reply",
2149 msg => $diag->{pl}->expand_cfpod ($msg),
2150 add_topics => []
2151 );
2152 2438
2153 } else { 2439 } else {
2154 $msg = $npc->name . " says: $msg" if $npc; 2440 $msg = $npc->name . " says: $msg" if $npc;
2155 $self->message ($msg, $flags); 2441 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2156 } 2442 }
2157 } 2443 }
2444}
2445
2446=item $object->send_msg ($channel, $msg, $color, [extra...])
2447
2448=cut
2449
2450sub cf::object::send_msg {
2451 my $pl = shift->contr
2452 or return;
2453 $pl->send_msg (@_);
2158} 2454}
2159 2455
2160=item $player_object->may ("access") 2456=item $player_object->may ("access")
2161 2457
2162Returns wether the given player is authorized to access resource "access" 2458Returns wether the given player is authorized to access resource "access"
… …
2175 2471
2176=item $player_object->enter_link 2472=item $player_object->enter_link
2177 2473
2178Freezes the player and moves him/her to a special map (C<{link}>). 2474Freezes the player and moves him/her to a special map (C<{link}>).
2179 2475
2180The player should be reasonably safe there for short amounts of time. You 2476The player should be reasonably safe there for short amounts of time (e.g.
2181I<MUST> call C<leave_link> as soon as possible, though. 2477for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2478though, as the palyer cannot control the character while it is on the link
2479map.
2182 2480
2183Will never block. 2481Will never block.
2184 2482
2185=item $player_object->leave_link ($map, $x, $y) 2483=item $player_object->leave_link ($map, $x, $y)
2186 2484
… …
2241 # use -1 or undef as default coordinates, not 0, 0 2539 # use -1 or undef as default coordinates, not 0, 0
2242 ($x, $y) = ($map->enter_x, $map->enter_y) 2540 ($x, $y) = ($map->enter_x, $map->enter_y)
2243 if $x <=0 && $y <= 0; 2541 if $x <=0 && $y <= 0;
2244 2542
2245 $map->load; 2543 $map->load;
2246 $map->load_diag; 2544 $map->load_neighbours;
2247 2545
2248 return unless $self->contr->active; 2546 return unless $self->contr->active;
2547 $self->flag (cf::FLAG_DEBUG, 0);#d# temp
2249 $self->activate_recursive; 2548 $self->activate_recursive;
2250 2549
2251 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2550 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2252 $self->enter_map ($map, $x, $y); 2551 $self->enter_map ($map, $x, $y);
2253} 2552}
2254 2553
2255=item $player_object->goto ($path, $x, $y[, $check->($map)]) 2554=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2256 2555
2257Moves the player to the given map-path and coordinates by first freezing 2556Moves the player to the given map-path and coordinates by first freezing
2258her, loading and preparing them map, calling the provided $check callback 2557her, loading and preparing them map, calling the provided $check callback
2259that has to return the map if sucecssful, and then unfreezes the player on 2558that has to return the map if sucecssful, and then unfreezes the player on
2260the new (success) or old (failed) map position. 2559the new (success) or old (failed) map position. In either case, $done will
2560be called at the end of this process.
2561
2562Note that $check will be called with a potentially non-loaded map, so if
2563it needs a loaded map it has to call C<< ->load >>.
2261 2564
2262=cut 2565=cut
2263 2566
2264our $GOTOGEN; 2567our $GOTOGEN;
2265 2568
2266sub cf::object::player::goto { 2569sub cf::object::player::goto {
2267 my ($self, $path, $x, $y, $check) = @_; 2570 my ($self, $path, $x, $y, $check, $done) = @_;
2268 2571
2269 # do generation counting so two concurrent goto's will be executed in-order 2572 # do generation counting so two concurrent goto's will be executed in-order
2270 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2573 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2271 2574
2272 $self->enter_link; 2575 $self->enter_link;
2273 2576
2274 (async { 2577 (async {
2578 $Coro::current->{desc} = "player::goto $path $x $y";
2579
2580 # *tag paths override both path and x|y
2581 if ($path =~ /^\*(.*)$/) {
2582 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2583 my $ob = $obs[rand @obs];
2584
2585 # see if we actually can go there
2586 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2587 $ob = $obs[rand @obs];
2588 } else {
2589 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2590 }
2591 # else put us there anyways for now #d#
2592
2593 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2594 } else {
2595 ($path, $x, $y) = (undef, undef, undef);
2596 }
2597 }
2598
2275 my $map = eval { 2599 my $map = eval {
2276 my $map = cf::map::find $path; 2600 my $map = defined $path ? cf::map::find $path : undef;
2277 2601
2278 if ($map) { 2602 if ($map) {
2279 $map = $map->customise_for ($self); 2603 $map = $map->customise_for ($self);
2280 $map = $check->($map) if $check && $map; 2604 $map = $check->($map) if $check && $map;
2281 } else { 2605 } else {
2282 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED); 2606 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2283 } 2607 }
2284 2608
2285 $map 2609 $map
2286 }; 2610 };
2287 2611
… …
2292 2616
2293 if ($gen == $self->{_goto_generation}) { 2617 if ($gen == $self->{_goto_generation}) {
2294 delete $self->{_goto_generation}; 2618 delete $self->{_goto_generation};
2295 $self->leave_link ($map, $x, $y); 2619 $self->leave_link ($map, $x, $y);
2296 } 2620 }
2621
2622 $done->() if $done;
2297 })->prio (1); 2623 })->prio (1);
2298} 2624}
2299 2625
2300=item $player_object->enter_exit ($exit_object) 2626=item $player_object->enter_exit ($exit_object)
2301 2627
… …
2321} 2647}
2322 2648
2323sub prepare_random_map { 2649sub prepare_random_map {
2324 my ($exit) = @_; 2650 my ($exit) = @_;
2325 2651
2326 my $guard = cf::lock_acquire "exit_prepare:$exit";
2327
2328 # all this does is basically replace the /! path by 2652 # all this does is basically replace the /! path by
2329 # a new random map path (?random/...) with a seed 2653 # a new random map path (?random/...) with a seed
2330 # that depends on the exit object 2654 # that depends on the exit object
2331 2655
2332 my $rmp = parse_random_map_params $exit->msg; 2656 my $rmp = parse_random_map_params $exit->msg;
… …
2334 if ($exit->map) { 2658 if ($exit->map) {
2335 $rmp->{region} = $exit->region->name; 2659 $rmp->{region} = $exit->region->name;
2336 $rmp->{origin_map} = $exit->map->path; 2660 $rmp->{origin_map} = $exit->map->path;
2337 $rmp->{origin_x} = $exit->x; 2661 $rmp->{origin_x} = $exit->x;
2338 $rmp->{origin_y} = $exit->y; 2662 $rmp->{origin_y} = $exit->y;
2663
2664 $exit->map->touch;
2339 } 2665 }
2340 2666
2341 $rmp->{random_seed} ||= $exit->random_seed; 2667 $rmp->{random_seed} ||= $exit->random_seed;
2342 2668
2343 my $data = cf::to_json $rmp; 2669 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2344 my $md5 = Digest::MD5::md5_hex $data; 2670 my $md5 = Digest::MD5::md5_hex $data;
2345 my $meta = "$RANDOMDIR/$md5.meta"; 2671 my $meta = "$RANDOMDIR/$md5.meta";
2346 2672
2347 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2673 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2348 aio_write $fh, 0, (length $data), $data, 0; 2674 aio_write $fh, 0, (length $data), $data, 0;
2349 undef $fh; 2675 undef $fh;
2350 aio_rename "$meta~", $meta; 2676 aio_rename "$meta~", $meta;
2351 2677
2678 my $slaying = "?random/$md5";
2679
2680 if ($exit->valid) {
2352 $exit->slaying ("?random/$md5"); 2681 $exit->slaying ("?random/$md5");
2353 $exit->msg (undef); 2682 $exit->msg (undef);
2683 }
2354 } 2684 }
2355} 2685}
2356 2686
2357sub cf::object::player::enter_exit { 2687sub cf::object::player::enter_exit {
2358 my ($self, $exit) = @_; 2688 my ($self, $exit) = @_;
2359 2689
2360 return unless $self->type == cf::PLAYER; 2690 return unless $self->type == cf::PLAYER;
2361 2691
2362 if ($exit->slaying eq "/!") {
2363 #TODO: this should de-fi-ni-te-ly not be a sync-job
2364 # the problem is that $exit might not survive long enough
2365 # so it needs to be done right now, right here
2366 cf::sync_job { prepare_random_map $exit };
2367 }
2368
2369 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2370 my $hp = $exit->stats->hp;
2371 my $sp = $exit->stats->sp;
2372
2373 $self->enter_link; 2692 $self->enter_link;
2374 2693
2375 # if exit is damned, update players death & WoR home-position
2376 $self->contr->savebed ($slaying, $hp, $sp)
2377 if $exit->flag (FLAG_DAMNED);
2378
2379 (async { 2694 (async {
2380 $self->deactivate_recursive; # just to be sure 2695 $Coro::current->{desc} = "enter_exit";
2696
2381 unless (eval { 2697 unless (eval {
2698 $self->deactivate_recursive; # just to be sure
2699
2700 # random map handling
2701 {
2702 my $guard = cf::lock_acquire "exit_prepare:$exit";
2703
2704 prepare_random_map $exit
2705 if $exit->slaying eq "/!";
2706 }
2707
2708 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2709 my $x = $exit->stats->hp;
2710 my $y = $exit->stats->sp;
2711
2382 $self->goto ($slaying, $hp, $sp); 2712 $self->goto ($map, $x, $y);
2383 2713
2714 # if exit is damned, update players death & WoR home-position
2715 $self->contr->savebed ($map, $x, $y)
2716 if $exit->flag (cf::FLAG_DAMNED);
2717
2384 1; 2718 1
2385 }) { 2719 }) {
2386 $self->message ("Something went wrong deep within the crossfire server. " 2720 $self->message ("Something went wrong deep within the deliantra server. "
2387 . "I'll try to bring you back to the map you were before. " 2721 . "I'll try to bring you back to the map you were before. "
2388 . "Please report this to the dungeon master!", 2722 . "Please report this to the dungeon master!",
2389 cf::NDI_UNIQUE | cf::NDI_RED); 2723 cf::NDI_UNIQUE | cf::NDI_RED);
2390 2724
2391 warn "ERROR in enter_exit: $@"; 2725 warn "ERROR in enter_exit: $@";
… …
2410 2744
2411 utf8::encode $text; 2745 utf8::encode $text;
2412 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2746 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2413} 2747}
2414 2748
2415=item $client->send_msg ($color, $type, $msg, [extra...]) 2749=item $client->send_msg ($channel, $msg, $color, [extra...])
2416 2750
2417Send a drawinfo or msg packet to the client, formatting the msg for the 2751Send a drawinfo or msg packet to the client, formatting the msg for the
2418client if neccessary. C<$type> should be a string identifying the type of 2752client if neccessary. C<$type> should be a string identifying the type of
2419the message, with C<log> being the default. If C<$color> is negative, suppress 2753the message, with C<log> being the default. If C<$color> is negative, suppress
2420the message unless the client supports the msg packet. 2754the message unless the client supports the msg packet.
2421 2755
2422=cut 2756=cut
2423 2757
2758# non-persistent channels (usually the info channel)
2759our %CHANNEL = (
2760 "c/identify" => {
2761 id => "infobox",
2762 title => "Identify",
2763 reply => undef,
2764 tooltip => "Items recently identified",
2765 },
2766 "c/examine" => {
2767 id => "infobox",
2768 title => "Examine",
2769 reply => undef,
2770 tooltip => "Signs and other items you examined",
2771 },
2772 "c/book" => {
2773 id => "infobox",
2774 title => "Book",
2775 reply => undef,
2776 tooltip => "The contents of a note or book",
2777 },
2778 "c/lookat" => {
2779 id => "infobox",
2780 title => "Look",
2781 reply => undef,
2782 tooltip => "What you saw there",
2783 },
2784 "c/who" => {
2785 id => "infobox",
2786 title => "Players",
2787 reply => undef,
2788 tooltip => "Shows players who are currently online",
2789 },
2790 "c/body" => {
2791 id => "infobox",
2792 title => "Body Parts",
2793 reply => undef,
2794 tooltip => "Shows which body parts you posess and are available",
2795 },
2796 "c/skills" => {
2797 id => "infobox",
2798 title => "Skills",
2799 reply => undef,
2800 tooltip => "Shows your experience per skill and item power",
2801 },
2802 "c/uptime" => {
2803 id => "infobox",
2804 title => "Uptime",
2805 reply => undef,
2806 tooltip => "How long the server has been running since last restart",
2807 },
2808 "c/mapinfo" => {
2809 id => "infobox",
2810 title => "Map Info",
2811 reply => undef,
2812 tooltip => "Information related to the maps",
2813 },
2814 "c/party" => {
2815 id => "party",
2816 title => "Party",
2817 reply => "gsay ",
2818 tooltip => "Messages and chat related to your party",
2819 },
2820);
2821
2424sub cf::client::send_msg { 2822sub cf::client::send_msg {
2425 my ($self, $color, $type, $msg, @extra) = @_; 2823 my ($self, $channel, $msg, $color, @extra) = @_;
2426 2824
2427 $msg = $self->pl->expand_cfpod ($msg); 2825 $msg = $self->pl->expand_cfpod ($msg)
2826 unless $color & cf::NDI_VERBATIM;
2827
2828 $color &= cf::NDI_CLIENT_MASK; # just in case...
2829
2830 # check predefined channels, for the benefit of C
2831 if ($CHANNEL{$channel}) {
2832 $channel = $CHANNEL{$channel};
2833
2834 $self->ext_msg (channel_info => $channel)
2835 if $self->can_msg;
2836
2837 $channel = $channel->{id};
2838
2839 } elsif (ref $channel) {
2840 # send meta info to client, if not yet sent
2841 unless (exists $self->{channel}{$channel->{id}}) {
2842 $self->{channel}{$channel->{id}} = $channel;
2843 $self->ext_msg (channel_info => $channel)
2844 if $self->can_msg;
2845 }
2846
2847 $channel = $channel->{id};
2848 }
2428 2849
2429 return unless @extra || length $msg; 2850 return unless @extra || length $msg;
2430 2851
2431 if ($self->can_msg) { 2852 if ($self->can_msg) {
2432 $self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $type, $msg, @extra])); 2853 # default colour, mask it out
2854 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2855 if $color & cf::NDI_DEF;
2856
2857 my $pkt = "msg "
2858 . $self->{json_coder}->encode (
2859 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2860 );
2861
2862 # try lzf for large packets
2863 $pkt = "lzf " . Compress::LZF::compress $pkt
2864 if 1024 <= length $pkt and $self->{can_lzf};
2865
2866 # split very large packets
2867 if (8192 < length $pkt and $self->{can_lzf}) {
2868 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2869 $pkt = "frag";
2870 }
2871
2872 $self->send_packet ($pkt);
2433 } else { 2873 } else {
2434 # replace some tags by gcfclient-compatible ones
2435 for ($msg) {
2436 1 while
2437 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2438 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2439 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2440 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2441 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2442 }
2443
2444 if ($color >= 0) { 2874 if ($color >= 0) {
2875 # replace some tags by gcfclient-compatible ones
2876 for ($msg) {
2877 1 while
2878 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2879 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2880 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2881 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2882 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2883 }
2884
2885 $color &= cf::NDI_COLOR_MASK;
2886
2887 utf8::encode $msg;
2888
2445 if (0 && $msg =~ /\[/) { 2889 if (0 && $msg =~ /\[/) {
2890 # COMMAND/INFO
2446 $self->send_packet ("drawextinfo $color 4 0 $msg") 2891 $self->send_packet ("drawextinfo $color 10 8 $msg")
2447 } else { 2892 } else {
2448 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g; 2893 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2449 $self->send_packet ("drawinfo $color $msg") 2894 $self->send_packet ("drawinfo $color $msg")
2450 } 2895 }
2451 } 2896 }
2452 } 2897 }
2453} 2898}
2454 2899
2455=item $client->ext_event ($type, %msg) 2900=item $client->ext_msg ($type, @msg)
2456 2901
2457Sends an ext event to the client. 2902Sends an ext event to the client.
2458 2903
2459=cut 2904=cut
2460 2905
2461sub cf::client::ext_event($$%) { 2906sub cf::client::ext_msg($$@) {
2462 my ($self, $type, %msg) = @_; 2907 my ($self, $type, @msg) = @_;
2463 2908
2909 if ($self->extcmd == 2) {
2910 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2911 } elsif ($self->extcmd == 1) { # TODO: remove
2464 $msg{msgtype} = "event_$type"; 2912 push @msg, msgtype => "event_$type";
2465 $self->send_packet ("ext " . $self->{json_coder}->encode (\%msg)); 2913 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2914 }
2915}
2916
2917=item $client->ext_reply ($msgid, @msg)
2918
2919Sends an ext reply to the client.
2920
2921=cut
2922
2923sub cf::client::ext_reply($$@) {
2924 my ($self, $id, @msg) = @_;
2925
2926 if ($self->extcmd == 2) {
2927 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2928 } elsif ($self->extcmd == 1) {
2929 #TODO: version 1, remove
2930 unshift @msg, msgtype => "reply", msgid => $id;
2931 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2932 }
2466} 2933}
2467 2934
2468=item $success = $client->query ($flags, "text", \&cb) 2935=item $success = $client->query ($flags, "text", \&cb)
2469 2936
2470Queues a query to the client, calling the given callback with 2937Queues a query to the client, calling the given callback with
… …
2525 my ($ns, $buf) = @_; 2992 my ($ns, $buf) = @_;
2526 2993
2527 my $msg = eval { $ns->{json_coder}->decode ($buf) }; 2994 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2528 2995
2529 if (ref $msg) { 2996 if (ref $msg) {
2997 my ($type, $reply, @payload) =
2998 "ARRAY" eq ref $msg
2999 ? @$msg
3000 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
3001
3002 my @reply;
3003
2530 if (my $cb = $EXTICMD{$msg->{msgtype}}) { 3004 if (my $cb = $EXTICMD{$type}) {
2531 if (my %reply = $cb->($ns, $msg)) { 3005 @reply = $cb->($ns, @payload);
2532 $reply{msgid} = $msg->{msgid};
2533 $ns->send ("ext " . $ns->{json_coder}->encode (\%reply));
2534 }
2535 } 3006 }
3007
3008 $ns->ext_reply ($reply, @reply)
3009 if $reply;
3010
2536 } else { 3011 } else {
2537 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 3012 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2538 } 3013 }
2539 3014
2540 cf::override; 3015 cf::override;
… …
2587our $safe = new Safe "safe"; 3062our $safe = new Safe "safe";
2588our $safe_hole = new Safe::Hole; 3063our $safe_hole = new Safe::Hole;
2589 3064
2590$SIG{FPE} = 'IGNORE'; 3065$SIG{FPE} = 'IGNORE';
2591 3066
2592$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 3067$safe->permit_only (Opcode::opset qw(
3068 :base_core :base_mem :base_orig :base_math
3069 grepstart grepwhile mapstart mapwhile
3070 sort time
3071));
2593 3072
2594# here we export the classes and methods available to script code 3073# here we export the classes and methods available to script code
2595 3074
2596=pod 3075=pod
2597 3076
2598The following functions and methods are available within a safe environment: 3077The following functions and methods are available within a safe environment:
2599 3078
2600 cf::object 3079 cf::object
2601 contr pay_amount pay_player map x y force_find force_add 3080 contr pay_amount pay_player map x y force_find force_add destroy
2602 insert remove 3081 insert remove name archname title slaying race decrease split
2603 3082
2604 cf::object::player 3083 cf::object::player
2605 player 3084 player
2606 3085
2607 cf::player 3086 cf::player
… …
2612 3091
2613=cut 3092=cut
2614 3093
2615for ( 3094for (
2616 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3095 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2617 insert remove)], 3096 insert remove inv nrof name archname title slaying race
3097 decrease split destroy change_exp)],
2618 ["cf::object::player" => qw(player)], 3098 ["cf::object::player" => qw(player)],
2619 ["cf::player" => qw(peaceful)], 3099 ["cf::player" => qw(peaceful)],
2620 ["cf::map" => qw(trigger)], 3100 ["cf::map" => qw(trigger)],
2621) { 3101) {
2622 no strict 'refs'; 3102 no strict 'refs';
… …
2698# the server's init and main functions 3178# the server's init and main functions
2699 3179
2700sub load_facedata($) { 3180sub load_facedata($) {
2701 my ($path) = @_; 3181 my ($path) = @_;
2702 3182
3183 # HACK to clear player env face cache, we need some signal framework
3184 # for this (global event?)
3185 %ext::player_env::MUSIC_FACE_CACHE = ();
3186
3187 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3188
2703 warn "loading facedata from $path\n"; 3189 warn "loading facedata from $path\n";
2704 3190
2705 my $facedata; 3191 my $facedata;
2706 0 < aio_load $path, $facedata 3192 0 < aio_load $path, $facedata
2707 or die "$path: $!"; 3193 or die "$path: $!";
… …
2709 $facedata = Coro::Storable::thaw $facedata; 3195 $facedata = Coro::Storable::thaw $facedata;
2710 3196
2711 $facedata->{version} == 2 3197 $facedata->{version} == 2
2712 or cf::cleanup "$path: version mismatch, cannot proceed."; 3198 or cf::cleanup "$path: version mismatch, cannot proceed.";
2713 3199
3200 # patch in the exptable
3201 $facedata->{resource}{"res/exp_table"} = {
3202 type => FT_RSRC,
3203 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
3204 };
3205 cf::cede_to_tick;
3206
2714 { 3207 {
2715 my $faces = $facedata->{faceinfo}; 3208 my $faces = $facedata->{faceinfo};
2716 3209
2717 while (my ($face, $info) = each %$faces) { 3210 while (my ($face, $info) = each %$faces) {
2718 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3211 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3212
2719 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 3213 cf::face::set_visibility $idx, $info->{visibility};
3214 cf::face::set_magicmap $idx, $info->{magicmap};
2720 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 3215 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2721 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 3216 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2722 Coro::cede; 3217
3218 cf::cede_to_tick;
2723 } 3219 }
2724 3220
2725 while (my ($face, $info) = each %$faces) { 3221 while (my ($face, $info) = each %$faces) {
2726 next unless $info->{smooth}; 3222 next unless $info->{smooth};
3223
2727 my $idx = cf::face::find $face 3224 my $idx = cf::face::find $face
2728 or next; 3225 or next;
3226
2729 if (my $smooth = cf::face::find $info->{smooth}) { 3227 if (my $smooth = cf::face::find $info->{smooth}) {
3228 cf::face::set_smooth $idx, $smooth;
2730 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel}; 3229 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2731 } else { 3230 } else {
2732 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3231 warn "smooth face '$info->{smooth}' not found for face '$face'";
2733 } 3232 }
2734 Coro::cede; 3233
3234 cf::cede_to_tick;
2735 } 3235 }
2736 } 3236 }
2737 3237
2738 { 3238 {
2739 my $anims = $facedata->{animinfo}; 3239 my $anims = $facedata->{animinfo};
2740 3240
2741 while (my ($anim, $info) = each %$anims) { 3241 while (my ($anim, $info) = each %$anims) {
2742 cf::anim::set $anim, $info->{frames}, $info->{facings}; 3242 cf::anim::set $anim, $info->{frames}, $info->{facings};
2743 Coro::cede; 3243 cf::cede_to_tick;
2744 } 3244 }
2745 3245
2746 cf::anim::invalidate_all; # d'oh 3246 cf::anim::invalidate_all; # d'oh
2747 } 3247 }
2748 3248
3249 {
3250 # TODO: for gcfclient pleasure, we should give resources
3251 # that gcfclient doesn't grok a >10000 face index.
3252 my $res = $facedata->{resource};
3253
3254 while (my ($name, $info) = each %$res) {
3255 if (defined $info->{type}) {
3256 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3257 my $data;
3258
3259 if ($info->{type} & 1) {
3260 # prepend meta info
3261
3262 my $meta = $enc->encode ({
3263 name => $name,
3264 %{ $info->{meta} || {} },
3265 });
3266
3267 $data = pack "(w/a*)*", $meta, $info->{data};
3268 } else {
3269 $data = $info->{data};
3270 }
3271
3272 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3273 cf::face::set_type $idx, $info->{type};
3274 } else {
3275 $RESOURCE{$name} = $info;
3276 }
3277
3278 cf::cede_to_tick;
3279 }
3280 }
3281
3282 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3283
2749 1 3284 1
2750} 3285}
2751 3286
3287cf::global->attach (on_resource_update => sub {
3288 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3289 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3290
3291 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3292 my $sound = $soundconf->{compat}[$_]
3293 or next;
3294
3295 my $face = cf::face::find "sound/$sound->[1]";
3296 cf::sound::set $sound->[0] => $face;
3297 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3298 }
3299
3300 while (my ($k, $v) = each %{$soundconf->{event}}) {
3301 my $face = cf::face::find "sound/$v";
3302 cf::sound::set $k => $face;
3303 }
3304 }
3305});
3306
3307register_exticmd fx_want => sub {
3308 my ($ns, $want) = @_;
3309
3310 while (my ($k, $v) = each %$want) {
3311 $ns->fx_want ($k, $v);
3312 }
3313};
3314
3315sub load_resource_file($) {
3316 my $guard = lock_acquire "load_resource_file";
3317
3318 my $status = load_resource_file_ $_[0];
3319 get_slot 0.1, 100;
3320 cf::arch::commit_load;
3321
3322 $status
3323}
3324
2752sub reload_regions { 3325sub reload_regions {
3326 # HACK to clear player env face cache, we need some signal framework
3327 # for this (global event?)
3328 %ext::player_env::MUSIC_FACE_CACHE = ();
3329
2753 load_resource_file "$MAPDIR/regions" 3330 load_resource_file "$MAPDIR/regions"
2754 or die "unable to load regions file\n"; 3331 or die "unable to load regions file\n";
3332
3333 for (cf::region::list) {
3334 $_->{match} = qr/$_->{match}/
3335 if exists $_->{match};
3336 }
2755} 3337}
2756 3338
2757sub reload_facedata { 3339sub reload_facedata {
2758 load_facedata "$DATADIR/facedata" 3340 load_facedata "$DATADIR/facedata"
2759 or die "unable to load facedata\n"; 3341 or die "unable to load facedata\n";
2760} 3342}
2761 3343
2762sub reload_archetypes { 3344sub reload_archetypes {
2763 load_resource_file "$DATADIR/archetypes" 3345 load_resource_file "$DATADIR/archetypes"
2764 or die "unable to load archetypes\n"; 3346 or die "unable to load archetypes\n";
2765 #d# NEED to laod twice to resolve forward references
2766 # this really needs to be done in an extra post-pass
2767 # (which needs to be synchronous, so solve it differently)
2768 load_resource_file "$DATADIR/archetypes"
2769 or die "unable to load archetypes\n";
2770} 3347}
2771 3348
2772sub reload_treasures { 3349sub reload_treasures {
2773 load_resource_file "$DATADIR/treasures" 3350 load_resource_file "$DATADIR/treasures"
2774 or die "unable to load treasurelists\n"; 3351 or die "unable to load treasurelists\n";
2775} 3352}
2776 3353
2777sub reload_resources { 3354sub reload_resources {
2778 warn "reloading resource files...\n"; 3355 warn "reloading resource files...\n";
2779 3356
3357 reload_facedata;
3358 reload_archetypes;
2780 reload_regions; 3359 reload_regions;
2781 reload_facedata;
2782 #reload_archetypes;#d#
2783 reload_archetypes;
2784 reload_treasures; 3360 reload_treasures;
2785 3361
2786 warn "finished reloading resource files\n"; 3362 warn "finished reloading resource files\n";
2787} 3363}
2788 3364
2789sub init { 3365sub reload_config {
2790 reload_resources;
2791}
2792
2793sub cfg_load {
2794 open my $fh, "<:utf8", "$CONFDIR/config" 3366 open my $fh, "<:utf8", "$CONFDIR/config"
2795 or return; 3367 or return;
2796 3368
2797 local $/; 3369 local $/;
2798 *CFG = YAML::Syck::Load <$fh>; 3370 *CFG = YAML::Load <$fh>;
2799 3371
2800 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3372 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
2801 3373
2802 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3374 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2803 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3375 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
… …
2809 }; 3381 };
2810 warn $@ if $@; 3382 warn $@ if $@;
2811 } 3383 }
2812} 3384}
2813 3385
3386sub pidfile() {
3387 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3388 or die "$PIDFILE: $!";
3389 flock $fh, &Fcntl::LOCK_EX
3390 or die "$PIDFILE: flock: $!";
3391 $fh
3392}
3393
3394# make sure only one server instance is running at any one time
3395sub atomic {
3396 my $fh = pidfile;
3397
3398 my $pid = <$fh>;
3399 kill 9, $pid if $pid > 0;
3400
3401 seek $fh, 0, 0;
3402 print $fh $$;
3403}
3404
2814sub main { 3405sub main {
3406 cf::init_globals; # initialise logging
3407
3408 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3409 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3410 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3411 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3412
3413 cf::init_experience;
3414 cf::init_anim;
3415 cf::init_attackmess;
3416 cf::init_dynamic;
3417 cf::init_block;
3418
3419 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3420
2815 # we must not ever block the main coroutine 3421 # we must not ever block the main coroutine
2816 local $Coro::idle = sub { 3422 local $Coro::idle = sub {
2817 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3423 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2818 (async { 3424 (async {
2819 Event::one_event; 3425 $Coro::current->{desc} = "IDLE BUG HANDLER";
3426 EV::loop EV::LOOP_ONESHOT;
2820 })->prio (Coro::PRIO_MAX); 3427 })->prio (Coro::PRIO_MAX);
2821 }; 3428 };
2822 3429
2823 cfg_load; 3430 evthread_start IO::AIO::poll_fileno;
3431
3432 cf::sync_job {
3433 reload_resources;
3434 reload_config;
2824 db_init; 3435 db_init;
3436
3437 cf::load_settings;
3438 cf::load_materials;
3439 cf::init_uuid;
3440 cf::init_signals;
3441 cf::init_commands;
3442 cf::init_skills;
3443
3444 cf::init_beforeplay;
3445
3446 atomic;
3447
2825 load_extensions; 3448 load_extensions;
2826 3449
2827 $TICK_WATCHER->start; 3450 utime time, time, $RUNTIMEFILE;
3451
3452 # no (long-running) fork's whatsoever before this point(!)
3453 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3454
3455 (pop @POST_INIT)->(0) while @POST_INIT;
3456 };
3457
2828 Event::loop; 3458 EV::loop;
2829} 3459}
2830 3460
2831############################################################################# 3461#############################################################################
2832# initialisation and cleanup 3462# initialisation and cleanup
2833 3463
2834# install some emergency cleanup handlers 3464# install some emergency cleanup handlers
2835BEGIN { 3465BEGIN {
3466 our %SIGWATCHER = ();
2836 for my $signal (qw(INT HUP TERM)) { 3467 for my $signal (qw(INT HUP TERM)) {
2837 Event->signal ( 3468 $SIGWATCHER{$signal} = EV::signal $signal, sub {
2838 reentrant => 0,
2839 data => WF_AUTOCANCEL,
2840 signal => $signal,
2841 prio => 0,
2842 cb => sub {
2843 cf::cleanup "SIG$signal"; 3469 cf::cleanup "SIG$signal";
2844 },
2845 ); 3470 };
2846 } 3471 }
2847} 3472}
2848 3473
2849sub write_runtime { 3474sub write_runtime_sync {
2850 my $runtime = "$LOCALDIR/runtime";
2851
2852 # first touch the runtime file to show we are still running: 3475 # first touch the runtime file to show we are still running:
2853 # the fsync below can take a very very long time. 3476 # the fsync below can take a very very long time.
2854 3477
2855 IO::AIO::aio_utime $runtime, undef, undef; 3478 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
2856 3479
2857 my $guard = cf::lock_acquire "write_runtime"; 3480 my $guard = cf::lock_acquire "write_runtime";
2858 3481
2859 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 3482 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644
2860 or return; 3483 or return;
2861 3484
2862 my $value = $cf::RUNTIME + 90 + 10; 3485 my $value = $cf::RUNTIME + 90 + 10;
2863 # 10 is the runtime save interval, for a monotonic clock 3486 # 10 is the runtime save interval, for a monotonic clock
2864 # 60 allows for the watchdog to kill the server. 3487 # 60 allows for the watchdog to kill the server.
… …
2874 aio_utime $fh, undef, undef; 3497 aio_utime $fh, undef, undef;
2875 3498
2876 close $fh 3499 close $fh
2877 or return; 3500 or return;
2878 3501
2879 aio_rename "$runtime~", $runtime 3502 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
2880 and return; 3503 and return;
2881 3504
2882 warn "runtime file written.\n"; 3505 warn "runtime file written.\n";
2883 3506
2884 1 3507 1
3508}
3509
3510our $uuid_lock;
3511our $uuid_skip;
3512
3513sub write_uuid_sync($) {
3514 $uuid_skip ||= $_[0];
3515
3516 return if $uuid_lock;
3517 local $uuid_lock = 1;
3518
3519 my $uuid = "$LOCALDIR/uuid";
3520
3521 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3522 or return;
3523
3524 my $value = uuid_seq uuid_cur;
3525
3526 unless ($value) {
3527 warn "cowardly refusing to write zero uuid value!\n";
3528 return;
3529 }
3530
3531 my $value = uuid_str $value + $uuid_skip;
3532 $uuid_skip = 0;
3533
3534 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3535 and return;
3536
3537 # always fsync - this file is important
3538 aio_fsync $fh
3539 and return;
3540
3541 close $fh
3542 or return;
3543
3544 aio_rename "$uuid~", $uuid
3545 and return;
3546
3547 warn "uuid file written ($value).\n";
3548
3549 1
3550
3551}
3552
3553sub write_uuid($$) {
3554 my ($skip, $sync) = @_;
3555
3556 $sync ? write_uuid_sync $skip
3557 : async { write_uuid_sync $skip };
2885} 3558}
2886 3559
2887sub emergency_save() { 3560sub emergency_save() {
2888 my $freeze_guard = cf::freeze_mainloop; 3561 my $freeze_guard = cf::freeze_mainloop;
2889 3562
… …
2895 # and maps saved/destroyed asynchronously. 3568 # and maps saved/destroyed asynchronously.
2896 warn "begin emergency player save\n"; 3569 warn "begin emergency player save\n";
2897 for my $login (keys %cf::PLAYER) { 3570 for my $login (keys %cf::PLAYER) {
2898 my $pl = $cf::PLAYER{$login} or next; 3571 my $pl = $cf::PLAYER{$login} or next;
2899 $pl->valid or next; 3572 $pl->valid or next;
3573 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
2900 $pl->save; 3574 $pl->save;
2901 } 3575 }
2902 warn "end emergency player save\n"; 3576 warn "end emergency player save\n";
2903 3577
2904 warn "begin emergency map save\n"; 3578 warn "begin emergency map save\n";
… …
2910 warn "end emergency map save\n"; 3584 warn "end emergency map save\n";
2911 3585
2912 warn "begin emergency database checkpoint\n"; 3586 warn "begin emergency database checkpoint\n";
2913 BDB::db_env_txn_checkpoint $DB_ENV; 3587 BDB::db_env_txn_checkpoint $DB_ENV;
2914 warn "end emergency database checkpoint\n"; 3588 warn "end emergency database checkpoint\n";
3589
3590 warn "begin write uuid\n";
3591 write_uuid_sync 1;
3592 warn "end write uuid\n";
2915 }; 3593 };
2916 3594
2917 warn "leave emergency perl save\n"; 3595 warn "leave emergency perl save\n";
2918} 3596}
2919 3597
2920sub post_cleanup { 3598sub post_cleanup {
2921 my ($make_core) = @_; 3599 my ($make_core) = @_;
2922 3600
2923 warn Carp::longmess "post_cleanup backtrace" 3601 warn Carp::longmess "post_cleanup backtrace"
2924 if $make_core; 3602 if $make_core;
3603
3604 my $fh = pidfile;
3605 unlink $PIDFILE if <$fh> == $$;
3606}
3607
3608# a safer delete_package, copied from Symbol
3609sub clear_package($) {
3610 my $pkg = shift;
3611
3612 # expand to full symbol table name if needed
3613 unless ($pkg =~ /^main::.*::$/) {
3614 $pkg = "main$pkg" if $pkg =~ /^::/;
3615 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3616 $pkg .= '::' unless $pkg =~ /::$/;
3617 }
3618
3619 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3620 my $stem_symtab = *{$stem}{HASH};
3621
3622 defined $stem_symtab and exists $stem_symtab->{$leaf}
3623 or return;
3624
3625 # clear all symbols
3626 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3627 for my $name (keys %$leaf_symtab) {
3628 _gv_clear *{"$pkg$name"};
3629# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3630 }
3631 warn "cleared package $pkg\n";#d#
2925} 3632}
2926 3633
2927sub do_reload_perl() { 3634sub do_reload_perl() {
2928 # can/must only be called in main 3635 # can/must only be called in main
2929 if ($Coro::current != $Coro::main) { 3636 if ($Coro::current != $Coro::main) {
2930 warn "can only reload from main coroutine"; 3637 warn "can only reload from main coroutine";
2931 return; 3638 return;
2932 } 3639 }
2933 3640
3641 return if $RELOAD++;
3642
3643 while ($RELOAD) {
2934 warn "reloading..."; 3644 warn "reloading...";
2935 3645
2936 warn "entering sync_job"; 3646 warn "entering sync_job";
2937 3647
2938 cf::sync_job { 3648 cf::sync_job {
2939 cf::write_runtime; # external watchdog should not bark 3649 cf::write_runtime_sync; # external watchdog should not bark
2940 cf::emergency_save; 3650 cf::emergency_save;
2941 cf::write_runtime; # external watchdog should not bark 3651 cf::write_runtime_sync; # external watchdog should not bark
2942 3652
2943 warn "syncing database to disk"; 3653 warn "syncing database to disk";
2944 BDB::db_env_txn_checkpoint $DB_ENV; 3654 BDB::db_env_txn_checkpoint $DB_ENV;
2945 3655
2946 # if anything goes wrong in here, we should simply crash as we already saved 3656 # if anything goes wrong in here, we should simply crash as we already saved
2947 3657
2948 warn "cancelling all WF_AUTOCANCEL watchers";
2949 for (Event::all_watchers) {
2950 $_->cancel if $_->data & WF_AUTOCANCEL;
2951 }
2952
2953 warn "flushing outstanding aio requests"; 3658 warn "flushing outstanding aio requests";
2954 for (;;) {
2955 BDB::flush;
2956 IO::AIO::flush;
2957 Coro::cede;
2958 last unless IO::AIO::nreqs || BDB::nreqs; 3659 while (IO::AIO::nreqs || BDB::nreqs) {
2959 warn "iterate..."; 3660 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
2960 }
2961
2962 ++$RELOAD;
2963
2964 warn "cancelling all extension coros";
2965 $_->cancel for values %EXT_CORO;
2966 %EXT_CORO = ();
2967
2968 warn "removing commands";
2969 %COMMAND = ();
2970
2971 warn "removing ext/exti commands";
2972 %EXTCMD = ();
2973 %EXTICMD = ();
2974
2975 warn "unloading/nuking all extensions";
2976 for my $pkg (@EXTS) {
2977 warn "... unloading $pkg";
2978
2979 if (my $cb = $pkg->can ("unload")) {
2980 eval {
2981 $cb->($pkg);
2982 1
2983 } or warn "$pkg unloaded, but with errors: $@";
2984 } 3661 }
2985 3662
2986 warn "... nuking $pkg"; 3663 warn "cancelling all extension coros";
2987 Symbol::delete_package $pkg; 3664 $_->cancel for values %EXT_CORO;
2988 } 3665 %EXT_CORO = ();
2989 3666
2990 warn "unloading all perl modules loaded from $LIBDIR"; 3667 warn "removing commands";
2991 while (my ($k, $v) = each %INC) { 3668 %COMMAND = ();
2992 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2993 3669
3670 warn "removing ext/exti commands";
3671 %EXTCMD = ();
3672 %EXTICMD = ();
3673
3674 warn "unloading/nuking all extensions";
3675 for my $pkg (@EXTS) {
2994 warn "... unloading $k"; 3676 warn "... unloading $pkg";
2995 delete $INC{$k};
2996 3677
2997 $k =~ s/\.pm$//;
2998 $k =~ s/\//::/g;
2999
3000 if (my $cb = $k->can ("unload_module")) { 3678 if (my $cb = $pkg->can ("unload")) {
3679 eval {
3001 $cb->(); 3680 $cb->($pkg);
3681 1
3682 } or warn "$pkg unloaded, but with errors: $@";
3683 }
3684
3685 warn "... clearing $pkg";
3686 clear_package $pkg;
3002 } 3687 }
3003 3688
3004 Symbol::delete_package $k; 3689 warn "unloading all perl modules loaded from $LIBDIR";
3690 while (my ($k, $v) = each %INC) {
3691 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3692
3693 warn "... unloading $k";
3694 delete $INC{$k};
3695
3696 $k =~ s/\.pm$//;
3697 $k =~ s/\//::/g;
3698
3699 if (my $cb = $k->can ("unload_module")) {
3700 $cb->();
3701 }
3702
3703 clear_package $k;
3005 } 3704 }
3006 3705
3007 warn "getting rid of safe::, as good as possible"; 3706 warn "getting rid of safe::, as good as possible";
3008 Symbol::delete_package "safe::$_" 3707 clear_package "safe::$_"
3009 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3708 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3010 3709
3011 warn "unloading cf.pm \"a bit\""; 3710 warn "unloading cf.pm \"a bit\"";
3012 delete $INC{"cf.pm"}; 3711 delete $INC{"cf.pm"};
3013 delete $INC{"cf/pod.pm"}; 3712 delete $INC{"cf/pod.pm"};
3014 3713
3015 # don't, removes xs symbols, too, 3714 # don't, removes xs symbols, too,
3016 # and global variables created in xs 3715 # and global variables created in xs
3017 #Symbol::delete_package __PACKAGE__; 3716 #clear_package __PACKAGE__;
3018 3717
3019 warn "unload completed, starting to reload now"; 3718 warn "unload completed, starting to reload now";
3020 3719
3021 warn "reloading cf.pm"; 3720 warn "reloading cf.pm";
3022 require cf; 3721 require cf;
3023 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3722 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3024 3723
3025 warn "loading config and database again"; 3724 warn "loading config and database again";
3026 cf::cfg_load; 3725 cf::reload_config;
3027 3726
3028 warn "loading extensions"; 3727 warn "loading extensions";
3029 cf::load_extensions; 3728 cf::load_extensions;
3030 3729
3031 warn "reattaching attachments to objects/players"; 3730 warn "reattaching attachments to objects/players";
3032 _global_reattach; # objects, sockets 3731 _global_reattach; # objects, sockets
3033 warn "reattaching attachments to maps"; 3732 warn "reattaching attachments to maps";
3034 reattach $_ for values %MAP; 3733 reattach $_ for values %MAP;
3035 warn "reattaching attachments to players"; 3734 warn "reattaching attachments to players";
3036 reattach $_ for values %PLAYER; 3735 reattach $_ for values %PLAYER;
3037 3736
3737 warn "running post_load";
3738 (pop @POST_INIT)->(1) while @POST_INIT;
3739
3038 warn "leaving sync_job"; 3740 warn "leaving sync_job";
3039 3741
3040 1 3742 1
3041 } or do { 3743 } or do {
3042 warn $@; 3744 warn $@;
3043 warn "error while reloading, exiting."; 3745 cf::cleanup "error while reloading, exiting.";
3044 exit 1;
3045 }; 3746 };
3046 3747
3047 warn "reloaded"; 3748 warn "reloaded";
3749 --$RELOAD;
3750 }
3048}; 3751};
3049 3752
3050our $RELOAD_WATCHER; # used only during reload 3753our $RELOAD_WATCHER; # used only during reload
3051 3754
3052sub reload_perl() { 3755sub reload_perl() {
3053 # doing reload synchronously and two reloads happen back-to-back, 3756 # doing reload synchronously and two reloads happen back-to-back,
3054 # coro crashes during coro_state_free->destroy here. 3757 # coro crashes during coro_state_free->destroy here.
3055 3758
3056 $RELOAD_WATCHER ||= Event->timer ( 3759 $RELOAD_WATCHER ||= EV::timer $TICK * 1.5, 0, sub {
3057 reentrant => 0,
3058 after => 0,
3059 data => WF_AUTOCANCEL,
3060 cb => sub {
3061 do_reload_perl; 3760 do_reload_perl;
3062 undef $RELOAD_WATCHER; 3761 undef $RELOAD_WATCHER;
3063 },
3064 ); 3762 };
3065} 3763}
3066 3764
3067register_command "reload" => sub { 3765register_command "reload" => sub {
3068 my ($who, $arg) = @_; 3766 my ($who, $arg) = @_;
3069 3767
3070 if ($who->flag (FLAG_WIZ)) { 3768 if ($who->flag (FLAG_WIZ)) {
3071 $who->message ("reloading server."); 3769 $who->message ("reloading server.");
3770 async {
3771 $Coro::current->{desc} = "perl_reload";
3072 async { reload_perl }; 3772 reload_perl;
3773 };
3073 } 3774 }
3074}; 3775};
3075 3776
3076unshift @INC, $LIBDIR; 3777unshift @INC, $LIBDIR;
3077 3778
… …
3079 3780
3080our @WAIT_FOR_TICK; 3781our @WAIT_FOR_TICK;
3081our @WAIT_FOR_TICK_BEGIN; 3782our @WAIT_FOR_TICK_BEGIN;
3082 3783
3083sub wait_for_tick { 3784sub wait_for_tick {
3084 return unless $TICK_WATCHER->is_active;
3085 return if $Coro::current == $Coro::main; 3785 return if tick_inhibit || $Coro::current == $Coro::main;
3086 3786
3087 my $signal = new Coro::Signal; 3787 my $signal = new Coro::Signal;
3088 push @WAIT_FOR_TICK, $signal; 3788 push @WAIT_FOR_TICK, $signal;
3089 $signal->wait; 3789 $signal->wait;
3090} 3790}
3091 3791
3092sub wait_for_tick_begin { 3792sub wait_for_tick_begin {
3093 return unless $TICK_WATCHER->is_active;
3094 return if $Coro::current == $Coro::main; 3793 return if tick_inhibit || $Coro::current == $Coro::main;
3095 3794
3096 my $signal = new Coro::Signal; 3795 my $signal = new Coro::Signal;
3097 push @WAIT_FOR_TICK_BEGIN, $signal; 3796 push @WAIT_FOR_TICK_BEGIN, $signal;
3098 $signal->wait; 3797 $signal->wait;
3099} 3798}
3100 3799
3101 my $min = 1e6;#d# 3800sub tick {
3102 my $avg = 10;
3103$TICK_WATCHER = Event->timer (
3104 reentrant => 0,
3105 parked => 1,
3106 prio => 0,
3107 at => $NEXT_TICK || $TICK,
3108 data => WF_AUTOCANCEL,
3109 cb => sub {
3110 if ($Coro::current != $Coro::main) { 3801 if ($Coro::current != $Coro::main) {
3111 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3802 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3112 unless ++$bug_warning > 10; 3803 unless ++$bug_warning > 10;
3113 return; 3804 return;
3114 } 3805 }
3115 3806
3116 $NOW = $tick_start = Event::time;
3117
3118 cf::server_tick; # one server iteration 3807 cf::server_tick; # one server iteration
3119 3808
3120 0 && sync_job {#d# 3809 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3121 for(1..10) { 3810 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3122 my $t = Event::time; 3811 Coro::async_pool {
3123 my $map = my $map = new_from_path cf::map "/tmp/x.map" 3812 $Coro::current->{desc} = "runtime saver";
3124 or die; 3813 write_runtime_sync
3125 3814 or warn "ERROR: unable to write runtime file: $!";
3126 $map->width (50);
3127 $map->height (50);
3128 $map->alloc;
3129 $map->_load_objects ("/tmp/x.map", 1);
3130 my $t = Event::time - $t;
3131
3132 #next unless $t < 0.0013;#d#
3133 if ($t < $min) {
3134 $min = $t;
3135 }
3136 $avg = $avg * 0.99 + $t * 0.01;
3137 }
3138 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3139 exit 0;
3140 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3141 }; 3815 };
3816 }
3142 3817
3143 $RUNTIME += $TICK;
3144 $NEXT_TICK += $TICK;
3145
3146 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3147 $NEXT_RUNTIME_WRITE = $NOW + 10;
3148 Coro::async_pool {
3149 write_runtime
3150 or warn "ERROR: unable to write runtime file: $!";
3151 };
3152 }
3153
3154# my $AFTER = Event::time;
3155# warn $AFTER - $NOW;#d#
3156
3157 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3818 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3158 $sig->send; 3819 $sig->send;
3159 } 3820 }
3160 while (my $sig = shift @WAIT_FOR_TICK) { 3821 while (my $sig = shift @WAIT_FOR_TICK) {
3161 $sig->send; 3822 $sig->send;
3162 } 3823 }
3163 3824
3164 $NOW = Event::time; 3825 $LOAD = ($NOW - $TICK_START) / $TICK;
3165
3166 # if we are delayed by four ticks or more, skip them all
3167 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3168
3169 $TICK_WATCHER->at ($NEXT_TICK);
3170 $TICK_WATCHER->start;
3171
3172 $LOAD = ($NOW - $tick_start) / $TICK;
3173 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3826 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3174 3827
3175 _post_tick; 3828 if (0) {
3176 3829 if ($NEXT_TICK) {
3177 3830 my $jitter = $TICK_START - $NEXT_TICK;
3831 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3832 warn "jitter $JITTER\n";#d#
3833 }
3178 }, 3834 }
3179); 3835}
3180 3836
3181{ 3837{
3182 BDB::max_poll_time $TICK * 0.1; 3838 # configure BDB
3183 $BDB_POLL_WATCHER = Event->io ( 3839
3184 reentrant => 0,
3185 fd => BDB::poll_fileno,
3186 poll => 'r',
3187 prio => 0,
3188 data => WF_AUTOCANCEL,
3189 cb => \&BDB::poll_cb,
3190 );
3191 BDB::min_parallel 8; 3840 BDB::min_parallel 8;
3192 3841 BDB::max_poll_reqs $TICK * 0.1;
3193 BDB::set_sync_prepare { 3842 $AnyEvent::BDB::WATCHER->priority (1);
3194 my $status;
3195 my $current = $Coro::current;
3196 (
3197 sub {
3198 $status = $!;
3199 $current->ready; undef $current;
3200 },
3201 sub {
3202 Coro::schedule while defined $current;
3203 $! = $status;
3204 },
3205 )
3206 };
3207 3843
3208 unless ($DB_ENV) { 3844 unless ($DB_ENV) {
3209 $DB_ENV = BDB::db_env_create; 3845 $DB_ENV = BDB::db_env_create;
3846 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3847 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
3848 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
3849 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3850 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3210 3851
3211 cf::sync_job { 3852 cf::sync_job {
3212 eval { 3853 eval {
3213 BDB::db_env_open 3854 BDB::db_env_open
3214 $DB_ENV, 3855 $DB_ENV,
… …
3216 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3857 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3217 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3858 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3218 0666; 3859 0666;
3219 3860
3220 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 3861 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3221
3222 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3223 $DB_ENV->set_lk_detect;
3224 }; 3862 };
3225 3863
3226 cf::cleanup "db_env_open(db): $@" if $@; 3864 cf::cleanup "db_env_open(db): $@" if $@;
3227 }; 3865 };
3228 } 3866 }
3867
3868 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3869 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3870 };
3871 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3872 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3873 };
3874 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3875 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3876 };
3229} 3877}
3230 3878
3231{ 3879{
3880 # configure IO::AIO
3881
3232 IO::AIO::min_parallel 8; 3882 IO::AIO::min_parallel 8;
3233
3234 undef $Coro::AIO::WATCHER;
3235 IO::AIO::max_poll_time $TICK * 0.1; 3883 IO::AIO::max_poll_time $TICK * 0.1;
3236 $AIO_POLL_WATCHER = Event->io ( 3884 undef $AnyEvent::AIO::WATCHER;
3237 reentrant => 0,
3238 data => WF_AUTOCANCEL,
3239 fd => IO::AIO::poll_fileno,
3240 poll => 'r',
3241 prio => 6,
3242 cb => \&IO::AIO::poll_cb,
3243 );
3244} 3885}
3245 3886
3246my $_log_backtrace; 3887my $_log_backtrace;
3247 3888
3248sub _log_backtrace { 3889sub _log_backtrace {
… …
3251 $msg =~ s/\n//; 3892 $msg =~ s/\n//;
3252 3893
3253 # limit the # of concurrent backtraces 3894 # limit the # of concurrent backtraces
3254 if ($_log_backtrace < 2) { 3895 if ($_log_backtrace < 2) {
3255 ++$_log_backtrace; 3896 ++$_log_backtrace;
3897 my $perl_bt = Carp::longmess $msg;
3256 async { 3898 async {
3899 $Coro::current->{desc} = "abt $msg";
3900
3257 my @bt = fork_call { 3901 my @bt = fork_call {
3258 @addr = map { sprintf "%x", $_ } @addr; 3902 @addr = map { sprintf "%x", $_ } @addr;
3259 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X; 3903 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3260 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |" 3904 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3261 or die "addr2line: $!"; 3905 or die "addr2line: $!";
… …
3269 } 3913 }
3270 3914
3271 @funcs 3915 @funcs
3272 }; 3916 };
3273 3917
3274 LOG llevInfo, "[ABT] $msg\n"; 3918 LOG llevInfo, "[ABT] $perl_bt\n";
3919 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
3275 LOG llevInfo, "[ABT] $_\n" for @bt; 3920 LOG llevInfo, "[ABT] $_\n" for @bt;
3276 --$_log_backtrace; 3921 --$_log_backtrace;
3277 }; 3922 };
3278 } else { 3923 } else {
3279 LOG llevInfo, "[ABT] $msg\n"; 3924 LOG llevInfo, "[ABT] $msg\n";

Diff Legend

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