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.367 by root, Wed Sep 12 11:10: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 {
2463 # *tag paths override both path and x|y
2464 if ($path =~ /^\*(.*)$/) {
2465 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2466 my $ob = $obs[rand @obs];
2467
2468 # see if we actually can go there
2469 # todo: use ob_blocked to check all tiles of the destination "object"
2470 # for suitability.
2471
2472 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2473 }
2474 }
2475
1880 my $map = eval { 2476 my $map = eval {
1881 my $map = cf::map::find $path; 2477 my $map = cf::map::find $path;
2478
2479 if ($map) {
1882 $map = $map->customise_for ($self) if $map; 2480 $map = $map->customise_for ($self);
2481 $map = $check->($map) if $check && $map;
2482 } else {
2483 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
2484 }
2485
1883 $map 2486 $map
2487 };
2488
2489 if ($@) {
2490 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2491 LOG llevError | logBacktrace, Carp::longmess $@;
1884 } or 2492 }
1885 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1886 2493
2494 if ($gen == $self->{_goto_generation}) {
2495 delete $self->{_goto_generation};
1887 $self->leave_link ($map, $x, $y); 2496 $self->leave_link ($map, $x, $y);
2497 }
2498
2499 $done->() if $done;
1888 })->prio (1); 2500 })->prio (1);
1889} 2501}
1890 2502
1891=item $player_object->enter_exit ($exit_object) 2503=item $player_object->enter_exit ($exit_object)
1892 2504
… …
1931 2543
1932 $rmp->{random_seed} ||= $exit->random_seed; 2544 $rmp->{random_seed} ||= $exit->random_seed;
1933 2545
1934 my $data = cf::to_json $rmp; 2546 my $data = cf::to_json $rmp;
1935 my $md5 = Digest::MD5::md5_hex $data; 2547 my $md5 = Digest::MD5::md5_hex $data;
1936 my $meta = "$cf::RANDOM_MAPS/$md5.meta"; 2548 my $meta = "$RANDOMDIR/$md5.meta";
1937 2549
1938 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2550 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1939 aio_write $fh, 0, (length $data), $data, 0; 2551 aio_write $fh, 0, (length $data), $data, 0;
1940 undef $fh; 2552 undef $fh;
1941 aio_rename "$meta~", $meta; 2553 aio_rename "$meta~", $meta;
… …
1950 2562
1951 return unless $self->type == cf::PLAYER; 2563 return unless $self->type == cf::PLAYER;
1952 2564
1953 if ($exit->slaying eq "/!") { 2565 if ($exit->slaying eq "/!") {
1954 #TODO: this should de-fi-ni-te-ly not be a sync-job 2566 #TODO: this should de-fi-ni-te-ly not be a sync-job
2567 # the problem is that $exit might not survive long enough
2568 # so it needs to be done right now, right here
1955 cf::sync_job { prepare_random_map $exit }; 2569 cf::sync_job { prepare_random_map $exit };
1956 } 2570 }
1957 2571
1958 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path; 2572 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
1959 my $hp = $exit->stats->hp; 2573 my $hp = $exit->stats->hp;
1960 my $sp = $exit->stats->sp; 2574 my $sp = $exit->stats->sp;
1961 2575
1962 $self->enter_link; 2576 $self->enter_link;
2577
2578 # if exit is damned, update players death & WoR home-position
2579 $self->contr->savebed ($slaying, $hp, $sp)
2580 if $exit->flag (FLAG_DAMNED);
1963 2581
1964 (async { 2582 (async {
1965 $self->deactivate_recursive; # just to be sure 2583 $self->deactivate_recursive; # just to be sure
1966 unless (eval { 2584 unless (eval {
1967 $self->goto ($slaying, $hp, $sp); 2585 $self->goto ($slaying, $hp, $sp);
1968 2586
1969 1; 2587 1;
1970 }) { 2588 }) {
1971 $self->message ("Something went wrong deep within the crossfire server. " 2589 $self->message ("Something went wrong deep within the crossfire server. "
1972 . "I'll try to bring you back to the map you were before. " 2590 . "I'll try to bring you back to the map you were before. "
1973 . "Please report this to the dungeon master!", 2591 . "Please report this to the dungeon master!",
1974 cf::NDI_UNIQUE | cf::NDI_RED); 2592 cf::NDI_UNIQUE | cf::NDI_RED);
1975 2593
1976 warn "ERROR in enter_exit: $@"; 2594 warn "ERROR in enter_exit: $@";
1977 $self->leave_link; 2595 $self->leave_link;
1978 } 2596 }
1979 })->prio (1); 2597 })->prio (1);
… …
1992 2610
1993sub cf::client::send_drawinfo { 2611sub cf::client::send_drawinfo {
1994 my ($self, $text, $flags) = @_; 2612 my ($self, $text, $flags) = @_;
1995 2613
1996 utf8::encode $text; 2614 utf8::encode $text;
1997 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 2615 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
1998} 2616}
1999 2617
2618=item $client->send_msg ($channel, $msg, $color, [extra...])
2619
2620Send a drawinfo or msg packet to the client, formatting the msg for the
2621client if neccessary. C<$type> should be a string identifying the type of
2622the message, with C<log> being the default. If C<$color> is negative, suppress
2623the message unless the client supports the msg packet.
2624
2625=cut
2626
2627our %CHANNEL = (
2628 "c/identify" => {
2629 id => "identify",
2630 title => "Identify",
2631 reply => undef,
2632 tooltip => "Items recently identified",
2633 },
2634 "c/examine" => {
2635 id => "examine",
2636 title => "Examine",
2637 reply => undef,
2638 tooltip => "Signs and other items you examined",
2639 },
2640);
2641
2642sub cf::client::send_msg {
2643 my ($self, $channel, $msg, $color, @extra) = @_;
2644
2645 $msg = $self->pl->expand_cfpod ($msg);
2646
2647 $color &= cf::NDI_CLIENT_MASK; # just in case...
2648
2649 # check predefined channels, for the benefit of C
2650 $channel = $CHANNEL{$channel} if $CHANNEL{$channel};
2651
2652 if (ref $channel) {
2653 # send meta info to client, if not yet sent
2654 unless (exists $self->{channel}{$channel->{id}}) {
2655 $self->{channel}{$channel->{id}} = $channel;
2656 $self->ext_msg (channel_info => $channel)
2657 if $self->can_msg;
2658 }
2659
2660 $channel = $channel->{id};
2661 }
2662
2663 return unless @extra || length $msg;
2664
2665 if ($self->can_msg) {
2666 # default colour, mask it out
2667 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2668 if $color & cf::NDI_DEF;
2669
2670 $self->send_packet ("msg " . $self->{json_coder}->encode (
2671 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2672 } else {
2673 if ($color >= 0) {
2674 # replace some tags by gcfclient-compatible ones
2675 for ($msg) {
2676 1 while
2677 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2678 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2679 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2680 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2681 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2682 }
2683
2684 $color &= cf::NDI_COLOR_MASK;
2685
2686 utf8::encode $msg;
2687
2688 if (0 && $msg =~ /\[/) {
2689 # COMMAND/INFO
2690 $self->send_packet ("drawextinfo $color 10 8 $msg")
2691 } else {
2692 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2693 $self->send_packet ("drawinfo $color $msg")
2694 }
2695 }
2696 }
2697}
2698
2699=item $client->ext_msg ($type, @msg)
2700
2701Sends an ext event to the client.
2702
2703=cut
2704
2705sub cf::client::ext_msg($$@) {
2706 my ($self, $type, @msg) = @_;
2707
2708 if ($self->extcmd == 2) {
2709 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2710 } elsif ($self->extcmd == 1) { # TODO: remove
2711 push @msg, msgtype => "event_$type";
2712 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2713 }
2714}
2715
2716=item $client->ext_reply ($msgid, @msg)
2717
2718Sends an ext reply to the client.
2719
2720=cut
2721
2722sub cf::client::ext_reply($$@) {
2723 my ($self, $id, @msg) = @_;
2724
2725 if ($self->extcmd == 2) {
2726 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2727 } elsif ($self->extcmd == 1) {
2728 #TODO: version 1, remove
2729 unshift @msg, msgtype => "reply", msgid => $id;
2730 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2731 }
2732}
2000 2733
2001=item $success = $client->query ($flags, "text", \&cb) 2734=item $success = $client->query ($flags, "text", \&cb)
2002 2735
2003Queues a query to the client, calling the given callback with 2736Queues a query to the client, calling the given callback with
2004the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2737the 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>. 2738C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2006 2739
2007Queries can fail, so check the return code. Or don't, as queries will become 2740Queries can fail, so check the return code. Or don't, as queries will
2008reliable at some point in the future. 2741become reliable at some point in the future.
2009 2742
2010=cut 2743=cut
2011 2744
2012sub cf::client::query { 2745sub cf::client::query {
2013 my ($self, $flags, $text, $cb) = @_; 2746 my ($self, $flags, $text, $cb) = @_;
… …
2021 utf8::encode $text; 2754 utf8::encode $text;
2022 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2755 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2023 2756
2024 $self->send_packet ($self->{query_queue}[0][0]) 2757 $self->send_packet ($self->{query_queue}[0][0])
2025 if @{ $self->{query_queue} } == 1; 2758 if @{ $self->{query_queue} } == 1;
2759
2760 1
2026} 2761}
2027 2762
2028cf::client->attach ( 2763cf::client->attach (
2764 on_connect => sub {
2765 my ($ns) = @_;
2766
2767 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2768 },
2029 on_reply => sub { 2769 on_reply => sub {
2030 my ($ns, $msg) = @_; 2770 my ($ns, $msg) = @_;
2031 2771
2032 # this weird shuffling is so that direct followup queries 2772 # this weird shuffling is so that direct followup queries
2033 # get handled first 2773 # get handled first
… …
2045 } else { 2785 } else {
2046 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 2786 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2047 } 2787 }
2048 } 2788 }
2049 }, 2789 },
2790 on_exticmd => sub {
2791 my ($ns, $buf) = @_;
2792
2793 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2794
2795 if (ref $msg) {
2796 my ($type, $reply, @payload) =
2797 "ARRAY" eq ref $msg
2798 ? @$msg
2799 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
2800
2801 my @reply;
2802
2803 if (my $cb = $EXTICMD{$type}) {
2804 @reply = $cb->($ns, @payload);
2805 }
2806
2807 $ns->ext_reply ($reply, @reply)
2808 if $reply;
2809
2810 } else {
2811 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2812 }
2813
2814 cf::override;
2815 },
2050); 2816);
2051 2817
2052=item $client->async (\&cb) 2818=item $client->async (\&cb)
2053 2819
2054Create a new coroutine, running the specified callback. The coroutine will 2820Create a new coroutine, running the specified callback. The coroutine will
… …
2095our $safe = new Safe "safe"; 2861our $safe = new Safe "safe";
2096our $safe_hole = new Safe::Hole; 2862our $safe_hole = new Safe::Hole;
2097 2863
2098$SIG{FPE} = 'IGNORE'; 2864$SIG{FPE} = 'IGNORE';
2099 2865
2100$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 2866$safe->permit_only (Opcode::opset qw(
2867 :base_core :base_mem :base_orig :base_math
2868 grepstart grepwhile mapstart mapwhile
2869 sort time
2870));
2101 2871
2102# here we export the classes and methods available to script code 2872# here we export the classes and methods available to script code
2103 2873
2104=pod 2874=pod
2105 2875
2106The following fucntions and emthods are available within a safe environment: 2876The following functions and methods are available within a safe environment:
2107 2877
2108 cf::object contr pay_amount pay_player map 2878 cf::object
2879 contr pay_amount pay_player map x y force_find force_add
2880 insert remove name archname title slaying race decrease_ob_nr
2881
2109 cf::object::player player 2882 cf::object::player
2110 cf::player peaceful 2883 player
2111 cf::map trigger 2884
2885 cf::player
2886 peaceful
2887
2888 cf::map
2889 trigger
2112 2890
2113=cut 2891=cut
2114 2892
2115for ( 2893for (
2116 ["cf::object" => qw(contr pay_amount pay_player map)], 2894 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2895 insert remove inv name archname title slaying race
2896 decrease_ob_nr)],
2117 ["cf::object::player" => qw(player)], 2897 ["cf::object::player" => qw(player)],
2118 ["cf::player" => qw(peaceful)], 2898 ["cf::player" => qw(peaceful)],
2119 ["cf::map" => qw(trigger)], 2899 ["cf::map" => qw(trigger)],
2120) { 2900) {
2121 no strict 'refs'; 2901 no strict 'refs';
… …
2192=back 2972=back
2193 2973
2194=cut 2974=cut
2195 2975
2196############################################################################# 2976#############################################################################
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 2977# the server's init and main functions
2270 2978
2271sub init_resources { 2979sub load_facedata($) {
2272 load_resource_file sprintf "%s/%s/regions", cf::datadir, cf::mapdir 2980 my ($path) = @_;
2981
2982 # HACK to clear player env face cache, we need some signal framework
2983 # for this (global event?)
2984 %ext::player_env::MUSIC_FACE_CACHE = ();
2985
2986 my $enc = JSON::XS->new->utf8->canonical->relaxed;
2987
2988 warn "loading facedata from $path\n";
2989
2990 my $facedata;
2991 0 < aio_load $path, $facedata
2992 or die "$path: $!";
2993
2994 $facedata = Coro::Storable::thaw $facedata;
2995
2996 $facedata->{version} == 2
2997 or cf::cleanup "$path: version mismatch, cannot proceed.";
2998
2999 # patch in the exptable
3000 $facedata->{resource}{"res/exp_table"} = {
3001 type => FT_RSRC,
3002 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
3003 };
3004 cf::cede_to_tick;
3005
3006 {
3007 my $faces = $facedata->{faceinfo};
3008
3009 while (my ($face, $info) = each %$faces) {
3010 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3011 cf::face::set_visibility $idx, $info->{visibility};
3012 cf::face::set_magicmap $idx, $info->{magicmap};
3013 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
3014 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
3015
3016 cf::cede_to_tick;
3017 }
3018
3019 while (my ($face, $info) = each %$faces) {
3020 next unless $info->{smooth};
3021 my $idx = cf::face::find $face
3022 or next;
3023 if (my $smooth = cf::face::find $info->{smooth}) {
3024 cf::face::set_smooth $idx, $smooth;
3025 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3026 } else {
3027 warn "smooth face '$info->{smooth}' not found for face '$face'";
3028 }
3029
3030 cf::cede_to_tick;
3031 }
3032 }
3033
3034 {
3035 my $anims = $facedata->{animinfo};
3036
3037 while (my ($anim, $info) = each %$anims) {
3038 cf::anim::set $anim, $info->{frames}, $info->{facings};
3039 cf::cede_to_tick;
3040 }
3041
3042 cf::anim::invalidate_all; # d'oh
3043 }
3044
3045 {
3046 # TODO: for gcfclient pleasure, we should give resources
3047 # that gcfclient doesn't grok a >10000 face index.
3048 my $res = $facedata->{resource};
3049
3050 my $soundconf = delete $res->{"res/sound.conf"};
3051
3052 while (my ($name, $info) = each %$res) {
3053 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3054 my $data;
3055
3056 if ($info->{type} & 1) {
3057 # prepend meta info
3058
3059 my $meta = $enc->encode ({
3060 name => $name,
3061 %{ $info->{meta} || {} },
3062 });
3063
3064 $data = pack "(w/a*)*", $meta, $info->{data};
3065 } else {
3066 $data = $info->{data};
3067 }
3068
3069 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3070 cf::face::set_type $idx, $info->{type};
3071
3072 cf::cede_to_tick;
3073 }
3074
3075 if ($soundconf) {
3076 $soundconf = $enc->decode (delete $soundconf->{data});
3077
3078 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3079 my $sound = $soundconf->{compat}[$_]
3080 or next;
3081
3082 my $face = cf::face::find "sound/$sound->[1]";
3083 cf::sound::set $sound->[0] => $face;
3084 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3085 }
3086
3087 while (my ($k, $v) = each %{$soundconf->{event}}) {
3088 my $face = cf::face::find "sound/$v";
3089 cf::sound::set $k => $face;
3090 }
3091 }
3092 }
3093
3094 1
3095}
3096
3097register_exticmd fx_want => sub {
3098 my ($ns, $want) = @_;
3099
3100 while (my ($k, $v) = each %$want) {
3101 $ns->fx_want ($k, $v);
3102 }
3103};
3104
3105sub reload_regions {
3106 # HACK to clear player env face cache, we need some signal framework
3107 # for this (global event?)
3108 %ext::player_env::MUSIC_FACE_CACHE = ();
3109
3110 load_resource_file "$MAPDIR/regions"
2273 or die "unable to load regions file\n";#d# 3111 or die "unable to load regions file\n";
2274}
2275 3112
2276sub cfg_load { 3113 for (cf::region::list) {
3114 $_->{match} = qr/$_->{match}/
3115 if exists $_->{match};
3116 }
3117}
3118
3119sub reload_facedata {
3120 load_facedata "$DATADIR/facedata"
3121 or die "unable to load facedata\n";
3122}
3123
3124sub reload_archetypes {
3125 load_resource_file "$DATADIR/archetypes"
3126 or die "unable to load archetypes\n";
3127 #d# NEED to laod twice to resolve forward references
3128 # this really needs to be done in an extra post-pass
3129 # (which needs to be synchronous, so solve it differently)
3130 load_resource_file "$DATADIR/archetypes"
3131 or die "unable to load archetypes\n";
3132}
3133
3134sub reload_treasures {
3135 load_resource_file "$DATADIR/treasures"
3136 or die "unable to load treasurelists\n";
3137}
3138
3139sub reload_resources {
3140 warn "reloading resource files...\n";
3141
3142 reload_regions;
3143 reload_facedata;
3144 #reload_archetypes;#d#
3145 reload_archetypes;
3146 reload_treasures;
3147
3148 warn "finished reloading resource files\n";
3149}
3150
3151sub init {
3152 reload_resources;
3153}
3154
3155sub reload_config {
2277 open my $fh, "<:utf8", cf::confdir . "/config" 3156 open my $fh, "<:utf8", "$CONFDIR/config"
2278 or return; 3157 or return;
2279 3158
2280 local $/; 3159 local $/;
2281 *CFG = YAML::Syck::Load <$fh>; 3160 *CFG = YAML::Syck::Load <$fh>;
2282 3161
… …
2290 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 3169 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
2291 and die "WARNING: m(un)lockall failed: $!\n"; 3170 and die "WARNING: m(un)lockall failed: $!\n";
2292 }; 3171 };
2293 warn $@ if $@; 3172 warn $@ if $@;
2294 } 3173 }
2295}
2296
2297sub init {
2298 init_resources;
2299} 3174}
2300 3175
2301sub main { 3176sub main {
2302 # we must not ever block the main coroutine 3177 # we must not ever block the main coroutine
2303 local $Coro::idle = sub { 3178 local $Coro::idle = sub {
… …
2305 (async { 3180 (async {
2306 Event::one_event; 3181 Event::one_event;
2307 })->prio (Coro::PRIO_MAX); 3182 })->prio (Coro::PRIO_MAX);
2308 }; 3183 };
2309 3184
2310 cfg_load; 3185 reload_config;
2311 db_init; 3186 db_init;
2312 load_extensions; 3187 load_extensions;
2313 3188
2314 $TICK_WATCHER->start; 3189 $TICK_WATCHER->start;
2315 Event::loop; 3190 Event::loop;
… …
2331 }, 3206 },
2332 ); 3207 );
2333 } 3208 }
2334} 3209}
2335 3210
3211sub write_runtime {
3212 my $runtime = "$LOCALDIR/runtime";
3213
3214 # first touch the runtime file to show we are still running:
3215 # the fsync below can take a very very long time.
3216
3217 IO::AIO::aio_utime $runtime, undef, undef;
3218
3219 my $guard = cf::lock_acquire "write_runtime";
3220
3221 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
3222 or return;
3223
3224 my $value = $cf::RUNTIME + 90 + 10;
3225 # 10 is the runtime save interval, for a monotonic clock
3226 # 60 allows for the watchdog to kill the server.
3227
3228 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3229 and return;
3230
3231 # always fsync - this file is important
3232 aio_fsync $fh
3233 and return;
3234
3235 # touch it again to show we are up-to-date
3236 aio_utime $fh, undef, undef;
3237
3238 close $fh
3239 or return;
3240
3241 aio_rename "$runtime~", $runtime
3242 and return;
3243
3244 warn "runtime file written.\n";
3245
3246 1
3247}
3248
2336sub emergency_save() { 3249sub emergency_save() {
2337 my $freeze_guard = cf::freeze_mainloop; 3250 my $freeze_guard = cf::freeze_mainloop;
2338 3251
2339 warn "enter emergency perl save\n"; 3252 warn "enter emergency perl save\n";
2340 3253
… …
2371 3284
2372 warn Carp::longmess "post_cleanup backtrace" 3285 warn Carp::longmess "post_cleanup backtrace"
2373 if $make_core; 3286 if $make_core;
2374} 3287}
2375 3288
2376sub reload() { 3289sub do_reload_perl() {
2377 # can/must only be called in main 3290 # can/must only be called in main
2378 if ($Coro::current != $Coro::main) { 3291 if ($Coro::current != $Coro::main) {
2379 warn "can only reload from main coroutine"; 3292 warn "can only reload from main coroutine";
2380 return; 3293 return;
2381 } 3294 }
… …
2406 Coro::cede; 3319 Coro::cede;
2407 last unless IO::AIO::nreqs || BDB::nreqs; 3320 last unless IO::AIO::nreqs || BDB::nreqs;
2408 warn "iterate..."; 3321 warn "iterate...";
2409 } 3322 }
2410 3323
3324 ++$RELOAD;
3325
2411 warn "cancelling all extension coros"; 3326 warn "cancelling all extension coros";
2412 $_->cancel for values %EXT_CORO; 3327 $_->cancel for values %EXT_CORO;
2413 %EXT_CORO = (); 3328 %EXT_CORO = ();
2414 3329
2415 warn "removing commands"; 3330 warn "removing commands";
2416 %COMMAND = (); 3331 %COMMAND = ();
2417 3332
2418 warn "removing ext commands"; 3333 warn "removing ext/exti commands";
2419 %EXTCMD = (); 3334 %EXTCMD = ();
3335 %EXTICMD = ();
2420 3336
2421 warn "unloading/nuking all extensions"; 3337 warn "unloading/nuking all extensions";
2422 for my $pkg (@EXTS) { 3338 for my $pkg (@EXTS) {
2423 warn "... unloading $pkg"; 3339 warn "... unloading $pkg";
2424 3340
… …
2454 Symbol::delete_package "safe::$_" 3370 Symbol::delete_package "safe::$_"
2455 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3371 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2456 3372
2457 warn "unloading cf.pm \"a bit\""; 3373 warn "unloading cf.pm \"a bit\"";
2458 delete $INC{"cf.pm"}; 3374 delete $INC{"cf.pm"};
3375 delete $INC{"cf/pod.pm"};
2459 3376
2460 # don't, removes xs symbols, too, 3377 # don't, removes xs symbols, too,
2461 # and global variables created in xs 3378 # and global variables created in xs
2462 #Symbol::delete_package __PACKAGE__; 3379 #Symbol::delete_package __PACKAGE__;
2463 3380
… …
2466 warn "reloading cf.pm"; 3383 warn "reloading cf.pm";
2467 require cf; 3384 require cf;
2468 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3385 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2469 3386
2470 warn "loading config and database again"; 3387 warn "loading config and database again";
2471 cf::cfg_load; 3388 cf::reload_config;
2472 3389
2473 warn "loading extensions"; 3390 warn "loading extensions";
2474 cf::load_extensions; 3391 cf::load_extensions;
2475 3392
2476 warn "reattaching attachments to objects/players"; 3393 warn "reattaching attachments to objects/players";
… …
2478 warn "reattaching attachments to maps"; 3395 warn "reattaching attachments to maps";
2479 reattach $_ for values %MAP; 3396 reattach $_ for values %MAP;
2480 warn "reattaching attachments to players"; 3397 warn "reattaching attachments to players";
2481 reattach $_ for values %PLAYER; 3398 reattach $_ for values %PLAYER;
2482 3399
2483 warn "loading reloadable resources";
2484 init_resources;
2485
2486 warn "leaving sync_job"; 3400 warn "leaving sync_job";
2487 3401
2488 1 3402 1
2489 } or do { 3403 } or do {
2490 warn $@; 3404 warn $@;
… …
2495 warn "reloaded"; 3409 warn "reloaded";
2496}; 3410};
2497 3411
2498our $RELOAD_WATCHER; # used only during reload 3412our $RELOAD_WATCHER; # used only during reload
2499 3413
3414sub reload_perl() {
3415 # doing reload synchronously and two reloads happen back-to-back,
3416 # coro crashes during coro_state_free->destroy here.
3417
3418 $RELOAD_WATCHER ||= Event->timer (
3419 reentrant => 0,
3420 after => 0,
3421 data => WF_AUTOCANCEL,
3422 cb => sub {
3423 do_reload_perl;
3424 undef $RELOAD_WATCHER;
3425 },
3426 );
3427}
3428
2500register_command "reload" => sub { 3429register_command "reload" => sub {
2501 my ($who, $arg) = @_; 3430 my ($who, $arg) = @_;
2502 3431
2503 if ($who->flag (FLAG_WIZ)) { 3432 if ($who->flag (FLAG_WIZ)) {
2504 $who->message ("reloading server."); 3433 $who->message ("reloading server.");
2505 3434 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 } 3435 }
2519}; 3436};
2520 3437
2521unshift @INC, $LIBDIR; 3438unshift @INC, $LIBDIR;
2522 3439
2523my $bug_warning = 0; 3440my $bug_warning = 0;
3441
3442our @WAIT_FOR_TICK;
3443our @WAIT_FOR_TICK_BEGIN;
3444
3445sub wait_for_tick {
3446 return unless $TICK_WATCHER->is_active;
3447 return if $Coro::current == $Coro::main;
3448
3449 my $signal = new Coro::Signal;
3450 push @WAIT_FOR_TICK, $signal;
3451 $signal->wait;
3452}
3453
3454sub wait_for_tick_begin {
3455 return unless $TICK_WATCHER->is_active;
3456 return if $Coro::current == $Coro::main;
3457
3458 my $signal = new Coro::Signal;
3459 push @WAIT_FOR_TICK_BEGIN, $signal;
3460 $signal->wait;
3461}
3462
3463our $stat_fh;
3464sysopen $stat_fh, "/tmp/cfstats", Fcntl::O_APPEND | Fcntl::O_CREAT | Fcntl::O_WRONLY, 0600;#d#
2524 3465
2525$TICK_WATCHER = Event->timer ( 3466$TICK_WATCHER = Event->timer (
2526 reentrant => 0, 3467 reentrant => 0,
2527 parked => 1, 3468 parked => 1,
2528 prio => 0, 3469 prio => 0,
… …
2533 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3474 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2534 unless ++$bug_warning > 10; 3475 unless ++$bug_warning > 10;
2535 return; 3476 return;
2536 } 3477 }
2537 3478
3479 my @pl = cf::player::list; my $stats = sprintf "%.2f %d %d %d", $RUNTIME, (scalar @pl), cf::object::actives_size, cf::object::objects_size; #d#
3480
2538 $NOW = Event::time; 3481 $NOW = $tick_start = Event::time;
2539 3482
2540 cf::server_tick; # one server iteration 3483 cf::server_tick; # one server iteration
3484
2541 $RUNTIME += $TICK; 3485 $RUNTIME += $TICK;
2542 $NEXT_TICK += $TICK; 3486 $NEXT_TICK += $TICK;
2543 3487
2544 if ($NOW >= $NEXT_RUNTIME_WRITE) { 3488 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2545 $NEXT_RUNTIME_WRITE = $NOW + 10; 3489 $NEXT_RUNTIME_WRITE = $NOW + 10;
… …
2547 write_runtime 3491 write_runtime
2548 or warn "ERROR: unable to write runtime file: $!"; 3492 or warn "ERROR: unable to write runtime file: $!";
2549 }; 3493 };
2550 } 3494 }
2551 3495
2552 $WAIT_FOR_TICK->broadcast;
2553 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited;
2554
2555# my $AFTER = Event::time; 3496# my $AFTER = Event::time;
2556# warn $AFTER - $NOW;#d# 3497# warn $AFTER - $NOW;#d#
2557 3498
3499 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3500 $sig->send;
3501 }
3502 while (my $sig = shift @WAIT_FOR_TICK) {
3503 $sig->send;
3504 }
3505
3506 $NOW = Event::time;
3507
2558 # if we are delayed by four ticks or more, skip them all 3508 # if we are delayed by four ticks or more, skip them all
2559 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 3509 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2560 3510
2561 $TICK_WATCHER->at ($NEXT_TICK); 3511 $TICK_WATCHER->at ($NEXT_TICK);
2562 $TICK_WATCHER->start; 3512 $TICK_WATCHER->start;
3513
3514 $LOAD = ($NOW - $tick_start) / $TICK;
3515 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3516
3517 _post_tick;
3518
3519 # gather some statistics#d#
3520 $stats .= sprintf " %d\n", 10000 * ($NOW - $tick_start);#d#
3521 IO::AIO::aio_write $stat_fh, undef, undef, $stats, 0;#d#
2563 }, 3522 },
2564); 3523);
2565 3524
2566{ 3525{
3526 BDB::min_parallel 8;
2567 BDB::max_poll_time $TICK * 0.1; 3527 BDB::max_poll_time $TICK * 0.1;
2568 $BDB_POLL_WATCHER = Event->io ( 3528 $BDB_POLL_WATCHER = Event->io (
2569 reentrant => 0, 3529 reentrant => 0,
2570 fd => BDB::poll_fileno, 3530 fd => BDB::poll_fileno,
2571 poll => 'r', 3531 poll => 'r',
2572 prio => 0, 3532 prio => 0,
2573 data => WF_AUTOCANCEL, 3533 data => WF_AUTOCANCEL,
2574 cb => \&BDB::poll_cb, 3534 cb => \&BDB::poll_cb,
2575 ); 3535 );
2576 BDB::min_parallel 8;
2577 3536
2578 BDB::set_sync_prepare { 3537 BDB::set_sync_prepare {
2579 my $status; 3538 my $status;
2580 my $current = $Coro::current; 3539 my $current = $Coro::current;
2581 ( 3540 (
… …
2595 3554
2596 cf::sync_job { 3555 cf::sync_job {
2597 eval { 3556 eval {
2598 BDB::db_env_open 3557 BDB::db_env_open
2599 $DB_ENV, 3558 $DB_ENV,
2600 $BDB_ENV_DIR, 3559 $BDBDIR,
2601 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3560 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2602 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3561 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2603 0666; 3562 0666;
2604 3563
2605 cf::cleanup "db_env_open($BDB_ENV_DIR): $!" if $!; 3564 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2606 3565
2607 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1); 3566 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC
3567 | BDB::LOG_AUTOREMOVE, 1);
2608 $DB_ENV->set_lk_detect; 3568 $DB_ENV->set_lk_detect;
2609 }; 3569 };
2610 3570
2611 cf::cleanup "db_env_open(db): $@" if $@; 3571 cf::cleanup "db_env_open(db): $@" if $@;
2612 }; 3572 };
2613 } 3573 }
3574
3575 $BDB_CHECKPOINT_WATCHER = Event->timer (
3576 after => 11,
3577 interval => 60,
3578 hard => 1,
3579 prio => 0,
3580 data => WF_AUTOCANCEL,
3581 cb => sub {
3582 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3583 },
3584 );
3585 $BDB_TRICKLE_WATCHER = Event->timer (
3586 after => 5,
3587 interval => 10,
3588 hard => 1,
3589 prio => 0,
3590 data => WF_AUTOCANCEL,
3591 cb => sub {
3592 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3593 },
3594 );
2614} 3595}
2615 3596
2616{ 3597{
2617 IO::AIO::min_parallel 8; 3598 IO::AIO::min_parallel 8;
2618 3599
… …
2626 prio => 6, 3607 prio => 6,
2627 cb => \&IO::AIO::poll_cb, 3608 cb => \&IO::AIO::poll_cb,
2628 ); 3609 );
2629} 3610}
2630 3611
3612my $_log_backtrace;
3613
3614sub _log_backtrace {
3615 my ($msg, @addr) = @_;
3616
3617 $msg =~ s/\n//;
3618
3619 # limit the # of concurrent backtraces
3620 if ($_log_backtrace < 2) {
3621 ++$_log_backtrace;
3622 async {
3623 my @bt = fork_call {
3624 @addr = map { sprintf "%x", $_ } @addr;
3625 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3626 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3627 or die "addr2line: $!";
3628
3629 my @funcs;
3630 my @res = <$fh>;
3631 chomp for @res;
3632 while (@res) {
3633 my ($func, $line) = splice @res, 0, 2, ();
3634 push @funcs, "[$func] $line";
3635 }
3636
3637 @funcs
3638 };
3639
3640 LOG llevInfo, "[ABT] $msg\n";
3641 LOG llevInfo, "[ABT] $_\n" for @bt;
3642 --$_log_backtrace;
3643 };
3644 } else {
3645 LOG llevInfo, "[ABT] $msg\n";
3646 LOG llevInfo, "[ABT] [suppressed]\n";
3647 }
3648}
3649
3650# load additional modules
3651use cf::pod;
3652
2631END { cf::emergency_save } 3653END { cf::emergency_save }
2632 3654
26331 36551
2634 3656

Diff Legend

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