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.268 by root, Tue May 22 10:50:00 2007 UTC vs.
Revision 1.419 by root, Sun Apr 13 01:34:09 2008 UTC

1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3#
4# Copyright (©) 2006,2007,2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5#
6# Deliantra is free software: you can redistribute it and/or modify
7# it under the terms of the GNU General Public License as published by
8# the Free Software Foundation, either version 3 of the License, or
9# (at your option) any later version.
10#
11# This program is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14# GNU General Public License for more details.
15#
16# You should have received a copy of the GNU General Public License
17# along with this program. If not, see <http://www.gnu.org/licenses/>.
18#
19# The authors can be reached via e-mail to <support@deliantra.net>
20#
21
1package cf; 22package cf;
2 23
3use utf8; 24use utf8;
4use strict; 25use strict;
5 26
6use Symbol; 27use Symbol;
7use List::Util; 28use List::Util;
8use Socket; 29use Socket;
9use Storable; 30use EV 3.2;
10use Event;
11use Opcode; 31use Opcode;
12use Safe; 32use Safe;
13use Safe::Hole; 33use Safe::Hole;
34use Storable ();
14 35
15use Coro 3.61 (); 36use Coro 4.50 ();
16use Coro::State; 37use Coro::State;
17use Coro::Handle; 38use Coro::Handle;
18use Coro::Event; 39use Coro::EV;
19use Coro::Timer; 40use Coro::Timer;
20use Coro::Signal; 41use Coro::Signal;
21use Coro::Semaphore; 42use Coro::Semaphore;
22use Coro::AIO; 43use Coro::AIO;
44use Coro::BDB;
23use Coro::Storable; 45use Coro::Storable;
46use Coro::Util ();
24 47
48use JSON::XS 2.01 ();
25use BDB (); 49use BDB ();
26use Data::Dumper; 50use Data::Dumper;
27use Digest::MD5; 51use Digest::MD5;
28use Fcntl; 52use Fcntl;
29use YAML::Syck (); 53use YAML ();
30use IO::AIO 2.32 (); 54use IO::AIO 2.51 ();
31use Time::HiRes; 55use Time::HiRes;
32use Compress::LZF; 56use Compress::LZF;
57use Digest::MD5 ();
33 58
34# configure various modules to our taste 59# configure various modules to our taste
35# 60#
36$Storable::canonical = 1; # reduce rsync transfers 61$Storable::canonical = 1; # reduce rsync transfers
37Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 62Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
38Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 63Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
39 64
40$Event::Eval = 1; # no idea why this is required, but it is
41
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 65$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
46 66
47sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 67sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
48 68
49our %COMMAND = (); 69our %COMMAND = ();
50our %COMMAND_TIME = (); 70our %COMMAND_TIME = ();
51 71
52our @EXTS = (); # list of extension package names 72our @EXTS = (); # list of extension package names
53our %EXTCMD = (); 73our %EXTCMD = ();
74our %EXTICMD = ();
54our %EXT_CORO = (); # coroutines bound to extensions 75our %EXT_CORO = (); # coroutines bound to extensions
55our %EXT_MAP = (); # pluggable maps 76our %EXT_MAP = (); # pluggable maps
56 77
57our $RELOAD; # number of reloads so far 78our $RELOAD; # number of reloads so far
58our @EVENT; 79our @EVENT;
… …
66our $TMPDIR = "$LOCALDIR/" . tmpdir; 87our $TMPDIR = "$LOCALDIR/" . tmpdir;
67our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 88our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
68our $PLAYERDIR = "$LOCALDIR/" . playerdir; 89our $PLAYERDIR = "$LOCALDIR/" . playerdir;
69our $RANDOMDIR = "$LOCALDIR/random"; 90our $RANDOMDIR = "$LOCALDIR/random";
70our $BDBDIR = "$LOCALDIR/db"; 91our $BDBDIR = "$LOCALDIR/db";
92our %RESOURCE;
71 93
72our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 94our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
73our $TICK_WATCHER;
74our $AIO_POLL_WATCHER; 95our $AIO_POLL_WATCHER;
75our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 96our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
76our $NEXT_TICK; 97our $NEXT_TICK;
77our $NOW;
78our $USE_FSYNC = 1; # use fsync to write maps - default off 98our $USE_FSYNC = 1; # use fsync to write maps - default off
79 99
80our $BDB_POLL_WATCHER; 100our $BDB_POLL_WATCHER;
101our $BDB_DEADLOCK_WATCHER;
102our $BDB_CHECKPOINT_WATCHER;
103our $BDB_TRICKLE_WATCHER;
81our $DB_ENV; 104our $DB_ENV;
82 105
83our %CFG; 106our %CFG;
84 107
85our $UPTIME; $UPTIME ||= time; 108our $UPTIME; $UPTIME ||= time;
86our $RUNTIME; 109our $RUNTIME;
110our $NOW;
87 111
88our %PLAYER; # all users 112our (%PLAYER, %PLAYER_LOADING); # all users
89our %MAP; # all maps 113our (%MAP, %MAP_LOADING ); # all maps
90our $LINK_MAP; # the special {link} map, which is always available 114our $LINK_MAP; # the special {link} map, which is always available
91 115
92# used to convert map paths into valid unix filenames by replacing / by ∕ 116# used to convert map paths into valid unix filenames by replacing / by ∕
93our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 117our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
94 118
95our $LOAD; # a number between 0 (idle) and 1 (too many objects) 119our $LOAD; # a number between 0 (idle) and 1 (too many objects)
96our $LOADAVG; # same thing, but with alpha-smoothing 120our $LOADAVG; # same thing, but with alpha-smoothing
121our $JITTER; # average jitter
97our $tick_start; # for load detecting purposes 122our $TICK_START; # for load detecting purposes
98 123
99binmode STDOUT; 124binmode STDOUT;
100binmode STDERR; 125binmode STDERR;
101 126
102# read virtual server time, if available 127# read virtual server time, if available
… …
155 180
156The raw value load value from the last tick. 181The raw value load value from the last tick.
157 182
158=item %cf::CFG 183=item %cf::CFG
159 184
160Configuration for the server, loaded from C</etc/crossfire/config>, or 185Configuration for the server, loaded from C</etc/deliantra-server/config>, or
161from wherever your confdir points to. 186from wherever your confdir points to.
162 187
163=item cf::wait_for_tick, cf::wait_for_tick_begin 188=item cf::wait_for_tick, cf::wait_for_tick_begin
164 189
165These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 190These 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 191returns 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. 192per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
168 193
194=item @cf::INVOKE_RESULTS
195
196This array contains the results of the last C<invoke ()> call. When
197C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
198that call.
199
169=back 200=back
170 201
171=cut 202=cut
172 203
173BEGIN { 204BEGIN {
… …
177 $msg .= "\n" 208 $msg .= "\n"
178 unless $msg =~ /\n$/; 209 unless $msg =~ /\n$/;
179 210
180 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 211 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
181 212
182 utf8::encode $msg;
183 LOG llevError, $msg; 213 LOG llevError, $msg;
184 }; 214 };
185} 215}
216
217$Coro::State::DIEHOOK = sub {
218 return unless $^S eq 0; # "eq", not "=="
219
220 if ($Coro::current == $Coro::main) {#d#
221 warn "DIEHOOK called in main context, Coro bug?\n";#d#
222 return;#d#
223 }#d#
224
225 # kill coroutine otherwise
226 warn Carp::longmess $_[0];
227 Coro::terminate
228};
229
230$SIG{__DIE__} = sub { }; #d#?
186 231
187@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 232@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
188@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 233@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
189@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 234@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
190@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 235@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
191@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable'; 236@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
237@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
192@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 238@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
193 239
194# we bless all objects into (empty) derived classes to force a method lookup 240# we bless all objects into (empty) derived classes to force a method lookup
195# within the Safe compartment. 241# within the Safe compartment.
196for my $pkg (qw( 242for my $pkg (qw(
197 cf::global cf::attachable 243 cf::global cf::attachable
… …
202)) { 248)) {
203 no strict 'refs'; 249 no strict 'refs';
204 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 250 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
205} 251}
206 252
207$Event::DIED = sub { 253$EV::DIED = sub {
208 warn "error in event callback: @_"; 254 warn "error in event callback: @_";
209}; 255};
256
257#############################################################################
210 258
211=head2 UTILITY FUNCTIONS 259=head2 UTILITY FUNCTIONS
212 260
213=over 4 261=over 4
214 262
… …
233 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 281 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
234 $d 282 $d
235 } || "[unable to dump $_[0]: '$@']"; 283 } || "[unable to dump $_[0]: '$@']";
236} 284}
237 285
238use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working
239
240=item $ref = cf::from_json $json 286=item $ref = cf::decode_json $json
241 287
242Converts a JSON string into the corresponding perl data structure. 288Converts a JSON string into the corresponding perl data structure.
243 289
244=item $json = cf::to_json $ref 290=item $json = cf::encode_json $ref
245 291
246Converts a perl data structure into its JSON representation. 292Converts a perl data structure into its JSON representation.
293
294=cut
295
296our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
297
298sub encode_json($) { $json_coder->encode ($_[0]) }
299sub decode_json($) { $json_coder->decode ($_[0]) }
247 300
248=item cf::lock_wait $string 301=item cf::lock_wait $string
249 302
250Wait until the given lock is available. See cf::lock_acquire. 303Wait until the given lock is available. See cf::lock_acquire.
251 304
… …
254Wait until the given lock is available and then acquires it and returns 307Wait until the given lock is available and then acquires it and returns
255a Coro::guard object. If the guard object gets destroyed (goes out of scope, 308a Coro::guard object. If the guard object gets destroyed (goes out of scope,
256for example when the coroutine gets canceled), the lock is automatically 309for example when the coroutine gets canceled), the lock is automatically
257returned. 310returned.
258 311
312Locks are *not* recursive, locking from the same coro twice results in a
313deadlocked coro.
314
259Lock names should begin with a unique identifier (for example, cf::map::find 315Lock names should begin with a unique identifier (for example, cf::map::find
260uses map_find and cf::map::load uses map_load). 316uses map_find and cf::map::load uses map_load).
261 317
262=item $locked = cf::lock_active $string 318=item $locked = cf::lock_active $string
263 319
264Return true if the lock is currently active, i.e. somebody has locked it. 320Return true if the lock is currently active, i.e. somebody has locked it.
265 321
266=cut 322=cut
267 323
268our %LOCK; 324our %LOCK;
325our %LOCKER;#d#
269 326
270sub lock_wait($) { 327sub lock_wait($) {
271 my ($key) = @_; 328 my ($key) = @_;
329
330 if ($LOCKER{$key} == $Coro::current) {#d#
331 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
332 return;#d#
333 }#d#
272 334
273 # wait for lock, if any 335 # wait for lock, if any
274 while ($LOCK{$key}) { 336 while ($LOCK{$key}) {
275 push @{ $LOCK{$key} }, $Coro::current; 337 push @{ $LOCK{$key} }, $Coro::current;
276 Coro::schedule; 338 Coro::schedule;
… …
282 344
283 # wait, to be sure we are not locked 345 # wait, to be sure we are not locked
284 lock_wait $key; 346 lock_wait $key;
285 347
286 $LOCK{$key} = []; 348 $LOCK{$key} = [];
349 $LOCKER{$key} = $Coro::current;#d#
287 350
288 Coro::guard { 351 Coro::guard {
352 delete $LOCKER{$key};#d#
289 # wake up all waiters, to be on the safe side 353 # wake up all waiters, to be on the safe side
290 $_->ready for @{ delete $LOCK{$key} }; 354 $_->ready for @{ delete $LOCK{$key} };
291 } 355 }
292} 356}
293 357
… …
296 360
297 ! ! $LOCK{$key} 361 ! ! $LOCK{$key}
298} 362}
299 363
300sub freeze_mainloop { 364sub freeze_mainloop {
301 return unless $TICK_WATCHER->is_active; 365 tick_inhibit_inc;
302 366
303 my $guard = Coro::guard { 367 Coro::guard \&tick_inhibit_dec;
304 $TICK_WATCHER->start; 368}
369
370=item cf::periodic $interval, $cb
371
372Like EV::periodic, but randomly selects a starting point so that the actions
373get spread over timer.
374
375=cut
376
377sub periodic($$) {
378 my ($interval, $cb) = @_;
379
380 my $start = rand List::Util::min 180, $interval;
381
382 EV::periodic $start, $interval, 0, $cb
383}
384
385=item cf::get_slot $time[, $priority[, $name]]
386
387Allocate $time seconds of blocking CPU time at priority C<$priority>:
388This call blocks and returns only when you have at least C<$time> seconds
389of cpu time till the next tick. The slot is only valid till the next cede.
390
391The optional C<$name> can be used to identify the job to run. It might be
392used for statistical purposes and should identify the same time-class.
393
394Useful for short background jobs.
395
396=cut
397
398our @SLOT_QUEUE;
399our $SLOT_QUEUE;
400
401$SLOT_QUEUE->cancel if $SLOT_QUEUE;
402$SLOT_QUEUE = Coro::async {
403 $Coro::current->desc ("timeslot manager");
404
405 my $signal = new Coro::Signal;
406
407 while () {
408 next_job:
409 my $avail = cf::till_tick;
410 if ($avail > 0.01) {
411 for (0 .. $#SLOT_QUEUE) {
412 if ($SLOT_QUEUE[$_][0] < $avail) {
413 my $job = splice @SLOT_QUEUE, $_, 1, ();
414 $job->[2]->send;
415 Coro::cede;
416 goto next_job;
417 }
418 }
419 }
420
421 if (@SLOT_QUEUE) {
422 # we do not use wait_for_tick() as it returns immediately when tick is inactive
423 push @cf::WAIT_FOR_TICK, $signal;
424 $signal->wait;
425 } else {
426 Coro::schedule;
427 }
305 }; 428 }
306 $TICK_WATCHER->stop; 429};
307 $guard 430
431sub get_slot($;$$) {
432 my ($time, $pri, $name) = @_;
433
434 $time = $TICK * .6 if $time > $TICK * .6;
435 my $sig = new Coro::Signal;
436
437 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
438 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
439 $SLOT_QUEUE->ready;
440 $sig->wait;
308} 441}
309 442
310=item cf::async { BLOCK } 443=item cf::async { BLOCK }
311 444
312Currently the same as Coro::async_pool, meaning you cannot use 445Currently the same as Coro::async_pool, meaning you cannot use
… …
317 450
318BEGIN { *async = \&Coro::async_pool } 451BEGIN { *async = \&Coro::async_pool }
319 452
320=item cf::sync_job { BLOCK } 453=item cf::sync_job { BLOCK }
321 454
322The design of crossfire+ requires that the main coro ($Coro::main) is 455The design of Deliantra requires that the main coroutine ($Coro::main)
323always able to handle events or runnable, as crossfire+ is only partly 456is always able to handle events or runnable, as Deliantra is only
324reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable. 457partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
458acceptable.
325 459
326If it must be done, put the blocking parts into C<sync_job>. This will run 460If it must be done, put the blocking parts into C<sync_job>. This will run
327the given BLOCK in another coroutine while waiting for the result. The 461the given BLOCK in another coroutine while waiting for the result. The
328server will be frozen during this time, so the block should either finish 462server will be frozen during this time, so the block should either finish
329fast or be very important. 463fast or be very important.
… …
332 466
333sub sync_job(&) { 467sub sync_job(&) {
334 my ($job) = @_; 468 my ($job) = @_;
335 469
336 if ($Coro::current == $Coro::main) { 470 if ($Coro::current == $Coro::main) {
337 my $time = Event::time; 471 my $time = EV::time;
338 472
339 # this is the main coro, too bad, we have to block 473 # this is the main coro, too bad, we have to block
340 # till the operation succeeds, freezing the server :/ 474 # till the operation succeeds, freezing the server :/
341 475
342 # TODO: use suspend/resume instead 476 LOG llevError, Carp::longmess "sync job";#d#
343 # (but this is cancel-safe) 477
344 my $freeze_guard = freeze_mainloop; 478 my $freeze_guard = freeze_mainloop;
345 479
346 my $busy = 1; 480 my $busy = 1;
347 my @res; 481 my @res;
348 482
349 (async { 483 (async {
484 $Coro::current->desc ("sync job coro");
350 @res = eval { $job->() }; 485 @res = eval { $job->() };
351 warn $@ if $@; 486 warn $@ if $@;
352 undef $busy; 487 undef $busy;
353 })->prio (Coro::PRIO_MAX); 488 })->prio (Coro::PRIO_MAX);
354 489
355 while ($busy) { 490 while ($busy) {
356 Coro::cede or Event::one_event; 491 if (Coro::nready) {
492 Coro::cede_notself;
493 } else {
494 EV::loop EV::LOOP_ONESHOT;
357 } 495 }
496 }
358 497
359 $time = Event::time - $time; 498 my $time = EV::time - $time;
360 499
361 LOG llevError | logBacktrace, Carp::longmess "long sync job"
362 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
363
364 $tick_start += $time; # do not account sync jobs to server load 500 $TICK_START += $time; # do not account sync jobs to server load
365 501
366 wantarray ? @res : $res[0] 502 wantarray ? @res : $res[0]
367 } else { 503 } else {
368 # we are in another coroutine, how wonderful, everything just works 504 # we are in another coroutine, how wonderful, everything just works
369 505
… …
389 $EXT_CORO{$coro+0} = $coro; 525 $EXT_CORO{$coro+0} = $coro;
390 526
391 $coro 527 $coro
392} 528}
393 529
394sub write_runtime { 530=item fork_call { }, $args
395 my $runtime = "$LOCALDIR/runtime";
396 531
397 # first touch the runtime file to show we are still running: 532Executes the given code block with the given arguments in a seperate
398 # the fsync below can take a very very long time. 533process, returning the results. Everything must be serialisable with
534Coro::Storable. May, of course, block. Note that the executed sub may
535never block itself or use any form of event handling.
399 536
400 if (my $fh = aio_open $runtime, O_WRONLY, 0) { 537=cut
401 utime undef, undef, $fh; 538
539sub fork_call(&@) {
540 my ($cb, @args) = @_;
541
542 # we seemingly have to make a local copy of the whole thing,
543 # otherwise perl prematurely frees the stuff :/
544 # TODO: investigate and fix (likely this will be rather laborious)
545
546 my @res = Coro::Util::fork_eval {
547 reset_signals;
548 &$cb
549 }, @args;
550
551 wantarray ? @res : $res[-1]
552}
553
554=item $coin = coin_from_name $name
555
556=cut
557
558our %coin_alias = (
559 "silver" => "silvercoin",
560 "silvercoin" => "silvercoin",
561 "silvercoins" => "silvercoin",
562 "gold" => "goldcoin",
563 "goldcoin" => "goldcoin",
564 "goldcoins" => "goldcoin",
565 "platinum" => "platinacoin",
566 "platinumcoin" => "platinacoin",
567 "platinumcoins" => "platinacoin",
568 "platina" => "platinacoin",
569 "platinacoin" => "platinacoin",
570 "platinacoins" => "platinacoin",
571 "royalty" => "royalty",
572 "royalties" => "royalty",
573);
574
575sub coin_from_name($) {
576 $coin_alias{$_[0]}
577 ? cf::arch::find $coin_alias{$_[0]}
578 : undef
579}
580
581=item $value = cf::db_get $family => $key
582
583Returns a single value from the environment database.
584
585=item cf::db_put $family => $key => $value
586
587Stores the given C<$value> in the family. It can currently store binary
588data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
589
590=item $db = cf::db_table "name"
591
592Create and/or open a new database table. The string must not be "db" and must be unique
593within each server.
594
595=cut
596
597sub db_table($) {
598 my ($name) = @_;
599 my $db = BDB::db_create $DB_ENV;
600
601 eval {
602 $db->set_flags (BDB::CHKSUM);
603
604 utf8::encode $name;
605 BDB::db_open $db, undef, $name, undef, BDB::BTREE,
606 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
607 cf::cleanup "db_open(db): $!" if $!;
402 } 608 };
609 cf::cleanup "db_open(db): $@" if $@;
403 610
404 my $guard = cf::lock_acquire "write_runtime"; 611 $db
612}
405 613
406 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 614our $DB;
407 or return;
408 615
409 my $value = $cf::RUNTIME + 90 + 10; 616sub db_init {
410 # 10 is the runtime save interval, for a monotonic clock 617 cf::sync_job {
411 # 60 allows for the watchdog to kill the server. 618 $DB ||= db_table "db";
619 };
620}
412 621
413 (aio_write $fh, 0, (length $value), $value, 0) <= 0 622sub db_get($$) {
414 and return; 623 my $key = "$_[0]/$_[1]";
415 624
416 # always fsync - this file is important 625 cf::sync_job {
417 aio_fsync $fh 626 BDB::db_get $DB, undef, $key, my $data;
418 and return;
419 627
420 # touch it again to show we are up-to-date 628 $! ? ()
421 utime undef, undef, $fh; 629 : $data
422
423 close $fh
424 or return;
425
426 aio_rename "$runtime~", $runtime
427 and return;
428
429 warn "runtime file written.\n";#d#
430
431 1 630 }
631}
632
633sub db_put($$$) {
634 BDB::dbreq_pri 4;
635 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
636}
637
638=item cf::cache $id => [$paths...], $processversion => $process
639
640Generic caching function that returns the value of the resource $id,
641caching and regenerating as required.
642
643This function can block.
644
645=cut
646
647sub cache {
648 my ($id, $src, $processversion, $process) = @_;
649
650 my $meta =
651 join "\x00",
652 $processversion,
653 map {
654 aio_stat $_
655 and Carp::croak "$_: $!";
656
657 ($_, (stat _)[7,9])
658 } @$src;
659
660 my $dbmeta = db_get cache => "$id/meta";
661 if ($dbmeta ne $meta) {
662 # changed, we may need to process
663
664 my @data;
665 my $md5;
666
667 for (0 .. $#$src) {
668 0 <= aio_load $src->[$_], $data[$_]
669 or Carp::croak "$src->[$_]: $!";
670 }
671
672 # if processing is expensive, check
673 # checksum first
674 if (1) {
675 $md5 =
676 join "\x00",
677 $processversion,
678 map {
679 cf::cede_to_tick;
680 ($src->[$_], Digest::MD5::md5_hex $data[$_])
681 } 0.. $#$src;
682
683
684 my $dbmd5 = db_get cache => "$id/md5";
685 if ($dbmd5 eq $md5) {
686 db_put cache => "$id/meta", $meta;
687
688 return db_get cache => "$id/data";
689 }
690 }
691
692 my $t1 = Time::HiRes::time;
693 my $data = $process->(\@data);
694 my $t2 = Time::HiRes::time;
695
696 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
697
698 db_put cache => "$id/data", $data;
699 db_put cache => "$id/md5" , $md5;
700 db_put cache => "$id/meta", $meta;
701
702 return $data;
703 }
704
705 db_get cache => "$id/data"
432} 706}
433 707
434=item cf::datalog type => key => value, ... 708=item cf::datalog type => key => value, ...
435 709
436Log a datalog packet of the given type with the given key-value pairs. 710Log a datalog packet of the given type with the given key-value pairs.
… …
454attach callbacks/event handlers (a collection of which is called an "attachment") 728attach callbacks/event handlers (a collection of which is called an "attachment")
455to it. All such attachable objects support the following methods. 729to it. All such attachable objects support the following methods.
456 730
457In the following description, CLASS can be any of C<global>, C<object> 731In the following description, CLASS can be any of C<global>, C<object>
458C<player>, C<client> or C<map> (i.e. the attachable objects in 732C<player>, C<client> or C<map> (i.e. the attachable objects in
459crossfire+). 733Deliantra).
460 734
461=over 4 735=over 4
462 736
463=item $attachable->attach ($attachment, key => $value...) 737=item $attachable->attach ($attachment, key => $value...)
464 738
… …
666 _attach $registry, $klass, @attach; 940 _attach $registry, $klass, @attach;
667 } 941 }
668 942
669 $obj->{$name} = \%arg; 943 $obj->{$name} = \%arg;
670 } else { 944 } else {
671 warn "object uses attachment '$name' that is not available, postponing.\n"; 945 warn "object uses attachment '$name' which is not available, postponing.\n";
672 } 946 }
673 947
674 $obj->{_attachment}{$name} = undef; 948 $obj->{_attachment}{$name} = undef;
675} 949}
676 950
… …
716 "; 990 ";
717 die if $@; 991 die if $@;
718} 992}
719 993
720our $override; 994our $override;
721our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 995our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
722 996
723sub override { 997sub override {
724 $override = 1; 998 $override = 1;
725 @invoke_results = (); 999 @INVOKE_RESULTS = (@_);
726} 1000}
727 1001
728sub do_invoke { 1002sub do_invoke {
729 my $event = shift; 1003 my $event = shift;
730 my $callbacks = shift; 1004 my $callbacks = shift;
731 1005
732 @invoke_results = (); 1006 @INVOKE_RESULTS = ();
733 1007
734 local $override; 1008 local $override;
735 1009
736 for (@$callbacks) { 1010 for (@$callbacks) {
737 eval { &{$_->[1]} }; 1011 eval { &{$_->[1]} };
… …
746 } 1020 }
747 1021
748 0 1022 0
749} 1023}
750 1024
751=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 1025=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
752 1026
753=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 1027=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
754 1028
755Generate an object-specific event with the given arguments. 1029Generate an object-specific event with the given arguments.
756 1030
757This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be 1031This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
758removed in future versions), and there is no public API to access override 1032removed in future versions), and there is no public API to access override
759results (if you must, access C<@cf::invoke_results> directly). 1033results (if you must, access C<@cf::INVOKE_RESULTS> directly).
760 1034
761=back 1035=back
762 1036
763=cut 1037=cut
764 1038
765############################################################################# 1039#############################################################################
766# object support 1040# object support
1041
1042sub _object_equal($$);
1043sub _object_equal($$) {
1044 my ($a, $b) = @_;
1045
1046 return 0 unless (ref $a) eq (ref $b);
1047
1048 if ("HASH" eq ref $a) {
1049 my @ka = keys %$a;
1050 my @kb = keys %$b;
1051
1052 return 0 if @ka != @kb;
1053
1054 for (0 .. $#ka) {
1055 return 0 unless $ka[$_] eq $kb[$_];
1056 return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
1057 }
1058
1059 } elsif ("ARRAY" eq ref $a) {
1060
1061 return 0 if @$a != @$b;
1062
1063 for (0 .. $#$a) {
1064 return 0 unless _object_equal $a->[$_], $b->[$_];
1065 }
1066
1067 } elsif ($a ne $b) {
1068 return 0;
1069 }
1070
1071 1
1072}
1073
1074our $SLOW_MERGES;#d#
1075sub _can_merge {
1076 my ($ob1, $ob2) = @_;
1077
1078 ++$SLOW_MERGES;#d#
1079
1080 # we do the slow way here
1081 return _object_equal $ob1, $ob2
1082}
767 1083
768sub reattach { 1084sub reattach {
769 # basically do the same as instantiate, without calling instantiate 1085 # basically do the same as instantiate, without calling instantiate
770 my ($obj) = @_; 1086 my ($obj) = @_;
771 1087
… …
792cf::attachable->attach ( 1108cf::attachable->attach (
793 prio => -1000000, 1109 prio => -1000000,
794 on_instantiate => sub { 1110 on_instantiate => sub {
795 my ($obj, $data) = @_; 1111 my ($obj, $data) = @_;
796 1112
797 $data = from_json $data; 1113 $data = decode_json $data;
798 1114
799 for (@$data) { 1115 for (@$data) {
800 my ($name, $args) = @$_; 1116 my ($name, $args) = @$_;
801 1117
802 $obj->attach ($name, %{$args || {} }); 1118 $obj->attach ($name, %{$args || {} });
… …
818sub object_freezer_save { 1134sub object_freezer_save {
819 my ($filename, $rdata, $objs) = @_; 1135 my ($filename, $rdata, $objs) = @_;
820 1136
821 sync_job { 1137 sync_job {
822 if (length $$rdata) { 1138 if (length $$rdata) {
1139 utf8::decode (my $decname = $filename);
823 warn sprintf "saving %s (%d,%d)\n", 1140 warn sprintf "saving %s (%d,%d)\n",
824 $filename, length $$rdata, scalar @$objs; 1141 $decname, length $$rdata, scalar @$objs;
825 1142
826 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1143 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
827 chmod SAVE_MODE, $fh; 1144 chmod SAVE_MODE, $fh;
828 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1145 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
829 aio_fsync $fh if $cf::USE_FSYNC; 1146 aio_fsync $fh if $cf::USE_FSYNC;
830 close $fh; 1147 close $fh;
831 1148
832 if (@$objs) { 1149 if (@$objs) {
833 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1150 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
834 chmod SAVE_MODE, $fh; 1151 chmod SAVE_MODE, $fh;
835 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1152 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
836 aio_write $fh, 0, (length $data), $data, 0; 1153 aio_write $fh, 0, (length $data), $data, 0;
837 aio_fsync $fh if $cf::USE_FSYNC; 1154 aio_fsync $fh if $cf::USE_FSYNC;
838 close $fh; 1155 close $fh;
839 aio_rename "$filename.pst~", "$filename.pst"; 1156 aio_rename "$filename.pst~", "$filename.pst";
840 } 1157 }
… …
848 } 1165 }
849 } else { 1166 } else {
850 aio_unlink $filename; 1167 aio_unlink $filename;
851 aio_unlink "$filename.pst"; 1168 aio_unlink "$filename.pst";
852 } 1169 }
853 } 1170 };
854} 1171}
855 1172
856sub object_freezer_as_string { 1173sub object_freezer_as_string {
857 my ($rdata, $objs) = @_; 1174 my ($rdata, $objs) = @_;
858 1175
… …
870 or return; 1187 or return;
871 1188
872 unless (aio_stat "$filename.pst") { 1189 unless (aio_stat "$filename.pst") {
873 (aio_load "$filename.pst", $av) >= 0 1190 (aio_load "$filename.pst", $av) >= 0
874 or return; 1191 or return;
1192
875 $av = eval { (Storable::thaw $av)->{objs} }; 1193 my $st = eval { Coro::Storable::thaw $av };
1194 $av = $st->{objs};
876 } 1195 }
877 1196
1197 utf8::decode (my $decname = $filename);
878 warn sprintf "loading %s (%d)\n", 1198 warn sprintf "loading %s (%d,%d)\n",
879 $filename, length $data, scalar @{$av || []};#d# 1199 $decname, length $data, scalar @{$av || []};
1200
880 return ($data, $av); 1201 ($data, $av)
881} 1202}
1203
1204=head2 COMMAND CALLBACKS
1205
1206=over 4
1207
1208=cut
882 1209
883############################################################################# 1210#############################################################################
884# command handling &c 1211# command handling &c
885 1212
886=item cf::register_command $name => \&callback($ob,$args); 1213=item cf::register_command $name => \&callback($ob,$args);
… …
899 push @{ $COMMAND{$name} }, [$caller, $cb]; 1226 push @{ $COMMAND{$name} }, [$caller, $cb];
900} 1227}
901 1228
902=item cf::register_extcmd $name => \&callback($pl,$packet); 1229=item cf::register_extcmd $name => \&callback($pl,$packet);
903 1230
904Register a callbackf ro execution when the client sends an extcmd packet. 1231Register a callback for execution when the client sends an (synchronous)
1232extcmd packet. Ext commands will be processed in the order they are
1233received by the server, like other user commands. The first argument is
1234the logged-in player. Ext commands can only be processed after a player
1235has logged in successfully.
905 1236
906If the callback returns something, it is sent back as if reply was being 1237If the callback returns something, it is sent back as if reply was being
907called. 1238called.
908 1239
1240=item cf::register_exticmd $name => \&callback($ns,$packet);
1241
1242Register a callback for execution when the client sends an (asynchronous)
1243exticmd packet. Exti commands are processed by the server as soon as they
1244are received, i.e. out of order w.r.t. other commands. The first argument
1245is a client socket. Exti commands can be received anytime, even before
1246log-in.
1247
1248If the callback returns something, it is sent back as if reply was being
1249called.
1250
909=cut 1251=cut
910 1252
911sub register_extcmd { 1253sub register_extcmd {
912 my ($name, $cb) = @_; 1254 my ($name, $cb) = @_;
913 1255
914 $EXTCMD{$name} = $cb; 1256 $EXTCMD{$name} = $cb;
1257}
1258
1259sub register_exticmd {
1260 my ($name, $cb) = @_;
1261
1262 $EXTICMD{$name} = $cb;
915} 1263}
916 1264
917cf::player->attach ( 1265cf::player->attach (
918 on_command => sub { 1266 on_command => sub {
919 my ($pl, $name, $params) = @_; 1267 my ($pl, $name, $params) = @_;
… …
928 cf::override; 1276 cf::override;
929 }, 1277 },
930 on_extcmd => sub { 1278 on_extcmd => sub {
931 my ($pl, $buf) = @_; 1279 my ($pl, $buf) = @_;
932 1280
933 my $msg = eval { from_json $buf }; 1281 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
934 1282
935 if (ref $msg) { 1283 if (ref $msg) {
1284 my ($type, $reply, @payload) =
1285 "ARRAY" eq ref $msg
1286 ? @$msg
1287 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1288
1289 my @reply;
1290
936 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1291 if (my $cb = $EXTCMD{$type}) {
937 if (my %reply = $cb->($pl, $msg)) { 1292 @reply = $cb->($pl, @payload);
938 $pl->ext_reply ($msg->{msgid}, %reply);
939 }
940 } 1293 }
1294
1295 $pl->ext_reply ($reply, @reply)
1296 if $reply;
1297
941 } else { 1298 } else {
942 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1299 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
943 } 1300 }
944 1301
945 cf::override; 1302 cf::override;
946 }, 1303 },
947); 1304);
948 1305
949sub load_extension {
950 my ($path) = @_;
951
952 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
953 my $base = $1;
954 my $pkg = $1;
955 $pkg =~ s/[^[:word:]]/_/g;
956 $pkg = "ext::$pkg";
957
958 warn "... loading '$path' into '$pkg'\n";
959
960 open my $fh, "<:utf8", $path
961 or die "$path: $!";
962
963 my $source =
964 "package $pkg; use strict; use utf8;\n"
965 . "#line 1 \"$path\"\n{\n"
966 . (do { local $/; <$fh> })
967 . "\n};\n1";
968
969 unless (eval $source) {
970 my $msg = $@ ? "$path: $@\n"
971 : "extension disabled.\n";
972 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
973 warn $@;
974 warn "mandatory extension failed to load, exiting.\n";
975 exit 1;
976 }
977 die $@;
978 }
979
980 push @EXTS, $pkg;
981}
982
983sub load_extensions { 1306sub load_extensions {
1307 cf::sync_job {
1308 my %todo;
1309
984 for my $ext (<$LIBDIR/*.ext>) { 1310 for my $path (<$LIBDIR/*.ext>) {
985 next unless -r $ext; 1311 next unless -r $path;
986 eval { 1312
987 load_extension $ext; 1313 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1314 my $base = $1;
1315 my $pkg = $1;
1316 $pkg =~ s/[^[:word:]]/_/g;
1317 $pkg = "ext::$pkg";
1318
1319 open my $fh, "<:utf8", $path
1320 or die "$path: $!";
1321
1322 my $source = do { local $/; <$fh> };
1323
1324 my %ext = (
1325 path => $path,
1326 base => $base,
1327 pkg => $pkg,
1328 );
1329
1330 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1331 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1332
1333 $ext{source} =
1334 "package $pkg; use strict; use utf8;\n"
1335 . "#line 1 \"$path\"\n{\n"
1336 . $source
1337 . "\n};\n1";
1338
1339 $todo{$base} = \%ext;
1340 }
1341
1342 my %done;
1343 while (%todo) {
1344 my $progress;
1345
1346 while (my ($k, $v) = each %todo) {
1347 for (split /,\s*/, $v->{meta}{depends}) {
1348 goto skip
1349 unless exists $done{$_};
1350 }
1351
1352 warn "... loading '$k' into '$v->{pkg}'\n";
1353
1354 unless (eval $v->{source}) {
1355 my $msg = $@ ? "$v->{path}: $@\n"
1356 : "$v->{base}: extension inactive.\n";
1357
1358 if (exists $v->{meta}{mandatory}) {
1359 warn $msg;
1360 cf::cleanup "mandatory extension failed to load, exiting.";
1361 }
1362
1363 warn $msg;
1364 }
1365
1366 $done{$k} = delete $todo{$k};
1367 push @EXTS, $v->{pkg};
1368 $progress = 1;
988 1 1369 }
989 } or warn "$ext not loaded: $@"; 1370
1371 skip:
1372 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1373 unless $progress;
1374 }
990 } 1375 };
991} 1376}
992 1377
993############################################################################# 1378#############################################################################
994 1379
1380=back
1381
995=head2 CORE EXTENSIONS 1382=head2 CORE EXTENSIONS
996 1383
997Functions and methods that extend core crossfire objects. 1384Functions and methods that extend core crossfire objects.
998 1385
999=cut 1386=cut
… …
1003use Coro::AIO; 1390use Coro::AIO;
1004 1391
1005=head3 cf::player 1392=head3 cf::player
1006 1393
1007=over 4 1394=over 4
1395
1396=item cf::player::num_playing
1397
1398Returns the official number of playing players, as per the Crossfire metaserver rules.
1399
1400=cut
1401
1402sub num_playing {
1403 scalar grep
1404 $_->ob->map
1405 && !$_->hidden
1406 && !$_->ob->flag (cf::FLAG_WIZ),
1407 cf::player::list
1408}
1008 1409
1009=item cf::player::find $login 1410=item cf::player::find $login
1010 1411
1011Returns the given player object, loading it if necessary (might block). 1412Returns the given player object, loading it if necessary (might block).
1012 1413
… …
1048 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst"; 1449 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1049 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata"; 1450 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1050 aio_unlink +(playerdir $login) . "/$login.pl.pst"; 1451 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1051 aio_unlink +(playerdir $login) . "/$login.pl"; 1452 aio_unlink +(playerdir $login) . "/$login.pl";
1052 1453
1053 my $pl = load_pl path $login 1454 my $f = new_from_file cf::object::thawer path $login
1054 or return; 1455 or return;
1456
1457 my $pl = cf::player::load_pl $f
1458 or return;
1459 local $cf::PLAYER_LOADING{$login} = $pl;
1460 $f->resolve_delayed_derefs;
1055 $cf::PLAYER{$login} = $pl 1461 $cf::PLAYER{$login} = $pl
1056 } 1462 }
1057 } 1463 }
1058} 1464}
1059 1465
… …
1069 1475
1070 aio_mkdir playerdir $pl, 0770; 1476 aio_mkdir playerdir $pl, 0770;
1071 $pl->{last_save} = $cf::RUNTIME; 1477 $pl->{last_save} = $cf::RUNTIME;
1072 1478
1073 $pl->save_pl ($path); 1479 $pl->save_pl ($path);
1074 Coro::cede; 1480 cf::cede_to_tick;
1075} 1481}
1076 1482
1077sub new($) { 1483sub new($) {
1078 my ($login) = @_; 1484 my ($login) = @_;
1079 1485
… …
1083 $self->{deny_save} = 1; 1489 $self->{deny_save} = 1;
1084 1490
1085 $cf::PLAYER{$login} = $self; 1491 $cf::PLAYER{$login} = $self;
1086 1492
1087 $self 1493 $self
1494}
1495
1496=item $player->send_msg ($channel, $msg, $color, [extra...])
1497
1498=cut
1499
1500sub send_msg {
1501 my $ns = shift->ns
1502 or return;
1503 $ns->send_msg (@_);
1088} 1504}
1089 1505
1090=item $pl->quit_character 1506=item $pl->quit_character
1091 1507
1092Nukes the player without looking back. If logged in, the connection will 1508Nukes the player without looking back. If logged in, the connection will
… …
1147 or return []; 1563 or return [];
1148 1564
1149 my @logins; 1565 my @logins;
1150 1566
1151 for my $login (@$dirs) { 1567 for my $login (@$dirs) {
1568 my $path = path $login;
1569
1570 # a .pst is a dead give-away for a valid player
1571 unless (-e "$path.pst") {
1152 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1572 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1153 aio_read $fh, 0, 512, my $buf, 0 or next; 1573 aio_read $fh, 0, 512, my $buf, 0 or next;
1154 $buf !~ /^password -------------$/m or next; # official not-valid tag 1574 $buf !~ /^password -------------$/m or next; # official not-valid tag
1575 }
1155 1576
1156 utf8::decode $login; 1577 utf8::decode $login;
1157 push @logins, $login; 1578 push @logins, $login;
1158 } 1579 }
1159 1580
… …
1186 } 1607 }
1187 1608
1188 \@paths 1609 \@paths
1189} 1610}
1190 1611
1612=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1613
1614Expand crossfire pod fragments into protocol xml.
1615
1616=cut
1617
1618use re 'eval';
1619
1620my $group;
1621my $interior; $interior = qr{
1622 # match a pod interior sequence sans C<< >>
1623 (?:
1624 \ (.*?)\ (?{ $group = $^N })
1625 | < (??{$interior}) >
1626 )
1627}x;
1628
1629sub expand_cfpod {
1630 my ($self, $pod) = @_;
1631
1632 my $xml;
1633
1634 while () {
1635 if ($pod =~ /\G( (?: [^BCGHITU]+ | .(?!<) )+ )/xgcs) {
1636 $group = $1;
1637
1638 $group =~ s/&/&amp;/g;
1639 $group =~ s/</&lt;/g;
1640
1641 $xml .= $group;
1642 } elsif ($pod =~ m%\G
1643 ([BCGHITU])
1644 <
1645 (?:
1646 ([^<>]*) (?{ $group = $^N })
1647 | < $interior >
1648 )
1649 >
1650 %gcsx
1651 ) {
1652 my ($code, $data) = ($1, $group);
1653
1654 if ($code eq "B") {
1655 $xml .= "<b>" . expand_cfpod ($self, $data) . "</b>";
1656 } elsif ($code eq "I") {
1657 $xml .= "<i>" . expand_cfpod ($self, $data) . "</i>";
1658 } elsif ($code eq "U") {
1659 $xml .= "<u>" . expand_cfpod ($self, $data) . "</u>";
1660 } elsif ($code eq "C") {
1661 $xml .= "<tt>" . expand_cfpod ($self, $data) . "</tt>";
1662 } elsif ($code eq "T") {
1663 $xml .= "<big><b>" . expand_cfpod ($self, $data) . "</b></big>";
1664 } elsif ($code eq "G") {
1665 my ($male, $female) = split /\|/, $data;
1666 $data = $self->gender ? $female : $male;
1667 $xml .= expand_cfpod ($self, $data);
1668 } elsif ($code eq "H") {
1669 $xml .= ("<fg name=\"lightblue\">[" . expand_cfpod ($self, $data) . " (Use hintmode to suppress hints)]</fg>",
1670 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1671 "")
1672 [$self->{hintmode}];
1673 } else {
1674 $xml .= "error processing '$code($data)' directive";
1675 }
1676 } else {
1677 if ($pod =~ /\G(.+)/) {
1678 warn "parse error while expanding $pod (at $1)";
1679 }
1680 last;
1681 }
1682 }
1683
1684 for ($xml) {
1685 # create single paragraphs (very hackish)
1686 s/(?<=\S)\n(?=\w)/ /g;
1687
1688 # compress some whitespace
1689 s/\s+\n/\n/g; # ws line-ends
1690 s/\n\n+/\n/g; # double lines
1691 s/^\n+//; # beginning lines
1692 s/\n+$//; # ending lines
1693 }
1694
1695 $xml
1696}
1697
1698no re 'eval';
1699
1700sub hintmode {
1701 $_[0]{hintmode} = $_[1] if @_ > 1;
1702 $_[0]{hintmode}
1703}
1704
1191=item $player->ext_reply ($msgid, %msg) 1705=item $player->ext_reply ($msgid, @msg)
1192 1706
1193Sends an ext reply to the player. 1707Sends an ext reply to the player.
1194 1708
1195=cut 1709=cut
1196 1710
1197sub ext_reply($$%) { 1711sub ext_reply($$@) {
1198 my ($self, $id, %msg) = @_; 1712 my ($self, $id, @msg) = @_;
1199 1713
1200 $msg{msgid} = $id; 1714 $self->ns->ext_reply ($id, @msg)
1201
1202 $self->send ("ext " . cf::to_json \%msg);
1203} 1715}
1204 1716
1205=item $player->ext_event ($type, %msg) 1717=item $player->ext_msg ($type, @msg)
1206 1718
1207Sends an ext event to the client. 1719Sends an ext event to the client.
1208 1720
1209=cut 1721=cut
1210 1722
1211sub ext_event($$%) { 1723sub ext_msg($$@) {
1212 my ($self, $type, %msg) = @_; 1724 my ($self, $type, @msg) = @_;
1213 1725
1214 $self->ns->ext_event ($type, %msg); 1726 $self->ns->ext_msg ($type, @msg);
1215} 1727}
1216 1728
1217=head3 cf::region 1729=head3 cf::region
1218 1730
1219=over 4 1731=over 4
… …
1222 1734
1223package cf::region; 1735package cf::region;
1224 1736
1225=item cf::region::find_by_path $path 1737=item cf::region::find_by_path $path
1226 1738
1227Tries to decuce the probable region for a map knowing only its path. 1739Tries to decuce the likely region for a map knowing only its path.
1228 1740
1229=cut 1741=cut
1230 1742
1231sub find_by_path($) { 1743sub find_by_path($) {
1232 my ($path) = @_; 1744 my ($path) = @_;
1233 1745
1234 my ($match, $specificity); 1746 my ($match, $specificity);
1235 1747
1236 for my $region (list) { 1748 for my $region (list) {
1237 if ($region->match && $path =~ $region->match) { 1749 if ($region->{match} && $path =~ $region->{match}) {
1238 ($match, $specificity) = ($region, $region->specificity) 1750 ($match, $specificity) = ($region, $region->specificity)
1239 if $region->specificity > $specificity; 1751 if $region->specificity > $specificity;
1240 } 1752 }
1241 } 1753 }
1242 1754
… …
1263our $MAX_RESET = 3600; 1775our $MAX_RESET = 3600;
1264our $DEFAULT_RESET = 3000; 1776our $DEFAULT_RESET = 3000;
1265 1777
1266sub generate_random_map { 1778sub generate_random_map {
1267 my ($self, $rmp) = @_; 1779 my ($self, $rmp) = @_;
1780
1781 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1782
1268 # mit "rum" bekleckern, nicht 1783 # mit "rum" bekleckern, nicht
1269 $self->_create_random_map ( 1784 $self->_create_random_map (
1270 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1785 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1271 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1786 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1272 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1787 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
… …
1306 my ($self, $merge) = @_; 1821 my ($self, $merge) = @_;
1307 1822
1308 # we have to keep some variables in memory intact 1823 # we have to keep some variables in memory intact
1309 local $self->{path}; 1824 local $self->{path};
1310 local $self->{load_path}; 1825 local $self->{load_path};
1311 local $self->{deny_save};
1312 local $self->{deny_reset};
1313 1826
1314 $self->SUPER::thawer_merge ($merge); 1827 $self->SUPER::thawer_merge ($merge);
1315} 1828}
1316 1829
1317sub normalise { 1830sub normalise {
… …
1364 $self->init; # pass $1 etc. 1877 $self->init; # pass $1 etc.
1365 return $self; 1878 return $self;
1366 } 1879 }
1367 } 1880 }
1368 1881
1369 Carp::carp "unable to resolve path '$path' (base '$base')."; 1882 Carp::cluck "unable to resolve path '$path' (base '$base').";
1370 () 1883 ()
1371} 1884}
1372 1885
1373sub init { 1886sub init {
1374 my ($self) = @_; 1887 my ($self) = @_;
… …
1396 1909
1397# the temporary/swap location 1910# the temporary/swap location
1398sub save_path { 1911sub save_path {
1399 my ($self) = @_; 1912 my ($self) = @_;
1400 1913
1401 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1914 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1402 "$TMPDIR/$path.map" 1915 "$TMPDIR/$path.map"
1403} 1916}
1404 1917
1405# the unique path, undef == no special unique path 1918# the unique path, undef == no special unique path
1406sub uniq_path { 1919sub uniq_path {
1407 my ($self) = @_; 1920 my ($self) = @_;
1408 1921
1409 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1922 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1410 "$UNIQUEDIR/$path" 1923 "$UNIQUEDIR/$path"
1411} 1924}
1412 1925
1413# and all this just because we cannot iterate over 1926# and all this just because we cannot iterate over
1414# all maps in C++... 1927# all maps in C++...
… …
1417 1930
1418 $_->change_map_light ($change) 1931 $_->change_map_light ($change)
1419 for grep $_->outdoor, values %cf::MAP; 1932 for grep $_->outdoor, values %cf::MAP;
1420} 1933}
1421 1934
1935sub decay_objects {
1936 my ($self) = @_;
1937
1938 return if $self->{deny_reset};
1939
1940 $self->do_decay_objects;
1941}
1942
1422sub unlink_save { 1943sub unlink_save {
1423 my ($self) = @_; 1944 my ($self) = @_;
1424 1945
1425 utf8::encode (my $save = $self->save_path); 1946 utf8::encode (my $save = $self->save_path);
1426 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save; 1947 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
… …
1429 1950
1430sub load_header_from($) { 1951sub load_header_from($) {
1431 my ($self, $path) = @_; 1952 my ($self, $path) = @_;
1432 1953
1433 utf8::encode $path; 1954 utf8::encode $path;
1434 #aio_open $path, O_RDONLY, 0 1955 my $f = new_from_file cf::object::thawer $path
1435 # or return;
1436
1437 $self->_load_header ($path)
1438 or return; 1956 or return;
1957
1958 $self->_load_header ($f)
1959 or return;
1960
1961 local $MAP_LOADING{$self->{path}} = $self;
1962 $f->resolve_delayed_derefs;
1439 1963
1440 $self->{load_path} = $path; 1964 $self->{load_path} = $path;
1441 1965
1442 1 1966 1
1443} 1967}
… …
1482 $self->load_header_orig 2006 $self->load_header_orig
1483 or return; 2007 or return;
1484 $self->prepare_orig; 2008 $self->prepare_orig;
1485 } 2009 }
1486 2010
2011 $self->{deny_reset} = 1
2012 if $self->no_reset;
2013
1487 $self->default_region (cf::region::find_by_path $self->{path}) 2014 $self->default_region (cf::region::find_by_path $self->{path})
1488 unless $self->default_region; 2015 unless $self->default_region;
1489 2016
1490 1 2017 1
1491} 2018}
… …
1494sub find { 2021sub find {
1495 my ($path, $origin) = @_; 2022 my ($path, $origin) = @_;
1496 2023
1497 $path = normalise $path, $origin && $origin->path; 2024 $path = normalise $path, $origin && $origin->path;
1498 2025
2026 cf::lock_wait "map_data:$path";#d#remove
1499 cf::lock_wait "map_find:$path"; 2027 cf::lock_wait "map_find:$path";
1500 2028
1501 $cf::MAP{$path} || do { 2029 $cf::MAP{$path} || do {
1502 my $guard = cf::lock_acquire "map_find:$path"; 2030 my $guard1 = cf::lock_acquire "map_find:$path";
2031 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
2032
1503 my $map = new_from_path cf::map $path 2033 my $map = new_from_path cf::map $path
1504 or return; 2034 or return;
1505 2035
1506 $map->{last_save} = $cf::RUNTIME; 2036 $map->{last_save} = $cf::RUNTIME;
1507 2037
1508 $map->load_header 2038 $map->load_header
1509 or return; 2039 or return;
1510 2040
1511 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?) 2041 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1512 # doing this can freeze the server in a sync job, obviously 2042 # doing this can freeze the server in a sync job, obviously
1513 #$cf::WAIT_FOR_TICK->wait; 2043 #$cf::WAIT_FOR_TICK->wait;
2044 undef $guard1;
2045 undef $guard2;
1514 $map->reset; 2046 $map->reset;
1515 undef $guard;
1516 return find $path; 2047 return find $path;
1517 } 2048 }
1518 2049
1519 $cf::MAP{$path} = $map 2050 $cf::MAP{$path} = $map
1520 } 2051 }
… …
1529 local $self->{deny_reset} = 1; # loading can take a long time 2060 local $self->{deny_reset} = 1; # loading can take a long time
1530 2061
1531 my $path = $self->{path}; 2062 my $path = $self->{path};
1532 2063
1533 { 2064 {
1534 my $guard = cf::lock_acquire "map_load:$path"; 2065 my $guard = cf::lock_acquire "map_data:$path";
1535 2066
2067 return unless $self->valid;
1536 return if $self->in_memory != cf::MAP_SWAPPED; 2068 return unless $self->in_memory == cf::MAP_SWAPPED;
1537 2069
1538 $self->in_memory (cf::MAP_LOADING); 2070 $self->in_memory (cf::MAP_LOADING);
1539 2071
1540 $self->alloc; 2072 $self->alloc;
1541 2073
1542 $self->pre_load; 2074 $self->pre_load;
1543 Coro::cede; 2075 cf::cede_to_tick;
1544 2076
2077 my $f = new_from_file cf::object::thawer $self->{load_path};
2078 $f->skip_block;
1545 $self->_load_objects ($self->{load_path}, 1) 2079 $self->_load_objects ($f)
1546 or return; 2080 or return;
1547 2081
1548 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2082 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1549 if delete $self->{load_original}; 2083 if delete $self->{load_original};
1550 2084
1551 if (my $uniq = $self->uniq_path) { 2085 if (my $uniq = $self->uniq_path) {
1552 utf8::encode $uniq; 2086 utf8::encode $uniq;
1553 if (aio_open $uniq, O_RDONLY, 0) { 2087 unless (aio_stat $uniq) {
2088 if (my $f = new_from_file cf::object::thawer $uniq) {
1554 $self->clear_unique_items; 2089 $self->clear_unique_items;
1555 $self->_load_objects ($uniq, 0); 2090 $self->_load_objects ($f);
2091 $f->resolve_delayed_derefs;
2092 }
1556 } 2093 }
1557 } 2094 }
1558 2095
1559 Coro::cede; 2096 $f->resolve_delayed_derefs;
2097
2098 cf::cede_to_tick;
1560 # now do the right thing for maps 2099 # now do the right thing for maps
1561 $self->link_multipart_objects; 2100 $self->link_multipart_objects;
1562 $self->difficulty ($self->estimate_difficulty) 2101 $self->difficulty ($self->estimate_difficulty)
1563 unless $self->difficulty; 2102 unless $self->difficulty;
1564 Coro::cede; 2103 cf::cede_to_tick;
1565 2104
1566 unless ($self->{deny_activate}) { 2105 unless ($self->{deny_activate}) {
1567 $self->decay_objects; 2106 $self->decay_objects;
1568 $self->fix_auto_apply; 2107 $self->fix_auto_apply;
1569 $self->update_buttons; 2108 $self->update_buttons;
1570 Coro::cede; 2109 cf::cede_to_tick;
1571 $self->set_darkness_map; 2110 $self->set_darkness_map;
1572 Coro::cede; 2111 cf::cede_to_tick;
1573 $self->activate; 2112 $self->activate;
1574 } 2113 }
2114
2115 $self->{last_save} = $cf::RUNTIME;
2116 $self->last_access ($cf::RUNTIME);
1575 2117
1576 $self->in_memory (cf::MAP_IN_MEMORY); 2118 $self->in_memory (cf::MAP_IN_MEMORY);
1577 } 2119 }
1578 2120
1579 $self->post_load; 2121 $self->post_load;
… …
1583 my ($self, $ob) = @_; 2125 my ($self, $ob) = @_;
1584 2126
1585 return find "~" . $ob->name . "/" . $self->{path} 2127 return find "~" . $ob->name . "/" . $self->{path}
1586 if $self->per_player; 2128 if $self->per_player;
1587 2129
2130# return find "?party/" . $ob->name . "/" . $self->{path}
2131# if $self->per_party;
2132
1588 $self 2133 $self
1589} 2134}
1590 2135
1591# find and load all maps in the 3x3 area around a map 2136# find and load all maps in the 3x3 area around a map
1592sub load_diag { 2137sub load_neighbours {
1593 my ($map) = @_; 2138 my ($map) = @_;
1594 2139
1595 my @diag; # diagonal neighbours 2140 my @neigh; # diagonal neighbours
1596 2141
1597 for (0 .. 3) { 2142 for (0 .. 3) {
1598 my $neigh = $map->tile_path ($_) 2143 my $neigh = $map->tile_path ($_)
1599 or next; 2144 or next;
1600 $neigh = find $neigh, $map 2145 $neigh = find $neigh, $map
1601 or next; 2146 or next;
1602 $neigh->load; 2147 $neigh->load;
1603 2148
2149 push @neigh,
1604 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 2150 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1605 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2151 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1606 } 2152 }
1607 2153
1608 for (@diag) { 2154 for (grep defined $_->[0], @neigh) {
2155 my ($path, $origin) = @$_;
1609 my $neigh = find @$_ 2156 my $neigh = find $path, $origin
1610 or next; 2157 or next;
1611 $neigh->load; 2158 $neigh->load;
1612 } 2159 }
1613} 2160}
1614 2161
… …
1619} 2166}
1620 2167
1621sub do_load_sync { 2168sub do_load_sync {
1622 my ($map) = @_; 2169 my ($map) = @_;
1623 2170
2171 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
2172 if $Coro::current == $Coro::main;
2173
1624 cf::sync_job { $map->load }; 2174 cf::sync_job { $map->load };
1625} 2175}
1626 2176
1627our %MAP_PREFETCH; 2177our %MAP_PREFETCH;
1628our $MAP_PREFETCHER = undef; 2178our $MAP_PREFETCHER = undef;
1629 2179
1630sub find_async { 2180sub find_async {
1631 my ($path, $origin) = @_; 2181 my ($path, $origin, $load) = @_;
1632 2182
1633 $path = normalise $path, $origin && $origin->{path}; 2183 $path = normalise $path, $origin && $origin->{path};
1634 2184
1635 if (my $map = $cf::MAP{$path}) { 2185 if (my $map = $cf::MAP{$path}) {
1636 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 2186 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY;
1637 } 2187 }
1638 2188
1639 undef $MAP_PREFETCH{$path}; 2189 $MAP_PREFETCH{$path} |= $load;
2190
1640 $MAP_PREFETCHER ||= cf::async { 2191 $MAP_PREFETCHER ||= cf::async {
2192 $Coro::current->{desc} = "map prefetcher";
2193
1641 while (%MAP_PREFETCH) { 2194 while (%MAP_PREFETCH) {
1642 for my $path (keys %MAP_PREFETCH) { 2195 while (my ($k, $v) = each %MAP_PREFETCH) {
1643 my $map = find $path 2196 if (my $map = find $k) {
1644 or next;
1645 $map->load; 2197 $map->load if $v;
2198 }
1646 2199
1647 delete $MAP_PREFETCH{$path}; 2200 delete $MAP_PREFETCH{$k};
1648 } 2201 }
1649 } 2202 }
1650 undef $MAP_PREFETCHER; 2203 undef $MAP_PREFETCHER;
1651 }; 2204 };
1652 $MAP_PREFETCHER->prio (6); 2205 $MAP_PREFETCHER->prio (6);
… …
1655} 2208}
1656 2209
1657sub save { 2210sub save {
1658 my ($self) = @_; 2211 my ($self) = @_;
1659 2212
1660 my $lock = cf::lock_acquire "map_data:" . $self->path; 2213 my $lock = cf::lock_acquire "map_data:$self->{path}";
1661 2214
1662 $self->{last_save} = $cf::RUNTIME; 2215 $self->{last_save} = $cf::RUNTIME;
1663 2216
1664 return unless $self->dirty; 2217 return unless $self->dirty;
1665 2218
… …
1671 return if $self->{deny_save}; 2224 return if $self->{deny_save};
1672 2225
1673 local $self->{last_access} = $self->last_access;#d# 2226 local $self->{last_access} = $self->last_access;#d#
1674 2227
1675 cf::async { 2228 cf::async {
2229 $Coro::current->{desc} = "map player save";
1676 $_->contr->save for $self->players; 2230 $_->contr->save for $self->players;
1677 }; 2231 };
1678 2232
1679 if ($uniq) { 2233 if ($uniq) {
1680 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2234 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
… …
1688 my ($self) = @_; 2242 my ($self) = @_;
1689 2243
1690 # save first because save cedes 2244 # save first because save cedes
1691 $self->save; 2245 $self->save;
1692 2246
1693 my $lock = cf::lock_acquire "map_data:" . $self->path; 2247 my $lock = cf::lock_acquire "map_data:$self->{path}";
1694 2248
1695 return if $self->players; 2249 return if $self->players;
1696 return if $self->in_memory != cf::MAP_IN_MEMORY; 2250 return if $self->in_memory != cf::MAP_IN_MEMORY;
1697 return if $self->{deny_save}; 2251 return if $self->{deny_save};
1698 2252
2253 $self->in_memory (cf::MAP_SWAPPED);
2254
2255 $self->deactivate;
2256 $_->clear_links_to ($self) for values %cf::MAP;
1699 $self->clear; 2257 $self->clear;
1700 $self->in_memory (cf::MAP_SWAPPED);
1701} 2258}
1702 2259
1703sub reset_at { 2260sub reset_at {
1704 my ($self) = @_; 2261 my ($self) = @_;
1705 2262
1706 # TODO: safety, remove and allow resettable per-player maps 2263 # TODO: safety, remove and allow resettable per-player maps
1707 return 1e99 if $self->isa ("ext::map_per_player");#d#
1708 return 1e99 if $self->{deny_reset}; 2264 return 1e99 if $self->{deny_reset};
1709 2265
1710 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 2266 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1711 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 2267 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1712 2268
… …
1723 my ($self) = @_; 2279 my ($self) = @_;
1724 2280
1725 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2281 my $lock = cf::lock_acquire "map_data:$self->{path}";
1726 2282
1727 return if $self->players; 2283 return if $self->players;
1728 return if $self->isa ("ext::map_per_player");#d#
1729 2284
1730 warn "resetting map ", $self->path;#d# 2285 warn "resetting map ", $self->path;
1731 2286
1732 $self->in_memory (cf::MAP_SWAPPED); 2287 $self->in_memory (cf::MAP_SWAPPED);
1733 2288
1734 # need to save uniques path 2289 # need to save uniques path
1735 unless ($self->{deny_save}) { 2290 unless ($self->{deny_save}) {
… …
1739 if $uniq; 2294 if $uniq;
1740 } 2295 }
1741 2296
1742 delete $cf::MAP{$self->path}; 2297 delete $cf::MAP{$self->path};
1743 2298
2299 $self->deactivate;
2300 $_->clear_links_to ($self) for values %cf::MAP;
1744 $self->clear; 2301 $self->clear;
1745
1746 $_->clear_links_to ($self) for values %cf::MAP;
1747 2302
1748 $self->unlink_save; 2303 $self->unlink_save;
1749 $self->destroy; 2304 $self->destroy;
1750} 2305}
1751 2306
1752my $nuke_counter = "aaaa"; 2307my $nuke_counter = "aaaa";
1753 2308
1754sub nuke { 2309sub nuke {
1755 my ($self) = @_; 2310 my ($self) = @_;
1756 2311
2312 {
2313 my $lock = cf::lock_acquire "map_data:$self->{path}";
2314
1757 delete $cf::MAP{$self->path}; 2315 delete $cf::MAP{$self->path};
1758 2316
1759 $self->unlink_save; 2317 $self->unlink_save;
1760 2318
1761 bless $self, "cf::map"; 2319 bless $self, "cf::map";
1762 delete $self->{deny_reset}; 2320 delete $self->{deny_reset};
1763 $self->{deny_save} = 1; 2321 $self->{deny_save} = 1;
1764 $self->reset_timeout (1); 2322 $self->reset_timeout (1);
1765 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2323 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1766 2324
1767 $cf::MAP{$self->path} = $self; 2325 $cf::MAP{$self->path} = $self;
2326 }
1768 2327
1769 $self->reset; # polite request, might not happen 2328 $self->reset; # polite request, might not happen
2329}
2330
2331=item $maps = cf::map::tmp_maps
2332
2333Returns an arrayref with all map paths of currently instantiated and saved
2334maps. May block.
2335
2336=cut
2337
2338sub tmp_maps() {
2339 [
2340 map {
2341 utf8::decode $_;
2342 /\.map$/
2343 ? normalise $_
2344 : ()
2345 } @{ aio_readdir $TMPDIR or [] }
2346 ]
2347}
2348
2349=item $maps = cf::map::random_maps
2350
2351Returns an arrayref with all map paths of currently instantiated and saved
2352random maps. May block.
2353
2354=cut
2355
2356sub random_maps() {
2357 [
2358 map {
2359 utf8::decode $_;
2360 /\.map$/
2361 ? normalise "?random/$_"
2362 : ()
2363 } @{ aio_readdir $RANDOMDIR or [] }
2364 ]
1770} 2365}
1771 2366
1772=item cf::map::unique_maps 2367=item cf::map::unique_maps
1773 2368
1774Returns an arrayref of paths of all shared maps that have 2369Returns an arrayref of paths of all shared maps that have
1775instantiated unique items. May block. 2370instantiated unique items. May block.
1776 2371
1777=cut 2372=cut
1778 2373
1779sub unique_maps() { 2374sub unique_maps() {
1780 my $files = aio_readdir $UNIQUEDIR 2375 [
1781 or return; 2376 map {
1782
1783 my @paths;
1784
1785 for (@$files) {
1786 utf8::decode $_; 2377 utf8::decode $_;
1787 next if /\.pst$/; 2378 s/\.map$//; # TODO future compatibility hack
1788 next unless /^$PATH_SEP/o; 2379 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
1789 2380 ? ()
1790 push @paths, cf::map::normalise $_; 2381 : normalise $_
2382 } @{ aio_readdir $UNIQUEDIR or [] }
1791 } 2383 ]
1792
1793 \@paths
1794} 2384}
1795
1796package cf;
1797 2385
1798=back 2386=back
1799 2387
1800=head3 cf::object 2388=head3 cf::object
1801 2389
… …
1805 2393
1806=over 4 2394=over 4
1807 2395
1808=item $ob->inv_recursive 2396=item $ob->inv_recursive
1809 2397
1810Returns the inventory of the object _and_ their inventories, recursively. 2398Returns the inventory of the object I<and> their inventories, recursively,
2399but I<not> the object itself.
1811 2400
1812=cut 2401=cut
1813 2402
1814sub inv_recursive_; 2403sub inv_recursive_;
1815sub inv_recursive_ { 2404sub inv_recursive_ {
1816 map { $_, inv_recursive_ $_->inv } @_ 2405 map { $_, inv_recursive_ $_->inv } @_
1817} 2406}
1818 2407
1819sub inv_recursive { 2408sub inv_recursive {
1820 inv_recursive_ inv $_[0] 2409 inv_recursive_ inv $_[0]
2410}
2411
2412=item $ref = $ob->ref
2413
2414Creates and returns a persistent reference to an object that can be stored as a string.
2415
2416=item $ob = cf::object::deref ($refstring)
2417
2418returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2419even if the object actually exists. May block.
2420
2421=cut
2422
2423sub deref {
2424 my ($ref) = @_;
2425
2426 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2427 my ($uuid, $name) = ($1, $2);
2428 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2429 or return;
2430 $pl->ob->uuid eq $uuid
2431 or return;
2432
2433 $pl->ob
2434 } else {
2435 warn "$ref: cannot resolve object reference\n";
2436 undef
2437 }
1821} 2438}
1822 2439
1823package cf; 2440package cf;
1824 2441
1825=back 2442=back
… …
1844 2461
1845 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2462 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1846 2463
1847 if ($self->{record_replies}) { 2464 if ($self->{record_replies}) {
1848 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2465 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2466
1849 } else { 2467 } else {
2468 my $pl = $self->contr;
2469
2470 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2471 my $dialog = $pl->{npc_dialog};
2472 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2473
2474 } else {
1850 $msg = $npc->name . " says: $msg" if $npc; 2475 $msg = $npc->name . " says: $msg" if $npc;
1851 $self->message ($msg, $flags); 2476 $self->message ($msg, $flags);
2477 }
1852 } 2478 }
2479}
2480
2481=item $object->send_msg ($channel, $msg, $color, [extra...])
2482
2483=cut
2484
2485sub cf::object::send_msg {
2486 my $pl = shift->contr
2487 or return;
2488 $pl->send_msg (@_);
1853} 2489}
1854 2490
1855=item $player_object->may ("access") 2491=item $player_object->may ("access")
1856 2492
1857Returns wether the given player is authorized to access resource "access" 2493Returns wether the given player is authorized to access resource "access"
… …
1904 $self->deactivate_recursive; 2540 $self->deactivate_recursive;
1905 2541
1906 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2542 return if UNIVERSAL::isa $self->map, "ext::map_link";
1907 2543
1908 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2544 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1909 if $self->map; 2545 if $self->map && $self->map->{path} ne "{link}";
1910 2546
1911 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2547 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1912} 2548}
1913 2549
1914sub cf::object::player::leave_link { 2550sub cf::object::player::leave_link {
1915 my ($self, $map, $x, $y) = @_; 2551 my ($self, $map, $x, $y) = @_;
2552
2553 return unless $self->contr->active;
1916 2554
1917 my $link_pos = delete $self->{_link_pos}; 2555 my $link_pos = delete $self->{_link_pos};
1918 2556
1919 unless ($map) { 2557 unless ($map) {
1920 # restore original map position 2558 # restore original map position
… …
1934 # use -1 or undef as default coordinates, not 0, 0 2572 # use -1 or undef as default coordinates, not 0, 0
1935 ($x, $y) = ($map->enter_x, $map->enter_y) 2573 ($x, $y) = ($map->enter_x, $map->enter_y)
1936 if $x <=0 && $y <= 0; 2574 if $x <=0 && $y <= 0;
1937 2575
1938 $map->load; 2576 $map->load;
1939 $map->load_diag; 2577 $map->load_neighbours;
1940 2578
1941 return unless $self->contr->active; 2579 return unless $self->contr->active;
1942 $self->activate_recursive; 2580 $self->activate_recursive;
1943 2581
1944 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2582 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1945 $self->enter_map ($map, $x, $y); 2583 $self->enter_map ($map, $x, $y);
1946} 2584}
1947 2585
1948cf::player->attach (
1949 on_logout => sub {
1950 my ($pl) = @_;
1951
1952 # abort map switching before logout
1953 if ($pl->ob->{_link_pos}) {
1954 cf::sync_job {
1955 $pl->ob->leave_link
1956 };
1957 }
1958 },
1959 on_login => sub {
1960 my ($pl) = @_;
1961
1962 # try to abort aborted map switching on player login :)
1963 # should happen only on crashes
1964 if ($pl->ob->{_link_pos}) {
1965 $pl->ob->enter_link;
1966 (async {
1967 $pl->ob->reply (undef,
1968 "There was an internal problem at your last logout, "
1969 . "the server will try to bring you to your intended destination in a second.",
1970 cf::NDI_RED);
1971 # we need this sleep as the login has a concurrent enter_exit running
1972 # and this sleep increases chances of the player not ending up in scorn
1973 Coro::Timer::sleep 1;
1974 $pl->ob->leave_link;
1975 })->prio (2);
1976 }
1977 },
1978);
1979
1980=item $player_object->goto ($path, $x, $y[, $check->($map)]) 2586=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
1981 2587
1982Moves the player to the given map-path and coordinates by first freezing 2588Moves the player to the given map-path and coordinates by first freezing
1983her, loading and preparing them map, calling the provided $check callback 2589her, loading and preparing them map, calling the provided $check callback
1984that has to return the map if sucecssful, and then unfreezes the player on 2590that has to return the map if sucecssful, and then unfreezes the player on
1985the new (success) or old (failed) map position. 2591the new (success) or old (failed) map position. In either case, $done will
2592be called at the end of this process.
1986 2593
1987=cut 2594=cut
2595
2596our $GOTOGEN;
1988 2597
1989sub cf::object::player::goto { 2598sub cf::object::player::goto {
1990 my ($self, $path, $x, $y, $check) = @_; 2599 my ($self, $path, $x, $y, $check, $done) = @_;
1991 2600
1992 #d# #TODO# 2601 # do generation counting so two concurrent goto's will be executed in-order
1993 if ($check && !ref $check) { 2602 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1994 warn Carp::longmess "goto called with non-ref check argument";#d#
1995 undef $check;
1996 }
1997 2603
1998 $self->enter_link; 2604 $self->enter_link;
1999 2605
2000 (async { 2606 (async {
2607 $Coro::current->{desc} = "player::goto $path $x $y";
2608
2609 # *tag paths override both path and x|y
2610 if ($path =~ /^\*(.*)$/) {
2611 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2612 my $ob = $obs[rand @obs];
2613
2614 # see if we actually can go there
2615 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2616 $ob = $obs[rand @obs];
2617 } else {
2618 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2619 }
2620 # else put us there anyways for now #d#
2621
2622 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2623 } else {
2624 ($path, $x, $y) = (undef, undef, undef);
2625 }
2626 }
2627
2001 my $map = eval { 2628 my $map = eval {
2002 my $map = cf::map::find $path; 2629 my $map = defined $path ? cf::map::find $path : undef;
2003 2630
2004 if ($map) { 2631 if ($map) {
2005 $map = $map->customise_for ($self); 2632 $map = $map->customise_for ($self);
2006 $map = $check->($map) if $check && $map; 2633 $map = $check->($map) if $check && $map;
2007 } else { 2634 } else {
2008 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED); 2635 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2009 } 2636 }
2010 2637
2011 $map 2638 $map
2012 }; 2639 };
2013 2640
2014 if ($@) { 2641 if ($@) {
2015 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED); 2642 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2016 LOG llevError | logBacktrace, Carp::longmess $@; 2643 LOG llevError | logBacktrace, Carp::longmess $@;
2017 } 2644 }
2018 2645
2646 if ($gen == $self->{_goto_generation}) {
2647 delete $self->{_goto_generation};
2019 $self->leave_link ($map, $x, $y); 2648 $self->leave_link ($map, $x, $y);
2649 }
2650
2651 $done->() if $done;
2020 })->prio (1); 2652 })->prio (1);
2021} 2653}
2022 2654
2023=item $player_object->enter_exit ($exit_object) 2655=item $player_object->enter_exit ($exit_object)
2024 2656
… …
2061 $rmp->{origin_y} = $exit->y; 2693 $rmp->{origin_y} = $exit->y;
2062 } 2694 }
2063 2695
2064 $rmp->{random_seed} ||= $exit->random_seed; 2696 $rmp->{random_seed} ||= $exit->random_seed;
2065 2697
2066 my $data = cf::to_json $rmp; 2698 my $data = cf::encode_json $rmp;
2067 my $md5 = Digest::MD5::md5_hex $data; 2699 my $md5 = Digest::MD5::md5_hex $data;
2068 my $meta = "$RANDOMDIR/$md5.meta"; 2700 my $meta = "$RANDOMDIR/$md5.meta";
2069 2701
2070 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2702 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2071 aio_write $fh, 0, (length $data), $data, 0; 2703 aio_write $fh, 0, (length $data), $data, 0;
… …
2093 my $hp = $exit->stats->hp; 2725 my $hp = $exit->stats->hp;
2094 my $sp = $exit->stats->sp; 2726 my $sp = $exit->stats->sp;
2095 2727
2096 $self->enter_link; 2728 $self->enter_link;
2097 2729
2730 # if exit is damned, update players death & WoR home-position
2731 $self->contr->savebed ($slaying, $hp, $sp)
2732 if $exit->flag (FLAG_DAMNED);
2733
2098 (async { 2734 (async {
2735 $Coro::current->{desc} = "enter_exit $slaying $hp $sp";
2736
2099 $self->deactivate_recursive; # just to be sure 2737 $self->deactivate_recursive; # just to be sure
2100 unless (eval { 2738 unless (eval {
2101 $self->goto ($slaying, $hp, $sp); 2739 $self->goto ($slaying, $hp, $sp);
2102 2740
2103 1; 2741 1;
… …
2129 2767
2130 utf8::encode $text; 2768 utf8::encode $text;
2131 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2769 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2132} 2770}
2133 2771
2772=item $client->send_msg ($channel, $msg, $color, [extra...])
2773
2774Send a drawinfo or msg packet to the client, formatting the msg for the
2775client if neccessary. C<$type> should be a string identifying the type of
2776the message, with C<log> being the default. If C<$color> is negative, suppress
2777the message unless the client supports the msg packet.
2778
2779=cut
2780
2781# non-persistent channels (usually the info channel)
2782our %CHANNEL = (
2783 "c/identify" => {
2784 id => "infobox",
2785 title => "Identify",
2786 reply => undef,
2787 tooltip => "Items recently identified",
2788 },
2789 "c/examine" => {
2790 id => "infobox",
2791 title => "Examine",
2792 reply => undef,
2793 tooltip => "Signs and other items you examined",
2794 },
2795 "c/book" => {
2796 id => "infobox",
2797 title => "Book",
2798 reply => undef,
2799 tooltip => "The contents of a note or book",
2800 },
2801 "c/lookat" => {
2802 id => "infobox",
2803 title => "Look",
2804 reply => undef,
2805 tooltip => "What you saw there",
2806 },
2807 "c/who" => {
2808 id => "infobox",
2809 title => "Players",
2810 reply => undef,
2811 tooltip => "Shows players who are currently online",
2812 },
2813 "c/body" => {
2814 id => "infobox",
2815 title => "Body Parts",
2816 reply => undef,
2817 tooltip => "Shows which body parts you posess and are available",
2818 },
2819 "c/uptime" => {
2820 id => "infobox",
2821 title => "Uptime",
2822 reply => undef,
2823 tooltip => "How long the server has been running since last restart",
2824 },
2825 "c/mapinfo" => {
2826 id => "infobox",
2827 title => "Map Info",
2828 reply => undef,
2829 tooltip => "Information related to the maps",
2830 },
2831);
2832
2833sub cf::client::send_msg {
2834 my ($self, $channel, $msg, $color, @extra) = @_;
2835
2836 $msg = $self->pl->expand_cfpod ($msg);
2837
2838 $color &= cf::NDI_CLIENT_MASK; # just in case...
2839
2840 # check predefined channels, for the benefit of C
2841 if ($CHANNEL{$channel}) {
2842 $channel = $CHANNEL{$channel};
2843
2844 $self->ext_msg (channel_info => $channel)
2845 if $self->can_msg;
2846
2847 $channel = $channel->{id};
2848
2849 } elsif (ref $channel) {
2850 # send meta info to client, if not yet sent
2851 unless (exists $self->{channel}{$channel->{id}}) {
2852 $self->{channel}{$channel->{id}} = $channel;
2853 $self->ext_msg (channel_info => $channel)
2854 if $self->can_msg;
2855 }
2856
2857 $channel = $channel->{id};
2858 }
2859
2860 return unless @extra || length $msg;
2861
2862 if ($self->can_msg) {
2863 # default colour, mask it out
2864 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2865 if $color & cf::NDI_DEF;
2866
2867 $self->send_packet ("msg " . $self->{json_coder}->encode (
2868 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2869 } else {
2870 if ($color >= 0) {
2871 # replace some tags by gcfclient-compatible ones
2872 for ($msg) {
2873 1 while
2874 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2875 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2876 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2877 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2878 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2879 }
2880
2881 $color &= cf::NDI_COLOR_MASK;
2882
2883 utf8::encode $msg;
2884
2885 if (0 && $msg =~ /\[/) {
2886 # COMMAND/INFO
2887 $self->send_packet ("drawextinfo $color 10 8 $msg")
2888 } else {
2889 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2890 $self->send_packet ("drawinfo $color $msg")
2891 }
2892 }
2893 }
2894}
2895
2134=item $client->ext_event ($type, %msg) 2896=item $client->ext_msg ($type, @msg)
2135 2897
2136Sends an exti event to the client. 2898Sends an ext event to the client.
2137 2899
2138=cut 2900=cut
2139 2901
2140sub cf::client::ext_event($$%) { 2902sub cf::client::ext_msg($$@) {
2141 my ($self, $type, %msg) = @_; 2903 my ($self, $type, @msg) = @_;
2142 2904
2905 if ($self->extcmd == 2) {
2906 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2907 } elsif ($self->extcmd == 1) { # TODO: remove
2143 $msg{msgtype} = "event_$type"; 2908 push @msg, msgtype => "event_$type";
2144 $self->send_packet ("ext " . cf::to_json \%msg); 2909 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2910 }
2911}
2912
2913=item $client->ext_reply ($msgid, @msg)
2914
2915Sends an ext reply to the client.
2916
2917=cut
2918
2919sub cf::client::ext_reply($$@) {
2920 my ($self, $id, @msg) = @_;
2921
2922 if ($self->extcmd == 2) {
2923 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2924 } elsif ($self->extcmd == 1) {
2925 #TODO: version 1, remove
2926 unshift @msg, msgtype => "reply", msgid => $id;
2927 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2928 }
2145} 2929}
2146 2930
2147=item $success = $client->query ($flags, "text", \&cb) 2931=item $success = $client->query ($flags, "text", \&cb)
2148 2932
2149Queues a query to the client, calling the given callback with 2933Queues a query to the client, calling the given callback with
2150the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2934the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
2151C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 2935C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2152 2936
2153Queries can fail, so check the return code. Or don't, as queries will become 2937Queries can fail, so check the return code. Or don't, as queries will
2154reliable at some point in the future. 2938become reliable at some point in the future.
2155 2939
2156=cut 2940=cut
2157 2941
2158sub cf::client::query { 2942sub cf::client::query {
2159 my ($self, $flags, $text, $cb) = @_; 2943 my ($self, $flags, $text, $cb) = @_;
… …
2167 utf8::encode $text; 2951 utf8::encode $text;
2168 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2952 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2169 2953
2170 $self->send_packet ($self->{query_queue}[0][0]) 2954 $self->send_packet ($self->{query_queue}[0][0])
2171 if @{ $self->{query_queue} } == 1; 2955 if @{ $self->{query_queue} } == 1;
2956
2957 1
2172} 2958}
2173 2959
2174cf::client->attach ( 2960cf::client->attach (
2961 on_connect => sub {
2962 my ($ns) = @_;
2963
2964 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2965 },
2175 on_reply => sub { 2966 on_reply => sub {
2176 my ($ns, $msg) = @_; 2967 my ($ns, $msg) = @_;
2177 2968
2178 # this weird shuffling is so that direct followup queries 2969 # this weird shuffling is so that direct followup queries
2179 # get handled first 2970 # get handled first
… …
2191 } else { 2982 } else {
2192 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 2983 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2193 } 2984 }
2194 } 2985 }
2195 }, 2986 },
2987 on_exticmd => sub {
2988 my ($ns, $buf) = @_;
2989
2990 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2991
2992 if (ref $msg) {
2993 my ($type, $reply, @payload) =
2994 "ARRAY" eq ref $msg
2995 ? @$msg
2996 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
2997
2998 my @reply;
2999
3000 if (my $cb = $EXTICMD{$type}) {
3001 @reply = $cb->($ns, @payload);
3002 }
3003
3004 $ns->ext_reply ($reply, @reply)
3005 if $reply;
3006
3007 } else {
3008 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3009 }
3010
3011 cf::override;
3012 },
2196); 3013);
2197 3014
2198=item $client->async (\&cb) 3015=item $client->async (\&cb)
2199 3016
2200Create a new coroutine, running the specified callback. The coroutine will 3017Create a new coroutine, running the specified callback. The coroutine will
… …
2241our $safe = new Safe "safe"; 3058our $safe = new Safe "safe";
2242our $safe_hole = new Safe::Hole; 3059our $safe_hole = new Safe::Hole;
2243 3060
2244$SIG{FPE} = 'IGNORE'; 3061$SIG{FPE} = 'IGNORE';
2245 3062
2246$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 3063$safe->permit_only (Opcode::opset qw(
3064 :base_core :base_mem :base_orig :base_math
3065 grepstart grepwhile mapstart mapwhile
3066 sort time
3067));
2247 3068
2248# here we export the classes and methods available to script code 3069# here we export the classes and methods available to script code
2249 3070
2250=pod 3071=pod
2251 3072
2252The following functions and methods are available within a safe environment: 3073The following functions and methods are available within a safe environment:
2253 3074
2254 cf::object contr pay_amount pay_player map 3075 cf::object
3076 contr pay_amount pay_player map x y force_find force_add destroy
3077 insert remove name archname title slaying race decrease_ob_nr
3078
2255 cf::object::player player 3079 cf::object::player
2256 cf::player peaceful 3080 player
2257 cf::map trigger 3081
3082 cf::player
3083 peaceful
3084
3085 cf::map
3086 trigger
2258 3087
2259=cut 3088=cut
2260 3089
2261for ( 3090for (
2262 ["cf::object" => qw(contr pay_amount pay_player map)], 3091 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3092 insert remove inv name archname title slaying race
3093 decrease_ob_nr destroy)],
2263 ["cf::object::player" => qw(player)], 3094 ["cf::object::player" => qw(player)],
2264 ["cf::player" => qw(peaceful)], 3095 ["cf::player" => qw(peaceful)],
2265 ["cf::map" => qw(trigger)], 3096 ["cf::map" => qw(trigger)],
2266) { 3097) {
2267 no strict 'refs'; 3098 no strict 'refs';
… …
2338=back 3169=back
2339 3170
2340=cut 3171=cut
2341 3172
2342############################################################################# 3173#############################################################################
2343
2344=head2 EXTENSION DATABASE SUPPORT
2345
2346Crossfire maintains a very simple database for extension use. It can
2347currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2348convert to/from binary).
2349
2350The parameter C<$family> should best start with the name of the extension
2351using it, it should be unique.
2352
2353=over 4
2354
2355=item $value = cf::db_get $family => $key
2356
2357Returns a single value from the database.
2358
2359=item cf::db_put $family => $key => $value
2360
2361Stores the given C<$value> in the family.
2362
2363=cut
2364
2365our $DB;
2366
2367sub db_init {
2368 unless ($DB) {
2369 $DB = BDB::db_create $DB_ENV;
2370
2371 cf::sync_job {
2372 eval {
2373 $DB->set_flags (BDB::CHKSUM);
2374
2375 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2376 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2377 cf::cleanup "db_open(db): $!" if $!;
2378 };
2379 cf::cleanup "db_open(db): $@" if $@;
2380 };
2381 }
2382}
2383
2384sub db_get($$) {
2385 my $key = "$_[0]/$_[1]";
2386
2387 cf::sync_job {
2388 BDB::db_get $DB, undef, $key, my $data;
2389
2390 $! ? ()
2391 : $data
2392 }
2393}
2394
2395sub db_put($$$) {
2396 BDB::dbreq_pri 4;
2397 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2398}
2399
2400=item cf::cache $id => [$paths...], $processversion => $process
2401
2402Generic caching function that returns the value of the resource $id,
2403caching and regenerating as required.
2404
2405This function can block.
2406
2407=cut
2408
2409sub cache {
2410 my ($id, $src, $processversion, $process) = @_;
2411
2412 my $meta =
2413 join "\x00",
2414 $processversion,
2415 map {
2416 aio_stat $_
2417 and Carp::croak "$_: $!";
2418
2419 ($_, (stat _)[7,9])
2420 } @$src;
2421
2422 my $dbmeta = db_get cache => "$id/meta";
2423 if ($dbmeta ne $meta) {
2424 # changed, we may need to process
2425
2426 my @data;
2427 my $md5;
2428
2429 for (0 .. $#$src) {
2430 0 <= aio_load $src->[$_], $data[$_]
2431 or Carp::croak "$src->[$_]: $!";
2432 }
2433
2434 # if processing is expensive, check
2435 # checksum first
2436 if (1) {
2437 $md5 =
2438 join "\x00",
2439 $processversion,
2440 map {
2441 Coro::cede;
2442 ($src->[$_], Digest::MD5::md5_hex $data[$_])
2443 } 0.. $#$src;
2444
2445
2446 my $dbmd5 = db_get cache => "$id/md5";
2447 if ($dbmd5 eq $md5) {
2448 db_put cache => "$id/meta", $meta;
2449
2450 return db_get cache => "$id/data";
2451 }
2452 }
2453
2454 my $t1 = Time::HiRes::time;
2455 my $data = $process->(\@data);
2456 my $t2 = Time::HiRes::time;
2457
2458 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2459
2460 db_put cache => "$id/data", $data;
2461 db_put cache => "$id/md5" , $md5;
2462 db_put cache => "$id/meta", $meta;
2463
2464 return $data;
2465 }
2466
2467 db_get cache => "$id/data"
2468}
2469
2470=item fork_call { }, $args
2471
2472Executes the given code block with the given arguments in a seperate
2473process, returning the results. Everything must be serialisable with
2474Coro::Storable. May, of course, block. Note that the executed sub may
2475never block itself or use any form of Event handling.
2476
2477=cut
2478
2479sub fork_call(&@) {
2480 my ($cb, @args) = @_;
2481
2482# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2483# or die "socketpair: $!";
2484 pipe my $fh1, my $fh2
2485 or die "pipe: $!";
2486
2487 if (my $pid = fork) {
2488 close $fh2;
2489
2490 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2491 $res = Coro::Storable::thaw $res;
2492
2493 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2494
2495 die $$res unless "ARRAY" eq ref $res;
2496
2497 return wantarray ? @$res : $res->[-1];
2498 } else {
2499 reset_signals;
2500 local $SIG{__WARN__};
2501 local $SIG{__DIE__};
2502 eval {
2503 close $fh1;
2504
2505 my @res = eval { $cb->(@args) };
2506 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2507 };
2508
2509 warn $@ if $@;
2510 _exit 0;
2511 }
2512}
2513
2514
2515
2516#############################################################################
2517# the server's init and main functions 3174# the server's init and main functions
2518 3175
2519sub load_facedata($) { 3176sub load_facedata($) {
2520 my ($path) = @_; 3177 my ($path) = @_;
3178
3179 # HACK to clear player env face cache, we need some signal framework
3180 # for this (global event?)
3181 %ext::player_env::MUSIC_FACE_CACHE = ();
3182
3183 my $enc = JSON::XS->new->utf8->canonical->relaxed;
2521 3184
2522 warn "loading facedata from $path\n"; 3185 warn "loading facedata from $path\n";
2523 3186
2524 my $facedata; 3187 my $facedata;
2525 0 < aio_load $path, $facedata 3188 0 < aio_load $path, $facedata
… …
2528 $facedata = Coro::Storable::thaw $facedata; 3191 $facedata = Coro::Storable::thaw $facedata;
2529 3192
2530 $facedata->{version} == 2 3193 $facedata->{version} == 2
2531 or cf::cleanup "$path: version mismatch, cannot proceed."; 3194 or cf::cleanup "$path: version mismatch, cannot proceed.";
2532 3195
3196 # patch in the exptable
3197 $facedata->{resource}{"res/exp_table"} = {
3198 type => FT_RSRC,
3199 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
3200 };
3201 cf::cede_to_tick;
3202
2533 { 3203 {
2534 my $faces = $facedata->{faceinfo}; 3204 my $faces = $facedata->{faceinfo};
2535 3205
2536 while (my ($face, $info) = each %$faces) { 3206 while (my ($face, $info) = each %$faces) {
2537 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3207 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3208
2538 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 3209 cf::face::set_visibility $idx, $info->{visibility};
3210 cf::face::set_magicmap $idx, $info->{magicmap};
2539 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 3211 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2540 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 3212 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2541 Coro::cede; 3213
3214 cf::cede_to_tick;
2542 } 3215 }
2543 3216
2544 while (my ($face, $info) = each %$faces) { 3217 while (my ($face, $info) = each %$faces) {
2545 next unless $info->{smooth}; 3218 next unless $info->{smooth};
3219
2546 my $idx = cf::face::find $face 3220 my $idx = cf::face::find $face
2547 or next; 3221 or next;
3222
2548 if (my $smooth = cf::face::find $info->{smooth}) { 3223 if (my $smooth = cf::face::find $info->{smooth}) {
3224 cf::face::set_smooth $idx, $smooth;
2549 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel}; 3225 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2550 } else { 3226 } else {
2551 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3227 warn "smooth face '$info->{smooth}' not found for face '$face'";
2552 } 3228 }
2553 Coro::cede; 3229
3230 cf::cede_to_tick;
2554 } 3231 }
2555 } 3232 }
2556 3233
2557 { 3234 {
2558 my $anims = $facedata->{animinfo}; 3235 my $anims = $facedata->{animinfo};
2559 3236
2560 while (my ($anim, $info) = each %$anims) { 3237 while (my ($anim, $info) = each %$anims) {
2561 cf::anim::set $anim, $info->{frames}, $info->{facings}; 3238 cf::anim::set $anim, $info->{frames}, $info->{facings};
2562 Coro::cede; 3239 cf::cede_to_tick;
2563 } 3240 }
2564 3241
2565 cf::anim::invalidate_all; # d'oh 3242 cf::anim::invalidate_all; # d'oh
2566 } 3243 }
2567 3244
3245 {
3246 # TODO: for gcfclient pleasure, we should give resources
3247 # that gcfclient doesn't grok a >10000 face index.
3248 my $res = $facedata->{resource};
3249
3250 while (my ($name, $info) = each %$res) {
3251 if (defined $info->{type}) {
3252 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3253 my $data;
3254
3255 if ($info->{type} & 1) {
3256 # prepend meta info
3257
3258 my $meta = $enc->encode ({
3259 name => $name,
3260 %{ $info->{meta} || {} },
3261 });
3262
3263 $data = pack "(w/a*)*", $meta, $info->{data};
3264 } else {
3265 $data = $info->{data};
3266 }
3267
3268 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3269 cf::face::set_type $idx, $info->{type};
3270 } else {
3271 $RESOURCE{$name} = $info;
3272 }
3273
3274 cf::cede_to_tick;
3275 }
3276 }
3277
3278 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3279
2568 1 3280 1
2569} 3281}
2570 3282
3283cf::global->attach (on_resource_update => sub {
3284 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3285 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3286
3287 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3288 my $sound = $soundconf->{compat}[$_]
3289 or next;
3290
3291 my $face = cf::face::find "sound/$sound->[1]";
3292 cf::sound::set $sound->[0] => $face;
3293 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3294 }
3295
3296 while (my ($k, $v) = each %{$soundconf->{event}}) {
3297 my $face = cf::face::find "sound/$v";
3298 cf::sound::set $k => $face;
3299 }
3300 }
3301});
3302
3303register_exticmd fx_want => sub {
3304 my ($ns, $want) = @_;
3305
3306 while (my ($k, $v) = each %$want) {
3307 $ns->fx_want ($k, $v);
3308 }
3309};
3310
2571sub reload_regions { 3311sub reload_regions {
3312 # HACK to clear player env face cache, we need some signal framework
3313 # for this (global event?)
3314 %ext::player_env::MUSIC_FACE_CACHE = ();
3315
2572 load_resource_file "$MAPDIR/regions" 3316 load_resource_file "$MAPDIR/regions"
2573 or die "unable to load regions file\n"; 3317 or die "unable to load regions file\n";
3318
3319 for (cf::region::list) {
3320 $_->{match} = qr/$_->{match}/
3321 if exists $_->{match};
3322 }
2574} 3323}
2575 3324
2576sub reload_facedata { 3325sub reload_facedata {
2577 load_facedata "$DATADIR/facedata" 3326 load_facedata "$DATADIR/facedata"
2578 or die "unable to load facedata\n"; 3327 or die "unable to load facedata\n";
2579} 3328}
2580 3329
2581sub reload_archetypes { 3330sub reload_archetypes {
2582 load_resource_file "$DATADIR/archetypes" 3331 load_resource_file "$DATADIR/archetypes"
2583 or die "unable to load archetypes\n"; 3332 or die "unable to load archetypes\n";
3333 #d# NEED to laod twice to resolve forward references
3334 # this really needs to be done in an extra post-pass
3335 # (which needs to be synchronous, so solve it differently)
3336 load_resource_file "$DATADIR/archetypes"
3337 or die "unable to load archetypes\n";
2584} 3338}
2585 3339
2586sub reload_treasures { 3340sub reload_treasures {
2587 load_resource_file "$DATADIR/treasures" 3341 load_resource_file "$DATADIR/treasures"
2588 or die "unable to load treasurelists\n"; 3342 or die "unable to load treasurelists\n";
… …
2591sub reload_resources { 3345sub reload_resources {
2592 warn "reloading resource files...\n"; 3346 warn "reloading resource files...\n";
2593 3347
2594 reload_regions; 3348 reload_regions;
2595 reload_facedata; 3349 reload_facedata;
3350 #reload_archetypes;#d#
2596 reload_archetypes; 3351 reload_archetypes;
2597 reload_treasures; 3352 reload_treasures;
2598 3353
2599 warn "finished reloading resource files\n"; 3354 warn "finished reloading resource files\n";
2600} 3355}
2601 3356
2602sub init { 3357sub init {
2603 reload_resources; 3358 reload_resources;
2604} 3359}
2605 3360
2606sub cfg_load { 3361sub reload_config {
2607 open my $fh, "<:utf8", "$CONFDIR/config" 3362 open my $fh, "<:utf8", "$CONFDIR/config"
2608 or return; 3363 or return;
2609 3364
2610 local $/; 3365 local $/;
2611 *CFG = YAML::Syck::Load <$fh>; 3366 *CFG = YAML::Load <$fh>;
2612 3367
2613 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3368 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
2614 3369
2615 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3370 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2616 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3371 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
… …
2627sub main { 3382sub main {
2628 # we must not ever block the main coroutine 3383 # we must not ever block the main coroutine
2629 local $Coro::idle = sub { 3384 local $Coro::idle = sub {
2630 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3385 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2631 (async { 3386 (async {
2632 Event::one_event; 3387 $Coro::current->{desc} = "IDLE BUG HANDLER";
3388 EV::loop EV::LOOP_ONESHOT;
2633 })->prio (Coro::PRIO_MAX); 3389 })->prio (Coro::PRIO_MAX);
2634 }; 3390 };
2635 3391
2636 cfg_load; 3392 reload_config;
2637 db_init; 3393 db_init;
2638 load_extensions; 3394 load_extensions;
2639 3395
2640 $TICK_WATCHER->start; 3396 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3397 evthread_start IO::AIO::poll_fileno;
2641 Event::loop; 3398 EV::loop;
2642} 3399}
2643 3400
2644############################################################################# 3401#############################################################################
2645# initialisation and cleanup 3402# initialisation and cleanup
2646 3403
2647# install some emergency cleanup handlers 3404# install some emergency cleanup handlers
2648BEGIN { 3405BEGIN {
3406 our %SIGWATCHER = ();
2649 for my $signal (qw(INT HUP TERM)) { 3407 for my $signal (qw(INT HUP TERM)) {
2650 Event->signal ( 3408 $SIGWATCHER{$signal} = EV::signal $signal, sub {
2651 reentrant => 0,
2652 data => WF_AUTOCANCEL,
2653 signal => $signal,
2654 prio => 0,
2655 cb => sub {
2656 cf::cleanup "SIG$signal"; 3409 cf::cleanup "SIG$signal";
2657 },
2658 ); 3410 };
3411 }
3412}
3413
3414sub write_runtime_sync {
3415 my $runtime = "$LOCALDIR/runtime";
3416
3417 # first touch the runtime file to show we are still running:
3418 # the fsync below can take a very very long time.
3419
3420 IO::AIO::aio_utime $runtime, undef, undef;
3421
3422 my $guard = cf::lock_acquire "write_runtime";
3423
3424 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
3425 or return;
3426
3427 my $value = $cf::RUNTIME + 90 + 10;
3428 # 10 is the runtime save interval, for a monotonic clock
3429 # 60 allows for the watchdog to kill the server.
3430
3431 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3432 and return;
3433
3434 # always fsync - this file is important
3435 aio_fsync $fh
3436 and return;
3437
3438 # touch it again to show we are up-to-date
3439 aio_utime $fh, undef, undef;
3440
3441 close $fh
3442 or return;
3443
3444 aio_rename "$runtime~", $runtime
3445 and return;
3446
3447 warn "runtime file written.\n";
3448
2659 } 3449 1
3450}
3451
3452our $uuid_lock;
3453our $uuid_skip;
3454
3455sub write_uuid_sync($) {
3456 $uuid_skip ||= $_[0];
3457
3458 return if $uuid_lock;
3459 local $uuid_lock = 1;
3460
3461 my $uuid = "$LOCALDIR/uuid";
3462
3463 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3464 or return;
3465
3466 my $value = uuid_str $uuid_skip + uuid_seq uuid_cur;
3467 $uuid_skip = 0;
3468
3469 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3470 and return;
3471
3472 # always fsync - this file is important
3473 aio_fsync $fh
3474 and return;
3475
3476 close $fh
3477 or return;
3478
3479 aio_rename "$uuid~", $uuid
3480 and return;
3481
3482 warn "uuid file written ($value).\n";
3483
3484 1
3485
3486}
3487
3488sub write_uuid($$) {
3489 my ($skip, $sync) = @_;
3490
3491 $sync ? write_uuid_sync $skip
3492 : async { write_uuid_sync $skip };
2660} 3493}
2661 3494
2662sub emergency_save() { 3495sub emergency_save() {
2663 my $freeze_guard = cf::freeze_mainloop; 3496 my $freeze_guard = cf::freeze_mainloop;
2664 3497
… …
2670 # and maps saved/destroyed asynchronously. 3503 # and maps saved/destroyed asynchronously.
2671 warn "begin emergency player save\n"; 3504 warn "begin emergency player save\n";
2672 for my $login (keys %cf::PLAYER) { 3505 for my $login (keys %cf::PLAYER) {
2673 my $pl = $cf::PLAYER{$login} or next; 3506 my $pl = $cf::PLAYER{$login} or next;
2674 $pl->valid or next; 3507 $pl->valid or next;
3508 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
2675 $pl->save; 3509 $pl->save;
2676 } 3510 }
2677 warn "end emergency player save\n"; 3511 warn "end emergency player save\n";
2678 3512
2679 warn "begin emergency map save\n"; 3513 warn "begin emergency map save\n";
… …
2685 warn "end emergency map save\n"; 3519 warn "end emergency map save\n";
2686 3520
2687 warn "begin emergency database checkpoint\n"; 3521 warn "begin emergency database checkpoint\n";
2688 BDB::db_env_txn_checkpoint $DB_ENV; 3522 BDB::db_env_txn_checkpoint $DB_ENV;
2689 warn "end emergency database checkpoint\n"; 3523 warn "end emergency database checkpoint\n";
3524
3525 warn "begin write uuid\n";
3526 write_uuid_sync 1;
3527 warn "end write uuid\n";
2690 }; 3528 };
2691 3529
2692 warn "leave emergency perl save\n"; 3530 warn "leave emergency perl save\n";
2693} 3531}
2694 3532
… …
2709 warn "reloading..."; 3547 warn "reloading...";
2710 3548
2711 warn "entering sync_job"; 3549 warn "entering sync_job";
2712 3550
2713 cf::sync_job { 3551 cf::sync_job {
2714 cf::write_runtime; # external watchdog should not bark 3552 cf::write_runtime_sync; # external watchdog should not bark
2715 cf::emergency_save; 3553 cf::emergency_save;
2716 cf::write_runtime; # external watchdog should not bark 3554 cf::write_runtime_sync; # external watchdog should not bark
2717 3555
2718 warn "syncing database to disk"; 3556 warn "syncing database to disk";
2719 BDB::db_env_txn_checkpoint $DB_ENV; 3557 BDB::db_env_txn_checkpoint $DB_ENV;
2720 3558
2721 # if anything goes wrong in here, we should simply crash as we already saved 3559 # if anything goes wrong in here, we should simply crash as we already saved
2722
2723 warn "cancelling all WF_AUTOCANCEL watchers";
2724 for (Event::all_watchers) {
2725 $_->cancel if $_->data & WF_AUTOCANCEL;
2726 }
2727 3560
2728 warn "flushing outstanding aio requests"; 3561 warn "flushing outstanding aio requests";
2729 for (;;) { 3562 for (;;) {
2730 BDB::flush; 3563 BDB::flush;
2731 IO::AIO::flush; 3564 IO::AIO::flush;
2732 Coro::cede; 3565 Coro::cede_notself;
2733 last unless IO::AIO::nreqs || BDB::nreqs; 3566 last unless IO::AIO::nreqs || BDB::nreqs;
2734 warn "iterate..."; 3567 warn "iterate...";
2735 } 3568 }
2736 3569
2737 ++$RELOAD; 3570 ++$RELOAD;
… …
2741 %EXT_CORO = (); 3574 %EXT_CORO = ();
2742 3575
2743 warn "removing commands"; 3576 warn "removing commands";
2744 %COMMAND = (); 3577 %COMMAND = ();
2745 3578
2746 warn "removing ext commands"; 3579 warn "removing ext/exti commands";
2747 %EXTCMD = (); 3580 %EXTCMD = ();
3581 %EXTICMD = ();
2748 3582
2749 warn "unloading/nuking all extensions"; 3583 warn "unloading/nuking all extensions";
2750 for my $pkg (@EXTS) { 3584 for my $pkg (@EXTS) {
2751 warn "... unloading $pkg"; 3585 warn "... unloading $pkg";
2752 3586
… …
2795 warn "reloading cf.pm"; 3629 warn "reloading cf.pm";
2796 require cf; 3630 require cf;
2797 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3631 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2798 3632
2799 warn "loading config and database again"; 3633 warn "loading config and database again";
2800 cf::cfg_load; 3634 cf::reload_config;
2801 3635
2802 warn "loading extensions"; 3636 warn "loading extensions";
2803 cf::load_extensions; 3637 cf::load_extensions;
2804 3638
2805 warn "reattaching attachments to objects/players"; 3639 warn "reattaching attachments to objects/players";
… …
2812 warn "leaving sync_job"; 3646 warn "leaving sync_job";
2813 3647
2814 1 3648 1
2815 } or do { 3649 } or do {
2816 warn $@; 3650 warn $@;
2817 warn "error while reloading, exiting."; 3651 cf::cleanup "error while reloading, exiting.";
2818 exit 1;
2819 }; 3652 };
2820 3653
2821 warn "reloaded"; 3654 warn "reloaded";
2822}; 3655};
2823 3656
… …
2825 3658
2826sub reload_perl() { 3659sub reload_perl() {
2827 # doing reload synchronously and two reloads happen back-to-back, 3660 # doing reload synchronously and two reloads happen back-to-back,
2828 # coro crashes during coro_state_free->destroy here. 3661 # coro crashes during coro_state_free->destroy here.
2829 3662
2830 $RELOAD_WATCHER ||= Event->timer ( 3663 $RELOAD_WATCHER ||= EV::timer 0, 0, sub {
2831 reentrant => 0,
2832 after => 0,
2833 data => WF_AUTOCANCEL,
2834 cb => sub {
2835 do_reload_perl; 3664 do_reload_perl;
2836 undef $RELOAD_WATCHER; 3665 undef $RELOAD_WATCHER;
2837 },
2838 ); 3666 };
2839} 3667}
2840 3668
2841register_command "reload" => sub { 3669register_command "reload" => sub {
2842 my ($who, $arg) = @_; 3670 my ($who, $arg) = @_;
2843 3671
2844 if ($who->flag (FLAG_WIZ)) { 3672 if ($who->flag (FLAG_WIZ)) {
2845 $who->message ("reloading server."); 3673 $who->message ("reloading server.");
3674 async {
3675 $Coro::current->{desc} = "perl_reload";
2846 async { reload_perl }; 3676 reload_perl;
3677 };
2847 } 3678 }
2848}; 3679};
2849 3680
2850unshift @INC, $LIBDIR; 3681unshift @INC, $LIBDIR;
2851 3682
… …
2853 3684
2854our @WAIT_FOR_TICK; 3685our @WAIT_FOR_TICK;
2855our @WAIT_FOR_TICK_BEGIN; 3686our @WAIT_FOR_TICK_BEGIN;
2856 3687
2857sub wait_for_tick { 3688sub wait_for_tick {
2858 return unless $TICK_WATCHER->is_active; 3689 return if tick_inhibit;
2859 return if $Coro::current == $Coro::main; 3690 return if $Coro::current == $Coro::main;
2860 3691
2861 my $signal = new Coro::Signal; 3692 my $signal = new Coro::Signal;
2862 push @WAIT_FOR_TICK, $signal; 3693 push @WAIT_FOR_TICK, $signal;
2863 $signal->wait; 3694 $signal->wait;
2864} 3695}
2865 3696
2866sub wait_for_tick_begin { 3697sub wait_for_tick_begin {
2867 return unless $TICK_WATCHER->is_active; 3698 return if tick_inhibit;
2868 return if $Coro::current == $Coro::main; 3699 return if $Coro::current == $Coro::main;
2869 3700
2870 my $signal = new Coro::Signal; 3701 my $signal = new Coro::Signal;
2871 push @WAIT_FOR_TICK_BEGIN, $signal; 3702 push @WAIT_FOR_TICK_BEGIN, $signal;
2872 $signal->wait; 3703 $signal->wait;
2873} 3704}
2874 3705
2875 my $min = 1e6;#d# 3706sub tick {
2876 my $avg = 10;
2877$TICK_WATCHER = Event->timer (
2878 reentrant => 0,
2879 parked => 1,
2880 prio => 0,
2881 at => $NEXT_TICK || $TICK,
2882 data => WF_AUTOCANCEL,
2883 cb => sub {
2884 if ($Coro::current != $Coro::main) { 3707 if ($Coro::current != $Coro::main) {
2885 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3708 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2886 unless ++$bug_warning > 10; 3709 unless ++$bug_warning > 10;
2887 return; 3710 return;
2888 } 3711 }
2889 3712
2890 $NOW = $tick_start = Event::time;
2891
2892 cf::server_tick; # one server iteration 3713 cf::server_tick; # one server iteration
2893 3714
2894 0 && sync_job {#d# 3715 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2895 for(1..10) { 3716 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
2896 my $t = Event::time; 3717 Coro::async_pool {
2897 my $map = my $map = new_from_path cf::map "/tmp/x.map" 3718 $Coro::current->{desc} = "runtime saver";
2898 or die; 3719 write_runtime_sync
2899 3720 or warn "ERROR: unable to write runtime file: $!";
2900 $map->width (50);
2901 $map->height (50);
2902 $map->alloc;
2903 $map->_load_objects ("/tmp/x.map", 1);
2904 my $t = Event::time - $t;
2905
2906 #next unless $t < 0.0013;#d#
2907 if ($t < $min) {
2908 $min = $t;
2909 }
2910 $avg = $avg * 0.99 + $t * 0.01;
2911 }
2912 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
2913 exit 0;
2914 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
2915 }; 3721 };
3722 }
2916 3723
2917 $RUNTIME += $TICK;
2918 $NEXT_TICK += $TICK;
2919
2920 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2921 $NEXT_RUNTIME_WRITE = $NOW + 10;
2922 Coro::async_pool {
2923 write_runtime
2924 or warn "ERROR: unable to write runtime file: $!";
2925 };
2926 }
2927
2928# my $AFTER = Event::time;
2929# warn $AFTER - $NOW;#d#
2930
2931 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3724 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
2932 $sig->send; 3725 $sig->send;
2933 } 3726 }
2934 while (my $sig = shift @WAIT_FOR_TICK) { 3727 while (my $sig = shift @WAIT_FOR_TICK) {
2935 $sig->send; 3728 $sig->send;
2936 } 3729 }
2937 3730
2938 $NOW = Event::time; 3731 $LOAD = ($NOW - $TICK_START) / $TICK;
2939
2940 # if we are delayed by four ticks or more, skip them all
2941 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2942
2943 $TICK_WATCHER->at ($NEXT_TICK);
2944 $TICK_WATCHER->start;
2945
2946 $LOAD = ($NOW - $tick_start) / $TICK;
2947 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3732 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
2948 3733
2949 _post_tick; 3734 if (0) {
2950 3735 if ($NEXT_TICK) {
2951 3736 my $jitter = $TICK_START - $NEXT_TICK;
3737 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3738 warn "jitter $JITTER\n";#d#
3739 }
2952 }, 3740 }
2953); 3741}
2954 3742
2955{ 3743{
2956 BDB::max_poll_time $TICK * 0.1; 3744 # configure BDB
2957 $BDB_POLL_WATCHER = Event->io ( 3745
2958 reentrant => 0,
2959 fd => BDB::poll_fileno,
2960 poll => 'r',
2961 prio => 0,
2962 data => WF_AUTOCANCEL,
2963 cb => \&BDB::poll_cb,
2964 );
2965 BDB::min_parallel 8; 3746 BDB::min_parallel 8;
2966 3747 BDB::max_poll_reqs $TICK * 0.1;
2967 BDB::set_sync_prepare { 3748 $Coro::BDB::WATCHER->priority (1);
2968 my $status;
2969 my $current = $Coro::current;
2970 (
2971 sub {
2972 $status = $!;
2973 $current->ready; undef $current;
2974 },
2975 sub {
2976 Coro::schedule while defined $current;
2977 $! = $status;
2978 },
2979 )
2980 };
2981 3749
2982 unless ($DB_ENV) { 3750 unless ($DB_ENV) {
2983 $DB_ENV = BDB::db_env_create; 3751 $DB_ENV = BDB::db_env_create;
3752 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC
3753 | BDB::LOG_AUTOREMOVE, 1);
3754 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3755 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
2984 3756
2985 cf::sync_job { 3757 cf::sync_job {
2986 eval { 3758 eval {
2987 BDB::db_env_open 3759 BDB::db_env_open
2988 $DB_ENV, 3760 $DB_ENV,
… …
2990 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3762 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2991 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3763 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2992 0666; 3764 0666;
2993 3765
2994 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 3766 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2995
2996 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2997 $DB_ENV->set_lk_detect;
2998 }; 3767 };
2999 3768
3000 cf::cleanup "db_env_open(db): $@" if $@; 3769 cf::cleanup "db_env_open(db): $@" if $@;
3001 }; 3770 };
3002 } 3771 }
3772
3773 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3774 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3775 };
3776 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3777 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3778 };
3779 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3780 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3781 };
3003} 3782}
3004 3783
3005{ 3784{
3785 # configure IO::AIO
3786
3006 IO::AIO::min_parallel 8; 3787 IO::AIO::min_parallel 8;
3007
3008 undef $Coro::AIO::WATCHER;
3009 IO::AIO::max_poll_time $TICK * 0.1; 3788 IO::AIO::max_poll_time $TICK * 0.1;
3010 $AIO_POLL_WATCHER = Event->io ( 3789 $Coro::AIO::WATCHER->priority (1);
3011 reentrant => 0,
3012 data => WF_AUTOCANCEL,
3013 fd => IO::AIO::poll_fileno,
3014 poll => 'r',
3015 prio => 6,
3016 cb => \&IO::AIO::poll_cb,
3017 );
3018} 3790}
3019 3791
3020my $_log_backtrace; 3792my $_log_backtrace;
3021 3793
3022sub _log_backtrace { 3794sub _log_backtrace {
… …
3026 3798
3027 # limit the # of concurrent backtraces 3799 # limit the # of concurrent backtraces
3028 if ($_log_backtrace < 2) { 3800 if ($_log_backtrace < 2) {
3029 ++$_log_backtrace; 3801 ++$_log_backtrace;
3030 async { 3802 async {
3803 $Coro::current->{desc} = "abt $msg";
3804
3031 my @bt = fork_call { 3805 my @bt = fork_call {
3032 @addr = map { sprintf "%x", $_ } @addr; 3806 @addr = map { sprintf "%x", $_ } @addr;
3033 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X; 3807 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3034 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |" 3808 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3035 or die "addr2line: $!"; 3809 or die "addr2line: $!";

Diff Legend

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