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.23 by root, Wed Jul 19 22:19:19 2006 UTC vs.
Revision 1.273 by root, Mon Jun 4 12:19:08 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.61 ();
16use Coro::State;
17use Coro::Handle;
10use Event; 18use Coro::Event;
19use Coro::Timer;
20use Coro::Signal;
21use Coro::Semaphore;
22use Coro::AIO;
23use Coro::Storable;
24
25use BDB ();
26use Data::Dumper;
27use Digest::MD5;
28use Fcntl;
29use YAML::Syck ();
30use IO::AIO 2.32 ();
31use Time::HiRes;
32use Compress::LZF;
33
34# configure various modules to our taste
35#
36$Storable::canonical = 1; # reduce rsync transfers
37Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
38Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
39
11$Event::Eval = 1; # no idea why this is required, but it is 40$Event::Eval = 1; # no idea why this is required, but it is
12 41
13use strict; 42# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
43$YAML::Syck::ImplicitUnicode = 1;
14 44
15our %COMMAND; 45$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
46
47sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
48
49our %COMMAND = ();
50our %COMMAND_TIME = ();
51
52our @EXTS = (); # list of extension package names
53our %EXTCMD = ();
54our %EXT_CORO = (); # coroutines bound to extensions
55our %EXT_MAP = (); # pluggable maps
56
57our $RELOAD; # number of reloads so far
16our @EVENT; 58our @EVENT;
17our %PROP_TYPE; 59
18our %PROP_IDX; 60our $CONFDIR = confdir;
61our $DATADIR = datadir;
62our $LIBDIR = "$DATADIR/ext";
63our $PODDIR = "$DATADIR/pod";
64our $MAPDIR = "$DATADIR/" . mapdir;
65our $LOCALDIR = localdir;
66our $TMPDIR = "$LOCALDIR/" . tmpdir;
67our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
68our $PLAYERDIR = "$LOCALDIR/" . playerdir;
69our $RANDOMDIR = "$LOCALDIR/random";
70our $BDBDIR = "$LOCALDIR/db";
71
72our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
73our $TICK_WATCHER;
74our $AIO_POLL_WATCHER;
75our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
76our $NEXT_TICK;
77our $NOW;
78our $USE_FSYNC = 1; # use fsync to write maps - default off
79
80our $BDB_POLL_WATCHER;
81our $DB_ENV;
82
83our %CFG;
84
85our $UPTIME; $UPTIME ||= time;
86our $RUNTIME;
87
88our %PLAYER; # all users
89our %MAP; # all maps
90our $LINK_MAP; # the special {link} map, which is always available
91
92# used to convert map paths into valid unix filenames by replacing / by ∕
93our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
94
95our $LOAD; # a number between 0 (idle) and 1 (too many objects)
96our $LOADAVG; # same thing, but with alpha-smoothing
97our $tick_start; # for load detecting purposes
98
99binmode STDOUT;
100binmode STDERR;
101
102# read virtual server time, if available
103unless ($RUNTIME || !-e "$LOCALDIR/runtime") {
104 open my $fh, "<", "$LOCALDIR/runtime"
105 or die "unable to read runtime file: $!";
106 $RUNTIME = <$fh> + 0.;
107}
108
109mkdir $_
110 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
111
112our $EMERGENCY_POSITION;
113
114sub cf::map::normalise;
115
116#############################################################################
117
118=head2 GLOBAL VARIABLES
119
120=over 4
121
122=item $cf::UPTIME
123
124The timestamp of the server start (so not actually an uptime).
125
126=item $cf::RUNTIME
127
128The time this server has run, starts at 0 and is increased by $cf::TICK on
129every server tick.
130
131=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
132$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
133$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
134
135Various directories - "/etc", read-only install directory, perl-library
136directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
137unique-items directory, player file directory, random maps directory and
138database environment.
139
140=item $cf::NOW
141
142The time of the last (current) server tick.
143
144=item $cf::TICK
145
146The interval between server ticks, in seconds.
147
148=item $cf::LOADAVG
149
150The current CPU load on the server (alpha-smoothed), as a value between 0
151(none) and 1 (overloaded), indicating how much time is spent on processing
152objects per tick. Healthy values are < 0.5.
153
154=item $cf::LOAD
155
156The raw value load value from the last tick.
157
158=item %cf::CFG
159
160Configuration for the server, loaded from C</etc/crossfire/config>, or
161from wherever your confdir points to.
162
163=item cf::wait_for_tick, cf::wait_for_tick_begin
164
165These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
166returns directly I<after> the tick processing (and consequently, can only wake one process
167per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
168
169=back
170
171=cut
19 172
20BEGIN { 173BEGIN {
21 @EVENT = map lc, @EVENT;
22
23 *CORE::GLOBAL::warn = sub { 174 *CORE::GLOBAL::warn = sub {
24 my $msg = join "", @_; 175 my $msg = join "", @_;
176
25 $msg .= "\n" 177 $msg .= "\n"
26 unless $msg =~ /\n$/; 178 unless $msg =~ /\n$/;
27 179
28 print STDERR "cfperl: $msg"; 180 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
181
182 utf8::encode $msg;
29 LOG llevError, "cfperl: $msg"; 183 LOG llevError, $msg;
30 }; 184 };
31} 185}
32 186
33my %ignore_set = (MAP_PROP_PATH => 1); # I hate the plug-in api. Deeply! 187@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
188@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
189@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
190@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
191@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
192@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
193@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
34 194
35# generate property mutators 195# we bless all objects into (empty) derived classes to force a method lookup
36sub prop_gen { 196# within the Safe compartment.
37 my ($prefix, $class) = @_; 197for my $pkg (qw(
38 198 cf::global cf::attachable
199 cf::object cf::object::player
200 cf::client cf::player
201 cf::arch cf::living
202 cf::map cf::party cf::region
203)) {
39 no strict 'refs'; 204 no strict 'refs';
40 205 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
41 for my $prop (keys %PROP_TYPE) {
42 $prop =~ /^\Q$prefix\E_(.*$)/ or next;
43 my $sub = lc $1;
44
45 my $type = $PROP_TYPE{$prop};
46 my $idx = $PROP_IDX {$prop};
47
48 *{"$class\::get_$sub"} = *{"$class\::$sub"} = sub {
49 $_[0]->get_property ($type, $idx)
50 };
51
52 *{"$class\::set_$sub"} = sub {
53 $_[0]->set_property ($type, $idx, $_[1]);
54 } unless $ignore_set{$prop};
55 }
56} 206}
57
58# auto-generate most of the API
59
60prop_gen OBJECT_PROP => "cf::object";
61# CFAPI_OBJECT_ANIMATION?
62prop_gen PLAYER_PROP => "cf::object::player";
63
64prop_gen MAP_PROP => "cf::map";
65prop_gen ARCH_PROP => "cf::arch";
66
67# guessed hierarchies
68
69@cf::object::player::ISA = 'cf::object';
70@cf::object::map::ISA = 'cf::object';
71 207
72$Event::DIED = sub { 208$Event::DIED = sub {
73 warn "error in event callback: @_"; 209 warn "error in event callback: @_";
74}; 210};
75 211
76my %ext_pkg; 212=head2 UTILITY FUNCTIONS
77my @exts;
78my @hook;
79my %command;
80my %extcmd;
81 213
82sub inject_event { 214=over 4
83 my $extension = shift; 215
216=item dumpval $ref
217
218=cut
219
220sub dumpval {
221 eval {
222 local $SIG{__DIE__};
223 my $d;
224 if (1) {
225 $d = new Data::Dumper([$_[0]], ["*var"]);
226 $d->Terse(1);
227 $d->Indent(2);
228 $d->Quotekeys(0);
229 $d->Useqq(1);
230 #$d->Bless(...);
231 $d->Seen($_[1]) if @_ > 1;
232 $d = $d->Dump();
233 }
234 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
235 $d
236 } || "[unable to dump $_[0]: '$@']";
237}
238
239use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working
240
241=item $ref = cf::from_json $json
242
243Converts a JSON string into the corresponding perl data structure.
244
245=item $json = cf::to_json $ref
246
247Converts a perl data structure into its JSON representation.
248
249=item cf::lock_wait $string
250
251Wait until the given lock is available. See cf::lock_acquire.
252
253=item my $lock = cf::lock_acquire $string
254
255Wait until the given lock is available and then acquires it and returns
256a Coro::guard object. If the guard object gets destroyed (goes out of scope,
257for example when the coroutine gets canceled), the lock is automatically
258returned.
259
260Lock names should begin with a unique identifier (for example, cf::map::find
261uses map_find and cf::map::load uses map_load).
262
263=item $locked = cf::lock_active $string
264
265Return true if the lock is currently active, i.e. somebody has locked it.
266
267=cut
268
269our %LOCK;
270
271sub lock_wait($) {
272 my ($key) = @_;
273
274 # wait for lock, if any
275 while ($LOCK{$key}) {
276 push @{ $LOCK{$key} }, $Coro::current;
277 Coro::schedule;
278 }
279}
280
281sub lock_acquire($) {
282 my ($key) = @_;
283
284 # wait, to be sure we are not locked
285 lock_wait $key;
286
287 $LOCK{$key} = [];
288
289 Coro::guard {
290 # wake up all waiters, to be on the safe side
291 $_->ready for @{ delete $LOCK{$key} };
292 }
293}
294
295sub lock_active($) {
296 my ($key) = @_;
297
298 ! ! $LOCK{$key}
299}
300
301sub freeze_mainloop {
302 return unless $TICK_WATCHER->is_active;
303
304 my $guard = Coro::guard {
305 $TICK_WATCHER->start;
306 };
307 $TICK_WATCHER->stop;
308 $guard
309}
310
311=item cf::async { BLOCK }
312
313Currently the same as Coro::async_pool, meaning you cannot use
314C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
315thing you are allowed to do is call C<prio> on it.
316
317=cut
318
319BEGIN { *async = \&Coro::async_pool }
320
321=item cf::sync_job { BLOCK }
322
323The design of crossfire+ requires that the main coro ($Coro::main) is
324always able to handle events or runnable, as crossfire+ is only partly
325reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable.
326
327If it must be done, put the blocking parts into C<sync_job>. This will run
328the given BLOCK in another coroutine while waiting for the result. The
329server will be frozen during this time, so the block should either finish
330fast or be very important.
331
332=cut
333
334sub sync_job(&) {
335 my ($job) = @_;
336
337 if ($Coro::current == $Coro::main) {
338 my $time = Event::time;
339
340 # this is the main coro, too bad, we have to block
341 # till the operation succeeds, freezing the server :/
342
343 # TODO: use suspend/resume instead
344 # (but this is cancel-safe)
345 my $freeze_guard = freeze_mainloop;
346
347 my $busy = 1;
348 my @res;
349
350 (async {
351 @res = eval { $job->() };
352 warn $@ if $@;
353 undef $busy;
354 })->prio (Coro::PRIO_MAX);
355
356 while ($busy) {
357 Coro::cede or Event::one_event;
358 }
359
360 $time = Event::time - $time;
361
362 LOG llevError | logBacktrace, Carp::longmess "long sync job"
363 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
364
365 $tick_start += $time; # do not account sync jobs to server load
366
367 wantarray ? @res : $res[0]
368 } else {
369 # we are in another coroutine, how wonderful, everything just works
370
371 $job->()
372 }
373}
374
375=item $coro = cf::async_ext { BLOCK }
376
377Like async, but this coro is automatically being canceled when the
378extension calling this is being unloaded.
379
380=cut
381
382sub async_ext(&) {
84 my $event_code = shift; 383 my $cb = shift;
85 384
86 my $cb = $hook[$event_code]{$extension} 385 my $coro = &Coro::async ($cb);
386
387 $coro->on_destroy (sub {
388 delete $EXT_CORO{$coro+0};
389 });
390 $EXT_CORO{$coro+0} = $coro;
391
392 $coro
393}
394
395sub write_runtime {
396 my $runtime = "$LOCALDIR/runtime";
397
398 # first touch the runtime file to show we are still running:
399 # the fsync below can take a very very long time.
400
401 IO::AIO::aio_utime $runtime, undef, undef;
402
403 my $guard = cf::lock_acquire "write_runtime";
404
405 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
87 or return; 406 or return;
88 407
89 &$cb 408 my $value = $cf::RUNTIME + 90 + 10;
90} 409 # 10 is the runtime save interval, for a monotonic clock
410 # 60 allows for the watchdog to kill the server.
91 411
92sub inject_global_event { 412 (aio_write $fh, 0, (length $value), $value, 0) <= 0
413 and return;
414
415 # always fsync - this file is important
416 aio_fsync $fh
417 and return;
418
419 # touch it again to show we are up-to-date
420 aio_utime $fh, undef, undef;
421
422 close $fh
423 or return;
424
425 aio_rename "$runtime~", $runtime
426 and return;
427
428 warn "runtime file written.\n";#d#
429
430 1
431}
432
433=item cf::datalog type => key => value, ...
434
435Log a datalog packet of the given type with the given key-value pairs.
436
437=cut
438
439sub datalog($@) {
440 my ($type, %kv) = @_;
441 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
442}
443
444=back
445
446=cut
447
448#############################################################################
449
450=head2 ATTACHABLE OBJECTS
451
452Many objects in crossfire are so-called attachable objects. That means you can
453attach callbacks/event handlers (a collection of which is called an "attachment")
454to it. All such attachable objects support the following methods.
455
456In the following description, CLASS can be any of C<global>, C<object>
457C<player>, C<client> or C<map> (i.e. the attachable objects in
458crossfire+).
459
460=over 4
461
462=item $attachable->attach ($attachment, key => $value...)
463
464=item $attachable->detach ($attachment)
465
466Attach/detach a pre-registered attachment to a specific object and give it
467the specified key/value pairs as arguments.
468
469Example, attach a minesweeper attachment to the given object, making it a
47010x10 minesweeper game:
471
472 $obj->attach (minesweeper => width => 10, height => 10);
473
474=item $bool = $attachable->attached ($name)
475
476Checks wether the named attachment is currently attached to the object.
477
478=item cf::CLASS->attach ...
479
480=item cf::CLASS->detach ...
481
482Define an anonymous attachment and attach it to all objects of the given
483CLASS. See the next function for an explanation of its arguments.
484
485You can attach to global events by using the C<cf::global> class.
486
487Example, log all player logins:
488
489 cf::player->attach (
490 on_login => sub {
491 my ($pl) = @_;
492 ...
493 },
494 );
495
496Example, attach to the jeweler skill:
497
498 cf::object->attach (
499 type => cf::SKILL,
500 subtype => cf::SK_JEWELER,
501 on_use_skill => sub {
502 my ($sk, $ob, $part, $dir, $msg) = @_;
503 ...
504 },
505 );
506
507=item cf::CLASS::attachment $name, ...
508
509Register an attachment by C<$name> through which attachable objects of the
510given CLASS can refer to this attachment.
511
512Some classes such as crossfire maps and objects can specify attachments
513that are attached at load/instantiate time, thus the need for a name.
514
515These calls expect any number of the following handler/hook descriptions:
516
517=over 4
518
519=item prio => $number
520
521Set the priority for all following handlers/hooks (unless overwritten
522by another C<prio> setting). Lower priority handlers get executed
523earlier. The default priority is C<0>, and many built-in handlers are
524registered at priority C<-1000>, so lower priorities should not be used
525unless you know what you are doing.
526
527=item type => $type
528
529(Only for C<< cf::object->attach >> calls), limits the attachment to the
530given type of objects only (the additional parameter C<subtype> can be
531used to further limit to the given subtype).
532
533=item on_I<event> => \&cb
534
535Call the given code reference whenever the named event happens (event is
536something like C<instantiate>, C<apply>, C<use_skill> and so on, and which
537handlers are recognised generally depends on the type of object these
538handlers attach to).
539
540See F<include/eventinc.h> for the full list of events supported, and their
541class.
542
543=item package => package::
544
545Look for sub functions of the name C<< on_I<event> >> in the given
546package and register them. Only handlers for eevents supported by the
547object/class are recognised.
548
549=back
550
551Example, define an attachment called "sockpuppet" that calls the given
552event handler when a monster attacks:
553
554 cf::object::attachment sockpuppet =>
555 on_skill_attack => sub {
556 my ($self, $victim) = @_;
557 ...
558 }
559 }
560
561=item $attachable->valid
562
563Just because you have a perl object does not mean that the corresponding
564C-level object still exists. If you try to access an object that has no
565valid C counterpart anymore you get an exception at runtime. This method
566can be used to test for existence of the C object part without causing an
567exception.
568
569=cut
570
571# the following variables are defined in .xs and must not be re-created
572our @CB_GLOBAL = (); # registry for all global events
573our @CB_ATTACHABLE = (); # registry for all attachables
574our @CB_OBJECT = (); # all objects (should not be used except in emergency)
575our @CB_PLAYER = ();
576our @CB_CLIENT = ();
577our @CB_TYPE = (); # registry for type (cf-object class) based events
578our @CB_MAP = ();
579
580my %attachment;
581
582sub cf::attachable::thawer_merge {
583 # simply override everything except _meta
584 local $_[0]{_meta};
585 %{$_[0]} = %{$_[1]};
586}
587
588sub _attach_cb($$$$) {
589 my ($registry, $event, $prio, $cb) = @_;
590
591 use sort 'stable';
592
593 $cb = [$prio, $cb];
594
595 @{$registry->[$event]} = sort
596 { $a->[0] cmp $b->[0] }
597 @{$registry->[$event] || []}, $cb;
598}
599
600# hack
601my %attachable_klass = map +($_ => 1), KLASS_OBJECT, KLASS_CLIENT, KLASS_PLAYER, KLASS_MAP;
602
603# attach handles attaching event callbacks
604# the only thing the caller has to do is pass the correct
605# registry (== where the callback attaches to).
606sub _attach {
607 my ($registry, $klass, @arg) = @_;
608
609 my $object_type;
610 my $prio = 0;
611 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;
612
613 #TODO: get rid of this hack
614 if ($attachable_klass{$klass}) {
615 %cb_id = (%cb_id, map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == KLASS_ATTACHABLE, 0 .. $#EVENT);
616 }
617
618 while (@arg) {
619 my $type = shift @arg;
620
621 if ($type eq "prio") {
622 $prio = shift @arg;
623
624 } elsif ($type eq "type") {
625 $object_type = shift @arg;
626 $registry = $CB_TYPE[$object_type] ||= [];
627
628 } elsif ($type eq "subtype") {
629 defined $object_type or Carp::croak "subtype specified without type";
630 my $object_subtype = shift @arg;
631 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
632
633 } elsif ($type eq "package") {
634 my $pkg = shift @arg;
635
636 while (my ($name, $id) = each %cb_id) {
637 if (my $cb = $pkg->can ($name)) {
638 _attach_cb $registry, $id, $prio, $cb;
639 }
640 }
641
642 } elsif (exists $cb_id{$type}) {
643 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
644
645 } elsif (ref $type) {
646 warn "attaching objects not supported, ignoring.\n";
647
648 } else {
649 shift @arg;
650 warn "attach argument '$type' not supported, ignoring.\n";
651 }
652 }
653}
654
655sub _object_attach {
656 my ($obj, $name, %arg) = @_;
657
658 return if exists $obj->{_attachment}{$name};
659
660 if (my $attach = $attachment{$name}) {
661 my $registry = $obj->registry;
662
663 for (@$attach) {
664 my ($klass, @attach) = @$_;
665 _attach $registry, $klass, @attach;
666 }
667
668 $obj->{$name} = \%arg;
669 } else {
670 warn "object uses attachment '$name' that is not available, postponing.\n";
671 }
672
673 $obj->{_attachment}{$name} = undef;
674}
675
676sub cf::attachable::attach {
677 if (ref $_[0]) {
678 _object_attach @_;
679 } else {
680 _attach shift->_attach_registry, @_;
681 }
682 _recalc_want;
683};
684
685# all those should be optimised
686sub cf::attachable::detach {
687 my ($obj, $name) = @_;
688
689 if (ref $obj) {
690 delete $obj->{_attachment}{$name};
691 reattach ($obj);
692 } else {
693 Carp::croak "cannot, currently, detach class attachments";
694 }
695 _recalc_want;
696};
697
698sub cf::attachable::attached {
699 my ($obj, $name) = @_;
700
701 exists $obj->{_attachment}{$name}
702}
703
704for my $klass (qw(ATTACHABLE GLOBAL OBJECT PLAYER CLIENT MAP)) {
705 eval "#line " . __LINE__ . " 'cf.pm'
706 sub cf::\L$klass\E::_attach_registry {
707 (\\\@CB_$klass, KLASS_$klass)
708 }
709
710 sub cf::\L$klass\E::attachment {
711 my \$name = shift;
712
713 \$attachment{\$name} = [[KLASS_$klass, \@_]];
714 }
715 ";
716 die if $@;
717}
718
719our $override;
720our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
721
722sub override {
723 $override = 1;
724 @invoke_results = ();
725}
726
727sub do_invoke {
93 my $event = shift; 728 my $event = shift;
729 my $callbacks = shift;
94 730
95 my $cb = $hook[$event] 731 @invoke_results = ();
732
733 local $override;
734
735 for (@$callbacks) {
736 eval { &{$_->[1]} };
737
738 if ($@) {
739 warn "$@";
740 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
741 override;
742 }
743
744 return 1 if $override;
745 }
746
747 0
748}
749
750=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...)
751
752=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
753
754Generate an object-specific event with the given arguments.
755
756This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
757removed in future versions), and there is no public API to access override
758results (if you must, access C<@cf::invoke_results> directly).
759
760=back
761
762=cut
763
764#############################################################################
765# object support
766
767sub reattach {
768 # basically do the same as instantiate, without calling instantiate
769 my ($obj) = @_;
770
771 bless $obj, ref $obj; # re-bless in case extensions have been reloaded
772
773 my $registry = $obj->registry;
774
775 @$registry = ();
776
777 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
778
779 for my $name (keys %{ $obj->{_attachment} || {} }) {
780 if (my $attach = $attachment{$name}) {
781 for (@$attach) {
782 my ($klass, @attach) = @$_;
783 _attach $registry, $klass, @attach;
784 }
785 } else {
786 warn "object uses attachment '$name' that is not available, postponing.\n";
787 }
788 }
789}
790
791cf::attachable->attach (
792 prio => -1000000,
793 on_instantiate => sub {
794 my ($obj, $data) = @_;
795
796 $data = from_json $data;
797
798 for (@$data) {
799 my ($name, $args) = @$_;
800
801 $obj->attach ($name, %{$args || {} });
802 }
803 },
804 on_reattach => \&reattach,
805 on_clone => sub {
806 my ($src, $dst) = @_;
807
808 @{$dst->registry} = @{$src->registry};
809
810 %$dst = %$src;
811
812 %{$dst->{_attachment}} = %{$src->{_attachment}}
813 if exists $src->{_attachment};
814 },
815);
816
817sub object_freezer_save {
818 my ($filename, $rdata, $objs) = @_;
819
820 sync_job {
821 if (length $$rdata) {
822 warn sprintf "saving %s (%d,%d)\n",
823 $filename, length $$rdata, scalar @$objs;
824
825 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
826 chmod SAVE_MODE, $fh;
827 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
828 aio_fsync $fh if $cf::USE_FSYNC;
829 close $fh;
830
831 if (@$objs) {
832 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
833 chmod SAVE_MODE, $fh;
834 my $data = Storable::nfreeze { version => 1, objs => $objs };
835 aio_write $fh, 0, (length $data), $data, 0;
836 aio_fsync $fh if $cf::USE_FSYNC;
837 close $fh;
838 aio_rename "$filename.pst~", "$filename.pst";
839 }
840 } else {
841 aio_unlink "$filename.pst";
842 }
843
844 aio_rename "$filename~", $filename;
845 } else {
846 warn "FATAL: $filename~: $!\n";
847 }
848 } else {
849 aio_unlink $filename;
850 aio_unlink "$filename.pst";
851 }
852 }
853}
854
855sub object_freezer_as_string {
856 my ($rdata, $objs) = @_;
857
858 use Data::Dumper;
859
860 $$rdata . Dumper $objs
861}
862
863sub object_thawer_load {
864 my ($filename) = @_;
865
866 my ($data, $av);
867
868 (aio_load $filename, $data) >= 0
96 or return; 869 or return;
97 870
98 List::Util::max map &$_, values %$cb 871 unless (aio_stat "$filename.pst") {
99} 872 (aio_load "$filename.pst", $av) >= 0
100 873 or return;
101sub inject_command { 874 $av = eval { (Storable::thaw $av)->{objs} };
102 my ($name, $obj, $params) = @_;
103
104 for my $cmd (@{ $command{$name} }) {
105 $cmd->[1]->($obj, $params);
106 } 875 }
107 876
108 -1 877 warn sprintf "loading %s (%d)\n",
878 $filename, length $data, scalar @{$av || []};#d#
879 return ($data, $av);
109} 880}
881
882#############################################################################
883# command handling &c
884
885=item cf::register_command $name => \&callback($ob,$args);
886
887Register a callback for execution when the client sends the user command
888$name.
889
890=cut
110 891
111sub register_command { 892sub register_command {
112 my ($name, $time, $cb) = @_; 893 my ($name, $cb) = @_;
113 894
114 my $caller = caller; 895 my $caller = caller;
115 #warn "registering command '$name/$time' to '$caller'"; 896 #warn "registering command '$name/$time' to '$caller'";
116 897
117 push @{ $command{$name} }, [$time, $cb, $caller]; 898 push @{ $COMMAND{$name} }, [$caller, $cb];
118 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
119} 899}
900
901=item cf::register_extcmd $name => \&callback($pl,$packet);
902
903Register a callbackf ro execution when the client sends an extcmd packet.
904
905If the callback returns something, it is sent back as if reply was being
906called.
907
908=cut
120 909
121sub register_extcmd { 910sub register_extcmd {
122 my ($name, $cb) = @_; 911 my ($name, $cb) = @_;
123 912
124 my $caller = caller; 913 $EXTCMD{$name} = $cb;
125 #warn "registering extcmd '$name' to '$caller'";
126
127 $extcmd{$name} = [$cb, $caller];
128} 914}
129 915
130sub register { 916cf::player->attach (
131 my ($base, $pkg) = @_; 917 on_command => sub {
918 my ($pl, $name, $params) = @_;
132 919
133 for my $idx (0 .. $#EVENT) { 920 my $cb = $COMMAND{$name}
134 if (my $ref = $pkg->can ("on_$EVENT[$idx]")) { 921 or return;
135 #warn "registering $EVENT[$idx] hook to '$pkg'\n"; 922
136 $hook[$idx]{$base} = $ref; 923 for my $cmd (@$cb) {
924 $cmd->[1]->($pl->ob, $params);
137 } 925 }
926
927 cf::override;
138 } 928 },
139} 929 on_extcmd => sub {
930 my ($pl, $buf) = @_;
931
932 my $msg = eval { from_json $buf };
933
934 if (ref $msg) {
935 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
936 if (my %reply = $cb->($pl, $msg)) {
937 $pl->ext_reply ($msg->{msgid}, %reply);
938 }
939 }
940 } else {
941 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
942 }
943
944 cf::override;
945 },
946);
140 947
141sub load_extension { 948sub load_extension {
142 my ($path) = @_; 949 my ($path) = @_;
143 950
144 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 951 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
145 my $base = $1; 952 my $base = $1;
146 my $pkg = $1; 953 my $pkg = $1;
147 $pkg =~ s/[^[:word:]]/_/g; 954 $pkg =~ s/[^[:word:]]/_/g;
148 $pkg = "cf::ext::$pkg"; 955 $pkg = "ext::$pkg";
149 956
150 warn "loading '$path' into '$pkg'\n"; 957 warn "... loading '$path' into '$pkg'\n";
151 958
152 open my $fh, "<:utf8", $path 959 open my $fh, "<:utf8", $path
153 or die "$path: $!"; 960 or die "$path: $!";
154 961
155 my $source = 962 my $source =
156 "package $pkg; use strict; use utf8;\n" 963 "package $pkg; use strict; use utf8;\n"
157 . "#line 1 \"$path\"\n{\n" 964 . "#line 1 \"$path\"\n{\n"
158 . (do { local $/; <$fh> }) 965 . (do { local $/; <$fh> })
159 . "\n};\n1"; 966 . "\n};\n1";
160 967
161 eval $source 968 unless (eval $source) {
162 or die "$path: $@"; 969 my $msg = $@ ? "$path: $@\n"
970 : "extension disabled.\n";
971 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
972 warn $@;
973 warn "mandatory extension failed to load, exiting.\n";
974 exit 1;
975 }
976 die $@;
977 }
163 978
164 push @exts, $pkg; 979 push @EXTS, $pkg;
165 $ext_pkg{$base} = $pkg;
166
167# no strict 'refs';
168# @{"$pkg\::ISA"} = ext::;
169
170 register $base, $pkg;
171}
172
173sub unload_extension {
174 my ($pkg) = @_;
175
176 warn "removing extension $pkg\n";
177
178 if (my $cb = $pkg->can ("on_unload")) {
179 $cb->($pkg);
180 }
181
182 # remove hooks
183 for my $idx (0 .. $#EVENT) {
184 delete $hook[$idx]{$pkg};
185 }
186
187 # remove commands
188 for my $name (keys %command) {
189 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} };
190
191 if (@cb) {
192 $command{$name} = \@cb;
193 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
194 } else {
195 delete $command{$name};
196 delete $COMMAND{"$name\000"};
197 }
198 }
199
200 # remove extcmds
201 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) {
202 delete $extcmd{$name};
203 }
204
205 Symbol::delete_package $pkg;
206} 980}
207 981
208sub load_extensions { 982sub load_extensions {
209 my $LIBDIR = maps_directory "perl";
210
211 for my $ext (<$LIBDIR/*.ext>) { 983 for my $ext (<$LIBDIR/*.ext>) {
212 next unless -r $ext; 984 next unless -r $ext;
213 eval { 985 eval {
214 load_extension $ext; 986 load_extension $ext;
215 1 987 1
216 } or warn "$ext not loaded: $@"; 988 } or warn "$ext not loaded: $@";
217 } 989 }
218} 990}
219 991
220register_command "perl-reload", 0, sub { 992#############################################################################
993
994=head2 CORE EXTENSIONS
995
996Functions and methods that extend core crossfire objects.
997
998=cut
999
1000package cf::player;
1001
1002use Coro::AIO;
1003
1004=head3 cf::player
1005
1006=over 4
1007
1008=item cf::player::find $login
1009
1010Returns the given player object, loading it if necessary (might block).
1011
1012=cut
1013
1014sub playerdir($) {
1015 "$PLAYERDIR/"
1016 . (ref $_[0] ? $_[0]->ob->name : $_[0])
1017}
1018
1019sub path($) {
1020 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
1021
1022 (playerdir $login) . "/playerdata"
1023}
1024
1025sub find_active($) {
1026 $cf::PLAYER{$_[0]}
1027 and $cf::PLAYER{$_[0]}->active
1028 and $cf::PLAYER{$_[0]}
1029}
1030
1031sub exists($) {
221 my ($who, $arg) = @_; 1032 my ($login) = @_;
222 1033
223 if ($who->flag (FLAG_WIZ)) { 1034 $cf::PLAYER{$login}
224 $who->message ("reloading..."); 1035 or cf::sync_job { !aio_stat path $login }
1036}
225 1037
226 warn "reloading...\n"; 1038sub find($) {
227 eval { 1039 return $cf::PLAYER{$_[0]} || do {
228 $_->cancel for Event::all_watchers; 1040 my $login = $_[0];
229 1041
230 unload_extension $_ for @exts; 1042 my $guard = cf::lock_acquire "user_find:$login";
231 delete $INC{"cf.pm"};
232 1043
233 # don't, removes xs symbols, too 1044 $cf::PLAYER{$_[0]} || do {
234 #Symbol::delete_package __PACKAGE__; 1045 # rename old playerfiles to new ones
1046 #TODO: remove when no longer required
1047 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1048 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1049 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1050 aio_unlink +(playerdir $login) . "/$login.pl";
235 1051
236 require cf; 1052 my $pl = load_pl path $login
1053 or return;
1054 $cf::PLAYER{$login} = $pl
237 }; 1055 }
238 warn $@ if $@; 1056 }
239 $who->message ($@) if $@; 1057}
240 warn "reloaded\n";
241 1058
242 $who->message ("reloaded"); 1059sub save($) {
1060 my ($pl) = @_;
1061
1062 return if $pl->{deny_save};
1063
1064 my $path = path $pl;
1065 my $guard = cf::lock_acquire "user_save:$path";
1066
1067 return if $pl->{deny_save};
1068
1069 aio_mkdir playerdir $pl, 0770;
1070 $pl->{last_save} = $cf::RUNTIME;
1071
1072 $pl->save_pl ($path);
1073 Coro::cede;
1074}
1075
1076sub new($) {
1077 my ($login) = @_;
1078
1079 my $self = create;
1080
1081 $self->ob->name ($login);
1082 $self->{deny_save} = 1;
1083
1084 $cf::PLAYER{$login} = $self;
1085
1086 $self
1087}
1088
1089=item $pl->quit_character
1090
1091Nukes the player without looking back. If logged in, the connection will
1092be destroyed. May block for a long time.
1093
1094=cut
1095
1096sub quit_character {
1097 my ($pl) = @_;
1098
1099 my $name = $pl->ob->name;
1100
1101 $pl->{deny_save} = 1;
1102 $pl->password ("*"); # this should lock out the player until we nuked the dir
1103
1104 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1105 $pl->deactivate;
1106 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1107 $pl->ns->destroy if $pl->ns;
1108
1109 my $path = playerdir $pl;
1110 my $temp = "$path~$cf::RUNTIME~deleting~";
1111 aio_rename $path, $temp;
1112 delete $cf::PLAYER{$pl->ob->name};
1113 $pl->destroy;
1114
1115 my $prefix = qr<^~\Q$name\E/>;
1116
1117 # nuke player maps
1118 $cf::MAP{$_}->nuke for grep /$prefix/, keys %cf::MAP;
1119
1120 IO::AIO::aio_rmtree $temp;
1121}
1122
1123=item $pl->kick
1124
1125Kicks a player out of the game. This destroys the connection.
1126
1127=cut
1128
1129sub kick {
1130 my ($pl, $kicker) = @_;
1131
1132 $pl->invoke (cf::EVENT_PLAYER_KICK, $kicker);
1133 $pl->killer ("kicked");
1134 $pl->ns->destroy;
1135}
1136
1137=item cf::player::list_logins
1138
1139Returns am arrayref of all valid playernames in the system, can take a
1140while and may block, so not sync_job-capable, ever.
1141
1142=cut
1143
1144sub list_logins {
1145 my $dirs = aio_readdir $PLAYERDIR
1146 or return [];
1147
1148 my @logins;
1149
1150 for my $login (@$dirs) {
1151 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;
1152 aio_read $fh, 0, 512, my $buf, 0 or next;
1153 $buf !~ /^password -------------$/m or next; # official not-valid tag
1154
1155 utf8::decode $login;
1156 push @logins, $login;
1157 }
1158
1159 \@logins
1160}
1161
1162=item $player->maps
1163
1164Returns an arrayref of map paths that are private for this
1165player. May block.
1166
1167=cut
1168
1169sub maps($) {
1170 my ($pl) = @_;
1171
1172 $pl = ref $pl ? $pl->ob->name : $pl;
1173
1174 my $files = aio_readdir playerdir $pl
1175 or return;
1176
1177 my @paths;
1178
1179 for (@$files) {
1180 utf8::decode $_;
1181 next if /\.(?:pl|pst)$/;
1182 next unless /^$PATH_SEP/o;
1183
1184 push @paths, cf::map::normalise "~$pl/$_";
1185 }
1186
1187 \@paths
1188}
1189
1190=item $player->ext_reply ($msgid, %msg)
1191
1192Sends an ext reply to the player.
1193
1194=cut
1195
1196sub ext_reply($$%) {
1197 my ($self, $id, %msg) = @_;
1198
1199 $msg{msgid} = $id;
1200
1201 $self->send ("ext " . cf::to_json \%msg);
1202}
1203
1204=item $player->ext_event ($type, %msg)
1205
1206Sends an ext event to the client.
1207
1208=cut
1209
1210sub ext_event($$%) {
1211 my ($self, $type, %msg) = @_;
1212
1213 $self->ns->ext_event ($type, %msg);
1214}
1215
1216=head3 cf::region
1217
1218=over 4
1219
1220=cut
1221
1222package cf::region;
1223
1224=item cf::region::find_by_path $path
1225
1226Tries to decuce the probable region for a map knowing only its path.
1227
1228=cut
1229
1230sub find_by_path($) {
1231 my ($path) = @_;
1232
1233 my ($match, $specificity);
1234
1235 for my $region (list) {
1236 if ($region->match && $path =~ $region->match) {
1237 ($match, $specificity) = ($region, $region->specificity)
1238 if $region->specificity > $specificity;
1239 }
1240 }
1241
1242 $match
1243}
1244
1245=back
1246
1247=head3 cf::map
1248
1249=over 4
1250
1251=cut
1252
1253package cf::map;
1254
1255use Fcntl;
1256use Coro::AIO;
1257
1258use overload
1259 '""' => \&as_string,
1260 fallback => 1;
1261
1262our $MAX_RESET = 3600;
1263our $DEFAULT_RESET = 3000;
1264
1265sub generate_random_map {
1266 my ($self, $rmp) = @_;
1267 # mit "rum" bekleckern, nicht
1268 $self->_create_random_map (
1269 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1270 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1271 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1272 $rmp->{exit_on_final_map},
1273 $rmp->{xsize}, $rmp->{ysize},
1274 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1275 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1276 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1277 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1278 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1279 (cf::region::find $rmp->{region}), $rmp->{custom}
1280 )
1281}
1282
1283=item cf::map->register ($regex, $prio)
1284
1285Register a handler for the map path matching the given regex at the
1286givne priority (higher is better, built-in handlers have priority 0, the
1287default).
1288
1289=cut
1290
1291sub register {
1292 my (undef, $regex, $prio) = @_;
1293 my $pkg = caller;
1294
1295 no strict;
1296 push @{"$pkg\::ISA"}, __PACKAGE__;
1297
1298 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1299}
1300
1301# also paths starting with '/'
1302$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}];
1303
1304sub thawer_merge {
1305 my ($self, $merge) = @_;
1306
1307 # we have to keep some variables in memory intact
1308 local $self->{path};
1309 local $self->{load_path};
1310 local $self->{deny_save};
1311 local $self->{deny_reset};
1312
1313 $self->SUPER::thawer_merge ($merge);
1314}
1315
1316sub normalise {
1317 my ($path, $base) = @_;
1318
1319 $path = "$path"; # make sure its a string
1320
1321 $path =~ s/\.map$//;
1322
1323 # map plan:
1324 #
1325 # /! non-realised random map exit (special hack!)
1326 # {... are special paths that are not being touched
1327 # ?xxx/... are special absolute paths
1328 # ?random/... random maps
1329 # /... normal maps
1330 # ~user/... per-player map of a specific user
1331
1332 $path =~ s/$PATH_SEP/\//go;
1333
1334 # treat it as relative path if it starts with
1335 # something that looks reasonable
1336 if ($path =~ m{^(?:\./|\.\./|\w)}) {
1337 $base or Carp::carp "normalise called with relative path and no base: '$path'";
1338
1339 $base =~ s{[^/]+/?$}{};
1340 $path = "$base/$path";
1341 }
1342
1343 for ($path) {
1344 redo if s{//}{/};
1345 redo if s{/\.?/}{/};
1346 redo if s{/[^/]+/\.\./}{/};
1347 }
1348
1349 $path
1350}
1351
1352sub new_from_path {
1353 my (undef, $path, $base) = @_;
1354
1355 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object
1356
1357 $path = normalise $path, $base;
1358
1359 for my $pkg (sort { $EXT_MAP{$b}[0] <=> $EXT_MAP{$a}[0] } keys %EXT_MAP) {
1360 if ($path =~ $EXT_MAP{$pkg}[1]) {
1361 my $self = bless cf::map::new, $pkg;
1362 $self->{path} = $path; $self->path ($path);
1363 $self->init; # pass $1 etc.
1364 return $self;
1365 }
1366 }
1367
1368 Carp::carp "unable to resolve path '$path' (base '$base').";
1369 ()
1370}
1371
1372sub init {
1373 my ($self) = @_;
1374
1375 $self
1376}
1377
1378sub as_string {
1379 my ($self) = @_;
1380
1381 "$self->{path}"
1382}
1383
1384# the displayed name, this is a one way mapping
1385sub visible_name {
1386 &as_string
1387}
1388
1389# the original (read-only) location
1390sub load_path {
1391 my ($self) = @_;
1392
1393 "$MAPDIR/$self->{path}.map"
1394}
1395
1396# the temporary/swap location
1397sub save_path {
1398 my ($self) = @_;
1399
1400 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1401 "$TMPDIR/$path.map"
1402}
1403
1404# the unique path, undef == no special unique path
1405sub uniq_path {
1406 my ($self) = @_;
1407
1408 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1409 "$UNIQUEDIR/$path"
1410}
1411
1412# and all this just because we cannot iterate over
1413# all maps in C++...
1414sub change_all_map_light {
1415 my ($change) = @_;
1416
1417 $_->change_map_light ($change)
1418 for grep $_->outdoor, values %cf::MAP;
1419}
1420
1421sub unlink_save {
1422 my ($self) = @_;
1423
1424 utf8::encode (my $save = $self->save_path);
1425 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
1426 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst";
1427}
1428
1429sub load_header_from($) {
1430 my ($self, $path) = @_;
1431
1432 utf8::encode $path;
1433 #aio_open $path, O_RDONLY, 0
1434 # or return;
1435
1436 $self->_load_header ($path)
1437 or return;
1438
1439 $self->{load_path} = $path;
1440
1441 1
1442}
1443
1444sub load_header_orig {
1445 my ($self) = @_;
1446
1447 $self->load_header_from ($self->load_path)
1448}
1449
1450sub load_header_temp {
1451 my ($self) = @_;
1452
1453 $self->load_header_from ($self->save_path)
1454}
1455
1456sub prepare_temp {
1457 my ($self) = @_;
1458
1459 $self->last_access ((delete $self->{last_access})
1460 || $cf::RUNTIME); #d#
1461 # safety
1462 $self->{instantiate_time} = $cf::RUNTIME
1463 if $self->{instantiate_time} > $cf::RUNTIME;
1464}
1465
1466sub prepare_orig {
1467 my ($self) = @_;
1468
1469 $self->{load_original} = 1;
1470 $self->{instantiate_time} = $cf::RUNTIME;
1471 $self->last_access ($cf::RUNTIME);
1472 $self->instantiate;
1473}
1474
1475sub load_header {
1476 my ($self) = @_;
1477
1478 if ($self->load_header_temp) {
1479 $self->prepare_temp;
243 } else { 1480 } else {
244 $who->message ("Intruder Alert!"); 1481 $self->load_header_orig
1482 or return;
1483 $self->prepare_orig;
1484 }
1485
1486 $self->default_region (cf::region::find_by_path $self->{path})
1487 unless $self->default_region;
1488
245 } 1489 1
246}; 1490}
247 1491
248############################################################################# 1492sub find;
249# extcmd framework, basically convert ext <id> <pkg> arg1 args 1493sub find {
250# into pkg::->on_extcmd_arg1 (...) while shortcutting a few 1494 my ($path, $origin) = @_;
251 1495
252sub on_extcmd { 1496 $path = normalise $path, $origin && $origin->path;
1497
1498 cf::lock_wait "map_find:$path";
1499
1500 $cf::MAP{$path} || do {
1501 my $guard = cf::lock_acquire "map_find:$path";
1502 my $map = new_from_path cf::map $path
1503 or return;
1504
1505 $map->{last_save} = $cf::RUNTIME;
1506
1507 $map->load_header
1508 or return;
1509
1510 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?)
1511 # doing this can freeze the server in a sync job, obviously
1512 #$cf::WAIT_FOR_TICK->wait;
1513 $map->reset;
1514 undef $guard;
1515 return find $path;
1516 }
1517
1518 $cf::MAP{$path} = $map
1519 }
1520}
1521
1522sub pre_load { }
1523sub post_load { }
1524
1525sub load {
1526 my ($self) = @_;
1527
1528 local $self->{deny_reset} = 1; # loading can take a long time
1529
1530 my $path = $self->{path};
1531
1532 {
1533 my $guard = cf::lock_acquire "map_load:$path";
1534
1535 return if $self->in_memory != cf::MAP_SWAPPED;
1536
1537 $self->in_memory (cf::MAP_LOADING);
1538
1539 $self->alloc;
1540
1541 $self->pre_load;
1542 Coro::cede;
1543
1544 $self->_load_objects ($self->{load_path}, 1)
1545 or return;
1546
1547 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1548 if delete $self->{load_original};
1549
1550 if (my $uniq = $self->uniq_path) {
1551 utf8::encode $uniq;
1552 if (aio_open $uniq, O_RDONLY, 0) {
1553 $self->clear_unique_items;
1554 $self->_load_objects ($uniq, 0);
1555 }
1556 }
1557
1558 Coro::cede;
1559 # now do the right thing for maps
1560 $self->link_multipart_objects;
1561 $self->difficulty ($self->estimate_difficulty)
1562 unless $self->difficulty;
1563 Coro::cede;
1564
1565 unless ($self->{deny_activate}) {
1566 $self->decay_objects;
1567 $self->fix_auto_apply;
1568 $self->update_buttons;
1569 Coro::cede;
1570 $self->set_darkness_map;
1571 Coro::cede;
1572 $self->activate;
1573 }
1574
1575 $self->in_memory (cf::MAP_IN_MEMORY);
1576 }
1577
1578 $self->post_load;
1579}
1580
1581sub customise_for {
253 my ($pl, $buf) = @_; 1582 my ($self, $ob) = @_;
254 1583
255 my ($type) = $buf =~ s/^(\S+) // ? $1 : ""; 1584 return find "~" . $ob->name . "/" . $self->{path}
1585 if $self->per_player;
256 1586
257 $extcmd{$type}[0]->($pl, $buf) 1587 $self
258 if $extcmd{$type};
259} 1588}
260 1589
261############################################################################# 1590# find and load all maps in the 3x3 area around a map
262# load/save/clean perl data associated with a map 1591sub load_diag {
263
264*on_mapclean = sub {
265 my ($map) = @_; 1592 my ($map) = @_;
266 1593
267 my $path = $map->tmpname; 1594 my @diag; # diagonal neighbours
268 defined $path or return;
269 1595
270 unlink "$path.cfperl"; 1596 for (0 .. 3) {
271}; 1597 my $neigh = $map->tile_path ($_)
1598 or next;
1599 $neigh = find $neigh, $map
1600 or next;
1601 $neigh->load;
272 1602
273*on_mapin = 1603 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],
274*on_mapload = sub { 1604 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1605 }
1606
1607 for (@diag) {
1608 my $neigh = find @$_
1609 or next;
1610 $neigh->load;
1611 }
1612}
1613
1614sub find_sync {
1615 my ($path, $origin) = @_;
1616
1617 cf::sync_job { find $path, $origin }
1618}
1619
1620sub do_load_sync {
275 my ($map) = @_; 1621 my ($map) = @_;
276 1622
277 my $path = $map->tmpname; 1623 cf::sync_job { $map->load };
278 $path = $map->path unless defined $path; 1624}
279 1625
280 open my $fh, "<:raw", "$path.cfperl" 1626our %MAP_PREFETCH;
281 or return; # no perl data 1627our $MAP_PREFETCHER = undef;
282 1628
283 my $data = Storable::thaw do { local $/; <$fh> }; 1629sub find_async {
1630 my ($path, $origin) = @_;
284 1631
285 $data->{version} <= 1 1632 $path = normalise $path, $origin && $origin->{path};
286 or return; # too new
287 1633
288 $map->_set_obs ($data->{obs}); 1634 if (my $map = $cf::MAP{$path}) {
289}; 1635 return $map if $map->in_memory == cf::MAP_IN_MEMORY;
1636 }
290 1637
291*on_mapout = sub { 1638 undef $MAP_PREFETCH{$path};
292 my ($map) = @_; 1639 $MAP_PREFETCHER ||= cf::async {
1640 while (%MAP_PREFETCH) {
1641 for my $path (keys %MAP_PREFETCH) {
1642 my $map = find $path
1643 or next;
1644 $map->load;
293 1645
294 my $path = $map->tmpname; 1646 delete $MAP_PREFETCH{$path};
295 $path = $map->path unless defined $path; 1647 }
296
297 my $obs = $map->_get_obs;
298
299 if (defined $obs) {
300 open my $fh, ">:raw", "$path.cfperl"
301 or die "$path.cfperl: $!";
302
303 stat $path;
304
305 print $fh Storable::nfreeze {
306 size => (stat _)[7],
307 time => (stat _)[9],
308 version => 1,
309 obs => $obs,
310 }; 1648 }
1649 undef $MAP_PREFETCHER;
1650 };
1651 $MAP_PREFETCHER->prio (6);
311 1652
312 chmod SAVE_MODE, "$path.cfperl"; # very racy, but cf-compatible *g* 1653 ()
1654}
1655
1656sub save {
1657 my ($self) = @_;
1658
1659 my $lock = cf::lock_acquire "map_data:" . $self->path;
1660
1661 $self->{last_save} = $cf::RUNTIME;
1662
1663 return unless $self->dirty;
1664
1665 my $save = $self->save_path; utf8::encode $save;
1666 my $uniq = $self->uniq_path; utf8::encode $uniq;
1667
1668 $self->{load_path} = $save;
1669
1670 return if $self->{deny_save};
1671
1672 local $self->{last_access} = $self->last_access;#d#
1673
1674 cf::async {
1675 $_->contr->save for $self->players;
1676 };
1677
1678 if ($uniq) {
1679 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1680 $self->_save_objects ($uniq, cf::IO_UNIQUES);
313 } else { 1681 } else {
314 unlink "$path.cfperl"; 1682 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
315 } 1683 }
316}; 1684}
317 1685
318############################################################################# 1686sub swap_out {
319# load/save perl data associated with player->ob objects 1687 my ($self) = @_;
320 1688
321*on_player_load = sub { 1689 # save first because save cedes
322 my ($ob, $path) = @_; 1690 $self->save;
323 1691
324 if (open my $fh, "<:raw", "$path.cfperl") { 1692 my $lock = cf::lock_acquire "map_data:" . $self->path;
325 1693
326 #d##TODO#remove 1694 return if $self->players;
1695 return if $self->in_memory != cf::MAP_IN_MEMORY;
1696 return if $self->{deny_save};
327 1697
328 my $data = Storable::thaw do { local $/; <$fh> }; 1698 $self->clear;
1699 $self->in_memory (cf::MAP_SWAPPED);
1700}
329 1701
330 $data->{version} <= 1 1702sub reset_at {
331 or return; # too new 1703 my ($self) = @_;
332 1704
333 %$ob = %{$data->{ob}}; 1705 # TODO: safety, remove and allow resettable per-player maps
1706 return 1e99 if $self->isa ("ext::map_per_player");#d#
1707 return 1e99 if $self->{deny_reset};
1708
1709 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1710 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1711
1712 $time + $to
1713}
1714
1715sub should_reset {
1716 my ($self) = @_;
1717
1718 $self->reset_at <= $cf::RUNTIME
1719}
1720
1721sub reset {
1722 my ($self) = @_;
1723
1724 my $lock = cf::lock_acquire "map_data:$self->{path}";
1725
1726 return if $self->players;
1727 return if $self->isa ("ext::map_per_player");#d#
1728
1729 warn "resetting map ", $self->path;#d#
1730
1731 $self->in_memory (cf::MAP_SWAPPED);
1732
1733 # need to save uniques path
1734 unless ($self->{deny_save}) {
1735 my $uniq = $self->uniq_path; utf8::encode $uniq;
1736
1737 $self->_save_objects ($uniq, cf::IO_UNIQUES)
1738 if $uniq;
1739 }
1740
1741 delete $cf::MAP{$self->path};
1742
1743 $self->clear;
1744
1745 $_->clear_links_to ($self) for values %cf::MAP;
1746
1747 $self->unlink_save;
1748 $self->destroy;
1749}
1750
1751my $nuke_counter = "aaaa";
1752
1753sub nuke {
1754 my ($self) = @_;
1755
1756 delete $cf::MAP{$self->path};
1757
1758 $self->unlink_save;
1759
1760 bless $self, "cf::map";
1761 delete $self->{deny_reset};
1762 $self->{deny_save} = 1;
1763 $self->reset_timeout (1);
1764 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1765
1766 $cf::MAP{$self->path} = $self;
1767
1768 $self->reset; # polite request, might not happen
1769}
1770
1771=item cf::map::unique_maps
1772
1773Returns an arrayref of paths of all shared maps that have
1774instantiated unique items. May block.
1775
1776=cut
1777
1778sub unique_maps() {
1779 my $files = aio_readdir $UNIQUEDIR
334 return; 1780 or return;
335 }
336 1781
337 for my $o ($ob, $ob->inv) { 1782 my @paths;
338 if (my $value = $o->get_ob_key_value ("_perl_data")) {
339 $o->set_ob_key_value ("_perl_data");
340 1783
341 %$o = %{ Storable::thaw pack "H*", $value }; 1784 for (@$files) {
342 } 1785 utf8::decode $_;
343 } 1786 next if /\.pst$/;
344}; 1787 next unless /^$PATH_SEP/o;
345 1788
346*on_player_save = sub { 1789 push @paths, cf::map::normalise $_;
347 my ($ob, $path) = @_; 1790 }
348 1791
349 $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_) 1792 \@paths
350 for grep %$_, $ob, $ob->inv;
351
352 unlink "$path.cfperl";#d##TODO#remove
353};
354
355#############################################################################
356# core extensions - in perl
357
358=item cf::player::exists $login
359
360Returns true when the given account exists.
361
362=cut
363
364sub cf::player::exists($) {
365 cf::player::find $_[0]
366 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
367} 1793}
1794
1795package cf;
1796
1797=back
1798
1799=head3 cf::object
1800
1801=cut
1802
1803package cf::object;
1804
1805=over 4
1806
1807=item $ob->inv_recursive
1808
1809Returns the inventory of the object _and_ their inventories, recursively.
1810
1811=cut
1812
1813sub inv_recursive_;
1814sub inv_recursive_ {
1815 map { $_, inv_recursive_ $_->inv } @_
1816}
1817
1818sub inv_recursive {
1819 inv_recursive_ inv $_[0]
1820}
1821
1822package cf;
1823
1824=back
1825
1826=head3 cf::object::player
1827
1828=over 4
1829
1830=item $player_object->reply ($npc, $msg[, $flags])
1831
1832Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
1833can be C<undef>. Does the right thing when the player is currently in a
1834dialogue with the given NPC character.
1835
1836=cut
368 1837
369# rough implementation of a future "reply" method that works 1838# rough implementation of a future "reply" method that works
370# with dialog boxes. 1839# with dialog boxes.
1840#TODO: the first argument must go, split into a $npc->reply_to ( method
371sub cf::object::player::reply($$$;$) { 1841sub cf::object::player::reply($$$;$) {
372 my ($self, $npc, $msg, $flags) = @_; 1842 my ($self, $npc, $msg, $flags) = @_;
373 1843
374 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 1844 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
375 1845
1846 if ($self->{record_replies}) {
1847 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
1848 } else {
376 $msg = $npc->name . " says: $msg" if $npc; 1849 $msg = $npc->name . " says: $msg" if $npc;
377
378 $self->message ($msg, $flags); 1850 $self->message ($msg, $flags);
1851 }
379} 1852}
380 1853
381############################################################################# 1854=item $player_object->may ("access")
382# map scripting support
383 1855
1856Returns wether the given player is authorized to access resource "access"
1857(e.g. "command_wizcast").
1858
1859=cut
1860
1861sub cf::object::player::may {
1862 my ($self, $access) = @_;
1863
1864 $self->flag (cf::FLAG_WIZ) ||
1865 (ref $cf::CFG{"may_$access"}
1866 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
1867 : $cf::CFG{"may_$access"})
1868}
1869
1870=item $player_object->enter_link
1871
1872Freezes the player and moves him/her to a special map (C<{link}>).
1873
1874The player should be reasonably safe there for short amounts of time. You
1875I<MUST> call C<leave_link> as soon as possible, though.
1876
1877Will never block.
1878
1879=item $player_object->leave_link ($map, $x, $y)
1880
1881Moves the player out of the special C<{link}> map onto the specified
1882map. If the map is not valid (or omitted), the player will be moved back
1883to the location he/she was before the call to C<enter_link>, or, if that
1884fails, to the emergency map position.
1885
1886Might block.
1887
1888=cut
1889
1890sub link_map {
1891 unless ($LINK_MAP) {
1892 $LINK_MAP = cf::map::find "{link}"
1893 or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
1894 $LINK_MAP->load;
1895 }
1896
1897 $LINK_MAP
1898}
1899
1900sub cf::object::player::enter_link {
1901 my ($self) = @_;
1902
1903 $self->deactivate_recursive;
1904
1905 return if UNIVERSAL::isa $self->map, "ext::map_link";
1906
1907 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1908 if $self->map && $self->map->{path} ne "{link}";
1909
1910 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1911}
1912
1913sub cf::object::player::leave_link {
1914 my ($self, $map, $x, $y) = @_;
1915
1916 return unless $self->contr->active;
1917
1918 my $link_pos = delete $self->{_link_pos};
1919
1920 unless ($map) {
1921 # restore original map position
1922 ($map, $x, $y) = @{ $link_pos || [] };
1923 $map = cf::map::find $map;
1924
1925 unless ($map) {
1926 ($map, $x, $y) = @$EMERGENCY_POSITION;
1927 $map = cf::map::find $map
1928 or die "FATAL: cannot load emergency map\n";
1929 }
1930 }
1931
1932 ($x, $y) = (-1, -1)
1933 unless (defined $x) && (defined $y);
1934
1935 # use -1 or undef as default coordinates, not 0, 0
1936 ($x, $y) = ($map->enter_x, $map->enter_y)
1937 if $x <=0 && $y <= 0;
1938
1939 $map->load;
1940 $map->load_diag;
1941
1942 return unless $self->contr->active;
1943 $self->activate_recursive;
1944
1945 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1946 $self->enter_map ($map, $x, $y);
1947}
1948
1949=item $player_object->goto ($path, $x, $y[, $check->($map)])
1950
1951Moves the player to the given map-path and coordinates by first freezing
1952her, loading and preparing them map, calling the provided $check callback
1953that has to return the map if sucecssful, and then unfreezes the player on
1954the new (success) or old (failed) map position.
1955
1956=cut
1957
1958our $GOTOGEN;
1959
1960sub cf::object::player::goto {
1961 my ($self, $path, $x, $y, $check) = @_;
1962
1963 # do generation counting so two concurrent goto's will be executed in-order
1964 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1965
1966 $self->enter_link;
1967
1968 (async {
1969 my $map = eval {
1970 my $map = cf::map::find $path;
1971
1972 if ($map) {
1973 $map = $map->customise_for ($self);
1974 $map = $check->($map) if $check && $map;
1975 } else {
1976 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1977 }
1978
1979 $map
1980 };
1981
1982 if ($@) {
1983 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
1984 LOG llevError | logBacktrace, Carp::longmess $@;
1985 }
1986
1987 if ($gen == $self->{_goto_generation}) {
1988 delete $self->{_goto_generation};
1989 $self->leave_link ($map, $x, $y);
1990 }
1991 })->prio (1);
1992}
1993
1994=item $player_object->enter_exit ($exit_object)
1995
1996=cut
1997
1998sub parse_random_map_params {
1999 my ($spec) = @_;
2000
2001 my $rmp = { # defaults
2002 xsize => (cf::rndm 15, 40),
2003 ysize => (cf::rndm 15, 40),
2004 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
2005 #layout => string,
2006 };
2007
2008 for (split /\n/, $spec) {
2009 my ($k, $v) = split /\s+/, $_, 2;
2010
2011 $rmp->{lc $k} = $v if (length $k) && (length $v);
2012 }
2013
2014 $rmp
2015}
2016
2017sub prepare_random_map {
2018 my ($exit) = @_;
2019
2020 my $guard = cf::lock_acquire "exit_prepare:$exit";
2021
2022 # all this does is basically replace the /! path by
2023 # a new random map path (?random/...) with a seed
2024 # that depends on the exit object
2025
2026 my $rmp = parse_random_map_params $exit->msg;
2027
2028 if ($exit->map) {
2029 $rmp->{region} = $exit->region->name;
2030 $rmp->{origin_map} = $exit->map->path;
2031 $rmp->{origin_x} = $exit->x;
2032 $rmp->{origin_y} = $exit->y;
2033 }
2034
2035 $rmp->{random_seed} ||= $exit->random_seed;
2036
2037 my $data = cf::to_json $rmp;
2038 my $md5 = Digest::MD5::md5_hex $data;
2039 my $meta = "$RANDOMDIR/$md5.meta";
2040
2041 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2042 aio_write $fh, 0, (length $data), $data, 0;
2043 undef $fh;
2044 aio_rename "$meta~", $meta;
2045
2046 $exit->slaying ("?random/$md5");
2047 $exit->msg (undef);
2048 }
2049}
2050
2051sub cf::object::player::enter_exit {
2052 my ($self, $exit) = @_;
2053
2054 return unless $self->type == cf::PLAYER;
2055
2056 if ($exit->slaying eq "/!") {
2057 #TODO: this should de-fi-ni-te-ly not be a sync-job
2058 # the problem is that $exit might not survive long enough
2059 # so it needs to be done right now, right here
2060 cf::sync_job { prepare_random_map $exit };
2061 }
2062
2063 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2064 my $hp = $exit->stats->hp;
2065 my $sp = $exit->stats->sp;
2066
2067 $self->enter_link;
2068
2069 (async {
2070 $self->deactivate_recursive; # just to be sure
2071 unless (eval {
2072 $self->goto ($slaying, $hp, $sp);
2073
2074 1;
2075 }) {
2076 $self->message ("Something went wrong deep within the crossfire server. "
2077 . "I'll try to bring you back to the map you were before. "
2078 . "Please report this to the dungeon master!",
2079 cf::NDI_UNIQUE | cf::NDI_RED);
2080
2081 warn "ERROR in enter_exit: $@";
2082 $self->leave_link;
2083 }
2084 })->prio (1);
2085}
2086
2087=head3 cf::client
2088
2089=over 4
2090
2091=item $client->send_drawinfo ($text, $flags)
2092
2093Sends a drawinfo packet to the client. Circumvents output buffering so
2094should not be used under normal circumstances.
2095
2096=cut
2097
2098sub cf::client::send_drawinfo {
2099 my ($self, $text, $flags) = @_;
2100
2101 utf8::encode $text;
2102 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2103}
2104
2105=item $client->ext_event ($type, %msg)
2106
2107Sends an exti event to the client.
2108
2109=cut
2110
2111sub cf::client::ext_event($$%) {
2112 my ($self, $type, %msg) = @_;
2113
2114 $msg{msgtype} = "event_$type";
2115 $self->send_packet ("ext " . cf::to_json \%msg);
2116}
2117
2118=item $success = $client->query ($flags, "text", \&cb)
2119
2120Queues a query to the client, calling the given callback with
2121the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
2122C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2123
2124Queries can fail, so check the return code. Or don't, as queries will become
2125reliable at some point in the future.
2126
2127=cut
2128
2129sub cf::client::query {
2130 my ($self, $flags, $text, $cb) = @_;
2131
2132 return unless $self->state == ST_PLAYING
2133 || $self->state == ST_SETUP
2134 || $self->state == ST_CUSTOM;
2135
2136 $self->state (ST_CUSTOM);
2137
2138 utf8::encode $text;
2139 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2140
2141 $self->send_packet ($self->{query_queue}[0][0])
2142 if @{ $self->{query_queue} } == 1;
2143}
2144
2145cf::client->attach (
2146 on_reply => sub {
2147 my ($ns, $msg) = @_;
2148
2149 # this weird shuffling is so that direct followup queries
2150 # get handled first
2151 my $queue = delete $ns->{query_queue}
2152 or return; # be conservative, not sure how that can happen, but we saw a crash here
2153
2154 (shift @$queue)->[1]->($msg);
2155 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
2156
2157 push @{ $ns->{query_queue} }, @$queue;
2158
2159 if (@{ $ns->{query_queue} } == @$queue) {
2160 if (@$queue) {
2161 $ns->send_packet ($ns->{query_queue}[0][0]);
2162 } else {
2163 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2164 }
2165 }
2166 },
2167);
2168
2169=item $client->async (\&cb)
2170
2171Create a new coroutine, running the specified callback. The coroutine will
2172be automatically cancelled when the client gets destroyed (e.g. on logout,
2173or loss of connection).
2174
2175=cut
2176
2177sub cf::client::async {
2178 my ($self, $cb) = @_;
2179
2180 my $coro = &Coro::async ($cb);
2181
2182 $coro->on_destroy (sub {
2183 delete $self->{_coro}{$coro+0};
2184 });
2185
2186 $self->{_coro}{$coro+0} = $coro;
2187
2188 $coro
2189}
2190
2191cf::client->attach (
2192 on_destroy => sub {
2193 my ($ns) = @_;
2194
2195 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
2196 },
2197);
2198
2199=back
2200
2201
2202=head2 SAFE SCRIPTING
2203
2204Functions that provide a safe environment to compile and execute
2205snippets of perl code without them endangering the safety of the server
2206itself. Looping constructs, I/O operators and other built-in functionality
2207is not available in the safe scripting environment, and the number of
2208functions and methods that can be called is greatly reduced.
2209
2210=cut
2211
384our $safe = new Safe "ext"; 2212our $safe = new Safe "safe";
385our $safe_hole = new Safe::Hole; 2213our $safe_hole = new Safe::Hole;
386 2214
387$SIG{FPE} = 'IGNORE'; 2215$SIG{FPE} = 'IGNORE';
388 2216
389$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 2217$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));
390 2218
391# here we would export the classes and methods available to script code 2219# here we export the classes and methods available to script code
392#@ext::cf::object::player::ISA = @cf::object::player::ISA; 2220
393#@ext::cf::object::map::ISA = @cf::object::map::ISA; 2221=pod
2222
2223The following functions and methods are available within a safe environment:
2224
2225 cf::object contr pay_amount pay_player map
2226 cf::object::player player
2227 cf::player peaceful
2228 cf::map trigger
2229
2230=cut
2231
2232for (
2233 ["cf::object" => qw(contr pay_amount pay_player map)],
2234 ["cf::object::player" => qw(player)],
2235 ["cf::player" => qw(peaceful)],
2236 ["cf::map" => qw(trigger)],
2237) {
2238 no strict 'refs';
2239 my ($pkg, @funs) = @$_;
2240 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
2241 for @funs;
2242}
2243
2244=over 4
2245
2246=item @retval = safe_eval $code, [var => value, ...]
2247
2248Compiled and executes the given perl code snippet. additional var/value
2249pairs result in temporary local (my) scalar variables of the given name
2250that are available in the code snippet. Example:
2251
2252 my $five = safe_eval '$first + $second', first => 1, second => 4;
2253
2254=cut
394 2255
395sub safe_eval($;@) { 2256sub safe_eval($;@) {
396 my ($code, %vars) = @_; 2257 my ($code, %vars) = @_;
397 2258
398 my $qcode = $code; 2259 my $qcode = $code;
399 $qcode =~ s/"/‟/g; # not allowed in #line filenames 2260 $qcode =~ s/"/‟/g; # not allowed in #line filenames
400 $qcode =~ s/\n/\\n/g; 2261 $qcode =~ s/\n/\\n/g;
401 2262
402 local $_; 2263 local $_;
403 local @ext::cf::_safe_eval_args = values %vars; 2264 local @safe::cf::_safe_eval_args = values %vars;
404 2265
405 $safe->reval ( 2266 my $eval =
406 "do {\n" 2267 "do {\n"
407 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 2268 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
408 . "#line 0 \"{$qcode}\"\n" 2269 . "#line 0 \"{$qcode}\"\n"
409 . $code 2270 . $code
410 . "\n}" 2271 . "\n}"
411 ) 2272 ;
2273
2274 sub_generation_inc;
2275 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
2276 sub_generation_inc;
2277
2278 if ($@) {
2279 warn "$@";
2280 warn "while executing safe code '$code'\n";
2281 warn "with arguments " . (join " ", %vars) . "\n";
2282 }
2283
2284 wantarray ? @res : $res[0]
412} 2285}
2286
2287=item cf::register_script_function $function => $cb
2288
2289Register a function that can be called from within map/npc scripts. The
2290function should be reasonably secure and should be put into a package name
2291like the extension.
2292
2293Example: register a function that gets called whenever a map script calls
2294C<rent::overview>, as used by the C<rent> extension.
2295
2296 cf::register_script_function "rent::overview" => sub {
2297 ...
2298 };
2299
2300=cut
413 2301
414sub register_script_function { 2302sub register_script_function {
415 my ($fun, $cb) = @_; 2303 my ($fun, $cb) = @_;
416 2304
417 no strict 'refs'; 2305 no strict 'refs';
418 *{"ext::$fun"} = $safe_hole->wrap ($cb); 2306 *{"safe::$fun"} = $safe_hole->wrap ($cb);
419} 2307}
2308
2309=back
2310
2311=cut
420 2312
421############################################################################# 2313#############################################################################
422# initialisation
423 2314
424register "<global>", __PACKAGE__; 2315=head2 EXTENSION DATABASE SUPPORT
425 2316
426unshift @INC, maps_directory "perl"; 2317Crossfire maintains a very simple database for extension use. It can
2318currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2319convert to/from binary).
427 2320
2321The parameter C<$family> should best start with the name of the extension
2322using it, it should be unique.
2323
2324=over 4
2325
2326=item $value = cf::db_get $family => $key
2327
2328Returns a single value from the database.
2329
2330=item cf::db_put $family => $key => $value
2331
2332Stores the given C<$value> in the family.
2333
2334=cut
2335
2336our $DB;
2337
2338sub db_init {
2339 unless ($DB) {
2340 $DB = BDB::db_create $DB_ENV;
2341
2342 cf::sync_job {
2343 eval {
2344 $DB->set_flags (BDB::CHKSUM);
2345
2346 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2347 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2348 cf::cleanup "db_open(db): $!" if $!;
2349 };
2350 cf::cleanup "db_open(db): $@" if $@;
2351 };
2352 }
2353}
2354
2355sub db_get($$) {
2356 my $key = "$_[0]/$_[1]";
2357
2358 cf::sync_job {
2359 BDB::db_get $DB, undef, $key, my $data;
2360
2361 $! ? ()
2362 : $data
2363 }
2364}
2365
2366sub db_put($$$) {
2367 BDB::dbreq_pri 4;
2368 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2369}
2370
2371=item cf::cache $id => [$paths...], $processversion => $process
2372
2373Generic caching function that returns the value of the resource $id,
2374caching and regenerating as required.
2375
2376This function can block.
2377
2378=cut
2379
2380sub cache {
2381 my ($id, $src, $processversion, $process) = @_;
2382
2383 my $meta =
2384 join "\x00",
2385 $processversion,
2386 map {
2387 aio_stat $_
2388 and Carp::croak "$_: $!";
2389
2390 ($_, (stat _)[7,9])
2391 } @$src;
2392
2393 my $dbmeta = db_get cache => "$id/meta";
2394 if ($dbmeta ne $meta) {
2395 # changed, we may need to process
2396
2397 my @data;
2398 my $md5;
2399
2400 for (0 .. $#$src) {
2401 0 <= aio_load $src->[$_], $data[$_]
2402 or Carp::croak "$src->[$_]: $!";
2403 }
2404
2405 # if processing is expensive, check
2406 # checksum first
2407 if (1) {
2408 $md5 =
2409 join "\x00",
2410 $processversion,
2411 map {
2412 Coro::cede;
2413 ($src->[$_], Digest::MD5::md5_hex $data[$_])
2414 } 0.. $#$src;
2415
2416
2417 my $dbmd5 = db_get cache => "$id/md5";
2418 if ($dbmd5 eq $md5) {
2419 db_put cache => "$id/meta", $meta;
2420
2421 return db_get cache => "$id/data";
2422 }
2423 }
2424
2425 my $t1 = Time::HiRes::time;
2426 my $data = $process->(\@data);
2427 my $t2 = Time::HiRes::time;
2428
2429 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2430
2431 db_put cache => "$id/data", $data;
2432 db_put cache => "$id/md5" , $md5;
2433 db_put cache => "$id/meta", $meta;
2434
2435 return $data;
2436 }
2437
2438 db_get cache => "$id/data"
2439}
2440
2441=item fork_call { }, $args
2442
2443Executes the given code block with the given arguments in a seperate
2444process, returning the results. Everything must be serialisable with
2445Coro::Storable. May, of course, block. Note that the executed sub may
2446never block itself or use any form of Event handling.
2447
2448=cut
2449
2450sub fork_call(&@) {
2451 my ($cb, @args) = @_;
2452
2453# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2454# or die "socketpair: $!";
2455 pipe my $fh1, my $fh2
2456 or die "pipe: $!";
2457
2458 if (my $pid = fork) {
2459 close $fh2;
2460
2461 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2462 $res = Coro::Storable::thaw $res;
2463
2464 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2465
2466 die $$res unless "ARRAY" eq ref $res;
2467
2468 return wantarray ? @$res : $res->[-1];
2469 } else {
2470 reset_signals;
2471 local $SIG{__WARN__};
2472 local $SIG{__DIE__};
2473 eval {
2474 close $fh1;
2475
2476 my @res = eval { $cb->(@args) };
2477 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2478 };
2479
2480 warn $@ if $@;
2481 _exit 0;
2482 }
2483}
2484
2485#############################################################################
2486# the server's init and main functions
2487
2488sub load_facedata($) {
2489 my ($path) = @_;
2490
2491 warn "loading facedata from $path\n";
2492
2493 my $facedata;
2494 0 < aio_load $path, $facedata
2495 or die "$path: $!";
2496
2497 $facedata = Coro::Storable::thaw $facedata;
2498
2499 $facedata->{version} == 2
2500 or cf::cleanup "$path: version mismatch, cannot proceed.";
2501
2502 {
2503 my $faces = $facedata->{faceinfo};
2504
2505 while (my ($face, $info) = each %$faces) {
2506 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2507 cf::face::set $idx, $info->{visibility}, $info->{magicmap};
2508 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2509 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2510 Coro::cede;
2511 }
2512
2513 while (my ($face, $info) = each %$faces) {
2514 next unless $info->{smooth};
2515 my $idx = cf::face::find $face
2516 or next;
2517 if (my $smooth = cf::face::find $info->{smooth}) {
2518 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel};
2519 } else {
2520 warn "smooth face '$info->{smooth}' not found for face '$face'";
2521 }
2522 Coro::cede;
2523 }
2524 }
2525
2526 {
2527 my $anims = $facedata->{animinfo};
2528
2529 while (my ($anim, $info) = each %$anims) {
2530 cf::anim::set $anim, $info->{frames}, $info->{facings};
2531 Coro::cede;
2532 }
2533
2534 cf::anim::invalidate_all; # d'oh
2535 }
2536
2537 1
2538}
2539
2540sub reload_regions {
2541 load_resource_file "$MAPDIR/regions"
2542 or die "unable to load regions file\n";
2543}
2544
2545sub reload_facedata {
2546 load_facedata "$DATADIR/facedata"
2547 or die "unable to load facedata\n";
2548}
2549
2550sub reload_archetypes {
2551 load_resource_file "$DATADIR/archetypes"
2552 or die "unable to load archetypes\n";
2553}
2554
2555sub reload_treasures {
2556 load_resource_file "$DATADIR/treasures"
2557 or die "unable to load treasurelists\n";
2558}
2559
2560sub reload_resources {
2561 warn "reloading resource files...\n";
2562
2563 reload_regions;
2564 reload_facedata;
2565 reload_archetypes;
2566 reload_treasures;
2567
2568 warn "finished reloading resource files\n";
2569}
2570
2571sub init {
2572 reload_resources;
2573}
2574
2575sub cfg_load {
2576 open my $fh, "<:utf8", "$CONFDIR/config"
2577 or return;
2578
2579 local $/;
2580 *CFG = YAML::Syck::Load <$fh>;
2581
2582 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
2583
2584 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2585 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
2586
2587 if (exists $CFG{mlockall}) {
2588 eval {
2589 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
2590 and die "WARNING: m(un)lockall failed: $!\n";
2591 };
2592 warn $@ if $@;
2593 }
2594}
2595
2596sub main {
2597 # we must not ever block the main coroutine
2598 local $Coro::idle = sub {
2599 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2600 (async {
2601 Event::one_event;
2602 })->prio (Coro::PRIO_MAX);
2603 };
2604
2605 cfg_load;
2606 db_init;
428load_extensions; 2607 load_extensions;
2608
2609 $TICK_WATCHER->start;
2610 Event::loop;
2611}
2612
2613#############################################################################
2614# initialisation and cleanup
2615
2616# install some emergency cleanup handlers
2617BEGIN {
2618 for my $signal (qw(INT HUP TERM)) {
2619 Event->signal (
2620 reentrant => 0,
2621 data => WF_AUTOCANCEL,
2622 signal => $signal,
2623 prio => 0,
2624 cb => sub {
2625 cf::cleanup "SIG$signal";
2626 },
2627 );
2628 }
2629}
2630
2631sub emergency_save() {
2632 my $freeze_guard = cf::freeze_mainloop;
2633
2634 warn "enter emergency perl save\n";
2635
2636 cf::sync_job {
2637 # use a peculiar iteration method to avoid tripping on perl
2638 # refcount bugs in for. also avoids problems with players
2639 # and maps saved/destroyed asynchronously.
2640 warn "begin emergency player save\n";
2641 for my $login (keys %cf::PLAYER) {
2642 my $pl = $cf::PLAYER{$login} or next;
2643 $pl->valid or next;
2644 $pl->save;
2645 }
2646 warn "end emergency player save\n";
2647
2648 warn "begin emergency map save\n";
2649 for my $path (keys %cf::MAP) {
2650 my $map = $cf::MAP{$path} or next;
2651 $map->valid or next;
2652 $map->save;
2653 }
2654 warn "end emergency map save\n";
2655
2656 warn "begin emergency database checkpoint\n";
2657 BDB::db_env_txn_checkpoint $DB_ENV;
2658 warn "end emergency database checkpoint\n";
2659 };
2660
2661 warn "leave emergency perl save\n";
2662}
2663
2664sub post_cleanup {
2665 my ($make_core) = @_;
2666
2667 warn Carp::longmess "post_cleanup backtrace"
2668 if $make_core;
2669}
2670
2671sub do_reload_perl() {
2672 # can/must only be called in main
2673 if ($Coro::current != $Coro::main) {
2674 warn "can only reload from main coroutine";
2675 return;
2676 }
2677
2678 warn "reloading...";
2679
2680 warn "entering sync_job";
2681
2682 cf::sync_job {
2683 cf::write_runtime; # external watchdog should not bark
2684 cf::emergency_save;
2685 cf::write_runtime; # external watchdog should not bark
2686
2687 warn "syncing database to disk";
2688 BDB::db_env_txn_checkpoint $DB_ENV;
2689
2690 # if anything goes wrong in here, we should simply crash as we already saved
2691
2692 warn "cancelling all WF_AUTOCANCEL watchers";
2693 for (Event::all_watchers) {
2694 $_->cancel if $_->data & WF_AUTOCANCEL;
2695 }
2696
2697 warn "flushing outstanding aio requests";
2698 for (;;) {
2699 BDB::flush;
2700 IO::AIO::flush;
2701 Coro::cede;
2702 last unless IO::AIO::nreqs || BDB::nreqs;
2703 warn "iterate...";
2704 }
2705
2706 ++$RELOAD;
2707
2708 warn "cancelling all extension coros";
2709 $_->cancel for values %EXT_CORO;
2710 %EXT_CORO = ();
2711
2712 warn "removing commands";
2713 %COMMAND = ();
2714
2715 warn "removing ext commands";
2716 %EXTCMD = ();
2717
2718 warn "unloading/nuking all extensions";
2719 for my $pkg (@EXTS) {
2720 warn "... unloading $pkg";
2721
2722 if (my $cb = $pkg->can ("unload")) {
2723 eval {
2724 $cb->($pkg);
2725 1
2726 } or warn "$pkg unloaded, but with errors: $@";
2727 }
2728
2729 warn "... nuking $pkg";
2730 Symbol::delete_package $pkg;
2731 }
2732
2733 warn "unloading all perl modules loaded from $LIBDIR";
2734 while (my ($k, $v) = each %INC) {
2735 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2736
2737 warn "... unloading $k";
2738 delete $INC{$k};
2739
2740 $k =~ s/\.pm$//;
2741 $k =~ s/\//::/g;
2742
2743 if (my $cb = $k->can ("unload_module")) {
2744 $cb->();
2745 }
2746
2747 Symbol::delete_package $k;
2748 }
2749
2750 warn "getting rid of safe::, as good as possible";
2751 Symbol::delete_package "safe::$_"
2752 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2753
2754 warn "unloading cf.pm \"a bit\"";
2755 delete $INC{"cf.pm"};
2756 delete $INC{"cf/pod.pm"};
2757
2758 # don't, removes xs symbols, too,
2759 # and global variables created in xs
2760 #Symbol::delete_package __PACKAGE__;
2761
2762 warn "unload completed, starting to reload now";
2763
2764 warn "reloading cf.pm";
2765 require cf;
2766 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2767
2768 warn "loading config and database again";
2769 cf::cfg_load;
2770
2771 warn "loading extensions";
2772 cf::load_extensions;
2773
2774 warn "reattaching attachments to objects/players";
2775 _global_reattach; # objects, sockets
2776 warn "reattaching attachments to maps";
2777 reattach $_ for values %MAP;
2778 warn "reattaching attachments to players";
2779 reattach $_ for values %PLAYER;
2780
2781 warn "leaving sync_job";
2782
2783 1
2784 } or do {
2785 warn $@;
2786 warn "error while reloading, exiting.";
2787 exit 1;
2788 };
2789
2790 warn "reloaded";
2791};
2792
2793our $RELOAD_WATCHER; # used only during reload
2794
2795sub reload_perl() {
2796 # doing reload synchronously and two reloads happen back-to-back,
2797 # coro crashes during coro_state_free->destroy here.
2798
2799 $RELOAD_WATCHER ||= Event->timer (
2800 reentrant => 0,
2801 after => 0,
2802 data => WF_AUTOCANCEL,
2803 cb => sub {
2804 do_reload_perl;
2805 undef $RELOAD_WATCHER;
2806 },
2807 );
2808}
2809
2810register_command "reload" => sub {
2811 my ($who, $arg) = @_;
2812
2813 if ($who->flag (FLAG_WIZ)) {
2814 $who->message ("reloading server.");
2815 async { reload_perl };
2816 }
2817};
2818
2819unshift @INC, $LIBDIR;
2820
2821my $bug_warning = 0;
2822
2823our @WAIT_FOR_TICK;
2824our @WAIT_FOR_TICK_BEGIN;
2825
2826sub wait_for_tick {
2827 return unless $TICK_WATCHER->is_active;
2828 return if $Coro::current == $Coro::main;
2829
2830 my $signal = new Coro::Signal;
2831 push @WAIT_FOR_TICK, $signal;
2832 $signal->wait;
2833}
2834
2835sub wait_for_tick_begin {
2836 return unless $TICK_WATCHER->is_active;
2837 return if $Coro::current == $Coro::main;
2838
2839 my $signal = new Coro::Signal;
2840 push @WAIT_FOR_TICK_BEGIN, $signal;
2841 $signal->wait;
2842}
2843
2844 my $min = 1e6;#d#
2845 my $avg = 10;
2846$TICK_WATCHER = Event->timer (
2847 reentrant => 0,
2848 parked => 1,
2849 prio => 0,
2850 at => $NEXT_TICK || $TICK,
2851 data => WF_AUTOCANCEL,
2852 cb => sub {
2853 if ($Coro::current != $Coro::main) {
2854 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2855 unless ++$bug_warning > 10;
2856 return;
2857 }
2858
2859 $NOW = $tick_start = Event::time;
2860
2861 cf::server_tick; # one server iteration
2862
2863 0 && sync_job {#d#
2864 for(1..10) {
2865 my $t = Event::time;
2866 my $map = my $map = new_from_path cf::map "/tmp/x.map"
2867 or die;
2868
2869 $map->width (50);
2870 $map->height (50);
2871 $map->alloc;
2872 $map->_load_objects ("/tmp/x.map", 1);
2873 my $t = Event::time - $t;
2874
2875 #next unless $t < 0.0013;#d#
2876 if ($t < $min) {
2877 $min = $t;
2878 }
2879 $avg = $avg * 0.99 + $t * 0.01;
2880 }
2881 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
2882 exit 0;
2883 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
2884 };
2885
2886 $RUNTIME += $TICK;
2887 $NEXT_TICK += $TICK;
2888
2889 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2890 $NEXT_RUNTIME_WRITE = $NOW + 10;
2891 Coro::async_pool {
2892 write_runtime
2893 or warn "ERROR: unable to write runtime file: $!";
2894 };
2895 }
2896
2897# my $AFTER = Event::time;
2898# warn $AFTER - $NOW;#d#
2899
2900 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
2901 $sig->send;
2902 }
2903 while (my $sig = shift @WAIT_FOR_TICK) {
2904 $sig->send;
2905 }
2906
2907 $NOW = Event::time;
2908
2909 # if we are delayed by four ticks or more, skip them all
2910 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2911
2912 $TICK_WATCHER->at ($NEXT_TICK);
2913 $TICK_WATCHER->start;
2914
2915 $LOAD = ($NOW - $tick_start) / $TICK;
2916 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
2917
2918 _post_tick;
2919
2920
2921 },
2922);
2923
2924{
2925 BDB::max_poll_time $TICK * 0.1;
2926 $BDB_POLL_WATCHER = Event->io (
2927 reentrant => 0,
2928 fd => BDB::poll_fileno,
2929 poll => 'r',
2930 prio => 0,
2931 data => WF_AUTOCANCEL,
2932 cb => \&BDB::poll_cb,
2933 );
2934 BDB::min_parallel 8;
2935
2936 BDB::set_sync_prepare {
2937 my $status;
2938 my $current = $Coro::current;
2939 (
2940 sub {
2941 $status = $!;
2942 $current->ready; undef $current;
2943 },
2944 sub {
2945 Coro::schedule while defined $current;
2946 $! = $status;
2947 },
2948 )
2949 };
2950
2951 unless ($DB_ENV) {
2952 $DB_ENV = BDB::db_env_create;
2953
2954 cf::sync_job {
2955 eval {
2956 BDB::db_env_open
2957 $DB_ENV,
2958 $BDBDIR,
2959 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2960 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2961 0666;
2962
2963 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2964
2965 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2966 $DB_ENV->set_lk_detect;
2967 };
2968
2969 cf::cleanup "db_env_open(db): $@" if $@;
2970 };
2971 }
2972}
2973
2974{
2975 IO::AIO::min_parallel 8;
2976
2977 undef $Coro::AIO::WATCHER;
2978 IO::AIO::max_poll_time $TICK * 0.1;
2979 $AIO_POLL_WATCHER = Event->io (
2980 reentrant => 0,
2981 data => WF_AUTOCANCEL,
2982 fd => IO::AIO::poll_fileno,
2983 poll => 'r',
2984 prio => 6,
2985 cb => \&IO::AIO::poll_cb,
2986 );
2987}
2988
2989my $_log_backtrace;
2990
2991sub _log_backtrace {
2992 my ($msg, @addr) = @_;
2993
2994 $msg =~ s/\n//;
2995
2996 # limit the # of concurrent backtraces
2997 if ($_log_backtrace < 2) {
2998 ++$_log_backtrace;
2999 async {
3000 my @bt = fork_call {
3001 @addr = map { sprintf "%x", $_ } @addr;
3002 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3003 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3004 or die "addr2line: $!";
3005
3006 my @funcs;
3007 my @res = <$fh>;
3008 chomp for @res;
3009 while (@res) {
3010 my ($func, $line) = splice @res, 0, 2, ();
3011 push @funcs, "[$func] $line";
3012 }
3013
3014 @funcs
3015 };
3016
3017 LOG llevInfo, "[ABT] $msg\n";
3018 LOG llevInfo, "[ABT] $_\n" for @bt;
3019 --$_log_backtrace;
3020 };
3021 } else {
3022 LOG llevInfo, "[ABT] $msg\n";
3023 LOG llevInfo, "[ABT] [suppressed]\n";
3024 }
3025}
3026
3027# load additional modules
3028use cf::pod;
3029
3030END { cf::emergency_save }
429 3031
4301 30321
431 3033

Diff Legend

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