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.99 by root, Sat Dec 23 05:25:35 2006 UTC vs.
Revision 1.414 by root, Thu Apr 10 09:10:45 2008 UTC

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

Diff Legend

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