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.237 by root, Fri Apr 13 05:08:51 2007 UTC vs.
Revision 1.360 by root, Sun Sep 9 06:25:46 2007 UTC

3use utf8; 3use utf8;
4use strict; 4use strict;
5 5
6use Symbol; 6use Symbol;
7use List::Util; 7use List::Util;
8use Socket;
8use Storable; 9use Storable;
9use Event; 10use Event;
10use Opcode; 11use Opcode;
11use Safe; 12use Safe;
12use Safe::Hole; 13use Safe::Hole;
13 14
14use Coro 3.52 (); 15use Coro 3.64 ();
15use Coro::State; 16use Coro::State;
17use Coro::Handle;
16use Coro::Event; 18use Coro::Event;
17use Coro::Timer; 19use Coro::Timer;
18use Coro::Signal; 20use Coro::Signal;
19use Coro::Semaphore; 21use Coro::Semaphore;
20use Coro::AIO; 22use Coro::AIO;
21use Coro::Storable; 23use Coro::Storable;
24use Coro::Util ();
22 25
26use JSON::XS ();
23use BDB (); 27use BDB ();
24use Data::Dumper; 28use Data::Dumper;
25use Digest::MD5; 29use Digest::MD5;
26use Fcntl; 30use Fcntl;
27use YAML::Syck (); 31use YAML::Syck ();
28use IO::AIO 2.32 (); 32use IO::AIO 2.32 ();
29use Time::HiRes; 33use Time::HiRes;
30use Compress::LZF; 34use Compress::LZF;
35use Digest::MD5 ();
31 36
32# configure various modules to our taste 37# configure various modules to our taste
33# 38#
34$Storable::canonical = 1; # reduce rsync transfers 39$Storable::canonical = 1; # reduce rsync transfers
35Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 40Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
47our %COMMAND = (); 52our %COMMAND = ();
48our %COMMAND_TIME = (); 53our %COMMAND_TIME = ();
49 54
50our @EXTS = (); # list of extension package names 55our @EXTS = (); # list of extension package names
51our %EXTCMD = (); 56our %EXTCMD = ();
57our %EXTICMD = ();
52our %EXT_CORO = (); # coroutines bound to extensions 58our %EXT_CORO = (); # coroutines bound to extensions
53our %EXT_MAP = (); # pluggable maps 59our %EXT_MAP = (); # pluggable maps
54 60
55our $RELOAD; # number of reloads so far 61our $RELOAD; # number of reloads so far
56our @EVENT; 62our @EVENT;
57our $LIBDIR = datadir . "/ext";
58 63
59our $TICK = MAX_TIME * 1e-6; 64our $CONFDIR = confdir;
65our $DATADIR = datadir;
66our $LIBDIR = "$DATADIR/ext";
67our $PODDIR = "$DATADIR/pod";
68our $MAPDIR = "$DATADIR/" . mapdir;
69our $LOCALDIR = localdir;
70our $TMPDIR = "$LOCALDIR/" . tmpdir;
71our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
72our $PLAYERDIR = "$LOCALDIR/" . playerdir;
73our $RANDOMDIR = "$LOCALDIR/random";
74our $BDBDIR = "$LOCALDIR/db";
75
76our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
60our $TICK_WATCHER; 77our $TICK_WATCHER;
61our $AIO_POLL_WATCHER; 78our $AIO_POLL_WATCHER;
62our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 79our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
63our $NEXT_TICK; 80our $NEXT_TICK;
64our $NOW; 81our $NOW;
70our %CFG; 87our %CFG;
71 88
72our $UPTIME; $UPTIME ||= time; 89our $UPTIME; $UPTIME ||= time;
73our $RUNTIME; 90our $RUNTIME;
74 91
75our %PLAYER; # all users 92our (%PLAYER, %PLAYER_LOADING); # all users
76our %MAP; # all maps 93our (%MAP, %MAP_LOADING ); # all maps
77our $LINK_MAP; # the special {link} map, which is always available 94our $LINK_MAP; # the special {link} map, which is always available
78our $RANDOM_MAPS = cf::localdir . "/random";
79our $BDB_ENV_DIR = cf::localdir . "/db";
80
81our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal;
82our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal;
83 95
84# used to convert map paths into valid unix filenames by replacing / by ∕ 96# used to convert map paths into valid unix filenames by replacing / by ∕
85our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 97our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
86 98
99our $LOAD; # a number between 0 (idle) and 1 (too many objects)
100our $LOADAVG; # same thing, but with alpha-smoothing
101our $tick_start; # for load detecting purposes
102
87binmode STDOUT; 103binmode STDOUT;
88binmode STDERR; 104binmode STDERR;
89 105
90# read virtual server time, if available 106# read virtual server time, if available
91unless ($RUNTIME || !-e cf::localdir . "/runtime") { 107unless ($RUNTIME || !-e "$LOCALDIR/runtime") {
92 open my $fh, "<", cf::localdir . "/runtime" 108 open my $fh, "<", "$LOCALDIR/runtime"
93 or die "unable to read runtime file: $!"; 109 or die "unable to read runtime file: $!";
94 $RUNTIME = <$fh> + 0.; 110 $RUNTIME = <$fh> + 0.;
95} 111}
96 112
97mkdir cf::localdir; 113mkdir $_
98mkdir cf::localdir . "/" . cf::playerdir; 114 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
99mkdir cf::localdir . "/" . cf::tmpdir;
100mkdir cf::localdir . "/" . cf::uniquedir;
101mkdir $RANDOM_MAPS;
102mkdir $BDB_ENV_DIR;
103 115
104our $EMERGENCY_POSITION; 116our $EMERGENCY_POSITION;
105 117
106sub cf::map::normalise; 118sub cf::map::normalise;
107 119
118=item $cf::RUNTIME 130=item $cf::RUNTIME
119 131
120The time this server has run, starts at 0 and is increased by $cf::TICK on 132The time this server has run, starts at 0 and is increased by $cf::TICK on
121every server tick. 133every server tick.
122 134
123=item $cf::LIBDIR 135=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
136$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
137$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
124 138
125The perl library directory, where extensions and cf-specific modules can 139Various directories - "/etc", read-only install directory, perl-library
126be found. It will be added to C<@INC> automatically. 140directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
141unique-items directory, player file directory, random maps directory and
142database environment.
127 143
128=item $cf::NOW 144=item $cf::NOW
129 145
130The time of the last (current) server tick. 146The time of the last (current) server tick.
131 147
132=item $cf::TICK 148=item $cf::TICK
133 149
134The interval between server ticks, in seconds. 150The interval between server ticks, in seconds.
151
152=item $cf::LOADAVG
153
154The current CPU load on the server (alpha-smoothed), as a value between 0
155(none) and 1 (overloaded), indicating how much time is spent on processing
156objects per tick. Healthy values are < 0.5.
157
158=item $cf::LOAD
159
160The raw value load value from the last tick.
135 161
136=item %cf::CFG 162=item %cf::CFG
137 163
138Configuration for the server, loaded from C</etc/crossfire/config>, or 164Configuration for the server, loaded from C</etc/crossfire/config>, or
139from wherever your confdir points to. 165from wherever your confdir points to.
140 166
141=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE 167=item cf::wait_for_tick, cf::wait_for_tick_begin
142 168
143These are Coro::Signal objects that are C<< ->broadcast >> (WAIT_FOR_TICK) 169These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
144or C<< ->send >> (WAIT_FOR_TICK_ONE) on after normal server tick 170returns directly I<after> the tick processing (and consequently, can only wake one process
145processing has been done. Call C<< ->wait >> on them to maximise the 171per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
146window of cpu time available, or simply to synchronise to the server tick. 172
173=item @cf::INVOKE_RESULTS
174
175This array contains the results of the last C<invoke ()> call. When
176C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
177that call.
147 178
148=back 179=back
149 180
150=cut 181=cut
151 182
152BEGIN { 183BEGIN {
153 *CORE::GLOBAL::warn = sub { 184 *CORE::GLOBAL::warn = sub {
154 my $msg = join "", @_; 185 my $msg = join "", @_;
155 utf8::encode $msg;
156 186
157 $msg .= "\n" 187 $msg .= "\n"
158 unless $msg =~ /\n$/; 188 unless $msg =~ /\n$/;
159 189
190 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
191
192 utf8::encode $msg;
160 LOG llevError, $msg; 193 LOG llevError, $msg;
161 }; 194 };
162} 195}
163 196
164@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 197@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
165@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 198@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
166@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 199@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
167@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 200@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
168@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable'; 201@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
202@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
169@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 203@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
170 204
171# we bless all objects into (empty) derived classes to force a method lookup 205# we bless all objects into (empty) derived classes to force a method lookup
172# within the Safe compartment. 206# within the Safe compartment.
173for my $pkg (qw( 207for my $pkg (qw(
174 cf::global cf::attachable 208 cf::global cf::attachable
182} 216}
183 217
184$Event::DIED = sub { 218$Event::DIED = sub {
185 warn "error in event callback: @_"; 219 warn "error in event callback: @_";
186}; 220};
221
222#############################################################################
187 223
188=head2 UTILITY FUNCTIONS 224=head2 UTILITY FUNCTIONS
189 225
190=over 4 226=over 4
191 227
210 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 246 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
211 $d 247 $d
212 } || "[unable to dump $_[0]: '$@']"; 248 } || "[unable to dump $_[0]: '$@']";
213} 249}
214 250
215use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working
216
217=item $ref = cf::from_json $json 251=item $ref = cf::from_json $json
218 252
219Converts a JSON string into the corresponding perl data structure. 253Converts a JSON string into the corresponding perl data structure.
220 254
221=item $json = cf::to_json $ref 255=item $json = cf::to_json $ref
222 256
223Converts a perl data structure into its JSON representation. 257Converts a perl data structure into its JSON representation.
258
259=cut
260
261our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
262
263sub to_json ($) { $json_coder->encode ($_[0]) }
264sub from_json ($) { $json_coder->decode ($_[0]) }
224 265
225=item cf::lock_wait $string 266=item cf::lock_wait $string
226 267
227Wait until the given lock is available. See cf::lock_acquire. 268Wait until the given lock is available. See cf::lock_acquire.
228 269
231Wait until the given lock is available and then acquires it and returns 272Wait until the given lock is available and then acquires it and returns
232a Coro::guard object. If the guard object gets destroyed (goes out of scope, 273a Coro::guard object. If the guard object gets destroyed (goes out of scope,
233for example when the coroutine gets canceled), the lock is automatically 274for example when the coroutine gets canceled), the lock is automatically
234returned. 275returned.
235 276
277Locks are *not* recursive, locking from the same coro twice results in a
278deadlocked coro.
279
236Lock names should begin with a unique identifier (for example, cf::map::find 280Lock names should begin with a unique identifier (for example, cf::map::find
237uses map_find and cf::map::load uses map_load). 281uses map_find and cf::map::load uses map_load).
238 282
283=item $locked = cf::lock_active $string
284
285Return true if the lock is currently active, i.e. somebody has locked it.
286
239=cut 287=cut
240 288
241our %LOCK; 289our %LOCK;
290our %LOCKER;#d#
242 291
243sub lock_wait($) { 292sub lock_wait($) {
244 my ($key) = @_; 293 my ($key) = @_;
294
295 if ($LOCKER{$key} == $Coro::current) {#d#
296 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
297 return;#d#
298 }#d#
245 299
246 # wait for lock, if any 300 # wait for lock, if any
247 while ($LOCK{$key}) { 301 while ($LOCK{$key}) {
248 push @{ $LOCK{$key} }, $Coro::current; 302 push @{ $LOCK{$key} }, $Coro::current;
249 Coro::schedule; 303 Coro::schedule;
255 309
256 # wait, to be sure we are not locked 310 # wait, to be sure we are not locked
257 lock_wait $key; 311 lock_wait $key;
258 312
259 $LOCK{$key} = []; 313 $LOCK{$key} = [];
314 $LOCKER{$key} = $Coro::current;#d#
260 315
261 Coro::guard { 316 Coro::guard {
317 delete $LOCKER{$key};#d#
262 # wake up all waiters, to be on the safe side 318 # wake up all waiters, to be on the safe side
263 $_->ready for @{ delete $LOCK{$key} }; 319 $_->ready for @{ delete $LOCK{$key} };
264 } 320 }
321}
322
323sub lock_active($) {
324 my ($key) = @_;
325
326 ! ! $LOCK{$key}
265} 327}
266 328
267sub freeze_mainloop { 329sub freeze_mainloop {
268 return unless $TICK_WATCHER->is_active; 330 return unless $TICK_WATCHER->is_active;
269 331
272 }; 334 };
273 $TICK_WATCHER->stop; 335 $TICK_WATCHER->stop;
274 $guard 336 $guard
275} 337}
276 338
339=item cf::get_slot $time[, $priority[, $name]]
340
341Allocate $time seconds of blocking CPU time at priority C<$priority>:
342This call blocks and returns only when you have at least C<$time> seconds
343of cpu time till the next tick. The slot is only valid till the next cede.
344
345The optional C<$name> can be used to identify the job to run. It might be
346used for statistical purposes and should identify the same time-class.
347
348Useful for short background jobs.
349
350=cut
351
352our @SLOT_QUEUE;
353our $SLOT_QUEUE;
354
355$SLOT_QUEUE->cancel if $SLOT_QUEUE;
356$SLOT_QUEUE = Coro::async {
357 my $signal = new Coro::Signal;
358
359 while () {
360 next_job:
361 my $avail = cf::till_tick;
362 if ($avail > 0.01) {
363 for (0 .. $#SLOT_QUEUE) {
364 if ($SLOT_QUEUE[$_][0] < $avail) {
365 my $job = splice @SLOT_QUEUE, $_, 1, ();
366 $job->[2]->send;
367 Coro::cede;
368 goto next_job;
369 }
370 }
371 }
372
373 if (@SLOT_QUEUE) {
374 # we do not use wait_For_tick() as it returns immediately when tick is inactive
375 push @cf::WAIT_FOR_TICK, $signal;
376 $signal->wait;
377 } else {
378 Coro::schedule;
379 }
380 }
381};
382
383sub get_slot($;$$) {
384 my ($time, $pri, $name) = @_;
385
386 $time = $TICK * .6 if $time > $TICK * .6;
387 my $sig = new Coro::Signal;
388
389 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
390 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
391 $SLOT_QUEUE->ready;
392 $sig->wait;
393}
394
277=item cf::async { BLOCK } 395=item cf::async { BLOCK }
278 396
279Currently the same as Coro::async_pool, meaning you cannot use 397Currently the same as Coro::async_pool, meaning you cannot use
280C<on_destroy>, C<join> or other gimmicks on these coroutines. The only 398C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
281thing you are allowed to do is call C<prio> on it. 399thing you are allowed to do is call C<prio> on it.
284 402
285BEGIN { *async = \&Coro::async_pool } 403BEGIN { *async = \&Coro::async_pool }
286 404
287=item cf::sync_job { BLOCK } 405=item cf::sync_job { BLOCK }
288 406
289The design of crossfire+ requires that the main coro ($Coro::main) is 407The design of Crossfire TRT requires that the main coroutine ($Coro::main)
290always able to handle events or runnable, as crossfire+ is only partly 408is always able to handle events or runnable, as Crossfire TRT is only
291reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable. 409partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
410acceptable.
292 411
293If it must be done, put the blocking parts into C<sync_job>. This will run 412If it must be done, put the blocking parts into C<sync_job>. This will run
294the given BLOCK in another coroutine while waiting for the result. The 413the given BLOCK in another coroutine while waiting for the result. The
295server will be frozen during this time, so the block should either finish 414server will be frozen during this time, so the block should either finish
296fast or be very important. 415fast or be very important.
299 418
300sub sync_job(&) { 419sub sync_job(&) {
301 my ($job) = @_; 420 my ($job) = @_;
302 421
303 if ($Coro::current == $Coro::main) { 422 if ($Coro::current == $Coro::main) {
423 my $time = Event::time;
424
304 # this is the main coro, too bad, we have to block 425 # this is the main coro, too bad, we have to block
305 # till the operation succeeds, freezing the server :/ 426 # till the operation succeeds, freezing the server :/
306 427
307 # TODO: use suspend/resume instead 428 # TODO: use suspend/resume instead
308 # (but this is cancel-safe) 429 # (but this is cancel-safe)
319 440
320 while ($busy) { 441 while ($busy) {
321 Coro::cede or Event::one_event; 442 Coro::cede or Event::one_event;
322 } 443 }
323 444
445 $time = Event::time - $time;
446
447 LOG llevError | logBacktrace, Carp::longmess "long sync job"
448 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
449
450 $tick_start += $time; # do not account sync jobs to server load
451
324 wantarray ? @res : $res[0] 452 wantarray ? @res : $res[0]
325 } else { 453 } else {
326 # we are in another coroutine, how wonderful, everything just works 454 # we are in another coroutine, how wonderful, everything just works
327 455
328 $job->() 456 $job->()
347 $EXT_CORO{$coro+0} = $coro; 475 $EXT_CORO{$coro+0} = $coro;
348 476
349 $coro 477 $coro
350} 478}
351 479
352sub write_runtime { 480=item fork_call { }, $args
353 my $guard = cf::lock_acquire "write_runtime";
354 481
355 my $runtime = cf::localdir . "/runtime"; 482Executes the given code block with the given arguments in a seperate
483process, returning the results. Everything must be serialisable with
484Coro::Storable. May, of course, block. Note that the executed sub may
485never block itself or use any form of Event handling.
356 486
357 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 487=cut
358 or return;
359 488
360 my $value = $cf::RUNTIME + 90 + 10; 489sub fork_call(&@) {
361 # 10 is the runtime save interval, for a monotonic clock 490 my ($cb, @args) = @_;
362 # 60 allows for the watchdog to kill the server.
363 491
364 (aio_write $fh, 0, (length $value), $value, 0) <= 0 492 # we seemingly have to make a local copy of the whole thing,
365 and return; 493 # otherwise perl prematurely frees the stuff :/
494 # TODO: investigate and fix (likely this will be rather laborious)
366 495
367 # always fsync - this file is important 496 my @res = Coro::Util::fork_eval {
368 aio_fsync $fh 497 reset_signals;
369 and return; 498 &$cb
499 }, @args;
370 500
371 close $fh 501 wantarray ? @res : $res[-1]
372 or return; 502}
373 503
374 aio_rename "$runtime~", $runtime 504=item $value = cf::db_get $family => $key
375 and return;
376 505
506Returns a single value from the environment database.
507
508=item cf::db_put $family => $key => $value
509
510Stores the given C<$value> in the family. It can currently store binary
511data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
512
513=cut
514
515our $DB;
516
517sub db_init {
518 unless ($DB) {
519 $DB = BDB::db_create $DB_ENV;
520
521 cf::sync_job {
522 eval {
523 $DB->set_flags (BDB::CHKSUM);
524
525 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
526 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
527 cf::cleanup "db_open(db): $!" if $!;
528 };
529 cf::cleanup "db_open(db): $@" if $@;
530 };
377 1 531 }
532}
533
534sub db_get($$) {
535 my $key = "$_[0]/$_[1]";
536
537 cf::sync_job {
538 BDB::db_get $DB, undef, $key, my $data;
539
540 $! ? ()
541 : $data
542 }
543}
544
545sub db_put($$$) {
546 BDB::dbreq_pri 4;
547 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
548}
549
550=item cf::cache $id => [$paths...], $processversion => $process
551
552Generic caching function that returns the value of the resource $id,
553caching and regenerating as required.
554
555This function can block.
556
557=cut
558
559sub cache {
560 my ($id, $src, $processversion, $process) = @_;
561
562 my $meta =
563 join "\x00",
564 $processversion,
565 map {
566 aio_stat $_
567 and Carp::croak "$_: $!";
568
569 ($_, (stat _)[7,9])
570 } @$src;
571
572 my $dbmeta = db_get cache => "$id/meta";
573 if ($dbmeta ne $meta) {
574 # changed, we may need to process
575
576 my @data;
577 my $md5;
578
579 for (0 .. $#$src) {
580 0 <= aio_load $src->[$_], $data[$_]
581 or Carp::croak "$src->[$_]: $!";
582 }
583
584 # if processing is expensive, check
585 # checksum first
586 if (1) {
587 $md5 =
588 join "\x00",
589 $processversion,
590 map {
591 cf::cede_to_tick;
592 ($src->[$_], Digest::MD5::md5_hex $data[$_])
593 } 0.. $#$src;
594
595
596 my $dbmd5 = db_get cache => "$id/md5";
597 if ($dbmd5 eq $md5) {
598 db_put cache => "$id/meta", $meta;
599
600 return db_get cache => "$id/data";
601 }
602 }
603
604 my $t1 = Time::HiRes::time;
605 my $data = $process->(\@data);
606 my $t2 = Time::HiRes::time;
607
608 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
609
610 db_put cache => "$id/data", $data;
611 db_put cache => "$id/md5" , $md5;
612 db_put cache => "$id/meta", $meta;
613
614 return $data;
615 }
616
617 db_get cache => "$id/data"
378} 618}
379 619
380=item cf::datalog type => key => value, ... 620=item cf::datalog type => key => value, ...
381 621
382Log a datalog packet of the given type with the given key-value pairs. 622Log a datalog packet of the given type with the given key-value pairs.
400attach callbacks/event handlers (a collection of which is called an "attachment") 640attach callbacks/event handlers (a collection of which is called an "attachment")
401to it. All such attachable objects support the following methods. 641to it. All such attachable objects support the following methods.
402 642
403In the following description, CLASS can be any of C<global>, C<object> 643In the following description, CLASS can be any of C<global>, C<object>
404C<player>, C<client> or C<map> (i.e. the attachable objects in 644C<player>, C<client> or C<map> (i.e. the attachable objects in
405crossfire+). 645Crossfire TRT).
406 646
407=over 4 647=over 4
408 648
409=item $attachable->attach ($attachment, key => $value...) 649=item $attachable->attach ($attachment, key => $value...)
410 650
573 $registry = $CB_TYPE[$object_type] ||= []; 813 $registry = $CB_TYPE[$object_type] ||= [];
574 814
575 } elsif ($type eq "subtype") { 815 } elsif ($type eq "subtype") {
576 defined $object_type or Carp::croak "subtype specified without type"; 816 defined $object_type or Carp::croak "subtype specified without type";
577 my $object_subtype = shift @arg; 817 my $object_subtype = shift @arg;
578 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 818 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
579 819
580 } elsif ($type eq "package") { 820 } elsif ($type eq "package") {
581 my $pkg = shift @arg; 821 my $pkg = shift @arg;
582 822
583 while (my ($name, $id) = each %cb_id) { 823 while (my ($name, $id) = each %cb_id) {
612 _attach $registry, $klass, @attach; 852 _attach $registry, $klass, @attach;
613 } 853 }
614 854
615 $obj->{$name} = \%arg; 855 $obj->{$name} = \%arg;
616 } else { 856 } else {
617 warn "object uses attachment '$name' that is not available, postponing.\n"; 857 warn "object uses attachment '$name' which is not available, postponing.\n";
618 } 858 }
619 859
620 $obj->{_attachment}{$name} = undef; 860 $obj->{_attachment}{$name} = undef;
621} 861}
622 862
624 if (ref $_[0]) { 864 if (ref $_[0]) {
625 _object_attach @_; 865 _object_attach @_;
626 } else { 866 } else {
627 _attach shift->_attach_registry, @_; 867 _attach shift->_attach_registry, @_;
628 } 868 }
869 _recalc_want;
629}; 870};
630 871
631# all those should be optimised 872# all those should be optimised
632sub cf::attachable::detach { 873sub cf::attachable::detach {
633 my ($obj, $name) = @_; 874 my ($obj, $name) = @_;
636 delete $obj->{_attachment}{$name}; 877 delete $obj->{_attachment}{$name};
637 reattach ($obj); 878 reattach ($obj);
638 } else { 879 } else {
639 Carp::croak "cannot, currently, detach class attachments"; 880 Carp::croak "cannot, currently, detach class attachments";
640 } 881 }
882 _recalc_want;
641}; 883};
642 884
643sub cf::attachable::attached { 885sub cf::attachable::attached {
644 my ($obj, $name) = @_; 886 my ($obj, $name) = @_;
645 887
660 "; 902 ";
661 die if $@; 903 die if $@;
662} 904}
663 905
664our $override; 906our $override;
665our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 907our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
666 908
667sub override { 909sub override {
668 $override = 1; 910 $override = 1;
669 @invoke_results = (); 911 @INVOKE_RESULTS = (@_);
670} 912}
671 913
672sub do_invoke { 914sub do_invoke {
673 my $event = shift; 915 my $event = shift;
674 my $callbacks = shift; 916 my $callbacks = shift;
675 917
676 @invoke_results = (); 918 @INVOKE_RESULTS = ();
677 919
678 local $override; 920 local $override;
679 921
680 for (@$callbacks) { 922 for (@$callbacks) {
681 eval { &{$_->[1]} }; 923 eval { &{$_->[1]} };
698 940
699Generate an object-specific event with the given arguments. 941Generate an object-specific event with the given arguments.
700 942
701This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be 943This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
702removed in future versions), and there is no public API to access override 944removed in future versions), and there is no public API to access override
703results (if you must, access C<@cf::invoke_results> directly). 945results (if you must, access C<@cf::INVOKE_RESULTS> directly).
704 946
705=back 947=back
706 948
707=cut 949=cut
708 950
709############################################################################# 951#############################################################################
710# object support 952# object support
953#
954
955sub _can_merge {
956 my ($ob1, $ob2) = @_;
957
958 local $Storable::canonical = 1;
959 my $fob1 = Storable::freeze $ob1;
960 my $fob2 = Storable::freeze $ob2;
961
962 $fob1 eq $fob2
963}
711 964
712sub reattach { 965sub reattach {
713 # basically do the same as instantiate, without calling instantiate 966 # basically do the same as instantiate, without calling instantiate
714 my ($obj) = @_; 967 my ($obj) = @_;
715 968
759 }, 1012 },
760); 1013);
761 1014
762sub object_freezer_save { 1015sub object_freezer_save {
763 my ($filename, $rdata, $objs) = @_; 1016 my ($filename, $rdata, $objs) = @_;
1017
1018 my $guard = cf::lock_acquire "io";
764 1019
765 sync_job { 1020 sync_job {
766 if (length $$rdata) { 1021 if (length $$rdata) {
767 warn sprintf "saving %s (%d,%d)\n", 1022 warn sprintf "saving %s (%d,%d)\n",
768 $filename, length $$rdata, scalar @$objs; 1023 $filename, length $$rdata, scalar @$objs;
792 } 1047 }
793 } else { 1048 } else {
794 aio_unlink $filename; 1049 aio_unlink $filename;
795 aio_unlink "$filename.pst"; 1050 aio_unlink "$filename.pst";
796 } 1051 }
797 } 1052 };
1053
1054 undef $guard;
798} 1055}
799 1056
800sub object_freezer_as_string { 1057sub object_freezer_as_string {
801 my ($rdata, $objs) = @_; 1058 my ($rdata, $objs) = @_;
802 1059
807 1064
808sub object_thawer_load { 1065sub object_thawer_load {
809 my ($filename) = @_; 1066 my ($filename) = @_;
810 1067
811 my ($data, $av); 1068 my ($data, $av);
1069
1070 my $guard = cf::lock_acquire "io";
812 1071
813 (aio_load $filename, $data) >= 0 1072 (aio_load $filename, $data) >= 0
814 or return; 1073 or return;
815 1074
816 unless (aio_stat "$filename.pst") { 1075 unless (aio_stat "$filename.pst") {
817 (aio_load "$filename.pst", $av) >= 0 1076 (aio_load "$filename.pst", $av) >= 0
818 or return; 1077 or return;
1078
1079 undef $guard;
819 $av = eval { (Storable::thaw $av)->{objs} }; 1080 $av = eval { (Storable::thaw $av)->{objs} };
820 } 1081 }
821 1082
822 warn sprintf "loading %s (%d)\n", 1083 warn sprintf "loading %s (%d)\n",
823 $filename, length $data, scalar @{$av || []};#d# 1084 $filename, length $data, scalar @{$av || []};
1085
824 return ($data, $av); 1086 ($data, $av)
825} 1087}
1088
1089=head2 COMMAND CALLBACKS
1090
1091=over 4
1092
1093=cut
826 1094
827############################################################################# 1095#############################################################################
828# command handling &c 1096# command handling &c
829 1097
830=item cf::register_command $name => \&callback($ob,$args); 1098=item cf::register_command $name => \&callback($ob,$args);
843 push @{ $COMMAND{$name} }, [$caller, $cb]; 1111 push @{ $COMMAND{$name} }, [$caller, $cb];
844} 1112}
845 1113
846=item cf::register_extcmd $name => \&callback($pl,$packet); 1114=item cf::register_extcmd $name => \&callback($pl,$packet);
847 1115
848Register a callbackf ro execution when the client sends an extcmd packet. 1116Register a callback for execution when the client sends an (synchronous)
1117extcmd packet. Ext commands will be processed in the order they are
1118received by the server, like other user commands. The first argument is
1119the logged-in player. Ext commands can only be processed after a player
1120has logged in successfully.
849 1121
850If the callback returns something, it is sent back as if reply was being 1122If the callback returns something, it is sent back as if reply was being
851called. 1123called.
852 1124
1125=item cf::register_exticmd $name => \&callback($ns,$packet);
1126
1127Register a callback for execution when the client sends an (asynchronous)
1128exticmd packet. Exti commands are processed by the server as soon as they
1129are received, i.e. out of order w.r.t. other commands. The first argument
1130is a client socket. Exti commands can be received anytime, even before
1131log-in.
1132
1133If the callback returns something, it is sent back as if reply was being
1134called.
1135
853=cut 1136=cut
854 1137
855sub register_extcmd { 1138sub register_extcmd {
856 my ($name, $cb) = @_; 1139 my ($name, $cb) = @_;
857 1140
858 $EXTCMD{$name} = $cb; 1141 $EXTCMD{$name} = $cb;
1142}
1143
1144sub register_exticmd {
1145 my ($name, $cb) = @_;
1146
1147 $EXTICMD{$name} = $cb;
859} 1148}
860 1149
861cf::player->attach ( 1150cf::player->attach (
862 on_command => sub { 1151 on_command => sub {
863 my ($pl, $name, $params) = @_; 1152 my ($pl, $name, $params) = @_;
872 cf::override; 1161 cf::override;
873 }, 1162 },
874 on_extcmd => sub { 1163 on_extcmd => sub {
875 my ($pl, $buf) = @_; 1164 my ($pl, $buf) = @_;
876 1165
877 my $msg = eval { from_json $buf }; 1166 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
878 1167
879 if (ref $msg) { 1168 if (ref $msg) {
1169 my ($type, $reply, @payload) =
1170 "ARRAY" eq ref $msg
1171 ? @$msg
1172 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1173
1174 my @reply;
1175
880 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1176 if (my $cb = $EXTCMD{$type}) {
881 if (my %reply = $cb->($pl, $msg)) { 1177 @reply = $cb->($pl, @payload);
882 $pl->ext_reply ($msg->{msgid}, %reply);
883 }
884 } 1178 }
1179
1180 $pl->ext_reply ($reply, @reply)
1181 if $reply;
1182
885 } else { 1183 } else {
886 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1184 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
887 } 1185 }
888 1186
889 cf::override; 1187 cf::override;
890 }, 1188 },
891); 1189);
892 1190
893sub load_extension {
894 my ($path) = @_;
895
896 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
897 my $base = $1;
898 my $pkg = $1;
899 $pkg =~ s/[^[:word:]]/_/g;
900 $pkg = "ext::$pkg";
901
902 warn "... loading '$path' into '$pkg'\n";
903
904 open my $fh, "<:utf8", $path
905 or die "$path: $!";
906
907 my $source =
908 "package $pkg; use strict; use utf8;\n"
909 . "#line 1 \"$path\"\n{\n"
910 . (do { local $/; <$fh> })
911 . "\n};\n1";
912
913 unless (eval $source) {
914 my $msg = $@ ? "$path: $@\n"
915 : "extension disabled.\n";
916 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
917 warn $@;
918 warn "mandatory extension failed to load, exiting.\n";
919 exit 1;
920 }
921 die $@;
922 }
923
924 push @EXTS, $pkg;
925}
926
927sub load_extensions { 1191sub load_extensions {
1192 cf::sync_job {
1193 my %todo;
1194
928 for my $ext (<$LIBDIR/*.ext>) { 1195 for my $path (<$LIBDIR/*.ext>) {
929 next unless -r $ext; 1196 next unless -r $path;
930 eval { 1197
931 load_extension $ext; 1198 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1199 my $base = $1;
1200 my $pkg = $1;
1201 $pkg =~ s/[^[:word:]]/_/g;
1202 $pkg = "ext::$pkg";
1203
1204 open my $fh, "<:utf8", $path
1205 or die "$path: $!";
1206
1207 my $source = do { local $/; <$fh> };
1208
1209 my %ext = (
1210 path => $path,
1211 base => $base,
1212 pkg => $pkg,
1213 );
1214
1215 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1216 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1217
1218 $ext{source} =
1219 "package $pkg; use strict; use utf8;\n"
1220 . "#line 1 \"$path\"\n{\n"
1221 . $source
1222 . "\n};\n1";
1223
1224 $todo{$base} = \%ext;
1225 }
1226
1227 my %done;
1228 while (%todo) {
1229 my $progress;
1230
1231 while (my ($k, $v) = each %todo) {
1232 for (split /,\s*/, $v->{meta}{depends}) {
1233 goto skip
1234 unless exists $done{$_};
1235 }
1236
1237 warn "... loading '$k' into '$v->{pkg}'\n";
1238
1239 unless (eval $v->{source}) {
1240 my $msg = $@ ? "$v->{path}: $@\n"
1241 : "$v->{base}: extension inactive.\n";
1242
1243 if (exists $v->{meta}{mandatory}) {
1244 warn $msg;
1245 warn "mandatory extension failed to load, exiting.\n";
1246 exit 1;
1247 }
1248
1249 warn $msg;
1250 }
1251
1252 $done{$k} = delete $todo{$k};
1253 push @EXTS, $v->{pkg};
1254 $progress = 1;
932 1 1255 }
933 } or warn "$ext not loaded: $@"; 1256
1257 skip:
1258 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1259 unless $progress;
1260 }
934 } 1261 };
935} 1262}
936 1263
937############################################################################# 1264#############################################################################
938 1265
1266=back
1267
939=head2 CORE EXTENSIONS 1268=head2 CORE EXTENSIONS
940 1269
941Functions and methods that extend core crossfire objects. 1270Functions and methods that extend core crossfire objects.
942 1271
943=cut 1272=cut
955Returns the given player object, loading it if necessary (might block). 1284Returns the given player object, loading it if necessary (might block).
956 1285
957=cut 1286=cut
958 1287
959sub playerdir($) { 1288sub playerdir($) {
960 cf::localdir 1289 "$PLAYERDIR/"
961 . "/"
962 . cf::playerdir
963 . "/"
964 . (ref $_[0] ? $_[0]->ob->name : $_[0]) 1290 . (ref $_[0] ? $_[0]->ob->name : $_[0])
965} 1291}
966 1292
967sub path($) { 1293sub path($) {
968 my $login = ref $_[0] ? $_[0]->ob->name : $_[0]; 1294 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
995 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst"; 1321 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
996 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata"; 1322 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
997 aio_unlink +(playerdir $login) . "/$login.pl.pst"; 1323 aio_unlink +(playerdir $login) . "/$login.pl.pst";
998 aio_unlink +(playerdir $login) . "/$login.pl"; 1324 aio_unlink +(playerdir $login) . "/$login.pl";
999 1325
1000 my $pl = load_pl path $login 1326 my $f = new_from_file cf::object::thawer path $login
1001 or return; 1327 or return;
1328
1329 $f->next;
1330 my $pl = cf::player::load_pl $f
1331 or return;
1332 local $cf::PLAYER_LOADING{$login} = $pl;
1333 $f->resolve_delayed_derefs;
1002 $cf::PLAYER{$login} = $pl 1334 $cf::PLAYER{$login} = $pl
1003 } 1335 }
1004 } 1336 }
1005} 1337}
1006 1338
1016 1348
1017 aio_mkdir playerdir $pl, 0770; 1349 aio_mkdir playerdir $pl, 0770;
1018 $pl->{last_save} = $cf::RUNTIME; 1350 $pl->{last_save} = $cf::RUNTIME;
1019 1351
1020 $pl->save_pl ($path); 1352 $pl->save_pl ($path);
1021 Coro::cede; 1353 cf::cede_to_tick;
1022} 1354}
1023 1355
1024sub new($) { 1356sub new($) {
1025 my ($login) = @_; 1357 my ($login) = @_;
1026 1358
1030 $self->{deny_save} = 1; 1362 $self->{deny_save} = 1;
1031 1363
1032 $cf::PLAYER{$login} = $self; 1364 $cf::PLAYER{$login} = $self;
1033 1365
1034 $self 1366 $self
1367}
1368
1369=item $player->send_msg ($channel, $msg, $color, [extra...])
1370
1371=cut
1372
1373sub send_msg {
1374 my $ns = shift->ns
1375 or return;
1376 $ns->send_msg (@_);
1035} 1377}
1036 1378
1037=item $pl->quit_character 1379=item $pl->quit_character
1038 1380
1039Nukes the player without looking back. If logged in, the connection will 1381Nukes the player without looking back. If logged in, the connection will
1088while and may block, so not sync_job-capable, ever. 1430while and may block, so not sync_job-capable, ever.
1089 1431
1090=cut 1432=cut
1091 1433
1092sub list_logins { 1434sub list_logins {
1093 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir 1435 my $dirs = aio_readdir $PLAYERDIR
1094 or return []; 1436 or return [];
1095 1437
1096 my @logins; 1438 my @logins;
1097 1439
1098 for my $login (@$dirs) { 1440 for my $login (@$dirs) {
1441 my $path = path $login;
1442
1443 # a .pst is a dead give-away for a valid player
1444 unless (-e "$path.pst") {
1099 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1445 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1100 aio_read $fh, 0, 512, my $buf, 0 or next; 1446 aio_read $fh, 0, 512, my $buf, 0 or next;
1101 $buf !~ /^password -------------$/m or next; # official not-valid tag 1447 $buf !~ /^password -------------$/m or next; # official not-valid tag
1448 }
1102 1449
1103 utf8::decode $login; 1450 utf8::decode $login;
1104 push @logins, $login; 1451 push @logins, $login;
1105 } 1452 }
1106 1453
1133 } 1480 }
1134 1481
1135 \@paths 1482 \@paths
1136} 1483}
1137 1484
1485=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1486
1487Expand crossfire pod fragments into protocol xml.
1488
1489=cut
1490
1491sub expand_cfpod {
1492 ((my $self), (local $_)) = @_;
1493
1494 # escape & and <
1495 s/&/&amp;/g;
1496 s/(?<![BIUGHT])</&lt;/g;
1497
1498 # this is buggy, it needs to properly take care of nested <'s
1499
1500 1 while
1501 # replace B<>, I<>, U<> etc.
1502 s/B<([^\>]*)>/<b>$1<\/b>/
1503 || s/I<([^\>]*)>/<i>$1<\/i>/
1504 || s/U<([^\>]*)>/<u>$1<\/u>/
1505 || s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/
1506 # replace G<male|female> tags
1507 || s{G<([^>|]*)\|([^>]*)>}{
1508 $self->gender ? $2 : $1
1509 }ge
1510 # replace H<hint text>
1511 || s{H<([^\>]*)>}
1512 {
1513 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
1514 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1515 "")
1516 [$self->{hintmode}]
1517 }ge;
1518
1519 # create single paragraphs (very hackish)
1520 s/(?<=\S)\n(?=\w)/ /g;
1521
1522 # compress some whitespace
1523 s/\s+\n/\n/g; # ws line-ends
1524 s/\n\n+/\n/g; # double lines
1525 s/^\n+//; # beginning lines
1526 s/\n+$//; # ending lines
1527
1528 $_
1529}
1530
1531sub hintmode {
1532 $_[0]{hintmode} = $_[1] if @_ > 1;
1533 $_[0]{hintmode}
1534}
1535
1138=item $player->ext_reply ($msgid, %msg) 1536=item $player->ext_reply ($msgid, @msg)
1139 1537
1140Sends an ext reply to the player. 1538Sends an ext reply to the player.
1141 1539
1142=cut 1540=cut
1143 1541
1144sub ext_reply($$%) { 1542sub ext_reply($$@) {
1145 my ($self, $id, %msg) = @_; 1543 my ($self, $id, @msg) = @_;
1146 1544
1147 $msg{msgid} = $id; 1545 $self->ns->ext_reply ($id, @msg)
1148
1149 $self->send ("ext " . cf::to_json \%msg);
1150} 1546}
1151 1547
1152=item $player->ext_event ($type, %msg) 1548=item $player->ext_msg ($type, @msg)
1153 1549
1154Sends an ext event to the client. 1550Sends an ext event to the client.
1155 1551
1156=cut 1552=cut
1157 1553
1158sub ext_event($$%) { 1554sub ext_msg($$@) {
1159 my ($self, $type, %msg) = @_; 1555 my ($self, $type, @msg) = @_;
1160 1556
1161 $self->ns->ext_event ($type, %msg); 1557 $self->ns->ext_msg ($type, @msg);
1162} 1558}
1163 1559
1164package cf; 1560=head3 cf::region
1561
1562=over 4
1563
1564=cut
1565
1566package cf::region;
1567
1568=item cf::region::find_by_path $path
1569
1570Tries to decuce the likely region for a map knowing only its path.
1571
1572=cut
1573
1574sub find_by_path($) {
1575 my ($path) = @_;
1576
1577 my ($match, $specificity);
1578
1579 for my $region (list) {
1580 if ($region->{match} && $path =~ $region->{match}) {
1581 ($match, $specificity) = ($region, $region->specificity)
1582 if $region->specificity > $specificity;
1583 }
1584 }
1585
1586 $match
1587}
1165 1588
1166=back 1589=back
1167
1168 1590
1169=head3 cf::map 1591=head3 cf::map
1170 1592
1171=over 4 1593=over 4
1172 1594
1227 my ($self, $merge) = @_; 1649 my ($self, $merge) = @_;
1228 1650
1229 # we have to keep some variables in memory intact 1651 # we have to keep some variables in memory intact
1230 local $self->{path}; 1652 local $self->{path};
1231 local $self->{load_path}; 1653 local $self->{load_path};
1232 local $self->{deny_save};
1233 local $self->{deny_reset};
1234 1654
1235 $self->SUPER::thawer_merge ($merge); 1655 $self->SUPER::thawer_merge ($merge);
1236} 1656}
1237 1657
1238sub normalise { 1658sub normalise {
1285 $self->init; # pass $1 etc. 1705 $self->init; # pass $1 etc.
1286 return $self; 1706 return $self;
1287 } 1707 }
1288 } 1708 }
1289 1709
1290 Carp::carp "unable to resolve path '$path' (base '$base')."; 1710 Carp::cluck "unable to resolve path '$path' (base '$base').";
1291 () 1711 ()
1292} 1712}
1293 1713
1294sub init { 1714sub init {
1295 my ($self) = @_; 1715 my ($self) = @_;
1310 1730
1311# the original (read-only) location 1731# the original (read-only) location
1312sub load_path { 1732sub load_path {
1313 my ($self) = @_; 1733 my ($self) = @_;
1314 1734
1315 sprintf "%s/%s/%s.map", cf::datadir, cf::mapdir, $self->{path} 1735 "$MAPDIR/$self->{path}.map"
1316} 1736}
1317 1737
1318# the temporary/swap location 1738# the temporary/swap location
1319sub save_path { 1739sub save_path {
1320 my ($self) = @_; 1740 my ($self) = @_;
1321 1741
1322 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1742 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1323 sprintf "%s/%s/%s.map", cf::localdir, cf::tmpdir, $path 1743 "$TMPDIR/$path.map"
1324} 1744}
1325 1745
1326# the unique path, undef == no special unique path 1746# the unique path, undef == no special unique path
1327sub uniq_path { 1747sub uniq_path {
1328 my ($self) = @_; 1748 my ($self) = @_;
1329 1749
1330 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1750 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1331 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $path 1751 "$UNIQUEDIR/$path"
1332} 1752}
1333 1753
1334# and all this just because we cannot iterate over 1754# and all this just because we cannot iterate over
1335# all maps in C++... 1755# all maps in C++...
1336sub change_all_map_light { 1756sub change_all_map_light {
1338 1758
1339 $_->change_map_light ($change) 1759 $_->change_map_light ($change)
1340 for grep $_->outdoor, values %cf::MAP; 1760 for grep $_->outdoor, values %cf::MAP;
1341} 1761}
1342 1762
1763sub decay_objects {
1764 my ($self) = @_;
1765
1766 return if $self->{deny_reset};
1767
1768 $self->do_decay_objects;
1769}
1770
1343sub unlink_save { 1771sub unlink_save {
1344 my ($self) = @_; 1772 my ($self) = @_;
1345 1773
1346 utf8::encode (my $save = $self->save_path); 1774 utf8::encode (my $save = $self->save_path);
1347 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save; 1775 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
1350 1778
1351sub load_header_from($) { 1779sub load_header_from($) {
1352 my ($self, $path) = @_; 1780 my ($self, $path) = @_;
1353 1781
1354 utf8::encode $path; 1782 utf8::encode $path;
1355 #aio_open $path, O_RDONLY, 0 1783 my $f = new_from_file cf::object::thawer $path
1356 # or return;
1357
1358 $self->_load_header ($path)
1359 or return; 1784 or return;
1785
1786 $self->_load_header ($f)
1787 or return;
1788
1789 local $MAP_LOADING{$self->{path}} = $self;
1790 $f->resolve_delayed_derefs;
1360 1791
1361 $self->{load_path} = $path; 1792 $self->{load_path} = $path;
1362 1793
1363 1 1794 1
1364} 1795}
1403 $self->load_header_orig 1834 $self->load_header_orig
1404 or return; 1835 or return;
1405 $self->prepare_orig; 1836 $self->prepare_orig;
1406 } 1837 }
1407 1838
1839 $self->{deny_reset} = 1
1840 if $self->no_reset;
1841
1842 $self->default_region (cf::region::find_by_path $self->{path})
1843 unless $self->default_region;
1844
1408 1 1845 1
1409} 1846}
1410 1847
1411sub find; 1848sub find;
1412sub find { 1849sub find {
1413 my ($path, $origin) = @_; 1850 my ($path, $origin) = @_;
1414 1851
1415 $path = normalise $path, $origin && $origin->path; 1852 $path = normalise $path, $origin && $origin->path;
1416 1853
1854 cf::lock_wait "map_data:$path";#d#remove
1417 cf::lock_wait "map_find:$path"; 1855 cf::lock_wait "map_find:$path";
1418 1856
1419 $cf::MAP{$path} || do { 1857 $cf::MAP{$path} || do {
1420 my $guard = cf::lock_acquire "map_find:$path"; 1858 my $guard1 = cf::lock_acquire "map_find:$path";
1859 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1860
1421 my $map = new_from_path cf::map $path 1861 my $map = new_from_path cf::map $path
1422 or return; 1862 or return;
1423 1863
1424 $map->{last_save} = $cf::RUNTIME; 1864 $map->{last_save} = $cf::RUNTIME;
1425 1865
1426 $map->load_header 1866 $map->load_header
1427 or return; 1867 or return;
1428 1868
1429 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?) 1869 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1430 # doing this can freeze the server in a sync job, obviously 1870 # doing this can freeze the server in a sync job, obviously
1431 #$cf::WAIT_FOR_TICK->wait; 1871 #$cf::WAIT_FOR_TICK->wait;
1872 undef $guard1;
1873 undef $guard2;
1432 $map->reset; 1874 $map->reset;
1433 undef $guard;
1434 return find $path; 1875 return find $path;
1435 } 1876 }
1436 1877
1437 $cf::MAP{$path} = $map 1878 $cf::MAP{$path} = $map
1438 } 1879 }
1445 my ($self) = @_; 1886 my ($self) = @_;
1446 1887
1447 local $self->{deny_reset} = 1; # loading can take a long time 1888 local $self->{deny_reset} = 1; # loading can take a long time
1448 1889
1449 my $path = $self->{path}; 1890 my $path = $self->{path};
1891
1892 {
1450 my $guard = cf::lock_acquire "map_load:$path"; 1893 my $guard = cf::lock_acquire "map_data:$path";
1451 1894
1895 return unless $self->valid;
1452 return if $self->in_memory != cf::MAP_SWAPPED; 1896 return unless $self->in_memory == cf::MAP_SWAPPED;
1453 1897
1454 $self->in_memory (cf::MAP_LOADING); 1898 $self->in_memory (cf::MAP_LOADING);
1455 1899
1456 $self->alloc; 1900 $self->alloc;
1457 1901
1458 $self->pre_load; 1902 $self->pre_load;
1903 cf::cede_to_tick;
1459 1904
1460 $self->_load_objects ($self->{load_path}, 1) 1905 my $f = new_from_file cf::object::thawer $self->{load_path};
1906 $f->skip_block;
1907 $self->_load_objects ($f)
1461 or return; 1908 or return;
1462 1909
1463 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 1910 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1464 if delete $self->{load_original}; 1911 if delete $self->{load_original};
1465 1912
1466 if (my $uniq = $self->uniq_path) { 1913 if (my $uniq = $self->uniq_path) {
1467 utf8::encode $uniq; 1914 utf8::encode $uniq;
1468 if (aio_open $uniq, O_RDONLY, 0) { 1915 unless (aio_stat $uniq) {
1916 if (my $f = new_from_file cf::object::thawer $uniq) {
1469 $self->clear_unique_items; 1917 $self->clear_unique_items;
1470 $self->_load_objects ($uniq, 0); 1918 $self->_load_objects ($f);
1919 $f->resolve_delayed_derefs;
1920 }
1471 } 1921 }
1472 } 1922 }
1473 1923
1474 Coro::cede; 1924 $f->resolve_delayed_derefs;
1475 1925
1926 cf::cede_to_tick;
1476 # now do the right thing for maps 1927 # now do the right thing for maps
1477 $self->link_multipart_objects; 1928 $self->link_multipart_objects;
1478
1479 unless ($self->{deny_activate}) {
1480 $self->decay_objects;
1481 $self->fix_auto_apply;
1482 $self->update_buttons;
1483 Coro::cede;
1484 $self->set_darkness_map;
1485 $self->difficulty ($self->estimate_difficulty) 1929 $self->difficulty ($self->estimate_difficulty)
1486 unless $self->difficulty; 1930 unless $self->difficulty;
1487 Coro::cede; 1931 cf::cede_to_tick;
1932
1933 unless ($self->{deny_activate}) {
1934 $self->decay_objects;
1935 $self->fix_auto_apply;
1936 $self->update_buttons;
1937 cf::cede_to_tick;
1938 $self->set_darkness_map;
1939 cf::cede_to_tick;
1488 $self->activate; 1940 $self->activate;
1941 }
1942
1943 $self->{last_save} = $cf::RUNTIME;
1944 $self->last_access ($cf::RUNTIME);
1945
1946 $self->in_memory (cf::MAP_IN_MEMORY);
1489 } 1947 }
1490 1948
1491 $self->post_load; 1949 $self->post_load;
1492
1493 $self->in_memory (cf::MAP_IN_MEMORY);
1494} 1950}
1495 1951
1496sub customise_for { 1952sub customise_for {
1497 my ($self, $ob) = @_; 1953 my ($self, $ob) = @_;
1498 1954
1499 return find "~" . $ob->name . "/" . $self->{path} 1955 return find "~" . $ob->name . "/" . $self->{path}
1500 if $self->per_player; 1956 if $self->per_player;
1501 1957
1958# return find "?party/" . $ob->name . "/" . $self->{path}
1959# if $self->per_party;
1960
1502 $self 1961 $self
1503} 1962}
1504 1963
1505# find and load all maps in the 3x3 area around a map 1964# find and load all maps in the 3x3 area around a map
1506sub load_diag { 1965sub load_neighbours {
1507 my ($map) = @_; 1966 my ($map) = @_;
1508 1967
1509 my @diag; # diagonal neighbours 1968 my @neigh; # diagonal neighbours
1510 1969
1511 for (0 .. 3) { 1970 for (0 .. 3) {
1512 my $neigh = $map->tile_path ($_) 1971 my $neigh = $map->tile_path ($_)
1513 or next; 1972 or next;
1514 $neigh = find $neigh, $map 1973 $neigh = find $neigh, $map
1515 or next; 1974 or next;
1516 $neigh->load; 1975 $neigh->load;
1517 1976
1977 push @neigh,
1518 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 1978 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1519 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 1979 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1520 } 1980 }
1521 1981
1522 for (@diag) { 1982 for (grep defined $_->[0], @neigh) {
1983 my ($path, $origin) = @$_;
1523 my $neigh = find @$_ 1984 my $neigh = find $path, $origin
1524 or next; 1985 or next;
1525 $neigh->load; 1986 $neigh->load;
1526 } 1987 }
1527} 1988}
1528 1989
1533} 1994}
1534 1995
1535sub do_load_sync { 1996sub do_load_sync {
1536 my ($map) = @_; 1997 my ($map) = @_;
1537 1998
1999 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
2000 if $Coro::current == $Coro::main;
2001
1538 cf::sync_job { $map->load }; 2002 cf::sync_job { $map->load };
1539} 2003}
1540 2004
1541our %MAP_PREFETCH; 2005our %MAP_PREFETCH;
1542our $MAP_PREFETCHER = undef; 2006our $MAP_PREFETCHER = undef;
1543 2007
1544sub find_async { 2008sub find_async {
1545 my ($path, $origin) = @_; 2009 my ($path, $origin, $load) = @_;
1546 2010
1547 $path = normalise $path, $origin && $origin->{path}; 2011 $path = normalise $path, $origin && $origin->{path};
1548 2012
1549 if (my $map = $cf::MAP{$path}) { 2013 if (my $map = $cf::MAP{$path}) {
1550 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 2014 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY;
1551 } 2015 }
1552 2016
1553 undef $MAP_PREFETCH{$path}; 2017 $MAP_PREFETCH{$path} |= $load;
2018
1554 $MAP_PREFETCHER ||= cf::async { 2019 $MAP_PREFETCHER ||= cf::async {
1555 while (%MAP_PREFETCH) { 2020 while (%MAP_PREFETCH) {
1556 for my $path (keys %MAP_PREFETCH) { 2021 while (my ($k, $v) = each %MAP_PREFETCH) {
1557 my $map = find $path 2022 if (my $map = find $k) {
1558 or next;
1559 $map->load; 2023 $map->load if $v;
2024 }
1560 2025
1561 delete $MAP_PREFETCH{$path}; 2026 delete $MAP_PREFETCH{$k};
1562 } 2027 }
1563 } 2028 }
1564 undef $MAP_PREFETCHER; 2029 undef $MAP_PREFETCHER;
1565 }; 2030 };
1566 $MAP_PREFETCHER->prio (6); 2031 $MAP_PREFETCHER->prio (6);
1569} 2034}
1570 2035
1571sub save { 2036sub save {
1572 my ($self) = @_; 2037 my ($self) = @_;
1573 2038
1574 my $lock = cf::lock_acquire "map_data:" . $self->path; 2039 my $lock = cf::lock_acquire "map_data:$self->{path}";
1575 2040
1576 $self->{last_save} = $cf::RUNTIME; 2041 $self->{last_save} = $cf::RUNTIME;
1577 2042
1578 return unless $self->dirty; 2043 return unless $self->dirty;
1579 2044
1602 my ($self) = @_; 2067 my ($self) = @_;
1603 2068
1604 # save first because save cedes 2069 # save first because save cedes
1605 $self->save; 2070 $self->save;
1606 2071
1607 my $lock = cf::lock_acquire "map_data:" . $self->path; 2072 my $lock = cf::lock_acquire "map_data:$self->{path}";
1608 2073
1609 return if $self->players; 2074 return if $self->players;
1610 return if $self->in_memory != cf::MAP_IN_MEMORY; 2075 return if $self->in_memory != cf::MAP_IN_MEMORY;
1611 return if $self->{deny_save}; 2076 return if $self->{deny_save};
1612 2077
2078 $self->in_memory (cf::MAP_SWAPPED);
2079
2080 $self->deactivate;
2081 $_->clear_links_to ($self) for values %cf::MAP;
1613 $self->clear; 2082 $self->clear;
1614 $self->in_memory (cf::MAP_SWAPPED);
1615} 2083}
1616 2084
1617sub reset_at { 2085sub reset_at {
1618 my ($self) = @_; 2086 my ($self) = @_;
1619 2087
1620 # TODO: safety, remove and allow resettable per-player maps 2088 # TODO: safety, remove and allow resettable per-player maps
1621 return 1e99 if $self->isa ("ext::map_per_player");#d#
1622 return 1e99 if $self->{deny_reset}; 2089 return 1e99 if $self->{deny_reset};
1623 2090
1624 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 2091 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1625 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 2092 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1626 2093
1637 my ($self) = @_; 2104 my ($self) = @_;
1638 2105
1639 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2106 my $lock = cf::lock_acquire "map_data:$self->{path}";
1640 2107
1641 return if $self->players; 2108 return if $self->players;
1642 return if $self->isa ("ext::map_per_player");#d#
1643 2109
1644 warn "resetting map ", $self->path;#d# 2110 warn "resetting map ", $self->path;
1645 2111
1646 $self->in_memory (cf::MAP_SWAPPED); 2112 $self->in_memory (cf::MAP_SWAPPED);
1647 2113
1648 # need to save uniques path 2114 # need to save uniques path
1649 unless ($self->{deny_save}) { 2115 unless ($self->{deny_save}) {
1653 if $uniq; 2119 if $uniq;
1654 } 2120 }
1655 2121
1656 delete $cf::MAP{$self->path}; 2122 delete $cf::MAP{$self->path};
1657 2123
2124 $self->deactivate;
2125 $_->clear_links_to ($self) for values %cf::MAP;
1658 $self->clear; 2126 $self->clear;
1659
1660 $_->clear_links_to ($self) for values %cf::MAP;
1661 2127
1662 $self->unlink_save; 2128 $self->unlink_save;
1663 $self->destroy; 2129 $self->destroy;
1664} 2130}
1665 2131
1666my $nuke_counter = "aaaa"; 2132my $nuke_counter = "aaaa";
1667 2133
1668sub nuke { 2134sub nuke {
1669 my ($self) = @_; 2135 my ($self) = @_;
1670 2136
2137 {
2138 my $lock = cf::lock_acquire "map_data:$self->{path}";
2139
1671 delete $cf::MAP{$self->path}; 2140 delete $cf::MAP{$self->path};
1672 2141
1673 $self->unlink_save; 2142 $self->unlink_save;
1674 2143
1675 bless $self, "cf::map"; 2144 bless $self, "cf::map";
1676 delete $self->{deny_reset}; 2145 delete $self->{deny_reset};
1677 $self->{deny_save} = 1; 2146 $self->{deny_save} = 1;
1678 $self->reset_timeout (1); 2147 $self->reset_timeout (1);
1679 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2148 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1680 2149
1681 $cf::MAP{$self->path} = $self; 2150 $cf::MAP{$self->path} = $self;
2151 }
1682 2152
1683 $self->reset; # polite request, might not happen 2153 $self->reset; # polite request, might not happen
2154}
2155
2156=item $maps = cf::map::tmp_maps
2157
2158Returns an arrayref with all map paths of currently instantiated and saved
2159maps. May block.
2160
2161=cut
2162
2163sub tmp_maps() {
2164 [
2165 map {
2166 utf8::decode $_;
2167 /\.map$/
2168 ? normalise $_
2169 : ()
2170 } @{ aio_readdir $TMPDIR or [] }
2171 ]
2172}
2173
2174=item $maps = cf::map::random_maps
2175
2176Returns an arrayref with all map paths of currently instantiated and saved
2177random maps. May block.
2178
2179=cut
2180
2181sub random_maps() {
2182 [
2183 map {
2184 utf8::decode $_;
2185 /\.map$/
2186 ? normalise "?random/$_"
2187 : ()
2188 } @{ aio_readdir $RANDOMDIR or [] }
2189 ]
1684} 2190}
1685 2191
1686=item cf::map::unique_maps 2192=item cf::map::unique_maps
1687 2193
1688Returns an arrayref of paths of all shared maps that have 2194Returns an arrayref of paths of all shared maps that have
1689instantiated unique items. May block. 2195instantiated unique items. May block.
1690 2196
1691=cut 2197=cut
1692 2198
1693sub unique_maps() { 2199sub unique_maps() {
1694 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir 2200 [
1695 or return; 2201 map {
1696
1697 my @paths;
1698
1699 for (@$files) {
1700 utf8::decode $_; 2202 utf8::decode $_;
1701 next if /\.pst$/; 2203 /\.map$/
1702 next unless /^$PATH_SEP/o; 2204 ? normalise $_
1703 2205 : ()
1704 push @paths, cf::map::normalise $_; 2206 } @{ aio_readdir $UNIQUEDIR or [] }
1705 } 2207 ]
1706
1707 \@paths
1708} 2208}
1709 2209
1710package cf; 2210package cf;
1711 2211
1712=back 2212=back
1730 map { $_, inv_recursive_ $_->inv } @_ 2230 map { $_, inv_recursive_ $_->inv } @_
1731} 2231}
1732 2232
1733sub inv_recursive { 2233sub inv_recursive {
1734 inv_recursive_ inv $_[0] 2234 inv_recursive_ inv $_[0]
2235}
2236
2237=item $ref = $ob->ref
2238
2239creates and returns a persistent reference to an objetc that can be stored as a string.
2240
2241=item $ob = cf::object::deref ($refstring)
2242
2243returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2244even if the object actually exists. May block.
2245
2246=cut
2247
2248sub deref {
2249 my ($ref) = @_;
2250
2251 # temporary compatibility#TODO#remove
2252 $ref =~ s{^<}{player/<};
2253
2254 if ($ref =~ m{^player\/(<1\.\d+>)/(.*)$}) {
2255 my ($uuid, $name) = ($1, $2);
2256 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2257 or return;
2258 $pl->ob->uuid eq $uuid
2259 or return;
2260
2261 $pl->ob
2262 } else {
2263 warn "$ref: cannot resolve object reference\n";
2264 undef
2265 }
1735} 2266}
1736 2267
1737package cf; 2268package cf;
1738 2269
1739=back 2270=back
1758 2289
1759 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2290 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1760 2291
1761 if ($self->{record_replies}) { 2292 if ($self->{record_replies}) {
1762 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2293 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2294
1763 } else { 2295 } else {
2296 my $pl = $self->contr;
2297
2298 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2299 my $dialog = $pl->{npc_dialog};
2300 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2301
2302 } else {
1764 $msg = $npc->name . " says: $msg" if $npc; 2303 $msg = $npc->name . " says: $msg" if $npc;
1765 $self->message ($msg, $flags); 2304 $self->message ($msg, $flags);
2305 }
1766 } 2306 }
2307}
2308
2309=item $object->send_msg ($channel, $msg, $color, [extra...])
2310
2311=cut
2312
2313sub cf::object::send_msg {
2314 my $pl = shift->contr
2315 or return;
2316 $pl->send_msg (@_);
1767} 2317}
1768 2318
1769=item $player_object->may ("access") 2319=item $player_object->may ("access")
1770 2320
1771Returns wether the given player is authorized to access resource "access" 2321Returns wether the given player is authorized to access resource "access"
1818 $self->deactivate_recursive; 2368 $self->deactivate_recursive;
1819 2369
1820 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2370 return if UNIVERSAL::isa $self->map, "ext::map_link";
1821 2371
1822 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2372 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1823 if $self->map; 2373 if $self->map && $self->map->{path} ne "{link}";
1824 2374
1825 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2375 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1826} 2376}
1827 2377
1828sub cf::object::player::leave_link { 2378sub cf::object::player::leave_link {
1829 my ($self, $map, $x, $y) = @_; 2379 my ($self, $map, $x, $y) = @_;
2380
2381 return unless $self->contr->active;
1830 2382
1831 my $link_pos = delete $self->{_link_pos}; 2383 my $link_pos = delete $self->{_link_pos};
1832 2384
1833 unless ($map) { 2385 unless ($map) {
1834 # restore original map position 2386 # restore original map position
1848 # use -1 or undef as default coordinates, not 0, 0 2400 # use -1 or undef as default coordinates, not 0, 0
1849 ($x, $y) = ($map->enter_x, $map->enter_y) 2401 ($x, $y) = ($map->enter_x, $map->enter_y)
1850 if $x <=0 && $y <= 0; 2402 if $x <=0 && $y <= 0;
1851 2403
1852 $map->load; 2404 $map->load;
1853 $map->load_diag; 2405 $map->load_neighbours;
1854 2406
1855 return unless $self->contr->active; 2407 return unless $self->contr->active;
1856 $self->activate_recursive; 2408 $self->activate_recursive;
1857 2409
1858 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2410 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1859 $self->enter_map ($map, $x, $y); 2411 $self->enter_map ($map, $x, $y);
1860} 2412}
1861 2413
1862cf::player->attach ( 2414=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
1863 on_logout => sub {
1864 my ($pl) = @_;
1865 2415
1866 # abort map switching before logout 2416Moves the player to the given map-path and coordinates by first freezing
1867 if ($pl->ob->{_link_pos}) { 2417her, loading and preparing them map, calling the provided $check callback
1868 cf::sync_job { 2418that has to return the map if sucecssful, and then unfreezes the player on
1869 $pl->ob->leave_link 2419the new (success) or old (failed) map position. In either case, $done will
1870 }; 2420be called at the end of this process.
1871 }
1872 },
1873 on_login => sub {
1874 my ($pl) = @_;
1875 2421
1876 # try to abort aborted map switching on player login :)
1877 # should happen only on crashes
1878 if ($pl->ob->{_link_pos}) {
1879 $pl->ob->enter_link;
1880 (async {
1881 $pl->ob->reply (undef,
1882 "There was an internal problem at your last logout, "
1883 . "the server will try to bring you to your intended destination in a second.",
1884 cf::NDI_RED);
1885 # we need this sleep as the login has a concurrent enter_exit running
1886 # and this sleep increases chances of the player not ending up in scorn
1887 Coro::Timer::sleep 1;
1888 $pl->ob->leave_link;
1889 })->prio (2);
1890 }
1891 },
1892);
1893
1894=item $player_object->goto ($path, $x, $y)
1895
1896=cut 2422=cut
2423
2424our $GOTOGEN;
1897 2425
1898sub cf::object::player::goto { 2426sub cf::object::player::goto {
1899 my ($self, $path, $x, $y) = @_; 2427 my ($self, $path, $x, $y, $check, $done) = @_;
2428
2429 # do generation counting so two concurrent goto's will be executed in-order
2430 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1900 2431
1901 $self->enter_link; 2432 $self->enter_link;
1902 2433
1903 (async { 2434 (async {
1904 my $map = eval { 2435 my $map = eval {
1905 my $map = cf::map::find $path; 2436 my $map = cf::map::find $path;
2437
2438 if ($map) {
1906 $map = $map->customise_for ($self) if $map; 2439 $map = $map->customise_for ($self);
2440 $map = $check->($map) if $check && $map;
2441 } else {
2442 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
2443 }
2444
1907 $map 2445 $map
2446 };
2447
2448 if ($@) {
2449 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2450 LOG llevError | logBacktrace, Carp::longmess $@;
1908 } or 2451 }
1909 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1910 2452
2453 if ($gen == $self->{_goto_generation}) {
2454 delete $self->{_goto_generation};
1911 $self->leave_link ($map, $x, $y); 2455 $self->leave_link ($map, $x, $y);
2456 }
2457
2458 $done->() if $done;
1912 })->prio (1); 2459 })->prio (1);
1913} 2460}
1914 2461
1915=item $player_object->enter_exit ($exit_object) 2462=item $player_object->enter_exit ($exit_object)
1916 2463
1955 2502
1956 $rmp->{random_seed} ||= $exit->random_seed; 2503 $rmp->{random_seed} ||= $exit->random_seed;
1957 2504
1958 my $data = cf::to_json $rmp; 2505 my $data = cf::to_json $rmp;
1959 my $md5 = Digest::MD5::md5_hex $data; 2506 my $md5 = Digest::MD5::md5_hex $data;
1960 my $meta = "$cf::RANDOM_MAPS/$md5.meta"; 2507 my $meta = "$RANDOMDIR/$md5.meta";
1961 2508
1962 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2509 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1963 aio_write $fh, 0, (length $data), $data, 0; 2510 aio_write $fh, 0, (length $data), $data, 0;
1964 undef $fh; 2511 undef $fh;
1965 aio_rename "$meta~", $meta; 2512 aio_rename "$meta~", $meta;
1984 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path; 2531 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
1985 my $hp = $exit->stats->hp; 2532 my $hp = $exit->stats->hp;
1986 my $sp = $exit->stats->sp; 2533 my $sp = $exit->stats->sp;
1987 2534
1988 $self->enter_link; 2535 $self->enter_link;
2536
2537 # if exit is damned, update players death & WoR home-position
2538 $self->contr->savebed ($slaying, $hp, $sp)
2539 if $exit->flag (FLAG_DAMNED);
1989 2540
1990 (async { 2541 (async {
1991 $self->deactivate_recursive; # just to be sure 2542 $self->deactivate_recursive; # just to be sure
1992 unless (eval { 2543 unless (eval {
1993 $self->goto ($slaying, $hp, $sp); 2544 $self->goto ($slaying, $hp, $sp);
2021 2572
2022 utf8::encode $text; 2573 utf8::encode $text;
2023 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2574 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2024} 2575}
2025 2576
2577=item $client->send_msg ($channel, $msg, $color, [extra...])
2578
2579Send a drawinfo or msg packet to the client, formatting the msg for the
2580client if neccessary. C<$type> should be a string identifying the type of
2581the message, with C<log> being the default. If C<$color> is negative, suppress
2582the message unless the client supports the msg packet.
2583
2584=cut
2585
2586our %CHANNEL = (
2587 "c/identify" => {
2588 id => "identify",
2589 title => "Identify",
2590 reply => undef,
2591 tooltip => "Items recently identified",
2592 },
2593 "c/examine" => {
2594 id => "examine",
2595 title => "Examine",
2596 reply => undef,
2597 tooltip => "Signs and other items you examined",
2598 },
2599);
2600
2601sub cf::client::send_msg {
2602 my ($self, $channel, $msg, $color, @extra) = @_;
2603
2604 $msg = $self->pl->expand_cfpod ($msg);
2605
2606 $color &= cf::NDI_CLIENT_MASK; # just in case...
2607
2608 # check predefined channels, for the benefit of C
2609 $channel = $CHANNEL{$channel} if $CHANNEL{$channel};
2610
2611 if (ref $channel) {
2612 # send meta info to client, if not yet sent
2613 unless (exists $self->{channel}{$channel->{id}}) {
2614 $self->{channel}{$channel->{id}} = $channel;
2615 $self->ext_msg (channel_info => $channel)
2616 if $self->can_msg;
2617 }
2618
2619 $channel = $channel->{id};
2620 }
2621
2622 return unless @extra || length $msg;
2623
2624 if ($self->can_msg) {
2625 # default colour, mask it out
2626 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2627 if $color & cf::NDI_DEF;
2628
2629 $self->send_packet ("msg " . $self->{json_coder}->encode (
2630 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2631 } else {
2632 if ($color >= 0) {
2633 # replace some tags by gcfclient-compatible ones
2634 for ($msg) {
2635 1 while
2636 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2637 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2638 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2639 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2640 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2641 }
2642
2643 $color &= cf::NDI_COLOR_MASK;
2644
2645 utf8::encode $msg;
2646
2647 if (0 && $msg =~ /\[/) {
2648 # COMMAND/INFO
2649 $self->send_packet ("drawextinfo $color 10 8 $msg")
2650 } else {
2651 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2652 $self->send_packet ("drawinfo $color $msg")
2653 }
2654 }
2655 }
2656}
2657
2026=item $client->ext_event ($type, %msg) 2658=item $client->ext_msg ($type, @msg)
2027 2659
2028Sends an exti event to the client. 2660Sends an ext event to the client.
2029 2661
2030=cut 2662=cut
2031 2663
2032sub cf::client::ext_event($$%) { 2664sub cf::client::ext_msg($$@) {
2033 my ($self, $type, %msg) = @_; 2665 my ($self, $type, @msg) = @_;
2034 2666
2667 if ($self->extcmd == 2) {
2668 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2669 } elsif ($self->extcmd == 1) { # TODO: remove
2035 $msg{msgtype} = "event_$type"; 2670 push @msg, msgtype => "event_$type";
2036 $self->send_packet ("ext " . cf::to_json \%msg); 2671 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2672 }
2673}
2674
2675=item $client->ext_reply ($msgid, @msg)
2676
2677Sends an ext reply to the client.
2678
2679=cut
2680
2681sub cf::client::ext_reply($$@) {
2682 my ($self, $id, @msg) = @_;
2683
2684 if ($self->extcmd == 2) {
2685 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2686 } elsif ($self->extcmd == 1) {
2687 #TODO: version 1, remove
2688 unshift @msg, msgtype => "reply", msgid => $id;
2689 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2690 }
2037} 2691}
2038 2692
2039=item $success = $client->query ($flags, "text", \&cb) 2693=item $success = $client->query ($flags, "text", \&cb)
2040 2694
2041Queues a query to the client, calling the given callback with 2695Queues a query to the client, calling the given callback with
2042the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2696the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
2043C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 2697C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2044 2698
2045Queries can fail, so check the return code. Or don't, as queries will become 2699Queries can fail, so check the return code. Or don't, as queries will
2046reliable at some point in the future. 2700become reliable at some point in the future.
2047 2701
2048=cut 2702=cut
2049 2703
2050sub cf::client::query { 2704sub cf::client::query {
2051 my ($self, $flags, $text, $cb) = @_; 2705 my ($self, $flags, $text, $cb) = @_;
2059 utf8::encode $text; 2713 utf8::encode $text;
2060 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2714 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2061 2715
2062 $self->send_packet ($self->{query_queue}[0][0]) 2716 $self->send_packet ($self->{query_queue}[0][0])
2063 if @{ $self->{query_queue} } == 1; 2717 if @{ $self->{query_queue} } == 1;
2718
2719 1
2064} 2720}
2065 2721
2066cf::client->attach ( 2722cf::client->attach (
2723 on_connect => sub {
2724 my ($ns) = @_;
2725
2726 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2727 },
2067 on_reply => sub { 2728 on_reply => sub {
2068 my ($ns, $msg) = @_; 2729 my ($ns, $msg) = @_;
2069 2730
2070 # this weird shuffling is so that direct followup queries 2731 # this weird shuffling is so that direct followup queries
2071 # get handled first 2732 # get handled first
2083 } else { 2744 } else {
2084 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 2745 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2085 } 2746 }
2086 } 2747 }
2087 }, 2748 },
2749 on_exticmd => sub {
2750 my ($ns, $buf) = @_;
2751
2752 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2753
2754 if (ref $msg) {
2755 my ($type, $reply, @payload) =
2756 "ARRAY" eq ref $msg
2757 ? @$msg
2758 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
2759
2760 my @reply;
2761
2762 if (my $cb = $EXTICMD{$type}) {
2763 @reply = $cb->($ns, @payload);
2764 }
2765
2766 $ns->ext_reply ($reply, @reply)
2767 if $reply;
2768
2769 } else {
2770 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2771 }
2772
2773 cf::override;
2774 },
2088); 2775);
2089 2776
2090=item $client->async (\&cb) 2777=item $client->async (\&cb)
2091 2778
2092Create a new coroutine, running the specified callback. The coroutine will 2779Create a new coroutine, running the specified callback. The coroutine will
2133our $safe = new Safe "safe"; 2820our $safe = new Safe "safe";
2134our $safe_hole = new Safe::Hole; 2821our $safe_hole = new Safe::Hole;
2135 2822
2136$SIG{FPE} = 'IGNORE'; 2823$SIG{FPE} = 'IGNORE';
2137 2824
2138$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 2825$safe->permit_only (Opcode::opset qw(
2826 :base_core :base_mem :base_orig :base_math
2827 grepstart grepwhile mapstart mapwhile
2828 sort time
2829));
2139 2830
2140# here we export the classes and methods available to script code 2831# here we export the classes and methods available to script code
2141 2832
2142=pod 2833=pod
2143 2834
2144The following functions and methods are available within a safe environment: 2835The following functions and methods are available within a safe environment:
2145 2836
2146 cf::object contr pay_amount pay_player map 2837 cf::object
2838 contr pay_amount pay_player map x y force_find force_add
2839 insert remove name archname title slaying race decrease_ob_nr
2840
2147 cf::object::player player 2841 cf::object::player
2148 cf::player peaceful 2842 player
2149 cf::map trigger 2843
2844 cf::player
2845 peaceful
2846
2847 cf::map
2848 trigger
2150 2849
2151=cut 2850=cut
2152 2851
2153for ( 2852for (
2154 ["cf::object" => qw(contr pay_amount pay_player map)], 2853 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2854 insert remove inv name archname title slaying race
2855 decrease_ob_nr)],
2155 ["cf::object::player" => qw(player)], 2856 ["cf::object::player" => qw(player)],
2156 ["cf::player" => qw(peaceful)], 2857 ["cf::player" => qw(peaceful)],
2157 ["cf::map" => qw(trigger)], 2858 ["cf::map" => qw(trigger)],
2158) { 2859) {
2159 no strict 'refs'; 2860 no strict 'refs';
2230=back 2931=back
2231 2932
2232=cut 2933=cut
2233 2934
2234############################################################################# 2935#############################################################################
2235
2236=head2 EXTENSION DATABASE SUPPORT
2237
2238Crossfire maintains a very simple database for extension use. It can
2239currently store anything that can be serialised using Storable, which
2240excludes objects.
2241
2242The parameter C<$family> should best start with the name of the extension
2243using it, it should be unique.
2244
2245=over 4
2246
2247=item $value = cf::db_get $family => $key
2248
2249Returns a single value from the database.
2250
2251=item cf::db_put $family => $key => $value
2252
2253Stores the given C<$value> in the family.
2254
2255=cut
2256
2257our $DB;
2258
2259sub db_init {
2260 unless ($DB) {
2261 $DB = BDB::db_create $DB_ENV;
2262
2263 cf::sync_job {
2264 eval {
2265 $DB->set_flags (BDB::CHKSUM);
2266
2267 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2268 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2269 cf::cleanup "db_open(db): $!" if $!;
2270 };
2271 cf::cleanup "db_open(db): $@" if $@;
2272 };
2273
2274 my $path = cf::localdir . "/database.pst";
2275 if (stat $path) {
2276 cf::sync_job {
2277 my $pst = Storable::retrieve $path;
2278
2279 cf::db_put (board => data => $pst->{board});
2280 cf::db_put (guildrules => data => $pst->{guildrules});
2281 cf::db_put (rent => balance => $pst->{rent}{balance});
2282 BDB::db_env_txn_checkpoint $DB_ENV;
2283
2284 unlink $path;
2285 };
2286 }
2287 }
2288}
2289
2290sub db_get($$) {
2291 my $key = "$_[0]/$_[1]";
2292
2293 cf::sync_job {
2294 BDB::db_get $DB, undef, $key, my $data;
2295
2296 $! ? ()
2297 : Compress::LZF::sthaw $data
2298 }
2299}
2300
2301sub db_put($$$) {
2302 BDB::dbreq_pri 4;
2303 BDB::db_put $DB, undef, "$_[0]/$_[1]", Compress::LZF::sfreeze_cr $_[2], 0, sub { };
2304}
2305
2306#############################################################################
2307# the server's init and main functions 2936# the server's init and main functions
2308 2937
2309sub load_facedata { 2938sub load_facedata($) {
2310 my $path = sprintf "%s/facedata", cf::datadir; 2939 my ($path) = @_;
2940
2941 # HACK to clear player env face cache, we need some signal framework
2942 # for this (global event?)
2943 %ext::player_env::MUSIC_FACE_CACHE = ();
2944
2945 my $enc = JSON::XS->new->utf8->canonical->relaxed;
2311 2946
2312 warn "loading facedata from $path\n"; 2947 warn "loading facedata from $path\n";
2313 2948
2314 my $facedata; 2949 my $facedata;
2315 0 < aio_load $path, $facedata 2950 0 < aio_load $path, $facedata
2318 $facedata = Coro::Storable::thaw $facedata; 2953 $facedata = Coro::Storable::thaw $facedata;
2319 2954
2320 $facedata->{version} == 2 2955 $facedata->{version} == 2
2321 or cf::cleanup "$path: version mismatch, cannot proceed."; 2956 or cf::cleanup "$path: version mismatch, cannot proceed.";
2322 2957
2958 # patch in the exptable
2959 $facedata->{resource}{"res/exp_table"} = {
2960 type => FT_RSRC,
2961 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
2962 };
2963 cf::cede_to_tick;
2964
2323 { 2965 {
2324 my $faces = $facedata->{faceinfo}; 2966 my $faces = $facedata->{faceinfo};
2325 2967
2326 while (my ($face, $info) = each %$faces) { 2968 while (my ($face, $info) = each %$faces) {
2327 my $idx = (cf::face::find $face) || cf::face::alloc $face; 2969 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2328 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 2970 cf::face::set_visibility $idx, $info->{visibility};
2971 cf::face::set_magicmap $idx, $info->{magicmap};
2329 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 2972 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2330 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 2973 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2331 Coro::cede; 2974
2975 cf::cede_to_tick;
2332 } 2976 }
2333 2977
2334 while (my ($face, $info) = each %$faces) { 2978 while (my ($face, $info) = each %$faces) {
2335 next unless $info->{smooth}; 2979 next unless $info->{smooth};
2336 my $idx = cf::face::find $face 2980 my $idx = cf::face::find $face
2337 or next; 2981 or next;
2338 if (my $smooth = cf::face::find $info->{smooth}) { 2982 if (my $smooth = cf::face::find $info->{smooth}) {
2983 cf::face::set_smooth $idx, $smooth;
2339 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel}; 2984 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2340 } else { 2985 } else {
2341 warn "smooth face '$info->{smooth}' not found for face '$face'"; 2986 warn "smooth face '$info->{smooth}' not found for face '$face'";
2342 } 2987 }
2343 Coro::cede; 2988
2989 cf::cede_to_tick;
2344 } 2990 }
2345 } 2991 }
2346 2992
2347 { 2993 {
2348 my $anims = $facedata->{animinfo}; 2994 my $anims = $facedata->{animinfo};
2349 2995
2350 while (my ($anim, $info) = each %$anims) { 2996 while (my ($anim, $info) = each %$anims) {
2351 cf::anim::set $anim, $info->{frames}, $info->{facings}; 2997 cf::anim::set $anim, $info->{frames}, $info->{facings};
2352 Coro::cede; 2998 cf::cede_to_tick;
2353 } 2999 }
2354 3000
2355 cf::anim::invalidate_all; # d'oh 3001 cf::anim::invalidate_all; # d'oh
2356 } 3002 }
2357 3003
3004 {
3005 # TODO: for gcfclient pleasure, we should give resources
3006 # that gcfclient doesn't grok a >10000 face index.
3007 my $res = $facedata->{resource};
3008
3009 my $soundconf = delete $res->{"res/sound.conf"};
3010
3011 while (my ($name, $info) = each %$res) {
3012 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3013 my $data;
3014
3015 if ($info->{type} & 1) {
3016 # prepend meta info
3017
3018 my $meta = $enc->encode ({
3019 name => $name,
3020 %{ $info->{meta} || {} },
3021 });
3022
3023 $data = pack "(w/a*)*", $meta, $info->{data};
3024 } else {
3025 $data = $info->{data};
3026 }
3027
3028 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3029 cf::face::set_type $idx, $info->{type};
3030
3031 cf::cede_to_tick;
3032 }
3033
3034 if ($soundconf) {
3035 $soundconf = $enc->decode (delete $soundconf->{data});
3036
3037 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3038 my $sound = $soundconf->{compat}[$_]
3039 or next;
3040
3041 my $face = cf::face::find "sound/$sound->[1]";
3042 cf::sound::set $sound->[0] => $face;
3043 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3044 }
3045
3046 while (my ($k, $v) = each %{$soundconf->{event}}) {
3047 my $face = cf::face::find "sound/$v";
3048 cf::sound::set $k => $face;
3049 }
3050 }
3051 }
3052
2358 1 3053 1
2359} 3054}
2360 3055
3056register_exticmd fx_want => sub {
3057 my ($ns, $want) = @_;
3058
3059 while (my ($k, $v) = each %$want) {
3060 $ns->fx_want ($k, $v);
3061 }
3062};
3063
3064sub reload_regions {
3065 # HACK to clear player env face cache, we need some signal framework
3066 # for this (global event?)
3067 %ext::player_env::MUSIC_FACE_CACHE = ();
3068
3069 load_resource_file "$MAPDIR/regions"
3070 or die "unable to load regions file\n";
3071
3072 for (cf::region::list) {
3073 $_->{match} = qr/$_->{match}/
3074 if exists $_->{match};
3075 }
3076}
3077
3078sub reload_facedata {
3079 load_facedata "$DATADIR/facedata"
3080 or die "unable to load facedata\n";
3081}
3082
3083sub reload_archetypes {
3084 load_resource_file "$DATADIR/archetypes"
3085 or die "unable to load archetypes\n";
3086 #d# NEED to laod twice to resolve forward references
3087 # this really needs to be done in an extra post-pass
3088 # (which needs to be synchronous, so solve it differently)
3089 load_resource_file "$DATADIR/archetypes"
3090 or die "unable to load archetypes\n";
3091}
3092
3093sub reload_treasures {
3094 load_resource_file "$DATADIR/treasures"
3095 or die "unable to load treasurelists\n";
3096}
3097
2361sub reload_resources { 3098sub reload_resources {
2362 load_resource_file sprintf "%s/%s/regions", cf::datadir, cf::mapdir 3099 warn "reloading resource files...\n";
2363 or die "unable to load regions file\n";#d# 3100
3101 reload_regions;
2364 load_facedata 3102 reload_facedata;
2365 or die "unable to load facedata\n";#d# 3103 #reload_archetypes;#d#
3104 reload_archetypes;
3105 reload_treasures;
3106
3107 warn "finished reloading resource files\n";
2366} 3108}
2367 3109
2368sub init { 3110sub init {
2369 reload_resources; 3111 reload_resources;
2370} 3112}
2371 3113
2372sub cfg_load { 3114sub reload_config {
2373 open my $fh, "<:utf8", cf::confdir . "/config" 3115 open my $fh, "<:utf8", "$CONFDIR/config"
2374 or return; 3116 or return;
2375 3117
2376 local $/; 3118 local $/;
2377 *CFG = YAML::Syck::Load <$fh>; 3119 *CFG = YAML::Syck::Load <$fh>;
2378 3120
2397 (async { 3139 (async {
2398 Event::one_event; 3140 Event::one_event;
2399 })->prio (Coro::PRIO_MAX); 3141 })->prio (Coro::PRIO_MAX);
2400 }; 3142 };
2401 3143
2402 cfg_load; 3144 reload_config;
2403 db_init; 3145 db_init;
2404 load_extensions; 3146 load_extensions;
2405 3147
2406 $TICK_WATCHER->start; 3148 $TICK_WATCHER->start;
2407 Event::loop; 3149 Event::loop;
2423 }, 3165 },
2424 ); 3166 );
2425 } 3167 }
2426} 3168}
2427 3169
3170sub write_runtime {
3171 my $runtime = "$LOCALDIR/runtime";
3172
3173 # first touch the runtime file to show we are still running:
3174 # the fsync below can take a very very long time.
3175
3176 IO::AIO::aio_utime $runtime, undef, undef;
3177
3178 my $guard = cf::lock_acquire "write_runtime";
3179
3180 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
3181 or return;
3182
3183 my $value = $cf::RUNTIME + 90 + 10;
3184 # 10 is the runtime save interval, for a monotonic clock
3185 # 60 allows for the watchdog to kill the server.
3186
3187 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3188 and return;
3189
3190 # always fsync - this file is important
3191 aio_fsync $fh
3192 and return;
3193
3194 # touch it again to show we are up-to-date
3195 aio_utime $fh, undef, undef;
3196
3197 close $fh
3198 or return;
3199
3200 aio_rename "$runtime~", $runtime
3201 and return;
3202
3203 warn "runtime file written.\n";
3204
3205 1
3206}
3207
2428sub emergency_save() { 3208sub emergency_save() {
2429 my $freeze_guard = cf::freeze_mainloop; 3209 my $freeze_guard = cf::freeze_mainloop;
2430 3210
2431 warn "enter emergency perl save\n"; 3211 warn "enter emergency perl save\n";
2432 3212
2463 3243
2464 warn Carp::longmess "post_cleanup backtrace" 3244 warn Carp::longmess "post_cleanup backtrace"
2465 if $make_core; 3245 if $make_core;
2466} 3246}
2467 3247
2468sub reload() { 3248sub do_reload_perl() {
2469 # can/must only be called in main 3249 # can/must only be called in main
2470 if ($Coro::current != $Coro::main) { 3250 if ($Coro::current != $Coro::main) {
2471 warn "can only reload from main coroutine"; 3251 warn "can only reload from main coroutine";
2472 return; 3252 return;
2473 } 3253 }
2507 %EXT_CORO = (); 3287 %EXT_CORO = ();
2508 3288
2509 warn "removing commands"; 3289 warn "removing commands";
2510 %COMMAND = (); 3290 %COMMAND = ();
2511 3291
2512 warn "removing ext commands"; 3292 warn "removing ext/exti commands";
2513 %EXTCMD = (); 3293 %EXTCMD = ();
3294 %EXTICMD = ();
2514 3295
2515 warn "unloading/nuking all extensions"; 3296 warn "unloading/nuking all extensions";
2516 for my $pkg (@EXTS) { 3297 for my $pkg (@EXTS) {
2517 warn "... unloading $pkg"; 3298 warn "... unloading $pkg";
2518 3299
2548 Symbol::delete_package "safe::$_" 3329 Symbol::delete_package "safe::$_"
2549 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3330 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2550 3331
2551 warn "unloading cf.pm \"a bit\""; 3332 warn "unloading cf.pm \"a bit\"";
2552 delete $INC{"cf.pm"}; 3333 delete $INC{"cf.pm"};
3334 delete $INC{"cf/pod.pm"};
2553 3335
2554 # don't, removes xs symbols, too, 3336 # don't, removes xs symbols, too,
2555 # and global variables created in xs 3337 # and global variables created in xs
2556 #Symbol::delete_package __PACKAGE__; 3338 #Symbol::delete_package __PACKAGE__;
2557 3339
2560 warn "reloading cf.pm"; 3342 warn "reloading cf.pm";
2561 require cf; 3343 require cf;
2562 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3344 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2563 3345
2564 warn "loading config and database again"; 3346 warn "loading config and database again";
2565 cf::cfg_load; 3347 cf::reload_config;
2566 3348
2567 warn "loading extensions"; 3349 warn "loading extensions";
2568 cf::load_extensions; 3350 cf::load_extensions;
2569 3351
2570 warn "reattaching attachments to objects/players"; 3352 warn "reattaching attachments to objects/players";
2572 warn "reattaching attachments to maps"; 3354 warn "reattaching attachments to maps";
2573 reattach $_ for values %MAP; 3355 reattach $_ for values %MAP;
2574 warn "reattaching attachments to players"; 3356 warn "reattaching attachments to players";
2575 reattach $_ for values %PLAYER; 3357 reattach $_ for values %PLAYER;
2576 3358
2577 warn "loading reloadable resources";
2578 reload_resources;
2579
2580 warn "leaving sync_job"; 3359 warn "leaving sync_job";
2581 3360
2582 1 3361 1
2583 } or do { 3362 } or do {
2584 warn $@; 3363 warn $@;
2589 warn "reloaded"; 3368 warn "reloaded";
2590}; 3369};
2591 3370
2592our $RELOAD_WATCHER; # used only during reload 3371our $RELOAD_WATCHER; # used only during reload
2593 3372
3373sub reload_perl() {
3374 # doing reload synchronously and two reloads happen back-to-back,
3375 # coro crashes during coro_state_free->destroy here.
3376
3377 $RELOAD_WATCHER ||= Event->timer (
3378 reentrant => 0,
3379 after => 0,
3380 data => WF_AUTOCANCEL,
3381 cb => sub {
3382 do_reload_perl;
3383 undef $RELOAD_WATCHER;
3384 },
3385 );
3386}
3387
2594register_command "reload" => sub { 3388register_command "reload" => sub {
2595 my ($who, $arg) = @_; 3389 my ($who, $arg) = @_;
2596 3390
2597 if ($who->flag (FLAG_WIZ)) { 3391 if ($who->flag (FLAG_WIZ)) {
2598 $who->message ("reloading server."); 3392 $who->message ("reloading server.");
2599 3393 async { reload_perl };
2600 # doing reload synchronously and two reloads happen back-to-back,
2601 # coro crashes during coro_state_free->destroy here.
2602
2603 $RELOAD_WATCHER ||= Event->timer (
2604 reentrant => 0,
2605 after => 0,
2606 data => WF_AUTOCANCEL,
2607 cb => sub {
2608 reload;
2609 undef $RELOAD_WATCHER;
2610 },
2611 );
2612 } 3394 }
2613}; 3395};
2614 3396
2615unshift @INC, $LIBDIR; 3397unshift @INC, $LIBDIR;
2616 3398
2617my $bug_warning = 0; 3399my $bug_warning = 0;
2618 3400
3401our @WAIT_FOR_TICK;
3402our @WAIT_FOR_TICK_BEGIN;
3403
3404sub wait_for_tick {
3405 return unless $TICK_WATCHER->is_active;
3406 return if $Coro::current == $Coro::main;
3407
3408 my $signal = new Coro::Signal;
3409 push @WAIT_FOR_TICK, $signal;
3410 $signal->wait;
3411}
3412
3413sub wait_for_tick_begin {
3414 return unless $TICK_WATCHER->is_active;
3415 return if $Coro::current == $Coro::main;
3416
3417 my $signal = new Coro::Signal;
3418 push @WAIT_FOR_TICK_BEGIN, $signal;
3419 $signal->wait;
3420}
3421
3422 my $min = 1e6;#d#
3423 my $avg = 10;
2619$TICK_WATCHER = Event->timer ( 3424$TICK_WATCHER = Event->timer (
2620 reentrant => 0, 3425 reentrant => 0,
2621 parked => 1, 3426 parked => 1,
2622 prio => 0, 3427 prio => 0,
2623 at => $NEXT_TICK || $TICK, 3428 at => $NEXT_TICK || $TICK,
2627 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3432 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2628 unless ++$bug_warning > 10; 3433 unless ++$bug_warning > 10;
2629 return; 3434 return;
2630 } 3435 }
2631 3436
2632 $NOW = Event::time; 3437 $NOW = $tick_start = Event::time;
2633 3438
2634 cf::server_tick; # one server iteration 3439 cf::server_tick; # one server iteration
3440
3441 0 && sync_job {#d#
3442 for(1..10) {
3443 my $t = Event::time;
3444 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3445 or die;
3446
3447 $map->width (50);
3448 $map->height (50);
3449 $map->alloc;
3450 $map->_load_objects ("/tmp/x.map", 1); #TODO: does not work
3451 my $t = Event::time - $t;
3452
3453 #next unless $t < 0.0013;#d#
3454 if ($t < $min) {
3455 $min = $t;
3456 }
3457 $avg = $avg * 0.99 + $t * 0.01;
3458 }
3459 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3460 exit 0;
3461 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3462 };
3463
2635 $RUNTIME += $TICK; 3464 $RUNTIME += $TICK;
2636 $NEXT_TICK += $TICK; 3465 $NEXT_TICK += $TICK;
2637 3466
2638 if ($NOW >= $NEXT_RUNTIME_WRITE) { 3467 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2639 $NEXT_RUNTIME_WRITE = $NOW + 10; 3468 $NEXT_RUNTIME_WRITE = $NOW + 10;
2641 write_runtime 3470 write_runtime
2642 or warn "ERROR: unable to write runtime file: $!"; 3471 or warn "ERROR: unable to write runtime file: $!";
2643 }; 3472 };
2644 } 3473 }
2645 3474
2646 $WAIT_FOR_TICK->broadcast;
2647 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited;
2648
2649# my $AFTER = Event::time; 3475# my $AFTER = Event::time;
2650# warn $AFTER - $NOW;#d# 3476# warn $AFTER - $NOW;#d#
2651 3477
3478 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3479 $sig->send;
3480 }
3481 while (my $sig = shift @WAIT_FOR_TICK) {
3482 $sig->send;
3483 }
3484
3485 $NOW = Event::time;
3486
2652 # if we are delayed by four ticks or more, skip them all 3487 # if we are delayed by four ticks or more, skip them all
2653 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 3488 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2654 3489
2655 $TICK_WATCHER->at ($NEXT_TICK); 3490 $TICK_WATCHER->at ($NEXT_TICK);
2656 $TICK_WATCHER->start; 3491 $TICK_WATCHER->start;
3492
3493 $LOAD = ($NOW - $tick_start) / $TICK;
3494 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3495
3496 _post_tick;
3497
3498
2657 }, 3499 },
2658); 3500);
2659 3501
2660{ 3502{
2661 BDB::max_poll_time $TICK * 0.1; 3503 BDB::max_poll_time $TICK * 0.1;
2689 3531
2690 cf::sync_job { 3532 cf::sync_job {
2691 eval { 3533 eval {
2692 BDB::db_env_open 3534 BDB::db_env_open
2693 $DB_ENV, 3535 $DB_ENV,
2694 $BDB_ENV_DIR, 3536 $BDBDIR,
2695 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3537 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2696 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3538 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2697 0666; 3539 0666;
2698 3540
2699 cf::cleanup "db_env_open($BDB_ENV_DIR): $!" if $!; 3541 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2700 3542
2701 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1); 3543 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2702 $DB_ENV->set_lk_detect; 3544 $DB_ENV->set_lk_detect;
2703 }; 3545 };
2704 3546
2720 prio => 6, 3562 prio => 6,
2721 cb => \&IO::AIO::poll_cb, 3563 cb => \&IO::AIO::poll_cb,
2722 ); 3564 );
2723} 3565}
2724 3566
3567my $_log_backtrace;
3568
3569sub _log_backtrace {
3570 my ($msg, @addr) = @_;
3571
3572 $msg =~ s/\n//;
3573
3574 # limit the # of concurrent backtraces
3575 if ($_log_backtrace < 2) {
3576 ++$_log_backtrace;
3577 async {
3578 my @bt = fork_call {
3579 @addr = map { sprintf "%x", $_ } @addr;
3580 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3581 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3582 or die "addr2line: $!";
3583
3584 my @funcs;
3585 my @res = <$fh>;
3586 chomp for @res;
3587 while (@res) {
3588 my ($func, $line) = splice @res, 0, 2, ();
3589 push @funcs, "[$func] $line";
3590 }
3591
3592 @funcs
3593 };
3594
3595 LOG llevInfo, "[ABT] $msg\n";
3596 LOG llevInfo, "[ABT] $_\n" for @bt;
3597 --$_log_backtrace;
3598 };
3599 } else {
3600 LOG llevInfo, "[ABT] $msg\n";
3601 LOG llevInfo, "[ABT] [suppressed]\n";
3602 }
3603}
3604
3605# load additional modules
3606use cf::pod;
3607
2725END { cf::emergency_save } 3608END { cf::emergency_save }
2726 3609
27271 36101
2728 3611

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines