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

Diff Legend

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