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.260 by root, Fri Apr 27 19:53:05 2007 UTC vs.
Revision 1.376 by root, Mon Oct 1 00:44:44 2007 UTC

… …
10use Event; 10use Event;
11use Opcode; 11use Opcode;
12use Safe; 12use Safe;
13use Safe::Hole; 13use Safe::Hole;
14 14
15use Coro 3.61 (); 15use Coro 3.64 ();
16use Coro::State; 16use Coro::State;
17use Coro::Handle; 17use Coro::Handle;
18use Coro::Event; 18use Coro::Event;
19use Coro::Timer; 19use Coro::Timer;
20use Coro::Signal; 20use Coro::Signal;
21use Coro::Semaphore; 21use Coro::Semaphore;
22use Coro::AIO; 22use Coro::AIO;
23use Coro::Storable; 23use Coro::Storable;
24use Coro::Util ();
24 25
26use JSON::XS ();
25use BDB (); 27use BDB ();
26use Data::Dumper; 28use Data::Dumper;
27use Digest::MD5; 29use Digest::MD5;
28use Fcntl; 30use Fcntl;
29use YAML::Syck (); 31use YAML::Syck ();
30use IO::AIO 2.32 (); 32use IO::AIO 2.32 ();
31use Time::HiRes; 33use Time::HiRes;
32use Compress::LZF; 34use Compress::LZF;
35use Digest::MD5 ();
33 36
34# configure various modules to our taste 37# configure various modules to our taste
35# 38#
36$Storable::canonical = 1; # reduce rsync transfers 39$Storable::canonical = 1; # reduce rsync transfers
37Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 40Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
… …
49our %COMMAND = (); 52our %COMMAND = ();
50our %COMMAND_TIME = (); 53our %COMMAND_TIME = ();
51 54
52our @EXTS = (); # list of extension package names 55our @EXTS = (); # list of extension package names
53our %EXTCMD = (); 56our %EXTCMD = ();
57our %EXTICMD = ();
54our %EXT_CORO = (); # coroutines bound to extensions 58our %EXT_CORO = (); # coroutines bound to extensions
55our %EXT_MAP = (); # pluggable maps 59our %EXT_MAP = (); # pluggable maps
56 60
57our $RELOAD; # number of reloads so far 61our $RELOAD; # number of reloads so far
58our @EVENT; 62our @EVENT;
… …
76our $NEXT_TICK; 80our $NEXT_TICK;
77our $NOW; 81our $NOW;
78our $USE_FSYNC = 1; # use fsync to write maps - default off 82our $USE_FSYNC = 1; # use fsync to write maps - default off
79 83
80our $BDB_POLL_WATCHER; 84our $BDB_POLL_WATCHER;
85our $BDB_DEADLOCK_WATCHER;
86our $BDB_CHECKPOINT_WATCHER;
87our $BDB_TRICKLE_WATCHER;
81our $DB_ENV; 88our $DB_ENV;
82 89
83our %CFG; 90our %CFG;
84 91
85our $UPTIME; $UPTIME ||= time; 92our $UPTIME; $UPTIME ||= time;
86our $RUNTIME; 93our $RUNTIME;
87 94
88our %PLAYER; # all users 95our (%PLAYER, %PLAYER_LOADING); # all users
89our %MAP; # all maps 96our (%MAP, %MAP_LOADING ); # all maps
90our $LINK_MAP; # the special {link} map, which is always available 97our $LINK_MAP; # the special {link} map, which is always available
91 98
92# used to convert map paths into valid unix filenames by replacing / by ∕ 99# used to convert map paths into valid unix filenames by replacing / by ∕
93our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 100our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
101
102our $LOAD; # a number between 0 (idle) and 1 (too many objects)
103our $LOADAVG; # same thing, but with alpha-smoothing
104our $tick_start; # for load detecting purposes
94 105
95binmode STDOUT; 106binmode STDOUT;
96binmode STDERR; 107binmode STDERR;
97 108
98# read virtual server time, if available 109# read virtual server time, if available
… …
139 150
140=item $cf::TICK 151=item $cf::TICK
141 152
142The interval between server ticks, in seconds. 153The interval between server ticks, in seconds.
143 154
155=item $cf::LOADAVG
156
157The current CPU load on the server (alpha-smoothed), as a value between 0
158(none) and 1 (overloaded), indicating how much time is spent on processing
159objects per tick. Healthy values are < 0.5.
160
161=item $cf::LOAD
162
163The raw value load value from the last tick.
164
144=item %cf::CFG 165=item %cf::CFG
145 166
146Configuration for the server, loaded from C</etc/crossfire/config>, or 167Configuration for the server, loaded from C</etc/crossfire/config>, or
147from wherever your confdir points to. 168from wherever your confdir points to.
148 169
… …
150 171
151These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 172These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
152returns directly I<after> the tick processing (and consequently, can only wake one process 173returns directly I<after> the tick processing (and consequently, can only wake one process
153per tick), while cf::wait_for_tick wakes up all waiters after tick processing. 174per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
154 175
176=item @cf::INVOKE_RESULTS
177
178This array contains the results of the last C<invoke ()> call. When
179C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
180that call.
181
155=back 182=back
156 183
157=cut 184=cut
158 185
159BEGIN { 186BEGIN {
… …
163 $msg .= "\n" 190 $msg .= "\n"
164 unless $msg =~ /\n$/; 191 unless $msg =~ /\n$/;
165 192
166 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 193 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
167 194
168 utf8::encode $msg;
169 LOG llevError, $msg; 195 LOG llevError, $msg;
170 }; 196 };
171} 197}
172 198
173@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 199@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
174@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 200@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
175@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 201@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
176@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 202@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
177@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable'; 203@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
204@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
178@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 205@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
179 206
180# we bless all objects into (empty) derived classes to force a method lookup 207# we bless all objects into (empty) derived classes to force a method lookup
181# within the Safe compartment. 208# within the Safe compartment.
182for my $pkg (qw( 209for my $pkg (qw(
183 cf::global cf::attachable 210 cf::global cf::attachable
… …
191} 218}
192 219
193$Event::DIED = sub { 220$Event::DIED = sub {
194 warn "error in event callback: @_"; 221 warn "error in event callback: @_";
195}; 222};
223
224#############################################################################
196 225
197=head2 UTILITY FUNCTIONS 226=head2 UTILITY FUNCTIONS
198 227
199=over 4 228=over 4
200 229
… …
219 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 248 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
220 $d 249 $d
221 } || "[unable to dump $_[0]: '$@']"; 250 } || "[unable to dump $_[0]: '$@']";
222} 251}
223 252
224use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working
225
226=item $ref = cf::from_json $json 253=item $ref = cf::from_json $json
227 254
228Converts a JSON string into the corresponding perl data structure. 255Converts a JSON string into the corresponding perl data structure.
229 256
230=item $json = cf::to_json $ref 257=item $json = cf::to_json $ref
231 258
232Converts a perl data structure into its JSON representation. 259Converts a perl data structure into its JSON representation.
260
261=cut
262
263our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
264
265sub to_json ($) { $json_coder->encode ($_[0]) }
266sub from_json ($) { $json_coder->decode ($_[0]) }
233 267
234=item cf::lock_wait $string 268=item cf::lock_wait $string
235 269
236Wait until the given lock is available. See cf::lock_acquire. 270Wait until the given lock is available. See cf::lock_acquire.
237 271
… …
240Wait until the given lock is available and then acquires it and returns 274Wait until the given lock is available and then acquires it and returns
241a Coro::guard object. If the guard object gets destroyed (goes out of scope, 275a Coro::guard object. If the guard object gets destroyed (goes out of scope,
242for example when the coroutine gets canceled), the lock is automatically 276for example when the coroutine gets canceled), the lock is automatically
243returned. 277returned.
244 278
279Locks are *not* recursive, locking from the same coro twice results in a
280deadlocked coro.
281
245Lock names should begin with a unique identifier (for example, cf::map::find 282Lock names should begin with a unique identifier (for example, cf::map::find
246uses map_find and cf::map::load uses map_load). 283uses map_find and cf::map::load uses map_load).
247 284
248=item $locked = cf::lock_active $string 285=item $locked = cf::lock_active $string
249 286
250Return true if the lock is currently active, i.e. somebody has locked it. 287Return true if the lock is currently active, i.e. somebody has locked it.
251 288
252=cut 289=cut
253 290
254our %LOCK; 291our %LOCK;
292our %LOCKER;#d#
255 293
256sub lock_wait($) { 294sub lock_wait($) {
257 my ($key) = @_; 295 my ($key) = @_;
296
297 if ($LOCKER{$key} == $Coro::current) {#d#
298 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
299 return;#d#
300 }#d#
258 301
259 # wait for lock, if any 302 # wait for lock, if any
260 while ($LOCK{$key}) { 303 while ($LOCK{$key}) {
261 push @{ $LOCK{$key} }, $Coro::current; 304 push @{ $LOCK{$key} }, $Coro::current;
262 Coro::schedule; 305 Coro::schedule;
… …
268 311
269 # wait, to be sure we are not locked 312 # wait, to be sure we are not locked
270 lock_wait $key; 313 lock_wait $key;
271 314
272 $LOCK{$key} = []; 315 $LOCK{$key} = [];
316 $LOCKER{$key} = $Coro::current;#d#
273 317
274 Coro::guard { 318 Coro::guard {
319 delete $LOCKER{$key};#d#
275 # wake up all waiters, to be on the safe side 320 # wake up all waiters, to be on the safe side
276 $_->ready for @{ delete $LOCK{$key} }; 321 $_->ready for @{ delete $LOCK{$key} };
277 } 322 }
278} 323}
279 324
… …
291 }; 336 };
292 $TICK_WATCHER->stop; 337 $TICK_WATCHER->stop;
293 $guard 338 $guard
294} 339}
295 340
341=item cf::get_slot $time[, $priority[, $name]]
342
343Allocate $time seconds of blocking CPU time at priority C<$priority>:
344This call blocks and returns only when you have at least C<$time> seconds
345of cpu time till the next tick. The slot is only valid till the next cede.
346
347The optional C<$name> can be used to identify the job to run. It might be
348used for statistical purposes and should identify the same time-class.
349
350Useful for short background jobs.
351
352=cut
353
354our @SLOT_QUEUE;
355our $SLOT_QUEUE;
356
357$SLOT_QUEUE->cancel if $SLOT_QUEUE;
358$SLOT_QUEUE = Coro::async {
359 $Coro::current->desc ("timeslot manager");
360
361 my $signal = new Coro::Signal;
362
363 while () {
364 next_job:
365 my $avail = cf::till_tick;
366 if ($avail > 0.01) {
367 for (0 .. $#SLOT_QUEUE) {
368 if ($SLOT_QUEUE[$_][0] < $avail) {
369 my $job = splice @SLOT_QUEUE, $_, 1, ();
370 $job->[2]->send;
371 Coro::cede;
372 goto next_job;
373 }
374 }
375 }
376
377 if (@SLOT_QUEUE) {
378 # we do not use wait_For_tick() as it returns immediately when tick is inactive
379 push @cf::WAIT_FOR_TICK, $signal;
380 $signal->wait;
381 } else {
382 Coro::schedule;
383 }
384 }
385};
386
387sub get_slot($;$$) {
388 my ($time, $pri, $name) = @_;
389
390 $time = $TICK * .6 if $time > $TICK * .6;
391 my $sig = new Coro::Signal;
392
393 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
394 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
395 $SLOT_QUEUE->ready;
396 $sig->wait;
397}
398
296=item cf::async { BLOCK } 399=item cf::async { BLOCK }
297 400
298Currently the same as Coro::async_pool, meaning you cannot use 401Currently the same as Coro::async_pool, meaning you cannot use
299C<on_destroy>, C<join> or other gimmicks on these coroutines. The only 402C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
300thing you are allowed to do is call C<prio> on it. 403thing you are allowed to do is call C<prio> on it.
… …
303 406
304BEGIN { *async = \&Coro::async_pool } 407BEGIN { *async = \&Coro::async_pool }
305 408
306=item cf::sync_job { BLOCK } 409=item cf::sync_job { BLOCK }
307 410
308The design of crossfire+ requires that the main coro ($Coro::main) is 411The design of Crossfire TRT requires that the main coroutine ($Coro::main)
309always able to handle events or runnable, as crossfire+ is only partly 412is always able to handle events or runnable, as Crossfire TRT is only
310reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable. 413partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
414acceptable.
311 415
312If it must be done, put the blocking parts into C<sync_job>. This will run 416If it must be done, put the blocking parts into C<sync_job>. This will run
313the given BLOCK in another coroutine while waiting for the result. The 417the given BLOCK in another coroutine while waiting for the result. The
314server will be frozen during this time, so the block should either finish 418server will be frozen during this time, so the block should either finish
315fast or be very important. 419fast or be very important.
… …
318 422
319sub sync_job(&) { 423sub sync_job(&) {
320 my ($job) = @_; 424 my ($job) = @_;
321 425
322 if ($Coro::current == $Coro::main) { 426 if ($Coro::current == $Coro::main) {
427 my $time = Event::time;
428
323 # this is the main coro, too bad, we have to block 429 # this is the main coro, too bad, we have to block
324 # till the operation succeeds, freezing the server :/ 430 # till the operation succeeds, freezing the server :/
325 431
326 # TODO: use suspend/resume instead 432 # TODO: use suspend/resume instead
327 # (but this is cancel-safe) 433 # (but this is cancel-safe)
… …
329 435
330 my $busy = 1; 436 my $busy = 1;
331 my @res; 437 my @res;
332 438
333 (async { 439 (async {
440 $Coro::current->desc ("sync job coro");
334 @res = eval { $job->() }; 441 @res = eval { $job->() };
335 warn $@ if $@; 442 warn $@ if $@;
336 undef $busy; 443 undef $busy;
337 })->prio (Coro::PRIO_MAX); 444 })->prio (Coro::PRIO_MAX);
338 445
339 while ($busy) { 446 while ($busy) {
340 Coro::cede or Event::one_event; 447 Coro::cede or Event::one_event;
341 } 448 }
449
450 $time = Event::time - $time;
451
452 LOG llevError | logBacktrace, Carp::longmess "long sync job"
453 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
454
455 $tick_start += $time; # do not account sync jobs to server load
342 456
343 wantarray ? @res : $res[0] 457 wantarray ? @res : $res[0]
344 } else { 458 } else {
345 # we are in another coroutine, how wonderful, everything just works 459 # we are in another coroutine, how wonderful, everything just works
346 460
… …
366 $EXT_CORO{$coro+0} = $coro; 480 $EXT_CORO{$coro+0} = $coro;
367 481
368 $coro 482 $coro
369} 483}
370 484
371sub write_runtime { 485=item fork_call { }, $args
372 my $guard = cf::lock_acquire "write_runtime";
373 486
374 my $runtime = "$LOCALDIR/runtime"; 487Executes the given code block with the given arguments in a seperate
488process, returning the results. Everything must be serialisable with
489Coro::Storable. May, of course, block. Note that the executed sub may
490never block itself or use any form of Event handling.
375 491
376 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 492=cut
377 or return;
378 493
379 my $value = $cf::RUNTIME + 90 + 10; 494sub fork_call(&@) {
380 # 10 is the runtime save interval, for a monotonic clock 495 my ($cb, @args) = @_;
381 # 60 allows for the watchdog to kill the server.
382 496
383 (aio_write $fh, 0, (length $value), $value, 0) <= 0 497 # we seemingly have to make a local copy of the whole thing,
384 and return; 498 # otherwise perl prematurely frees the stuff :/
499 # TODO: investigate and fix (likely this will be rather laborious)
385 500
386 # always fsync - this file is important 501 my @res = Coro::Util::fork_eval {
387 aio_fsync $fh 502 reset_signals;
388 and return; 503 &$cb
504 }, @args;
389 505
390 close $fh 506 wantarray ? @res : $res[-1]
391 or return; 507}
392 508
393 aio_rename "$runtime~", $runtime 509=item $value = cf::db_get $family => $key
394 and return;
395 510
511Returns a single value from the environment database.
512
513=item cf::db_put $family => $key => $value
514
515Stores the given C<$value> in the family. It can currently store binary
516data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
517
518=item $db = cf::db_table "name"
519
520Create and/or open a new database table. The string must not be "db" and must be unique
521within each server.
522
523=cut
524
525sub db_table($) {
526 my ($name) = @_;
527 my $db = BDB::db_create $DB_ENV;
528
529 eval {
530 $db->set_flags (BDB::CHKSUM);
531
532 utf8::encode $name;
533 BDB::db_open $db, undef, $name, undef, BDB::BTREE,
534 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
535 cf::cleanup "db_open(db): $!" if $!;
536 };
537 cf::cleanup "db_open(db): $@" if $@;
538
539 $db
540}
541
542our $DB;
543
544sub db_init {
545 cf::sync_job {
546 $DB ||= db_table "db";
547 };
548}
549
550sub db_get($$) {
551 my $key = "$_[0]/$_[1]";
552
553 cf::sync_job {
554 BDB::db_get $DB, undef, $key, my $data;
555
556 $! ? ()
557 : $data
396 1 558 }
559}
560
561sub db_put($$$) {
562 BDB::dbreq_pri 4;
563 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
564}
565
566=item cf::cache $id => [$paths...], $processversion => $process
567
568Generic caching function that returns the value of the resource $id,
569caching and regenerating as required.
570
571This function can block.
572
573=cut
574
575sub cache {
576 my ($id, $src, $processversion, $process) = @_;
577
578 my $meta =
579 join "\x00",
580 $processversion,
581 map {
582 aio_stat $_
583 and Carp::croak "$_: $!";
584
585 ($_, (stat _)[7,9])
586 } @$src;
587
588 my $dbmeta = db_get cache => "$id/meta";
589 if ($dbmeta ne $meta) {
590 # changed, we may need to process
591
592 my @data;
593 my $md5;
594
595 for (0 .. $#$src) {
596 0 <= aio_load $src->[$_], $data[$_]
597 or Carp::croak "$src->[$_]: $!";
598 }
599
600 # if processing is expensive, check
601 # checksum first
602 if (1) {
603 $md5 =
604 join "\x00",
605 $processversion,
606 map {
607 cf::cede_to_tick;
608 ($src->[$_], Digest::MD5::md5_hex $data[$_])
609 } 0.. $#$src;
610
611
612 my $dbmd5 = db_get cache => "$id/md5";
613 if ($dbmd5 eq $md5) {
614 db_put cache => "$id/meta", $meta;
615
616 return db_get cache => "$id/data";
617 }
618 }
619
620 my $t1 = Time::HiRes::time;
621 my $data = $process->(\@data);
622 my $t2 = Time::HiRes::time;
623
624 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
625
626 db_put cache => "$id/data", $data;
627 db_put cache => "$id/md5" , $md5;
628 db_put cache => "$id/meta", $meta;
629
630 return $data;
631 }
632
633 db_get cache => "$id/data"
397} 634}
398 635
399=item cf::datalog type => key => value, ... 636=item cf::datalog type => key => value, ...
400 637
401Log a datalog packet of the given type with the given key-value pairs. 638Log a datalog packet of the given type with the given key-value pairs.
… …
419attach callbacks/event handlers (a collection of which is called an "attachment") 656attach callbacks/event handlers (a collection of which is called an "attachment")
420to it. All such attachable objects support the following methods. 657to it. All such attachable objects support the following methods.
421 658
422In the following description, CLASS can be any of C<global>, C<object> 659In the following description, CLASS can be any of C<global>, C<object>
423C<player>, C<client> or C<map> (i.e. the attachable objects in 660C<player>, C<client> or C<map> (i.e. the attachable objects in
424crossfire+). 661Crossfire TRT).
425 662
426=over 4 663=over 4
427 664
428=item $attachable->attach ($attachment, key => $value...) 665=item $attachable->attach ($attachment, key => $value...)
429 666
… …
592 $registry = $CB_TYPE[$object_type] ||= []; 829 $registry = $CB_TYPE[$object_type] ||= [];
593 830
594 } elsif ($type eq "subtype") { 831 } elsif ($type eq "subtype") {
595 defined $object_type or Carp::croak "subtype specified without type"; 832 defined $object_type or Carp::croak "subtype specified without type";
596 my $object_subtype = shift @arg; 833 my $object_subtype = shift @arg;
597 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 834 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
598 835
599 } elsif ($type eq "package") { 836 } elsif ($type eq "package") {
600 my $pkg = shift @arg; 837 my $pkg = shift @arg;
601 838
602 while (my ($name, $id) = each %cb_id) { 839 while (my ($name, $id) = each %cb_id) {
… …
631 _attach $registry, $klass, @attach; 868 _attach $registry, $klass, @attach;
632 } 869 }
633 870
634 $obj->{$name} = \%arg; 871 $obj->{$name} = \%arg;
635 } else { 872 } else {
636 warn "object uses attachment '$name' that is not available, postponing.\n"; 873 warn "object uses attachment '$name' which is not available, postponing.\n";
637 } 874 }
638 875
639 $obj->{_attachment}{$name} = undef; 876 $obj->{_attachment}{$name} = undef;
640} 877}
641 878
… …
643 if (ref $_[0]) { 880 if (ref $_[0]) {
644 _object_attach @_; 881 _object_attach @_;
645 } else { 882 } else {
646 _attach shift->_attach_registry, @_; 883 _attach shift->_attach_registry, @_;
647 } 884 }
885 _recalc_want;
648}; 886};
649 887
650# all those should be optimised 888# all those should be optimised
651sub cf::attachable::detach { 889sub cf::attachable::detach {
652 my ($obj, $name) = @_; 890 my ($obj, $name) = @_;
… …
655 delete $obj->{_attachment}{$name}; 893 delete $obj->{_attachment}{$name};
656 reattach ($obj); 894 reattach ($obj);
657 } else { 895 } else {
658 Carp::croak "cannot, currently, detach class attachments"; 896 Carp::croak "cannot, currently, detach class attachments";
659 } 897 }
898 _recalc_want;
660}; 899};
661 900
662sub cf::attachable::attached { 901sub cf::attachable::attached {
663 my ($obj, $name) = @_; 902 my ($obj, $name) = @_;
664 903
… …
679 "; 918 ";
680 die if $@; 919 die if $@;
681} 920}
682 921
683our $override; 922our $override;
684our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 923our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
685 924
686sub override { 925sub override {
687 $override = 1; 926 $override = 1;
688 @invoke_results = (); 927 @INVOKE_RESULTS = (@_);
689} 928}
690 929
691sub do_invoke { 930sub do_invoke {
692 my $event = shift; 931 my $event = shift;
693 my $callbacks = shift; 932 my $callbacks = shift;
694 933
695 @invoke_results = (); 934 @INVOKE_RESULTS = ();
696 935
697 local $override; 936 local $override;
698 937
699 for (@$callbacks) { 938 for (@$callbacks) {
700 eval { &{$_->[1]} }; 939 eval { &{$_->[1]} };
… …
717 956
718Generate an object-specific event with the given arguments. 957Generate an object-specific event with the given arguments.
719 958
720This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be 959This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
721removed in future versions), and there is no public API to access override 960removed in future versions), and there is no public API to access override
722results (if you must, access C<@cf::invoke_results> directly). 961results (if you must, access C<@cf::INVOKE_RESULTS> directly).
723 962
724=back 963=back
725 964
726=cut 965=cut
727 966
728############################################################################# 967#############################################################################
729# object support 968# object support
969#
970
971sub _can_merge {
972 my ($ob1, $ob2) = @_;
973
974 local $Storable::canonical = 1;
975 my $fob1 = Storable::freeze $ob1;
976 my $fob2 = Storable::freeze $ob2;
977
978 $fob1 eq $fob2
979}
730 980
731sub reattach { 981sub reattach {
732 # basically do the same as instantiate, without calling instantiate 982 # basically do the same as instantiate, without calling instantiate
733 my ($obj) = @_; 983 my ($obj) = @_;
734 984
… …
781sub object_freezer_save { 1031sub object_freezer_save {
782 my ($filename, $rdata, $objs) = @_; 1032 my ($filename, $rdata, $objs) = @_;
783 1033
784 sync_job { 1034 sync_job {
785 if (length $$rdata) { 1035 if (length $$rdata) {
1036 utf8::decode (my $decname = $filename);
786 warn sprintf "saving %s (%d,%d)\n", 1037 warn sprintf "saving %s (%d,%d)\n",
787 $filename, length $$rdata, scalar @$objs; 1038 $decname, length $$rdata, scalar @$objs;
788 1039
789 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1040 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
790 chmod SAVE_MODE, $fh; 1041 chmod SAVE_MODE, $fh;
791 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1042 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
792 aio_fsync $fh if $cf::USE_FSYNC; 1043 aio_fsync $fh if $cf::USE_FSYNC;
… …
811 } 1062 }
812 } else { 1063 } else {
813 aio_unlink $filename; 1064 aio_unlink $filename;
814 aio_unlink "$filename.pst"; 1065 aio_unlink "$filename.pst";
815 } 1066 }
816 } 1067 };
817} 1068}
818 1069
819sub object_freezer_as_string { 1070sub object_freezer_as_string {
820 my ($rdata, $objs) = @_; 1071 my ($rdata, $objs) = @_;
821 1072
… …
833 or return; 1084 or return;
834 1085
835 unless (aio_stat "$filename.pst") { 1086 unless (aio_stat "$filename.pst") {
836 (aio_load "$filename.pst", $av) >= 0 1087 (aio_load "$filename.pst", $av) >= 0
837 or return; 1088 or return;
1089
838 $av = eval { (Storable::thaw $av)->{objs} }; 1090 $av = eval { (Storable::thaw $av)->{objs} };
839 } 1091 }
840 1092
1093 utf8::decode (my $decname = $filename);
841 warn sprintf "loading %s (%d)\n", 1094 warn sprintf "loading %s (%d,%d)\n",
842 $filename, length $data, scalar @{$av || []};#d# 1095 $decname, length $data, scalar @{$av || []};
1096
843 return ($data, $av); 1097 ($data, $av)
844} 1098}
1099
1100=head2 COMMAND CALLBACKS
1101
1102=over 4
1103
1104=cut
845 1105
846############################################################################# 1106#############################################################################
847# command handling &c 1107# command handling &c
848 1108
849=item cf::register_command $name => \&callback($ob,$args); 1109=item cf::register_command $name => \&callback($ob,$args);
… …
862 push @{ $COMMAND{$name} }, [$caller, $cb]; 1122 push @{ $COMMAND{$name} }, [$caller, $cb];
863} 1123}
864 1124
865=item cf::register_extcmd $name => \&callback($pl,$packet); 1125=item cf::register_extcmd $name => \&callback($pl,$packet);
866 1126
867Register a callbackf ro execution when the client sends an extcmd packet. 1127Register a callback for execution when the client sends an (synchronous)
1128extcmd packet. Ext commands will be processed in the order they are
1129received by the server, like other user commands. The first argument is
1130the logged-in player. Ext commands can only be processed after a player
1131has logged in successfully.
868 1132
869If the callback returns something, it is sent back as if reply was being 1133If the callback returns something, it is sent back as if reply was being
870called. 1134called.
871 1135
1136=item cf::register_exticmd $name => \&callback($ns,$packet);
1137
1138Register a callback for execution when the client sends an (asynchronous)
1139exticmd packet. Exti commands are processed by the server as soon as they
1140are received, i.e. out of order w.r.t. other commands. The first argument
1141is a client socket. Exti commands can be received anytime, even before
1142log-in.
1143
1144If the callback returns something, it is sent back as if reply was being
1145called.
1146
872=cut 1147=cut
873 1148
874sub register_extcmd { 1149sub register_extcmd {
875 my ($name, $cb) = @_; 1150 my ($name, $cb) = @_;
876 1151
877 $EXTCMD{$name} = $cb; 1152 $EXTCMD{$name} = $cb;
1153}
1154
1155sub register_exticmd {
1156 my ($name, $cb) = @_;
1157
1158 $EXTICMD{$name} = $cb;
878} 1159}
879 1160
880cf::player->attach ( 1161cf::player->attach (
881 on_command => sub { 1162 on_command => sub {
882 my ($pl, $name, $params) = @_; 1163 my ($pl, $name, $params) = @_;
… …
891 cf::override; 1172 cf::override;
892 }, 1173 },
893 on_extcmd => sub { 1174 on_extcmd => sub {
894 my ($pl, $buf) = @_; 1175 my ($pl, $buf) = @_;
895 1176
896 my $msg = eval { from_json $buf }; 1177 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
897 1178
898 if (ref $msg) { 1179 if (ref $msg) {
1180 my ($type, $reply, @payload) =
1181 "ARRAY" eq ref $msg
1182 ? @$msg
1183 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1184
1185 my @reply;
1186
899 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1187 if (my $cb = $EXTCMD{$type}) {
900 if (my %reply = $cb->($pl, $msg)) { 1188 @reply = $cb->($pl, @payload);
901 $pl->ext_reply ($msg->{msgid}, %reply);
902 }
903 } 1189 }
1190
1191 $pl->ext_reply ($reply, @reply)
1192 if $reply;
1193
904 } else { 1194 } else {
905 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1195 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
906 } 1196 }
907 1197
908 cf::override; 1198 cf::override;
909 }, 1199 },
910); 1200);
911 1201
912sub load_extension {
913 my ($path) = @_;
914
915 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
916 my $base = $1;
917 my $pkg = $1;
918 $pkg =~ s/[^[:word:]]/_/g;
919 $pkg = "ext::$pkg";
920
921 warn "... loading '$path' into '$pkg'\n";
922
923 open my $fh, "<:utf8", $path
924 or die "$path: $!";
925
926 my $source =
927 "package $pkg; use strict; use utf8;\n"
928 . "#line 1 \"$path\"\n{\n"
929 . (do { local $/; <$fh> })
930 . "\n};\n1";
931
932 unless (eval $source) {
933 my $msg = $@ ? "$path: $@\n"
934 : "extension disabled.\n";
935 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
936 warn $@;
937 warn "mandatory extension failed to load, exiting.\n";
938 exit 1;
939 }
940 die $@;
941 }
942
943 push @EXTS, $pkg;
944}
945
946sub load_extensions { 1202sub load_extensions {
1203 cf::sync_job {
1204 my %todo;
1205
947 for my $ext (<$LIBDIR/*.ext>) { 1206 for my $path (<$LIBDIR/*.ext>) {
948 next unless -r $ext; 1207 next unless -r $path;
949 eval { 1208
950 load_extension $ext; 1209 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1210 my $base = $1;
1211 my $pkg = $1;
1212 $pkg =~ s/[^[:word:]]/_/g;
1213 $pkg = "ext::$pkg";
1214
1215 open my $fh, "<:utf8", $path
1216 or die "$path: $!";
1217
1218 my $source = do { local $/; <$fh> };
1219
1220 my %ext = (
1221 path => $path,
1222 base => $base,
1223 pkg => $pkg,
1224 );
1225
1226 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1227 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1228
1229 $ext{source} =
1230 "package $pkg; use strict; use utf8;\n"
1231 . "#line 1 \"$path\"\n{\n"
1232 . $source
1233 . "\n};\n1";
1234
1235 $todo{$base} = \%ext;
1236 }
1237
1238 my %done;
1239 while (%todo) {
1240 my $progress;
1241
1242 while (my ($k, $v) = each %todo) {
1243 for (split /,\s*/, $v->{meta}{depends}) {
1244 goto skip
1245 unless exists $done{$_};
1246 }
1247
1248 warn "... loading '$k' into '$v->{pkg}'\n";
1249
1250 unless (eval $v->{source}) {
1251 my $msg = $@ ? "$v->{path}: $@\n"
1252 : "$v->{base}: extension inactive.\n";
1253
1254 if (exists $v->{meta}{mandatory}) {
1255 warn $msg;
1256 warn "mandatory extension failed to load, exiting.\n";
1257 exit 1;
1258 }
1259
1260 warn $msg;
1261 }
1262
1263 $done{$k} = delete $todo{$k};
1264 push @EXTS, $v->{pkg};
1265 $progress = 1;
951 1 1266 }
952 } or warn "$ext not loaded: $@"; 1267
1268 skip:
1269 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1270 unless $progress;
1271 }
953 } 1272 };
954} 1273}
955 1274
956############################################################################# 1275#############################################################################
957 1276
1277=back
1278
958=head2 CORE EXTENSIONS 1279=head2 CORE EXTENSIONS
959 1280
960Functions and methods that extend core crossfire objects. 1281Functions and methods that extend core crossfire objects.
961 1282
962=cut 1283=cut
… …
966use Coro::AIO; 1287use Coro::AIO;
967 1288
968=head3 cf::player 1289=head3 cf::player
969 1290
970=over 4 1291=over 4
1292
1293=item cf::player::num_playing
1294
1295Returns the official number of playing players, as per the Crossfire metaserver rules.
1296
1297=cut
1298
1299sub num_playing {
1300 scalar grep
1301 $_->ob->map
1302 && !$_->hidden
1303 && !$_->ob->flag (cf::FLAG_WIZ),
1304 cf::player::list
1305}
971 1306
972=item cf::player::find $login 1307=item cf::player::find $login
973 1308
974Returns the given player object, loading it if necessary (might block). 1309Returns the given player object, loading it if necessary (might block).
975 1310
… …
1011 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst"; 1346 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1012 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata"; 1347 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1013 aio_unlink +(playerdir $login) . "/$login.pl.pst"; 1348 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1014 aio_unlink +(playerdir $login) . "/$login.pl"; 1349 aio_unlink +(playerdir $login) . "/$login.pl";
1015 1350
1016 my $pl = load_pl path $login 1351 my $f = new_from_file cf::object::thawer path $login
1017 or return; 1352 or return;
1353
1354 my $pl = cf::player::load_pl $f
1355 or return;
1356 local $cf::PLAYER_LOADING{$login} = $pl;
1357 $f->resolve_delayed_derefs;
1018 $cf::PLAYER{$login} = $pl 1358 $cf::PLAYER{$login} = $pl
1019 } 1359 }
1020 } 1360 }
1021} 1361}
1022 1362
… …
1032 1372
1033 aio_mkdir playerdir $pl, 0770; 1373 aio_mkdir playerdir $pl, 0770;
1034 $pl->{last_save} = $cf::RUNTIME; 1374 $pl->{last_save} = $cf::RUNTIME;
1035 1375
1036 $pl->save_pl ($path); 1376 $pl->save_pl ($path);
1037 Coro::cede; 1377 cf::cede_to_tick;
1038} 1378}
1039 1379
1040sub new($) { 1380sub new($) {
1041 my ($login) = @_; 1381 my ($login) = @_;
1042 1382
… …
1046 $self->{deny_save} = 1; 1386 $self->{deny_save} = 1;
1047 1387
1048 $cf::PLAYER{$login} = $self; 1388 $cf::PLAYER{$login} = $self;
1049 1389
1050 $self 1390 $self
1391}
1392
1393=item $player->send_msg ($channel, $msg, $color, [extra...])
1394
1395=cut
1396
1397sub send_msg {
1398 my $ns = shift->ns
1399 or return;
1400 $ns->send_msg (@_);
1051} 1401}
1052 1402
1053=item $pl->quit_character 1403=item $pl->quit_character
1054 1404
1055Nukes the player without looking back. If logged in, the connection will 1405Nukes the player without looking back. If logged in, the connection will
… …
1110 or return []; 1460 or return [];
1111 1461
1112 my @logins; 1462 my @logins;
1113 1463
1114 for my $login (@$dirs) { 1464 for my $login (@$dirs) {
1465 my $path = path $login;
1466
1467 # a .pst is a dead give-away for a valid player
1468 unless (-e "$path.pst") {
1115 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1469 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1116 aio_read $fh, 0, 512, my $buf, 0 or next; 1470 aio_read $fh, 0, 512, my $buf, 0 or next;
1117 $buf !~ /^password -------------$/m or next; # official not-valid tag 1471 $buf !~ /^password -------------$/m or next; # official not-valid tag
1472 }
1118 1473
1119 utf8::decode $login; 1474 utf8::decode $login;
1120 push @logins, $login; 1475 push @logins, $login;
1121 } 1476 }
1122 1477
… …
1149 } 1504 }
1150 1505
1151 \@paths 1506 \@paths
1152} 1507}
1153 1508
1509=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1510
1511Expand crossfire pod fragments into protocol xml.
1512
1513=cut
1514
1515sub expand_cfpod {
1516 ((my $self), (local $_)) = @_;
1517
1518 # escape & and <
1519 s/&/&amp;/g;
1520 s/(?<![BIUGHT])</&lt;/g;
1521
1522 # this is buggy, it needs to properly take care of nested <'s
1523
1524 1 while
1525 # replace B<>, I<>, U<> etc.
1526 s/B<([^\>]*)>/<b>$1<\/b>/
1527 || s/I<([^\>]*)>/<i>$1<\/i>/
1528 || s/U<([^\>]*)>/<u>$1<\/u>/
1529 || s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/
1530 # replace G<male|female> tags
1531 || s{G<([^>|]*)\|([^>]*)>}{
1532 $self->gender ? $2 : $1
1533 }ge
1534 # replace H<hint text>
1535 || s{H<([^\>]*)>}
1536 {
1537 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
1538 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1539 "")
1540 [$self->{hintmode}]
1541 }ge;
1542
1543 # create single paragraphs (very hackish)
1544 s/(?<=\S)\n(?=\w)/ /g;
1545
1546 # compress some whitespace
1547 s/\s+\n/\n/g; # ws line-ends
1548 s/\n\n+/\n/g; # double lines
1549 s/^\n+//; # beginning lines
1550 s/\n+$//; # ending lines
1551
1552 $_
1553}
1554
1555sub hintmode {
1556 $_[0]{hintmode} = $_[1] if @_ > 1;
1557 $_[0]{hintmode}
1558}
1559
1154=item $player->ext_reply ($msgid, %msg) 1560=item $player->ext_reply ($msgid, @msg)
1155 1561
1156Sends an ext reply to the player. 1562Sends an ext reply to the player.
1157 1563
1158=cut 1564=cut
1159 1565
1160sub ext_reply($$%) { 1566sub ext_reply($$@) {
1161 my ($self, $id, %msg) = @_; 1567 my ($self, $id, @msg) = @_;
1162 1568
1163 $msg{msgid} = $id; 1569 $self->ns->ext_reply ($id, @msg)
1164
1165 $self->send ("ext " . cf::to_json \%msg);
1166} 1570}
1167 1571
1168=item $player->ext_event ($type, %msg) 1572=item $player->ext_msg ($type, @msg)
1169 1573
1170Sends an ext event to the client. 1574Sends an ext event to the client.
1171 1575
1172=cut 1576=cut
1173 1577
1174sub ext_event($$%) { 1578sub ext_msg($$@) {
1175 my ($self, $type, %msg) = @_; 1579 my ($self, $type, @msg) = @_;
1176 1580
1177 $self->ns->ext_event ($type, %msg); 1581 $self->ns->ext_msg ($type, @msg);
1178} 1582}
1179 1583
1180=head3 cf::region 1584=head3 cf::region
1181 1585
1182=over 4 1586=over 4
… …
1185 1589
1186package cf::region; 1590package cf::region;
1187 1591
1188=item cf::region::find_by_path $path 1592=item cf::region::find_by_path $path
1189 1593
1190Tries to decuce the probable region for a map knowing only its path. 1594Tries to decuce the likely region for a map knowing only its path.
1191 1595
1192=cut 1596=cut
1193 1597
1194sub find_by_path($) { 1598sub find_by_path($) {
1195 my ($path) = @_; 1599 my ($path) = @_;
1196 1600
1197 my ($match, $specificity); 1601 my ($match, $specificity);
1198 1602
1199 for my $region (list) { 1603 for my $region (list) {
1200 if ($region->match && $path =~ $region->match) { 1604 if ($region->{match} && $path =~ $region->{match}) {
1201 ($match, $specificity) = ($region, $region->specificity) 1605 ($match, $specificity) = ($region, $region->specificity)
1202 if $region->specificity > $specificity; 1606 if $region->specificity > $specificity;
1203 } 1607 }
1204 } 1608 }
1205 1609
… …
1269 my ($self, $merge) = @_; 1673 my ($self, $merge) = @_;
1270 1674
1271 # we have to keep some variables in memory intact 1675 # we have to keep some variables in memory intact
1272 local $self->{path}; 1676 local $self->{path};
1273 local $self->{load_path}; 1677 local $self->{load_path};
1274 local $self->{deny_save};
1275 local $self->{deny_reset};
1276 1678
1277 $self->SUPER::thawer_merge ($merge); 1679 $self->SUPER::thawer_merge ($merge);
1278} 1680}
1279 1681
1280sub normalise { 1682sub normalise {
… …
1327 $self->init; # pass $1 etc. 1729 $self->init; # pass $1 etc.
1328 return $self; 1730 return $self;
1329 } 1731 }
1330 } 1732 }
1331 1733
1332 Carp::carp "unable to resolve path '$path' (base '$base')."; 1734 Carp::cluck "unable to resolve path '$path' (base '$base').";
1333 () 1735 ()
1334} 1736}
1335 1737
1336sub init { 1738sub init {
1337 my ($self) = @_; 1739 my ($self) = @_;
… …
1380 1782
1381 $_->change_map_light ($change) 1783 $_->change_map_light ($change)
1382 for grep $_->outdoor, values %cf::MAP; 1784 for grep $_->outdoor, values %cf::MAP;
1383} 1785}
1384 1786
1787sub decay_objects {
1788 my ($self) = @_;
1789
1790 return if $self->{deny_reset};
1791
1792 $self->do_decay_objects;
1793}
1794
1385sub unlink_save { 1795sub unlink_save {
1386 my ($self) = @_; 1796 my ($self) = @_;
1387 1797
1388 utf8::encode (my $save = $self->save_path); 1798 utf8::encode (my $save = $self->save_path);
1389 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save; 1799 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
… …
1392 1802
1393sub load_header_from($) { 1803sub load_header_from($) {
1394 my ($self, $path) = @_; 1804 my ($self, $path) = @_;
1395 1805
1396 utf8::encode $path; 1806 utf8::encode $path;
1397 #aio_open $path, O_RDONLY, 0 1807 my $f = new_from_file cf::object::thawer $path
1398 # or return;
1399
1400 $self->_load_header ($path)
1401 or return; 1808 or return;
1809
1810 $self->_load_header ($f)
1811 or return;
1812
1813 local $MAP_LOADING{$self->{path}} = $self;
1814 $f->resolve_delayed_derefs;
1402 1815
1403 $self->{load_path} = $path; 1816 $self->{load_path} = $path;
1404 1817
1405 1 1818 1
1406} 1819}
… …
1445 $self->load_header_orig 1858 $self->load_header_orig
1446 or return; 1859 or return;
1447 $self->prepare_orig; 1860 $self->prepare_orig;
1448 } 1861 }
1449 1862
1863 $self->{deny_reset} = 1
1864 if $self->no_reset;
1865
1450 $self->default_region (cf::region::find_by_path $self->{path}) 1866 $self->default_region (cf::region::find_by_path $self->{path})
1451 unless $self->default_region; 1867 unless $self->default_region;
1452 1868
1453 1 1869 1
1454} 1870}
… …
1457sub find { 1873sub find {
1458 my ($path, $origin) = @_; 1874 my ($path, $origin) = @_;
1459 1875
1460 $path = normalise $path, $origin && $origin->path; 1876 $path = normalise $path, $origin && $origin->path;
1461 1877
1878 cf::lock_wait "map_data:$path";#d#remove
1462 cf::lock_wait "map_find:$path"; 1879 cf::lock_wait "map_find:$path";
1463 1880
1464 $cf::MAP{$path} || do { 1881 $cf::MAP{$path} || do {
1465 my $guard = cf::lock_acquire "map_find:$path"; 1882 my $guard1 = cf::lock_acquire "map_find:$path";
1883 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1884
1466 my $map = new_from_path cf::map $path 1885 my $map = new_from_path cf::map $path
1467 or return; 1886 or return;
1468 1887
1469 $map->{last_save} = $cf::RUNTIME; 1888 $map->{last_save} = $cf::RUNTIME;
1470 1889
1471 $map->load_header 1890 $map->load_header
1472 or return; 1891 or return;
1473 1892
1474 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?) 1893 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1475 # doing this can freeze the server in a sync job, obviously 1894 # doing this can freeze the server in a sync job, obviously
1476 #$cf::WAIT_FOR_TICK->wait; 1895 #$cf::WAIT_FOR_TICK->wait;
1896 undef $guard1;
1897 undef $guard2;
1477 $map->reset; 1898 $map->reset;
1478 undef $guard;
1479 return find $path; 1899 return find $path;
1480 } 1900 }
1481 1901
1482 $cf::MAP{$path} = $map 1902 $cf::MAP{$path} = $map
1483 } 1903 }
… …
1492 local $self->{deny_reset} = 1; # loading can take a long time 1912 local $self->{deny_reset} = 1; # loading can take a long time
1493 1913
1494 my $path = $self->{path}; 1914 my $path = $self->{path};
1495 1915
1496 { 1916 {
1497 my $guard = cf::lock_acquire "map_load:$path"; 1917 my $guard = cf::lock_acquire "map_data:$path";
1498 1918
1919 return unless $self->valid;
1499 return if $self->in_memory != cf::MAP_SWAPPED; 1920 return unless $self->in_memory == cf::MAP_SWAPPED;
1500 1921
1501 $self->in_memory (cf::MAP_LOADING); 1922 $self->in_memory (cf::MAP_LOADING);
1502 1923
1503 $self->alloc; 1924 $self->alloc;
1504 1925
1505 $self->pre_load; 1926 $self->pre_load;
1506 Coro::cede; 1927 cf::cede_to_tick;
1507 1928
1929 my $f = new_from_file cf::object::thawer $self->{load_path};
1930 $f->skip_block;
1508 $self->_load_objects ($self->{load_path}, 1) 1931 $self->_load_objects ($f)
1509 or return; 1932 or return;
1510 1933
1511 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 1934 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1512 if delete $self->{load_original}; 1935 if delete $self->{load_original};
1513 1936
1514 if (my $uniq = $self->uniq_path) { 1937 if (my $uniq = $self->uniq_path) {
1515 utf8::encode $uniq; 1938 utf8::encode $uniq;
1516 if (aio_open $uniq, O_RDONLY, 0) { 1939 unless (aio_stat $uniq) {
1940 if (my $f = new_from_file cf::object::thawer $uniq) {
1517 $self->clear_unique_items; 1941 $self->clear_unique_items;
1518 $self->_load_objects ($uniq, 0); 1942 $self->_load_objects ($f);
1943 $f->resolve_delayed_derefs;
1944 }
1519 } 1945 }
1520 } 1946 }
1521 1947
1522 Coro::cede; 1948 $f->resolve_delayed_derefs;
1949
1950 cf::cede_to_tick;
1523 # now do the right thing for maps 1951 # now do the right thing for maps
1524 $self->link_multipart_objects; 1952 $self->link_multipart_objects;
1525 $self->difficulty ($self->estimate_difficulty) 1953 $self->difficulty ($self->estimate_difficulty)
1526 unless $self->difficulty; 1954 unless $self->difficulty;
1527 Coro::cede; 1955 cf::cede_to_tick;
1528 1956
1529 unless ($self->{deny_activate}) { 1957 unless ($self->{deny_activate}) {
1530 $self->decay_objects; 1958 $self->decay_objects;
1531 $self->fix_auto_apply; 1959 $self->fix_auto_apply;
1532 $self->update_buttons; 1960 $self->update_buttons;
1533 Coro::cede; 1961 cf::cede_to_tick;
1534 $self->set_darkness_map; 1962 $self->set_darkness_map;
1535 Coro::cede; 1963 cf::cede_to_tick;
1536 $self->activate; 1964 $self->activate;
1537 } 1965 }
1966
1967 $self->{last_save} = $cf::RUNTIME;
1968 $self->last_access ($cf::RUNTIME);
1538 1969
1539 $self->in_memory (cf::MAP_IN_MEMORY); 1970 $self->in_memory (cf::MAP_IN_MEMORY);
1540 } 1971 }
1541 1972
1542 $self->post_load; 1973 $self->post_load;
… …
1546 my ($self, $ob) = @_; 1977 my ($self, $ob) = @_;
1547 1978
1548 return find "~" . $ob->name . "/" . $self->{path} 1979 return find "~" . $ob->name . "/" . $self->{path}
1549 if $self->per_player; 1980 if $self->per_player;
1550 1981
1982# return find "?party/" . $ob->name . "/" . $self->{path}
1983# if $self->per_party;
1984
1551 $self 1985 $self
1552} 1986}
1553 1987
1554# find and load all maps in the 3x3 area around a map 1988# find and load all maps in the 3x3 area around a map
1555sub load_diag { 1989sub load_neighbours {
1556 my ($map) = @_; 1990 my ($map) = @_;
1557 1991
1558 my @diag; # diagonal neighbours 1992 my @neigh; # diagonal neighbours
1559 1993
1560 for (0 .. 3) { 1994 for (0 .. 3) {
1561 my $neigh = $map->tile_path ($_) 1995 my $neigh = $map->tile_path ($_)
1562 or next; 1996 or next;
1563 $neigh = find $neigh, $map 1997 $neigh = find $neigh, $map
1564 or next; 1998 or next;
1565 $neigh->load; 1999 $neigh->load;
1566 2000
2001 push @neigh,
1567 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 2002 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1568 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2003 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1569 } 2004 }
1570 2005
1571 for (@diag) { 2006 for (grep defined $_->[0], @neigh) {
2007 my ($path, $origin) = @$_;
1572 my $neigh = find @$_ 2008 my $neigh = find $path, $origin
1573 or next; 2009 or next;
1574 $neigh->load; 2010 $neigh->load;
1575 } 2011 }
1576} 2012}
1577 2013
… …
1582} 2018}
1583 2019
1584sub do_load_sync { 2020sub do_load_sync {
1585 my ($map) = @_; 2021 my ($map) = @_;
1586 2022
2023 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
2024 if $Coro::current == $Coro::main;
2025
1587 cf::sync_job { $map->load }; 2026 cf::sync_job { $map->load };
1588} 2027}
1589 2028
1590our %MAP_PREFETCH; 2029our %MAP_PREFETCH;
1591our $MAP_PREFETCHER = undef; 2030our $MAP_PREFETCHER = undef;
1592 2031
1593sub find_async { 2032sub find_async {
1594 my ($path, $origin) = @_; 2033 my ($path, $origin, $load) = @_;
1595 2034
1596 $path = normalise $path, $origin && $origin->{path}; 2035 $path = normalise $path, $origin && $origin->{path};
1597 2036
1598 if (my $map = $cf::MAP{$path}) { 2037 if (my $map = $cf::MAP{$path}) {
1599 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 2038 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY;
1600 } 2039 }
1601 2040
1602 undef $MAP_PREFETCH{$path}; 2041 $MAP_PREFETCH{$path} |= $load;
2042
1603 $MAP_PREFETCHER ||= cf::async { 2043 $MAP_PREFETCHER ||= cf::async {
2044 $Coro::current->{desc} = "map prefetcher";
2045
1604 while (%MAP_PREFETCH) { 2046 while (%MAP_PREFETCH) {
1605 for my $path (keys %MAP_PREFETCH) { 2047 while (my ($k, $v) = each %MAP_PREFETCH) {
1606 my $map = find $path 2048 if (my $map = find $k) {
1607 or next;
1608 $map->load; 2049 $map->load if $v;
2050 }
1609 2051
1610 delete $MAP_PREFETCH{$path}; 2052 delete $MAP_PREFETCH{$k};
1611 } 2053 }
1612 } 2054 }
1613 undef $MAP_PREFETCHER; 2055 undef $MAP_PREFETCHER;
1614 }; 2056 };
1615 $MAP_PREFETCHER->prio (6); 2057 $MAP_PREFETCHER->prio (6);
… …
1618} 2060}
1619 2061
1620sub save { 2062sub save {
1621 my ($self) = @_; 2063 my ($self) = @_;
1622 2064
1623 my $lock = cf::lock_acquire "map_data:" . $self->path; 2065 my $lock = cf::lock_acquire "map_data:$self->{path}";
1624 2066
1625 $self->{last_save} = $cf::RUNTIME; 2067 $self->{last_save} = $cf::RUNTIME;
1626 2068
1627 return unless $self->dirty; 2069 return unless $self->dirty;
1628 2070
… …
1634 return if $self->{deny_save}; 2076 return if $self->{deny_save};
1635 2077
1636 local $self->{last_access} = $self->last_access;#d# 2078 local $self->{last_access} = $self->last_access;#d#
1637 2079
1638 cf::async { 2080 cf::async {
2081 $Coro::current->{desc} = "map player save";
1639 $_->contr->save for $self->players; 2082 $_->contr->save for $self->players;
1640 }; 2083 };
1641 2084
1642 if ($uniq) { 2085 if ($uniq) {
1643 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2086 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
… …
1651 my ($self) = @_; 2094 my ($self) = @_;
1652 2095
1653 # save first because save cedes 2096 # save first because save cedes
1654 $self->save; 2097 $self->save;
1655 2098
1656 my $lock = cf::lock_acquire "map_data:" . $self->path; 2099 my $lock = cf::lock_acquire "map_data:$self->{path}";
1657 2100
1658 return if $self->players; 2101 return if $self->players;
1659 return if $self->in_memory != cf::MAP_IN_MEMORY; 2102 return if $self->in_memory != cf::MAP_IN_MEMORY;
1660 return if $self->{deny_save}; 2103 return if $self->{deny_save};
1661 2104
2105 $self->in_memory (cf::MAP_SWAPPED);
2106
2107 $self->deactivate;
2108 $_->clear_links_to ($self) for values %cf::MAP;
1662 $self->clear; 2109 $self->clear;
1663 $self->in_memory (cf::MAP_SWAPPED);
1664} 2110}
1665 2111
1666sub reset_at { 2112sub reset_at {
1667 my ($self) = @_; 2113 my ($self) = @_;
1668 2114
1669 # TODO: safety, remove and allow resettable per-player maps 2115 # TODO: safety, remove and allow resettable per-player maps
1670 return 1e99 if $self->isa ("ext::map_per_player");#d#
1671 return 1e99 if $self->{deny_reset}; 2116 return 1e99 if $self->{deny_reset};
1672 2117
1673 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 2118 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1674 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 2119 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1675 2120
… …
1686 my ($self) = @_; 2131 my ($self) = @_;
1687 2132
1688 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2133 my $lock = cf::lock_acquire "map_data:$self->{path}";
1689 2134
1690 return if $self->players; 2135 return if $self->players;
1691 return if $self->isa ("ext::map_per_player");#d#
1692 2136
1693 warn "resetting map ", $self->path;#d# 2137 warn "resetting map ", $self->path;
1694 2138
1695 $self->in_memory (cf::MAP_SWAPPED); 2139 $self->in_memory (cf::MAP_SWAPPED);
1696 2140
1697 # need to save uniques path 2141 # need to save uniques path
1698 unless ($self->{deny_save}) { 2142 unless ($self->{deny_save}) {
… …
1702 if $uniq; 2146 if $uniq;
1703 } 2147 }
1704 2148
1705 delete $cf::MAP{$self->path}; 2149 delete $cf::MAP{$self->path};
1706 2150
2151 $self->deactivate;
2152 $_->clear_links_to ($self) for values %cf::MAP;
1707 $self->clear; 2153 $self->clear;
1708
1709 $_->clear_links_to ($self) for values %cf::MAP;
1710 2154
1711 $self->unlink_save; 2155 $self->unlink_save;
1712 $self->destroy; 2156 $self->destroy;
1713} 2157}
1714 2158
1715my $nuke_counter = "aaaa"; 2159my $nuke_counter = "aaaa";
1716 2160
1717sub nuke { 2161sub nuke {
1718 my ($self) = @_; 2162 my ($self) = @_;
1719 2163
2164 {
2165 my $lock = cf::lock_acquire "map_data:$self->{path}";
2166
1720 delete $cf::MAP{$self->path}; 2167 delete $cf::MAP{$self->path};
1721 2168
1722 $self->unlink_save; 2169 $self->unlink_save;
1723 2170
1724 bless $self, "cf::map"; 2171 bless $self, "cf::map";
1725 delete $self->{deny_reset}; 2172 delete $self->{deny_reset};
1726 $self->{deny_save} = 1; 2173 $self->{deny_save} = 1;
1727 $self->reset_timeout (1); 2174 $self->reset_timeout (1);
1728 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2175 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1729 2176
1730 $cf::MAP{$self->path} = $self; 2177 $cf::MAP{$self->path} = $self;
2178 }
1731 2179
1732 $self->reset; # polite request, might not happen 2180 $self->reset; # polite request, might not happen
2181}
2182
2183=item $maps = cf::map::tmp_maps
2184
2185Returns an arrayref with all map paths of currently instantiated and saved
2186maps. May block.
2187
2188=cut
2189
2190sub tmp_maps() {
2191 [
2192 map {
2193 utf8::decode $_;
2194 /\.map$/
2195 ? normalise $_
2196 : ()
2197 } @{ aio_readdir $TMPDIR or [] }
2198 ]
2199}
2200
2201=item $maps = cf::map::random_maps
2202
2203Returns an arrayref with all map paths of currently instantiated and saved
2204random maps. May block.
2205
2206=cut
2207
2208sub random_maps() {
2209 [
2210 map {
2211 utf8::decode $_;
2212 /\.map$/
2213 ? normalise "?random/$_"
2214 : ()
2215 } @{ aio_readdir $RANDOMDIR or [] }
2216 ]
1733} 2217}
1734 2218
1735=item cf::map::unique_maps 2219=item cf::map::unique_maps
1736 2220
1737Returns an arrayref of paths of all shared maps that have 2221Returns an arrayref of paths of all shared maps that have
1738instantiated unique items. May block. 2222instantiated unique items. May block.
1739 2223
1740=cut 2224=cut
1741 2225
1742sub unique_maps() { 2226sub unique_maps() {
1743 my $files = aio_readdir $UNIQUEDIR 2227 [
1744 or return; 2228 map {
1745
1746 my @paths;
1747
1748 for (@$files) {
1749 utf8::decode $_; 2229 utf8::decode $_;
1750 next if /\.pst$/; 2230 /\.map$/
1751 next unless /^$PATH_SEP/o; 2231 ? normalise $_
1752 2232 : ()
1753 push @paths, cf::map::normalise $_; 2233 } @{ aio_readdir $UNIQUEDIR or [] }
1754 } 2234 ]
1755
1756 \@paths
1757} 2235}
1758 2236
1759package cf; 2237package cf;
1760 2238
1761=back 2239=back
… …
1779 map { $_, inv_recursive_ $_->inv } @_ 2257 map { $_, inv_recursive_ $_->inv } @_
1780} 2258}
1781 2259
1782sub inv_recursive { 2260sub inv_recursive {
1783 inv_recursive_ inv $_[0] 2261 inv_recursive_ inv $_[0]
2262}
2263
2264=item $ref = $ob->ref
2265
2266creates and returns a persistent reference to an objetc that can be stored as a string.
2267
2268=item $ob = cf::object::deref ($refstring)
2269
2270returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2271even if the object actually exists. May block.
2272
2273=cut
2274
2275sub deref {
2276 my ($ref) = @_;
2277
2278 # temporary compatibility#TODO#remove
2279 $ref =~ s{^<}{player/<};
2280
2281 if ($ref =~ m{^player\/(<1\.\d+>)/(.*)$}) {
2282 my ($uuid, $name) = ($1, $2);
2283 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2284 or return;
2285 $pl->ob->uuid eq $uuid
2286 or return;
2287
2288 $pl->ob
2289 } else {
2290 warn "$ref: cannot resolve object reference\n";
2291 undef
2292 }
1784} 2293}
1785 2294
1786package cf; 2295package cf;
1787 2296
1788=back 2297=back
… …
1807 2316
1808 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2317 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1809 2318
1810 if ($self->{record_replies}) { 2319 if ($self->{record_replies}) {
1811 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2320 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2321
1812 } else { 2322 } else {
2323 my $pl = $self->contr;
2324
2325 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2326 my $dialog = $pl->{npc_dialog};
2327 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2328
2329 } else {
1813 $msg = $npc->name . " says: $msg" if $npc; 2330 $msg = $npc->name . " says: $msg" if $npc;
1814 $self->message ($msg, $flags); 2331 $self->message ($msg, $flags);
2332 }
1815 } 2333 }
2334}
2335
2336=item $object->send_msg ($channel, $msg, $color, [extra...])
2337
2338=cut
2339
2340sub cf::object::send_msg {
2341 my $pl = shift->contr
2342 or return;
2343 $pl->send_msg (@_);
1816} 2344}
1817 2345
1818=item $player_object->may ("access") 2346=item $player_object->may ("access")
1819 2347
1820Returns wether the given player is authorized to access resource "access" 2348Returns wether the given player is authorized to access resource "access"
… …
1867 $self->deactivate_recursive; 2395 $self->deactivate_recursive;
1868 2396
1869 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2397 return if UNIVERSAL::isa $self->map, "ext::map_link";
1870 2398
1871 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2399 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1872 if $self->map; 2400 if $self->map && $self->map->{path} ne "{link}";
1873 2401
1874 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2402 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1875} 2403}
1876 2404
1877sub cf::object::player::leave_link { 2405sub cf::object::player::leave_link {
1878 my ($self, $map, $x, $y) = @_; 2406 my ($self, $map, $x, $y) = @_;
2407
2408 return unless $self->contr->active;
1879 2409
1880 my $link_pos = delete $self->{_link_pos}; 2410 my $link_pos = delete $self->{_link_pos};
1881 2411
1882 unless ($map) { 2412 unless ($map) {
1883 # restore original map position 2413 # restore original map position
… …
1897 # use -1 or undef as default coordinates, not 0, 0 2427 # use -1 or undef as default coordinates, not 0, 0
1898 ($x, $y) = ($map->enter_x, $map->enter_y) 2428 ($x, $y) = ($map->enter_x, $map->enter_y)
1899 if $x <=0 && $y <= 0; 2429 if $x <=0 && $y <= 0;
1900 2430
1901 $map->load; 2431 $map->load;
1902 $map->load_diag; 2432 $map->load_neighbours;
1903 2433
1904 return unless $self->contr->active; 2434 return unless $self->contr->active;
1905 $self->activate_recursive; 2435 $self->activate_recursive;
1906 2436
1907 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2437 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1908 $self->enter_map ($map, $x, $y); 2438 $self->enter_map ($map, $x, $y);
1909} 2439}
1910 2440
1911cf::player->attach ( 2441=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
1912 on_logout => sub {
1913 my ($pl) = @_;
1914 2442
1915 # abort map switching before logout 2443Moves the player to the given map-path and coordinates by first freezing
1916 if ($pl->ob->{_link_pos}) { 2444her, loading and preparing them map, calling the provided $check callback
1917 cf::sync_job { 2445that has to return the map if sucecssful, and then unfreezes the player on
1918 $pl->ob->leave_link 2446the new (success) or old (failed) map position. In either case, $done will
1919 }; 2447be called at the end of this process.
1920 }
1921 },
1922 on_login => sub {
1923 my ($pl) = @_;
1924 2448
1925 # try to abort aborted map switching on player login :)
1926 # should happen only on crashes
1927 if ($pl->ob->{_link_pos}) {
1928 $pl->ob->enter_link;
1929 (async {
1930 $pl->ob->reply (undef,
1931 "There was an internal problem at your last logout, "
1932 . "the server will try to bring you to your intended destination in a second.",
1933 cf::NDI_RED);
1934 # we need this sleep as the login has a concurrent enter_exit running
1935 # and this sleep increases chances of the player not ending up in scorn
1936 Coro::Timer::sleep 1;
1937 $pl->ob->leave_link;
1938 })->prio (2);
1939 }
1940 },
1941);
1942
1943=item $player_object->goto ($path, $x, $y)
1944
1945=cut 2449=cut
2450
2451our $GOTOGEN;
1946 2452
1947sub cf::object::player::goto { 2453sub cf::object::player::goto {
1948 my ($self, $path, $x, $y) = @_; 2454 my ($self, $path, $x, $y, $check, $done) = @_;
2455
2456 # do generation counting so two concurrent goto's will be executed in-order
2457 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1949 2458
1950 $self->enter_link; 2459 $self->enter_link;
1951 2460
1952 (async { 2461 (async {
2462 $Coro::current->{desc} = "player::goto $path $x $y";
2463
2464 # *tag paths override both path and x|y
2465 if ($path =~ /^\*(.*)$/) {
2466 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2467 my $ob = $obs[rand @obs];
2468
2469 # see if we actually can go there
2470 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2471 $ob = $obs[rand @obs];
2472 } else {
2473 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2474 }
2475 # else put us there anyways for now #d#
2476
2477 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2478 } else {
2479 ($path, $x, $y) = (undef, undef, undef);
2480 }
2481 }
2482
1953 my $map = eval { 2483 my $map = eval {
1954 my $map = cf::map::find $path; 2484 my $map = defined $path ? cf::map::find $path : undef;
2485
2486 if ($map) {
1955 $map = $map->customise_for ($self) if $map; 2487 $map = $map->customise_for ($self);
2488 $map = $check->($map) if $check && $map;
2489 } else {
2490 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2491 }
2492
1956 $map 2493 $map
2494 };
2495
2496 if ($@) {
2497 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2498 LOG llevError | logBacktrace, Carp::longmess $@;
1957 } or 2499 }
1958 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1959 2500
2501 if ($gen == $self->{_goto_generation}) {
2502 delete $self->{_goto_generation};
1960 $self->leave_link ($map, $x, $y); 2503 $self->leave_link ($map, $x, $y);
2504 }
2505
2506 $done->() if $done;
1961 })->prio (1); 2507 })->prio (1);
1962} 2508}
1963 2509
1964=item $player_object->enter_exit ($exit_object) 2510=item $player_object->enter_exit ($exit_object)
1965 2511
… …
2034 my $hp = $exit->stats->hp; 2580 my $hp = $exit->stats->hp;
2035 my $sp = $exit->stats->sp; 2581 my $sp = $exit->stats->sp;
2036 2582
2037 $self->enter_link; 2583 $self->enter_link;
2038 2584
2585 # if exit is damned, update players death & WoR home-position
2586 $self->contr->savebed ($slaying, $hp, $sp)
2587 if $exit->flag (FLAG_DAMNED);
2588
2039 (async { 2589 (async {
2590 $Coro::current->{desc} = "enter_exit $slaying $hp $sp";
2591
2040 $self->deactivate_recursive; # just to be sure 2592 $self->deactivate_recursive; # just to be sure
2041 unless (eval { 2593 unless (eval {
2042 $self->goto ($slaying, $hp, $sp); 2594 $self->goto ($slaying, $hp, $sp);
2043 2595
2044 1; 2596 1;
… …
2070 2622
2071 utf8::encode $text; 2623 utf8::encode $text;
2072 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2624 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2073} 2625}
2074 2626
2627=item $client->send_msg ($channel, $msg, $color, [extra...])
2628
2629Send a drawinfo or msg packet to the client, formatting the msg for the
2630client if neccessary. C<$type> should be a string identifying the type of
2631the message, with C<log> being the default. If C<$color> is negative, suppress
2632the message unless the client supports the msg packet.
2633
2634=cut
2635
2636our %CHANNEL = (
2637 "c/identify" => {
2638 id => "infobox",
2639 title => "Identify",
2640 reply => undef,
2641 tooltip => "Items recently identified",
2642 },
2643 "c/examine" => {
2644 id => "infobox",
2645 title => "Examine",
2646 reply => undef,
2647 tooltip => "Signs and other items you examined",
2648 },
2649 "c/lookat" => {
2650 id => "infobox",
2651 title => "Look",
2652 reply => undef,
2653 tooltip => "What you saw there",
2654 },
2655);
2656
2657sub cf::client::send_msg {
2658 my ($self, $channel, $msg, $color, @extra) = @_;
2659
2660 $msg = $self->pl->expand_cfpod ($msg);
2661
2662 $color &= cf::NDI_CLIENT_MASK; # just in case...
2663
2664 # check predefined channels, for the benefit of C
2665 if ($CHANNEL{$channel}) {
2666 $channel = $CHANNEL{$channel};
2667
2668 $self->ext_msg (channel_info => $channel)
2669 if $self->can_msg;
2670
2671 $channel = $channel->{id};
2672
2673 } elsif (ref $channel) {
2674 # send meta info to client, if not yet sent
2675 unless (exists $self->{channel}{$channel->{id}}) {
2676 $self->{channel}{$channel->{id}} = $channel;
2677 $self->ext_msg (channel_info => $channel)
2678 if $self->can_msg;
2679 }
2680
2681 $channel = $channel->{id};
2682 }
2683
2684 return unless @extra || length $msg;
2685
2686 if ($self->can_msg) {
2687 # default colour, mask it out
2688 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2689 if $color & cf::NDI_DEF;
2690
2691 $self->send_packet ("msg " . $self->{json_coder}->encode (
2692 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2693 } else {
2694 if ($color >= 0) {
2695 # replace some tags by gcfclient-compatible ones
2696 for ($msg) {
2697 1 while
2698 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2699 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2700 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2701 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2702 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2703 }
2704
2705 $color &= cf::NDI_COLOR_MASK;
2706
2707 utf8::encode $msg;
2708
2709 if (0 && $msg =~ /\[/) {
2710 # COMMAND/INFO
2711 $self->send_packet ("drawextinfo $color 10 8 $msg")
2712 } else {
2713 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2714 $self->send_packet ("drawinfo $color $msg")
2715 }
2716 }
2717 }
2718}
2719
2075=item $client->ext_event ($type, %msg) 2720=item $client->ext_msg ($type, @msg)
2076 2721
2077Sends an exti event to the client. 2722Sends an ext event to the client.
2078 2723
2079=cut 2724=cut
2080 2725
2081sub cf::client::ext_event($$%) { 2726sub cf::client::ext_msg($$@) {
2082 my ($self, $type, %msg) = @_; 2727 my ($self, $type, @msg) = @_;
2083 2728
2729 if ($self->extcmd == 2) {
2730 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2731 } elsif ($self->extcmd == 1) { # TODO: remove
2084 $msg{msgtype} = "event_$type"; 2732 push @msg, msgtype => "event_$type";
2085 $self->send_packet ("ext " . cf::to_json \%msg); 2733 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2734 }
2735}
2736
2737=item $client->ext_reply ($msgid, @msg)
2738
2739Sends an ext reply to the client.
2740
2741=cut
2742
2743sub cf::client::ext_reply($$@) {
2744 my ($self, $id, @msg) = @_;
2745
2746 if ($self->extcmd == 2) {
2747 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2748 } elsif ($self->extcmd == 1) {
2749 #TODO: version 1, remove
2750 unshift @msg, msgtype => "reply", msgid => $id;
2751 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2752 }
2086} 2753}
2087 2754
2088=item $success = $client->query ($flags, "text", \&cb) 2755=item $success = $client->query ($flags, "text", \&cb)
2089 2756
2090Queues a query to the client, calling the given callback with 2757Queues a query to the client, calling the given callback with
2091the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2758the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
2092C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 2759C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2093 2760
2094Queries can fail, so check the return code. Or don't, as queries will become 2761Queries can fail, so check the return code. Or don't, as queries will
2095reliable at some point in the future. 2762become reliable at some point in the future.
2096 2763
2097=cut 2764=cut
2098 2765
2099sub cf::client::query { 2766sub cf::client::query {
2100 my ($self, $flags, $text, $cb) = @_; 2767 my ($self, $flags, $text, $cb) = @_;
… …
2108 utf8::encode $text; 2775 utf8::encode $text;
2109 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2776 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2110 2777
2111 $self->send_packet ($self->{query_queue}[0][0]) 2778 $self->send_packet ($self->{query_queue}[0][0])
2112 if @{ $self->{query_queue} } == 1; 2779 if @{ $self->{query_queue} } == 1;
2780
2781 1
2113} 2782}
2114 2783
2115cf::client->attach ( 2784cf::client->attach (
2785 on_connect => sub {
2786 my ($ns) = @_;
2787
2788 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2789 },
2116 on_reply => sub { 2790 on_reply => sub {
2117 my ($ns, $msg) = @_; 2791 my ($ns, $msg) = @_;
2118 2792
2119 # this weird shuffling is so that direct followup queries 2793 # this weird shuffling is so that direct followup queries
2120 # get handled first 2794 # get handled first
… …
2132 } else { 2806 } else {
2133 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 2807 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2134 } 2808 }
2135 } 2809 }
2136 }, 2810 },
2811 on_exticmd => sub {
2812 my ($ns, $buf) = @_;
2813
2814 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2815
2816 if (ref $msg) {
2817 my ($type, $reply, @payload) =
2818 "ARRAY" eq ref $msg
2819 ? @$msg
2820 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
2821
2822 my @reply;
2823
2824 if (my $cb = $EXTICMD{$type}) {
2825 @reply = $cb->($ns, @payload);
2826 }
2827
2828 $ns->ext_reply ($reply, @reply)
2829 if $reply;
2830
2831 } else {
2832 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2833 }
2834
2835 cf::override;
2836 },
2137); 2837);
2138 2838
2139=item $client->async (\&cb) 2839=item $client->async (\&cb)
2140 2840
2141Create a new coroutine, running the specified callback. The coroutine will 2841Create a new coroutine, running the specified callback. The coroutine will
… …
2182our $safe = new Safe "safe"; 2882our $safe = new Safe "safe";
2183our $safe_hole = new Safe::Hole; 2883our $safe_hole = new Safe::Hole;
2184 2884
2185$SIG{FPE} = 'IGNORE'; 2885$SIG{FPE} = 'IGNORE';
2186 2886
2187$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 2887$safe->permit_only (Opcode::opset qw(
2888 :base_core :base_mem :base_orig :base_math
2889 grepstart grepwhile mapstart mapwhile
2890 sort time
2891));
2188 2892
2189# here we export the classes and methods available to script code 2893# here we export the classes and methods available to script code
2190 2894
2191=pod 2895=pod
2192 2896
2193The following functions and methods are available within a safe environment: 2897The following functions and methods are available within a safe environment:
2194 2898
2195 cf::object contr pay_amount pay_player map 2899 cf::object
2900 contr pay_amount pay_player map x y force_find force_add
2901 insert remove name archname title slaying race decrease_ob_nr
2902
2196 cf::object::player player 2903 cf::object::player
2197 cf::player peaceful 2904 player
2198 cf::map trigger 2905
2906 cf::player
2907 peaceful
2908
2909 cf::map
2910 trigger
2199 2911
2200=cut 2912=cut
2201 2913
2202for ( 2914for (
2203 ["cf::object" => qw(contr pay_amount pay_player map)], 2915 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2916 insert remove inv name archname title slaying race
2917 decrease_ob_nr)],
2204 ["cf::object::player" => qw(player)], 2918 ["cf::object::player" => qw(player)],
2205 ["cf::player" => qw(peaceful)], 2919 ["cf::player" => qw(peaceful)],
2206 ["cf::map" => qw(trigger)], 2920 ["cf::map" => qw(trigger)],
2207) { 2921) {
2208 no strict 'refs'; 2922 no strict 'refs';
… …
2279=back 2993=back
2280 2994
2281=cut 2995=cut
2282 2996
2283############################################################################# 2997#############################################################################
2284
2285=head2 EXTENSION DATABASE SUPPORT
2286
2287Crossfire maintains a very simple database for extension use. It can
2288currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2289convert to/from binary).
2290
2291The parameter C<$family> should best start with the name of the extension
2292using it, it should be unique.
2293
2294=over 4
2295
2296=item $value = cf::db_get $family => $key
2297
2298Returns a single value from the database.
2299
2300=item cf::db_put $family => $key => $value
2301
2302Stores the given C<$value> in the family.
2303
2304=cut
2305
2306our $DB;
2307
2308sub db_init {
2309 unless ($DB) {
2310 $DB = BDB::db_create $DB_ENV;
2311
2312 cf::sync_job {
2313 eval {
2314 $DB->set_flags (BDB::CHKSUM);
2315
2316 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2317 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2318 cf::cleanup "db_open(db): $!" if $!;
2319 };
2320 cf::cleanup "db_open(db): $@" if $@;
2321 };
2322 }
2323}
2324
2325sub db_get($$) {
2326 my $key = "$_[0]/$_[1]";
2327
2328 cf::sync_job {
2329 BDB::db_get $DB, undef, $key, my $data;
2330
2331 $! ? ()
2332 : $data
2333 }
2334}
2335
2336sub db_put($$$) {
2337 BDB::dbreq_pri 4;
2338 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2339}
2340
2341=item cf::cache $id => [$paths...], $processversion => $process
2342
2343Generic caching function that returns the value of the resource $id,
2344caching and regenerating as required.
2345
2346This function can block.
2347
2348=cut
2349
2350sub cache {
2351 my ($id, $src, $processversion, $process) = @_;
2352
2353 my $meta =
2354 join "\x00",
2355 $processversion,
2356 map {
2357 aio_stat $_
2358 and Carp::croak "$_: $!";
2359
2360 ($_, (stat _)[7,9])
2361 } @$src;
2362
2363 my $dbmeta = db_get cache => "$id/meta";
2364 if ($dbmeta ne $meta) {
2365 # changed, we may need to process
2366
2367 my @data;
2368 my $md5;
2369
2370 for (0 .. $#$src) {
2371 0 <= aio_load $src->[$_], $data[$_]
2372 or Carp::croak "$src->[$_]: $!";
2373 }
2374
2375 # if processing is expensive, check
2376 # checksum first
2377 if (1) {
2378 $md5 =
2379 join "\x00",
2380 $processversion,
2381 map {
2382 Coro::cede;
2383 ($src->[$_], Digest::MD5::md5_hex $data[$_])
2384 } 0.. $#$src;
2385
2386
2387 my $dbmd5 = db_get cache => "$id/md5";
2388 if ($dbmd5 eq $md5) {
2389 db_put cache => "$id/meta", $meta;
2390
2391 return db_get cache => "$id/data";
2392 }
2393 }
2394
2395 my $t1 = Time::HiRes::time;
2396 my $data = $process->(\@data);
2397 my $t2 = Time::HiRes::time;
2398
2399 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2400
2401 db_put cache => "$id/data", $data;
2402 db_put cache => "$id/md5" , $md5;
2403 db_put cache => "$id/meta", $meta;
2404
2405 return $data;
2406 }
2407
2408 db_get cache => "$id/data"
2409}
2410
2411=item fork_call { }, $args
2412
2413Executes the given code block with the given arguments in a seperate
2414process, returning the results. Everything must be serialisable with
2415Coro::Storable. May, of course, block. Note that the executed sub may
2416never block itself or use any form of Event handling.
2417
2418=cut
2419
2420sub fork_call(&@) {
2421 my ($cb, @args) = @_;
2422
2423# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2424# or die "socketpair: $!";
2425 pipe my $fh1, my $fh2
2426 or die "pipe: $!";
2427
2428 if (my $pid = fork) {
2429 close $fh2;
2430
2431 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2432 $res = Coro::Storable::thaw $res;
2433
2434 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2435
2436 die $$res unless "ARRAY" eq ref $res;
2437
2438 return wantarray ? @$res : $res->[-1];
2439 } else {
2440 local $SIG{__WARN__};
2441 eval {
2442 local $SIG{__DIE__};
2443 close $fh1;
2444
2445 my @res = eval { $cb->(@args) };
2446 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2447 };
2448
2449 warn $@ if $@;
2450 _exit 0;
2451 }
2452}
2453
2454
2455
2456#############################################################################
2457# the server's init and main functions 2998# the server's init and main functions
2458 2999
2459sub load_facedata($) { 3000sub load_facedata($) {
2460 my ($path) = @_; 3001 my ($path) = @_;
3002
3003 # HACK to clear player env face cache, we need some signal framework
3004 # for this (global event?)
3005 %ext::player_env::MUSIC_FACE_CACHE = ();
3006
3007 my $enc = JSON::XS->new->utf8->canonical->relaxed;
2461 3008
2462 warn "loading facedata from $path\n"; 3009 warn "loading facedata from $path\n";
2463 3010
2464 my $facedata; 3011 my $facedata;
2465 0 < aio_load $path, $facedata 3012 0 < aio_load $path, $facedata
… …
2468 $facedata = Coro::Storable::thaw $facedata; 3015 $facedata = Coro::Storable::thaw $facedata;
2469 3016
2470 $facedata->{version} == 2 3017 $facedata->{version} == 2
2471 or cf::cleanup "$path: version mismatch, cannot proceed."; 3018 or cf::cleanup "$path: version mismatch, cannot proceed.";
2472 3019
3020 # patch in the exptable
3021 $facedata->{resource}{"res/exp_table"} = {
3022 type => FT_RSRC,
3023 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
3024 };
3025 cf::cede_to_tick;
3026
2473 { 3027 {
2474 my $faces = $facedata->{faceinfo}; 3028 my $faces = $facedata->{faceinfo};
2475 3029
2476 while (my ($face, $info) = each %$faces) { 3030 while (my ($face, $info) = each %$faces) {
2477 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3031 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2478 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 3032 cf::face::set_visibility $idx, $info->{visibility};
3033 cf::face::set_magicmap $idx, $info->{magicmap};
2479 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 3034 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2480 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 3035 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2481 Coro::cede; 3036
3037 cf::cede_to_tick;
2482 } 3038 }
2483 3039
2484 while (my ($face, $info) = each %$faces) { 3040 while (my ($face, $info) = each %$faces) {
2485 next unless $info->{smooth}; 3041 next unless $info->{smooth};
2486 my $idx = cf::face::find $face 3042 my $idx = cf::face::find $face
2487 or next; 3043 or next;
2488 if (my $smooth = cf::face::find $info->{smooth}) { 3044 if (my $smooth = cf::face::find $info->{smooth}) {
3045 cf::face::set_smooth $idx, $smooth;
2489 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel}; 3046 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2490 } else { 3047 } else {
2491 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3048 warn "smooth face '$info->{smooth}' not found for face '$face'";
2492 } 3049 }
2493 Coro::cede; 3050
3051 cf::cede_to_tick;
2494 } 3052 }
2495 } 3053 }
2496 3054
2497 { 3055 {
2498 my $anims = $facedata->{animinfo}; 3056 my $anims = $facedata->{animinfo};
2499 3057
2500 while (my ($anim, $info) = each %$anims) { 3058 while (my ($anim, $info) = each %$anims) {
2501 cf::anim::set $anim, $info->{frames}, $info->{facings}; 3059 cf::anim::set $anim, $info->{frames}, $info->{facings};
2502 Coro::cede; 3060 cf::cede_to_tick;
2503 } 3061 }
2504 3062
2505 cf::anim::invalidate_all; # d'oh 3063 cf::anim::invalidate_all; # d'oh
2506 } 3064 }
2507 3065
3066 {
3067 # TODO: for gcfclient pleasure, we should give resources
3068 # that gcfclient doesn't grok a >10000 face index.
3069 my $res = $facedata->{resource};
3070
3071 my $soundconf = delete $res->{"res/sound.conf"};
3072
3073 while (my ($name, $info) = each %$res) {
3074 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3075 my $data;
3076
3077 if ($info->{type} & 1) {
3078 # prepend meta info
3079
3080 my $meta = $enc->encode ({
3081 name => $name,
3082 %{ $info->{meta} || {} },
3083 });
3084
3085 $data = pack "(w/a*)*", $meta, $info->{data};
3086 } else {
3087 $data = $info->{data};
3088 }
3089
3090 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3091 cf::face::set_type $idx, $info->{type};
3092
3093 cf::cede_to_tick;
3094 }
3095
3096 if ($soundconf) {
3097 $soundconf = $enc->decode (delete $soundconf->{data});
3098
3099 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3100 my $sound = $soundconf->{compat}[$_]
3101 or next;
3102
3103 my $face = cf::face::find "sound/$sound->[1]";
3104 cf::sound::set $sound->[0] => $face;
3105 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3106 }
3107
3108 while (my ($k, $v) = each %{$soundconf->{event}}) {
3109 my $face = cf::face::find "sound/$v";
3110 cf::sound::set $k => $face;
3111 }
3112 }
3113 }
3114
2508 1 3115 1
2509} 3116}
2510 3117
3118register_exticmd fx_want => sub {
3119 my ($ns, $want) = @_;
3120
3121 while (my ($k, $v) = each %$want) {
3122 $ns->fx_want ($k, $v);
3123 }
3124};
3125
2511sub reload_regions { 3126sub reload_regions {
3127 # HACK to clear player env face cache, we need some signal framework
3128 # for this (global event?)
3129 %ext::player_env::MUSIC_FACE_CACHE = ();
3130
2512 load_resource_file "$MAPDIR/regions" 3131 load_resource_file "$MAPDIR/regions"
2513 or die "unable to load regions file\n"; 3132 or die "unable to load regions file\n";
3133
3134 for (cf::region::list) {
3135 $_->{match} = qr/$_->{match}/
3136 if exists $_->{match};
3137 }
2514} 3138}
2515 3139
2516sub reload_facedata { 3140sub reload_facedata {
2517 load_facedata "$DATADIR/facedata" 3141 load_facedata "$DATADIR/facedata"
2518 or die "unable to load facedata\n"; 3142 or die "unable to load facedata\n";
2519} 3143}
2520 3144
2521sub reload_archetypes { 3145sub reload_archetypes {
2522 load_resource_file "$DATADIR/archetypes" 3146 load_resource_file "$DATADIR/archetypes"
2523 or die "unable to load archetypes\n"; 3147 or die "unable to load archetypes\n";
3148 #d# NEED to laod twice to resolve forward references
3149 # this really needs to be done in an extra post-pass
3150 # (which needs to be synchronous, so solve it differently)
3151 load_resource_file "$DATADIR/archetypes"
3152 or die "unable to load archetypes\n";
2524} 3153}
2525 3154
2526sub reload_treasures { 3155sub reload_treasures {
2527 load_resource_file "$DATADIR/treasures" 3156 load_resource_file "$DATADIR/treasures"
2528 or die "unable to load treasurelists\n"; 3157 or die "unable to load treasurelists\n";
… …
2531sub reload_resources { 3160sub reload_resources {
2532 warn "reloading resource files...\n"; 3161 warn "reloading resource files...\n";
2533 3162
2534 reload_regions; 3163 reload_regions;
2535 reload_facedata; 3164 reload_facedata;
3165 #reload_archetypes;#d#
2536 reload_archetypes; 3166 reload_archetypes;
2537 reload_treasures; 3167 reload_treasures;
2538 3168
2539 warn "finished reloading resource files\n"; 3169 warn "finished reloading resource files\n";
2540} 3170}
2541 3171
2542sub init { 3172sub init {
2543 reload_resources; 3173 reload_resources;
2544} 3174}
2545 3175
2546sub cfg_load { 3176sub reload_config {
2547 open my $fh, "<:utf8", "$CONFDIR/config" 3177 open my $fh, "<:utf8", "$CONFDIR/config"
2548 or return; 3178 or return;
2549 3179
2550 local $/; 3180 local $/;
2551 *CFG = YAML::Syck::Load <$fh>; 3181 *CFG = YAML::Syck::Load <$fh>;
… …
2567sub main { 3197sub main {
2568 # we must not ever block the main coroutine 3198 # we must not ever block the main coroutine
2569 local $Coro::idle = sub { 3199 local $Coro::idle = sub {
2570 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3200 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2571 (async { 3201 (async {
3202 $Coro::current->{desc} = "IDLE BUG HANDLER";
2572 Event::one_event; 3203 Event::one_event;
2573 })->prio (Coro::PRIO_MAX); 3204 })->prio (Coro::PRIO_MAX);
2574 }; 3205 };
2575 3206
2576 cfg_load; 3207 reload_config;
2577 db_init; 3208 db_init;
2578 load_extensions; 3209 load_extensions;
2579 3210
2580 $TICK_WATCHER->start; 3211 $TICK_WATCHER->start;
2581 Event::loop; 3212 Event::loop;
… …
2597 }, 3228 },
2598 ); 3229 );
2599 } 3230 }
2600} 3231}
2601 3232
3233sub write_runtime {
3234 my $runtime = "$LOCALDIR/runtime";
3235
3236 # first touch the runtime file to show we are still running:
3237 # the fsync below can take a very very long time.
3238
3239 IO::AIO::aio_utime $runtime, undef, undef;
3240
3241 my $guard = cf::lock_acquire "write_runtime";
3242
3243 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
3244 or return;
3245
3246 my $value = $cf::RUNTIME + 90 + 10;
3247 # 10 is the runtime save interval, for a monotonic clock
3248 # 60 allows for the watchdog to kill the server.
3249
3250 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3251 and return;
3252
3253 # always fsync - this file is important
3254 aio_fsync $fh
3255 and return;
3256
3257 # touch it again to show we are up-to-date
3258 aio_utime $fh, undef, undef;
3259
3260 close $fh
3261 or return;
3262
3263 aio_rename "$runtime~", $runtime
3264 and return;
3265
3266 warn "runtime file written.\n";
3267
3268 1
3269}
3270
2602sub emergency_save() { 3271sub emergency_save() {
2603 my $freeze_guard = cf::freeze_mainloop; 3272 my $freeze_guard = cf::freeze_mainloop;
2604 3273
2605 warn "enter emergency perl save\n"; 3274 warn "enter emergency perl save\n";
2606 3275
… …
2681 %EXT_CORO = (); 3350 %EXT_CORO = ();
2682 3351
2683 warn "removing commands"; 3352 warn "removing commands";
2684 %COMMAND = (); 3353 %COMMAND = ();
2685 3354
2686 warn "removing ext commands"; 3355 warn "removing ext/exti commands";
2687 %EXTCMD = (); 3356 %EXTCMD = ();
3357 %EXTICMD = ();
2688 3358
2689 warn "unloading/nuking all extensions"; 3359 warn "unloading/nuking all extensions";
2690 for my $pkg (@EXTS) { 3360 for my $pkg (@EXTS) {
2691 warn "... unloading $pkg"; 3361 warn "... unloading $pkg";
2692 3362
… …
2735 warn "reloading cf.pm"; 3405 warn "reloading cf.pm";
2736 require cf; 3406 require cf;
2737 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3407 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2738 3408
2739 warn "loading config and database again"; 3409 warn "loading config and database again";
2740 cf::cfg_load; 3410 cf::reload_config;
2741 3411
2742 warn "loading extensions"; 3412 warn "loading extensions";
2743 cf::load_extensions; 3413 cf::load_extensions;
2744 3414
2745 warn "reattaching attachments to objects/players"; 3415 warn "reattaching attachments to objects/players";
… …
2781register_command "reload" => sub { 3451register_command "reload" => sub {
2782 my ($who, $arg) = @_; 3452 my ($who, $arg) = @_;
2783 3453
2784 if ($who->flag (FLAG_WIZ)) { 3454 if ($who->flag (FLAG_WIZ)) {
2785 $who->message ("reloading server."); 3455 $who->message ("reloading server.");
3456 async {
3457 $Coro::current->{desc} = "perl_reload";
2786 async { reload_perl }; 3458 reload_perl;
3459 };
2787 } 3460 }
2788}; 3461};
2789 3462
2790unshift @INC, $LIBDIR; 3463unshift @INC, $LIBDIR;
2791 3464
… …
2823 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3496 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2824 unless ++$bug_warning > 10; 3497 unless ++$bug_warning > 10;
2825 return; 3498 return;
2826 } 3499 }
2827 3500
2828 $NOW = Event::time; 3501 $NOW = $tick_start = Event::time;
2829 3502
2830 cf::server_tick; # one server iteration 3503 cf::server_tick; # one server iteration
2831 3504
2832 $RUNTIME += $TICK; 3505 $RUNTIME += $TICK;
2833 $NEXT_TICK += $TICK; 3506 $NEXT_TICK += $TICK;
2834 3507
2835 if ($NOW >= $NEXT_RUNTIME_WRITE) { 3508 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2836 $NEXT_RUNTIME_WRITE = $NOW + 10; 3509 $NEXT_RUNTIME_WRITE = $NOW + 10;
2837 Coro::async_pool { 3510 Coro::async_pool {
3511 $Coro::current->{desc} = "runtime saver";
2838 write_runtime 3512 write_runtime
2839 or warn "ERROR: unable to write runtime file: $!"; 3513 or warn "ERROR: unable to write runtime file: $!";
2840 }; 3514 };
2841 } 3515 }
2842 3516
2843# my $AFTER = Event::time; 3517 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
2844# warn $AFTER - $NOW;#d# 3518 $sig->send;
3519 }
3520 while (my $sig = shift @WAIT_FOR_TICK) {
3521 $sig->send;
3522 }
3523
3524 $NOW = Event::time;
2845 3525
2846 # if we are delayed by four ticks or more, skip them all 3526 # if we are delayed by four ticks or more, skip them all
2847 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 3527 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2848 3528
2849 $TICK_WATCHER->at ($NEXT_TICK); 3529 $TICK_WATCHER->at ($NEXT_TICK);
2850 $TICK_WATCHER->start; 3530 $TICK_WATCHER->start;
2851 3531
2852 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3532 $LOAD = ($NOW - $tick_start) / $TICK;
2853 $sig->send; 3533 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
2854 }
2855 while (my $sig = shift @WAIT_FOR_TICK) {
2856 $sig->send;
2857 }
2858 3534
2859 _post_tick; 3535 _post_tick;
2860 }, 3536 },
2861); 3537);
2862 3538
2863{ 3539{
3540 BDB::min_parallel 8;
2864 BDB::max_poll_time $TICK * 0.1; 3541 BDB::max_poll_time $TICK * 0.1;
2865 $BDB_POLL_WATCHER = Event->io ( 3542 $BDB_POLL_WATCHER = Event->io (
2866 reentrant => 0, 3543 reentrant => 0,
2867 fd => BDB::poll_fileno, 3544 fd => BDB::poll_fileno,
2868 poll => 'r', 3545 poll => 'r',
2869 prio => 0, 3546 prio => 0,
2870 data => WF_AUTOCANCEL, 3547 data => WF_AUTOCANCEL,
2871 cb => \&BDB::poll_cb, 3548 cb => \&BDB::poll_cb,
2872 ); 3549 );
2873 BDB::min_parallel 8;
2874 3550
2875 BDB::set_sync_prepare { 3551 BDB::set_sync_prepare {
2876 my $status; 3552 my $status;
2877 my $current = $Coro::current; 3553 my $current = $Coro::current;
2878 ( 3554 (
… …
2887 ) 3563 )
2888 }; 3564 };
2889 3565
2890 unless ($DB_ENV) { 3566 unless ($DB_ENV) {
2891 $DB_ENV = BDB::db_env_create; 3567 $DB_ENV = BDB::db_env_create;
3568 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC
3569 | BDB::LOG_AUTOREMOVE, 1);
3570 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3571 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
2892 3572
2893 cf::sync_job { 3573 cf::sync_job {
2894 eval { 3574 eval {
2895 BDB::db_env_open 3575 BDB::db_env_open
2896 $DB_ENV, 3576 $DB_ENV,
… …
2898 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3578 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2899 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3579 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2900 0666; 3580 0666;
2901 3581
2902 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 3582 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2903
2904 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2905 $DB_ENV->set_lk_detect;
2906 }; 3583 };
2907 3584
2908 cf::cleanup "db_env_open(db): $@" if $@; 3585 cf::cleanup "db_env_open(db): $@" if $@;
2909 }; 3586 };
2910 } 3587 }
3588
3589 $BDB_DEADLOCK_WATCHER = Event->timer (
3590 after => 3,
3591 interval => 1,
3592 hard => 1,
3593 prio => 0,
3594 data => WF_AUTOCANCEL,
3595 cb => sub {
3596 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3597 },
3598 );
3599 $BDB_CHECKPOINT_WATCHER = Event->timer (
3600 after => 11,
3601 interval => 60,
3602 hard => 1,
3603 prio => 0,
3604 data => WF_AUTOCANCEL,
3605 cb => sub {
3606 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3607 },
3608 );
3609 $BDB_TRICKLE_WATCHER = Event->timer (
3610 after => 5,
3611 interval => 10,
3612 hard => 1,
3613 prio => 0,
3614 data => WF_AUTOCANCEL,
3615 cb => sub {
3616 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3617 },
3618 );
2911} 3619}
2912 3620
2913{ 3621{
2914 IO::AIO::min_parallel 8; 3622 IO::AIO::min_parallel 8;
2915 3623
… …
2918 $AIO_POLL_WATCHER = Event->io ( 3626 $AIO_POLL_WATCHER = Event->io (
2919 reentrant => 0, 3627 reentrant => 0,
2920 data => WF_AUTOCANCEL, 3628 data => WF_AUTOCANCEL,
2921 fd => IO::AIO::poll_fileno, 3629 fd => IO::AIO::poll_fileno,
2922 poll => 'r', 3630 poll => 'r',
2923 prio => 6, 3631 prio => 0,
2924 cb => \&IO::AIO::poll_cb, 3632 cb => \&IO::AIO::poll_cb,
2925 ); 3633 );
2926} 3634}
2927 3635
3636my $_log_backtrace;
3637
2928sub _log_backtrace { 3638sub _log_backtrace {
2929 my ($msg, @addr) = @_; 3639 my ($msg, @addr) = @_;
2930 3640
3641 $msg =~ s/\n//;
3642
3643 # limit the # of concurrent backtraces
3644 if ($_log_backtrace < 2) {
3645 ++$_log_backtrace;
2931 async { 3646 async {
3647 $Coro::current->{desc} = "abt $msg";
3648
2932 my @bt = fork_call { 3649 my @bt = fork_call {
2933 @addr = map { sprintf "%x", $_ } @addr; 3650 @addr = map { sprintf "%x", $_ } @addr;
3651 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
2934 open my $fh, "exec addr2line -C -f -i -e \Q$^X\E @addr 2>&1 |" 3652 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
2935 or die "addr2line: $!"; 3653 or die "addr2line: $!";
2936 3654
2937 my @funcs; 3655 my @funcs;
2938 my @res = <$fh>; 3656 my @res = <$fh>;
2939 chomp for @res; 3657 chomp for @res;
2940 while (@res) { 3658 while (@res) {
2941 my ($func, $line) = splice @res, 0, 2, (); 3659 my ($func, $line) = splice @res, 0, 2, ();
2942 push @funcs, "[$func] $line"; 3660 push @funcs, "[$func] $line";
3661 }
3662
3663 @funcs
2943 } 3664 };
2944 3665
2945 @funcs 3666 LOG llevInfo, "[ABT] $msg\n";
3667 LOG llevInfo, "[ABT] $_\n" for @bt;
3668 --$_log_backtrace;
2946 }; 3669 };
2947 3670 } else {
2948 $msg =~ s/\n//;
2949
2950 LOG llevInfo, "[ABT] $msg\n"; 3671 LOG llevInfo, "[ABT] $msg\n";
2951 LOG llevInfo, "[ABT] $_\n" for @bt; 3672 LOG llevInfo, "[ABT] [suppressed]\n";
2952 }; 3673 }
2953} 3674}
2954 3675
2955# load additional modules 3676# load additional modules
2956use cf::pod; 3677use cf::pod;
2957 3678

Diff Legend

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