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.45 by root, Sat Aug 26 23:36:32 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 %PROP_TYPE;
19our %PROP_IDX;
20our $LIBDIR = maps_directory "perl";
21 63
22our $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(!)
23our $TICK_WATCHER; 77our $TICK_WATCHER;
78our $AIO_POLL_WATCHER;
79our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
24our $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
25 182
26BEGIN { 183BEGIN {
27 *CORE::GLOBAL::warn = sub { 184 *CORE::GLOBAL::warn = sub {
28 my $msg = join "", @_; 185 my $msg = join "", @_;
186
29 $msg .= "\n" 187 $msg .= "\n"
30 unless $msg =~ /\n$/; 188 unless $msg =~ /\n$/;
31 189
32 print STDERR "cfperl: $msg"; 190 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
191
192 utf8::encode $msg;
33 LOG llevError, "cfperl: $msg"; 193 LOG llevError, $msg;
34 }; 194 };
35} 195}
36 196
37my %ignore_set = (MAP_PROP_PATH => 1); # I hate the plug-in api. Deeply! 197@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
38 198@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
39# generate property mutators 199@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
40sub prop_gen { 200@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
41 my ($prefix, $class) = @_; 201@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
42 202@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
43 no strict 'refs';
44
45 for my $prop (keys %PROP_TYPE) {
46 $prop =~ /^\Q$prefix\E_(.*$)/ or next;
47 my $sub = lc $1;
48
49 my $type = $PROP_TYPE{$prop};
50 my $idx = $PROP_IDX {$prop};
51
52 *{"$class\::get_$sub"} = *{"$class\::$sub"} = sub {
53 $_[0]->get_property ($type, $idx)
54 };
55
56 *{"$class\::set_$sub"} = sub {
57 $_[0]->set_property ($type, $idx, $_[1]);
58 } unless $ignore_set{$prop};
59 }
60}
61
62# auto-generate most of the API
63
64prop_gen OBJECT_PROP => "cf::object";
65# CFAPI_OBJECT_ANIMATION?
66prop_gen PLAYER_PROP => "cf::object::player";
67
68prop_gen MAP_PROP => "cf::map";
69prop_gen ARCH_PROP => "cf::arch";
70
71@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)
72 204
73# 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
74# within the Safe compartment. 206# within the Safe compartment.
75for my $pkg (qw(cf::object 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)) {
76 no strict 'refs'; 214 no strict 'refs';
77 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 215 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
78} 216}
79 217
80$Event::DIED = sub { 218$Event::DIED = sub {
81 warn "error in event callback: @_"; 219 warn "error in event callback: @_";
82}; 220};
83 221
84my %ext_pkg;
85my @exts;
86my @hook;
87my %command;
88my %extcmd;
89
90############################################################################# 222#############################################################################
91# utility functions
92 223
93use JSON::Syck (); # TODO# replace by JSON::PC once working 224=head2 UTILITY FUNCTIONS
94 225
95sub from_json($) { 226=over 4
96 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
97 JSON::Syck::Load $_[0]
98}
99 227
100sub to_json($) { 228=item dumpval $ref
101 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 229
102 JSON::Syck::Dump $_[0] 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]: '$@']";
103} 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
104 623
105############################################################################# 624#############################################################################
106# "new" plug-in system
107 625
108=item cf::object::attach ... # NYI 626=head2 ATTACHABLE OBJECTS
109 627
110=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.
111 631
112=item cf::attach_to_type $object_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).
113 635
114=item cf::attach_to_objects ... 636=over 4
115 637
116=item cf::attach_to_players ... 638=item $attachable->attach ($attachment, key => $value...)
117 639
118=item cf::attach_to_maps ... 640=item $attachable->detach ($attachment)
119 641
642Attach/detach a pre-registered attachment to a specific object and give it
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
120=item cf:register_attachment $name, ... 683=item cf::CLASS::attachment $name, ...
121 684
122 prio => $number, # lower is earlier 685Register an attachment by C<$name> through which attachable objects of the
123 on_xxx => \&cb, 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
124 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.
125 744
126=cut 745=cut
127 746
128# 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
129our @CB_GLOBAL = (); # registry for all global events 748our @CB_GLOBAL = (); # registry for all global events
749our @CB_ATTACHABLE = (); # registry for all attachables
130our @CB_OBJECT = (); # all objects (should not be used except in emergency) 750our @CB_OBJECT = (); # all objects (should not be used except in emergency)
131our @CB_PLAYER = (); 751our @CB_PLAYER = ();
752our @CB_CLIENT = ();
132our @CB_TYPE = (); # registry for type (cf-object class) based events 753our @CB_TYPE = (); # registry for type (cf-object class) based events
133our @CB_MAP = (); 754our @CB_MAP = ();
134 755
135my %attachment; 756my %attachment;
136 757
758sub cf::attachable::thawer_merge {
759 # simply override everything except _meta
760 local $_[0]{_meta};
761 %{$_[0]} = %{$_[1]};
762}
763
137sub _attach_cb($\%$$$) { 764sub _attach_cb($$$$) {
138 my ($registry, $undo, $event, $prio, $cb) = @_; 765 my ($registry, $event, $prio, $cb) = @_;
139 766
140 use sort 'stable'; 767 use sort 'stable';
141 768
142 $cb = [$prio, $cb]; 769 $cb = [$prio, $cb];
143 770
144 @{$registry->[$event]} = sort 771 @{$registry->[$event]} = sort
145 { $a->[0] cmp $b->[0] } 772 { $a->[0] cmp $b->[0] }
146 @{$registry->[$event] || []}, $cb; 773 @{$registry->[$event] || []}, $cb;
147
148 push @{$undo->{cb}}, [$event, $cb];
149} 774}
775
776# hack
777my %attachable_klass = map +($_ => 1), KLASS_OBJECT, KLASS_CLIENT, KLASS_PLAYER, KLASS_MAP;
150 778
151# attach handles attaching event callbacks 779# attach handles attaching event callbacks
152# 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
153# registry (== where the callback attaches to). 781# registry (== where the callback attaches to).
154sub _attach(\@$@) { 782sub _attach {
155 my ($registry, $klass, @arg) = @_; 783 my ($registry, $klass, @arg) = @_;
156 784
785 my $object_type;
157 my $prio = 0; 786 my $prio = 0;
158
159 my %undo = (
160 registry => $registry,
161 cb => [],
162 );
163
164 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;
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 }
165 793
166 while (@arg) { 794 while (@arg) {
167 my $type = shift @arg; 795 my $type = shift @arg;
168 796
169 if ($type eq "prio") { 797 if ($type eq "prio") {
170 $prio = shift @arg; 798 $prio = shift @arg;
171 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] ||= [];
808
172 } elsif ($type eq "package") { 809 } elsif ($type eq "package") {
173 my $pkg = shift @arg; 810 my $pkg = shift @arg;
174 811
175 while (my ($name, $id) = each %cb_id) { 812 while (my ($name, $id) = each %cb_id) {
176 if (my $cb = $pkg->can ($name)) { 813 if (my $cb = $pkg->can ($name)) {
177 _attach_cb $registry, %undo, $id, $prio, $cb; 814 _attach_cb $registry, $id, $prio, $cb;
178 } 815 }
179 } 816 }
180 817
181 } elsif (exists $cb_id{$type}) { 818 } elsif (exists $cb_id{$type}) {
182 _attach_cb $registry, %undo, $cb_id{$type}, $prio, shift @arg; 819 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
183 820
184 } elsif (ref $type) { 821 } elsif (ref $type) {
185 warn "attaching objects not supported, ignoring.\n"; 822 warn "attaching objects not supported, ignoring.\n";
186 823
187 } else { 824 } else {
188 shift @arg; 825 shift @arg;
189 warn "attach argument '$type' not supported, ignoring.\n"; 826 warn "attach argument '$type' not supported, ignoring.\n";
190 } 827 }
191 } 828 }
192
193 \%undo
194} 829}
195 830
196sub cf::object::attach { 831sub _object_attach {
197 die; 832 my ($obj, $name, %arg) = @_;
198}
199 833
200sub attach_global { 834 return if exists $obj->{_attachment}{$name};
201 _attach @CB_GLOBAL, KLASS_GLOBAL, @_
202}
203 835
204sub attach_to_type { 836 if (my $attach = $attachment{$name}) {
205 my $type = shift; 837 my $registry = $obj->registry;
206 838
207 _attach @{$CB_TYPE[$type]}, KLASS_OBJECT, @_ 839 for (@$attach) {
208} 840 my ($klass, @attach) = @$_;
841 _attach $registry, $klass, @attach;
842 }
209 843
210sub attach_to_objects { 844 $obj->{$name} = \%arg;
211 _attach @CB_OBJECT, KLASS_OBJECT, @_ 845 } else {
212} 846 warn "object uses attachment '$name' which is not available, postponing.\n";
847 }
213 848
214sub attach_to_players { 849 $obj->{_attachment}{$name} = undef;
215 _attach @CB_PLAYER, KLASS_PLAYER, @_
216} 850}
217 851
218sub attach_to_maps { 852sub cf::attachable::attach {
219 _attach @CB_MAP, KLASS_MAP, @_ 853 if (ref $_[0]) {
220} 854 _object_attach @_;
855 } else {
856 _attach shift->_attach_registry, @_;
857 }
858 _recalc_want;
859};
221 860
222sub register_attachment { 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 {
223 my $name = shift; 887 my \$name = shift;
224 888
225 $attachment{$name} = [@_]; 889 \$attachment{\$name} = [[KLASS_$klass, \@_]];
890 }
891 ";
892 die if $@;
226} 893}
227 894
228our $override; 895our $override;
229our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 896our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
230 897
231sub override { 898sub override {
232 $override = 1; 899 $override = 1;
233 @invoke_results = (); 900 @INVOKE_RESULTS = (@_);
234} 901}
235 902
236sub do_invoke { 903sub do_invoke {
237 my $event = shift; 904 my $event = shift;
238 my $callbacks = shift; 905 my $callbacks = shift;
239 906
240 @invoke_results = (); 907 @INVOKE_RESULTS = ();
241 908
242 local $override; 909 local $override;
243 910
244 for (@$callbacks) { 911 for (@$callbacks) {
245 eval { &{$_->[1]} }; 912 eval { &{$_->[1]} };
246 913
247 if ($@) { 914 if ($@) {
248 warn "$@"; 915 warn "$@";
249 warn "... while processing $EVENT[$event][0] event, skipping processing altogether.\n"; 916 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
250 override; 917 override;
251 } 918 }
252 919
253 return 1 if $override; 920 return 1 if $override;
254 } 921 }
255 922
256 0 923 0
257} 924}
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
258 939
259############################################################################# 940#############################################################################
260# object support 941# object support
942#
261 943
262sub instantiate { 944sub _can_merge {
945 my ($ob1, $ob2) = @_;
946
947 local $Storable::canonical = 1;
948 my $fob1 = Storable::freeze $ob1;
949 my $fob2 = Storable::freeze $ob2;
950
951 $fob1 eq $fob2
952}
953
954sub reattach {
955 # basically do the same as instantiate, without calling instantiate
263 my ($obj, $data) = @_; 956 my ($obj) = @_;
957
958 bless $obj, ref $obj; # re-bless in case extensions have been reloaded
959
264 my $registry = $obj->registry; 960 my $registry = $obj->registry;
265 961
266 $data = from_json $data; 962 @$registry = ();
267 963
268 for (@$data) { 964 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
269 my ($pri, $name, @args) = @$_;
270 965
966 for my $name (keys %{ $obj->{_attachment} || {} }) {
271 if (my $attach = $attachment{$name}) { 967 if (my $attach = $attachment{$name}) {
272 _attach @$registry, KLASS_OBJECT, @$attach;
273
274 if (my $cb = delete $registry->[EVENT_OBJECT_INSTANTIATE]) {
275 for (@$cb) { 968 for (@$attach) {
276 eval { $_->[1]->($obj, @args); }; 969 my ($klass, @attach) = @$_;
277 if ($@) { 970 _attach $registry, $klass, @attach;
278 warn "$@";
279 warn "... while processing '$name' instantiate with args <@args>\n";
280 }
281 }
282 } 971 }
283 } else { 972 } else {
284 warn "object uses attachment $name that is not available, postponing.\n"; 973 warn "object uses attachment '$name' that is not available, postponing.\n";
285 } 974 }
286
287 push @{$obj->{_attachment}}, $name;
288 } 975 }
289} 976}
290 977
291# basically do the same as instantiate, without calling instantiate 978cf::attachable->attach (
292sub reattach {
293 my ($obj) = @_;
294 my $registry = $obj->registry;
295
296 warn "reattach<@_, $_>\n";
297}
298
299attach_to_objects
300 prio => -1000000, 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,
301 on_clone => sub { 992 on_clone => sub {
302 my ($src, $dst) = @_; 993 my ($src, $dst) = @_;
303 994
304 @{$dst->registry} = @{$src->registry}; 995 @{$dst->registry} = @{$src->registry};
305 warn "registry clone ", join ":", @{$src->registry};#d#
306 996
307 %$dst = %$src; 997 %$dst = %$src;
308 998
309 $dst->{_attachment} = [@{ $src->{_attachment} }] 999 %{$dst->{_attachment}} = %{$src->{_attachment}}
310 if exists $src->{_attachment}; 1000 if exists $src->{_attachment};
311
312 warn "clone<@_>\n";#d#
313 }, 1001 },
314; 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
1056 or return;
1057
1058 unless (aio_stat "$filename.pst") {
1059 (aio_load "$filename.pst", $av) >= 0
1060 or return;
1061 $av = eval { (Storable::thaw $av)->{objs} };
1062 }
1063
1064 warn sprintf "loading %s (%d)\n",
1065 $filename, length $data, scalar @{$av || []};
1066 return ($data, $av);
1067}
1068
1069=head2 COMMAND CALLBACKS
1070
1071=over 4
1072
1073=cut
315 1074
316############################################################################# 1075#############################################################################
317# old plug-in events 1076# command handling &c
318 1077
319sub inject_event { 1078=item cf::register_command $name => \&callback($ob,$args);
320 my $extension = shift;
321 my $event_code = shift;
322 1079
323 my $cb = $hook[$event_code]{$extension} 1080Register a callback for execution when the client sends the user command
324 or return; 1081$name.
325 1082
326 &$cb 1083=cut
327}
328
329sub inject_global_event {
330 my $event = shift;
331
332 my $cb = $hook[$event]
333 or return;
334
335 List::Util::max map &$_, values %$cb
336}
337
338sub inject_command {
339 my ($name, $obj, $params) = @_;
340
341 for my $cmd (@{ $command{$name} }) {
342 $cmd->[1]->($obj, $params);
343 }
344
345 -1
346}
347 1084
348sub register_command { 1085sub register_command {
349 my ($name, $time, $cb) = @_; 1086 my ($name, $cb) = @_;
350 1087
351 my $caller = caller; 1088 my $caller = caller;
352 #warn "registering command '$name/$time' to '$caller'"; 1089 #warn "registering command '$name/$time' to '$caller'";
353 1090
354 push @{ $command{$name} }, [$time, $cb, $caller]; 1091 push @{ $COMMAND{$name} }, [$caller, $cb];
355 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
356} 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
357 1117
358sub register_extcmd { 1118sub register_extcmd {
359 my ($name, $cb) = @_; 1119 my ($name, $cb) = @_;
360 1120
361 my $caller = caller; 1121 $EXTCMD{$name} = $cb;
362 #warn "registering extcmd '$name' to '$caller'";
363
364 $extcmd{$name} = [$cb, $caller];
365} 1122}
366 1123
367sub register { 1124sub register_exticmd {
368 my ($base, $pkg) = @_; 1125 my ($name, $cb) = @_;
369 1126
370 #TODO 1127 $EXTICMD{$name} = $cb;
371} 1128}
372 1129
373sub load_extension { 1130cf::player->attach (
374 my ($path) = @_; 1131 on_command => sub {
1132 my ($pl, $name, $params) = @_;
375 1133
376 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 1134 my $cb = $COMMAND{$name}
377 my $base = $1; 1135 or return;
378 my $pkg = $1;
379 $pkg =~ s/[^[:word:]]/_/g;
380 $pkg = "ext::$pkg";
381 1136
382 warn "loading '$path' into '$pkg'\n"; 1137 for my $cmd (@$cb) {
383 1138 $cmd->[1]->($pl->ob, $params);
384 open my $fh, "<:utf8", $path
385 or die "$path: $!";
386
387 my $source =
388 "package $pkg; use strict; use utf8;\n"
389 . "#line 1 \"$path\"\n{\n"
390 . (do { local $/; <$fh> })
391 . "\n};\n1";
392
393 eval $source
394 or die "$path: $@";
395
396 push @exts, $pkg;
397 $ext_pkg{$base} = $pkg;
398
399# no strict 'refs';
400# @{"$pkg\::ISA"} = ext::;
401
402 register $base, $pkg;
403}
404
405sub unload_extension {
406 my ($pkg) = @_;
407
408 warn "removing extension $pkg\n";
409
410 # remove hooks
411 #TODO
412# for my $idx (0 .. $#PLUGIN_EVENT) {
413# delete $hook[$idx]{$pkg};
414# }
415
416 # remove commands
417 for my $name (keys %command) {
418 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} };
419
420 if (@cb) {
421 $command{$name} = \@cb;
422 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
423 } else {
424 delete $command{$name};
425 delete $COMMAND{"$name\000"};
426 }
427 }
428
429 # remove extcmds
430 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) {
431 delete $extcmd{$name};
432 }
433
434 if (my $cb = $pkg->can ("unload")) {
435 eval {
436 $cb->($pkg);
437 1
438 } or warn "$pkg unloaded, but with errors: $@";
439 }
440
441 Symbol::delete_package $pkg;
442}
443
444sub load_extensions {
445 my $LIBDIR = maps_directory "perl";
446
447 for my $ext (<$LIBDIR/*.ext>) {
448 next unless -r $ext;
449 eval {
450 load_extension $ext;
451 1
452 } or warn "$ext not loaded: $@";
453 }
454}
455
456sub _perl_reload(&) {
457 my ($msg) = @_;
458
459 $msg->("reloading...");
460
461 eval {
462 # 1. cancel all watchers
463 $_->cancel for Event::all_watchers;
464
465 # 2. unload all extensions
466 for (@exts) {
467 $msg->("unloading <$_>");
468 unload_extension $_;
469 }
470
471 # 3. unload all modules loaded from $LIBDIR
472 while (my ($k, $v) = each %INC) {
473 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
474
475 $msg->("removing <$k>");
476 delete $INC{$k};
477
478 $k =~ s/\.pm$//;
479 $k =~ s/\//::/g;
480
481 if (my $cb = $k->can ("unload_module")) {
482 $cb->();
483 }
484
485 Symbol::delete_package $k;
486 }
487
488 # 4. get rid of safe::, as good as possible
489 Symbol::delete_package "safe::$_"
490 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
491
492 # 5. remove register_script_function callbacks
493 # TODO
494
495 # 6. unload cf.pm "a bit"
496 delete $INC{"cf.pm"};
497
498 # don't, removes xs symbols, too,
499 # and global variables created in xs
500 #Symbol::delete_package __PACKAGE__;
501
502 # 7. reload cf.pm
503 $msg->("reloading cf.pm");
504 require cf;
505 };
506 $msg->($@) if $@;
507
508 $msg->("reloaded");
509};
510
511sub perl_reload() {
512 _perl_reload {
513 warn $_[0];
514 print "$_[0]\n";
515 };
516}
517
518register_command "perl-reload", 0, sub {
519 my ($who, $arg) = @_;
520
521 if ($who->flag (FLAG_WIZ)) {
522 _perl_reload {
523 warn $_[0];
524 $who->message ($_[0]);
525 }; 1139 }
1140
1141 cf::override;
526 } 1142 },
527};
528
529#############################################################################
530# extcmd framework, basically convert ext <msg>
531# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
532
533attach_to_players
534 on_extcmd => sub { 1143 on_extcmd => sub {
535 my ($pl, $buf) = @_; 1144 my ($pl, $buf) = @_;
536 1145
537 my $msg = eval { from_json $buf }; 1146 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
538 1147
539 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
540 if (my $cb = $extcmd{$msg->{msgtype}}) { 1154 if (my $cb = $EXTCMD{$type}) {
541 if (my %reply = $cb->[0]->($pl, $msg)) { 1155 my @reply = $cb->($pl, @payload);
1156
542 $pl->ext_reply ($msg->{msgid}, %reply); 1157 $pl->ext_reply ($reply, @reply)
543 } 1158 if $reply;
544 } 1159 }
545 } else { 1160 } else {
546 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1161 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
547 } 1162 }
548 1163
549 cf::override; 1164 cf::override;
550 }, 1165 },
551; 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}
552 1240
553############################################################################# 1241#############################################################################
554# load/save/clean perl data associated with a map
555 1242
556*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 {
557 my ($map) = @_; 1922 my ($map) = @_;
558 1923
559 my $path = $map->tmpname; 1924 my @neigh; # diagonal neighbours
560 defined $path or return;
561 1925
562 unlink "$path.cfperl"; 1926 for (0 .. 3) {
563}; 1927 my $neigh = $map->tile_path ($_)
1928 or next;
1929 $neigh = find $neigh, $map
1930 or next;
1931 $neigh->load;
564 1932
565*cf::mapsupport::on_swapin = 1933 push @neigh,
566*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 {
567 my ($map) = @_; 1953 my ($map) = @_;
568 1954
569 my $path = $map->tmpname; 1955 cf::sync_job { $map->load };
570 $path = $map->path unless defined $path; 1956}
571 1957
572 open my $fh, "<:raw", "$path.cfperl" 1958our %MAP_PREFETCH;
573 or return; # no perl data 1959our $MAP_PREFETCHER = undef;
574 1960
575 my $data = Storable::thaw do { local $/; <$fh> }; 1961sub find_async {
1962 my ($path, $origin) = @_;
576 1963
577 $data->{version} <= 1 1964 $path = normalise $path, $origin && $origin->{path};
578 or return; # too new
579 1965
580 $map->_set_obs ($data->{obs}); 1966 if (my $map = $cf::MAP{$path}) {
581}; 1967 return $map if $map->in_memory == cf::MAP_IN_MEMORY;
1968 }
582 1969
583*cf::mapsupport::on_swapout = sub { 1970 undef $MAP_PREFETCH{$path};
584 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 }
585 1977
586 my $path = $map->tmpname; 1978 delete $MAP_PREFETCH{$path};
587 $path = $map->path unless defined $path; 1979 }
588
589 my $obs = $map->_get_obs;
590
591 if (defined $obs) {
592 open my $fh, ">:raw", "$path.cfperl"
593 or die "$path.cfperl: $!";
594
595 stat $path;
596
597 print $fh Storable::nfreeze {
598 size => (stat _)[7],
599 time => (stat _)[9],
600 version => 1,
601 obs => $obs,
602 }; 1980 }
1981 undef $MAP_PREFETCHER;
1982 };
1983 $MAP_PREFETCHER->prio (6);
603 1984
604 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);
605 } else { 2013 } else {
606 unlink "$path.cfperl"; 2014 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
607 }
608};
609
610attach_to_maps prio => -10000, package => cf::mapsupport::;
611
612#############################################################################
613# load/save perl data associated with player->ob objects
614
615sub all_objects(@) {
616 @_, map all_objects ($_->inv), @_
617}
618
619attach_to_players
620 on_load => sub {
621 my ($pl, $path) = @_;
622
623 for my $o (all_objects $pl->ob) {
624 if (my $value = $o->get_ob_key_value ("_perl_data")) {
625 $o->set_ob_key_value ("_perl_data");
626
627 %$o = %{ Storable::thaw pack "H*", $value };
628 }
629 }
630 }, 2015 }
631 on_save => sub { 2016}
632 my ($pl, $path) = @_;
633 2017
634 $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_) 2018sub swap_out {
635 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;
636 }, 2069 }
637;
638 2070
639############################################################################# 2071 delete $cf::MAP{$self->path};
640# core extensions - in perl
641 2072
642=item cf::player::exists $login 2073 $self->clear;
643 2074
644Returns true when the given account exists. 2075 $_->clear_links_to ($self) for values %cf::MAP;
645 2076
646=cut 2077 $self->unlink_save;
647 2078 $self->destroy;
648sub cf::player::exists($) {
649 cf::player::find $_[0]
650 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
651} 2079}
652 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
653=item $player->reply ($npc, $msg[, $flags]) 2190=item $player_object->reply ($npc, $msg[, $flags])
654 2191
655Sends 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>
656can 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
657dialogue with the given NPC character. 2194dialogue with the given NPC character.
658 2195
659=cut 2196=cut
660 2197
661# rough implementation of a future "reply" method that works 2198# rough implementation of a future "reply" method that works
662# with dialog boxes. 2199# with dialog boxes.
2200#TODO: the first argument must go, split into a $npc->reply_to ( method
663sub cf::object::player::reply($$$;$) { 2201sub cf::object::player::reply($$$;$) {
664 my ($self, $npc, $msg, $flags) = @_; 2202 my ($self, $npc, $msg, $flags) = @_;
665 2203
666 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2204 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
667 2205
668 if ($self->{record_replies}) { 2206 if ($self->{record_replies}) {
669 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2207 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2208
670 } 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 {
671 $msg = $npc->name . " says: $msg" if $npc; 2217 $msg = $npc->name . " says: $msg" if $npc;
672 $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,
673 } 2388 };
674}
675 2389
676=item $player->ext_reply ($msgid, $msgtype, %msg) 2390 for (split /\n/, $spec) {
2391 my ($k, $v) = split /\s+/, $_, 2;
677 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
678Sends an ext reply to the player. 2555Sends an ext event to the client.
679 2556
680=cut 2557=cut
681 2558
682sub cf::player::ext_reply($$$%) { 2559sub cf::client::ext_msg($$@) {
683 my ($self, $id, %msg) = @_; 2560 my ($self, $type, @msg) = @_;
684 2561
685 $msg{msgid} = $id; 2562 my $extcmd = $self->extcmd;
686 2563
687 $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 }
688} 2570}
689 2571
690############################################################################# 2572=item $success = $client->query ($flags, "text", \&cb)
691# 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
692 2695
693our $safe = new Safe "safe"; 2696our $safe = new Safe "safe";
694our $safe_hole = new Safe::Hole; 2697our $safe_hole = new Safe::Hole;
695 2698
696$SIG{FPE} = 'IGNORE'; 2699$SIG{FPE} = 'IGNORE';
697 2700
698$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));
699 2706
700# here we export the classes and methods available to script code 2707# here we export the classes and methods available to script code
701 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
702for ( 2728for (
703 ["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)],
704 ["cf::object::player" => qw(player)], 2731 ["cf::object::player" => qw(player)],
705 ["cf::player" => qw(peaceful)], 2732 ["cf::player" => qw(peaceful)],
2733 ["cf::map" => qw(trigger)],
706) { 2734) {
707 no strict 'refs'; 2735 no strict 'refs';
708 my ($pkg, @funs) = @$_; 2736 my ($pkg, @funs) = @$_;
709 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 2737 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
710 for @funs; 2738 for @funs;
711} 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
712 2752
713sub safe_eval($;@) { 2753sub safe_eval($;@) {
714 my ($code, %vars) = @_; 2754 my ($code, %vars) = @_;
715 2755
716 my $qcode = $code; 2756 my $qcode = $code;
… …
739 } 2779 }
740 2780
741 wantarray ? @res : $res[0] 2781 wantarray ? @res : $res[0]
742} 2782}
743 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
744sub register_script_function { 2799sub register_script_function {
745 my ($fun, $cb) = @_; 2800 my ($fun, $cb) = @_;
746 2801
747 no strict 'refs'; 2802 no strict 'refs';
748 *{"safe::$fun"} = $safe_hole->wrap ($cb); 2803 *{"safe::$fun"} = $safe_hole->wrap ($cb);
749} 2804}
750 2805
2806=back
2807
2808=cut
2809
751############################################################################# 2810#############################################################################
752# 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}
753 2999
754sub 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;
755 Event::loop; 3014 Event::loop;
756} 3015}
757 3016
758############################################################################# 3017#############################################################################
759# initialisation 3018# initialisation and cleanup
760 3019
761register "<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};
762 3261
763unshift @INC, $LIBDIR; 3262unshift @INC, $LIBDIR;
764 3263
765load_extensions; 3264my $bug_warning = 0;
766 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;
767$TICK_WATCHER = Event->timer ( 3289$TICK_WATCHER = Event->timer (
3290 reentrant => 0,
3291 parked => 1,
768 prio => 1, 3292 prio => 0,
769 at => $NEXT_TICK || 1, 3293 at => $NEXT_TICK || $TICK,
3294 data => WF_AUTOCANCEL,
770 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
771 cf::server_tick; # one server iteration 3304 cf::server_tick; # one server iteration
772 3305
3306 0 && sync_job {#d#
3307 for(1..10) {
773 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;
774 $NEXT_TICK += $TICK; 3330 $NEXT_TICK += $TICK;
775 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
776 # if we are delayed by four ticks, skip them all 3352 # if we are delayed by four ticks or more, skip them all
777 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 3353 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
778 3354
779 $TICK_WATCHER->at ($NEXT_TICK); 3355 $TICK_WATCHER->at ($NEXT_TICK);
780 $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
781 }, 3364 },
782); 3365);
783 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
7841 34751
785 3476

Diff Legend

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