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.160 by root, Wed Jan 10 22:54:06 2007 UTC vs.
Revision 1.289 by root, Sat Jun 30 03:00:54 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;
26 34
35# configure various modules to our taste
36#
37$Storable::canonical = 1; # reduce rsync transfers
38Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
39Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
40
27use Event; $Event::Eval = 1; # no idea why this is required, but it is 41$Event::Eval = 1; # no idea why this is required, but it is
28
29sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
30 42
31# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 43# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
32$YAML::Syck::ImplicitUnicode = 1; 44$YAML::Syck::ImplicitUnicode = 1;
33 45
34$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 46$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
35 47
48sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
49
36our %COMMAND = (); 50our %COMMAND = ();
37our %COMMAND_TIME = (); 51our %COMMAND_TIME = ();
38 52
39our @EXTS = (); # list of extension package names 53our @EXTS = (); # list of extension package names
40our %EXTCMD = (); 54our %EXTCMD = ();
55our %EXTICMD = ();
41our %EXT_CORO = (); # coroutines bound to extensions 56our %EXT_CORO = (); # coroutines bound to extensions
57our %EXT_MAP = (); # pluggable maps
42 58
59our $RELOAD; # number of reloads so far
43our @EVENT; 60our @EVENT;
44our $LIBDIR = datadir . "/ext";
45 61
46our $TICK = MAX_TIME * 1e-6; 62our $CONFDIR = confdir;
63our $DATADIR = datadir;
64our $LIBDIR = "$DATADIR/ext";
65our $PODDIR = "$DATADIR/pod";
66our $MAPDIR = "$DATADIR/" . mapdir;
67our $LOCALDIR = localdir;
68our $TMPDIR = "$LOCALDIR/" . tmpdir;
69our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
70our $PLAYERDIR = "$LOCALDIR/" . playerdir;
71our $RANDOMDIR = "$LOCALDIR/random";
72our $BDBDIR = "$LOCALDIR/db";
73
74our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
47our $TICK_WATCHER; 75our $TICK_WATCHER;
76our $AIO_POLL_WATCHER;
77our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
48our $NEXT_TICK; 78our $NEXT_TICK;
49our $NOW; 79our $NOW;
80our $USE_FSYNC = 1; # use fsync to write maps - default off
81
82our $BDB_POLL_WATCHER;
83our $DB_ENV;
50 84
51our %CFG; 85our %CFG;
52 86
53our $UPTIME; $UPTIME ||= time; 87our $UPTIME; $UPTIME ||= time;
54our $RUNTIME; 88our $RUNTIME;
55 89
56our %PLAYER; # all users 90our %PLAYER; # all users
57our %MAP; # all maps 91our %MAP; # all maps
58our $LINK_MAP; # the special {link} map 92our $LINK_MAP; # the special {link} map, which is always available
59our $RANDOM_MAPS = cf::localdir . "/random";
60 93
61our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal; 94# used to convert map paths into valid unix filenames by replacing / by ∕
62our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal; 95our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
96
97our $LOAD; # a number between 0 (idle) and 1 (too many objects)
98our $LOADAVG; # same thing, but with alpha-smoothing
99our $tick_start; # for load detecting purposes
63 100
64binmode STDOUT; 101binmode STDOUT;
65binmode STDERR; 102binmode STDERR;
66 103
67# read virtual server time, if available 104# read virtual server time, if available
68unless ($RUNTIME || !-e cf::localdir . "/runtime") { 105unless ($RUNTIME || !-e "$LOCALDIR/runtime") {
69 open my $fh, "<", cf::localdir . "/runtime" 106 open my $fh, "<", "$LOCALDIR/runtime"
70 or die "unable to read runtime file: $!"; 107 or die "unable to read runtime file: $!";
71 $RUNTIME = <$fh> + 0.; 108 $RUNTIME = <$fh> + 0.;
72} 109}
73 110
74mkdir cf::localdir; 111mkdir $_
75mkdir cf::localdir . "/" . cf::playerdir; 112 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
76mkdir cf::localdir . "/" . cf::tmpdir;
77mkdir cf::localdir . "/" . cf::uniquedir;
78mkdir $RANDOM_MAPS;
79 113
80# a special map that is always available
81our $LINK_MAP;
82our $EMERGENCY_POSITION; 114our $EMERGENCY_POSITION;
115
116sub cf::map::normalise;
83 117
84############################################################################# 118#############################################################################
85 119
86=head2 GLOBAL VARIABLES 120=head2 GLOBAL VARIABLES
87 121
… …
94=item $cf::RUNTIME 128=item $cf::RUNTIME
95 129
96The time this server has run, starts at 0 and is increased by $cf::TICK on 130The time this server has run, starts at 0 and is increased by $cf::TICK on
97every server tick. 131every server tick.
98 132
99=item $cf::LIBDIR 133=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
134$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
135$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
100 136
101The perl library directory, where extensions and cf-specific modules can 137Various directories - "/etc", read-only install directory, perl-library
102be found. It will be added to C<@INC> automatically. 138directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
139unique-items directory, player file directory, random maps directory and
140database environment.
103 141
104=item $cf::NOW 142=item $cf::NOW
105 143
106The time of the last (current) server tick. 144The time of the last (current) server tick.
107 145
108=item $cf::TICK 146=item $cf::TICK
109 147
110The interval between server ticks, in seconds. 148The interval between server ticks, in seconds.
149
150=item $cf::LOADAVG
151
152The current CPU load on the server (alpha-smoothed), as a value between 0
153(none) and 1 (overloaded), indicating how much time is spent on processing
154objects per tick. Healthy values are < 0.5.
155
156=item $cf::LOAD
157
158The raw value load value from the last tick.
111 159
112=item %cf::CFG 160=item %cf::CFG
113 161
114Configuration for the server, loaded from C</etc/crossfire/config>, or 162Configuration for the server, loaded from C</etc/crossfire/config>, or
115from wherever your confdir points to. 163from wherever your confdir points to.
116 164
117=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE 165=item cf::wait_for_tick, cf::wait_for_tick_begin
118 166
119These are Coro::Signal objects that are C<< ->broadcast >> (WAIT_FOR_TICK) 167These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
120or C<< ->send >> (WAIT_FOR_TICK_ONE) on after normal server tick 168returns directly I<after> the tick processing (and consequently, can only wake one process
121processing has been done. Call C<< ->wait >> on them to maximise the 169per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
122window of cpu time available, or simply to synchronise to the server tick.
123 170
124=back 171=back
125 172
126=cut 173=cut
127 174
128BEGIN { 175BEGIN {
129 *CORE::GLOBAL::warn = sub { 176 *CORE::GLOBAL::warn = sub {
130 my $msg = join "", @_; 177 my $msg = join "", @_;
131 utf8::encode $msg;
132 178
133 $msg .= "\n" 179 $msg .= "\n"
134 unless $msg =~ /\n$/; 180 unless $msg =~ /\n$/;
135 181
182 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
183
184 utf8::encode $msg;
136 LOG llevError, $msg; 185 LOG llevError, $msg;
137 }; 186 };
138} 187}
139 188
140@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 189@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
141@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 190@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
142@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 191@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
143@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 192@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
144@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable'; 193@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
194@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
145@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 195@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
146 196
147# we bless all objects into (empty) derived classes to force a method lookup 197# we bless all objects into (empty) derived classes to force a method lookup
148# within the Safe compartment. 198# within the Safe compartment.
149for my $pkg (qw( 199for my $pkg (qw(
150 cf::global cf::attachable 200 cf::global cf::attachable
… …
158} 208}
159 209
160$Event::DIED = sub { 210$Event::DIED = sub {
161 warn "error in event callback: @_"; 211 warn "error in event callback: @_";
162}; 212};
213
214#############################################################################
163 215
164=head2 UTILITY FUNCTIONS 216=head2 UTILITY FUNCTIONS
165 217
166=over 4 218=over 4
167 219
… …
186 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 238 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
187 $d 239 $d
188 } || "[unable to dump $_[0]: '$@']"; 240 } || "[unable to dump $_[0]: '$@']";
189} 241}
190 242
191use JSON::Syck (); # TODO# replace by JSON::PC once working
192
193=item $ref = cf::from_json $json 243=item $ref = cf::from_json $json
194 244
195Converts a JSON string into the corresponding perl data structure. 245Converts a JSON string into the corresponding perl data structure.
196 246
197=cut
198
199sub from_json($) {
200 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
201 JSON::Syck::Load $_[0]
202}
203
204=item $json = cf::to_json $ref 247=item $json = cf::to_json $ref
205 248
206Converts a perl data structure into its JSON representation. 249Converts a perl data structure into its JSON representation.
207 250
208=cut 251=cut
209 252
210sub to_json($) { 253our $json_coder = JSON::XS->new->convert_blessed->utf8->max_size (1e6); # accept ~1mb max
211 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 254
212 JSON::Syck::Dump $_[0] 255sub to_json ($) { $json_coder->encode ($_[0]) }
213} 256sub from_json ($) { $json_coder->decode ($_[0]) }
214 257
215=item cf::lock_wait $string 258=item cf::lock_wait $string
216 259
217Wait until the given lock is available. See cf::lock_acquire. 260Wait until the given lock is available. See cf::lock_acquire.
218 261
… …
224returned. 267returned.
225 268
226Lock names should begin with a unique identifier (for example, cf::map::find 269Lock names should begin with a unique identifier (for example, cf::map::find
227uses map_find and cf::map::load uses map_load). 270uses map_find and cf::map::load uses map_load).
228 271
272=item $locked = cf::lock_active $string
273
274Return true if the lock is currently active, i.e. somebody has locked it.
275
229=cut 276=cut
230 277
231our %LOCK; 278our %LOCK;
232 279
233sub lock_wait($) { 280sub lock_wait($) {
… …
252 # wake up all waiters, to be on the safe side 299 # wake up all waiters, to be on the safe side
253 $_->ready for @{ delete $LOCK{$key} }; 300 $_->ready for @{ delete $LOCK{$key} };
254 } 301 }
255} 302}
256 303
304sub lock_active($) {
305 my ($key) = @_;
306
307 ! ! $LOCK{$key}
308}
309
257sub freeze_mainloop { 310sub freeze_mainloop {
258 return unless $TICK_WATCHER->is_active; 311 return unless $TICK_WATCHER->is_active;
259 312
260 my $guard = Coro::guard { $TICK_WATCHER->start }; 313 my $guard = Coro::guard {
314 $TICK_WATCHER->start;
315 };
261 $TICK_WATCHER->stop; 316 $TICK_WATCHER->stop;
262 $guard 317 $guard
263} 318}
264 319
265=item cf::async { BLOCK } 320=item cf::async { BLOCK }
… …
272 327
273BEGIN { *async = \&Coro::async_pool } 328BEGIN { *async = \&Coro::async_pool }
274 329
275=item cf::sync_job { BLOCK } 330=item cf::sync_job { BLOCK }
276 331
277The design of crossfire+ requires that the main coro ($Coro::main) is 332The design of Crossfire TRT requires that the main coroutine ($Coro::main)
278always able to handle events or runnable, as crossfire+ is only partly 333is always able to handle events or runnable, as Crossfire TRT is only
279reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable. 334partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
335acceptable.
280 336
281If it must be done, put the blocking parts into C<sync_job>. This will run 337If it must be done, put the blocking parts into C<sync_job>. This will run
282the given BLOCK in another coroutine while waiting for the result. The 338the given BLOCK in another coroutine while waiting for the result. The
283server will be frozen during this time, so the block should either finish 339server will be frozen during this time, so the block should either finish
284fast or be very important. 340fast or be very important.
… …
287 343
288sub sync_job(&) { 344sub sync_job(&) {
289 my ($job) = @_; 345 my ($job) = @_;
290 346
291 if ($Coro::current == $Coro::main) { 347 if ($Coro::current == $Coro::main) {
348 my $time = Event::time;
349
292 # this is the main coro, too bad, we have to block 350 # this is the main coro, too bad, we have to block
293 # till the operation succeeds, freezing the server :/ 351 # till the operation succeeds, freezing the server :/
294 352
295 # TODO: use suspend/resume instead 353 # TODO: use suspend/resume instead
296 # (but this is cancel-safe) 354 # (but this is cancel-safe)
… …
307 365
308 while ($busy) { 366 while ($busy) {
309 Coro::cede or Event::one_event; 367 Coro::cede or Event::one_event;
310 } 368 }
311 369
370 $time = Event::time - $time;
371
372 LOG llevError | logBacktrace, Carp::longmess "long sync job"
373 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
374
375 $tick_start += $time; # do not account sync jobs to server load
376
312 wantarray ? @res : $res[0] 377 wantarray ? @res : $res[0]
313 } else { 378 } else {
314 # we are in another coroutine, how wonderful, everything just works 379 # we are in another coroutine, how wonderful, everything just works
315 380
316 $job->() 381 $job->()
… …
335 $EXT_CORO{$coro+0} = $coro; 400 $EXT_CORO{$coro+0} = $coro;
336 401
337 $coro 402 $coro
338} 403}
339 404
340sub write_runtime { 405=item fork_call { }, $args
341 my $runtime = cf::localdir . "/runtime";
342 406
343 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 407Executes the given code block with the given arguments in a seperate
344 or return; 408process, returning the results. Everything must be serialisable with
409Coro::Storable. May, of course, block. Note that the executed sub may
410never block itself or use any form of Event handling.
345 411
346 my $value = $cf::RUNTIME + 1 + 10; # 10 is the runtime save interval, for a monotonic clock 412=cut
347 (aio_write $fh, 0, (length $value), $value, 0) <= 0
348 and return;
349 413
350 aio_fsync $fh 414sub fork_call(&@) {
351 and return; 415 my ($cb, @args) = @_;
352 416
417# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
418# or die "socketpair: $!";
419 pipe my $fh1, my $fh2
420 or die "pipe: $!";
421
422 if (my $pid = fork) {
353 close $fh 423 close $fh2;
354 or return;
355 424
356 aio_rename "$runtime~", $runtime 425 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
357 and return; 426 $res = Coro::Storable::thaw $res;
358 427
428 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
429
430 die $$res unless "ARRAY" eq ref $res;
431
432 return wantarray ? @$res : $res->[-1];
433 } else {
434 reset_signals;
435 local $SIG{__WARN__};
436 local $SIG{__DIE__};
437 eval {
438 close $fh1;
439
440 my @res = eval { $cb->(@args) };
441 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
442 };
443
444 warn $@ if $@;
445 _exit 0;
359 1 446 }
447}
448
449=item $value = cf::db_get $family => $key
450
451Returns a single value from the environment database.
452
453=item cf::db_put $family => $key => $value
454
455Stores the given C<$value> in the family. It can currently store binary
456data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
457
458=cut
459
460our $DB;
461
462sub db_init {
463 unless ($DB) {
464 $DB = BDB::db_create $DB_ENV;
465
466 cf::sync_job {
467 eval {
468 $DB->set_flags (BDB::CHKSUM);
469
470 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
471 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
472 cf::cleanup "db_open(db): $!" if $!;
473 };
474 cf::cleanup "db_open(db): $@" if $@;
475 };
476 }
477}
478
479sub db_get($$) {
480 my $key = "$_[0]/$_[1]";
481
482 cf::sync_job {
483 BDB::db_get $DB, undef, $key, my $data;
484
485 $! ? ()
486 : $data
487 }
488}
489
490sub db_put($$$) {
491 BDB::dbreq_pri 4;
492 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
493}
494
495=item cf::cache $id => [$paths...], $processversion => $process
496
497Generic caching function that returns the value of the resource $id,
498caching and regenerating as required.
499
500This function can block.
501
502=cut
503
504sub cache {
505 my ($id, $src, $processversion, $process) = @_;
506
507 my $meta =
508 join "\x00",
509 $processversion,
510 map {
511 aio_stat $_
512 and Carp::croak "$_: $!";
513
514 ($_, (stat _)[7,9])
515 } @$src;
516
517 my $dbmeta = db_get cache => "$id/meta";
518 if ($dbmeta ne $meta) {
519 # changed, we may need to process
520
521 my @data;
522 my $md5;
523
524 for (0 .. $#$src) {
525 0 <= aio_load $src->[$_], $data[$_]
526 or Carp::croak "$src->[$_]: $!";
527 }
528
529 # if processing is expensive, check
530 # checksum first
531 if (1) {
532 $md5 =
533 join "\x00",
534 $processversion,
535 map {
536 Coro::cede;
537 ($src->[$_], Digest::MD5::md5_hex $data[$_])
538 } 0.. $#$src;
539
540
541 my $dbmd5 = db_get cache => "$id/md5";
542 if ($dbmd5 eq $md5) {
543 db_put cache => "$id/meta", $meta;
544
545 return db_get cache => "$id/data";
546 }
547 }
548
549 my $t1 = Time::HiRes::time;
550 my $data = $process->(\@data);
551 my $t2 = Time::HiRes::time;
552
553 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
554
555 db_put cache => "$id/data", $data;
556 db_put cache => "$id/md5" , $md5;
557 db_put cache => "$id/meta", $meta;
558
559 return $data;
560 }
561
562 db_get cache => "$id/data"
563}
564
565=item cf::datalog type => key => value, ...
566
567Log a datalog packet of the given type with the given key-value pairs.
568
569=cut
570
571sub datalog($@) {
572 my ($type, %kv) = @_;
573 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
360} 574}
361 575
362=back 576=back
363 577
364=cut 578=cut
365
366#############################################################################
367
368package cf::path;
369
370use overload
371 '""' => \&as_string;
372
373# used to convert map paths into valid unix filenames by repalcing / by ∕
374our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
375
376sub new {
377 my ($class, $path, $base) = @_;
378
379 $path = $path->as_string if ref $path;
380
381 my $self = bless { }, $class;
382
383 # {... are special paths that are not touched
384 # ?xxx/... are special absolute paths
385 # ?random/... random maps
386 # /! non-realised random map exit
387 # /... normal maps
388 # ~/... per-player maps without a specific player (DO NOT USE)
389 # ~user/... per-player map of a specific user
390
391 $path =~ s/$PATH_SEP/\//go;
392
393 if ($path =~ /^{/) {
394 # fine as it is
395 } elsif ($path =~ s{^\?random/}{}) {
396 Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;
397 $self->{random} = cf::from_json $data;
398 } else {
399 if ($path =~ s{^~([^/]+)?}{}) {
400 $self->{user_rel} = 1;
401
402 if (defined $1) {
403 $self->{user} = $1;
404 } elsif ($base =~ m{^~([^/]+)/}) {
405 $self->{user} = $1;
406 } else {
407 warn "cannot resolve user-relative path without user <$path,$base>\n";
408 }
409 } elsif ($path =~ /^\//) {
410 # already absolute
411 } else {
412 $base =~ s{[^/]+/?$}{};
413 return $class->new ("$base/$path");
414 }
415
416 for ($path) {
417 redo if s{/\.?/}{/};
418 redo if s{/[^/]+/\.\./}{/};
419 }
420 }
421
422 $self->{path} = $path;
423
424 $self
425}
426
427# the name / primary key / in-game path
428sub as_string {
429 my ($self) = @_;
430
431 $self->{user_rel} ? "~$self->{user}$self->{path}"
432 : $self->{random} ? "?random/$self->{path}"
433 : $self->{path}
434}
435
436# the displayed name, this is a one way mapping
437sub visible_name {
438 my ($self) = @_;
439
440# if (my $rmp = $self->{random}) {
441# # todo: be more intelligent about this
442# "?random/$rmp->{origin_map}+$rmp->{origin_x}+$rmp->{origin_y}/$rmp->{dungeon_level}"
443# } else {
444 $self->as_string
445# }
446}
447
448# escape the /'s in the path
449sub _escaped_path {
450 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
451 $path
452}
453
454# the original (read-only) location
455sub load_path {
456 my ($self) = @_;
457
458 sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path}
459}
460
461# the temporary/swap location
462sub save_path {
463 my ($self) = @_;
464
465 $self->{user_rel} ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path
466 : $self->{random} ? sprintf "%s/%s", $RANDOM_MAPS, $self->{path}
467 : sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path
468}
469
470# the unique path, might be eq to save_path
471sub uniq_path {
472 my ($self) = @_;
473
474 $self->{user_rel} || $self->{random}
475 ? undef
476 : sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path
477}
478
479# return random map parameters, or undef
480sub random_map_params {
481 my ($self) = @_;
482
483 $self->{random}
484}
485
486# this is somewhat ugly, but style maps do need special treatment
487sub is_style_map {
488 $_[0]{path} =~ m{^/styles/}
489}
490
491package cf;
492 579
493############################################################################# 580#############################################################################
494 581
495=head2 ATTACHABLE OBJECTS 582=head2 ATTACHABLE OBJECTS
496 583
… …
498attach callbacks/event handlers (a collection of which is called an "attachment") 585attach callbacks/event handlers (a collection of which is called an "attachment")
499to it. All such attachable objects support the following methods. 586to it. All such attachable objects support the following methods.
500 587
501In the following description, CLASS can be any of C<global>, C<object> 588In the following description, CLASS can be any of C<global>, C<object>
502C<player>, C<client> or C<map> (i.e. the attachable objects in 589C<player>, C<client> or C<map> (i.e. the attachable objects in
503crossfire+). 590Crossfire TRT).
504 591
505=over 4 592=over 4
506 593
507=item $attachable->attach ($attachment, key => $value...) 594=item $attachable->attach ($attachment, key => $value...)
508 595
… …
622our @CB_TYPE = (); # registry for type (cf-object class) based events 709our @CB_TYPE = (); # registry for type (cf-object class) based events
623our @CB_MAP = (); 710our @CB_MAP = ();
624 711
625my %attachment; 712my %attachment;
626 713
714sub cf::attachable::thawer_merge {
715 # simply override everything except _meta
716 local $_[0]{_meta};
717 %{$_[0]} = %{$_[1]};
718}
719
627sub _attach_cb($$$$) { 720sub _attach_cb($$$$) {
628 my ($registry, $event, $prio, $cb) = @_; 721 my ($registry, $event, $prio, $cb) = @_;
629 722
630 use sort 'stable'; 723 use sort 'stable';
631 724
… …
665 $registry = $CB_TYPE[$object_type] ||= []; 758 $registry = $CB_TYPE[$object_type] ||= [];
666 759
667 } elsif ($type eq "subtype") { 760 } elsif ($type eq "subtype") {
668 defined $object_type or Carp::croak "subtype specified without type"; 761 defined $object_type or Carp::croak "subtype specified without type";
669 my $object_subtype = shift @arg; 762 my $object_subtype = shift @arg;
670 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 763 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
671 764
672 } elsif ($type eq "package") { 765 } elsif ($type eq "package") {
673 my $pkg = shift @arg; 766 my $pkg = shift @arg;
674 767
675 while (my ($name, $id) = each %cb_id) { 768 while (my ($name, $id) = each %cb_id) {
… …
704 _attach $registry, $klass, @attach; 797 _attach $registry, $klass, @attach;
705 } 798 }
706 799
707 $obj->{$name} = \%arg; 800 $obj->{$name} = \%arg;
708 } else { 801 } else {
709 warn "object uses attachment '$name' that is not available, postponing.\n"; 802 warn "object uses attachment '$name' which is not available, postponing.\n";
710 } 803 }
711 804
712 $obj->{_attachment}{$name} = undef; 805 $obj->{_attachment}{$name} = undef;
713} 806}
714 807
… …
716 if (ref $_[0]) { 809 if (ref $_[0]) {
717 _object_attach @_; 810 _object_attach @_;
718 } else { 811 } else {
719 _attach shift->_attach_registry, @_; 812 _attach shift->_attach_registry, @_;
720 } 813 }
814 _recalc_want;
721}; 815};
722 816
723# all those should be optimised 817# all those should be optimised
724sub cf::attachable::detach { 818sub cf::attachable::detach {
725 my ($obj, $name) = @_; 819 my ($obj, $name) = @_;
… …
728 delete $obj->{_attachment}{$name}; 822 delete $obj->{_attachment}{$name};
729 reattach ($obj); 823 reattach ($obj);
730 } else { 824 } else {
731 Carp::croak "cannot, currently, detach class attachments"; 825 Carp::croak "cannot, currently, detach class attachments";
732 } 826 }
827 _recalc_want;
733}; 828};
734 829
735sub cf::attachable::attached { 830sub cf::attachable::attached {
736 my ($obj, $name) = @_; 831 my ($obj, $name) = @_;
737 832
… …
802# object support 897# object support
803 898
804sub reattach { 899sub reattach {
805 # basically do the same as instantiate, without calling instantiate 900 # basically do the same as instantiate, without calling instantiate
806 my ($obj) = @_; 901 my ($obj) = @_;
902
903 bless $obj, ref $obj; # re-bless in case extensions have been reloaded
807 904
808 my $registry = $obj->registry; 905 my $registry = $obj->registry;
809 906
810 @$registry = (); 907 @$registry = ();
811 908
… …
858 $filename, length $$rdata, scalar @$objs; 955 $filename, length $$rdata, scalar @$objs;
859 956
860 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 957 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
861 chmod SAVE_MODE, $fh; 958 chmod SAVE_MODE, $fh;
862 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 959 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
863 aio_fsync $fh; 960 aio_fsync $fh if $cf::USE_FSYNC;
864 close $fh; 961 close $fh;
865 962
866 if (@$objs) { 963 if (@$objs) {
867 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 964 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
868 chmod SAVE_MODE, $fh; 965 chmod SAVE_MODE, $fh;
869 my $data = Storable::nfreeze { version => 1, objs => $objs }; 966 my $data = Storable::nfreeze { version => 1, objs => $objs };
870 aio_write $fh, 0, (length $data), $data, 0; 967 aio_write $fh, 0, (length $data), $data, 0;
871 aio_fsync $fh; 968 aio_fsync $fh if $cf::USE_FSYNC;
872 close $fh; 969 close $fh;
873 aio_rename "$filename.pst~", "$filename.pst"; 970 aio_rename "$filename.pst~", "$filename.pst";
874 } 971 }
875 } else { 972 } else {
876 aio_unlink "$filename.pst"; 973 aio_unlink "$filename.pst";
… …
908 or return; 1005 or return;
909 $av = eval { (Storable::thaw $av)->{objs} }; 1006 $av = eval { (Storable::thaw $av)->{objs} };
910 } 1007 }
911 1008
912 warn sprintf "loading %s (%d)\n", 1009 warn sprintf "loading %s (%d)\n",
913 $filename, length $data, scalar @{$av || []};#d# 1010 $filename, length $data, scalar @{$av || []};
914 return ($data, $av); 1011 return ($data, $av);
915} 1012}
1013
1014=head2 COMMAND CALLBACKS
1015
1016=over 4
1017
1018=cut
916 1019
917############################################################################# 1020#############################################################################
918# command handling &c 1021# command handling &c
919 1022
920=item cf::register_command $name => \&callback($ob,$args); 1023=item cf::register_command $name => \&callback($ob,$args);
… …
933 push @{ $COMMAND{$name} }, [$caller, $cb]; 1036 push @{ $COMMAND{$name} }, [$caller, $cb];
934} 1037}
935 1038
936=item cf::register_extcmd $name => \&callback($pl,$packet); 1039=item cf::register_extcmd $name => \&callback($pl,$packet);
937 1040
938Register a callbackf ro execution when the client sends an extcmd packet. 1041Register a callback for execution when the client sends an (synchronous)
1042extcmd packet. Ext commands will be processed in the order they are
1043received by the server, like other user commands. The first argument is
1044the logged-in player. Ext commands can only be processed after a player
1045has logged in successfully.
939 1046
940If the callback returns something, it is sent back as if reply was being 1047If the callback returns something, it is sent back as if reply was being
941called. 1048called.
942 1049
1050=item cf::register_exticmd $name => \&callback($ns,$packet);
1051
1052Register a callback for execution when the client sends an (asynchronous)
1053exticmd packet. Exti commands are processed by the server as soon as they
1054are received, i.e. out of order w.r.t. other commands. The first argument
1055is a client socket. Exti commands can be received anytime, even before
1056log-in.
1057
1058If the callback returns something, it is sent back as if reply was being
1059called.
1060
943=cut 1061=cut
944 1062
945sub register_extcmd { 1063sub register_extcmd {
946 my ($name, $cb) = @_; 1064 my ($name, $cb) = @_;
947 1065
948 $EXTCMD{$name} = $cb; 1066 $EXTCMD{$name} = $cb;
1067}
1068
1069sub register_exticmd {
1070 my ($name, $cb) = @_;
1071
1072 $EXTICMD{$name} = $cb;
949} 1073}
950 1074
951cf::player->attach ( 1075cf::player->attach (
952 on_command => sub { 1076 on_command => sub {
953 my ($pl, $name, $params) = @_; 1077 my ($pl, $name, $params) = @_;
… …
978 1102
979 cf::override; 1103 cf::override;
980 }, 1104 },
981); 1105);
982 1106
983sub load_extension {
984 my ($path) = @_;
985
986 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
987 my $base = $1;
988 my $pkg = $1;
989 $pkg =~ s/[^[:word:]]/_/g;
990 $pkg = "ext::$pkg";
991
992 warn "... loading '$path' into '$pkg'\n";
993
994 open my $fh, "<:utf8", $path
995 or die "$path: $!";
996
997 my $source =
998 "package $pkg; use strict; use utf8;\n"
999 . "#line 1 \"$path\"\n{\n"
1000 . (do { local $/; <$fh> })
1001 . "\n};\n1";
1002
1003 eval $source
1004 or die $@ ? "$path: $@\n"
1005 : "extension disabled.\n";
1006
1007 push @EXTS, $pkg;
1008}
1009
1010sub load_extensions { 1107sub load_extensions {
1108 cf::sync_job {
1109 my %todo;
1110
1011 for my $ext (<$LIBDIR/*.ext>) { 1111 for my $path (<$LIBDIR/*.ext>) {
1012 next unless -r $ext; 1112 next unless -r $path;
1013 eval { 1113
1014 load_extension $ext; 1114 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1115 my $base = $1;
1116 my $pkg = $1;
1117 $pkg =~ s/[^[:word:]]/_/g;
1118 $pkg = "ext::$pkg";
1119
1120 open my $fh, "<:utf8", $path
1121 or die "$path: $!";
1122
1123 my $source = do { local $/; <$fh> };
1124
1125 my %ext = (
1126 path => $path,
1127 base => $base,
1128 pkg => $pkg,
1129 );
1130
1131 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1132 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1133
1134 $ext{source} =
1135 "package $pkg; use strict; use utf8;\n"
1136 . "#line 1 \"$path\"\n{\n"
1137 . $source
1138 . "\n};\n1";
1139
1140 $todo{$base} = \%ext;
1141 }
1142
1143 my %done;
1144 while (%todo) {
1145 my $progress;
1146
1147 while (my ($k, $v) = each %todo) {
1148 for (split /,\s*/, $v->{meta}{depends}) {
1149 goto skip
1150 unless exists $done{$_};
1151 }
1152
1153 warn "... loading '$k' into '$v->{pkg}'\n";
1154
1155 unless (eval $v->{source}) {
1156 my $msg = $@ ? "$v->{path}: $@\n"
1157 : "$v->{base}: extension inactive.\n";
1158
1159 if (exists $v->{meta}{mandatory}) {
1160 warn $msg;
1161 warn "mandatory extension failed to load, exiting.\n";
1162 exit 1;
1163 }
1164
1165 warn $msg;
1166 }
1167
1168 $done{$k} = delete $todo{$k};
1169 push @EXTS, $v->{pkg};
1170 $progress = 1;
1015 1 1171 }
1016 } or warn "$ext not loaded: $@"; 1172
1173 skip:
1174 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1175 unless $progress;
1176 }
1017 } 1177 };
1018} 1178}
1019 1179
1020############################################################################# 1180#############################################################################
1021# load/save/clean perl data associated with a map
1022 1181
1023*cf::mapsupport::on_clean = sub { 1182=back
1024 my ($map) = @_;
1025
1026 my $path = $map->tmpname;
1027 defined $path or return;
1028
1029 unlink "$path.pst";
1030};
1031
1032cf::map->attach (prio => -10000, package => cf::mapsupport::);
1033
1034#############################################################################
1035 1183
1036=head2 CORE EXTENSIONS 1184=head2 CORE EXTENSIONS
1037 1185
1038Functions and methods that extend core crossfire objects. 1186Functions and methods that extend core crossfire objects.
1039 1187
… …
1052Returns the given player object, loading it if necessary (might block). 1200Returns the given player object, loading it if necessary (might block).
1053 1201
1054=cut 1202=cut
1055 1203
1056sub playerdir($) { 1204sub playerdir($) {
1057 cf::localdir 1205 "$PLAYERDIR/"
1058 . "/"
1059 . cf::playerdir
1060 . "/"
1061 . (ref $_[0] ? $_[0]->ob->name : $_[0]) 1206 . (ref $_[0] ? $_[0]->ob->name : $_[0])
1062} 1207}
1063 1208
1064sub path($) { 1209sub path($) {
1065 my $login = ref $_[0] ? $_[0]->ob->name : $_[0]; 1210 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
1066 1211
1067 (playerdir $login) . "/$login.pl" 1212 (playerdir $login) . "/playerdata"
1068} 1213}
1069 1214
1070sub find_active($) { 1215sub find_active($) {
1071 $cf::PLAYER{$_[0]} 1216 $cf::PLAYER{$_[0]}
1072 and $cf::PLAYER{$_[0]}->active 1217 and $cf::PLAYER{$_[0]}->active
… …
1075 1220
1076sub exists($) { 1221sub exists($) {
1077 my ($login) = @_; 1222 my ($login) = @_;
1078 1223
1079 $cf::PLAYER{$login} 1224 $cf::PLAYER{$login}
1080 or cf::sync_job { !aio_stat $login } 1225 or cf::sync_job { !aio_stat path $login }
1081} 1226}
1082 1227
1083sub find($) { 1228sub find($) {
1084 return $cf::PLAYER{$_[0]} || do { 1229 return $cf::PLAYER{$_[0]} || do {
1085 my $login = $_[0]; 1230 my $login = $_[0];
1086 1231
1087 my $guard = cf::lock_acquire "user_find:$login"; 1232 my $guard = cf::lock_acquire "user_find:$login";
1088 1233
1089 $cf::PLAYER{$_[0]} || do { 1234 $cf::PLAYER{$_[0]} || do {
1235 # rename old playerfiles to new ones
1236 #TODO: remove when no longer required
1237 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1238 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1239 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1240 aio_unlink +(playerdir $login) . "/$login.pl";
1241
1090 my $pl = load_pl path $login 1242 my $pl = load_pl path $login
1091 or return; 1243 or return;
1092 $cf::PLAYER{$login} = $pl 1244 $cf::PLAYER{$login} = $pl
1093 } 1245 }
1094 } 1246 }
… …
1131 1283
1132=cut 1284=cut
1133 1285
1134sub quit_character { 1286sub quit_character {
1135 my ($pl) = @_; 1287 my ($pl) = @_;
1288
1289 my $name = $pl->ob->name;
1136 1290
1137 $pl->{deny_save} = 1; 1291 $pl->{deny_save} = 1;
1138 $pl->password ("*"); # this should lock out the player until we nuked the dir 1292 $pl->password ("*"); # this should lock out the player until we nuked the dir
1139 1293
1140 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1294 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
… …
1145 my $path = playerdir $pl; 1299 my $path = playerdir $pl;
1146 my $temp = "$path~$cf::RUNTIME~deleting~"; 1300 my $temp = "$path~$cf::RUNTIME~deleting~";
1147 aio_rename $path, $temp; 1301 aio_rename $path, $temp;
1148 delete $cf::PLAYER{$pl->ob->name}; 1302 delete $cf::PLAYER{$pl->ob->name};
1149 $pl->destroy; 1303 $pl->destroy;
1304
1305 my $prefix = qr<^~\Q$name\E/>;
1306
1307 # nuke player maps
1308 $cf::MAP{$_}->nuke for grep /$prefix/, keys %cf::MAP;
1309
1150 IO::AIO::aio_rmtree $temp; 1310 IO::AIO::aio_rmtree $temp;
1311}
1312
1313=item $pl->kick
1314
1315Kicks a player out of the game. This destroys the connection.
1316
1317=cut
1318
1319sub kick {
1320 my ($pl, $kicker) = @_;
1321
1322 $pl->invoke (cf::EVENT_PLAYER_KICK, $kicker);
1323 $pl->killer ("kicked");
1324 $pl->ns->destroy;
1151} 1325}
1152 1326
1153=item cf::player::list_logins 1327=item cf::player::list_logins
1154 1328
1155Returns am arrayref of all valid playernames in the system, can take a 1329Returns am arrayref of all valid playernames in the system, can take a
1156while and may block, so not sync_job-capable, ever. 1330while and may block, so not sync_job-capable, ever.
1157 1331
1158=cut 1332=cut
1159 1333
1160sub list_logins { 1334sub list_logins {
1161 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir 1335 my $dirs = aio_readdir $PLAYERDIR
1162 or return []; 1336 or return [];
1163 1337
1164 my @logins; 1338 my @logins;
1165 1339
1166 for my $login (@$dirs) { 1340 for my $login (@$dirs) {
… …
1175 \@logins 1349 \@logins
1176} 1350}
1177 1351
1178=item $player->maps 1352=item $player->maps
1179 1353
1180Returns an arrayref of cf::path's of all maps that are private for this 1354Returns an arrayref of map paths that are private for this
1181player. May block. 1355player. May block.
1182 1356
1183=cut 1357=cut
1184 1358
1185sub maps($) { 1359sub maps($) {
1186 my ($pl) = @_; 1360 my ($pl) = @_;
1361
1362 $pl = ref $pl ? $pl->ob->name : $pl;
1187 1363
1188 my $files = aio_readdir playerdir $pl 1364 my $files = aio_readdir playerdir $pl
1189 or return; 1365 or return;
1190 1366
1191 my @paths; 1367 my @paths;
… …
1193 for (@$files) { 1369 for (@$files) {
1194 utf8::decode $_; 1370 utf8::decode $_;
1195 next if /\.(?:pl|pst)$/; 1371 next if /\.(?:pl|pst)$/;
1196 next unless /^$PATH_SEP/o; 1372 next unless /^$PATH_SEP/o;
1197 1373
1198 push @paths, new cf::path "~" . $pl->ob->name . "/" . $_; 1374 push @paths, cf::map::normalise "~$pl/$_";
1199 } 1375 }
1200 1376
1201 \@paths 1377 \@paths
1202} 1378}
1203 1379
1380=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1381
1382Expand crossfire pod fragments into protocol xml.
1383
1384=cut
1385
1386sub expand_cfpod {
1387 ((my $self), (local $_)) = @_;
1388
1389 # escape & and <
1390 s/&/&amp;/g;
1391 s/(?<![BIUGH])</&lt;/g;
1392
1393 # this is buggy, it needs to properly take care of nested <'s
1394
1395 1 while
1396 # replace B<>, I<>, U<> etc.
1397 s/B<([^\>]*)>/<b>$1<\/b>/
1398 || s/I<([^\>]*)>/<i>$1<\/i>/
1399 || s/U<([^\>]*)>/<u>$1<\/u>/
1400 # replace G<male|female> tags
1401 || s{G<([^>|]*)\|([^>]*)>}{
1402 $self->gender ? $2 : $1
1403 }ge
1404 # replace H<hint text>
1405 || s/H<([^\>]*)>/<fg name="lightblue">[$1]<\/fg>/g;
1406
1407 # create single paragraphs (very hackish)
1408 s/(?<=\S)\n(?=\w)/ /g;
1409
1410 $_
1411}
1412
1204=item $player->ext_reply ($msgid, $msgtype, %msg) 1413=item $player->ext_reply ($msgid, %msg)
1205 1414
1206Sends an ext reply to the player. 1415Sends an ext reply to the player.
1207 1416
1208=cut 1417=cut
1209 1418
1210sub ext_reply($$$%) { 1419sub ext_reply($$%) {
1211 my ($self, $id, %msg) = @_; 1420 my ($self, $id, %msg) = @_;
1212 1421
1213 $msg{msgid} = $id; 1422 $msg{msgid} = $id;
1214
1215 $self->send ("ext " . cf::to_json \%msg); 1423 $self->send ("ext " . cf::to_json \%msg);
1216} 1424}
1217 1425
1218package cf; 1426=item $player->ext_event ($type, %msg)
1427
1428Sends an ext event to the client.
1429
1430=cut
1431
1432sub ext_event($$%) {
1433 my ($self, $type, %msg) = @_;
1434
1435 $self->ns->ext_event ($type, %msg);
1436}
1437
1438=head3 cf::region
1439
1440=over 4
1441
1442=cut
1443
1444package cf::region;
1445
1446=item cf::region::find_by_path $path
1447
1448Tries to decuce the likely region for a map knowing only its path.
1449
1450=cut
1451
1452sub find_by_path($) {
1453 my ($path) = @_;
1454
1455 my ($match, $specificity);
1456
1457 for my $region (list) {
1458 if ($region->match && $path =~ $region->match) {
1459 ($match, $specificity) = ($region, $region->specificity)
1460 if $region->specificity > $specificity;
1461 }
1462 }
1463
1464 $match
1465}
1219 1466
1220=back 1467=back
1221
1222 1468
1223=head3 cf::map 1469=head3 cf::map
1224 1470
1225=over 4 1471=over 4
1226 1472
… …
1229package cf::map; 1475package cf::map;
1230 1476
1231use Fcntl; 1477use Fcntl;
1232use Coro::AIO; 1478use Coro::AIO;
1233 1479
1480use overload
1481 '""' => \&as_string,
1482 fallback => 1;
1483
1234our $MAX_RESET = 3600; 1484our $MAX_RESET = 3600;
1235our $DEFAULT_RESET = 3000; 1485our $DEFAULT_RESET = 3000;
1236 1486
1237sub generate_random_map { 1487sub generate_random_map {
1238 my ($path, $rmp) = @_; 1488 my ($self, $rmp) = @_;
1239
1240 # mit "rum" bekleckern, nicht 1489 # mit "rum" bekleckern, nicht
1241 cf::map::_create_random_map 1490 $self->_create_random_map (
1242 $path,
1243 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1491 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1244 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1492 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1245 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1493 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1246 $rmp->{exit_on_final_map}, 1494 $rmp->{exit_on_final_map},
1247 $rmp->{xsize}, $rmp->{ysize}, 1495 $rmp->{xsize}, $rmp->{ysize},
1248 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1496 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1249 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1497 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1250 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation}, 1498 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1251 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp}, 1499 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1252 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used}, 1500 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1253 (cf::region::find $rmp->{region}) 1501 (cf::region::find $rmp->{region}), $rmp->{custom}
1502 )
1503}
1504
1505=item cf::map->register ($regex, $prio)
1506
1507Register a handler for the map path matching the given regex at the
1508givne priority (higher is better, built-in handlers have priority 0, the
1509default).
1510
1511=cut
1512
1513sub register {
1514 my (undef, $regex, $prio) = @_;
1515 my $pkg = caller;
1516
1517 no strict;
1518 push @{"$pkg\::ISA"}, __PACKAGE__;
1519
1520 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1521}
1522
1523# also paths starting with '/'
1524$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}];
1525
1526sub thawer_merge {
1527 my ($self, $merge) = @_;
1528
1529 # we have to keep some variables in memory intact
1530 local $self->{path};
1531 local $self->{load_path};
1532
1533 $self->SUPER::thawer_merge ($merge);
1534}
1535
1536sub normalise {
1537 my ($path, $base) = @_;
1538
1539 $path = "$path"; # make sure its a string
1540
1541 $path =~ s/\.map$//;
1542
1543 # map plan:
1544 #
1545 # /! non-realised random map exit (special hack!)
1546 # {... are special paths that are not being touched
1547 # ?xxx/... are special absolute paths
1548 # ?random/... random maps
1549 # /... normal maps
1550 # ~user/... per-player map of a specific user
1551
1552 $path =~ s/$PATH_SEP/\//go;
1553
1554 # treat it as relative path if it starts with
1555 # something that looks reasonable
1556 if ($path =~ m{^(?:\./|\.\./|\w)}) {
1557 $base or Carp::carp "normalise called with relative path and no base: '$path'";
1558
1559 $base =~ s{[^/]+/?$}{};
1560 $path = "$base/$path";
1561 }
1562
1563 for ($path) {
1564 redo if s{//}{/};
1565 redo if s{/\.?/}{/};
1566 redo if s{/[^/]+/\.\./}{/};
1567 }
1568
1569 $path
1570}
1571
1572sub new_from_path {
1573 my (undef, $path, $base) = @_;
1574
1575 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object
1576
1577 $path = normalise $path, $base;
1578
1579 for my $pkg (sort { $EXT_MAP{$b}[0] <=> $EXT_MAP{$a}[0] } keys %EXT_MAP) {
1580 if ($path =~ $EXT_MAP{$pkg}[1]) {
1581 my $self = bless cf::map::new, $pkg;
1582 $self->{path} = $path; $self->path ($path);
1583 $self->init; # pass $1 etc.
1584 return $self;
1585 }
1586 }
1587
1588 Carp::carp "unable to resolve path '$path' (base '$base').";
1589 ()
1590}
1591
1592sub init {
1593 my ($self) = @_;
1594
1595 $self
1596}
1597
1598sub as_string {
1599 my ($self) = @_;
1600
1601 "$self->{path}"
1602}
1603
1604# the displayed name, this is a one way mapping
1605sub visible_name {
1606 &as_string
1607}
1608
1609# the original (read-only) location
1610sub load_path {
1611 my ($self) = @_;
1612
1613 "$MAPDIR/$self->{path}.map"
1614}
1615
1616# the temporary/swap location
1617sub save_path {
1618 my ($self) = @_;
1619
1620 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1621 "$TMPDIR/$path.map"
1622}
1623
1624# the unique path, undef == no special unique path
1625sub uniq_path {
1626 my ($self) = @_;
1627
1628 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1629 "$UNIQUEDIR/$path"
1254} 1630}
1255 1631
1256# and all this just because we cannot iterate over 1632# and all this just because we cannot iterate over
1257# all maps in C++... 1633# all maps in C++...
1258sub change_all_map_light { 1634sub change_all_map_light {
… …
1260 1636
1261 $_->change_map_light ($change) 1637 $_->change_map_light ($change)
1262 for grep $_->outdoor, values %cf::MAP; 1638 for grep $_->outdoor, values %cf::MAP;
1263} 1639}
1264 1640
1641sub decay_objects {
1642 my ($self) = @_;
1643
1644 return if $self->{deny_reset};
1645
1646 $self->do_decay_objects;
1647}
1648
1649sub unlink_save {
1650 my ($self) = @_;
1651
1652 utf8::encode (my $save = $self->save_path);
1653 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
1654 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst";
1655}
1656
1265sub try_load_header($) { 1657sub load_header_from($) {
1266 my ($path) = @_; 1658 my ($self, $path) = @_;
1267 1659
1268 utf8::encode $path; 1660 utf8::encode $path;
1269 aio_open $path, O_RDONLY, 0 1661 #aio_open $path, O_RDONLY, 0
1662 # or return;
1663
1664 $self->_load_header ($path)
1270 or return; 1665 or return;
1271 1666
1272 my $map = cf::map::new 1667 $self->{load_path} = $path;
1668
1669 1
1670}
1671
1672sub load_header_orig {
1673 my ($self) = @_;
1674
1675 $self->load_header_from ($self->load_path)
1676}
1677
1678sub load_header_temp {
1679 my ($self) = @_;
1680
1681 $self->load_header_from ($self->save_path)
1682}
1683
1684sub prepare_temp {
1685 my ($self) = @_;
1686
1687 $self->last_access ((delete $self->{last_access})
1688 || $cf::RUNTIME); #d#
1689 # safety
1690 $self->{instantiate_time} = $cf::RUNTIME
1691 if $self->{instantiate_time} > $cf::RUNTIME;
1692}
1693
1694sub prepare_orig {
1695 my ($self) = @_;
1696
1697 $self->{load_original} = 1;
1698 $self->{instantiate_time} = $cf::RUNTIME;
1699 $self->last_access ($cf::RUNTIME);
1700 $self->instantiate;
1701}
1702
1703sub load_header {
1704 my ($self) = @_;
1705
1706 if ($self->load_header_temp) {
1707 $self->prepare_temp;
1708 } else {
1709 $self->load_header_orig
1273 or return; 1710 or return;
1711 $self->prepare_orig;
1712 }
1274 1713
1275 # for better error messages only, will be overwritten 1714 $self->{deny_reset} = 1
1276 $map->path ($path); 1715 if $self->no_reset;
1277 1716
1278 $map->load_header ($path) 1717 $self->default_region (cf::region::find_by_path $self->{path})
1279 or return; 1718 unless $self->default_region;
1280 1719
1281 $map->{load_path} = $path; 1720 1
1282
1283 $map
1284} 1721}
1285 1722
1286sub find; 1723sub find;
1287sub find { 1724sub find {
1288 my ($path, $origin) = @_; 1725 my ($path, $origin) = @_;
1289 1726
1290 #warn "find<$path,$origin>\n";#d#
1291
1292 $path = new cf::path $path, $origin && $origin->path; 1727 $path = normalise $path, $origin && $origin->path;
1293 my $key = $path->as_string;
1294 1728
1295 cf::lock_wait "map_find:$key"; 1729 cf::lock_wait "map_find:$path";
1296 1730
1297 $cf::MAP{$key} || do { 1731 $cf::MAP{$path} || do {
1298 my $guard = cf::lock_acquire "map_find:$key"; 1732 my $guard = cf::lock_acquire "map_find:$path";
1299 1733 my $map = new_from_path cf::map $path
1300 # do it the slow way
1301 my $map = try_load_header $path->save_path;
1302
1303 Coro::cede;
1304
1305 if ($map) {
1306 $map->last_access ((delete $map->{last_access})
1307 || $cf::RUNTIME); #d#
1308 # safety
1309 $map->{instantiate_time} = $cf::RUNTIME
1310 if $map->{instantiate_time} > $cf::RUNTIME;
1311 } else {
1312 if (my $rmp = $path->random_map_params) {
1313 $map = generate_random_map $key, $rmp;
1314 } else {
1315 $map = try_load_header $path->load_path;
1316 }
1317
1318 $map or return; 1734 or return;
1319 1735
1320 $map->{load_original} = 1;
1321 $map->{instantiate_time} = $cf::RUNTIME;
1322 $map->last_access ($cf::RUNTIME);
1323 $map->instantiate;
1324
1325 # per-player maps become, after loading, normal maps
1326 $map->per_player (0) if $path->{user_rel};
1327 }
1328
1329 $map->path ($key);
1330 $map->{path} = $path;
1331 $map->{last_save} = $cf::RUNTIME; 1736 $map->{last_save} = $cf::RUNTIME;
1332 1737
1333 Coro::cede; 1738 $map->load_header
1739 or return;
1334 1740
1335 if ($map->should_reset) { 1741 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1742 # doing this can freeze the server in a sync job, obviously
1743 #$cf::WAIT_FOR_TICK->wait;
1336 $map->reset; 1744 $map->reset;
1337 undef $guard; 1745 undef $guard;
1338 $map = find $path 1746 return find $path;
1339 or return;
1340 } 1747 }
1341 1748
1342 $cf::MAP{$key} = $map 1749 $cf::MAP{$path} = $map
1343 } 1750 }
1344} 1751}
1752
1753sub pre_load { }
1754sub post_load { }
1345 1755
1346sub load { 1756sub load {
1347 my ($self) = @_; 1757 my ($self) = @_;
1348 1758
1759 local $self->{deny_reset} = 1; # loading can take a long time
1760
1349 my $path = $self->{path}; 1761 my $path = $self->{path};
1762
1763 {
1350 my $guard = cf::lock_acquire "map_load:" . $path->as_string; 1764 my $guard = cf::lock_acquire "map_load:$path";
1351 1765
1352 return if $self->in_memory != cf::MAP_SWAPPED; 1766 return if $self->in_memory != cf::MAP_SWAPPED;
1353 1767
1354 $self->in_memory (cf::MAP_LOADING); 1768 $self->in_memory (cf::MAP_LOADING);
1355 1769
1356 $self->alloc; 1770 $self->alloc;
1771
1772 $self->pre_load;
1773 Coro::cede;
1774
1357 $self->load_objects ($self->{load_path}, 1) 1775 $self->_load_objects ($self->{load_path}, 1)
1358 or return; 1776 or return;
1359 1777
1360 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 1778 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1361 if delete $self->{load_original}; 1779 if delete $self->{load_original};
1362 1780
1363 if (my $uniq = $path->uniq_path) { 1781 if (my $uniq = $self->uniq_path) {
1364 utf8::encode $uniq; 1782 utf8::encode $uniq;
1365 if (aio_open $uniq, O_RDONLY, 0) { 1783 if (aio_open $uniq, O_RDONLY, 0) {
1366 $self->clear_unique_items; 1784 $self->clear_unique_items;
1367 $self->load_objects ($uniq, 0); 1785 $self->_load_objects ($uniq, 0);
1368 } 1786 }
1369 } 1787 }
1370 1788
1371 Coro::cede; 1789 Coro::cede;
1372
1373 # now do the right thing for maps 1790 # now do the right thing for maps
1374 $self->link_multipart_objects; 1791 $self->link_multipart_objects;
1375
1376 if ($self->{path}->is_style_map) {
1377 $self->{deny_save} = 1;
1378 $self->{deny_reset} = 1;
1379 } else {
1380 $self->fix_auto_apply;
1381 $self->decay_objects;
1382 $self->update_buttons;
1383 $self->set_darkness_map;
1384 $self->difficulty ($self->estimate_difficulty) 1792 $self->difficulty ($self->estimate_difficulty)
1385 unless $self->difficulty; 1793 unless $self->difficulty;
1794 Coro::cede;
1795
1796 unless ($self->{deny_activate}) {
1797 $self->decay_objects;
1798 $self->fix_auto_apply;
1799 $self->update_buttons;
1800 Coro::cede;
1801 $self->set_darkness_map;
1802 Coro::cede;
1386 $self->activate; 1803 $self->activate;
1387 } 1804 }
1388 1805
1389 Coro::cede;
1390
1391 $self->in_memory (cf::MAP_IN_MEMORY); 1806 $self->in_memory (cf::MAP_IN_MEMORY);
1807 }
1808
1809 $self->post_load;
1810}
1811
1812sub customise_for {
1813 my ($self, $ob) = @_;
1814
1815 return find "~" . $ob->name . "/" . $self->{path}
1816 if $self->per_player;
1817
1818# return find "?party/" . $ob->name . "/" . $self->{path}
1819# if $self->per_party;
1820
1821 $self
1392} 1822}
1393 1823
1394# find and load all maps in the 3x3 area around a map 1824# find and load all maps in the 3x3 area around a map
1395sub load_diag { 1825sub load_diag {
1396 my ($map) = @_; 1826 my ($map) = @_;
… …
1426 1856
1427 cf::sync_job { $map->load }; 1857 cf::sync_job { $map->load };
1428} 1858}
1429 1859
1430our %MAP_PREFETCH; 1860our %MAP_PREFETCH;
1431our $MAP_PREFETCHER = Coro::async { 1861our $MAP_PREFETCHER = undef;
1432 while () {
1433 while (%MAP_PREFETCH) {
1434 my $key = each %MAP_PREFETCH
1435 or next;
1436 my $path = delete $MAP_PREFETCH{$key};
1437
1438 my $map = find $path
1439 or next;
1440 $map->load;
1441 }
1442 Coro::schedule;
1443 }
1444};
1445 1862
1446sub find_async { 1863sub find_async {
1447 my ($path, $origin) = @_; 1864 my ($path, $origin) = @_;
1448 1865
1449 $path = new cf::path $path, $origin && $origin->path; 1866 $path = normalise $path, $origin && $origin->{path};
1450 my $key = $path->as_string;
1451 1867
1452 if (my $map = $cf::MAP{$key}) { 1868 if (my $map = $cf::MAP{$path}) {
1453 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 1869 return $map if $map->in_memory == cf::MAP_IN_MEMORY;
1454 } 1870 }
1455 1871
1456 $MAP_PREFETCH{$key} = $path; 1872 undef $MAP_PREFETCH{$path};
1873 $MAP_PREFETCHER ||= cf::async {
1874 while (%MAP_PREFETCH) {
1875 for my $path (keys %MAP_PREFETCH) {
1876 my $map = find $path
1877 or next;
1878 $map->load;
1879
1880 delete $MAP_PREFETCH{$path};
1881 }
1882 }
1883 undef $MAP_PREFETCHER;
1884 };
1457 $MAP_PREFETCHER->ready; 1885 $MAP_PREFETCHER->prio (6);
1458 1886
1459 () 1887 ()
1460} 1888}
1461 1889
1462sub save { 1890sub save {
… …
1466 1894
1467 $self->{last_save} = $cf::RUNTIME; 1895 $self->{last_save} = $cf::RUNTIME;
1468 1896
1469 return unless $self->dirty; 1897 return unless $self->dirty;
1470 1898
1471 my $save = $self->{path}->save_path; utf8::encode $save; 1899 my $save = $self->save_path; utf8::encode $save;
1472 my $uniq = $self->{path}->uniq_path; utf8::encode $uniq; 1900 my $uniq = $self->uniq_path; utf8::encode $uniq;
1473 1901
1474 $self->{load_path} = $save; 1902 $self->{load_path} = $save;
1475 1903
1476 return if $self->{deny_save}; 1904 return if $self->{deny_save};
1477 1905
… …
1480 cf::async { 1908 cf::async {
1481 $_->contr->save for $self->players; 1909 $_->contr->save for $self->players;
1482 }; 1910 };
1483 1911
1484 if ($uniq) { 1912 if ($uniq) {
1485 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 1913 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1486 $self->save_objects ($uniq, cf::IO_UNIQUES); 1914 $self->_save_objects ($uniq, cf::IO_UNIQUES);
1487 } else { 1915 } else {
1488 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 1916 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
1489 } 1917 }
1490} 1918}
1491 1919
1492sub swap_out { 1920sub swap_out {
1493 my ($self) = @_; 1921 my ($self) = @_;
… …
1507 1935
1508sub reset_at { 1936sub reset_at {
1509 my ($self) = @_; 1937 my ($self) = @_;
1510 1938
1511 # TODO: safety, remove and allow resettable per-player maps 1939 # TODO: safety, remove and allow resettable per-player maps
1512 return 1e99 if $self->{path}{user_rel};
1513 return 1e99 if $self->{deny_reset}; 1940 return 1e99 if $self->{deny_reset};
1514 1941
1515 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 1942 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1516 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 1943 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1517 1944
… …
1522 my ($self) = @_; 1949 my ($self) = @_;
1523 1950
1524 $self->reset_at <= $cf::RUNTIME 1951 $self->reset_at <= $cf::RUNTIME
1525} 1952}
1526 1953
1527sub unlink_save {
1528 my ($self) = @_;
1529
1530 utf8::encode (my $save = $self->{path}->save_path);
1531 aioreq_pri 3; IO::AIO::aio_unlink $save;
1532 aioreq_pri 3; IO::AIO::aio_unlink "$save.pst";
1533}
1534
1535sub rename {
1536 my ($self, $new_path) = @_;
1537
1538 $self->unlink_save;
1539
1540 delete $cf::MAP{$self->path};
1541 $self->{path} = new cf::path $new_path;
1542 $self->path ($self->{path}->as_string);
1543 $cf::MAP{$self->path} = $self;
1544
1545 $self->save;
1546}
1547
1548sub reset { 1954sub reset {
1549 my ($self) = @_; 1955 my ($self) = @_;
1550 1956
1551 my $lock = cf::lock_acquire "map_data:" . $self->path; 1957 my $lock = cf::lock_acquire "map_data:$self->{path}";
1552 1958
1553 return if $self->players; 1959 return if $self->players;
1554 return if $self->{path}{user_rel};#d#
1555 1960
1556 warn "resetting map ", $self->path;#d# 1961 warn "resetting map ", $self->path;
1962
1963 $self->in_memory (cf::MAP_SWAPPED);
1964
1965 # need to save uniques path
1966 unless ($self->{deny_save}) {
1967 my $uniq = $self->uniq_path; utf8::encode $uniq;
1968
1969 $self->_save_objects ($uniq, cf::IO_UNIQUES)
1970 if $uniq;
1971 }
1557 1972
1558 delete $cf::MAP{$self->path}; 1973 delete $cf::MAP{$self->path};
1974
1975 $self->clear;
1559 1976
1560 $_->clear_links_to ($self) for values %cf::MAP; 1977 $_->clear_links_to ($self) for values %cf::MAP;
1561 1978
1562 $self->unlink_save; 1979 $self->unlink_save;
1563 $self->destroy; 1980 $self->destroy;
… …
1566my $nuke_counter = "aaaa"; 1983my $nuke_counter = "aaaa";
1567 1984
1568sub nuke { 1985sub nuke {
1569 my ($self) = @_; 1986 my ($self) = @_;
1570 1987
1988 delete $cf::MAP{$self->path};
1989
1990 $self->unlink_save;
1991
1992 bless $self, "cf::map";
1993 delete $self->{deny_reset};
1571 $self->{deny_save} = 1; 1994 $self->{deny_save} = 1;
1572 $self->reset_timeout (1); 1995 $self->reset_timeout (1);
1573 $self->rename ("{nuke}/" . ($nuke_counter++)); 1996 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1997
1998 $cf::MAP{$self->path} = $self;
1999
1574 $self->reset; # polite request, might not happen 2000 $self->reset; # polite request, might not happen
1575} 2001}
1576 2002
1577sub customise_for { 2003=item $maps = cf::map::tmp_maps
1578 my ($map, $ob) = @_;
1579 2004
1580 if ($map->per_player) { 2005Returns an arrayref with all map paths of currently instantiated and saved
1581 return cf::map::find "~" . $ob->name . "/" . $map->{path}{path}; 2006maps. May block.
2007
2008=cut
2009
2010sub tmp_maps() {
1582 } 2011 [
2012 map {
2013 utf8::decode $_;
2014 /\.map$/
2015 ? normalise $_
2016 : ()
2017 } @{ aio_readdir $TMPDIR or [] }
2018 ]
2019}
1583 2020
1584 $map 2021=item $maps = cf::map::random_maps
2022
2023Returns an arrayref with all map paths of currently instantiated and saved
2024random maps. May block.
2025
2026=cut
2027
2028sub random_maps() {
2029 [
2030 map {
2031 utf8::decode $_;
2032 /\.map$/
2033 ? normalise "?random/$_"
2034 : ()
2035 } @{ aio_readdir $RANDOMDIR or [] }
2036 ]
1585} 2037}
1586 2038
1587=item cf::map::unique_maps 2039=item cf::map::unique_maps
1588 2040
1589Returns an arrayref of cf::path's of all shared maps that have 2041Returns an arrayref of paths of all shared maps that have
1590instantiated unique items. May block. 2042instantiated unique items. May block.
1591 2043
1592=cut 2044=cut
1593 2045
1594sub unique_maps() { 2046sub unique_maps() {
1595 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir 2047 [
1596 or return; 2048 map {
1597
1598 my @paths;
1599
1600 for (@$files) {
1601 utf8::decode $_; 2049 utf8::decode $_;
1602 next if /\.pst$/; 2050 /\.map$/
1603 next unless /^$PATH_SEP/o; 2051 ? normalise $_
1604 2052 : ()
1605 push @paths, new cf::path $_; 2053 } @{ aio_readdir $UNIQUEDIR or [] }
1606 } 2054 ]
1607
1608 \@paths
1609} 2055}
1610 2056
1611package cf; 2057package cf;
1612 2058
1613=back 2059=back
… …
1659 2105
1660 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2106 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1661 2107
1662 if ($self->{record_replies}) { 2108 if ($self->{record_replies}) {
1663 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2109 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2110
1664 } else { 2111 } else {
2112 my $pl = $self->contr;
2113
2114 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2115 my $diag = $pl->{npc_dialog};
2116 $diag->{pl}->ext_reply (
2117 $diag->{id},
2118 msgtype => "reply",
2119 msg => $diag->{pl}->expand_cfpod ($msg),
2120 add_topics => []
2121 );
2122
2123 } else {
1665 $msg = $npc->name . " says: $msg" if $npc; 2124 $msg = $npc->name . " says: $msg" if $npc;
1666 $self->message ($msg, $flags); 2125 $self->message ($msg, $flags);
2126 }
1667 } 2127 }
1668} 2128}
1669 2129
1670=item $player_object->may ("access") 2130=item $player_object->may ("access")
1671 2131
… …
1685 2145
1686=item $player_object->enter_link 2146=item $player_object->enter_link
1687 2147
1688Freezes the player and moves him/her to a special map (C<{link}>). 2148Freezes the player and moves him/her to a special map (C<{link}>).
1689 2149
1690The player should be reaosnably safe there for short amounts of time. You 2150The player should be reasonably safe there for short amounts of time. You
1691I<MUST> call C<leave_link> as soon as possible, though. 2151I<MUST> call C<leave_link> as soon as possible, though.
1692 2152
2153Will never block.
2154
1693=item $player_object->leave_link ($map, $x, $y) 2155=item $player_object->leave_link ($map, $x, $y)
1694 2156
1695Moves the player out of the specila link map onto the given map. If the 2157Moves the player out of the special C<{link}> map onto the specified
1696map is not valid (or omitted), the player will be moved back to the 2158map. If the map is not valid (or omitted), the player will be moved back
1697location he/she was before the call to C<enter_link>, or, if that fails, 2159to the location he/she was before the call to C<enter_link>, or, if that
1698to the emergency map position. 2160fails, to the emergency map position.
1699 2161
1700Might block. 2162Might block.
1701 2163
1702=cut 2164=cut
2165
2166sub link_map {
2167 unless ($LINK_MAP) {
2168 $LINK_MAP = cf::map::find "{link}"
2169 or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
2170 $LINK_MAP->load;
2171 }
2172
2173 $LINK_MAP
2174}
1703 2175
1704sub cf::object::player::enter_link { 2176sub cf::object::player::enter_link {
1705 my ($self) = @_; 2177 my ($self) = @_;
1706 2178
1707 $self->deactivate_recursive; 2179 $self->deactivate_recursive;
1708 2180
1709 return if $self->map == $LINK_MAP; 2181 return if UNIVERSAL::isa $self->map, "ext::map_link";
1710 2182
1711 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2183 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1712 if $self->map; 2184 if $self->map && $self->map->{path} ne "{link}";
1713 2185
1714 $self->enter_map ($LINK_MAP, 20, 20); 2186 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1715} 2187}
1716 2188
1717sub cf::object::player::leave_link { 2189sub cf::object::player::leave_link {
1718 my ($self, $map, $x, $y) = @_; 2190 my ($self, $map, $x, $y) = @_;
2191
2192 return unless $self->contr->active;
1719 2193
1720 my $link_pos = delete $self->{_link_pos}; 2194 my $link_pos = delete $self->{_link_pos};
1721 2195
1722 unless ($map) { 2196 unless ($map) {
1723 # restore original map position 2197 # restore original map position
… …
1741 $map->load; 2215 $map->load;
1742 $map->load_diag; 2216 $map->load_diag;
1743 2217
1744 return unless $self->contr->active; 2218 return unless $self->contr->active;
1745 $self->activate_recursive; 2219 $self->activate_recursive;
2220
2221 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1746 $self->enter_map ($map, $x, $y); 2222 $self->enter_map ($map, $x, $y);
1747} 2223}
1748 2224
1749cf::player->attach (
1750 on_logout => sub {
1751 my ($pl) = @_;
1752
1753 # abort map switching before logout
1754 if ($pl->ob->{_link_pos}) {
1755 cf::sync_job {
1756 $pl->ob->leave_link
1757 };
1758 }
1759 },
1760 on_login => sub {
1761 my ($pl) = @_;
1762
1763 # try to abort aborted map switching on player login :)
1764 # should happen only on crashes
1765 if ($pl->ob->{_link_pos}) {
1766 $pl->ob->enter_link;
1767 (async {
1768 # we need this sleep as the login has a concurrent enter_exit running
1769 # and this sleep increases chances of the player not ending up in scorn
1770 $pl->ob->reply (undef,
1771 "There was an internal problem at your last logout, "
1772 . "the server will try to bring you to your intended destination in a second.",
1773 cf::NDI_RED);
1774 Coro::Timer::sleep 1;
1775 $pl->ob->leave_link;
1776 })->prio (2);
1777 }
1778 },
1779);
1780
1781=item $player_object->goto ($path, $x, $y) 2225=item $player_object->goto ($path, $x, $y[, $check->($map)])
1782 2226
2227Moves the player to the given map-path and coordinates by first freezing
2228her, loading and preparing them map, calling the provided $check callback
2229that has to return the map if sucecssful, and then unfreezes the player on
2230the new (success) or old (failed) map position.
2231
1783=cut 2232=cut
2233
2234our $GOTOGEN;
1784 2235
1785sub cf::object::player::goto { 2236sub cf::object::player::goto {
1786 my ($self, $path, $x, $y) = @_; 2237 my ($self, $path, $x, $y, $check) = @_;
1787 2238
1788 $path = new cf::path $path; 2239 # do generation counting so two concurrent goto's will be executed in-order
2240 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1789 2241
1790 $self->enter_link; 2242 $self->enter_link;
1791 2243
1792 (async { 2244 (async {
2245 my $map = eval {
1793 my $map = cf::map::find $path->as_string; 2246 my $map = cf::map::find $path;
2247
2248 if ($map) {
1794 $map = $map->customise_for ($self) if $map; 2249 $map = $map->customise_for ($self);
1795 2250 $map = $check->($map) if $check && $map;
1796# warn "entering ", $map->path, " at ($x, $y)\n" 2251 } else {
1797# if $map;
1798
1799 $map or $self->message ("The exit to '" . ($path->visible_name) . "' is closed", cf::NDI_UNIQUE | cf::NDI_RED); 2252 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
2253 }
1800 2254
2255 $map
2256 };
2257
2258 if ($@) {
2259 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2260 LOG llevError | logBacktrace, Carp::longmess $@;
2261 }
2262
2263 if ($gen == $self->{_goto_generation}) {
2264 delete $self->{_goto_generation};
1801 $self->leave_link ($map, $x, $y); 2265 $self->leave_link ($map, $x, $y);
2266 }
1802 })->prio (1); 2267 })->prio (1);
1803} 2268}
1804 2269
1805=item $player_object->enter_exit ($exit_object) 2270=item $player_object->enter_exit ($exit_object)
1806 2271
… …
1808 2273
1809sub parse_random_map_params { 2274sub parse_random_map_params {
1810 my ($spec) = @_; 2275 my ($spec) = @_;
1811 2276
1812 my $rmp = { # defaults 2277 my $rmp = { # defaults
1813 xsize => 10, 2278 xsize => (cf::rndm 15, 40),
1814 ysize => 10, 2279 ysize => (cf::rndm 15, 40),
2280 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
2281 #layout => string,
1815 }; 2282 };
1816 2283
1817 for (split /\n/, $spec) { 2284 for (split /\n/, $spec) {
1818 my ($k, $v) = split /\s+/, $_, 2; 2285 my ($k, $v) = split /\s+/, $_, 2;
1819 2286
… …
1823 $rmp 2290 $rmp
1824} 2291}
1825 2292
1826sub prepare_random_map { 2293sub prepare_random_map {
1827 my ($exit) = @_; 2294 my ($exit) = @_;
2295
2296 my $guard = cf::lock_acquire "exit_prepare:$exit";
1828 2297
1829 # all this does is basically replace the /! path by 2298 # all this does is basically replace the /! path by
1830 # a new random map path (?random/...) with a seed 2299 # a new random map path (?random/...) with a seed
1831 # that depends on the exit object 2300 # that depends on the exit object
1832 2301
1833 my $rmp = parse_random_map_params $exit->msg; 2302 my $rmp = parse_random_map_params $exit->msg;
1834 2303
1835 if ($exit->map) { 2304 if ($exit->map) {
1836 $rmp->{region} = $exit->map->region_name; 2305 $rmp->{region} = $exit->region->name;
1837 $rmp->{origin_map} = $exit->map->path; 2306 $rmp->{origin_map} = $exit->map->path;
1838 $rmp->{origin_x} = $exit->x; 2307 $rmp->{origin_x} = $exit->x;
1839 $rmp->{origin_y} = $exit->y; 2308 $rmp->{origin_y} = $exit->y;
1840 } 2309 }
1841 2310
1842 $rmp->{random_seed} ||= $exit->random_seed; 2311 $rmp->{random_seed} ||= $exit->random_seed;
1843 2312
1844 my $data = cf::to_json $rmp; 2313 my $data = cf::to_json $rmp;
1845 my $md5 = Digest::MD5::md5_hex $data; 2314 my $md5 = Digest::MD5::md5_hex $data;
2315 my $meta = "$RANDOMDIR/$md5.meta";
1846 2316
1847 if (my $fh = aio_open "$cf::RANDOM_MAPS/$md5.meta", O_WRONLY | O_CREAT, 0666) { 2317 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1848 aio_write $fh, 0, (length $data), $data, 0; 2318 aio_write $fh, 0, (length $data), $data, 0;
2319 undef $fh;
2320 aio_rename "$meta~", $meta;
1849 2321
1850 $exit->slaying ("?random/$md5"); 2322 $exit->slaying ("?random/$md5");
1851 $exit->msg (undef); 2323 $exit->msg (undef);
1852 } 2324 }
1853} 2325}
1854 2326
1855sub cf::object::player::enter_exit { 2327sub cf::object::player::enter_exit {
1856 my ($self, $exit) = @_; 2328 my ($self, $exit) = @_;
1857 2329
1858 return unless $self->type == cf::PLAYER; 2330 return unless $self->type == cf::PLAYER;
2331
2332 if ($exit->slaying eq "/!") {
2333 #TODO: this should de-fi-ni-te-ly not be a sync-job
2334 # the problem is that $exit might not survive long enough
2335 # so it needs to be done right now, right here
2336 cf::sync_job { prepare_random_map $exit };
2337 }
2338
2339 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2340 my $hp = $exit->stats->hp;
2341 my $sp = $exit->stats->sp;
1859 2342
1860 $self->enter_link; 2343 $self->enter_link;
1861 2344
1862 (async { 2345 (async {
1863 $self->deactivate_recursive; # just to be sure 2346 $self->deactivate_recursive; # just to be sure
1864 unless (eval { 2347 unless (eval {
1865 prepare_random_map $exit 2348 $self->goto ($slaying, $hp, $sp);
1866 if $exit->slaying eq "/!";
1867
1868 my $path = new cf::path $exit->slaying, $exit->map && $exit->map->path;
1869 $self->goto ($path, $exit->stats->hp, $exit->stats->sp);
1870 2349
1871 1; 2350 1;
1872 }) { 2351 }) {
1873 $self->message ("Something went wrong deep within the crossfire server. " 2352 $self->message ("Something went wrong deep within the crossfire server. "
1874 . "I'll try to bring you back to the map you were before. " 2353 . "I'll try to bring you back to the map you were before. "
1875 . "Please report this to the dungeon master!", 2354 . "Please report this to the dungeon master!",
1876 cf::NDI_UNIQUE | cf::NDI_RED); 2355 cf::NDI_UNIQUE | cf::NDI_RED);
1877 2356
1878 warn "ERROR in enter_exit: $@"; 2357 warn "ERROR in enter_exit: $@";
1879 $self->leave_link; 2358 $self->leave_link;
1880 } 2359 }
1881 })->prio (1); 2360 })->prio (1);
… …
1894 2373
1895sub cf::client::send_drawinfo { 2374sub cf::client::send_drawinfo {
1896 my ($self, $text, $flags) = @_; 2375 my ($self, $text, $flags) = @_;
1897 2376
1898 utf8::encode $text; 2377 utf8::encode $text;
1899 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 2378 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
1900} 2379}
1901 2380
2381=item $client->send_msg ($color, $type, $msg, [extra...])
2382
2383Send a drawinfo or msg packet to the client, formatting the msg for the
2384client if neccessary. C<$type> should be a string identifying the type of
2385the message, with C<log> being the default. If C<$color> is negative, suppress
2386the message unless the client supports the msg packet.
2387
2388=cut
2389
2390sub cf::client::send_msg {
2391 my ($self, $color, $type, $msg, @extra) = @_;
2392
2393 $msg = $self->pl->expand_cfpod ($msg);
2394
2395 if ($self->can_msg) {
2396 $self->send_packet ("msg " . cf::to_json [$color, $type, $msg, @extra]);
2397 } else {
2398 # replace some tags by gcfclient-compatible ones
2399 for ($msg) {
2400 1 while
2401 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2402 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2403 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2404 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2405 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2406 }
2407
2408 if ($color >= 0) {
2409 if (0 && $msg =~ /\[/) {
2410 $self->send_packet ("drawextinfo $color 4 0 $msg")
2411 } else {
2412 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2413 $self->send_packet ("drawinfo $color $msg")
2414 }
2415 }
2416 }
2417}
2418
2419=item $client->ext_event ($type, %msg)
2420
2421Sends an ext event to the client.
2422
2423=cut
2424
2425sub cf::client::ext_event($$%) {
2426 my ($self, $type, %msg) = @_;
2427
2428 $msg{msgtype} = "event_$type";
2429 $self->send_packet ("ext " . cf::to_json \%msg);
2430}
1902 2431
1903=item $success = $client->query ($flags, "text", \&cb) 2432=item $success = $client->query ($flags, "text", \&cb)
1904 2433
1905Queues a query to the client, calling the given callback with 2434Queues a query to the client, calling the given callback with
1906the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2435the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
1907C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 2436C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
1908 2437
1909Queries can fail, so check the return code. Or don't, as queries will become 2438Queries can fail, so check the return code. Or don't, as queries will
1910reliable at some point in the future. 2439become reliable at some point in the future.
1911 2440
1912=cut 2441=cut
1913 2442
1914sub cf::client::query { 2443sub cf::client::query {
1915 my ($self, $flags, $text, $cb) = @_; 2444 my ($self, $flags, $text, $cb) = @_;
… …
1923 utf8::encode $text; 2452 utf8::encode $text;
1924 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2453 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
1925 2454
1926 $self->send_packet ($self->{query_queue}[0][0]) 2455 $self->send_packet ($self->{query_queue}[0][0])
1927 if @{ $self->{query_queue} } == 1; 2456 if @{ $self->{query_queue} } == 1;
2457
2458 1
1928} 2459}
1929 2460
1930cf::client->attach ( 2461cf::client->attach (
1931 on_reply => sub { 2462 on_reply => sub {
1932 my ($ns, $msg) = @_; 2463 my ($ns, $msg) = @_;
… …
1935 # get handled first 2466 # get handled first
1936 my $queue = delete $ns->{query_queue} 2467 my $queue = delete $ns->{query_queue}
1937 or return; # be conservative, not sure how that can happen, but we saw a crash here 2468 or return; # be conservative, not sure how that can happen, but we saw a crash here
1938 2469
1939 (shift @$queue)->[1]->($msg); 2470 (shift @$queue)->[1]->($msg);
2471 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
1940 2472
1941 push @{ $ns->{query_queue} }, @$queue; 2473 push @{ $ns->{query_queue} }, @$queue;
1942 2474
1943 if (@{ $ns->{query_queue} } == @$queue) { 2475 if (@{ $ns->{query_queue} } == @$queue) {
1944 if (@$queue) { 2476 if (@$queue) {
… …
1946 } else { 2478 } else {
1947 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 2479 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
1948 } 2480 }
1949 } 2481 }
1950 }, 2482 },
2483 on_exticmd => sub {
2484 my ($ns, $buf) = @_;
2485
2486 my $msg = eval { from_json $buf };
2487
2488 if (ref $msg) {
2489 if (my $cb = $EXTICMD{$msg->{msgtype}}) {
2490 if (my %reply = $cb->($ns, $msg)) {
2491 $reply{msgid} = $msg->{msgid};
2492 $ns->send ("ext " . cf::to_json \%reply);
2493 }
2494 }
2495 } else {
2496 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2497 }
2498
2499 cf::override;
2500 },
1951); 2501);
1952 2502
1953=item $client->async (\&cb) 2503=item $client->async (\&cb)
1954 2504
1955Create a new coroutine, running the specified callback. The coroutine will 2505Create a new coroutine, running the specified callback. The coroutine will
… …
2002 2552
2003# here we export the classes and methods available to script code 2553# here we export the classes and methods available to script code
2004 2554
2005=pod 2555=pod
2006 2556
2007The following fucntions and emthods are available within a safe environment: 2557The following functions and methods are available within a safe environment:
2008 2558
2009 cf::object contr pay_amount pay_player map 2559 cf::object contr pay_amount pay_player map
2010 cf::object::player player 2560 cf::object::player player
2011 cf::player peaceful 2561 cf::player peaceful
2012 cf::map trigger 2562 cf::map trigger
… …
2093=back 2643=back
2094 2644
2095=cut 2645=cut
2096 2646
2097############################################################################# 2647#############################################################################
2648# the server's init and main functions
2098 2649
2099=head2 EXTENSION DATABASE SUPPORT 2650sub load_facedata($) {
2651 my ($path) = @_;
2100 2652
2101Crossfire maintains a very simple database for extension use. It can 2653 warn "loading facedata from $path\n";
2102currently store anything that can be serialised using Storable, which
2103excludes objects.
2104 2654
2105The parameter C<$family> should best start with the name of the extension 2655 my $facedata;
2106using it, it should be unique. 2656 0 < aio_load $path, $facedata
2657 or die "$path: $!";
2107 2658
2108=over 4 2659 $facedata = Coro::Storable::thaw $facedata;
2109 2660
2110=item $hashref = cf::db_get $family 2661 $facedata->{version} == 2
2662 or cf::cleanup "$path: version mismatch, cannot proceed.";
2111 2663
2112Return a hashref for use by the extension C<$family>, which can be
2113modified. After modifications, you have to call C<cf::db_dirty> or
2114C<cf::db_sync>.
2115
2116=item $value = cf::db_get $family => $key
2117
2118Returns a single value from the database
2119
2120=item cf::db_put $family => $hashref
2121
2122Stores the given family hashref into the database. Updates are delayed, if
2123you want the data to be synced to disk immediately, use C<cf::db_sync>.
2124
2125=item cf::db_put $family => $key => $value
2126
2127Stores the given C<$value> in the family hash. Updates are delayed, if you
2128want the data to be synced to disk immediately, use C<cf::db_sync>.
2129
2130=item cf::db_dirty
2131
2132Marks the database as dirty, to be updated at a later time.
2133
2134=item cf::db_sync
2135
2136Immediately write the database to disk I<if it is dirty>.
2137
2138=cut
2139
2140our $DB;
2141
2142{
2143 my $path = cf::localdir . "/database.pst";
2144
2145 sub db_load() {
2146 $DB = stat $path ? Storable::retrieve $path : { };
2147 } 2664 {
2665 my $faces = $facedata->{faceinfo};
2148 2666
2149 my $pid; 2667 while (my ($face, $info) = each %$faces) {
2150 2668 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2151 sub db_save() { 2669 cf::face::set $idx, $info->{visibility}, $info->{magicmap};
2152 waitpid $pid, 0 if $pid; 2670 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2153 if (0 == ($pid = fork)) { 2671 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2154 $DB->{_meta}{version} = 1; 2672 Coro::cede;
2155 Storable::nstore $DB, "$path~";
2156 rename "$path~", $path;
2157 cf::_exit 0 if defined $pid;
2158 }
2159 }
2160
2161 my $dirty;
2162
2163 sub db_sync() {
2164 db_save if $dirty;
2165 undef $dirty;
2166 }
2167
2168 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
2169 db_sync;
2170 });
2171
2172 sub db_dirty() {
2173 $dirty = 1;
2174 $idle->start;
2175 }
2176
2177 sub db_get($;$) {
2178 @_ >= 2
2179 ? $DB->{$_[0]}{$_[1]}
2180 : ($DB->{$_[0]} ||= { })
2181 }
2182
2183 sub db_put($$;$) {
2184 if (@_ >= 3) {
2185 $DB->{$_[0]}{$_[1]} = $_[2];
2186 } else {
2187 $DB->{$_[0]} = $_[1];
2188 }
2189 db_dirty;
2190 }
2191
2192 cf::global->attach (
2193 prio => 10000,
2194 on_cleanup => sub {
2195 db_sync;
2196 }, 2673 }
2197 );
2198}
2199 2674
2200############################################################################# 2675 while (my ($face, $info) = each %$faces) {
2201# the server's main() 2676 next unless $info->{smooth};
2677 my $idx = cf::face::find $face
2678 or next;
2679 if (my $smooth = cf::face::find $info->{smooth}) {
2680 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel};
2681 } else {
2682 warn "smooth face '$info->{smooth}' not found for face '$face'";
2683 }
2684 Coro::cede;
2685 }
2686 }
2687
2688 {
2689 my $anims = $facedata->{animinfo};
2690
2691 while (my ($anim, $info) = each %$anims) {
2692 cf::anim::set $anim, $info->{frames}, $info->{facings};
2693 Coro::cede;
2694 }
2695
2696 cf::anim::invalidate_all; # d'oh
2697 }
2698
2699 1
2700}
2701
2702sub reload_regions {
2703 load_resource_file "$MAPDIR/regions"
2704 or die "unable to load regions file\n";
2705}
2706
2707sub reload_facedata {
2708 load_facedata "$DATADIR/facedata"
2709 or die "unable to load facedata\n";
2710}
2711
2712sub reload_archetypes {
2713 load_resource_file "$DATADIR/archetypes"
2714 or die "unable to load archetypes\n";
2715 #d# NEED to laod twice to resolve forward references
2716 # this really needs to be done in an extra post-pass
2717 # (which needs to be synchronous, so solve it differently)
2718 load_resource_file "$DATADIR/archetypes"
2719 or die "unable to load archetypes\n";
2720}
2721
2722sub reload_treasures {
2723 load_resource_file "$DATADIR/treasures"
2724 or die "unable to load treasurelists\n";
2725}
2726
2727sub reload_resources {
2728 warn "reloading resource files...\n";
2729
2730 reload_regions;
2731 reload_facedata;
2732 #reload_archetypes;#d#
2733 reload_archetypes;
2734 reload_treasures;
2735
2736 warn "finished reloading resource files\n";
2737}
2738
2739sub init {
2740 reload_resources;
2741}
2202 2742
2203sub cfg_load { 2743sub cfg_load {
2204 open my $fh, "<:utf8", cf::confdir . "/config" 2744 open my $fh, "<:utf8", "$CONFDIR/config"
2205 or return; 2745 or return;
2206 2746
2207 local $/; 2747 local $/;
2208 *CFG = YAML::Syck::Load <$fh>; 2748 *CFG = YAML::Syck::Load <$fh>;
2209 2749
… …
2223 2763
2224sub main { 2764sub main {
2225 # we must not ever block the main coroutine 2765 # we must not ever block the main coroutine
2226 local $Coro::idle = sub { 2766 local $Coro::idle = sub {
2227 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 2767 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2768 (async {
2228 async { Event::one_event }; 2769 Event::one_event;
2770 })->prio (Coro::PRIO_MAX);
2229 }; 2771 };
2230 2772
2231 cfg_load; 2773 cfg_load;
2232 db_load; 2774 db_init;
2233 load_extensions; 2775 load_extensions;
2776
2777 $TICK_WATCHER->start;
2234 Event::loop; 2778 Event::loop;
2235} 2779}
2236 2780
2237############################################################################# 2781#############################################################################
2238# initialisation and cleanup 2782# initialisation and cleanup
2239 2783
2240# install some emergency cleanup handlers 2784# install some emergency cleanup handlers
2241BEGIN { 2785BEGIN {
2242 for my $signal (qw(INT HUP TERM)) { 2786 for my $signal (qw(INT HUP TERM)) {
2243 Event->signal ( 2787 Event->signal (
2788 reentrant => 0,
2244 data => WF_AUTOCANCEL, 2789 data => WF_AUTOCANCEL,
2245 signal => $signal, 2790 signal => $signal,
2791 prio => 0,
2246 cb => sub { 2792 cb => sub {
2247 cf::cleanup "SIG$signal"; 2793 cf::cleanup "SIG$signal";
2248 }, 2794 },
2249 ); 2795 );
2250 } 2796 }
2251} 2797}
2252 2798
2799sub write_runtime {
2800 my $runtime = "$LOCALDIR/runtime";
2801
2802 # first touch the runtime file to show we are still running:
2803 # the fsync below can take a very very long time.
2804
2805 IO::AIO::aio_utime $runtime, undef, undef;
2806
2807 my $guard = cf::lock_acquire "write_runtime";
2808
2809 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
2810 or return;
2811
2812 my $value = $cf::RUNTIME + 90 + 10;
2813 # 10 is the runtime save interval, for a monotonic clock
2814 # 60 allows for the watchdog to kill the server.
2815
2816 (aio_write $fh, 0, (length $value), $value, 0) <= 0
2817 and return;
2818
2819 # always fsync - this file is important
2820 aio_fsync $fh
2821 and return;
2822
2823 # touch it again to show we are up-to-date
2824 aio_utime $fh, undef, undef;
2825
2826 close $fh
2827 or return;
2828
2829 aio_rename "$runtime~", $runtime
2830 and return;
2831
2832 warn "runtime file written.\n";
2833
2834 1
2835}
2836
2253sub emergency_save() { 2837sub emergency_save() {
2254 my $freeze_guard = cf::freeze_mainloop; 2838 my $freeze_guard = cf::freeze_mainloop;
2255 2839
2256 warn "enter emergency perl save\n"; 2840 warn "enter emergency perl save\n";
2257 2841
2258 cf::sync_job { 2842 cf::sync_job {
2259 # use a peculiar iteration method to avoid tripping on perl 2843 # use a peculiar iteration method to avoid tripping on perl
2260 # refcount bugs in for. also avoids problems with players 2844 # refcount bugs in for. also avoids problems with players
2261 # and maps saved/Destroyed asynchronously. 2845 # and maps saved/destroyed asynchronously.
2262 warn "begin emergency player save\n"; 2846 warn "begin emergency player save\n";
2263 for my $login (keys %cf::PLAYER) { 2847 for my $login (keys %cf::PLAYER) {
2264 my $pl = $cf::PLAYER{$login} or next; 2848 my $pl = $cf::PLAYER{$login} or next;
2265 $pl->valid or next; 2849 $pl->valid or next;
2266 $pl->save; 2850 $pl->save;
… …
2272 my $map = $cf::MAP{$path} or next; 2856 my $map = $cf::MAP{$path} or next;
2273 $map->valid or next; 2857 $map->valid or next;
2274 $map->save; 2858 $map->save;
2275 } 2859 }
2276 warn "end emergency map save\n"; 2860 warn "end emergency map save\n";
2861
2862 warn "begin emergency database checkpoint\n";
2863 BDB::db_env_txn_checkpoint $DB_ENV;
2864 warn "end emergency database checkpoint\n";
2277 }; 2865 };
2278 2866
2279 warn "leave emergency perl save\n"; 2867 warn "leave emergency perl save\n";
2280} 2868}
2281 2869
2870sub post_cleanup {
2871 my ($make_core) = @_;
2872
2873 warn Carp::longmess "post_cleanup backtrace"
2874 if $make_core;
2875}
2876
2282sub reload() { 2877sub do_reload_perl() {
2283 # can/must only be called in main 2878 # can/must only be called in main
2284 if ($Coro::current != $Coro::main) { 2879 if ($Coro::current != $Coro::main) {
2285 warn "can only reload from main coroutine\n"; 2880 warn "can only reload from main coroutine";
2286 return; 2881 return;
2287 } 2882 }
2288 2883
2289 warn "reloading..."; 2884 warn "reloading...";
2290 2885
2291 warn "freezing server"; 2886 warn "entering sync_job";
2292 my $guard = freeze_mainloop; 2887
2888 cf::sync_job {
2889 cf::write_runtime; # external watchdog should not bark
2293 cf::emergency_save; 2890 cf::emergency_save;
2891 cf::write_runtime; # external watchdog should not bark
2294 2892
2295 warn "sync database to disk"; 2893 warn "syncing database to disk";
2296 cf::db_sync; 2894 BDB::db_env_txn_checkpoint $DB_ENV;
2297 IO::AIO::flush;
2298 2895
2299 eval {
2300 # if anything goes wrong in here, we should simply crash as we already saved 2896 # if anything goes wrong in here, we should simply crash as we already saved
2301 2897
2302 warn "cancel all watchers"; 2898 warn "cancelling all WF_AUTOCANCEL watchers";
2303 for (Event::all_watchers) { 2899 for (Event::all_watchers) {
2304 $_->cancel if $_->data & WF_AUTOCANCEL; 2900 $_->cancel if $_->data & WF_AUTOCANCEL;
2305 } 2901 }
2306 2902
2903 warn "flushing outstanding aio requests";
2904 for (;;) {
2905 BDB::flush;
2906 IO::AIO::flush;
2907 Coro::cede;
2908 last unless IO::AIO::nreqs || BDB::nreqs;
2909 warn "iterate...";
2910 }
2911
2912 ++$RELOAD;
2913
2307 warn "cancel all extension coros"; 2914 warn "cancelling all extension coros";
2308 $_->cancel for values %EXT_CORO; 2915 $_->cancel for values %EXT_CORO;
2309 %EXT_CORO = (); 2916 %EXT_CORO = ();
2310 2917
2311 warn "remove commands"; 2918 warn "removing commands";
2312 %COMMAND = (); 2919 %COMMAND = ();
2313 2920
2314 warn "remove ext commands"; 2921 warn "removing ext/exti commands";
2315 %EXTCMD = (); 2922 %EXTCMD = ();
2923 %EXTICMD = ();
2316 2924
2317 warn "unload/nuke all extensions"; 2925 warn "unloading/nuking all extensions";
2318 for my $pkg (@EXTS) { 2926 for my $pkg (@EXTS) {
2319 warn "... unloading $pkg"; 2927 warn "... unloading $pkg";
2320 2928
2321 if (my $cb = $pkg->can ("unload")) { 2929 if (my $cb = $pkg->can ("unload")) {
2322 eval { 2930 eval {
… …
2327 2935
2328 warn "... nuking $pkg"; 2936 warn "... nuking $pkg";
2329 Symbol::delete_package $pkg; 2937 Symbol::delete_package $pkg;
2330 } 2938 }
2331 2939
2332 warn "unload all perl modules loaded from $LIBDIR"; 2940 warn "unloading all perl modules loaded from $LIBDIR";
2333 while (my ($k, $v) = each %INC) { 2941 while (my ($k, $v) = each %INC) {
2334 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2942 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2335 2943
2336 warn "removing <$k>"; 2944 warn "... unloading $k";
2337 delete $INC{$k}; 2945 delete $INC{$k};
2338 2946
2339 $k =~ s/\.pm$//; 2947 $k =~ s/\.pm$//;
2340 $k =~ s/\//::/g; 2948 $k =~ s/\//::/g;
2341 2949
… …
2344 } 2952 }
2345 2953
2346 Symbol::delete_package $k; 2954 Symbol::delete_package $k;
2347 } 2955 }
2348 2956
2349 warn "get rid of safe::, as good as possible"; 2957 warn "getting rid of safe::, as good as possible";
2350 Symbol::delete_package "safe::$_" 2958 Symbol::delete_package "safe::$_"
2351 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 2959 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2352 2960
2353 warn "unload cf.pm \"a bit\""; 2961 warn "unloading cf.pm \"a bit\"";
2354 delete $INC{"cf.pm"}; 2962 delete $INC{"cf.pm"};
2963 delete $INC{"cf/pod.pm"};
2355 2964
2356 # don't, removes xs symbols, too, 2965 # don't, removes xs symbols, too,
2357 # and global variables created in xs 2966 # and global variables created in xs
2358 #Symbol::delete_package __PACKAGE__; 2967 #Symbol::delete_package __PACKAGE__;
2359 2968
2969 warn "unload completed, starting to reload now";
2970
2360 warn "reloading cf.pm"; 2971 warn "reloading cf.pm";
2361 require cf; 2972 require cf;
2362 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 2973 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2363 2974
2364 warn "load config and database again"; 2975 warn "loading config and database again";
2365 cf::cfg_load; 2976 cf::cfg_load;
2366 cf::db_load;
2367 2977
2368 warn "load extensions"; 2978 warn "loading extensions";
2369 cf::load_extensions; 2979 cf::load_extensions;
2370 2980
2371 warn "reattach attachments to objects/players"; 2981 warn "reattaching attachments to objects/players";
2372 _global_reattach; 2982 _global_reattach; # objects, sockets
2373 warn "reattach attachments to maps"; 2983 warn "reattaching attachments to maps";
2374 reattach $_ for values %MAP; 2984 reattach $_ for values %MAP;
2375 }; 2985 warn "reattaching attachments to players";
2986 reattach $_ for values %PLAYER;
2376 2987
2377 if ($@) { 2988 warn "leaving sync_job";
2989
2990 1
2991 } or do {
2378 warn $@; 2992 warn $@;
2379 warn "error while reloading, exiting."; 2993 warn "error while reloading, exiting.";
2380 exit 1; 2994 exit 1;
2381 } 2995 };
2382 2996
2383 warn "reloaded"; 2997 warn "reloaded";
2384}; 2998};
2385 2999
2386############################################################################# 3000our $RELOAD_WATCHER; # used only during reload
2387 3001
2388unless ($LINK_MAP) { 3002sub reload_perl() {
2389 $LINK_MAP = cf::map::new; 3003 # doing reload synchronously and two reloads happen back-to-back,
3004 # coro crashes during coro_state_free->destroy here.
2390 3005
2391 $LINK_MAP->width (41); 3006 $RELOAD_WATCHER ||= Event->timer (
2392 $LINK_MAP->height (41); 3007 reentrant => 0,
2393 $LINK_MAP->alloc;
2394 $LINK_MAP->path ("{link}");
2395 $LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";
2396 $LINK_MAP->in_memory (MAP_IN_MEMORY);
2397
2398 # dirty hack because... archetypes are not yet loaded
2399 Event->timer (
2400 after => 10, 3008 after => 0,
3009 data => WF_AUTOCANCEL,
2401 cb => sub { 3010 cb => sub {
2402 $_[0]->w->cancel; 3011 do_reload_perl;
2403 3012 undef $RELOAD_WATCHER;
2404 # provide some exits "home"
2405 my $exit = cf::object::new "exit";
2406
2407 $exit->slaying ($EMERGENCY_POSITION->[0]);
2408 $exit->stats->hp ($EMERGENCY_POSITION->[1]);
2409 $exit->stats->sp ($EMERGENCY_POSITION->[2]);
2410
2411 $LINK_MAP->insert ($exit->clone, 19, 19);
2412 $LINK_MAP->insert ($exit->clone, 19, 20);
2413 $LINK_MAP->insert ($exit->clone, 19, 21);
2414 $LINK_MAP->insert ($exit->clone, 20, 19);
2415 $LINK_MAP->insert ($exit->clone, 20, 21);
2416 $LINK_MAP->insert ($exit->clone, 21, 19);
2417 $LINK_MAP->insert ($exit->clone, 21, 20);
2418 $LINK_MAP->insert ($exit->clone, 21, 21);
2419
2420 $exit->destroy;
2421 }); 3013 },
2422 3014 );
2423 $LINK_MAP->{deny_save} = 1;
2424 $LINK_MAP->{deny_reset} = 1;
2425
2426 $cf::MAP{$LINK_MAP->path} = $LINK_MAP;
2427} 3015}
2428 3016
2429register_command "reload" => sub { 3017register_command "reload" => sub {
2430 my ($who, $arg) = @_; 3018 my ($who, $arg) = @_;
2431 3019
2432 if ($who->flag (FLAG_WIZ)) { 3020 if ($who->flag (FLAG_WIZ)) {
2433 $who->message ("start of reload.");
2434 reload;
2435 $who->message ("end of reload."); 3021 $who->message ("reloading server.");
3022 async { reload_perl };
2436 } 3023 }
2437}; 3024};
2438 3025
2439unshift @INC, $LIBDIR; 3026unshift @INC, $LIBDIR;
2440 3027
3028my $bug_warning = 0;
3029
3030our @WAIT_FOR_TICK;
3031our @WAIT_FOR_TICK_BEGIN;
3032
3033sub wait_for_tick {
3034 return unless $TICK_WATCHER->is_active;
3035 return if $Coro::current == $Coro::main;
3036
3037 my $signal = new Coro::Signal;
3038 push @WAIT_FOR_TICK, $signal;
3039 $signal->wait;
3040}
3041
3042sub wait_for_tick_begin {
3043 return unless $TICK_WATCHER->is_active;
3044 return if $Coro::current == $Coro::main;
3045
3046 my $signal = new Coro::Signal;
3047 push @WAIT_FOR_TICK_BEGIN, $signal;
3048 $signal->wait;
3049}
3050
3051 my $min = 1e6;#d#
3052 my $avg = 10;
2441$TICK_WATCHER = Event->timer ( 3053$TICK_WATCHER = Event->timer (
2442 reentrant => 0, 3054 reentrant => 0,
3055 parked => 1,
2443 prio => 0, 3056 prio => 0,
2444 at => $NEXT_TICK || $TICK, 3057 at => $NEXT_TICK || $TICK,
2445 data => WF_AUTOCANCEL, 3058 data => WF_AUTOCANCEL,
2446 cb => sub { 3059 cb => sub {
3060 if ($Coro::current != $Coro::main) {
3061 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3062 unless ++$bug_warning > 10;
3063 return;
3064 }
3065
3066 $NOW = $tick_start = Event::time;
3067
2447 cf::server_tick; # one server iteration 3068 cf::server_tick; # one server iteration
3069
3070 0 && sync_job {#d#
3071 for(1..10) {
3072 my $t = Event::time;
3073 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3074 or die;
3075
3076 $map->width (50);
3077 $map->height (50);
3078 $map->alloc;
3079 $map->_load_objects ("/tmp/x.map", 1);
3080 my $t = Event::time - $t;
3081
3082 #next unless $t < 0.0013;#d#
3083 if ($t < $min) {
3084 $min = $t;
3085 }
3086 $avg = $avg * 0.99 + $t * 0.01;
3087 }
3088 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3089 exit 0;
3090 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3091 };
3092
2448 $RUNTIME += $TICK; 3093 $RUNTIME += $TICK;
2449 $NEXT_TICK += $TICK; 3094 $NEXT_TICK += $TICK;
2450 3095
2451 $WAIT_FOR_TICK->broadcast; 3096 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2452 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited; 3097 $NEXT_RUNTIME_WRITE = $NOW + 10;
3098 Coro::async_pool {
3099 write_runtime
3100 or warn "ERROR: unable to write runtime file: $!";
3101 };
3102 }
3103
3104# my $AFTER = Event::time;
3105# warn $AFTER - $NOW;#d#
3106
3107 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3108 $sig->send;
3109 }
3110 while (my $sig = shift @WAIT_FOR_TICK) {
3111 $sig->send;
3112 }
3113
3114 $NOW = Event::time;
2453 3115
2454 # if we are delayed by four ticks or more, skip them all 3116 # if we are delayed by four ticks or more, skip them all
2455 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 3117 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2456 3118
2457 $TICK_WATCHER->at ($NEXT_TICK); 3119 $TICK_WATCHER->at ($NEXT_TICK);
2458 $TICK_WATCHER->start; 3120 $TICK_WATCHER->start;
3121
3122 $LOAD = ($NOW - $tick_start) / $TICK;
3123 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3124
3125 _post_tick;
3126
3127
2459 }, 3128 },
2460); 3129);
2461 3130
3131{
2462IO::AIO::max_poll_time $TICK * 0.2; 3132 BDB::max_poll_time $TICK * 0.1;
2463 3133 $BDB_POLL_WATCHER = Event->io (
2464Event->io ( 3134 reentrant => 0,
2465 fd => IO::AIO::poll_fileno, 3135 fd => BDB::poll_fileno,
2466 poll => 'r', 3136 poll => 'r',
2467 prio => 5, 3137 prio => 0,
2468 data => WF_AUTOCANCEL,
2469 cb => \&IO::AIO::poll_cb,
2470);
2471
2472Event->timer (
2473 data => WF_AUTOCANCEL, 3138 data => WF_AUTOCANCEL,
2474 after => 0, 3139 cb => \&BDB::poll_cb,
2475 interval => 10, 3140 );
2476 cb => sub { 3141 BDB::min_parallel 8;
2477 (Coro::unblock_sub { 3142
2478 write_runtime 3143 BDB::set_sync_prepare {
2479 or warn "ERROR: unable to write runtime file: $!"; 3144 my $status;
3145 my $current = $Coro::current;
3146 (
3147 sub {
3148 $status = $!;
3149 $current->ready; undef $current;
3150 },
3151 sub {
3152 Coro::schedule while defined $current;
3153 $! = $status;
3154 },
3155 )
3156 };
3157
3158 unless ($DB_ENV) {
3159 $DB_ENV = BDB::db_env_create;
3160
3161 cf::sync_job {
3162 eval {
3163 BDB::db_env_open
3164 $DB_ENV,
3165 $BDBDIR,
3166 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3167 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3168 0666;
3169
3170 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3171
3172 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3173 $DB_ENV->set_lk_detect;
3174 };
3175
3176 cf::cleanup "db_env_open(db): $@" if $@;
2480 })->(); 3177 };
2481 }, 3178 }
2482); 3179}
3180
3181{
3182 IO::AIO::min_parallel 8;
3183
3184 undef $Coro::AIO::WATCHER;
3185 IO::AIO::max_poll_time $TICK * 0.1;
3186 $AIO_POLL_WATCHER = Event->io (
3187 reentrant => 0,
3188 data => WF_AUTOCANCEL,
3189 fd => IO::AIO::poll_fileno,
3190 poll => 'r',
3191 prio => 6,
3192 cb => \&IO::AIO::poll_cb,
3193 );
3194}
3195
3196my $_log_backtrace;
3197
3198sub _log_backtrace {
3199 my ($msg, @addr) = @_;
3200
3201 $msg =~ s/\n//;
3202
3203 # limit the # of concurrent backtraces
3204 if ($_log_backtrace < 2) {
3205 ++$_log_backtrace;
3206 async {
3207 my @bt = fork_call {
3208 @addr = map { sprintf "%x", $_ } @addr;
3209 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3210 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3211 or die "addr2line: $!";
3212
3213 my @funcs;
3214 my @res = <$fh>;
3215 chomp for @res;
3216 while (@res) {
3217 my ($func, $line) = splice @res, 0, 2, ();
3218 push @funcs, "[$func] $line";
3219 }
3220
3221 @funcs
3222 };
3223
3224 LOG llevInfo, "[ABT] $msg\n";
3225 LOG llevInfo, "[ABT] $_\n" for @bt;
3226 --$_log_backtrace;
3227 };
3228 } else {
3229 LOG llevInfo, "[ABT] $msg\n";
3230 LOG llevInfo, "[ABT] [suppressed]\n";
3231 }
3232}
3233
3234# load additional modules
3235use cf::pod;
2483 3236
2484END { cf::emergency_save } 3237END { cf::emergency_save }
2485 3238
24861 32391
2487 3240

Diff Legend

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