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

Diff Legend

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