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.227 by root, Fri Mar 23 18:32:48 2007 UTC vs.
Revision 1.374 by root, Wed Sep 19 22:07:16 2007 UTC

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

Diff Legend

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