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

Diff Legend

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