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.158 by root, Wed Jan 10 19:52:43 2007 UTC vs.
Revision 1.360 by root, Sun Sep 9 06:25:46 2007 UTC

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

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines