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.44 by root, Sat Aug 26 08:44:06 2006 UTC vs.
Revision 1.335 by root, Mon Aug 20 22:21:48 2007 UTC

1package cf; 1package cf;
2
3use utf8;
4use strict;
2 5
3use Symbol; 6use Symbol;
4use List::Util; 7use List::Util;
8use Socket;
5use Storable; 9use Storable;
10use Event;
6use Opcode; 11use Opcode;
7use Safe; 12use Safe;
8use Safe::Hole; 13use Safe::Hole;
9 14
15use Coro 3.64 ();
16use Coro::State;
17use Coro::Handle;
18use Coro::Event;
19use Coro::Timer;
20use Coro::Signal;
21use Coro::Semaphore;
22use Coro::AIO;
23use Coro::Storable;
24use Coro::Util ();
25
26use JSON::XS 1.4 ();
27use BDB ();
28use Data::Dumper;
29use Digest::MD5;
30use Fcntl;
31use YAML::Syck ();
32use IO::AIO 2.32 ();
10use Time::HiRes; 33use Time::HiRes;
11use Event; 34use Compress::LZF;
35use Digest::MD5 ();
36
37# configure various modules to our taste
38#
39$Storable::canonical = 1; # reduce rsync transfers
40Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
41Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
42
12$Event::Eval = 1; # no idea why this is required, but it is 43$Event::Eval = 1; # no idea why this is required, but it is
13 44
14use strict; 45# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
46$YAML::Syck::ImplicitUnicode = 1;
15 47
48$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
49
50sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
51
16our %COMMAND = (); 52our %COMMAND = ();
53our %COMMAND_TIME = ();
54
55our @EXTS = (); # list of extension package names
56our %EXTCMD = ();
57our %EXTICMD = ();
58our %EXT_CORO = (); # coroutines bound to extensions
59our %EXT_MAP = (); # pluggable maps
60
61our $RELOAD; # number of reloads so far
17our @EVENT; 62our @EVENT;
18our @PLUGIN_EVENT;
19our %PROP_TYPE;
20our %PROP_IDX;
21our $LIBDIR = maps_directory "perl";
22 63
23our $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(!)
24our $TICK_WATCHER; 77our $TICK_WATCHER;
78our $AIO_POLL_WATCHER;
79our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
25our $NEXT_TICK; 80our $NEXT_TICK;
81our $NOW;
82our $USE_FSYNC = 1; # use fsync to write maps - default off
83
84our $BDB_POLL_WATCHER;
85our $DB_ENV;
86
87our %CFG;
88
89our $UPTIME; $UPTIME ||= time;
90our $RUNTIME;
91
92our %PLAYER; # all users
93our %MAP; # all maps
94our $LINK_MAP; # the special {link} map, which is always available
95
96# used to convert map paths into valid unix filenames by replacing / by ∕
97our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
98
99our $LOAD; # a number between 0 (idle) and 1 (too many objects)
100our $LOADAVG; # same thing, but with alpha-smoothing
101our $tick_start; # for load detecting purposes
102
103binmode STDOUT;
104binmode STDERR;
105
106# read virtual server time, if available
107unless ($RUNTIME || !-e "$LOCALDIR/runtime") {
108 open my $fh, "<", "$LOCALDIR/runtime"
109 or die "unable to read runtime file: $!";
110 $RUNTIME = <$fh> + 0.;
111}
112
113mkdir $_
114 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
115
116our $EMERGENCY_POSITION;
117
118sub cf::map::normalise;
119
120#############################################################################
121
122=head2 GLOBAL VARIABLES
123
124=over 4
125
126=item $cf::UPTIME
127
128The timestamp of the server start (so not actually an uptime).
129
130=item $cf::RUNTIME
131
132The time this server has run, starts at 0 and is increased by $cf::TICK on
133every server tick.
134
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
138
139Various directories - "/etc", read-only install directory, perl-library
140directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
141unique-items directory, player file directory, random maps directory and
142database environment.
143
144=item $cf::NOW
145
146The time of the last (current) server tick.
147
148=item $cf::TICK
149
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.
161
162=item %cf::CFG
163
164Configuration for the server, loaded from C</etc/crossfire/config>, or
165from wherever your confdir points to.
166
167=item cf::wait_for_tick, cf::wait_for_tick_begin
168
169These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
170returns directly I<after> the tick processing (and consequently, can only wake one process
171per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
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
179=back
180
181=cut
26 182
27BEGIN { 183BEGIN {
28 @PLUGIN_EVENT = map lc, @PLUGIN_EVENT;
29
30 *CORE::GLOBAL::warn = sub { 184 *CORE::GLOBAL::warn = sub {
31 my $msg = join "", @_; 185 my $msg = join "", @_;
186
32 $msg .= "\n" 187 $msg .= "\n"
33 unless $msg =~ /\n$/; 188 unless $msg =~ /\n$/;
34 189
35 print STDERR "cfperl: $msg"; 190 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
191
192 utf8::encode $msg;
36 LOG llevError, "cfperl: $msg"; 193 LOG llevError, $msg;
37 }; 194 };
38} 195}
39 196
40my %ignore_set = (MAP_PROP_PATH => 1); # I hate the plug-in api. Deeply! 197@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
41 198@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
42# generate property mutators 199@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
43sub prop_gen { 200@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
44 my ($prefix, $class) = @_; 201@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
45 202@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
46 no strict 'refs';
47
48 for my $prop (keys %PROP_TYPE) {
49 $prop =~ /^\Q$prefix\E_(.*$)/ or next;
50 my $sub = lc $1;
51
52 my $type = $PROP_TYPE{$prop};
53 my $idx = $PROP_IDX {$prop};
54
55 *{"$class\::get_$sub"} = *{"$class\::$sub"} = sub {
56 $_[0]->get_property ($type, $idx)
57 };
58
59 *{"$class\::set_$sub"} = sub {
60 $_[0]->set_property ($type, $idx, $_[1]);
61 } unless $ignore_set{$prop};
62 }
63}
64
65# auto-generate most of the API
66
67prop_gen OBJECT_PROP => "cf::object";
68# CFAPI_OBJECT_ANIMATION?
69prop_gen PLAYER_PROP => "cf::object::player";
70
71prop_gen MAP_PROP => "cf::map";
72prop_gen ARCH_PROP => "cf::arch";
73
74# guessed hierarchies
75
76@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)
77@safe::cf::object::map::ISA = @cf::object::map::ISA = 'cf::object';
78 204
79# 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
80# within the Safe compartment. 206# within the Safe compartment.
81for my $pkg (qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region cf::arch)) { 207for my $pkg (qw(
208 cf::global cf::attachable
209 cf::object cf::object::player
210 cf::client cf::player
211 cf::arch cf::living
212 cf::map cf::party cf::region
213)) {
82 no strict 'refs'; 214 no strict 'refs';
83 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 215 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
84} 216}
85 217
86$Event::DIED = sub { 218$Event::DIED = sub {
87 warn "error in event callback: @_"; 219 warn "error in event callback: @_";
88}; 220};
89 221
90my %ext_pkg;
91my @exts;
92my @hook;
93my %command;
94my %extcmd;
95
96############################################################################# 222#############################################################################
97# object support
98 223
99sub reattach { 224=head2 UTILITY FUNCTIONS
100 warn "reattach<@_>\n";
101}
102 225
103sub instantiate { 226=over 4
104 warn "instantiate<@_>\n";
105}
106 227
107sub clone { 228=item dumpval $ref
108 warn "clone<@_>\n"; 229
230=cut
231
232sub dumpval {
233 eval {
234 local $SIG{__DIE__};
235 my $d;
236 if (1) {
237 $d = new Data::Dumper([$_[0]], ["*var"]);
238 $d->Terse(1);
239 $d->Indent(2);
240 $d->Quotekeys(0);
241 $d->Useqq(1);
242 #$d->Bless(...);
243 $d->Seen($_[1]) if @_ > 1;
244 $d = $d->Dump();
245 }
246 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
247 $d
248 } || "[unable to dump $_[0]: '$@']";
109} 249}
250
251=item $ref = cf::from_json $json
252
253Converts a JSON string into the corresponding perl data structure.
254
255=item $json = cf::to_json $ref
256
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]) }
265
266=item cf::lock_wait $string
267
268Wait until the given lock is available. See cf::lock_acquire.
269
270=item my $lock = cf::lock_acquire $string
271
272Wait until the given lock is available and then acquires it and returns
273a Coro::guard object. If the guard object gets destroyed (goes out of scope,
274for example when the coroutine gets canceled), the lock is automatically
275returned.
276
277Lock names should begin with a unique identifier (for example, cf::map::find
278uses map_find and cf::map::load uses map_load).
279
280=item $locked = cf::lock_active $string
281
282Return true if the lock is currently active, i.e. somebody has locked it.
283
284=cut
285
286our %LOCK;
287
288sub lock_wait($) {
289 my ($key) = @_;
290
291 # wait for lock, if any
292 while ($LOCK{$key}) {
293 push @{ $LOCK{$key} }, $Coro::current;
294 Coro::schedule;
295 }
296}
297
298sub lock_acquire($) {
299 my ($key) = @_;
300
301 # wait, to be sure we are not locked
302 lock_wait $key;
303
304 $LOCK{$key} = [];
305
306 Coro::guard {
307 # wake up all waiters, to be on the safe side
308 $_->ready for @{ delete $LOCK{$key} };
309 }
310}
311
312sub lock_active($) {
313 my ($key) = @_;
314
315 ! ! $LOCK{$key}
316}
317
318sub freeze_mainloop {
319 return unless $TICK_WATCHER->is_active;
320
321 my $guard = Coro::guard {
322 $TICK_WATCHER->start;
323 };
324 $TICK_WATCHER->stop;
325 $guard
326}
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
384=item cf::async { BLOCK }
385
386Currently the same as Coro::async_pool, meaning you cannot use
387C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
388thing you are allowed to do is call C<prio> on it.
389
390=cut
391
392BEGIN { *async = \&Coro::async_pool }
393
394=item cf::sync_job { BLOCK }
395
396The design of Crossfire TRT requires that the main coroutine ($Coro::main)
397is always able to handle events or runnable, as Crossfire TRT is only
398partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
399acceptable.
400
401If it must be done, put the blocking parts into C<sync_job>. This will run
402the given BLOCK in another coroutine while waiting for the result. The
403server will be frozen during this time, so the block should either finish
404fast or be very important.
405
406=cut
407
408sub sync_job(&) {
409 my ($job) = @_;
410
411 if ($Coro::current == $Coro::main) {
412 my $time = Event::time;
413
414 # this is the main coro, too bad, we have to block
415 # till the operation succeeds, freezing the server :/
416
417 # TODO: use suspend/resume instead
418 # (but this is cancel-safe)
419 my $freeze_guard = freeze_mainloop;
420
421 my $busy = 1;
422 my @res;
423
424 (async {
425 @res = eval { $job->() };
426 warn $@ if $@;
427 undef $busy;
428 })->prio (Coro::PRIO_MAX);
429
430 while ($busy) {
431 Coro::cede or Event::one_event;
432 }
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
441 wantarray ? @res : $res[0]
442 } else {
443 # we are in another coroutine, how wonderful, everything just works
444
445 $job->()
446 }
447}
448
449=item $coro = cf::async_ext { BLOCK }
450
451Like async, but this coro is automatically being canceled when the
452extension calling this is being unloaded.
453
454=cut
455
456sub async_ext(&) {
457 my $cb = shift;
458
459 my $coro = &Coro::async ($cb);
460
461 $coro->on_destroy (sub {
462 delete $EXT_CORO{$coro+0};
463 });
464 $EXT_CORO{$coro+0} = $coro;
465
466 $coro
467}
468
469=item fork_call { }, $args
470
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.
475
476=cut
477
478sub fork_call(&@) {
479 my ($cb, @args) = @_;
480
481 # we seemingly have to make a local copy of the whole thing,
482 # otherwise perl prematurely frees the stuff :/
483 # TODO: investigate and fix (liekly this will be rather laborious)
484
485 my @res = Coro::Util::fork_eval {
486 reset_signals;
487 &$cb
488 }, @args;
489
490 wantarray ? @res : $res[-1]
491}
492
493=item $value = cf::db_get $family => $key
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 };
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"
607}
608
609=item cf::datalog type => key => value, ...
610
611Log a datalog packet of the given type with the given key-value pairs.
612
613=cut
614
615sub datalog($@) {
616 my ($type, %kv) = @_;
617 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
618}
619
620=back
621
622=cut
110 623
111############################################################################# 624#############################################################################
112# "new" plug-in system
113 625
114=item cf::object::attach ... # NYI 626=head2 ATTACHABLE OBJECTS
115 627
116=item cf::attach_global ... 628Many objects in crossfire are so-called attachable objects. That means you can
629attach callbacks/event handlers (a collection of which is called an "attachment")
630to it. All such attachable objects support the following methods.
117 631
118=item cf::attach_to_type ... 632In the following description, CLASS can be any of C<global>, C<object>
633C<player>, C<client> or C<map> (i.e. the attachable objects in
634Crossfire TRT).
119 635
120=item cf::attach_to_objects ... 636=over 4
121 637
122=item cf::attach_to_players ... 638=item $attachable->attach ($attachment, key => $value...)
123 639
124=item cf::attach_to_maps ... 640=item $attachable->detach ($attachment)
125 641
126 prio => $number, # lower is earlier 642Attach/detach a pre-registered attachment to a specific object and give it
127 on_xxx => \&cb, 643the specified key/value pairs as arguments.
644
645Example, attach a minesweeper attachment to the given object, making it a
64610x10 minesweeper game:
647
648 $obj->attach (minesweeper => width => 10, height => 10);
649
650=item $bool = $attachable->attached ($name)
651
652Checks wether the named attachment is currently attached to the object.
653
654=item cf::CLASS->attach ...
655
656=item cf::CLASS->detach ...
657
658Define an anonymous attachment and attach it to all objects of the given
659CLASS. See the next function for an explanation of its arguments.
660
661You can attach to global events by using the C<cf::global> class.
662
663Example, log all player logins:
664
665 cf::player->attach (
666 on_login => sub {
667 my ($pl) = @_;
668 ...
669 },
670 );
671
672Example, attach to the jeweler skill:
673
674 cf::object->attach (
675 type => cf::SKILL,
676 subtype => cf::SK_JEWELER,
677 on_use_skill => sub {
678 my ($sk, $ob, $part, $dir, $msg) = @_;
679 ...
680 },
681 );
682
683=item cf::CLASS::attachment $name, ...
684
685Register an attachment by C<$name> through which attachable objects of the
686given CLASS can refer to this attachment.
687
688Some classes such as crossfire maps and objects can specify attachments
689that are attached at load/instantiate time, thus the need for a name.
690
691These calls expect any number of the following handler/hook descriptions:
692
693=over 4
694
695=item prio => $number
696
697Set the priority for all following handlers/hooks (unless overwritten
698by another C<prio> setting). Lower priority handlers get executed
699earlier. The default priority is C<0>, and many built-in handlers are
700registered at priority C<-1000>, so lower priorities should not be used
701unless you know what you are doing.
702
703=item type => $type
704
705(Only for C<< cf::object->attach >> calls), limits the attachment to the
706given type of objects only (the additional parameter C<subtype> can be
707used to further limit to the given subtype).
708
709=item on_I<event> => \&cb
710
711Call the given code reference whenever the named event happens (event is
712something like C<instantiate>, C<apply>, C<use_skill> and so on, and which
713handlers are recognised generally depends on the type of object these
714handlers attach to).
715
716See F<include/eventinc.h> for the full list of events supported, and their
717class.
718
128 package => package::, 719=item package => package::
720
721Look for sub functions of the name C<< on_I<event> >> in the given
722package and register them. Only handlers for eevents supported by the
723object/class are recognised.
724
725=back
726
727Example, define an attachment called "sockpuppet" that calls the given
728event handler when a monster attacks:
729
730 cf::object::attachment sockpuppet =>
731 on_skill_attack => sub {
732 my ($self, $victim) = @_;
733 ...
734 }
735 }
736
737=item $attachable->valid
738
739Just because you have a perl object does not mean that the corresponding
740C-level object still exists. If you try to access an object that has no
741valid C counterpart anymore you get an exception at runtime. This method
742can be used to test for existence of the C object part without causing an
743exception.
129 744
130=cut 745=cut
131 746
132# the following variables are defined in .xs and must not be re-created 747# the following variables are defined in .xs and must not be re-created
133our @CB_GLOBAL = (); # registry for all global events 748our @CB_GLOBAL = (); # registry for all global events
134our @CB_OBJECT = (); 749our @CB_ATTACHABLE = (); # registry for all attachables
750our @CB_OBJECT = (); # all objects (should not be used except in emergency)
135our @CB_PLAYER = (); 751our @CB_PLAYER = ();
752our @CB_CLIENT = ();
136our @CB_TYPE = (); # registry for type (cf-object class) based events 753our @CB_TYPE = (); # registry for type (cf-object class) based events
137our @CB_MAP = (); 754our @CB_MAP = ();
138 755
756my %attachment;
757
758sub cf::attachable::thawer_merge {
759 # simply override everything except _meta
760 local $_[0]{_meta};
761 %{$_[0]} = %{$_[1]};
762}
763
139sub _attach_cb($\%$$$) { 764sub _attach_cb($$$$) {
140 my ($registry, $undo, $event, $prio, $cb) = @_; 765 my ($registry, $event, $prio, $cb) = @_;
141 766
142 use sort 'stable'; 767 use sort 'stable';
143 768
144 $cb = [$prio, $cb]; 769 $cb = [$prio, $cb];
145 770
146 @{$registry->[$event]} = sort 771 @{$registry->[$event]} = sort
147 { $a->[0] cmp $b->[0] } 772 { $a->[0] cmp $b->[0] }
148 @{$registry->[$event] || []}, $cb; 773 @{$registry->[$event] || []}, $cb;
149
150 push @{$undo->{cb}}, [$event, $cb];
151} 774}
775
776# hack
777my %attachable_klass = map +($_ => 1), KLASS_OBJECT, KLASS_CLIENT, KLASS_PLAYER, KLASS_MAP;
152 778
153# attach handles attaching event callbacks 779# attach handles attaching event callbacks
154# the only thing the caller has to do is pass the correct 780# the only thing the caller has to do is pass the correct
155# registry (== where the callback attaches to). 781# registry (== where the callback attaches to).
156sub _attach(\@$\@) { 782sub _attach {
157 my ($registry, $klass, $arg) = @_; 783 my ($registry, $klass, @arg) = @_;
158 784
785 my $object_type;
159 my $prio = 0; 786 my $prio = 0;
160
161 my %undo = (
162 registry => $registry,
163 cb => [],
164 );
165
166 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT; 787 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;
167 788
789 #TODO: get rid of this hack
790 if ($attachable_klass{$klass}) {
791 %cb_id = (%cb_id, map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == KLASS_ATTACHABLE, 0 .. $#EVENT);
792 }
793
168 while (@$arg) { 794 while (@arg) {
169 my $type = shift @$arg; 795 my $type = shift @arg;
170 796
171 if ($type eq "prio") { 797 if ($type eq "prio") {
172 $prio = shift @$arg; 798 $prio = shift @arg;
799
800 } elsif ($type eq "type") {
801 $object_type = shift @arg;
802 $registry = $CB_TYPE[$object_type] ||= [];
803
804 } elsif ($type eq "subtype") {
805 defined $object_type or Carp::croak "subtype specified without type";
806 my $object_subtype = shift @arg;
807 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
173 808
174 } elsif ($type eq "package") { 809 } elsif ($type eq "package") {
175 my $pkg = shift @$arg; 810 my $pkg = shift @arg;
176 811
177 while (my ($name, $id) = each %cb_id) { 812 while (my ($name, $id) = each %cb_id) {
178 if (my $cb = $pkg->can ($name)) { 813 if (my $cb = $pkg->can ($name)) {
179 _attach_cb $registry, %undo, $id, $prio, $cb; 814 _attach_cb $registry, $id, $prio, $cb;
180 } 815 }
181 } 816 }
182 817
183 } elsif (exists $cb_id{$type}) { 818 } elsif (exists $cb_id{$type}) {
184 _attach_cb $registry, %undo, $cb_id{$type}, $prio, shift @$arg; 819 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
185 820
186 } elsif (ref $type) { 821 } elsif (ref $type) {
187 warn "attaching objects not supported, ignoring.\n"; 822 warn "attaching objects not supported, ignoring.\n";
188 823
189 } else { 824 } else {
190 shift @$arg; 825 shift @arg;
191 warn "attach argument '$type' not supported, ignoring.\n"; 826 warn "attach argument '$type' not supported, ignoring.\n";
192 } 827 }
193 } 828 }
194
195 \%undo
196} 829}
197 830
198sub cf::object::attach { 831sub _object_attach {
199 die; 832 my ($obj, $name, %arg) = @_;
200}
201 833
202sub attach_global { 834 return if exists $obj->{_attachment}{$name};
203 _attach @CB_GLOBAL, KLASS_GLOBAL, @_
204}
205 835
206sub attach_to_type { 836 if (my $attach = $attachment{$name}) {
207 my $type = shift; 837 my $registry = $obj->registry;
208 _attach @{$CB_TYPE[$type]}, KLASS_OBJECT, @_
209}
210 838
211sub attach_to_objects { 839 for (@$attach) {
212 _attach @CB_OBJECT, KLASS_OBJECT, @_ 840 my ($klass, @attach) = @$_;
213} 841 _attach $registry, $klass, @attach;
842 }
214 843
215sub attach_to_players { 844 $obj->{$name} = \%arg;
216 _attach @CB_PLAYER, KLASS_PLAYER, @_ 845 } else {
217} 846 warn "object uses attachment '$name' which is not available, postponing.\n";
847 }
218 848
219sub attach_to_maps { 849 $obj->{_attachment}{$name} = undef;
220 _attach @CB_MAP, KLASS_MAP, @_ 850}
851
852sub cf::attachable::attach {
853 if (ref $_[0]) {
854 _object_attach @_;
855 } else {
856 _attach shift->_attach_registry, @_;
857 }
858 _recalc_want;
859};
860
861# all those should be optimised
862sub cf::attachable::detach {
863 my ($obj, $name) = @_;
864
865 if (ref $obj) {
866 delete $obj->{_attachment}{$name};
867 reattach ($obj);
868 } else {
869 Carp::croak "cannot, currently, detach class attachments";
870 }
871 _recalc_want;
872};
873
874sub cf::attachable::attached {
875 my ($obj, $name) = @_;
876
877 exists $obj->{_attachment}{$name}
878}
879
880for my $klass (qw(ATTACHABLE GLOBAL OBJECT PLAYER CLIENT MAP)) {
881 eval "#line " . __LINE__ . " 'cf.pm'
882 sub cf::\L$klass\E::_attach_registry {
883 (\\\@CB_$klass, KLASS_$klass)
884 }
885
886 sub cf::\L$klass\E::attachment {
887 my \$name = shift;
888
889 \$attachment{\$name} = [[KLASS_$klass, \@_]];
890 }
891 ";
892 die if $@;
221} 893}
222 894
223our $override; 895our $override;
896our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
224 897
225sub override() { 898sub override {
226 $override = 1 899 $override = 1;
900 @INVOKE_RESULTS = (@_);
227} 901}
228 902
229sub invoke { 903sub do_invoke {
230 my $event = shift; 904 my $event = shift;
231 my $callbacks = shift; 905 my $callbacks = shift;
232 906
907 @INVOKE_RESULTS = ();
908
233 local $override; 909 local $override;
234 910
235 for (@$callbacks) { 911 for (@$callbacks) {
236 eval { &{$_->[1]} }; 912 eval { &{$_->[1]} };
237 913
238 if ($@) { 914 if ($@) {
239 warn "$@"; 915 warn "$@";
240 warn "... while processing $EVENT[$event][0] event, skipping processing altogether.\n"; 916 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
241 override; 917 override;
242 } 918 }
243 919
244 return 1 if $override; 920 return 1 if $override;
245 } 921 }
246 922
247 0 923 0
248} 924}
249 925
926=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...)
927
928=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
929
930Generate an object-specific event with the given arguments.
931
932This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
933removed in future versions), and there is no public API to access override
934results (if you must, access C<@cf::INVOKE_RESULTS> directly).
935
936=back
937
938=cut
939
250############################################################################# 940#############################################################################
251# old plug-in events 941# object support
942#
252 943
253sub inject_event { 944sub _can_merge {
254 my $extension = shift; 945 my ($ob1, $ob2) = @_;
255 my $event_code = shift;
256 946
257 my $cb = $hook[$event_code]{$extension} 947 local $Storable::canonical = 1;
948 my $fob1 = Storable::freeze $ob1;
949 my $fob2 = Storable::freeze $ob2;
950
951 $fob1 eq $fob2
952}
953
954sub reattach {
955 # basically do the same as instantiate, without calling instantiate
956 my ($obj) = @_;
957
958 bless $obj, ref $obj; # re-bless in case extensions have been reloaded
959
960 my $registry = $obj->registry;
961
962 @$registry = ();
963
964 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
965
966 for my $name (keys %{ $obj->{_attachment} || {} }) {
967 if (my $attach = $attachment{$name}) {
968 for (@$attach) {
969 my ($klass, @attach) = @$_;
970 _attach $registry, $klass, @attach;
971 }
972 } else {
973 warn "object uses attachment '$name' that is not available, postponing.\n";
974 }
975 }
976}
977
978cf::attachable->attach (
979 prio => -1000000,
980 on_instantiate => sub {
981 my ($obj, $data) = @_;
982
983 $data = from_json $data;
984
985 for (@$data) {
986 my ($name, $args) = @$_;
987
988 $obj->attach ($name, %{$args || {} });
989 }
990 },
991 on_reattach => \&reattach,
992 on_clone => sub {
993 my ($src, $dst) = @_;
994
995 @{$dst->registry} = @{$src->registry};
996
997 %$dst = %$src;
998
999 %{$dst->{_attachment}} = %{$src->{_attachment}}
1000 if exists $src->{_attachment};
1001 },
1002);
1003
1004sub object_freezer_save {
1005 my ($filename, $rdata, $objs) = @_;
1006
1007 sync_job {
1008 if (length $$rdata) {
1009 warn sprintf "saving %s (%d,%d)\n",
1010 $filename, length $$rdata, scalar @$objs;
1011
1012 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1013 chmod SAVE_MODE, $fh;
1014 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1015 aio_fsync $fh if $cf::USE_FSYNC;
1016 close $fh;
1017
1018 if (@$objs) {
1019 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1020 chmod SAVE_MODE, $fh;
1021 my $data = Storable::nfreeze { version => 1, objs => $objs };
1022 aio_write $fh, 0, (length $data), $data, 0;
1023 aio_fsync $fh if $cf::USE_FSYNC;
1024 close $fh;
1025 aio_rename "$filename.pst~", "$filename.pst";
1026 }
1027 } else {
1028 aio_unlink "$filename.pst";
1029 }
1030
1031 aio_rename "$filename~", $filename;
1032 } else {
1033 warn "FATAL: $filename~: $!\n";
1034 }
1035 } else {
1036 aio_unlink $filename;
1037 aio_unlink "$filename.pst";
1038 }
1039 }
1040}
1041
1042sub object_freezer_as_string {
1043 my ($rdata, $objs) = @_;
1044
1045 use Data::Dumper;
1046
1047 $$rdata . Dumper $objs
1048}
1049
1050sub object_thawer_load {
1051 my ($filename) = @_;
1052
1053 my ($data, $av);
1054
1055 (aio_load $filename, $data) >= 0
258 or return; 1056 or return;
259 1057
260 &$cb 1058 unless (aio_stat "$filename.pst") {
261} 1059 (aio_load "$filename.pst", $av) >= 0
262
263sub inject_global_event {
264 my $event = shift;
265
266 my $cb = $hook[$event]
267 or return; 1060 or return;
268 1061 $av = eval { (Storable::thaw $av)->{objs} };
269 List::Util::max map &$_, values %$cb
270}
271
272sub inject_command {
273 my ($name, $obj, $params) = @_;
274
275 for my $cmd (@{ $command{$name} }) {
276 $cmd->[1]->($obj, $params);
277 } 1062 }
278 1063
279 -1 1064 warn sprintf "loading %s (%d)\n",
1065 $filename, length $data, scalar @{$av || []};
1066 return ($data, $av);
280} 1067}
1068
1069=head2 COMMAND CALLBACKS
1070
1071=over 4
1072
1073=cut
1074
1075#############################################################################
1076# command handling &c
1077
1078=item cf::register_command $name => \&callback($ob,$args);
1079
1080Register a callback for execution when the client sends the user command
1081$name.
1082
1083=cut
281 1084
282sub register_command { 1085sub register_command {
283 my ($name, $time, $cb) = @_; 1086 my ($name, $cb) = @_;
284 1087
285 my $caller = caller; 1088 my $caller = caller;
286 #warn "registering command '$name/$time' to '$caller'"; 1089 #warn "registering command '$name/$time' to '$caller'";
287 1090
288 push @{ $command{$name} }, [$time, $cb, $caller]; 1091 push @{ $COMMAND{$name} }, [$caller, $cb];
289 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
290} 1092}
1093
1094=item cf::register_extcmd $name => \&callback($pl,$packet);
1095
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.
1101
1102If the callback returns something, it is sent back as if reply was being
1103called.
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
1116=cut
291 1117
292sub register_extcmd { 1118sub register_extcmd {
293 my ($name, $cb) = @_; 1119 my ($name, $cb) = @_;
294 1120
295 my $caller = caller; 1121 $EXTCMD{$name} = $cb;
296 #warn "registering extcmd '$name' to '$caller'";
297
298 $extcmd{$name} = [$cb, $caller];
299} 1122}
300 1123
301sub register { 1124sub register_exticmd {
302 my ($base, $pkg) = @_; 1125 my ($name, $cb) = @_;
303 1126
304 for my $idx (0 .. $#PLUGIN_EVENT) { 1127 $EXTICMD{$name} = $cb;
305 if (my $ref = $pkg->can ("on_$PLUGIN_EVENT[$idx]")) {
306 #warn "registering $PLUGIN_EVENT[$idx] hook to '$pkg'\n";
307 $hook[$idx]{$base} = $ref;
308 }
309 }
310} 1128}
311 1129
312sub load_extension { 1130cf::player->attach (
313 my ($path) = @_; 1131 on_command => sub {
1132 my ($pl, $name, $params) = @_;
314 1133
315 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 1134 my $cb = $COMMAND{$name}
316 my $base = $1; 1135 or return;
317 my $pkg = $1;
318 $pkg =~ s/[^[:word:]]/_/g;
319 $pkg = "ext::$pkg";
320 1136
321 warn "loading '$path' into '$pkg'\n"; 1137 for my $cmd (@$cb) {
322 1138 $cmd->[1]->($pl->ob, $params);
323 open my $fh, "<:utf8", $path
324 or die "$path: $!";
325
326 my $source =
327 "package $pkg; use strict; use utf8;\n"
328 . "#line 1 \"$path\"\n{\n"
329 . (do { local $/; <$fh> })
330 . "\n};\n1";
331
332 eval $source
333 or die "$path: $@";
334
335 push @exts, $pkg;
336 $ext_pkg{$base} = $pkg;
337
338# no strict 'refs';
339# @{"$pkg\::ISA"} = ext::;
340
341 register $base, $pkg;
342}
343
344sub unload_extension {
345 my ($pkg) = @_;
346
347 warn "removing extension $pkg\n";
348
349 # remove hooks
350 for my $idx (0 .. $#PLUGIN_EVENT) {
351 delete $hook[$idx]{$pkg};
352 }
353
354 # remove commands
355 for my $name (keys %command) {
356 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} };
357
358 if (@cb) {
359 $command{$name} = \@cb;
360 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
361 } else {
362 delete $command{$name};
363 delete $COMMAND{"$name\000"};
364 }
365 }
366
367 # remove extcmds
368 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) {
369 delete $extcmd{$name};
370 }
371
372 if (my $cb = $pkg->can ("unload")) {
373 eval {
374 $cb->($pkg);
375 1
376 } or warn "$pkg unloaded, but with errors: $@";
377 }
378
379 Symbol::delete_package $pkg;
380}
381
382sub load_extensions {
383 my $LIBDIR = maps_directory "perl";
384
385 for my $ext (<$LIBDIR/*.ext>) {
386 next unless -r $ext;
387 eval {
388 load_extension $ext;
389 1
390 } or warn "$ext not loaded: $@";
391 }
392}
393
394sub _perl_reload(&) {
395 my ($msg) = @_;
396
397 $msg->("reloading...");
398
399 eval {
400 # 1. cancel all watchers
401 $_->cancel for Event::all_watchers;
402
403 # 2. unload all extensions
404 for (@exts) {
405 $msg->("unloading <$_>");
406 unload_extension $_;
407 }
408
409 # 3. unload all modules loaded from $LIBDIR
410 while (my ($k, $v) = each %INC) {
411 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
412
413 $msg->("removing <$k>");
414 delete $INC{$k};
415
416 $k =~ s/\.pm$//;
417 $k =~ s/\//::/g;
418
419 if (my $cb = $k->can ("unload_module")) {
420 $cb->();
421 }
422
423 Symbol::delete_package $k;
424 }
425
426 # 4. get rid of safe::, as good as possible
427 Symbol::delete_package "safe::$_"
428 for qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region);
429
430 # 5. remove register_script_function callbacks
431 # TODO
432
433 # 6. unload cf.pm "a bit"
434 delete $INC{"cf.pm"};
435
436 # don't, removes xs symbols, too,
437 # and global variables created in xs
438 #Symbol::delete_package __PACKAGE__;
439
440 # 7. reload cf.pm
441 $msg->("reloading cf.pm");
442 require cf;
443 };
444 $msg->($@) if $@;
445
446 $msg->("reloaded");
447};
448
449sub perl_reload() {
450 _perl_reload {
451 warn $_[0];
452 print "$_[0]\n";
453 };
454}
455
456register_command "perl-reload", 0, sub {
457 my ($who, $arg) = @_;
458
459 if ($who->flag (FLAG_WIZ)) {
460 _perl_reload {
461 warn $_[0];
462 $who->message ($_[0]);
463 }; 1139 }
1140
1141 cf::override;
464 } 1142 },
465};
466
467#############################################################################
468# utility functions
469
470use JSON::Syck (); # TODO# replace by JSON::PC once working
471
472sub from_json($) {
473 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
474 JSON::Syck::Load $_[0]
475}
476
477sub to_json($) {
478 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
479 JSON::Syck::Dump $_[0]
480}
481
482#############################################################################
483# extcmd framework, basically convert ext <msg>
484# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
485
486attach_to_players
487 on_extcmd => sub { 1143 on_extcmd => sub {
488 my ($pl, $buf) = @_; 1144 my ($pl, $buf) = @_;
489 1145
490 my $msg = eval { from_json $buf }; 1146 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
491 1147
492 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
493 if (my $cb = $extcmd{$msg->{msgtype}}) { 1154 if (my $cb = $EXTCMD{$type}) {
494 if (my %reply = $cb->[0]->($pl, $msg)) { 1155 my @reply = $cb->($pl, @payload);
1156
495 $pl->ext_reply ($msg->{msgid}, %reply); 1157 $pl->ext_reply ($reply, @reply)
496 } 1158 if $reply;
497 } 1159 }
498 } else { 1160 } else {
499 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1161 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
500 } 1162 }
501 1163
502 cf::override; 1164 cf::override;
503 }, 1165 },
504; 1166);
1167
1168sub load_extensions {
1169 cf::sync_job {
1170 my %todo;
1171
1172 for my $path (<$LIBDIR/*.ext>) {
1173 next unless -r $path;
1174
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;
1232 }
1233
1234 skip:
1235 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1236 unless $progress;
1237 }
1238 };
1239}
505 1240
506############################################################################# 1241#############################################################################
507# load/save/clean perl data associated with a map
508 1242
509*cf::mapsupport::on_clean = sub { 1243=back
1244
1245=head2 CORE EXTENSIONS
1246
1247Functions and methods that extend core crossfire objects.
1248
1249=cut
1250
1251package cf::player;
1252
1253use Coro::AIO;
1254
1255=head3 cf::player
1256
1257=over 4
1258
1259=item cf::player::find $login
1260
1261Returns the given player object, loading it if necessary (might block).
1262
1263=cut
1264
1265sub playerdir($) {
1266 "$PLAYERDIR/"
1267 . (ref $_[0] ? $_[0]->ob->name : $_[0])
1268}
1269
1270sub path($) {
1271 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
1272
1273 (playerdir $login) . "/playerdata"
1274}
1275
1276sub find_active($) {
1277 $cf::PLAYER{$_[0]}
1278 and $cf::PLAYER{$_[0]}->active
1279 and $cf::PLAYER{$_[0]}
1280}
1281
1282sub exists($) {
1283 my ($login) = @_;
1284
1285 $cf::PLAYER{$login}
1286 or cf::sync_job { !aio_stat path $login }
1287}
1288
1289sub find($) {
1290 return $cf::PLAYER{$_[0]} || do {
1291 my $login = $_[0];
1292
1293 my $guard = cf::lock_acquire "user_find:$login";
1294
1295 $cf::PLAYER{$_[0]} || do {
1296 # rename old playerfiles to new ones
1297 #TODO: remove when no longer required
1298 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1299 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1300 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1301 aio_unlink +(playerdir $login) . "/$login.pl";
1302
1303 my $pl = load_pl path $login
1304 or return;
1305 $cf::PLAYER{$login} = $pl
1306 }
1307 }
1308}
1309
1310sub save($) {
1311 my ($pl) = @_;
1312
1313 return if $pl->{deny_save};
1314
1315 my $path = path $pl;
1316 my $guard = cf::lock_acquire "user_save:$path";
1317
1318 return if $pl->{deny_save};
1319
1320 aio_mkdir playerdir $pl, 0770;
1321 $pl->{last_save} = $cf::RUNTIME;
1322
1323 $pl->save_pl ($path);
1324 Coro::cede;
1325}
1326
1327sub new($) {
1328 my ($login) = @_;
1329
1330 my $self = create;
1331
1332 $self->ob->name ($login);
1333 $self->{deny_save} = 1;
1334
1335 $cf::PLAYER{$login} = $self;
1336
1337 $self
1338}
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
1350=item $pl->quit_character
1351
1352Nukes the player without looking back. If logged in, the connection will
1353be destroyed. May block for a long time.
1354
1355=cut
1356
1357sub quit_character {
1358 my ($pl) = @_;
1359
1360 my $name = $pl->ob->name;
1361
1362 $pl->{deny_save} = 1;
1363 $pl->password ("*"); # this should lock out the player until we nuked the dir
1364
1365 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1366 $pl->deactivate;
1367 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1368 $pl->ns->destroy if $pl->ns;
1369
1370 my $path = playerdir $pl;
1371 my $temp = "$path~$cf::RUNTIME~deleting~";
1372 aio_rename $path, $temp;
1373 delete $cf::PLAYER{$pl->ob->name};
1374 $pl->destroy;
1375
1376 my $prefix = qr<^~\Q$name\E/>;
1377
1378 # nuke player maps
1379 $cf::MAP{$_}->nuke for grep /$prefix/, keys %cf::MAP;
1380
1381 IO::AIO::aio_rmtree $temp;
1382}
1383
1384=item $pl->kick
1385
1386Kicks a player out of the game. This destroys the connection.
1387
1388=cut
1389
1390sub kick {
1391 my ($pl, $kicker) = @_;
1392
1393 $pl->invoke (cf::EVENT_PLAYER_KICK, $kicker);
1394 $pl->killer ("kicked");
1395 $pl->ns->destroy;
1396}
1397
1398=item cf::player::list_logins
1399
1400Returns am arrayref of all valid playernames in the system, can take a
1401while and may block, so not sync_job-capable, ever.
1402
1403=cut
1404
1405sub list_logins {
1406 my $dirs = aio_readdir $PLAYERDIR
1407 or return [];
1408
1409 my @logins;
1410
1411 for my $login (@$dirs) {
1412 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;
1413 aio_read $fh, 0, 512, my $buf, 0 or next;
1414 $buf !~ /^password -------------$/m or next; # official not-valid tag
1415
1416 utf8::decode $login;
1417 push @logins, $login;
1418 }
1419
1420 \@logins
1421}
1422
1423=item $player->maps
1424
1425Returns an arrayref of map paths that are private for this
1426player. May block.
1427
1428=cut
1429
1430sub maps($) {
1431 my ($pl) = @_;
1432
1433 $pl = ref $pl ? $pl->ob->name : $pl;
1434
1435 my $files = aio_readdir playerdir $pl
1436 or return;
1437
1438 my @paths;
1439
1440 for (@$files) {
1441 utf8::decode $_;
1442 next if /\.(?:pl|pst)$/;
1443 next unless /^$PATH_SEP/o;
1444
1445 push @paths, cf::map::normalise "~$pl/$_";
1446 }
1447
1448 \@paths
1449}
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
1501=item $player->ext_reply ($msgid, @msg)
1502
1503Sends an ext reply to the player.
1504
1505=cut
1506
1507sub ext_reply($$@) {
1508 my ($self, $id, @msg) = @_;
1509
1510 if ($self->ns->extcmd == 2) {
1511 $self->send ("ext " . $self->ns->{json_coder}->encode (["reply-$id", @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 }
1517}
1518
1519=item $player->ext_msg ($type, @msg)
1520
1521Sends an ext event to the client.
1522
1523=cut
1524
1525sub ext_msg($$@) {
1526 my ($self, $type, @msg) = @_;
1527
1528 $self->ns->ext_msg ($type, @msg);
1529}
1530
1531=head3 cf::region
1532
1533=over 4
1534
1535=cut
1536
1537package cf::region;
1538
1539=item cf::region::find_by_path $path
1540
1541Tries to decuce the likely region for a map knowing only its path.
1542
1543=cut
1544
1545sub find_by_path($) {
1546 my ($path) = @_;
1547
1548 my ($match, $specificity);
1549
1550 for my $region (list) {
1551 if ($region->{match} && $path =~ $region->{match}) {
1552 ($match, $specificity) = ($region, $region->specificity)
1553 if $region->specificity > $specificity;
1554 }
1555 }
1556
1557 $match
1558}
1559
1560=back
1561
1562=head3 cf::map
1563
1564=over 4
1565
1566=cut
1567
1568package cf::map;
1569
1570use Fcntl;
1571use Coro::AIO;
1572
1573use overload
1574 '""' => \&as_string,
1575 fallback => 1;
1576
1577our $MAX_RESET = 3600;
1578our $DEFAULT_RESET = 3000;
1579
1580sub generate_random_map {
1581 my ($self, $rmp) = @_;
1582 # mit "rum" bekleckern, nicht
1583 $self->_create_random_map (
1584 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1585 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1586 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1587 $rmp->{exit_on_final_map},
1588 $rmp->{xsize}, $rmp->{ysize},
1589 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1590 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1591 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1592 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1593 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1594 (cf::region::find $rmp->{region}), $rmp->{custom}
1595 )
1596}
1597
1598=item cf::map->register ($regex, $prio)
1599
1600Register a handler for the map path matching the given regex at the
1601givne priority (higher is better, built-in handlers have priority 0, the
1602default).
1603
1604=cut
1605
1606sub register {
1607 my (undef, $regex, $prio) = @_;
1608 my $pkg = caller;
1609
1610 no strict;
1611 push @{"$pkg\::ISA"}, __PACKAGE__;
1612
1613 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1614}
1615
1616# also paths starting with '/'
1617$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}];
1618
1619sub thawer_merge {
1620 my ($self, $merge) = @_;
1621
1622 # we have to keep some variables in memory intact
1623 local $self->{path};
1624 local $self->{load_path};
1625
1626 $self->SUPER::thawer_merge ($merge);
1627}
1628
1629sub normalise {
1630 my ($path, $base) = @_;
1631
1632 $path = "$path"; # make sure its a string
1633
1634 $path =~ s/\.map$//;
1635
1636 # map plan:
1637 #
1638 # /! non-realised random map exit (special hack!)
1639 # {... are special paths that are not being touched
1640 # ?xxx/... are special absolute paths
1641 # ?random/... random maps
1642 # /... normal maps
1643 # ~user/... per-player map of a specific user
1644
1645 $path =~ s/$PATH_SEP/\//go;
1646
1647 # treat it as relative path if it starts with
1648 # something that looks reasonable
1649 if ($path =~ m{^(?:\./|\.\./|\w)}) {
1650 $base or Carp::carp "normalise called with relative path and no base: '$path'";
1651
1652 $base =~ s{[^/]+/?$}{};
1653 $path = "$base/$path";
1654 }
1655
1656 for ($path) {
1657 redo if s{//}{/};
1658 redo if s{/\.?/}{/};
1659 redo if s{/[^/]+/\.\./}{/};
1660 }
1661
1662 $path
1663}
1664
1665sub new_from_path {
1666 my (undef, $path, $base) = @_;
1667
1668 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object
1669
1670 $path = normalise $path, $base;
1671
1672 for my $pkg (sort { $EXT_MAP{$b}[0] <=> $EXT_MAP{$a}[0] } keys %EXT_MAP) {
1673 if ($path =~ $EXT_MAP{$pkg}[1]) {
1674 my $self = bless cf::map::new, $pkg;
1675 $self->{path} = $path; $self->path ($path);
1676 $self->init; # pass $1 etc.
1677 return $self;
1678 }
1679 }
1680
1681 Carp::cluck "unable to resolve path '$path' (base '$base').";
1682 ()
1683}
1684
1685sub init {
1686 my ($self) = @_;
1687
1688 $self
1689}
1690
1691sub as_string {
1692 my ($self) = @_;
1693
1694 "$self->{path}"
1695}
1696
1697# the displayed name, this is a one way mapping
1698sub visible_name {
1699 &as_string
1700}
1701
1702# the original (read-only) location
1703sub load_path {
1704 my ($self) = @_;
1705
1706 "$MAPDIR/$self->{path}.map"
1707}
1708
1709# the temporary/swap location
1710sub save_path {
1711 my ($self) = @_;
1712
1713 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1714 "$TMPDIR/$path.map"
1715}
1716
1717# the unique path, undef == no special unique path
1718sub uniq_path {
1719 my ($self) = @_;
1720
1721 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1722 "$UNIQUEDIR/$path"
1723}
1724
1725# and all this just because we cannot iterate over
1726# all maps in C++...
1727sub change_all_map_light {
1728 my ($change) = @_;
1729
1730 $_->change_map_light ($change)
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;
1740}
1741
1742sub unlink_save {
1743 my ($self) = @_;
1744
1745 utf8::encode (my $save = $self->save_path);
1746 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
1747 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst";
1748}
1749
1750sub load_header_from($) {
1751 my ($self, $path) = @_;
1752
1753 utf8::encode $path;
1754 #aio_open $path, O_RDONLY, 0
1755 # or return;
1756
1757 $self->_load_header ($path)
1758 or return;
1759
1760 $self->{load_path} = $path;
1761
1762 1
1763}
1764
1765sub load_header_orig {
1766 my ($self) = @_;
1767
1768 $self->load_header_from ($self->load_path)
1769}
1770
1771sub load_header_temp {
1772 my ($self) = @_;
1773
1774 $self->load_header_from ($self->save_path)
1775}
1776
1777sub prepare_temp {
1778 my ($self) = @_;
1779
1780 $self->last_access ((delete $self->{last_access})
1781 || $cf::RUNTIME); #d#
1782 # safety
1783 $self->{instantiate_time} = $cf::RUNTIME
1784 if $self->{instantiate_time} > $cf::RUNTIME;
1785}
1786
1787sub prepare_orig {
1788 my ($self) = @_;
1789
1790 $self->{load_original} = 1;
1791 $self->{instantiate_time} = $cf::RUNTIME;
1792 $self->last_access ($cf::RUNTIME);
1793 $self->instantiate;
1794}
1795
1796sub load_header {
1797 my ($self) = @_;
1798
1799 if ($self->load_header_temp) {
1800 $self->prepare_temp;
1801 } else {
1802 $self->load_header_orig
1803 or return;
1804 $self->prepare_orig;
1805 }
1806
1807 $self->{deny_reset} = 1
1808 if $self->no_reset;
1809
1810 $self->default_region (cf::region::find_by_path $self->{path})
1811 unless $self->default_region;
1812
1813 1
1814}
1815
1816sub find;
1817sub find {
1818 my ($path, $origin) = @_;
1819
1820 $path = normalise $path, $origin && $origin->path;
1821
1822 cf::lock_wait "map_find:$path";
1823
1824 $cf::MAP{$path} || do {
1825 my $guard = cf::lock_acquire "map_find:$path";
1826 my $map = new_from_path cf::map $path
1827 or return;
1828
1829 $map->{last_save} = $cf::RUNTIME;
1830
1831 $map->load_header
1832 or return;
1833
1834 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1835 # doing this can freeze the server in a sync job, obviously
1836 #$cf::WAIT_FOR_TICK->wait;
1837 $map->reset;
1838 undef $guard;
1839 return find $path;
1840 }
1841
1842 $cf::MAP{$path} = $map
1843 }
1844}
1845
1846sub pre_load { }
1847sub post_load { }
1848
1849sub load {
1850 my ($self) = @_;
1851
1852 local $self->{deny_reset} = 1; # loading can take a long time
1853
1854 my $path = $self->{path};
1855
1856 {
1857 my $guard = cf::lock_acquire "map_load:$path";
1858
1859 return if $self->in_memory != cf::MAP_SWAPPED;
1860
1861 $self->in_memory (cf::MAP_LOADING);
1862
1863 $self->alloc;
1864
1865 $self->pre_load;
1866 Coro::cede;
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;
1885 $self->difficulty ($self->estimate_difficulty)
1886 unless $self->difficulty;
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;
1896 $self->activate;
1897 }
1898
1899 $self->{last_save} = $cf::RUNTIME;
1900 $self->last_access ($cf::RUNTIME);
1901
1902 $self->in_memory (cf::MAP_IN_MEMORY);
1903 }
1904
1905 $self->post_load;
1906}
1907
1908sub customise_for {
1909 my ($self, $ob) = @_;
1910
1911 return find "~" . $ob->name . "/" . $self->{path}
1912 if $self->per_player;
1913
1914# return find "?party/" . $ob->name . "/" . $self->{path}
1915# if $self->per_party;
1916
1917 $self
1918}
1919
1920# find and load all maps in the 3x3 area around a map
1921sub load_neighbours {
510 my ($map) = @_; 1922 my ($map) = @_;
511 1923
512 my $path = $map->tmpname; 1924 my @neigh; # diagonal neighbours
513 defined $path or return;
514 1925
515 unlink "$path.cfperl"; 1926 for (0 .. 3) {
516}; 1927 my $neigh = $map->tile_path ($_)
1928 or next;
1929 $neigh = find $neigh, $map
1930 or next;
1931 $neigh->load;
517 1932
518*cf::mapsupport::on_swapin = 1933 push @neigh,
519*cf::mapsupport::on_load = sub { 1934 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1935 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1936 }
1937
1938 for (grep defined $_->[0], @neigh) {
1939 my ($path, $origin) = @$_;
1940 my $neigh = find $path, $origin
1941 or next;
1942 $neigh->load;
1943 }
1944}
1945
1946sub find_sync {
1947 my ($path, $origin) = @_;
1948
1949 cf::sync_job { find $path, $origin }
1950}
1951
1952sub do_load_sync {
520 my ($map) = @_; 1953 my ($map) = @_;
521 1954
522 my $path = $map->tmpname; 1955 cf::sync_job { $map->load };
523 $path = $map->path unless defined $path; 1956}
524 1957
525 open my $fh, "<:raw", "$path.cfperl" 1958our %MAP_PREFETCH;
526 or return; # no perl data 1959our $MAP_PREFETCHER = undef;
527 1960
528 my $data = Storable::thaw do { local $/; <$fh> }; 1961sub find_async {
1962 my ($path, $origin) = @_;
529 1963
530 $data->{version} <= 1 1964 $path = normalise $path, $origin && $origin->{path};
531 or return; # too new
532 1965
533 $map->_set_obs ($data->{obs}); 1966 if (my $map = $cf::MAP{$path}) {
534}; 1967 return $map if $map->in_memory == cf::MAP_IN_MEMORY;
1968 }
535 1969
536*cf::mapsupport::on_swapout = sub { 1970 undef $MAP_PREFETCH{$path};
537 my ($map) = @_; 1971 $MAP_PREFETCHER ||= cf::async {
1972 while (%MAP_PREFETCH) {
1973 for my $path (keys %MAP_PREFETCH) {
1974 if (my $map = find $path) {
1975 $map->load;
1976 }
538 1977
539 my $path = $map->tmpname; 1978 delete $MAP_PREFETCH{$path};
540 $path = $map->path unless defined $path; 1979 }
541
542 my $obs = $map->_get_obs;
543
544 if (defined $obs) {
545 open my $fh, ">:raw", "$path.cfperl"
546 or die "$path.cfperl: $!";
547
548 stat $path;
549
550 print $fh Storable::nfreeze {
551 size => (stat _)[7],
552 time => (stat _)[9],
553 version => 1,
554 obs => $obs,
555 }; 1980 }
1981 undef $MAP_PREFETCHER;
1982 };
1983 $MAP_PREFETCHER->prio (6);
556 1984
557 chmod SAVE_MODE, "$path.cfperl"; # very racy, but cf-compatible *g* 1985 ()
1986}
1987
1988sub save {
1989 my ($self) = @_;
1990
1991 my $lock = cf::lock_acquire "map_data:" . $self->path;
1992
1993 $self->{last_save} = $cf::RUNTIME;
1994
1995 return unless $self->dirty;
1996
1997 my $save = $self->save_path; utf8::encode $save;
1998 my $uniq = $self->uniq_path; utf8::encode $uniq;
1999
2000 $self->{load_path} = $save;
2001
2002 return if $self->{deny_save};
2003
2004 local $self->{last_access} = $self->last_access;#d#
2005
2006 cf::async {
2007 $_->contr->save for $self->players;
2008 };
2009
2010 if ($uniq) {
2011 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
2012 $self->_save_objects ($uniq, cf::IO_UNIQUES);
558 } else { 2013 } else {
559 unlink "$path.cfperl"; 2014 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
560 }
561};
562
563attach_to_maps prio => -10000, package => cf::mapsupport::;
564
565#############################################################################
566# load/save perl data associated with player->ob objects
567
568sub all_objects(@) {
569 @_, map all_objects ($_->inv), @_
570}
571
572attach_to_players
573 on_load => sub {
574 my ($pl, $path) = @_;
575
576 for my $o (all_objects $pl->ob) {
577 if (my $value = $o->get_ob_key_value ("_perl_data")) {
578 $o->set_ob_key_value ("_perl_data");
579
580 %$o = %{ Storable::thaw pack "H*", $value };
581 }
582 }
583 }, 2015 }
584 on_save => sub { 2016}
585 my ($pl, $path) = @_;
586 2017
587 $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_) 2018sub swap_out {
588 for grep %$_, all_objects $pl->ob; 2019 my ($self) = @_;
2020
2021 # save first because save cedes
2022 $self->save;
2023
2024 my $lock = cf::lock_acquire "map_data:" . $self->path;
2025
2026 return if $self->players;
2027 return if $self->in_memory != cf::MAP_IN_MEMORY;
2028 return if $self->{deny_save};
2029
2030 $self->clear;
2031 $self->in_memory (cf::MAP_SWAPPED);
2032}
2033
2034sub reset_at {
2035 my ($self) = @_;
2036
2037 # TODO: safety, remove and allow resettable per-player maps
2038 return 1e99 if $self->{deny_reset};
2039
2040 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2041 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2042
2043 $time + $to
2044}
2045
2046sub should_reset {
2047 my ($self) = @_;
2048
2049 $self->reset_at <= $cf::RUNTIME
2050}
2051
2052sub reset {
2053 my ($self) = @_;
2054
2055 my $lock = cf::lock_acquire "map_data:$self->{path}";
2056
2057 return if $self->players;
2058
2059 warn "resetting map ", $self->path;
2060
2061 $self->in_memory (cf::MAP_SWAPPED);
2062
2063 # need to save uniques path
2064 unless ($self->{deny_save}) {
2065 my $uniq = $self->uniq_path; utf8::encode $uniq;
2066
2067 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2068 if $uniq;
589 }, 2069 }
590;
591 2070
592############################################################################# 2071 delete $cf::MAP{$self->path};
593# core extensions - in perl
594 2072
595=item cf::player::exists $login 2073 $self->clear;
596 2074
597Returns true when the given account exists. 2075 $_->clear_links_to ($self) for values %cf::MAP;
598 2076
599=cut 2077 $self->unlink_save;
600 2078 $self->destroy;
601sub cf::player::exists($) {
602 cf::player::find $_[0]
603 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
604} 2079}
605 2080
2081my $nuke_counter = "aaaa";
2082
2083sub nuke {
2084 my ($self) = @_;
2085
2086 delete $cf::MAP{$self->path};
2087
2088 $self->unlink_save;
2089
2090 bless $self, "cf::map";
2091 delete $self->{deny_reset};
2092 $self->{deny_save} = 1;
2093 $self->reset_timeout (1);
2094 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2095
2096 $cf::MAP{$self->path} = $self;
2097
2098 $self->reset; # polite request, might not happen
2099}
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
2137=item cf::map::unique_maps
2138
2139Returns an arrayref of paths of all shared maps that have
2140instantiated unique items. May block.
2141
2142=cut
2143
2144sub unique_maps() {
2145 [
2146 map {
2147 utf8::decode $_;
2148 /\.map$/
2149 ? normalise $_
2150 : ()
2151 } @{ aio_readdir $UNIQUEDIR or [] }
2152 ]
2153}
2154
2155package cf;
2156
2157=back
2158
2159=head3 cf::object
2160
2161=cut
2162
2163package cf::object;
2164
2165=over 4
2166
2167=item $ob->inv_recursive
2168
2169Returns the inventory of the object _and_ their inventories, recursively.
2170
2171=cut
2172
2173sub inv_recursive_;
2174sub inv_recursive_ {
2175 map { $_, inv_recursive_ $_->inv } @_
2176}
2177
2178sub inv_recursive {
2179 inv_recursive_ inv $_[0]
2180}
2181
2182package cf;
2183
2184=back
2185
2186=head3 cf::object::player
2187
2188=over 4
2189
606=item $player->reply ($npc, $msg[, $flags]) 2190=item $player_object->reply ($npc, $msg[, $flags])
607 2191
608Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 2192Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
609can be C<undef>. Does the right thing when the player is currently in a 2193can be C<undef>. Does the right thing when the player is currently in a
610dialogue with the given NPC character. 2194dialogue with the given NPC character.
611 2195
612=cut 2196=cut
613 2197
614# rough implementation of a future "reply" method that works 2198# rough implementation of a future "reply" method that works
615# with dialog boxes. 2199# with dialog boxes.
2200#TODO: the first argument must go, split into a $npc->reply_to ( method
616sub cf::object::player::reply($$$;$) { 2201sub cf::object::player::reply($$$;$) {
617 my ($self, $npc, $msg, $flags) = @_; 2202 my ($self, $npc, $msg, $flags) = @_;
618 2203
619 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2204 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
620 2205
621 if ($self->{record_replies}) { 2206 if ($self->{record_replies}) {
622 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2207 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2208
623 } 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 {
624 $msg = $npc->name . " says: $msg" if $npc; 2217 $msg = $npc->name . " says: $msg" if $npc;
625 $self->message ($msg, $flags); 2218 $self->message ($msg, $flags);
2219 }
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 (@_);
2231}
2232
2233=item $player_object->may ("access")
2234
2235Returns wether the given player is authorized to access resource "access"
2236(e.g. "command_wizcast").
2237
2238=cut
2239
2240sub cf::object::player::may {
2241 my ($self, $access) = @_;
2242
2243 $self->flag (cf::FLAG_WIZ) ||
2244 (ref $cf::CFG{"may_$access"}
2245 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
2246 : $cf::CFG{"may_$access"})
2247}
2248
2249=item $player_object->enter_link
2250
2251Freezes the player and moves him/her to a special map (C<{link}>).
2252
2253The player should be reasonably safe there for short amounts of time. You
2254I<MUST> call C<leave_link> as soon as possible, though.
2255
2256Will never block.
2257
2258=item $player_object->leave_link ($map, $x, $y)
2259
2260Moves the player out of the special C<{link}> map onto the specified
2261map. If the map is not valid (or omitted), the player will be moved back
2262to the location he/she was before the call to C<enter_link>, or, if that
2263fails, to the emergency map position.
2264
2265Might block.
2266
2267=cut
2268
2269sub link_map {
2270 unless ($LINK_MAP) {
2271 $LINK_MAP = cf::map::find "{link}"
2272 or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
2273 $LINK_MAP->load;
2274 }
2275
2276 $LINK_MAP
2277}
2278
2279sub cf::object::player::enter_link {
2280 my ($self) = @_;
2281
2282 $self->deactivate_recursive;
2283
2284 return if UNIVERSAL::isa $self->map, "ext::map_link";
2285
2286 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2287 if $self->map && $self->map->{path} ne "{link}";
2288
2289 $self->enter_map ($LINK_MAP || link_map, 10, 10);
2290}
2291
2292sub cf::object::player::leave_link {
2293 my ($self, $map, $x, $y) = @_;
2294
2295 return unless $self->contr->active;
2296
2297 my $link_pos = delete $self->{_link_pos};
2298
2299 unless ($map) {
2300 # restore original map position
2301 ($map, $x, $y) = @{ $link_pos || [] };
2302 $map = cf::map::find $map;
2303
2304 unless ($map) {
2305 ($map, $x, $y) = @$EMERGENCY_POSITION;
2306 $map = cf::map::find $map
2307 or die "FATAL: cannot load emergency map\n";
2308 }
2309 }
2310
2311 ($x, $y) = (-1, -1)
2312 unless (defined $x) && (defined $y);
2313
2314 # use -1 or undef as default coordinates, not 0, 0
2315 ($x, $y) = ($map->enter_x, $map->enter_y)
2316 if $x <=0 && $y <= 0;
2317
2318 $map->load;
2319 $map->load_neighbours;
2320
2321 return unless $self->contr->active;
2322 $self->activate_recursive;
2323
2324 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2325 $self->enter_map ($map, $x, $y);
2326}
2327
2328=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2329
2330Moves the player to the given map-path and coordinates by first freezing
2331her, loading and preparing them map, calling the provided $check callback
2332that has to return the map if sucecssful, and then unfreezes the player on
2333the new (success) or old (failed) map position. In either case, $done will
2334be called at the end of this process.
2335
2336=cut
2337
2338our $GOTOGEN;
2339
2340sub cf::object::player::goto {
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;
2345
2346 $self->enter_link;
2347
2348 (async {
2349 my $map = eval {
2350 my $map = cf::map::find $path;
2351
2352 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
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 $@;
2365 }
2366
2367 if ($gen == $self->{_goto_generation}) {
2368 delete $self->{_goto_generation};
2369 $self->leave_link ($map, $x, $y);
2370 }
2371
2372 $done->() if $done;
2373 })->prio (1);
2374}
2375
2376=item $player_object->enter_exit ($exit_object)
2377
2378=cut
2379
2380sub parse_random_map_params {
2381 my ($spec) = @_;
2382
2383 my $rmp = { # defaults
2384 xsize => (cf::rndm 15, 40),
2385 ysize => (cf::rndm 15, 40),
2386 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
2387 #layout => string,
626 } 2388 };
627}
628 2389
629=item $player->ext_reply ($msgid, $msgtype, %msg) 2390 for (split /\n/, $spec) {
2391 my ($k, $v) = split /\s+/, $_, 2;
630 2392
2393 $rmp->{lc $k} = $v if (length $k) && (length $v);
2394 }
2395
2396 $rmp
2397}
2398
2399sub prepare_random_map {
2400 my ($exit) = @_;
2401
2402 my $guard = cf::lock_acquire "exit_prepare:$exit";
2403
2404 # all this does is basically replace the /! path by
2405 # a new random map path (?random/...) with a seed
2406 # that depends on the exit object
2407
2408 my $rmp = parse_random_map_params $exit->msg;
2409
2410 if ($exit->map) {
2411 $rmp->{region} = $exit->region->name;
2412 $rmp->{origin_map} = $exit->map->path;
2413 $rmp->{origin_x} = $exit->x;
2414 $rmp->{origin_y} = $exit->y;
2415 }
2416
2417 $rmp->{random_seed} ||= $exit->random_seed;
2418
2419 my $data = cf::to_json $rmp;
2420 my $md5 = Digest::MD5::md5_hex $data;
2421 my $meta = "$RANDOMDIR/$md5.meta";
2422
2423 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2424 aio_write $fh, 0, (length $data), $data, 0;
2425 undef $fh;
2426 aio_rename "$meta~", $meta;
2427
2428 $exit->slaying ("?random/$md5");
2429 $exit->msg (undef);
2430 }
2431}
2432
2433sub cf::object::player::enter_exit {
2434 my ($self, $exit) = @_;
2435
2436 return unless $self->type == cf::PLAYER;
2437
2438 if ($exit->slaying eq "/!") {
2439 #TODO: this should de-fi-ni-te-ly not be a sync-job
2440 # the problem is that $exit might not survive long enough
2441 # so it needs to be done right now, right here
2442 cf::sync_job { prepare_random_map $exit };
2443 }
2444
2445 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2446 my $hp = $exit->stats->hp;
2447 my $sp = $exit->stats->sp;
2448
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);
2454
2455 (async {
2456 $self->deactivate_recursive; # just to be sure
2457 unless (eval {
2458 $self->goto ($slaying, $hp, $sp);
2459
2460 1;
2461 }) {
2462 $self->message ("Something went wrong deep within the crossfire server. "
2463 . "I'll try to bring you back to the map you were before. "
2464 . "Please report this to the dungeon master!",
2465 cf::NDI_UNIQUE | cf::NDI_RED);
2466
2467 warn "ERROR in enter_exit: $@";
2468 $self->leave_link;
2469 }
2470 })->prio (1);
2471}
2472
2473=head3 cf::client
2474
2475=over 4
2476
2477=item $client->send_drawinfo ($text, $flags)
2478
2479Sends a drawinfo packet to the client. Circumvents output buffering so
2480should not be used under normal circumstances.
2481
2482=cut
2483
2484sub cf::client::send_drawinfo {
2485 my ($self, $text, $flags) = @_;
2486
2487 utf8::encode $text;
2488 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2489}
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
2553=item $client->ext_msg ($type, @msg)
2554
631Sends an ext reply to the player. 2555Sends an ext event to the client.
632 2556
633=cut 2557=cut
634 2558
635sub cf::player::ext_reply($$$%) { 2559sub cf::client::ext_msg($$@) {
636 my ($self, $id, %msg) = @_; 2560 my ($self, $type, @msg) = @_;
637 2561
638 $msg{msgid} = $id; 2562 my $extcmd = $self->extcmd;
639 2563
640 $self->send ("ext " . to_json \%msg); 2564 if ($extcmd == 2) {
2565 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2566 } elsif ($extcmd == 1) { # TODO: remove
2567 push @msg, msgtype => "event_$type";
2568 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2569 }
641} 2570}
642 2571
643############################################################################# 2572=item $success = $client->query ($flags, "text", \&cb)
644# map scripting support 2573
2574Queues a query to the client, calling the given callback with
2575the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
2576C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2577
2578Queries can fail, so check the return code. Or don't, as queries will
2579become reliable at some point in the future.
2580
2581=cut
2582
2583sub cf::client::query {
2584 my ($self, $flags, $text, $cb) = @_;
2585
2586 return unless $self->state == ST_PLAYING
2587 || $self->state == ST_SETUP
2588 || $self->state == ST_CUSTOM;
2589
2590 $self->state (ST_CUSTOM);
2591
2592 utf8::encode $text;
2593 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2594
2595 $self->send_packet ($self->{query_queue}[0][0])
2596 if @{ $self->{query_queue} } == 1;
2597
2598 1
2599}
2600
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 },
2607 on_reply => sub {
2608 my ($ns, $msg) = @_;
2609
2610 # this weird shuffling is so that direct followup queries
2611 # get handled first
2612 my $queue = delete $ns->{query_queue}
2613 or return; # be conservative, not sure how that can happen, but we saw a crash here
2614
2615 (shift @$queue)->[1]->($msg);
2616 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
2617
2618 push @{ $ns->{query_queue} }, @$queue;
2619
2620 if (@{ $ns->{query_queue} } == @$queue) {
2621 if (@$queue) {
2622 $ns->send_packet ($ns->{query_queue}[0][0]);
2623 } else {
2624 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2625 }
2626 }
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 },
2651);
2652
2653=item $client->async (\&cb)
2654
2655Create a new coroutine, running the specified callback. The coroutine will
2656be automatically cancelled when the client gets destroyed (e.g. on logout,
2657or loss of connection).
2658
2659=cut
2660
2661sub cf::client::async {
2662 my ($self, $cb) = @_;
2663
2664 my $coro = &Coro::async ($cb);
2665
2666 $coro->on_destroy (sub {
2667 delete $self->{_coro}{$coro+0};
2668 });
2669
2670 $self->{_coro}{$coro+0} = $coro;
2671
2672 $coro
2673}
2674
2675cf::client->attach (
2676 on_destroy => sub {
2677 my ($ns) = @_;
2678
2679 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
2680 },
2681);
2682
2683=back
2684
2685
2686=head2 SAFE SCRIPTING
2687
2688Functions that provide a safe environment to compile and execute
2689snippets of perl code without them endangering the safety of the server
2690itself. Looping constructs, I/O operators and other built-in functionality
2691is not available in the safe scripting environment, and the number of
2692functions and methods that can be called is greatly reduced.
2693
2694=cut
645 2695
646our $safe = new Safe "safe"; 2696our $safe = new Safe "safe";
647our $safe_hole = new Safe::Hole; 2697our $safe_hole = new Safe::Hole;
648 2698
649$SIG{FPE} = 'IGNORE'; 2699$SIG{FPE} = 'IGNORE';
650 2700
651$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));
652 2706
653# here we export the classes and methods available to script code 2707# here we export the classes and methods available to script code
654 2708
2709=pod
2710
2711The following functions and methods are available within a safe environment:
2712
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
2717 cf::object::player
2718 player
2719
2720 cf::player
2721 peaceful
2722
2723 cf::map
2724 trigger
2725
2726=cut
2727
655for ( 2728for (
656 ["cf::object" => qw(contr pay_amount pay_player)], 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)],
657 ["cf::object::player" => qw(player)], 2731 ["cf::object::player" => qw(player)],
658 ["cf::player" => qw(peaceful)], 2732 ["cf::player" => qw(peaceful)],
2733 ["cf::map" => qw(trigger)],
659) { 2734) {
660 no strict 'refs'; 2735 no strict 'refs';
661 my ($pkg, @funs) = @$_; 2736 my ($pkg, @funs) = @$_;
662 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 2737 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
663 for @funs; 2738 for @funs;
664} 2739}
2740
2741=over 4
2742
2743=item @retval = safe_eval $code, [var => value, ...]
2744
2745Compiled and executes the given perl code snippet. additional var/value
2746pairs result in temporary local (my) scalar variables of the given name
2747that are available in the code snippet. Example:
2748
2749 my $five = safe_eval '$first + $second', first => 1, second => 4;
2750
2751=cut
665 2752
666sub safe_eval($;@) { 2753sub safe_eval($;@) {
667 my ($code, %vars) = @_; 2754 my ($code, %vars) = @_;
668 2755
669 my $qcode = $code; 2756 my $qcode = $code;
… …
692 } 2779 }
693 2780
694 wantarray ? @res : $res[0] 2781 wantarray ? @res : $res[0]
695} 2782}
696 2783
2784=item cf::register_script_function $function => $cb
2785
2786Register a function that can be called from within map/npc scripts. The
2787function should be reasonably secure and should be put into a package name
2788like the extension.
2789
2790Example: register a function that gets called whenever a map script calls
2791C<rent::overview>, as used by the C<rent> extension.
2792
2793 cf::register_script_function "rent::overview" => sub {
2794 ...
2795 };
2796
2797=cut
2798
697sub register_script_function { 2799sub register_script_function {
698 my ($fun, $cb) = @_; 2800 my ($fun, $cb) = @_;
699 2801
700 no strict 'refs'; 2802 no strict 'refs';
701 *{"safe::$fun"} = $safe_hole->wrap ($cb); 2803 *{"safe::$fun"} = $safe_hole->wrap ($cb);
702} 2804}
703 2805
2806=back
2807
2808=cut
2809
704############################################################################# 2810#############################################################################
705# the server's main() 2811# the server's init and main functions
2812
2813sub load_facedata($) {
2814 my ($path) = @_;
2815
2816 my $enc = JSON::XS->new->utf8->canonical;
2817
2818 warn "loading facedata from $path\n";
2819
2820 my $facedata;
2821 0 < aio_load $path, $facedata
2822 or die "$path: $!";
2823
2824 $facedata = Coro::Storable::thaw $facedata;
2825
2826 $facedata->{version} == 2
2827 or cf::cleanup "$path: version mismatch, cannot proceed.";
2828
2829 # patch in the exptable
2830 $facedata->{resource}{"res/exp_table"} = {
2831 type => FT_RSRC,
2832 data => $enc->encode ([map cf::level_to_min_exp $_, 0 .. cf::settings->max_level]),
2833 };
2834 cf::cede_to_tick;
2835
2836 {
2837 my $faces = $facedata->{faceinfo};
2838
2839 while (my ($face, $info) = each %$faces) {
2840 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2841 cf::face::set_visibility $idx, $info->{visibility};
2842 cf::face::set_magicmap $idx, $info->{magicmap};
2843 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2844 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2845
2846 cf::cede_to_tick;
2847 }
2848
2849 while (my ($face, $info) = each %$faces) {
2850 next unless $info->{smooth};
2851 my $idx = cf::face::find $face
2852 or next;
2853 if (my $smooth = cf::face::find $info->{smooth}) {
2854 cf::face::set_smooth $idx, $smooth;
2855 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2856 } else {
2857 warn "smooth face '$info->{smooth}' not found for face '$face'";
2858 }
2859
2860 cf::cede_to_tick;
2861 }
2862 }
2863
2864 {
2865 my $anims = $facedata->{animinfo};
2866
2867 while (my ($anim, $info) = each %$anims) {
2868 cf::anim::set $anim, $info->{frames}, $info->{facings};
2869 cf::cede_to_tick;
2870 }
2871
2872 cf::anim::invalidate_all; # d'oh
2873 }
2874
2875 {
2876 # TODO: for gcfclient pleasure, we should give resources
2877 # that gcfclient doesn't grok a >10000 face index.
2878 my $res = $facedata->{resource};
2879
2880 my $soundconf = delete $res->{"res/sound.conf"};
2881
2882 while (my ($name, $info) = each %$res) {
2883 my $idx = (cf::face::find $name) || cf::face::alloc $name;
2884 my $data;
2885
2886 if ($info->{type} & 1) {
2887 # prepend meta info
2888
2889 my $meta = $enc->encode ({
2890 name => $name,
2891 %{ $info->{meta} || {} },
2892 });
2893
2894 $data = pack "(w/a*)*", $meta, $info->{data};
2895 }
2896
2897 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
2898 cf::face::set_type $idx, $info->{type};
2899
2900 cf::cede_to_tick;
2901 }
2902
2903 if ($soundconf) {
2904 $soundconf = $enc->decode (delete $soundconf->{data});
2905
2906 for (0 .. SOUND_CAST_SPELL_0 - 1) {
2907 my $sound = $soundconf->{compat}[$_]
2908 or next;
2909
2910 my $face = cf::face::find "sound/$sound->[1]";
2911 cf::sound::set $sound->[0] => $face;
2912 cf::sound::old_sound_index $_, $face; # gcfclient-compat
2913 }
2914
2915 while (my ($k, $v) = each %{$soundconf->{event}}) {
2916 my $face = cf::face::find "sound/$v";
2917 cf::sound::set $k => $face;
2918 }
2919 }
2920 }
2921
2922 1
2923}
2924
2925register_exticmd fx_want => sub {
2926 my ($ns, $want) = @_;
2927
2928 while (my ($k, $v) = each %$want) {
2929 $ns->fx_want ($k, $v);
2930 }
2931};
2932
2933sub reload_regions {
2934 load_resource_file "$MAPDIR/regions"
2935 or die "unable to load regions file\n";
2936
2937 for (cf::region::list) {
2938 $_->{match} = qr/$_->{match}/
2939 if exists $_->{match};
2940 }
2941}
2942
2943sub reload_facedata {
2944 load_facedata "$DATADIR/facedata"
2945 or die "unable to load facedata\n";
2946}
2947
2948sub reload_archetypes {
2949 load_resource_file "$DATADIR/archetypes"
2950 or die "unable to load archetypes\n";
2951 #d# NEED to laod twice to resolve forward references
2952 # this really needs to be done in an extra post-pass
2953 # (which needs to be synchronous, so solve it differently)
2954 load_resource_file "$DATADIR/archetypes"
2955 or die "unable to load archetypes\n";
2956}
2957
2958sub reload_treasures {
2959 load_resource_file "$DATADIR/treasures"
2960 or die "unable to load treasurelists\n";
2961}
2962
2963sub reload_resources {
2964 warn "reloading resource files...\n";
2965
2966 reload_regions;
2967 reload_facedata;
2968 #reload_archetypes;#d#
2969 reload_archetypes;
2970 reload_treasures;
2971
2972 warn "finished reloading resource files\n";
2973}
2974
2975sub init {
2976 reload_resources;
2977}
2978
2979sub cfg_load {
2980 open my $fh, "<:utf8", "$CONFDIR/config"
2981 or return;
2982
2983 local $/;
2984 *CFG = YAML::Syck::Load <$fh>;
2985
2986 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
2987
2988 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2989 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
2990
2991 if (exists $CFG{mlockall}) {
2992 eval {
2993 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
2994 and die "WARNING: m(un)lockall failed: $!\n";
2995 };
2996 warn $@ if $@;
2997 }
2998}
706 2999
707sub main { 3000sub main {
3001 # we must not ever block the main coroutine
3002 local $Coro::idle = sub {
3003 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3004 (async {
3005 Event::one_event;
3006 })->prio (Coro::PRIO_MAX);
3007 };
3008
3009 cfg_load;
3010 db_init;
3011 load_extensions;
3012
3013 $TICK_WATCHER->start;
708 Event::loop; 3014 Event::loop;
709} 3015}
710 3016
711############################################################################# 3017#############################################################################
712# initialisation 3018# initialisation and cleanup
713 3019
714register "<global>", __PACKAGE__; 3020# install some emergency cleanup handlers
3021BEGIN {
3022 for my $signal (qw(INT HUP TERM)) {
3023 Event->signal (
3024 reentrant => 0,
3025 data => WF_AUTOCANCEL,
3026 signal => $signal,
3027 prio => 0,
3028 cb => sub {
3029 cf::cleanup "SIG$signal";
3030 },
3031 );
3032 }
3033}
3034
3035sub write_runtime {
3036 my $runtime = "$LOCALDIR/runtime";
3037
3038 # first touch the runtime file to show we are still running:
3039 # the fsync below can take a very very long time.
3040
3041 IO::AIO::aio_utime $runtime, undef, undef;
3042
3043 my $guard = cf::lock_acquire "write_runtime";
3044
3045 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
3046 or return;
3047
3048 my $value = $cf::RUNTIME + 90 + 10;
3049 # 10 is the runtime save interval, for a monotonic clock
3050 # 60 allows for the watchdog to kill the server.
3051
3052 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3053 and return;
3054
3055 # always fsync - this file is important
3056 aio_fsync $fh
3057 and return;
3058
3059 # touch it again to show we are up-to-date
3060 aio_utime $fh, undef, undef;
3061
3062 close $fh
3063 or return;
3064
3065 aio_rename "$runtime~", $runtime
3066 and return;
3067
3068 warn "runtime file written.\n";
3069
3070 1
3071}
3072
3073sub emergency_save() {
3074 my $freeze_guard = cf::freeze_mainloop;
3075
3076 warn "enter emergency perl save\n";
3077
3078 cf::sync_job {
3079 # use a peculiar iteration method to avoid tripping on perl
3080 # refcount bugs in for. also avoids problems with players
3081 # and maps saved/destroyed asynchronously.
3082 warn "begin emergency player save\n";
3083 for my $login (keys %cf::PLAYER) {
3084 my $pl = $cf::PLAYER{$login} or next;
3085 $pl->valid or next;
3086 $pl->save;
3087 }
3088 warn "end emergency player save\n";
3089
3090 warn "begin emergency map save\n";
3091 for my $path (keys %cf::MAP) {
3092 my $map = $cf::MAP{$path} or next;
3093 $map->valid or next;
3094 $map->save;
3095 }
3096 warn "end emergency map save\n";
3097
3098 warn "begin emergency database checkpoint\n";
3099 BDB::db_env_txn_checkpoint $DB_ENV;
3100 warn "end emergency database checkpoint\n";
3101 };
3102
3103 warn "leave emergency perl save\n";
3104}
3105
3106sub post_cleanup {
3107 my ($make_core) = @_;
3108
3109 warn Carp::longmess "post_cleanup backtrace"
3110 if $make_core;
3111}
3112
3113sub do_reload_perl() {
3114 # can/must only be called in main
3115 if ($Coro::current != $Coro::main) {
3116 warn "can only reload from main coroutine";
3117 return;
3118 }
3119
3120 warn "reloading...";
3121
3122 warn "entering sync_job";
3123
3124 cf::sync_job {
3125 cf::write_runtime; # external watchdog should not bark
3126 cf::emergency_save;
3127 cf::write_runtime; # external watchdog should not bark
3128
3129 warn "syncing database to disk";
3130 BDB::db_env_txn_checkpoint $DB_ENV;
3131
3132 # if anything goes wrong in here, we should simply crash as we already saved
3133
3134 warn "cancelling all WF_AUTOCANCEL watchers";
3135 for (Event::all_watchers) {
3136 $_->cancel if $_->data & WF_AUTOCANCEL;
3137 }
3138
3139 warn "flushing outstanding aio requests";
3140 for (;;) {
3141 BDB::flush;
3142 IO::AIO::flush;
3143 Coro::cede;
3144 last unless IO::AIO::nreqs || BDB::nreqs;
3145 warn "iterate...";
3146 }
3147
3148 ++$RELOAD;
3149
3150 warn "cancelling all extension coros";
3151 $_->cancel for values %EXT_CORO;
3152 %EXT_CORO = ();
3153
3154 warn "removing commands";
3155 %COMMAND = ();
3156
3157 warn "removing ext/exti commands";
3158 %EXTCMD = ();
3159 %EXTICMD = ();
3160
3161 warn "unloading/nuking all extensions";
3162 for my $pkg (@EXTS) {
3163 warn "... unloading $pkg";
3164
3165 if (my $cb = $pkg->can ("unload")) {
3166 eval {
3167 $cb->($pkg);
3168 1
3169 } or warn "$pkg unloaded, but with errors: $@";
3170 }
3171
3172 warn "... nuking $pkg";
3173 Symbol::delete_package $pkg;
3174 }
3175
3176 warn "unloading all perl modules loaded from $LIBDIR";
3177 while (my ($k, $v) = each %INC) {
3178 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3179
3180 warn "... unloading $k";
3181 delete $INC{$k};
3182
3183 $k =~ s/\.pm$//;
3184 $k =~ s/\//::/g;
3185
3186 if (my $cb = $k->can ("unload_module")) {
3187 $cb->();
3188 }
3189
3190 Symbol::delete_package $k;
3191 }
3192
3193 warn "getting rid of safe::, as good as possible";
3194 Symbol::delete_package "safe::$_"
3195 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3196
3197 warn "unloading cf.pm \"a bit\"";
3198 delete $INC{"cf.pm"};
3199 delete $INC{"cf/pod.pm"};
3200
3201 # don't, removes xs symbols, too,
3202 # and global variables created in xs
3203 #Symbol::delete_package __PACKAGE__;
3204
3205 warn "unload completed, starting to reload now";
3206
3207 warn "reloading cf.pm";
3208 require cf;
3209 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3210
3211 warn "loading config and database again";
3212 cf::cfg_load;
3213
3214 warn "loading extensions";
3215 cf::load_extensions;
3216
3217 warn "reattaching attachments to objects/players";
3218 _global_reattach; # objects, sockets
3219 warn "reattaching attachments to maps";
3220 reattach $_ for values %MAP;
3221 warn "reattaching attachments to players";
3222 reattach $_ for values %PLAYER;
3223
3224 warn "leaving sync_job";
3225
3226 1
3227 } or do {
3228 warn $@;
3229 warn "error while reloading, exiting.";
3230 exit 1;
3231 };
3232
3233 warn "reloaded";
3234};
3235
3236our $RELOAD_WATCHER; # used only during reload
3237
3238sub reload_perl() {
3239 # doing reload synchronously and two reloads happen back-to-back,
3240 # coro crashes during coro_state_free->destroy here.
3241
3242 $RELOAD_WATCHER ||= Event->timer (
3243 reentrant => 0,
3244 after => 0,
3245 data => WF_AUTOCANCEL,
3246 cb => sub {
3247 do_reload_perl;
3248 undef $RELOAD_WATCHER;
3249 },
3250 );
3251}
3252
3253register_command "reload" => sub {
3254 my ($who, $arg) = @_;
3255
3256 if ($who->flag (FLAG_WIZ)) {
3257 $who->message ("reloading server.");
3258 async { reload_perl };
3259 }
3260};
715 3261
716unshift @INC, $LIBDIR; 3262unshift @INC, $LIBDIR;
717 3263
718load_extensions; 3264my $bug_warning = 0;
719 3265
3266our @WAIT_FOR_TICK;
3267our @WAIT_FOR_TICK_BEGIN;
3268
3269sub wait_for_tick {
3270 return unless $TICK_WATCHER->is_active;
3271 return if $Coro::current == $Coro::main;
3272
3273 my $signal = new Coro::Signal;
3274 push @WAIT_FOR_TICK, $signal;
3275 $signal->wait;
3276}
3277
3278sub wait_for_tick_begin {
3279 return unless $TICK_WATCHER->is_active;
3280 return if $Coro::current == $Coro::main;
3281
3282 my $signal = new Coro::Signal;
3283 push @WAIT_FOR_TICK_BEGIN, $signal;
3284 $signal->wait;
3285}
3286
3287 my $min = 1e6;#d#
3288 my $avg = 10;
720$TICK_WATCHER = Event->timer ( 3289$TICK_WATCHER = Event->timer (
3290 reentrant => 0,
3291 parked => 1,
721 prio => 1, 3292 prio => 0,
722 at => $NEXT_TICK || 1, 3293 at => $NEXT_TICK || $TICK,
3294 data => WF_AUTOCANCEL,
723 cb => sub { 3295 cb => sub {
3296 if ($Coro::current != $Coro::main) {
3297 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3298 unless ++$bug_warning > 10;
3299 return;
3300 }
3301
3302 $NOW = $tick_start = Event::time;
3303
724 cf::server_tick; # one server iteration 3304 cf::server_tick; # one server iteration
725 3305
3306 0 && sync_job {#d#
3307 for(1..10) {
726 my $NOW = Event::time; 3308 my $t = Event::time;
3309 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3310 or die;
3311
3312 $map->width (50);
3313 $map->height (50);
3314 $map->alloc;
3315 $map->_load_objects ("/tmp/x.map", 1);
3316 my $t = Event::time - $t;
3317
3318 #next unless $t < 0.0013;#d#
3319 if ($t < $min) {
3320 $min = $t;
3321 }
3322 $avg = $avg * 0.99 + $t * 0.01;
3323 }
3324 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3325 exit 0;
3326 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3327 };
3328
3329 $RUNTIME += $TICK;
727 $NEXT_TICK += $TICK; 3330 $NEXT_TICK += $TICK;
728 3331
3332 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3333 $NEXT_RUNTIME_WRITE = $NOW + 10;
3334 Coro::async_pool {
3335 write_runtime
3336 or warn "ERROR: unable to write runtime file: $!";
3337 };
3338 }
3339
3340# my $AFTER = Event::time;
3341# warn $AFTER - $NOW;#d#
3342
3343 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3344 $sig->send;
3345 }
3346 while (my $sig = shift @WAIT_FOR_TICK) {
3347 $sig->send;
3348 }
3349
3350 $NOW = Event::time;
3351
729 # if we are delayed by four ticks, skip them all 3352 # if we are delayed by four ticks or more, skip them all
730 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 3353 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
731 3354
732 $TICK_WATCHER->at ($NEXT_TICK); 3355 $TICK_WATCHER->at ($NEXT_TICK);
733 $TICK_WATCHER->start; 3356 $TICK_WATCHER->start;
3357
3358 $LOAD = ($NOW - $tick_start) / $TICK;
3359 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3360
3361 _post_tick;
3362
3363
734 }, 3364 },
735); 3365);
736 3366
3367{
3368 BDB::max_poll_time $TICK * 0.1;
3369 $BDB_POLL_WATCHER = Event->io (
3370 reentrant => 0,
3371 fd => BDB::poll_fileno,
3372 poll => 'r',
3373 prio => 0,
3374 data => WF_AUTOCANCEL,
3375 cb => \&BDB::poll_cb,
3376 );
3377 BDB::min_parallel 8;
3378
3379 BDB::set_sync_prepare {
3380 my $status;
3381 my $current = $Coro::current;
3382 (
3383 sub {
3384 $status = $!;
3385 $current->ready; undef $current;
3386 },
3387 sub {
3388 Coro::schedule while defined $current;
3389 $! = $status;
3390 },
3391 )
3392 };
3393
3394 unless ($DB_ENV) {
3395 $DB_ENV = BDB::db_env_create;
3396
3397 cf::sync_job {
3398 eval {
3399 BDB::db_env_open
3400 $DB_ENV,
3401 $BDBDIR,
3402 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3403 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3404 0666;
3405
3406 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3407
3408 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3409 $DB_ENV->set_lk_detect;
3410 };
3411
3412 cf::cleanup "db_env_open(db): $@" if $@;
3413 };
3414 }
3415}
3416
3417{
3418 IO::AIO::min_parallel 8;
3419
3420 undef $Coro::AIO::WATCHER;
3421 IO::AIO::max_poll_time $TICK * 0.1;
3422 $AIO_POLL_WATCHER = Event->io (
3423 reentrant => 0,
3424 data => WF_AUTOCANCEL,
3425 fd => IO::AIO::poll_fileno,
3426 poll => 'r',
3427 prio => 6,
3428 cb => \&IO::AIO::poll_cb,
3429 );
3430}
3431
3432my $_log_backtrace;
3433
3434sub _log_backtrace {
3435 my ($msg, @addr) = @_;
3436
3437 $msg =~ s/\n//;
3438
3439 # limit the # of concurrent backtraces
3440 if ($_log_backtrace < 2) {
3441 ++$_log_backtrace;
3442 async {
3443 my @bt = fork_call {
3444 @addr = map { sprintf "%x", $_ } @addr;
3445 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3446 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3447 or die "addr2line: $!";
3448
3449 my @funcs;
3450 my @res = <$fh>;
3451 chomp for @res;
3452 while (@res) {
3453 my ($func, $line) = splice @res, 0, 2, ();
3454 push @funcs, "[$func] $line";
3455 }
3456
3457 @funcs
3458 };
3459
3460 LOG llevInfo, "[ABT] $msg\n";
3461 LOG llevInfo, "[ABT] $_\n" for @bt;
3462 --$_log_backtrace;
3463 };
3464 } else {
3465 LOG llevInfo, "[ABT] $msg\n";
3466 LOG llevInfo, "[ABT] [suppressed]\n";
3467 }
3468}
3469
3470# load additional modules
3471use cf::pod;
3472
3473END { cf::emergency_save }
3474
7371 34751
738 3476

Diff Legend

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