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

Diff Legend

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