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.243 by root, Mon Apr 16 13:02:29 2007 UTC vs.
Revision 1.333 by root, Sun Aug 19 09:14:50 2007 UTC

3use utf8; 3use utf8;
4use strict; 4use strict;
5 5
6use Symbol; 6use Symbol;
7use List::Util; 7use List::Util;
8use Socket;
8use Storable; 9use Storable;
9use Event; 10use Event;
10use Opcode; 11use Opcode;
11use Safe; 12use Safe;
12use Safe::Hole; 13use Safe::Hole;
13 14
14use Coro 3.52 (); 15use Coro 3.64 ();
15use Coro::State; 16use Coro::State;
17use Coro::Handle;
16use Coro::Event; 18use Coro::Event;
17use Coro::Timer; 19use Coro::Timer;
18use Coro::Signal; 20use Coro::Signal;
19use Coro::Semaphore; 21use Coro::Semaphore;
20use Coro::AIO; 22use Coro::AIO;
21use Coro::Storable; 23use Coro::Storable;
24use Coro::Util ();
22 25
26use JSON::XS 1.4 ();
23use BDB (); 27use BDB ();
24use Data::Dumper; 28use Data::Dumper;
25use Digest::MD5; 29use Digest::MD5;
26use Fcntl; 30use Fcntl;
27use YAML::Syck (); 31use YAML::Syck ();
28use IO::AIO 2.32 (); 32use IO::AIO 2.32 ();
29use Time::HiRes; 33use Time::HiRes;
30use Compress::LZF; 34use Compress::LZF;
35use Digest::MD5 ();
31 36
32# configure various modules to our taste 37# configure various modules to our taste
33# 38#
34$Storable::canonical = 1; # reduce rsync transfers 39$Storable::canonical = 1; # reduce rsync transfers
35Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 40Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
47our %COMMAND = (); 52our %COMMAND = ();
48our %COMMAND_TIME = (); 53our %COMMAND_TIME = ();
49 54
50our @EXTS = (); # list of extension package names 55our @EXTS = (); # list of extension package names
51our %EXTCMD = (); 56our %EXTCMD = ();
57our %EXTICMD = ();
52our %EXT_CORO = (); # coroutines bound to extensions 58our %EXT_CORO = (); # coroutines bound to extensions
53our %EXT_MAP = (); # pluggable maps 59our %EXT_MAP = (); # pluggable maps
54 60
55our $RELOAD; # number of reloads so far 61our $RELOAD; # number of reloads so far
56our @EVENT; 62our @EVENT;
57our $LIBDIR = datadir . "/ext";
58 63
59our $TICK = MAX_TIME * 1e-6; 64our $CONFDIR = confdir;
65our $DATADIR = datadir;
66our $LIBDIR = "$DATADIR/ext";
67our $PODDIR = "$DATADIR/pod";
68our $MAPDIR = "$DATADIR/" . mapdir;
69our $LOCALDIR = localdir;
70our $TMPDIR = "$LOCALDIR/" . tmpdir;
71our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
72our $PLAYERDIR = "$LOCALDIR/" . playerdir;
73our $RANDOMDIR = "$LOCALDIR/random";
74our $BDBDIR = "$LOCALDIR/db";
75
76our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
60our $TICK_WATCHER; 77our $TICK_WATCHER;
61our $AIO_POLL_WATCHER; 78our $AIO_POLL_WATCHER;
62our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 79our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
63our $NEXT_TICK; 80our $NEXT_TICK;
64our $NOW; 81our $NOW;
73our $RUNTIME; 90our $RUNTIME;
74 91
75our %PLAYER; # all users 92our %PLAYER; # all users
76our %MAP; # all maps 93our %MAP; # all maps
77our $LINK_MAP; # the special {link} map, which is always available 94our $LINK_MAP; # the special {link} map, which is always available
78our $RANDOM_MAPS = cf::localdir . "/random";
79our $BDB_ENV_DIR = cf::localdir . "/db";
80 95
81# used to convert map paths into valid unix filenames by replacing / by ∕ 96# used to convert map paths into valid unix filenames by replacing / by ∕
82our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 97our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
83 98
99our $LOAD; # a number between 0 (idle) and 1 (too many objects)
100our $LOADAVG; # same thing, but with alpha-smoothing
101our $tick_start; # for load detecting purposes
102
84binmode STDOUT; 103binmode STDOUT;
85binmode STDERR; 104binmode STDERR;
86 105
87# read virtual server time, if available 106# read virtual server time, if available
88unless ($RUNTIME || !-e cf::localdir . "/runtime") { 107unless ($RUNTIME || !-e "$LOCALDIR/runtime") {
89 open my $fh, "<", cf::localdir . "/runtime" 108 open my $fh, "<", "$LOCALDIR/runtime"
90 or die "unable to read runtime file: $!"; 109 or die "unable to read runtime file: $!";
91 $RUNTIME = <$fh> + 0.; 110 $RUNTIME = <$fh> + 0.;
92} 111}
93 112
94mkdir cf::localdir; 113mkdir $_
95mkdir cf::localdir . "/" . cf::playerdir; 114 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
96mkdir cf::localdir . "/" . cf::tmpdir;
97mkdir cf::localdir . "/" . cf::uniquedir;
98mkdir $RANDOM_MAPS;
99mkdir $BDB_ENV_DIR;
100 115
101our $EMERGENCY_POSITION; 116our $EMERGENCY_POSITION;
102 117
103sub cf::map::normalise; 118sub cf::map::normalise;
104 119
115=item $cf::RUNTIME 130=item $cf::RUNTIME
116 131
117The time this server has run, starts at 0 and is increased by $cf::TICK on 132The time this server has run, starts at 0 and is increased by $cf::TICK on
118every server tick. 133every server tick.
119 134
120=item $cf::LIBDIR 135=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
136$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
137$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
121 138
122The perl library directory, where extensions and cf-specific modules can 139Various directories - "/etc", read-only install directory, perl-library
123be found. It will be added to C<@INC> automatically. 140directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
141unique-items directory, player file directory, random maps directory and
142database environment.
124 143
125=item $cf::NOW 144=item $cf::NOW
126 145
127The time of the last (current) server tick. 146The time of the last (current) server tick.
128 147
129=item $cf::TICK 148=item $cf::TICK
130 149
131The interval between server ticks, in seconds. 150The interval between server ticks, in seconds.
151
152=item $cf::LOADAVG
153
154The current CPU load on the server (alpha-smoothed), as a value between 0
155(none) and 1 (overloaded), indicating how much time is spent on processing
156objects per tick. Healthy values are < 0.5.
157
158=item $cf::LOAD
159
160The raw value load value from the last tick.
132 161
133=item %cf::CFG 162=item %cf::CFG
134 163
135Configuration for the server, loaded from C</etc/crossfire/config>, or 164Configuration for the server, loaded from C</etc/crossfire/config>, or
136from wherever your confdir points to. 165from wherever your confdir points to.
139 168
140These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 169These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
141returns directly I<after> the tick processing (and consequently, can only wake one process 170returns directly I<after> the tick processing (and consequently, can only wake one process
142per tick), while cf::wait_for_tick wakes up all waiters after tick processing. 171per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
143 172
173=item @cf::INVOKE_RESULTS
174
175This array contains the results of the last C<invoke ()> call. When
176C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
177that call.
178
144=back 179=back
145 180
146=cut 181=cut
147 182
148BEGIN { 183BEGIN {
149 *CORE::GLOBAL::warn = sub { 184 *CORE::GLOBAL::warn = sub {
150 my $msg = join "", @_; 185 my $msg = join "", @_;
151 utf8::encode $msg;
152 186
153 $msg .= "\n" 187 $msg .= "\n"
154 unless $msg =~ /\n$/; 188 unless $msg =~ /\n$/;
155 189
190 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
191
192 utf8::encode $msg;
156 LOG llevError, $msg; 193 LOG llevError, $msg;
157 }; 194 };
158} 195}
159 196
160@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 197@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
161@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 198@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
162@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 199@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
163@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 200@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
164@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable'; 201@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
202@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
165@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 203@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
166 204
167# we bless all objects into (empty) derived classes to force a method lookup 205# we bless all objects into (empty) derived classes to force a method lookup
168# within the Safe compartment. 206# within the Safe compartment.
169for my $pkg (qw( 207for my $pkg (qw(
170 cf::global cf::attachable 208 cf::global cf::attachable
178} 216}
179 217
180$Event::DIED = sub { 218$Event::DIED = sub {
181 warn "error in event callback: @_"; 219 warn "error in event callback: @_";
182}; 220};
221
222#############################################################################
183 223
184=head2 UTILITY FUNCTIONS 224=head2 UTILITY FUNCTIONS
185 225
186=over 4 226=over 4
187 227
206 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 246 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
207 $d 247 $d
208 } || "[unable to dump $_[0]: '$@']"; 248 } || "[unable to dump $_[0]: '$@']";
209} 249}
210 250
211use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working
212
213=item $ref = cf::from_json $json 251=item $ref = cf::from_json $json
214 252
215Converts a JSON string into the corresponding perl data structure. 253Converts a JSON string into the corresponding perl data structure.
216 254
217=item $json = cf::to_json $ref 255=item $json = cf::to_json $ref
218 256
219Converts a perl data structure into its JSON representation. 257Converts a perl data structure into its JSON representation.
258
259=cut
260
261our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
262
263sub to_json ($) { $json_coder->encode ($_[0]) }
264sub from_json ($) { $json_coder->decode ($_[0]) }
220 265
221=item cf::lock_wait $string 266=item cf::lock_wait $string
222 267
223Wait until the given lock is available. See cf::lock_acquire. 268Wait until the given lock is available. See cf::lock_acquire.
224 269
230returned. 275returned.
231 276
232Lock names should begin with a unique identifier (for example, cf::map::find 277Lock names should begin with a unique identifier (for example, cf::map::find
233uses map_find and cf::map::load uses map_load). 278uses map_find and cf::map::load uses map_load).
234 279
280=item $locked = cf::lock_active $string
281
282Return true if the lock is currently active, i.e. somebody has locked it.
283
235=cut 284=cut
236 285
237our %LOCK; 286our %LOCK;
238 287
239sub lock_wait($) { 288sub lock_wait($) {
256 305
257 Coro::guard { 306 Coro::guard {
258 # wake up all waiters, to be on the safe side 307 # wake up all waiters, to be on the safe side
259 $_->ready for @{ delete $LOCK{$key} }; 308 $_->ready for @{ delete $LOCK{$key} };
260 } 309 }
310}
311
312sub lock_active($) {
313 my ($key) = @_;
314
315 ! ! $LOCK{$key}
261} 316}
262 317
263sub freeze_mainloop { 318sub freeze_mainloop {
264 return unless $TICK_WATCHER->is_active; 319 return unless $TICK_WATCHER->is_active;
265 320
268 }; 323 };
269 $TICK_WATCHER->stop; 324 $TICK_WATCHER->stop;
270 $guard 325 $guard
271} 326}
272 327
328=item cf::get_slot $time[, $priority[, $name]]
329
330Allocate $time seconds of blocking CPU time at priority C<$priority>:
331This call blocks and returns only when you have at least C<$time> seconds
332of cpu time till the next tick. The slot is only valid till the next cede.
333
334The optional C<$name> can be used to identify the job to run. It might be
335used for statistical purposes and should identify the same time-class.
336
337Useful for short background jobs.
338
339=cut
340
341our @SLOT_QUEUE;
342our $SLOT_QUEUE;
343
344$SLOT_QUEUE->cancel if $SLOT_QUEUE;
345$SLOT_QUEUE = Coro::async {
346 my $signal = new Coro::Signal;
347
348 while () {
349 next_job:
350 my $avail = cf::till_tick;
351 if ($avail > 0.01) {
352 for (0 .. $#SLOT_QUEUE) {
353 if ($SLOT_QUEUE[$_][0] < $avail) {
354 my $job = splice @SLOT_QUEUE, $_, 1, ();
355 $job->[2]->send;
356 Coro::cede;
357 goto next_job;
358 }
359 }
360 }
361
362 if (@SLOT_QUEUE) {
363 # we do not use wait_For_tick() as it returns immediately when tick is inactive
364 push @cf::WAIT_FOR_TICK, $signal;
365 $signal->wait;
366 } else {
367 Coro::schedule;
368 }
369 }
370};
371
372sub get_slot($;$$) {
373 my ($time, $pri, $name) = @_;
374
375 $time = $TICK * .6 if $time > $TICK * .6;
376 my $sig = new Coro::Signal;
377
378 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
379 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
380 $SLOT_QUEUE->ready;
381 $sig->wait;
382}
383
273=item cf::async { BLOCK } 384=item cf::async { BLOCK }
274 385
275Currently the same as Coro::async_pool, meaning you cannot use 386Currently the same as Coro::async_pool, meaning you cannot use
276C<on_destroy>, C<join> or other gimmicks on these coroutines. The only 387C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
277thing you are allowed to do is call C<prio> on it. 388thing you are allowed to do is call C<prio> on it.
280 391
281BEGIN { *async = \&Coro::async_pool } 392BEGIN { *async = \&Coro::async_pool }
282 393
283=item cf::sync_job { BLOCK } 394=item cf::sync_job { BLOCK }
284 395
285The design of crossfire+ requires that the main coro ($Coro::main) is 396The design of Crossfire TRT requires that the main coroutine ($Coro::main)
286always able to handle events or runnable, as crossfire+ is only partly 397is always able to handle events or runnable, as Crossfire TRT is only
287reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable. 398partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
399acceptable.
288 400
289If it must be done, put the blocking parts into C<sync_job>. This will run 401If it must be done, put the blocking parts into C<sync_job>. This will run
290the given BLOCK in another coroutine while waiting for the result. The 402the given BLOCK in another coroutine while waiting for the result. The
291server will be frozen during this time, so the block should either finish 403server will be frozen during this time, so the block should either finish
292fast or be very important. 404fast or be very important.
295 407
296sub sync_job(&) { 408sub sync_job(&) {
297 my ($job) = @_; 409 my ($job) = @_;
298 410
299 if ($Coro::current == $Coro::main) { 411 if ($Coro::current == $Coro::main) {
412 my $time = Event::time;
413
300 # this is the main coro, too bad, we have to block 414 # this is the main coro, too bad, we have to block
301 # till the operation succeeds, freezing the server :/ 415 # till the operation succeeds, freezing the server :/
302 416
303 # TODO: use suspend/resume instead 417 # TODO: use suspend/resume instead
304 # (but this is cancel-safe) 418 # (but this is cancel-safe)
315 429
316 while ($busy) { 430 while ($busy) {
317 Coro::cede or Event::one_event; 431 Coro::cede or Event::one_event;
318 } 432 }
319 433
434 $time = Event::time - $time;
435
436 LOG llevError | logBacktrace, Carp::longmess "long sync job"
437 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
438
439 $tick_start += $time; # do not account sync jobs to server load
440
320 wantarray ? @res : $res[0] 441 wantarray ? @res : $res[0]
321 } else { 442 } else {
322 # we are in another coroutine, how wonderful, everything just works 443 # we are in another coroutine, how wonderful, everything just works
323 444
324 $job->() 445 $job->()
343 $EXT_CORO{$coro+0} = $coro; 464 $EXT_CORO{$coro+0} = $coro;
344 465
345 $coro 466 $coro
346} 467}
347 468
348sub write_runtime { 469=item fork_call { }, $args
349 my $guard = cf::lock_acquire "write_runtime";
350 470
351 my $runtime = cf::localdir . "/runtime"; 471Executes the given code block with the given arguments in a seperate
472process, returning the results. Everything must be serialisable with
473Coro::Storable. May, of course, block. Note that the executed sub may
474never block itself or use any form of Event handling.
352 475
353 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 476=cut
354 or return;
355 477
356 my $value = $cf::RUNTIME + 90 + 10; 478sub fork_call(&@) {
357 # 10 is the runtime save interval, for a monotonic clock 479 my ($cb, @args) = @_;
358 # 60 allows for the watchdog to kill the server.
359 480
360 (aio_write $fh, 0, (length $value), $value, 0) <= 0 481 # we seemingly have to make a local copy of the whole thing,
361 and return; 482 # otherwise perl prematurely frees the stuff :/
483 # TODO: investigate and fix (liekly this will be rather laborious)
362 484
363 # always fsync - this file is important 485 my @res = Coro::Util::fork_eval {
364 aio_fsync $fh 486 reset_signals;
365 and return; 487 &$cb
488 }, @args;
366 489
367 close $fh 490 wantarray ? @res : $res[-1]
368 or return; 491}
369 492
370 aio_rename "$runtime~", $runtime 493=item $value = cf::db_get $family => $key
371 and return;
372 494
495Returns a single value from the environment database.
496
497=item cf::db_put $family => $key => $value
498
499Stores the given C<$value> in the family. It can currently store binary
500data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
501
502=cut
503
504our $DB;
505
506sub db_init {
507 unless ($DB) {
508 $DB = BDB::db_create $DB_ENV;
509
510 cf::sync_job {
511 eval {
512 $DB->set_flags (BDB::CHKSUM);
513
514 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
515 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
516 cf::cleanup "db_open(db): $!" if $!;
517 };
518 cf::cleanup "db_open(db): $@" if $@;
519 };
373 1 520 }
521}
522
523sub db_get($$) {
524 my $key = "$_[0]/$_[1]";
525
526 cf::sync_job {
527 BDB::db_get $DB, undef, $key, my $data;
528
529 $! ? ()
530 : $data
531 }
532}
533
534sub db_put($$$) {
535 BDB::dbreq_pri 4;
536 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
537}
538
539=item cf::cache $id => [$paths...], $processversion => $process
540
541Generic caching function that returns the value of the resource $id,
542caching and regenerating as required.
543
544This function can block.
545
546=cut
547
548sub cache {
549 my ($id, $src, $processversion, $process) = @_;
550
551 my $meta =
552 join "\x00",
553 $processversion,
554 map {
555 aio_stat $_
556 and Carp::croak "$_: $!";
557
558 ($_, (stat _)[7,9])
559 } @$src;
560
561 my $dbmeta = db_get cache => "$id/meta";
562 if ($dbmeta ne $meta) {
563 # changed, we may need to process
564
565 my @data;
566 my $md5;
567
568 for (0 .. $#$src) {
569 0 <= aio_load $src->[$_], $data[$_]
570 or Carp::croak "$src->[$_]: $!";
571 }
572
573 # if processing is expensive, check
574 # checksum first
575 if (1) {
576 $md5 =
577 join "\x00",
578 $processversion,
579 map {
580 Coro::cede;
581 ($src->[$_], Digest::MD5::md5_hex $data[$_])
582 } 0.. $#$src;
583
584
585 my $dbmd5 = db_get cache => "$id/md5";
586 if ($dbmd5 eq $md5) {
587 db_put cache => "$id/meta", $meta;
588
589 return db_get cache => "$id/data";
590 }
591 }
592
593 my $t1 = Time::HiRes::time;
594 my $data = $process->(\@data);
595 my $t2 = Time::HiRes::time;
596
597 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
598
599 db_put cache => "$id/data", $data;
600 db_put cache => "$id/md5" , $md5;
601 db_put cache => "$id/meta", $meta;
602
603 return $data;
604 }
605
606 db_get cache => "$id/data"
374} 607}
375 608
376=item cf::datalog type => key => value, ... 609=item cf::datalog type => key => value, ...
377 610
378Log a datalog packet of the given type with the given key-value pairs. 611Log a datalog packet of the given type with the given key-value pairs.
396attach callbacks/event handlers (a collection of which is called an "attachment") 629attach callbacks/event handlers (a collection of which is called an "attachment")
397to it. All such attachable objects support the following methods. 630to it. All such attachable objects support the following methods.
398 631
399In the following description, CLASS can be any of C<global>, C<object> 632In the following description, CLASS can be any of C<global>, C<object>
400C<player>, C<client> or C<map> (i.e. the attachable objects in 633C<player>, C<client> or C<map> (i.e. the attachable objects in
401crossfire+). 634Crossfire TRT).
402 635
403=over 4 636=over 4
404 637
405=item $attachable->attach ($attachment, key => $value...) 638=item $attachable->attach ($attachment, key => $value...)
406 639
569 $registry = $CB_TYPE[$object_type] ||= []; 802 $registry = $CB_TYPE[$object_type] ||= [];
570 803
571 } elsif ($type eq "subtype") { 804 } elsif ($type eq "subtype") {
572 defined $object_type or Carp::croak "subtype specified without type"; 805 defined $object_type or Carp::croak "subtype specified without type";
573 my $object_subtype = shift @arg; 806 my $object_subtype = shift @arg;
574 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 807 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
575 808
576 } elsif ($type eq "package") { 809 } elsif ($type eq "package") {
577 my $pkg = shift @arg; 810 my $pkg = shift @arg;
578 811
579 while (my ($name, $id) = each %cb_id) { 812 while (my ($name, $id) = each %cb_id) {
608 _attach $registry, $klass, @attach; 841 _attach $registry, $klass, @attach;
609 } 842 }
610 843
611 $obj->{$name} = \%arg; 844 $obj->{$name} = \%arg;
612 } else { 845 } else {
613 warn "object uses attachment '$name' that is not available, postponing.\n"; 846 warn "object uses attachment '$name' which is not available, postponing.\n";
614 } 847 }
615 848
616 $obj->{_attachment}{$name} = undef; 849 $obj->{_attachment}{$name} = undef;
617} 850}
618 851
620 if (ref $_[0]) { 853 if (ref $_[0]) {
621 _object_attach @_; 854 _object_attach @_;
622 } else { 855 } else {
623 _attach shift->_attach_registry, @_; 856 _attach shift->_attach_registry, @_;
624 } 857 }
858 _recalc_want;
625}; 859};
626 860
627# all those should be optimised 861# all those should be optimised
628sub cf::attachable::detach { 862sub cf::attachable::detach {
629 my ($obj, $name) = @_; 863 my ($obj, $name) = @_;
632 delete $obj->{_attachment}{$name}; 866 delete $obj->{_attachment}{$name};
633 reattach ($obj); 867 reattach ($obj);
634 } else { 868 } else {
635 Carp::croak "cannot, currently, detach class attachments"; 869 Carp::croak "cannot, currently, detach class attachments";
636 } 870 }
871 _recalc_want;
637}; 872};
638 873
639sub cf::attachable::attached { 874sub cf::attachable::attached {
640 my ($obj, $name) = @_; 875 my ($obj, $name) = @_;
641 876
656 "; 891 ";
657 die if $@; 892 die if $@;
658} 893}
659 894
660our $override; 895our $override;
661our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 896our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
662 897
663sub override { 898sub override {
664 $override = 1; 899 $override = 1;
665 @invoke_results = (); 900 @INVOKE_RESULTS = (@_);
666} 901}
667 902
668sub do_invoke { 903sub do_invoke {
669 my $event = shift; 904 my $event = shift;
670 my $callbacks = shift; 905 my $callbacks = shift;
671 906
672 @invoke_results = (); 907 @INVOKE_RESULTS = ();
673 908
674 local $override; 909 local $override;
675 910
676 for (@$callbacks) { 911 for (@$callbacks) {
677 eval { &{$_->[1]} }; 912 eval { &{$_->[1]} };
694 929
695Generate an object-specific event with the given arguments. 930Generate an object-specific event with the given arguments.
696 931
697This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be 932This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
698removed in future versions), and there is no public API to access override 933removed in future versions), and there is no public API to access override
699results (if you must, access C<@cf::invoke_results> directly). 934results (if you must, access C<@cf::INVOKE_RESULTS> directly).
700 935
701=back 936=back
702 937
703=cut 938=cut
704 939
705############################################################################# 940#############################################################################
706# object support 941# object support
942#
943
944sub _can_merge {
945 my ($ob1, $ob2) = @_;
946
947 local $Storable::canonical = 1;
948 my $fob1 = Storable::freeze $ob1;
949 my $fob2 = Storable::freeze $ob2;
950
951 $fob1 eq $fob2
952}
707 953
708sub reattach { 954sub reattach {
709 # basically do the same as instantiate, without calling instantiate 955 # basically do the same as instantiate, without calling instantiate
710 my ($obj) = @_; 956 my ($obj) = @_;
711 957
814 or return; 1060 or return;
815 $av = eval { (Storable::thaw $av)->{objs} }; 1061 $av = eval { (Storable::thaw $av)->{objs} };
816 } 1062 }
817 1063
818 warn sprintf "loading %s (%d)\n", 1064 warn sprintf "loading %s (%d)\n",
819 $filename, length $data, scalar @{$av || []};#d# 1065 $filename, length $data, scalar @{$av || []};
820 return ($data, $av); 1066 return ($data, $av);
821} 1067}
1068
1069=head2 COMMAND CALLBACKS
1070
1071=over 4
1072
1073=cut
822 1074
823############################################################################# 1075#############################################################################
824# command handling &c 1076# command handling &c
825 1077
826=item cf::register_command $name => \&callback($ob,$args); 1078=item cf::register_command $name => \&callback($ob,$args);
839 push @{ $COMMAND{$name} }, [$caller, $cb]; 1091 push @{ $COMMAND{$name} }, [$caller, $cb];
840} 1092}
841 1093
842=item cf::register_extcmd $name => \&callback($pl,$packet); 1094=item cf::register_extcmd $name => \&callback($pl,$packet);
843 1095
844Register a callbackf ro execution when the client sends an extcmd packet. 1096Register a callback for execution when the client sends an (synchronous)
1097extcmd packet. Ext commands will be processed in the order they are
1098received by the server, like other user commands. The first argument is
1099the logged-in player. Ext commands can only be processed after a player
1100has logged in successfully.
845 1101
846If the callback returns something, it is sent back as if reply was being 1102If the callback returns something, it is sent back as if reply was being
847called. 1103called.
848 1104
1105=item cf::register_exticmd $name => \&callback($ns,$packet);
1106
1107Register a callback for execution when the client sends an (asynchronous)
1108exticmd packet. Exti commands are processed by the server as soon as they
1109are received, i.e. out of order w.r.t. other commands. The first argument
1110is a client socket. Exti commands can be received anytime, even before
1111log-in.
1112
1113If the callback returns something, it is sent back as if reply was being
1114called.
1115
849=cut 1116=cut
850 1117
851sub register_extcmd { 1118sub register_extcmd {
852 my ($name, $cb) = @_; 1119 my ($name, $cb) = @_;
853 1120
854 $EXTCMD{$name} = $cb; 1121 $EXTCMD{$name} = $cb;
1122}
1123
1124sub register_exticmd {
1125 my ($name, $cb) = @_;
1126
1127 $EXTICMD{$name} = $cb;
855} 1128}
856 1129
857cf::player->attach ( 1130cf::player->attach (
858 on_command => sub { 1131 on_command => sub {
859 my ($pl, $name, $params) = @_; 1132 my ($pl, $name, $params) = @_;
868 cf::override; 1141 cf::override;
869 }, 1142 },
870 on_extcmd => sub { 1143 on_extcmd => sub {
871 my ($pl, $buf) = @_; 1144 my ($pl, $buf) = @_;
872 1145
873 my $msg = eval { from_json $buf }; 1146 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
874 1147
875 if (ref $msg) { 1148 if (ref $msg) {
1149 my ($type, $reply, @payload) =
1150 "ARRAY" eq ref $msg
1151 ? @$msg
1152 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1153
876 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1154 if (my $cb = $EXTCMD{$type}) {
877 if (my %reply = $cb->($pl, $msg)) { 1155 my @reply = $cb->($pl, @payload);
1156
878 $pl->ext_reply ($msg->{msgid}, %reply); 1157 $pl->ext_reply ($reply, @reply)
879 } 1158 if $reply;
880 } 1159 }
881 } else { 1160 } else {
882 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1161 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
883 } 1162 }
884 1163
885 cf::override; 1164 cf::override;
886 }, 1165 },
887); 1166);
888 1167
889sub load_extension {
890 my ($path) = @_;
891
892 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
893 my $base = $1;
894 my $pkg = $1;
895 $pkg =~ s/[^[:word:]]/_/g;
896 $pkg = "ext::$pkg";
897
898 warn "... loading '$path' into '$pkg'\n";
899
900 open my $fh, "<:utf8", $path
901 or die "$path: $!";
902
903 my $source =
904 "package $pkg; use strict; use utf8;\n"
905 . "#line 1 \"$path\"\n{\n"
906 . (do { local $/; <$fh> })
907 . "\n};\n1";
908
909 unless (eval $source) {
910 my $msg = $@ ? "$path: $@\n"
911 : "extension disabled.\n";
912 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
913 warn $@;
914 warn "mandatory extension failed to load, exiting.\n";
915 exit 1;
916 }
917 die $@;
918 }
919
920 push @EXTS, $pkg;
921}
922
923sub load_extensions { 1168sub load_extensions {
1169 cf::sync_job {
1170 my %todo;
1171
924 for my $ext (<$LIBDIR/*.ext>) { 1172 for my $path (<$LIBDIR/*.ext>) {
925 next unless -r $ext; 1173 next unless -r $path;
926 eval { 1174
927 load_extension $ext; 1175 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1176 my $base = $1;
1177 my $pkg = $1;
1178 $pkg =~ s/[^[:word:]]/_/g;
1179 $pkg = "ext::$pkg";
1180
1181 open my $fh, "<:utf8", $path
1182 or die "$path: $!";
1183
1184 my $source = do { local $/; <$fh> };
1185
1186 my %ext = (
1187 path => $path,
1188 base => $base,
1189 pkg => $pkg,
1190 );
1191
1192 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1193 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1194
1195 $ext{source} =
1196 "package $pkg; use strict; use utf8;\n"
1197 . "#line 1 \"$path\"\n{\n"
1198 . $source
1199 . "\n};\n1";
1200
1201 $todo{$base} = \%ext;
1202 }
1203
1204 my %done;
1205 while (%todo) {
1206 my $progress;
1207
1208 while (my ($k, $v) = each %todo) {
1209 for (split /,\s*/, $v->{meta}{depends}) {
1210 goto skip
1211 unless exists $done{$_};
1212 }
1213
1214 warn "... loading '$k' into '$v->{pkg}'\n";
1215
1216 unless (eval $v->{source}) {
1217 my $msg = $@ ? "$v->{path}: $@\n"
1218 : "$v->{base}: extension inactive.\n";
1219
1220 if (exists $v->{meta}{mandatory}) {
1221 warn $msg;
1222 warn "mandatory extension failed to load, exiting.\n";
1223 exit 1;
1224 }
1225
1226 warn $msg;
1227 }
1228
1229 $done{$k} = delete $todo{$k};
1230 push @EXTS, $v->{pkg};
1231 $progress = 1;
928 1 1232 }
929 } or warn "$ext not loaded: $@"; 1233
1234 skip:
1235 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1236 unless $progress;
1237 }
930 } 1238 };
931} 1239}
932 1240
933############################################################################# 1241#############################################################################
934 1242
1243=back
1244
935=head2 CORE EXTENSIONS 1245=head2 CORE EXTENSIONS
936 1246
937Functions and methods that extend core crossfire objects. 1247Functions and methods that extend core crossfire objects.
938 1248
939=cut 1249=cut
951Returns the given player object, loading it if necessary (might block). 1261Returns the given player object, loading it if necessary (might block).
952 1262
953=cut 1263=cut
954 1264
955sub playerdir($) { 1265sub playerdir($) {
956 cf::localdir 1266 "$PLAYERDIR/"
957 . "/"
958 . cf::playerdir
959 . "/"
960 . (ref $_[0] ? $_[0]->ob->name : $_[0]) 1267 . (ref $_[0] ? $_[0]->ob->name : $_[0])
961} 1268}
962 1269
963sub path($) { 1270sub path($) {
964 my $login = ref $_[0] ? $_[0]->ob->name : $_[0]; 1271 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
1028 $cf::PLAYER{$login} = $self; 1335 $cf::PLAYER{$login} = $self;
1029 1336
1030 $self 1337 $self
1031} 1338}
1032 1339
1340=item $player->send_msg ($channel, $msg, $color, [extra...])
1341
1342=cut
1343
1344sub send_msg {
1345 my $ns = shift->ns
1346 or return;
1347 $ns->send_msg (@_);
1348}
1349
1033=item $pl->quit_character 1350=item $pl->quit_character
1034 1351
1035Nukes the player without looking back. If logged in, the connection will 1352Nukes the player without looking back. If logged in, the connection will
1036be destroyed. May block for a long time. 1353be destroyed. May block for a long time.
1037 1354
1084while and may block, so not sync_job-capable, ever. 1401while and may block, so not sync_job-capable, ever.
1085 1402
1086=cut 1403=cut
1087 1404
1088sub list_logins { 1405sub list_logins {
1089 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir 1406 my $dirs = aio_readdir $PLAYERDIR
1090 or return []; 1407 or return [];
1091 1408
1092 my @logins; 1409 my @logins;
1093 1410
1094 for my $login (@$dirs) { 1411 for my $login (@$dirs) {
1129 } 1446 }
1130 1447
1131 \@paths 1448 \@paths
1132} 1449}
1133 1450
1451=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1452
1453Expand crossfire pod fragments into protocol xml.
1454
1455=cut
1456
1457sub expand_cfpod {
1458 ((my $self), (local $_)) = @_;
1459
1460 # escape & and <
1461 s/&/&amp;/g;
1462 s/(?<![BIUGH])</&lt;/g;
1463
1464 # this is buggy, it needs to properly take care of nested <'s
1465
1466 1 while
1467 # replace B<>, I<>, U<> etc.
1468 s/B<([^\>]*)>/<b>$1<\/b>/
1469 || s/I<([^\>]*)>/<i>$1<\/i>/
1470 || s/U<([^\>]*)>/<u>$1<\/u>/
1471 # replace G<male|female> tags
1472 || s{G<([^>|]*)\|([^>]*)>}{
1473 $self->gender ? $2 : $1
1474 }ge
1475 # replace H<hint text>
1476 || s{H<([^\>]*)>}
1477 {
1478 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
1479 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1480 "")
1481 [$self->{hintmode}]
1482 }ge;
1483
1484 # create single paragraphs (very hackish)
1485 s/(?<=\S)\n(?=\w)/ /g;
1486
1487 # compress some whitespace
1488 s/\s+\n/\n/g; # ws line-ends
1489 s/\n\n+/\n/g; # double lines
1490 s/^\n+//; # beginning lines
1491 s/\n+$//; # ending lines
1492
1493 $_
1494}
1495
1496sub hintmode {
1497 $_[0]{hintmode} = $_[1] if @_ > 1;
1498 $_[0]{hintmode}
1499}
1500
1134=item $player->ext_reply ($msgid, %msg) 1501=item $player->ext_reply ($msgid, @msg)
1135 1502
1136Sends an ext reply to the player. 1503Sends an ext reply to the player.
1137 1504
1138=cut 1505=cut
1139 1506
1140sub ext_reply($$%) { 1507sub ext_reply($$@) {
1141 my ($self, $id, %msg) = @_; 1508 my ($self, $id, @msg) = @_;
1142 1509
1143 $msg{msgid} = $id; 1510 if ($self->ns->extcmd == 2) {
1144 1511 $self->send ("ext " . $self->ns->{json_coder}->encode (["reply-$id", @msg]));
1145 $self->send ("ext " . cf::to_json \%msg); 1512 } elsif ($self->ns->extcmd == 1) {
1513 #TODO: version 1, remove
1514 unshift @msg, msgtype => "reply", msgid => $id;
1515 $self->send ("ext " . $self->ns->{json_coder}->encode ({@msg}));
1516 }
1146} 1517}
1147 1518
1148=item $player->ext_event ($type, %msg) 1519=item $player->ext_msg ($type, @msg)
1149 1520
1150Sends an ext event to the client. 1521Sends an ext event to the client.
1151 1522
1152=cut 1523=cut
1153 1524
1154sub ext_event($$%) { 1525sub ext_msg($$@) {
1155 my ($self, $type, %msg) = @_; 1526 my ($self, $type, @msg) = @_;
1156 1527
1157 $self->ns->ext_event ($type, %msg); 1528 $self->ns->ext_msg ($type, @msg);
1158} 1529}
1159 1530
1160=head3 cf::region 1531=head3 cf::region
1161 1532
1162=over 4 1533=over 4
1165 1536
1166package cf::region; 1537package cf::region;
1167 1538
1168=item cf::region::find_by_path $path 1539=item cf::region::find_by_path $path
1169 1540
1170Tries to decuce the probable region for a map knowing only its path. 1541Tries to decuce the likely region for a map knowing only its path.
1171 1542
1172=cut 1543=cut
1173 1544
1174sub find_by_path($) { 1545sub find_by_path($) {
1175 my ($path) = @_; 1546 my ($path) = @_;
1176 1547
1177 my ($match, $specificity); 1548 my ($match, $specificity);
1178 1549
1179 for my $region (list) { 1550 for my $region (list) {
1180 if ($region->match && $path =~ $region->match) { 1551 if ($region->{match} && $path =~ $region->{match}) {
1181 ($match, $specificity) = ($region, $region->specificity) 1552 ($match, $specificity) = ($region, $region->specificity)
1182 if $region->specificity > $specificity; 1553 if $region->specificity > $specificity;
1183 } 1554 }
1184 } 1555 }
1185 1556
1249 my ($self, $merge) = @_; 1620 my ($self, $merge) = @_;
1250 1621
1251 # we have to keep some variables in memory intact 1622 # we have to keep some variables in memory intact
1252 local $self->{path}; 1623 local $self->{path};
1253 local $self->{load_path}; 1624 local $self->{load_path};
1254 local $self->{deny_save};
1255 local $self->{deny_reset};
1256 1625
1257 $self->SUPER::thawer_merge ($merge); 1626 $self->SUPER::thawer_merge ($merge);
1258} 1627}
1259 1628
1260sub normalise { 1629sub normalise {
1307 $self->init; # pass $1 etc. 1676 $self->init; # pass $1 etc.
1308 return $self; 1677 return $self;
1309 } 1678 }
1310 } 1679 }
1311 1680
1312 Carp::carp "unable to resolve path '$path' (base '$base')."; 1681 Carp::cluck "unable to resolve path '$path' (base '$base').";
1313 () 1682 ()
1314} 1683}
1315 1684
1316sub init { 1685sub init {
1317 my ($self) = @_; 1686 my ($self) = @_;
1332 1701
1333# the original (read-only) location 1702# the original (read-only) location
1334sub load_path { 1703sub load_path {
1335 my ($self) = @_; 1704 my ($self) = @_;
1336 1705
1337 sprintf "%s/%s/%s.map", cf::datadir, cf::mapdir, $self->{path} 1706 "$MAPDIR/$self->{path}.map"
1338} 1707}
1339 1708
1340# the temporary/swap location 1709# the temporary/swap location
1341sub save_path { 1710sub save_path {
1342 my ($self) = @_; 1711 my ($self) = @_;
1343 1712
1344 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1713 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1345 sprintf "%s/%s/%s.map", cf::localdir, cf::tmpdir, $path 1714 "$TMPDIR/$path.map"
1346} 1715}
1347 1716
1348# the unique path, undef == no special unique path 1717# the unique path, undef == no special unique path
1349sub uniq_path { 1718sub uniq_path {
1350 my ($self) = @_; 1719 my ($self) = @_;
1351 1720
1352 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1721 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1353 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $path 1722 "$UNIQUEDIR/$path"
1354} 1723}
1355 1724
1356# and all this just because we cannot iterate over 1725# and all this just because we cannot iterate over
1357# all maps in C++... 1726# all maps in C++...
1358sub change_all_map_light { 1727sub change_all_map_light {
1359 my ($change) = @_; 1728 my ($change) = @_;
1360 1729
1361 $_->change_map_light ($change) 1730 $_->change_map_light ($change)
1362 for grep $_->outdoor, values %cf::MAP; 1731 for grep $_->outdoor, values %cf::MAP;
1732}
1733
1734sub decay_objects {
1735 my ($self) = @_;
1736
1737 return if $self->{deny_reset};
1738
1739 $self->do_decay_objects;
1363} 1740}
1364 1741
1365sub unlink_save { 1742sub unlink_save {
1366 my ($self) = @_; 1743 my ($self) = @_;
1367 1744
1425 $self->load_header_orig 1802 $self->load_header_orig
1426 or return; 1803 or return;
1427 $self->prepare_orig; 1804 $self->prepare_orig;
1428 } 1805 }
1429 1806
1807 $self->{deny_reset} = 1
1808 if $self->no_reset;
1809
1430 $self->default_region (cf::region::find_by_path $self->{path}) 1810 $self->default_region (cf::region::find_by_path $self->{path})
1431 unless $self->default_region; 1811 unless $self->default_region;
1432 1812
1433 1 1813 1
1434} 1814}
1449 $map->{last_save} = $cf::RUNTIME; 1829 $map->{last_save} = $cf::RUNTIME;
1450 1830
1451 $map->load_header 1831 $map->load_header
1452 or return; 1832 or return;
1453 1833
1454 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?) 1834 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1455 # doing this can freeze the server in a sync job, obviously 1835 # doing this can freeze the server in a sync job, obviously
1456 #$cf::WAIT_FOR_TICK->wait; 1836 #$cf::WAIT_FOR_TICK->wait;
1457 $map->reset; 1837 $map->reset;
1458 undef $guard; 1838 undef $guard;
1459 return find $path; 1839 return find $path;
1470 my ($self) = @_; 1850 my ($self) = @_;
1471 1851
1472 local $self->{deny_reset} = 1; # loading can take a long time 1852 local $self->{deny_reset} = 1; # loading can take a long time
1473 1853
1474 my $path = $self->{path}; 1854 my $path = $self->{path};
1855
1856 {
1475 my $guard = cf::lock_acquire "map_load:$path"; 1857 my $guard = cf::lock_acquire "map_load:$path";
1476 1858
1477 return if $self->in_memory != cf::MAP_SWAPPED; 1859 return if $self->in_memory != cf::MAP_SWAPPED;
1478 1860
1479 $self->in_memory (cf::MAP_LOADING); 1861 $self->in_memory (cf::MAP_LOADING);
1480 1862
1481 $self->alloc; 1863 $self->alloc;
1482 1864
1483 $self->pre_load; 1865 $self->pre_load;
1484 Coro::cede;
1485
1486 $self->_load_objects ($self->{load_path}, 1)
1487 or return;
1488
1489 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1490 if delete $self->{load_original};
1491
1492 if (my $uniq = $self->uniq_path) {
1493 utf8::encode $uniq;
1494 if (aio_open $uniq, O_RDONLY, 0) {
1495 $self->clear_unique_items;
1496 $self->_load_objects ($uniq, 0);
1497 }
1498 }
1499
1500 Coro::cede;
1501 # now do the right thing for maps
1502 $self->link_multipart_objects;
1503 Coro::cede;
1504
1505 unless ($self->{deny_activate}) {
1506 $self->decay_objects;
1507 $self->fix_auto_apply;
1508 $self->update_buttons;
1509 Coro::cede; 1866 Coro::cede;
1510 $self->set_darkness_map; 1867
1868 $self->_load_objects ($self->{load_path}, 1)
1869 or return;
1870
1871 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1872 if delete $self->{load_original};
1873
1874 if (my $uniq = $self->uniq_path) {
1875 utf8::encode $uniq;
1876 if (aio_open $uniq, O_RDONLY, 0) {
1877 $self->clear_unique_items;
1878 $self->_load_objects ($uniq, 0);
1879 }
1880 }
1881
1882 Coro::cede;
1883 # now do the right thing for maps
1884 $self->link_multipart_objects;
1511 $self->difficulty ($self->estimate_difficulty) 1885 $self->difficulty ($self->estimate_difficulty)
1512 unless $self->difficulty; 1886 unless $self->difficulty;
1513 Coro::cede; 1887 Coro::cede;
1888
1889 unless ($self->{deny_activate}) {
1890 $self->decay_objects;
1891 $self->fix_auto_apply;
1892 $self->update_buttons;
1893 Coro::cede;
1894 $self->set_darkness_map;
1895 Coro::cede;
1514 $self->activate; 1896 $self->activate;
1515 Coro::cede; 1897 }
1898
1899 $self->{last_save} = $cf::RUNTIME;
1900 $self->last_access ($cf::RUNTIME);
1901
1902 $self->in_memory (cf::MAP_IN_MEMORY);
1516 } 1903 }
1517 1904
1518 $self->post_load; 1905 $self->post_load;
1519 Coro::cede;
1520
1521 $self->in_memory (cf::MAP_IN_MEMORY);
1522} 1906}
1523 1907
1524sub customise_for { 1908sub customise_for {
1525 my ($self, $ob) = @_; 1909 my ($self, $ob) = @_;
1526 1910
1527 return find "~" . $ob->name . "/" . $self->{path} 1911 return find "~" . $ob->name . "/" . $self->{path}
1528 if $self->per_player; 1912 if $self->per_player;
1529 1913
1914# return find "?party/" . $ob->name . "/" . $self->{path}
1915# if $self->per_party;
1916
1530 $self 1917 $self
1531} 1918}
1532 1919
1533# find and load all maps in the 3x3 area around a map 1920# find and load all maps in the 3x3 area around a map
1534sub load_diag { 1921sub load_neighbours {
1535 my ($map) = @_; 1922 my ($map) = @_;
1536 1923
1537 my @diag; # diagonal neighbours 1924 my @neigh; # diagonal neighbours
1538 1925
1539 for (0 .. 3) { 1926 for (0 .. 3) {
1540 my $neigh = $map->tile_path ($_) 1927 my $neigh = $map->tile_path ($_)
1541 or next; 1928 or next;
1542 $neigh = find $neigh, $map 1929 $neigh = find $neigh, $map
1543 or next; 1930 or next;
1544 $neigh->load; 1931 $neigh->load;
1545 1932
1933 push @neigh,
1546 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 1934 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1547 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 1935 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1548 } 1936 }
1549 1937
1550 for (@diag) { 1938 for (grep defined $_->[0], @neigh) {
1939 my ($path, $origin) = @$_;
1551 my $neigh = find @$_ 1940 my $neigh = find $path, $origin
1552 or next; 1941 or next;
1553 $neigh->load; 1942 $neigh->load;
1554 } 1943 }
1555} 1944}
1556 1945
1580 1969
1581 undef $MAP_PREFETCH{$path}; 1970 undef $MAP_PREFETCH{$path};
1582 $MAP_PREFETCHER ||= cf::async { 1971 $MAP_PREFETCHER ||= cf::async {
1583 while (%MAP_PREFETCH) { 1972 while (%MAP_PREFETCH) {
1584 for my $path (keys %MAP_PREFETCH) { 1973 for my $path (keys %MAP_PREFETCH) {
1585 my $map = find $path 1974 if (my $map = find $path) {
1586 or next;
1587 $map->load; 1975 $map->load;
1976 }
1588 1977
1589 delete $MAP_PREFETCH{$path}; 1978 delete $MAP_PREFETCH{$path};
1590 } 1979 }
1591 } 1980 }
1592 undef $MAP_PREFETCHER; 1981 undef $MAP_PREFETCHER;
1644 2033
1645sub reset_at { 2034sub reset_at {
1646 my ($self) = @_; 2035 my ($self) = @_;
1647 2036
1648 # TODO: safety, remove and allow resettable per-player maps 2037 # TODO: safety, remove and allow resettable per-player maps
1649 return 1e99 if $self->isa ("ext::map_per_player");#d#
1650 return 1e99 if $self->{deny_reset}; 2038 return 1e99 if $self->{deny_reset};
1651 2039
1652 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 2040 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1653 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 2041 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1654 2042
1665 my ($self) = @_; 2053 my ($self) = @_;
1666 2054
1667 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2055 my $lock = cf::lock_acquire "map_data:$self->{path}";
1668 2056
1669 return if $self->players; 2057 return if $self->players;
1670 return if $self->isa ("ext::map_per_player");#d#
1671 2058
1672 warn "resetting map ", $self->path;#d# 2059 warn "resetting map ", $self->path;
1673 2060
1674 $self->in_memory (cf::MAP_SWAPPED); 2061 $self->in_memory (cf::MAP_SWAPPED);
1675 2062
1676 # need to save uniques path 2063 # need to save uniques path
1677 unless ($self->{deny_save}) { 2064 unless ($self->{deny_save}) {
1709 $cf::MAP{$self->path} = $self; 2096 $cf::MAP{$self->path} = $self;
1710 2097
1711 $self->reset; # polite request, might not happen 2098 $self->reset; # polite request, might not happen
1712} 2099}
1713 2100
2101=item $maps = cf::map::tmp_maps
2102
2103Returns an arrayref with all map paths of currently instantiated and saved
2104maps. May block.
2105
2106=cut
2107
2108sub tmp_maps() {
2109 [
2110 map {
2111 utf8::decode $_;
2112 /\.map$/
2113 ? normalise $_
2114 : ()
2115 } @{ aio_readdir $TMPDIR or [] }
2116 ]
2117}
2118
2119=item $maps = cf::map::random_maps
2120
2121Returns an arrayref with all map paths of currently instantiated and saved
2122random maps. May block.
2123
2124=cut
2125
2126sub random_maps() {
2127 [
2128 map {
2129 utf8::decode $_;
2130 /\.map$/
2131 ? normalise "?random/$_"
2132 : ()
2133 } @{ aio_readdir $RANDOMDIR or [] }
2134 ]
2135}
2136
1714=item cf::map::unique_maps 2137=item cf::map::unique_maps
1715 2138
1716Returns an arrayref of paths of all shared maps that have 2139Returns an arrayref of paths of all shared maps that have
1717instantiated unique items. May block. 2140instantiated unique items. May block.
1718 2141
1719=cut 2142=cut
1720 2143
1721sub unique_maps() { 2144sub unique_maps() {
1722 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir 2145 [
1723 or return; 2146 map {
1724
1725 my @paths;
1726
1727 for (@$files) {
1728 utf8::decode $_; 2147 utf8::decode $_;
1729 next if /\.pst$/; 2148 /\.map$/
1730 next unless /^$PATH_SEP/o; 2149 ? normalise $_
1731 2150 : ()
1732 push @paths, cf::map::normalise $_; 2151 } @{ aio_readdir $UNIQUEDIR or [] }
1733 } 2152 ]
1734
1735 \@paths
1736} 2153}
1737 2154
1738package cf; 2155package cf;
1739 2156
1740=back 2157=back
1786 2203
1787 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2204 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1788 2205
1789 if ($self->{record_replies}) { 2206 if ($self->{record_replies}) {
1790 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2207 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2208
1791 } else { 2209 } else {
2210 my $pl = $self->contr;
2211
2212 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2213 my $dialog = $pl->{npc_dialog};
2214 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2215
2216 } else {
1792 $msg = $npc->name . " says: $msg" if $npc; 2217 $msg = $npc->name . " says: $msg" if $npc;
1793 $self->message ($msg, $flags); 2218 $self->message ($msg, $flags);
2219 }
1794 } 2220 }
2221}
2222
2223=item $object->send_msg ($channel, $msg, $color, [extra...])
2224
2225=cut
2226
2227sub cf::object::send_msg {
2228 my $pl = shift->contr
2229 or return;
2230 $pl->send_msg (@_);
1795} 2231}
1796 2232
1797=item $player_object->may ("access") 2233=item $player_object->may ("access")
1798 2234
1799Returns wether the given player is authorized to access resource "access" 2235Returns wether the given player is authorized to access resource "access"
1846 $self->deactivate_recursive; 2282 $self->deactivate_recursive;
1847 2283
1848 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2284 return if UNIVERSAL::isa $self->map, "ext::map_link";
1849 2285
1850 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2286 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1851 if $self->map; 2287 if $self->map && $self->map->{path} ne "{link}";
1852 2288
1853 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2289 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1854} 2290}
1855 2291
1856sub cf::object::player::leave_link { 2292sub cf::object::player::leave_link {
1857 my ($self, $map, $x, $y) = @_; 2293 my ($self, $map, $x, $y) = @_;
2294
2295 return unless $self->contr->active;
1858 2296
1859 my $link_pos = delete $self->{_link_pos}; 2297 my $link_pos = delete $self->{_link_pos};
1860 2298
1861 unless ($map) { 2299 unless ($map) {
1862 # restore original map position 2300 # restore original map position
1876 # use -1 or undef as default coordinates, not 0, 0 2314 # use -1 or undef as default coordinates, not 0, 0
1877 ($x, $y) = ($map->enter_x, $map->enter_y) 2315 ($x, $y) = ($map->enter_x, $map->enter_y)
1878 if $x <=0 && $y <= 0; 2316 if $x <=0 && $y <= 0;
1879 2317
1880 $map->load; 2318 $map->load;
1881 $map->load_diag; 2319 $map->load_neighbours;
1882 2320
1883 return unless $self->contr->active; 2321 return unless $self->contr->active;
1884 $self->activate_recursive; 2322 $self->activate_recursive;
1885 2323
1886 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2324 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1887 $self->enter_map ($map, $x, $y); 2325 $self->enter_map ($map, $x, $y);
1888} 2326}
1889 2327
1890cf::player->attach ( 2328=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
1891 on_logout => sub {
1892 my ($pl) = @_;
1893 2329
1894 # abort map switching before logout 2330Moves the player to the given map-path and coordinates by first freezing
1895 if ($pl->ob->{_link_pos}) { 2331her, loading and preparing them map, calling the provided $check callback
1896 cf::sync_job { 2332that has to return the map if sucecssful, and then unfreezes the player on
1897 $pl->ob->leave_link 2333the new (success) or old (failed) map position. In either case, $done will
1898 }; 2334be called at the end of this process.
1899 }
1900 },
1901 on_login => sub {
1902 my ($pl) = @_;
1903 2335
1904 # try to abort aborted map switching on player login :)
1905 # should happen only on crashes
1906 if ($pl->ob->{_link_pos}) {
1907 $pl->ob->enter_link;
1908 (async {
1909 $pl->ob->reply (undef,
1910 "There was an internal problem at your last logout, "
1911 . "the server will try to bring you to your intended destination in a second.",
1912 cf::NDI_RED);
1913 # we need this sleep as the login has a concurrent enter_exit running
1914 # and this sleep increases chances of the player not ending up in scorn
1915 Coro::Timer::sleep 1;
1916 $pl->ob->leave_link;
1917 })->prio (2);
1918 }
1919 },
1920);
1921
1922=item $player_object->goto ($path, $x, $y)
1923
1924=cut 2336=cut
2337
2338our $GOTOGEN;
1925 2339
1926sub cf::object::player::goto { 2340sub cf::object::player::goto {
1927 my ($self, $path, $x, $y) = @_; 2341 my ($self, $path, $x, $y, $check, $done) = @_;
2342
2343 # do generation counting so two concurrent goto's will be executed in-order
2344 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1928 2345
1929 $self->enter_link; 2346 $self->enter_link;
1930 2347
1931 (async { 2348 (async {
1932 my $map = eval { 2349 my $map = eval {
1933 my $map = cf::map::find $path; 2350 my $map = cf::map::find $path;
2351
2352 if ($map) {
1934 $map = $map->customise_for ($self) if $map; 2353 $map = $map->customise_for ($self);
2354 $map = $check->($map) if $check && $map;
2355 } else {
2356 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
2357 }
2358
1935 $map 2359 $map
2360 };
2361
2362 if ($@) {
2363 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2364 LOG llevError | logBacktrace, Carp::longmess $@;
1936 } or 2365 }
1937 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1938 2366
2367 if ($gen == $self->{_goto_generation}) {
2368 delete $self->{_goto_generation};
1939 $self->leave_link ($map, $x, $y); 2369 $self->leave_link ($map, $x, $y);
2370 }
2371
2372 $done->() if $done;
1940 })->prio (1); 2373 })->prio (1);
1941} 2374}
1942 2375
1943=item $player_object->enter_exit ($exit_object) 2376=item $player_object->enter_exit ($exit_object)
1944 2377
1983 2416
1984 $rmp->{random_seed} ||= $exit->random_seed; 2417 $rmp->{random_seed} ||= $exit->random_seed;
1985 2418
1986 my $data = cf::to_json $rmp; 2419 my $data = cf::to_json $rmp;
1987 my $md5 = Digest::MD5::md5_hex $data; 2420 my $md5 = Digest::MD5::md5_hex $data;
1988 my $meta = "$cf::RANDOM_MAPS/$md5.meta"; 2421 my $meta = "$RANDOMDIR/$md5.meta";
1989 2422
1990 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2423 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1991 aio_write $fh, 0, (length $data), $data, 0; 2424 aio_write $fh, 0, (length $data), $data, 0;
1992 undef $fh; 2425 undef $fh;
1993 aio_rename "$meta~", $meta; 2426 aio_rename "$meta~", $meta;
2012 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path; 2445 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2013 my $hp = $exit->stats->hp; 2446 my $hp = $exit->stats->hp;
2014 my $sp = $exit->stats->sp; 2447 my $sp = $exit->stats->sp;
2015 2448
2016 $self->enter_link; 2449 $self->enter_link;
2450
2451 # if exit is damned, update players death & WoR home-position
2452 $self->contr->savebed ($slaying, $hp, $sp)
2453 if $exit->flag (FLAG_DAMNED);
2017 2454
2018 (async { 2455 (async {
2019 $self->deactivate_recursive; # just to be sure 2456 $self->deactivate_recursive; # just to be sure
2020 unless (eval { 2457 unless (eval {
2021 $self->goto ($slaying, $hp, $sp); 2458 $self->goto ($slaying, $hp, $sp);
2049 2486
2050 utf8::encode $text; 2487 utf8::encode $text;
2051 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2488 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2052} 2489}
2053 2490
2491=item $client->send_msg ($channel, $msg, $color, [extra...])
2492
2493Send a drawinfo or msg packet to the client, formatting the msg for the
2494client if neccessary. C<$type> should be a string identifying the type of
2495the message, with C<log> being the default. If C<$color> is negative, suppress
2496the message unless the client supports the msg packet.
2497
2498=cut
2499
2500sub cf::client::send_msg {
2501 my ($self, $channel, $msg, $color, @extra) = @_;
2502
2503 $msg = $self->pl->expand_cfpod ($msg);
2504
2505 $color &= cf::NDI_CLIENT_MASK; # just in case...
2506
2507 if (ref $channel) {
2508 # send meta info to client, if not yet sent
2509 unless (exists $self->{channel}{$channel->{id}}) {
2510 $self->{channel}{$channel->{id}} = $channel;
2511 $self->ext_msg (channel_info => $channel);
2512 }
2513
2514 $channel = $channel->{id};
2515 }
2516
2517 return unless @extra || length $msg;
2518
2519 if ($self->can_msg) {
2520 # default colour, mask it out
2521 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2522 if $color & cf::NDI_DEF;
2523
2524 $self->send_packet ("msg " . $self->{json_coder}->encode (
2525 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2526 } else {
2527 if ($color >= 0) {
2528 # replace some tags by gcfclient-compatible ones
2529 for ($msg) {
2530 1 while
2531 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2532 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2533 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2534 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2535 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2536 }
2537
2538 $color &= cf::NDI_COLOR_MASK;
2539
2540 utf8::encode $msg;
2541
2542 if (0 && $msg =~ /\[/) {
2543 # COMMAND/INFO
2544 $self->send_packet ("drawextinfo $color 10 8 $msg")
2545 } else {
2546 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2547 $self->send_packet ("drawinfo $color $msg")
2548 }
2549 }
2550 }
2551}
2552
2054=item $client->ext_event ($type, %msg) 2553=item $client->ext_msg ($type, @msg)
2055 2554
2056Sends an exti event to the client. 2555Sends an ext event to the client.
2057 2556
2058=cut 2557=cut
2059 2558
2060sub cf::client::ext_event($$%) { 2559sub cf::client::ext_msg($$@) {
2061 my ($self, $type, %msg) = @_; 2560 my ($self, $type, @msg) = @_;
2062 2561
2562 my $extcmd = $self->extcmd;
2563
2564 if ($extcmd == 2) {
2565 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2566 } elsif ($extcmd == 1) { # TODO: remove
2063 $msg{msgtype} = "event_$type"; 2567 push @msg, msgtype => "event_$type";
2064 $self->send_packet ("ext " . cf::to_json \%msg); 2568 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2569 }
2065} 2570}
2066 2571
2067=item $success = $client->query ($flags, "text", \&cb) 2572=item $success = $client->query ($flags, "text", \&cb)
2068 2573
2069Queues a query to the client, calling the given callback with 2574Queues a query to the client, calling the given callback with
2070the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2575the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
2071C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 2576C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2072 2577
2073Queries can fail, so check the return code. Or don't, as queries will become 2578Queries can fail, so check the return code. Or don't, as queries will
2074reliable at some point in the future. 2579become reliable at some point in the future.
2075 2580
2076=cut 2581=cut
2077 2582
2078sub cf::client::query { 2583sub cf::client::query {
2079 my ($self, $flags, $text, $cb) = @_; 2584 my ($self, $flags, $text, $cb) = @_;
2087 utf8::encode $text; 2592 utf8::encode $text;
2088 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2593 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2089 2594
2090 $self->send_packet ($self->{query_queue}[0][0]) 2595 $self->send_packet ($self->{query_queue}[0][0])
2091 if @{ $self->{query_queue} } == 1; 2596 if @{ $self->{query_queue} } == 1;
2597
2598 1
2092} 2599}
2093 2600
2094cf::client->attach ( 2601cf::client->attach (
2602 on_connect => sub {
2603 my ($ns) = @_;
2604
2605 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2606 },
2095 on_reply => sub { 2607 on_reply => sub {
2096 my ($ns, $msg) = @_; 2608 my ($ns, $msg) = @_;
2097 2609
2098 # this weird shuffling is so that direct followup queries 2610 # this weird shuffling is so that direct followup queries
2099 # get handled first 2611 # get handled first
2111 } else { 2623 } else {
2112 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 2624 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2113 } 2625 }
2114 } 2626 }
2115 }, 2627 },
2628 on_exticmd => sub {
2629 my ($ns, $buf) = @_;
2630
2631 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2632
2633 if (ref $msg) {
2634 my ($type, $reply, @payload) =
2635 "ARRAY" eq ref $msg
2636 ? @$msg
2637 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
2638
2639 if (my $cb = $EXTICMD{$type}) {
2640 my @reply = $cb->($ns, @payload);
2641
2642 $ns->ext_reply ($reply, @reply)
2643 if $reply;
2644 }
2645 } else {
2646 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2647 }
2648
2649 cf::override;
2650 },
2116); 2651);
2117 2652
2118=item $client->async (\&cb) 2653=item $client->async (\&cb)
2119 2654
2120Create a new coroutine, running the specified callback. The coroutine will 2655Create a new coroutine, running the specified callback. The coroutine will
2161our $safe = new Safe "safe"; 2696our $safe = new Safe "safe";
2162our $safe_hole = new Safe::Hole; 2697our $safe_hole = new Safe::Hole;
2163 2698
2164$SIG{FPE} = 'IGNORE'; 2699$SIG{FPE} = 'IGNORE';
2165 2700
2166$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 2701$safe->permit_only (Opcode::opset qw(
2702 :base_core :base_mem :base_orig :base_math
2703 grepstart grepwhile mapstart mapwhile
2704 sort time
2705));
2167 2706
2168# here we export the classes and methods available to script code 2707# here we export the classes and methods available to script code
2169 2708
2170=pod 2709=pod
2171 2710
2172The following functions and methods are available within a safe environment: 2711The following functions and methods are available within a safe environment:
2173 2712
2174 cf::object contr pay_amount pay_player map 2713 cf::object
2714 contr pay_amount pay_player map x y force_find force_add
2715 insert remove name archname title slaying race
2716
2175 cf::object::player player 2717 cf::object::player
2176 cf::player peaceful 2718 player
2177 cf::map trigger 2719
2720 cf::player
2721 peaceful
2722
2723 cf::map
2724 trigger
2178 2725
2179=cut 2726=cut
2180 2727
2181for ( 2728for (
2182 ["cf::object" => qw(contr pay_amount pay_player map)], 2729 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2730 insert remove inv name archname title slaying race)],
2183 ["cf::object::player" => qw(player)], 2731 ["cf::object::player" => qw(player)],
2184 ["cf::player" => qw(peaceful)], 2732 ["cf::player" => qw(peaceful)],
2185 ["cf::map" => qw(trigger)], 2733 ["cf::map" => qw(trigger)],
2186) { 2734) {
2187 no strict 'refs'; 2735 no strict 'refs';
2258=back 2806=back
2259 2807
2260=cut 2808=cut
2261 2809
2262############################################################################# 2810#############################################################################
2263
2264=head2 EXTENSION DATABASE SUPPORT
2265
2266Crossfire maintains a very simple database for extension use. It can
2267currently store anything that can be serialised using Storable, which
2268excludes objects.
2269
2270The parameter C<$family> should best start with the name of the extension
2271using it, it should be unique.
2272
2273=over 4
2274
2275=item $value = cf::db_get $family => $key
2276
2277Returns a single value from the database.
2278
2279=item cf::db_put $family => $key => $value
2280
2281Stores the given C<$value> in the family.
2282
2283=cut
2284
2285our $DB;
2286
2287sub db_init {
2288 unless ($DB) {
2289 $DB = BDB::db_create $DB_ENV;
2290
2291 cf::sync_job {
2292 eval {
2293 $DB->set_flags (BDB::CHKSUM);
2294
2295 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2296 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2297 cf::cleanup "db_open(db): $!" if $!;
2298 };
2299 cf::cleanup "db_open(db): $@" if $@;
2300 };
2301
2302 my $path = cf::localdir . "/database.pst";
2303 if (stat $path) {
2304 cf::sync_job {
2305 my $pst = Storable::retrieve $path;
2306
2307 cf::db_put (board => data => $pst->{board});
2308 cf::db_put (guildrules => data => $pst->{guildrules});
2309 cf::db_put (rent => balance => $pst->{rent}{balance});
2310 BDB::db_env_txn_checkpoint $DB_ENV;
2311
2312 unlink $path;
2313 };
2314 }
2315 }
2316}
2317
2318sub db_get($$) {
2319 my $key = "$_[0]/$_[1]";
2320
2321 cf::sync_job {
2322 BDB::db_get $DB, undef, $key, my $data;
2323
2324 $! ? ()
2325 : Compress::LZF::sthaw $data
2326 }
2327}
2328
2329sub db_put($$$) {
2330 BDB::dbreq_pri 4;
2331 BDB::db_put $DB, undef, "$_[0]/$_[1]", Compress::LZF::sfreeze_cr $_[2], 0, sub { };
2332}
2333
2334#############################################################################
2335# the server's init and main functions 2811# the server's init and main functions
2336 2812
2337sub load_facedata { 2813sub load_facedata($) {
2338 my $path = sprintf "%s/facedata", cf::datadir; 2814 my ($path) = @_;
2339 2815
2340 warn "loading facedata from $path\n"; 2816 warn "loading facedata from $path\n";
2341 2817
2342 my $facedata; 2818 my $facedata;
2343 0 < aio_load $path, $facedata 2819 0 < aio_load $path, $facedata
2351 { 2827 {
2352 my $faces = $facedata->{faceinfo}; 2828 my $faces = $facedata->{faceinfo};
2353 2829
2354 while (my ($face, $info) = each %$faces) { 2830 while (my ($face, $info) = each %$faces) {
2355 my $idx = (cf::face::find $face) || cf::face::alloc $face; 2831 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2356 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 2832 cf::face::set_visibility $idx, $info->{visibility};
2833 cf::face::set_magicmap $idx, $info->{magicmap};
2357 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 2834 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2358 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 2835 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2359 Coro::cede; 2836
2837 cf::cede_to_tick;
2360 } 2838 }
2361 2839
2362 while (my ($face, $info) = each %$faces) { 2840 while (my ($face, $info) = each %$faces) {
2363 next unless $info->{smooth}; 2841 next unless $info->{smooth};
2364 my $idx = cf::face::find $face 2842 my $idx = cf::face::find $face
2365 or next; 2843 or next;
2366 if (my $smooth = cf::face::find $info->{smooth}) { 2844 if (my $smooth = cf::face::find $info->{smooth}) {
2845 cf::face::set_smooth $idx, $smooth;
2367 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel}; 2846 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2368 } else { 2847 } else {
2369 warn "smooth face '$info->{smooth}' not found for face '$face'"; 2848 warn "smooth face '$info->{smooth}' not found for face '$face'";
2370 } 2849 }
2371 Coro::cede; 2850
2851 cf::cede_to_tick;
2372 } 2852 }
2373 } 2853 }
2374 2854
2375 { 2855 {
2376 my $anims = $facedata->{animinfo}; 2856 my $anims = $facedata->{animinfo};
2377 2857
2378 while (my ($anim, $info) = each %$anims) { 2858 while (my ($anim, $info) = each %$anims) {
2379 cf::anim::set $anim, $info->{frames}, $info->{facings}; 2859 cf::anim::set $anim, $info->{frames}, $info->{facings};
2380 Coro::cede; 2860 cf::cede_to_tick;
2381 } 2861 }
2382 2862
2383 cf::anim::invalidate_all; # d'oh 2863 cf::anim::invalidate_all; # d'oh
2384 } 2864 }
2385 2865
2866 {
2867 # TODO: for gcfclient pleasure, we should give resources
2868 # that gcfclient doesn't grok a >10000 face index.
2869 my $res = $facedata->{resource};
2870 my $enc = JSON::XS->new->utf8->canonical;
2871
2872 my $soundconf = delete $res->{"res/sound.conf"};
2873
2874 while (my ($name, $info) = each %$res) {
2875 my $meta = $enc->encode ({
2876 name => $name,
2877 %{ $info->{meta} || {} },
2878 });
2879
2880 my $idx = (cf::face::find $name) || cf::face::alloc $name;
2881
2882 if ($info->{type} & 1) {
2883 # prepend meta info
2884
2885 my $data = pack "(w/a*)*", $meta, $info->{data};
2886 my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
2887
2888 cf::face::set_data $idx, 0, $data, $chk;
2889 } else {
2890 cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};
2891 }
2892
2893 cf::face::set_type $idx, $info->{type};
2894
2895 cf::cede_to_tick;
2896 }
2897
2898 if ($soundconf) {
2899 $soundconf = $enc->decode (delete $soundconf->{data});
2900
2901 for (0 .. SOUND_CAST_SPELL_0 - 1) {
2902 my $sound = $soundconf->{compat}[$_]
2903 or next;
2904
2905 my $face = cf::face::find "sound/$sound->[1]";
2906 cf::sound::set $sound->[0] => $face;
2907 cf::sound::old_sound_index $_, $face; # gcfclient-compat
2908 }
2909
2910 while (my ($k, $v) = each %{$soundconf->{event}}) {
2911 my $face = cf::face::find "sound/$v";
2912 cf::sound::set $k => $face;
2913 }
2914 }
2915 }
2916
2386 1 2917 1
2387} 2918}
2388 2919
2389our $archetypes_loaded; 2920register_exticmd fx_want => sub {
2921 my ($ns, $want) = @_;
2390 2922
2923 while (my ($k, $v) = each %$want) {
2924 $ns->fx_want ($k, $v);
2925 }
2926};
2927
2928sub reload_regions {
2929 load_resource_file "$MAPDIR/regions"
2930 or die "unable to load regions file\n";
2931
2932 for (cf::region::list) {
2933 $_->{match} = qr/$_->{match}/
2934 if exists $_->{match};
2935 }
2936}
2937
2938sub reload_facedata {
2939 load_facedata "$DATADIR/facedata"
2940 or die "unable to load facedata\n";
2941}
2942
2391sub load_archetypes { 2943sub reload_archetypes {
2392 return 1 if $archetypes_loaded++; # current can only load them once 2944 load_resource_file "$DATADIR/archetypes"
2393 load_archetype_file sprintf "%s/archetypes", cf::datadir; # remove when stable 2945 or die "unable to load archetypes\n";
2394 load_archetype_file sprintf "%s/archetypes", cf::datadir 2946 #d# NEED to laod twice to resolve forward references
2947 # this really needs to be done in an extra post-pass
2948 # (which needs to be synchronous, so solve it differently)
2949 load_resource_file "$DATADIR/archetypes"
2950 or die "unable to load archetypes\n";
2395} 2951}
2396 2952
2397sub load_treasures { 2953sub reload_treasures {
2398 load_treasure_file sprintf "%s/treasures", cf::datadir 2954 load_resource_file "$DATADIR/treasures"
2955 or die "unable to load treasurelists\n";
2399} 2956}
2400 2957
2401sub reload_resources { 2958sub reload_resources {
2402 load_resource_file sprintf "%s/%s/regions", cf::datadir, cf::mapdir 2959 warn "reloading resource files...\n";
2403 or die "unable to load regions file\n"; 2960
2961 reload_regions;
2404 load_facedata 2962 reload_facedata;
2405 or die "unable to load facedata\n"; 2963 #reload_archetypes;#d#
2406 load_archetypes 2964 reload_archetypes;
2407 or die "unable to load archetypes\n";
2408 load_treasures 2965 reload_treasures;
2409 or die "unable to load treasurelists\n"; 2966
2967 warn "finished reloading resource files\n";
2410} 2968}
2411 2969
2412sub init { 2970sub init {
2413 reload_resources; 2971 reload_resources;
2414} 2972}
2415 2973
2416sub cfg_load { 2974sub cfg_load {
2417 open my $fh, "<:utf8", cf::confdir . "/config" 2975 open my $fh, "<:utf8", "$CONFDIR/config"
2418 or return; 2976 or return;
2419 2977
2420 local $/; 2978 local $/;
2421 *CFG = YAML::Syck::Load <$fh>; 2979 *CFG = YAML::Syck::Load <$fh>;
2422 2980
2467 }, 3025 },
2468 ); 3026 );
2469 } 3027 }
2470} 3028}
2471 3029
3030sub write_runtime {
3031 my $runtime = "$LOCALDIR/runtime";
3032
3033 # first touch the runtime file to show we are still running:
3034 # the fsync below can take a very very long time.
3035
3036 IO::AIO::aio_utime $runtime, undef, undef;
3037
3038 my $guard = cf::lock_acquire "write_runtime";
3039
3040 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
3041 or return;
3042
3043 my $value = $cf::RUNTIME + 90 + 10;
3044 # 10 is the runtime save interval, for a monotonic clock
3045 # 60 allows for the watchdog to kill the server.
3046
3047 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3048 and return;
3049
3050 # always fsync - this file is important
3051 aio_fsync $fh
3052 and return;
3053
3054 # touch it again to show we are up-to-date
3055 aio_utime $fh, undef, undef;
3056
3057 close $fh
3058 or return;
3059
3060 aio_rename "$runtime~", $runtime
3061 and return;
3062
3063 warn "runtime file written.\n";
3064
3065 1
3066}
3067
2472sub emergency_save() { 3068sub emergency_save() {
2473 my $freeze_guard = cf::freeze_mainloop; 3069 my $freeze_guard = cf::freeze_mainloop;
2474 3070
2475 warn "enter emergency perl save\n"; 3071 warn "enter emergency perl save\n";
2476 3072
2507 3103
2508 warn Carp::longmess "post_cleanup backtrace" 3104 warn Carp::longmess "post_cleanup backtrace"
2509 if $make_core; 3105 if $make_core;
2510} 3106}
2511 3107
2512sub reload() { 3108sub do_reload_perl() {
2513 # can/must only be called in main 3109 # can/must only be called in main
2514 if ($Coro::current != $Coro::main) { 3110 if ($Coro::current != $Coro::main) {
2515 warn "can only reload from main coroutine"; 3111 warn "can only reload from main coroutine";
2516 return; 3112 return;
2517 } 3113 }
2551 %EXT_CORO = (); 3147 %EXT_CORO = ();
2552 3148
2553 warn "removing commands"; 3149 warn "removing commands";
2554 %COMMAND = (); 3150 %COMMAND = ();
2555 3151
2556 warn "removing ext commands"; 3152 warn "removing ext/exti commands";
2557 %EXTCMD = (); 3153 %EXTCMD = ();
3154 %EXTICMD = ();
2558 3155
2559 warn "unloading/nuking all extensions"; 3156 warn "unloading/nuking all extensions";
2560 for my $pkg (@EXTS) { 3157 for my $pkg (@EXTS) {
2561 warn "... unloading $pkg"; 3158 warn "... unloading $pkg";
2562 3159
2592 Symbol::delete_package "safe::$_" 3189 Symbol::delete_package "safe::$_"
2593 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3190 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2594 3191
2595 warn "unloading cf.pm \"a bit\""; 3192 warn "unloading cf.pm \"a bit\"";
2596 delete $INC{"cf.pm"}; 3193 delete $INC{"cf.pm"};
3194 delete $INC{"cf/pod.pm"};
2597 3195
2598 # don't, removes xs symbols, too, 3196 # don't, removes xs symbols, too,
2599 # and global variables created in xs 3197 # and global variables created in xs
2600 #Symbol::delete_package __PACKAGE__; 3198 #Symbol::delete_package __PACKAGE__;
2601 3199
2616 warn "reattaching attachments to maps"; 3214 warn "reattaching attachments to maps";
2617 reattach $_ for values %MAP; 3215 reattach $_ for values %MAP;
2618 warn "reattaching attachments to players"; 3216 warn "reattaching attachments to players";
2619 reattach $_ for values %PLAYER; 3217 reattach $_ for values %PLAYER;
2620 3218
2621 warn "loading reloadable resources";
2622 reload_resources;
2623
2624 warn "leaving sync_job"; 3219 warn "leaving sync_job";
2625 3220
2626 1 3221 1
2627 } or do { 3222 } or do {
2628 warn $@; 3223 warn $@;
2633 warn "reloaded"; 3228 warn "reloaded";
2634}; 3229};
2635 3230
2636our $RELOAD_WATCHER; # used only during reload 3231our $RELOAD_WATCHER; # used only during reload
2637 3232
3233sub reload_perl() {
3234 # doing reload synchronously and two reloads happen back-to-back,
3235 # coro crashes during coro_state_free->destroy here.
3236
3237 $RELOAD_WATCHER ||= Event->timer (
3238 reentrant => 0,
3239 after => 0,
3240 data => WF_AUTOCANCEL,
3241 cb => sub {
3242 do_reload_perl;
3243 undef $RELOAD_WATCHER;
3244 },
3245 );
3246}
3247
2638register_command "reload" => sub { 3248register_command "reload" => sub {
2639 my ($who, $arg) = @_; 3249 my ($who, $arg) = @_;
2640 3250
2641 if ($who->flag (FLAG_WIZ)) { 3251 if ($who->flag (FLAG_WIZ)) {
2642 $who->message ("reloading server."); 3252 $who->message ("reloading server.");
2643 3253 async { reload_perl };
2644 # doing reload synchronously and two reloads happen back-to-back,
2645 # coro crashes during coro_state_free->destroy here.
2646
2647 $RELOAD_WATCHER ||= Event->timer (
2648 reentrant => 0,
2649 after => 0,
2650 data => WF_AUTOCANCEL,
2651 cb => sub {
2652 reload;
2653 undef $RELOAD_WATCHER;
2654 },
2655 );
2656 } 3254 }
2657}; 3255};
2658 3256
2659unshift @INC, $LIBDIR; 3257unshift @INC, $LIBDIR;
2660 3258
2679 my $signal = new Coro::Signal; 3277 my $signal = new Coro::Signal;
2680 push @WAIT_FOR_TICK_BEGIN, $signal; 3278 push @WAIT_FOR_TICK_BEGIN, $signal;
2681 $signal->wait; 3279 $signal->wait;
2682} 3280}
2683 3281
3282 my $min = 1e6;#d#
3283 my $avg = 10;
2684$TICK_WATCHER = Event->timer ( 3284$TICK_WATCHER = Event->timer (
2685 reentrant => 0, 3285 reentrant => 0,
2686 parked => 1, 3286 parked => 1,
2687 prio => 0, 3287 prio => 0,
2688 at => $NEXT_TICK || $TICK, 3288 at => $NEXT_TICK || $TICK,
2692 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3292 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2693 unless ++$bug_warning > 10; 3293 unless ++$bug_warning > 10;
2694 return; 3294 return;
2695 } 3295 }
2696 3296
2697 $NOW = Event::time; 3297 $NOW = $tick_start = Event::time;
2698 3298
2699 cf::server_tick; # one server iteration 3299 cf::server_tick; # one server iteration
3300
3301 0 && sync_job {#d#
3302 for(1..10) {
3303 my $t = Event::time;
3304 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3305 or die;
3306
3307 $map->width (50);
3308 $map->height (50);
3309 $map->alloc;
3310 $map->_load_objects ("/tmp/x.map", 1);
3311 my $t = Event::time - $t;
3312
3313 #next unless $t < 0.0013;#d#
3314 if ($t < $min) {
3315 $min = $t;
3316 }
3317 $avg = $avg * 0.99 + $t * 0.01;
3318 }
3319 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3320 exit 0;
3321 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3322 };
3323
2700 $RUNTIME += $TICK; 3324 $RUNTIME += $TICK;
2701 $NEXT_TICK += $TICK; 3325 $NEXT_TICK += $TICK;
2702 3326
2703 if ($NOW >= $NEXT_RUNTIME_WRITE) { 3327 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2704 $NEXT_RUNTIME_WRITE = $NOW + 10; 3328 $NEXT_RUNTIME_WRITE = $NOW + 10;
2706 write_runtime 3330 write_runtime
2707 or warn "ERROR: unable to write runtime file: $!"; 3331 or warn "ERROR: unable to write runtime file: $!";
2708 }; 3332 };
2709 } 3333 }
2710 3334
3335# my $AFTER = Event::time;
3336# warn $AFTER - $NOW;#d#
3337
2711 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3338 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
2712 $sig->send; 3339 $sig->send;
2713 } 3340 }
2714 while (my $sig = shift @WAIT_FOR_TICK) { 3341 while (my $sig = shift @WAIT_FOR_TICK) {
2715 $sig->send; 3342 $sig->send;
2716 } 3343 }
2717 3344
2718# my $AFTER = Event::time; 3345 $NOW = Event::time;
2719# warn $AFTER - $NOW;#d#
2720 3346
2721 # if we are delayed by four ticks or more, skip them all 3347 # if we are delayed by four ticks or more, skip them all
2722 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 3348 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2723 3349
2724 $TICK_WATCHER->at ($NEXT_TICK); 3350 $TICK_WATCHER->at ($NEXT_TICK);
2725 $TICK_WATCHER->start; 3351 $TICK_WATCHER->start;
3352
3353 $LOAD = ($NOW - $tick_start) / $TICK;
3354 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3355
3356 _post_tick;
3357
3358
2726 }, 3359 },
2727); 3360);
2728 3361
2729{ 3362{
2730 BDB::max_poll_time $TICK * 0.1; 3363 BDB::max_poll_time $TICK * 0.1;
2758 3391
2759 cf::sync_job { 3392 cf::sync_job {
2760 eval { 3393 eval {
2761 BDB::db_env_open 3394 BDB::db_env_open
2762 $DB_ENV, 3395 $DB_ENV,
2763 $BDB_ENV_DIR, 3396 $BDBDIR,
2764 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3397 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2765 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3398 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2766 0666; 3399 0666;
2767 3400
2768 cf::cleanup "db_env_open($BDB_ENV_DIR): $!" if $!; 3401 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2769 3402
2770 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1); 3403 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2771 $DB_ENV->set_lk_detect; 3404 $DB_ENV->set_lk_detect;
2772 }; 3405 };
2773 3406
2789 prio => 6, 3422 prio => 6,
2790 cb => \&IO::AIO::poll_cb, 3423 cb => \&IO::AIO::poll_cb,
2791 ); 3424 );
2792} 3425}
2793 3426
3427my $_log_backtrace;
3428
3429sub _log_backtrace {
3430 my ($msg, @addr) = @_;
3431
3432 $msg =~ s/\n//;
3433
3434 # limit the # of concurrent backtraces
3435 if ($_log_backtrace < 2) {
3436 ++$_log_backtrace;
3437 async {
3438 my @bt = fork_call {
3439 @addr = map { sprintf "%x", $_ } @addr;
3440 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3441 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3442 or die "addr2line: $!";
3443
3444 my @funcs;
3445 my @res = <$fh>;
3446 chomp for @res;
3447 while (@res) {
3448 my ($func, $line) = splice @res, 0, 2, ();
3449 push @funcs, "[$func] $line";
3450 }
3451
3452 @funcs
3453 };
3454
3455 LOG llevInfo, "[ABT] $msg\n";
3456 LOG llevInfo, "[ABT] $_\n" for @bt;
3457 --$_log_backtrace;
3458 };
3459 } else {
3460 LOG llevInfo, "[ABT] $msg\n";
3461 LOG llevInfo, "[ABT] [suppressed]\n";
3462 }
3463}
3464
3465# load additional modules
3466use cf::pod;
3467
2794END { cf::emergency_save } 3468END { cf::emergency_save }
2795 3469
27961 34701
2797 3471

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines