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.314 by root, Mon Jul 23 16:53:15 2007 UTC vs.
Revision 1.474 by root, Thu Jul 16 21:42:56 2009 UTC

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

Diff Legend

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