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.333 by root, Sun Aug 19 09:14:50 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 warn "loading facedata from $path\n";
2817
2818 my $facedata;
2819 0 < aio_load $path, $facedata
2820 or die "$path: $!";
2821
2822 $facedata = Coro::Storable::thaw $facedata;
2823
2824 $facedata->{version} == 2
2825 or cf::cleanup "$path: version mismatch, cannot proceed.";
2826
2827 {
2828 my $faces = $facedata->{faceinfo};
2829
2830 while (my ($face, $info) = each %$faces) {
2831 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2832 cf::face::set_visibility $idx, $info->{visibility};
2833 cf::face::set_magicmap $idx, $info->{magicmap};
2834 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2835 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2836
2837 cf::cede_to_tick;
2838 }
2839
2840 while (my ($face, $info) = each %$faces) {
2841 next unless $info->{smooth};
2842 my $idx = cf::face::find $face
2843 or next;
2844 if (my $smooth = cf::face::find $info->{smooth}) {
2845 cf::face::set_smooth $idx, $smooth;
2846 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2847 } else {
2848 warn "smooth face '$info->{smooth}' not found for face '$face'";
2849 }
2850
2851 cf::cede_to_tick;
2852 }
2853 }
2854
2855 {
2856 my $anims = $facedata->{animinfo};
2857
2858 while (my ($anim, $info) = each %$anims) {
2859 cf::anim::set $anim, $info->{frames}, $info->{facings};
2860 cf::cede_to_tick;
2861 }
2862
2863 cf::anim::invalidate_all; # d'oh
2864 }
2865
2866 {
2867 # TODO: for gcfclient pleasure, we should give resources
2868 # that gcfclient doesn't grok a >10000 face index.
2869 my $res = $facedata->{resource};
2870 my $enc = JSON::XS->new->utf8->canonical;
2871
2872 my $soundconf = delete $res->{"res/sound.conf"};
2873
2874 while (my ($name, $info) = each %$res) {
2875 my $meta = $enc->encode ({
2876 name => $name,
2877 %{ $info->{meta} || {} },
2878 });
2879
2880 my $idx = (cf::face::find $name) || cf::face::alloc $name;
2881
2882 if ($info->{type} & 1) {
2883 # prepend meta info
2884
2885 my $data = pack "(w/a*)*", $meta, $info->{data};
2886 my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
2887
2888 cf::face::set_data $idx, 0, $data, $chk;
2889 } else {
2890 cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};
2891 }
2892
2893 cf::face::set_type $idx, $info->{type};
2894
2895 cf::cede_to_tick;
2896 }
2897
2898 if ($soundconf) {
2899 $soundconf = $enc->decode (delete $soundconf->{data});
2900
2901 for (0 .. SOUND_CAST_SPELL_0 - 1) {
2902 my $sound = $soundconf->{compat}[$_]
2903 or next;
2904
2905 my $face = cf::face::find "sound/$sound->[1]";
2906 cf::sound::set $sound->[0] => $face;
2907 cf::sound::old_sound_index $_, $face; # gcfclient-compat
2908 }
2909
2910 while (my ($k, $v) = each %{$soundconf->{event}}) {
2911 my $face = cf::face::find "sound/$v";
2912 cf::sound::set $k => $face;
2913 }
2914 }
2915 }
2916
2917 1
2918}
2919
2920register_exticmd fx_want => sub {
2921 my ($ns, $want) = @_;
2922
2923 while (my ($k, $v) = each %$want) {
2924 $ns->fx_want ($k, $v);
2925 }
2926};
2927
2928sub reload_regions {
2929 load_resource_file "$MAPDIR/regions"
2930 or die "unable to load regions file\n";
2931
2932 for (cf::region::list) {
2933 $_->{match} = qr/$_->{match}/
2934 if exists $_->{match};
2935 }
2936}
2937
2938sub reload_facedata {
2939 load_facedata "$DATADIR/facedata"
2940 or die "unable to load facedata\n";
2941}
2942
2943sub reload_archetypes {
2944 load_resource_file "$DATADIR/archetypes"
2945 or die "unable to load archetypes\n";
2946 #d# NEED to laod twice to resolve forward references
2947 # this really needs to be done in an extra post-pass
2948 # (which needs to be synchronous, so solve it differently)
2949 load_resource_file "$DATADIR/archetypes"
2950 or die "unable to load archetypes\n";
2951}
2952
2953sub reload_treasures {
2954 load_resource_file "$DATADIR/treasures"
2955 or die "unable to load treasurelists\n";
2956}
2957
2958sub reload_resources {
2959 warn "reloading resource files...\n";
2960
2961 reload_regions;
2962 reload_facedata;
2963 #reload_archetypes;#d#
2964 reload_archetypes;
2965 reload_treasures;
2966
2967 warn "finished reloading resource files\n";
2968}
2969
2970sub init {
2971 reload_resources;
2972}
2973
2974sub cfg_load {
2975 open my $fh, "<:utf8", "$CONFDIR/config"
2976 or return;
2977
2978 local $/;
2979 *CFG = YAML::Syck::Load <$fh>;
2980
2981 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
2982
2983 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2984 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
2985
2986 if (exists $CFG{mlockall}) {
2987 eval {
2988 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
2989 and die "WARNING: m(un)lockall failed: $!\n";
2990 };
2991 warn $@ if $@;
2992 }
2993}
753 2994
754sub main { 2995sub main {
2996 # we must not ever block the main coroutine
2997 local $Coro::idle = sub {
2998 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2999 (async {
3000 Event::one_event;
3001 })->prio (Coro::PRIO_MAX);
3002 };
3003
3004 cfg_load;
3005 db_init;
3006 load_extensions;
3007
3008 $TICK_WATCHER->start;
755 Event::loop; 3009 Event::loop;
756} 3010}
757 3011
758############################################################################# 3012#############################################################################
759# initialisation 3013# initialisation and cleanup
760 3014
761register "<global>", __PACKAGE__; 3015# install some emergency cleanup handlers
3016BEGIN {
3017 for my $signal (qw(INT HUP TERM)) {
3018 Event->signal (
3019 reentrant => 0,
3020 data => WF_AUTOCANCEL,
3021 signal => $signal,
3022 prio => 0,
3023 cb => sub {
3024 cf::cleanup "SIG$signal";
3025 },
3026 );
3027 }
3028}
3029
3030sub write_runtime {
3031 my $runtime = "$LOCALDIR/runtime";
3032
3033 # first touch the runtime file to show we are still running:
3034 # the fsync below can take a very very long time.
3035
3036 IO::AIO::aio_utime $runtime, undef, undef;
3037
3038 my $guard = cf::lock_acquire "write_runtime";
3039
3040 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
3041 or return;
3042
3043 my $value = $cf::RUNTIME + 90 + 10;
3044 # 10 is the runtime save interval, for a monotonic clock
3045 # 60 allows for the watchdog to kill the server.
3046
3047 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3048 and return;
3049
3050 # always fsync - this file is important
3051 aio_fsync $fh
3052 and return;
3053
3054 # touch it again to show we are up-to-date
3055 aio_utime $fh, undef, undef;
3056
3057 close $fh
3058 or return;
3059
3060 aio_rename "$runtime~", $runtime
3061 and return;
3062
3063 warn "runtime file written.\n";
3064
3065 1
3066}
3067
3068sub emergency_save() {
3069 my $freeze_guard = cf::freeze_mainloop;
3070
3071 warn "enter emergency perl save\n";
3072
3073 cf::sync_job {
3074 # use a peculiar iteration method to avoid tripping on perl
3075 # refcount bugs in for. also avoids problems with players
3076 # and maps saved/destroyed asynchronously.
3077 warn "begin emergency player save\n";
3078 for my $login (keys %cf::PLAYER) {
3079 my $pl = $cf::PLAYER{$login} or next;
3080 $pl->valid or next;
3081 $pl->save;
3082 }
3083 warn "end emergency player save\n";
3084
3085 warn "begin emergency map save\n";
3086 for my $path (keys %cf::MAP) {
3087 my $map = $cf::MAP{$path} or next;
3088 $map->valid or next;
3089 $map->save;
3090 }
3091 warn "end emergency map save\n";
3092
3093 warn "begin emergency database checkpoint\n";
3094 BDB::db_env_txn_checkpoint $DB_ENV;
3095 warn "end emergency database checkpoint\n";
3096 };
3097
3098 warn "leave emergency perl save\n";
3099}
3100
3101sub post_cleanup {
3102 my ($make_core) = @_;
3103
3104 warn Carp::longmess "post_cleanup backtrace"
3105 if $make_core;
3106}
3107
3108sub do_reload_perl() {
3109 # can/must only be called in main
3110 if ($Coro::current != $Coro::main) {
3111 warn "can only reload from main coroutine";
3112 return;
3113 }
3114
3115 warn "reloading...";
3116
3117 warn "entering sync_job";
3118
3119 cf::sync_job {
3120 cf::write_runtime; # external watchdog should not bark
3121 cf::emergency_save;
3122 cf::write_runtime; # external watchdog should not bark
3123
3124 warn "syncing database to disk";
3125 BDB::db_env_txn_checkpoint $DB_ENV;
3126
3127 # if anything goes wrong in here, we should simply crash as we already saved
3128
3129 warn "cancelling all WF_AUTOCANCEL watchers";
3130 for (Event::all_watchers) {
3131 $_->cancel if $_->data & WF_AUTOCANCEL;
3132 }
3133
3134 warn "flushing outstanding aio requests";
3135 for (;;) {
3136 BDB::flush;
3137 IO::AIO::flush;
3138 Coro::cede;
3139 last unless IO::AIO::nreqs || BDB::nreqs;
3140 warn "iterate...";
3141 }
3142
3143 ++$RELOAD;
3144
3145 warn "cancelling all extension coros";
3146 $_->cancel for values %EXT_CORO;
3147 %EXT_CORO = ();
3148
3149 warn "removing commands";
3150 %COMMAND = ();
3151
3152 warn "removing ext/exti commands";
3153 %EXTCMD = ();
3154 %EXTICMD = ();
3155
3156 warn "unloading/nuking all extensions";
3157 for my $pkg (@EXTS) {
3158 warn "... unloading $pkg";
3159
3160 if (my $cb = $pkg->can ("unload")) {
3161 eval {
3162 $cb->($pkg);
3163 1
3164 } or warn "$pkg unloaded, but with errors: $@";
3165 }
3166
3167 warn "... nuking $pkg";
3168 Symbol::delete_package $pkg;
3169 }
3170
3171 warn "unloading all perl modules loaded from $LIBDIR";
3172 while (my ($k, $v) = each %INC) {
3173 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3174
3175 warn "... unloading $k";
3176 delete $INC{$k};
3177
3178 $k =~ s/\.pm$//;
3179 $k =~ s/\//::/g;
3180
3181 if (my $cb = $k->can ("unload_module")) {
3182 $cb->();
3183 }
3184
3185 Symbol::delete_package $k;
3186 }
3187
3188 warn "getting rid of safe::, as good as possible";
3189 Symbol::delete_package "safe::$_"
3190 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3191
3192 warn "unloading cf.pm \"a bit\"";
3193 delete $INC{"cf.pm"};
3194 delete $INC{"cf/pod.pm"};
3195
3196 # don't, removes xs symbols, too,
3197 # and global variables created in xs
3198 #Symbol::delete_package __PACKAGE__;
3199
3200 warn "unload completed, starting to reload now";
3201
3202 warn "reloading cf.pm";
3203 require cf;
3204 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3205
3206 warn "loading config and database again";
3207 cf::cfg_load;
3208
3209 warn "loading extensions";
3210 cf::load_extensions;
3211
3212 warn "reattaching attachments to objects/players";
3213 _global_reattach; # objects, sockets
3214 warn "reattaching attachments to maps";
3215 reattach $_ for values %MAP;
3216 warn "reattaching attachments to players";
3217 reattach $_ for values %PLAYER;
3218
3219 warn "leaving sync_job";
3220
3221 1
3222 } or do {
3223 warn $@;
3224 warn "error while reloading, exiting.";
3225 exit 1;
3226 };
3227
3228 warn "reloaded";
3229};
3230
3231our $RELOAD_WATCHER; # used only during reload
3232
3233sub reload_perl() {
3234 # doing reload synchronously and two reloads happen back-to-back,
3235 # coro crashes during coro_state_free->destroy here.
3236
3237 $RELOAD_WATCHER ||= Event->timer (
3238 reentrant => 0,
3239 after => 0,
3240 data => WF_AUTOCANCEL,
3241 cb => sub {
3242 do_reload_perl;
3243 undef $RELOAD_WATCHER;
3244 },
3245 );
3246}
3247
3248register_command "reload" => sub {
3249 my ($who, $arg) = @_;
3250
3251 if ($who->flag (FLAG_WIZ)) {
3252 $who->message ("reloading server.");
3253 async { reload_perl };
3254 }
3255};
762 3256
763unshift @INC, $LIBDIR; 3257unshift @INC, $LIBDIR;
764 3258
765load_extensions; 3259my $bug_warning = 0;
766 3260
3261our @WAIT_FOR_TICK;
3262our @WAIT_FOR_TICK_BEGIN;
3263
3264sub wait_for_tick {
3265 return unless $TICK_WATCHER->is_active;
3266 return if $Coro::current == $Coro::main;
3267
3268 my $signal = new Coro::Signal;
3269 push @WAIT_FOR_TICK, $signal;
3270 $signal->wait;
3271}
3272
3273sub wait_for_tick_begin {
3274 return unless $TICK_WATCHER->is_active;
3275 return if $Coro::current == $Coro::main;
3276
3277 my $signal = new Coro::Signal;
3278 push @WAIT_FOR_TICK_BEGIN, $signal;
3279 $signal->wait;
3280}
3281
3282 my $min = 1e6;#d#
3283 my $avg = 10;
767$TICK_WATCHER = Event->timer ( 3284$TICK_WATCHER = Event->timer (
3285 reentrant => 0,
3286 parked => 1,
768 prio => 1, 3287 prio => 0,
769 at => $NEXT_TICK || 1, 3288 at => $NEXT_TICK || $TICK,
3289 data => WF_AUTOCANCEL,
770 cb => sub { 3290 cb => sub {
3291 if ($Coro::current != $Coro::main) {
3292 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3293 unless ++$bug_warning > 10;
3294 return;
3295 }
3296
3297 $NOW = $tick_start = Event::time;
3298
771 cf::server_tick; # one server iteration 3299 cf::server_tick; # one server iteration
772 3300
3301 0 && sync_job {#d#
3302 for(1..10) {
773 my $NOW = Event::time; 3303 my $t = Event::time;
3304 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3305 or die;
3306
3307 $map->width (50);
3308 $map->height (50);
3309 $map->alloc;
3310 $map->_load_objects ("/tmp/x.map", 1);
3311 my $t = Event::time - $t;
3312
3313 #next unless $t < 0.0013;#d#
3314 if ($t < $min) {
3315 $min = $t;
3316 }
3317 $avg = $avg * 0.99 + $t * 0.01;
3318 }
3319 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3320 exit 0;
3321 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3322 };
3323
3324 $RUNTIME += $TICK;
774 $NEXT_TICK += $TICK; 3325 $NEXT_TICK += $TICK;
775 3326
3327 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3328 $NEXT_RUNTIME_WRITE = $NOW + 10;
3329 Coro::async_pool {
3330 write_runtime
3331 or warn "ERROR: unable to write runtime file: $!";
3332 };
3333 }
3334
3335# my $AFTER = Event::time;
3336# warn $AFTER - $NOW;#d#
3337
3338 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3339 $sig->send;
3340 }
3341 while (my $sig = shift @WAIT_FOR_TICK) {
3342 $sig->send;
3343 }
3344
3345 $NOW = Event::time;
3346
776 # if we are delayed by four ticks, skip them all 3347 # if we are delayed by four ticks or more, skip them all
777 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 3348 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
778 3349
779 $TICK_WATCHER->at ($NEXT_TICK); 3350 $TICK_WATCHER->at ($NEXT_TICK);
780 $TICK_WATCHER->start; 3351 $TICK_WATCHER->start;
3352
3353 $LOAD = ($NOW - $tick_start) / $TICK;
3354 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3355
3356 _post_tick;
3357
3358
781 }, 3359 },
782); 3360);
783 3361
3362{
3363 BDB::max_poll_time $TICK * 0.1;
3364 $BDB_POLL_WATCHER = Event->io (
3365 reentrant => 0,
3366 fd => BDB::poll_fileno,
3367 poll => 'r',
3368 prio => 0,
3369 data => WF_AUTOCANCEL,
3370 cb => \&BDB::poll_cb,
3371 );
3372 BDB::min_parallel 8;
3373
3374 BDB::set_sync_prepare {
3375 my $status;
3376 my $current = $Coro::current;
3377 (
3378 sub {
3379 $status = $!;
3380 $current->ready; undef $current;
3381 },
3382 sub {
3383 Coro::schedule while defined $current;
3384 $! = $status;
3385 },
3386 )
3387 };
3388
3389 unless ($DB_ENV) {
3390 $DB_ENV = BDB::db_env_create;
3391
3392 cf::sync_job {
3393 eval {
3394 BDB::db_env_open
3395 $DB_ENV,
3396 $BDBDIR,
3397 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3398 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3399 0666;
3400
3401 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3402
3403 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3404 $DB_ENV->set_lk_detect;
3405 };
3406
3407 cf::cleanup "db_env_open(db): $@" if $@;
3408 };
3409 }
3410}
3411
3412{
3413 IO::AIO::min_parallel 8;
3414
3415 undef $Coro::AIO::WATCHER;
3416 IO::AIO::max_poll_time $TICK * 0.1;
3417 $AIO_POLL_WATCHER = Event->io (
3418 reentrant => 0,
3419 data => WF_AUTOCANCEL,
3420 fd => IO::AIO::poll_fileno,
3421 poll => 'r',
3422 prio => 6,
3423 cb => \&IO::AIO::poll_cb,
3424 );
3425}
3426
3427my $_log_backtrace;
3428
3429sub _log_backtrace {
3430 my ($msg, @addr) = @_;
3431
3432 $msg =~ s/\n//;
3433
3434 # limit the # of concurrent backtraces
3435 if ($_log_backtrace < 2) {
3436 ++$_log_backtrace;
3437 async {
3438 my @bt = fork_call {
3439 @addr = map { sprintf "%x", $_ } @addr;
3440 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3441 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3442 or die "addr2line: $!";
3443
3444 my @funcs;
3445 my @res = <$fh>;
3446 chomp for @res;
3447 while (@res) {
3448 my ($func, $line) = splice @res, 0, 2, ();
3449 push @funcs, "[$func] $line";
3450 }
3451
3452 @funcs
3453 };
3454
3455 LOG llevInfo, "[ABT] $msg\n";
3456 LOG llevInfo, "[ABT] $_\n" for @bt;
3457 --$_log_backtrace;
3458 };
3459 } else {
3460 LOG llevInfo, "[ABT] $msg\n";
3461 LOG llevInfo, "[ABT] [suppressed]\n";
3462 }
3463}
3464
3465# load additional modules
3466use cf::pod;
3467
3468END { cf::emergency_save }
3469
7841 34701
785 3471

Diff Legend

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