ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/server/lib/cf.pm
Revision: 1.123
Committed: Tue Jan 2 19:18:33 2007 UTC (17 years, 5 months ago) by root
Branch: MAIN
Changes since 1.122: +1 -0 lines
Log Message:
lotsa bugfixes

File Contents

# User Rev Content
1 root 1.1 package cf;
2    
3 root 1.96 use utf8;
4     use strict;
5    
6 root 1.1 use Symbol;
7     use List::Util;
8 root 1.6 use Storable;
9 root 1.23 use Opcode;
10     use Safe;
11     use Safe::Hole;
12 root 1.19
13 root 1.103 use Coro 3.3;
14 root 1.96 use Coro::Event;
15     use Coro::Timer;
16     use Coro::Signal;
17     use Coro::Semaphore;
18 root 1.105 use Coro::AIO;
19 root 1.96
20 root 1.108 use Digest::MD5;
21 root 1.105 use Fcntl;
22     use IO::AIO 2.31 ();
23 root 1.72 use YAML::Syck ();
24 root 1.32 use Time::HiRes;
25 root 1.96
26     use Event; $Event::Eval = 1; # no idea why this is required, but it is
27 root 1.1
28 root 1.72 # work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
29     $YAML::Syck::ImplicitUnicode = 1;
30    
31 root 1.103 $Coro::main->prio (2); # run main coroutine ("the server") with very high priority
32 root 1.1
33 root 1.87 sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
34    
35 root 1.85 our %COMMAND = ();
36     our %COMMAND_TIME = ();
37     our %EXTCMD = ();
38    
39 root 1.1 our @EVENT;
40 root 1.88 our $LIBDIR = datadir . "/ext";
41 root 1.1
42 root 1.35 our $TICK = MAX_TIME * 1e-6;
43     our $TICK_WATCHER;
44     our $NEXT_TICK;
45 root 1.103 our $NOW;
46 root 1.35
47 root 1.70 our %CFG;
48    
49 root 1.84 our $UPTIME; $UPTIME ||= time;
50 root 1.103 our $RUNTIME;
51    
52     our %MAP; # all maps
53     our $LINK_MAP; # the special {link} map
54     our $FREEZE;
55 root 1.108 our $RANDOM_MAPS = cf::localdir . "/random";
56     our %EXT_CORO;
57 root 1.103
58     binmode STDOUT;
59     binmode STDERR;
60    
61     # read virtual server time, if available
62     unless ($RUNTIME || !-e cf::localdir . "/runtime") {
63     open my $fh, "<", cf::localdir . "/runtime"
64     or die "unable to read runtime file: $!";
65     $RUNTIME = <$fh> + 0.;
66     }
67    
68     mkdir cf::localdir;
69     mkdir cf::localdir . "/" . cf::playerdir;
70     mkdir cf::localdir . "/" . cf::tmpdir;
71     mkdir cf::localdir . "/" . cf::uniquedir;
72 root 1.108 mkdir $RANDOM_MAPS;
73 root 1.103
74 root 1.108 # a special map that is always available
75     our $LINK_MAP;
76 root 1.76
77 root 1.110 our $EMERGENCY_POSITION = $cf::CFG{emergency_position} || ["/world/world_105_115", 5, 37];
78    
79 root 1.70 #############################################################################
80    
81     =head2 GLOBAL VARIABLES
82    
83     =over 4
84    
85 root 1.83 =item $cf::UPTIME
86    
87     The timestamp of the server start (so not actually an uptime).
88    
89 root 1.103 =item $cf::RUNTIME
90    
91     The time this server has run, starts at 0 and is increased by $cf::TICK on
92     every server tick.
93    
94 root 1.70 =item $cf::LIBDIR
95    
96     The perl library directory, where extensions and cf-specific modules can
97     be found. It will be added to C<@INC> automatically.
98    
99 root 1.103 =item $cf::NOW
100    
101     The time of the last (current) server tick.
102    
103 root 1.70 =item $cf::TICK
104    
105     The interval between server ticks, in seconds.
106    
107     =item %cf::CFG
108    
109     Configuration for the server, loaded from C</etc/crossfire/config>, or
110     from wherever your confdir points to.
111    
112     =back
113    
114     =cut
115    
116 root 1.1 BEGIN {
117     *CORE::GLOBAL::warn = sub {
118     my $msg = join "", @_;
119 root 1.103 utf8::encode $msg;
120    
121 root 1.1 $msg .= "\n"
122     unless $msg =~ /\n$/;
123    
124     LOG llevError, "cfperl: $msg";
125     };
126     }
127    
128 root 1.93 @safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
129     @safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
130     @safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
131     @safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
132     @safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
133 root 1.41 @safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
134 root 1.25
135 root 1.41 # we bless all objects into (empty) derived classes to force a method lookup
136 root 1.25 # within the Safe compartment.
137 root 1.86 for my $pkg (qw(
138 root 1.100 cf::global cf::attachable
139 root 1.86 cf::object cf::object::player
140 root 1.89 cf::client cf::player
141 root 1.86 cf::arch cf::living
142     cf::map cf::party cf::region
143     )) {
144 root 1.25 no strict 'refs';
145 root 1.41 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
146 root 1.25 }
147 root 1.1
148 root 1.18 $Event::DIED = sub {
149     warn "error in event callback: @_";
150     };
151    
152 root 1.5 my %ext_pkg;
153 root 1.1 my @exts;
154     my @hook;
155    
156 root 1.70 =head2 UTILITY FUNCTIONS
157    
158     =over 4
159    
160     =cut
161 root 1.44
162 root 1.45 use JSON::Syck (); # TODO# replace by JSON::PC once working
163 root 1.44
164 root 1.70 =item $ref = cf::from_json $json
165    
166     Converts a JSON string into the corresponding perl data structure.
167    
168     =cut
169    
170 root 1.45 sub from_json($) {
171     $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
172     JSON::Syck::Load $_[0]
173 root 1.44 }
174    
175 root 1.70 =item $json = cf::to_json $ref
176    
177     Converts a perl data structure into its JSON representation.
178    
179     =cut
180    
181 root 1.45 sub to_json($) {
182     $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
183     JSON::Syck::Dump $_[0]
184 root 1.44 }
185    
186 root 1.120 =item my $guard = cf::guard { BLOCK }
187    
188     Run the given callback when the guard object gets destroyed (useful for
189     coroutine cancellations).
190    
191     You can call C<< ->cancel >> on the guard object to stop the block from
192     being executed.
193    
194     =cut
195    
196     sub guard(&) {
197     bless \(my $cb = $_[0]), cf::guard::;
198     }
199    
200     sub cf::guard::cancel {
201     ${$_[0]} = sub { };
202     }
203    
204     sub cf::guard::DESTROY {
205     ${$_[0]}->();
206     }
207    
208     =item cf::lock_wait $string
209    
210     Wait until the given lock is available. See cf::lock_acquire.
211    
212     =item my $lock = cf::lock_acquire $string
213    
214     Wait until the given lock is available and then acquires it and returns
215     a guard object. If the guard object gets destroyed (goes out of scope,
216     for example when the coroutine gets canceled), the lock is automatically
217     returned.
218    
219     Lock names should begin with a unique identifier (for example, find_map
220     uses map_find and load_map uses map_load).
221    
222     =cut
223    
224     our %LOCK;
225    
226     sub lock_wait($) {
227     my ($key) = @_;
228    
229     # wait for lock, if any
230     while ($LOCK{$key}) {
231     push @{ $LOCK{$key} }, $Coro::current;
232     Coro::schedule;
233     }
234     }
235    
236     sub lock_acquire($) {
237     my ($key) = @_;
238    
239     # wait, to be sure we are not locked
240     lock_wait $key;
241    
242     $LOCK{$key} = [];
243    
244     cf::guard {
245     # wake up all waiters, to be on the safe side
246     $_->ready for @{ delete $LOCK{$key} };
247     }
248     }
249    
250 root 1.106 =item cf::sync_job { BLOCK }
251    
252     The design of crossfire+ requires that the main coro ($Coro::main) is
253     always able to handle events or runnable, as crossfire+ is only partly
254     reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable.
255    
256     If it must be done, put the blocking parts into C<sync_job>. This will run
257     the given BLOCK in another coroutine while waiting for the result. The
258     server will be frozen during this time, so the block should either finish
259     fast or be very important.
260    
261     =cut
262    
263 root 1.105 sub sync_job(&) {
264     my ($job) = @_;
265    
266     if ($Coro::current == $Coro::main) {
267 root 1.112 # this is the main coro, too bad, we have to block
268     # till the operation succeeds, freezing the server :/
269    
270 root 1.110 # TODO: use suspend/resume instead
271 root 1.112 # (but this is cancel-safe)
272 root 1.110 local $FREEZE = 1;
273 root 1.112
274     my $busy = 1;
275     my @res;
276    
277     (Coro::async {
278     @res = eval { $job->() };
279     warn $@ if $@;
280     undef $busy;
281     })->prio (Coro::PRIO_MAX);
282    
283 root 1.105 while ($busy) {
284     Coro::cede_notself;
285     Event::one_event unless Coro::nready;
286     }
287 root 1.112
288     wantarray ? @res : $res[0]
289 root 1.105 } else {
290 root 1.112 # we are in another coroutine, how wonderful, everything just works
291    
292     $job->()
293 root 1.105 }
294     }
295    
296 root 1.103 =item $coro = cf::coro { BLOCK }
297    
298     Creates and returns a new coro. This coro is automcatially being canceled
299     when the extension calling this is being unloaded.
300    
301     =cut
302    
303     sub coro(&) {
304     my $cb = shift;
305    
306     my $coro; $coro = async {
307     eval {
308     $cb->();
309     };
310     warn $@ if $@;
311     };
312    
313     $coro->on_destroy (sub {
314     delete $EXT_CORO{$coro+0};
315     });
316     $EXT_CORO{$coro+0} = $coro;
317    
318     $coro
319     }
320    
321 root 1.108 sub write_runtime {
322     my $runtime = cf::localdir . "/runtime";
323    
324     my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
325     or return;
326    
327 root 1.112 my $value = $cf::RUNTIME + 1 + 10; # 10 is the runtime save interval, for a monotonic clock
328 root 1.108 (aio_write $fh, 0, (length $value), $value, 0) <= 0
329     and return;
330    
331     aio_fsync $fh
332     and return;
333    
334     close $fh
335     or return;
336    
337     aio_rename "$runtime~", $runtime
338     and return;
339    
340     1
341     }
342    
343 root 1.70 =back
344    
345 root 1.71 =cut
346    
347 root 1.44 #############################################################################
348 root 1.39
349 root 1.108 package cf::path;
350    
351     sub new {
352     my ($class, $path, $base) = @_;
353    
354 root 1.110 $path = $path->as_string if ref $path;
355    
356 root 1.108 my $self = bless { }, $class;
357    
358 root 1.114 # {... are special paths that are not touched
359     # ?xxx/... are special absolute paths
360     # ?random/... random maps
361     # /! non-realised random map exit
362     # /... normal maps
363     # ~/... per-player maps without a specific player (DO NOT USE)
364     # ~user/... per-player map of a specific user
365    
366     if ($path =~ /^{/) {
367     # fine as it is
368     } elsif ($path =~ s{^\?random/}{}) {
369 root 1.109 Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;
370     $self->{random} = cf::from_json $data;
371 root 1.108 } else {
372     if ($path =~ s{^~([^/]+)?}{}) {
373     $self->{user_rel} = 1;
374    
375     if (defined $1) {
376     $self->{user} = $1;
377     } elsif ($base =~ m{^~([^/]+)/}) {
378     $self->{user} = $1;
379     } else {
380     warn "cannot resolve user-relative path without user <$path,$base>\n";
381     }
382     } elsif ($path =~ /^\//) {
383     # already absolute
384     } else {
385     $base =~ s{[^/]+/?$}{};
386     return $class->new ("$base/$path");
387     }
388    
389     for ($path) {
390     redo if s{/\.?/}{/};
391     redo if s{/[^/]+/\.\./}{/};
392     }
393     }
394    
395     $self->{path} = $path;
396    
397     $self
398     }
399    
400     # the name / primary key / in-game path
401     sub as_string {
402     my ($self) = @_;
403    
404     $self->{user_rel} ? "~$self->{user}$self->{path}"
405     : $self->{random} ? "?random/$self->{path}"
406     : $self->{path}
407     }
408    
409     # the displayed name, this is a one way mapping
410     sub visible_name {
411     my ($self) = @_;
412    
413 root 1.109 # if (my $rmp = $self->{random}) {
414     # # todo: be more intelligent about this
415     # "?random/$rmp->{origin_map}+$rmp->{origin_x}+$rmp->{origin_y}/$rmp->{dungeon_level}"
416     # } else {
417     $self->as_string
418     # }
419 root 1.108 }
420    
421     # escape the /'s in the path
422     sub _escaped_path {
423     # ∕ is U+2215
424     (my $path = $_[0]{path}) =~ s/\//∕/g;
425     $path
426     }
427    
428     # the original (read-only) location
429     sub load_path {
430     my ($self) = @_;
431    
432     sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path}
433     }
434    
435     # the temporary/swap location
436     sub save_path {
437     my ($self) = @_;
438    
439     $self->{user_rel} ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path
440 root 1.109 : $self->{random} ? sprintf "%s/%s", $RANDOM_MAPS, $self->{path}
441 root 1.108 : sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path
442     }
443    
444     # the unique path, might be eq to save_path
445     sub uniq_path {
446     my ($self) = @_;
447    
448     $self->{user_rel} || $self->{random}
449     ? undef
450     : sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path
451     }
452    
453     # return random map parameters, or undef
454     sub random_map_params {
455     my ($self) = @_;
456    
457     $self->{random}
458     }
459    
460     # this is somewhat ugly, but style maps do need special treatment
461     sub is_style_map {
462     $_[0]{path} =~ m{^/styles/}
463     }
464    
465     package cf;
466    
467     #############################################################################
468    
469 root 1.93 =head2 ATTACHABLE OBJECTS
470    
471 root 1.94 Many objects in crossfire are so-called attachable objects. That means you can
472     attach callbacks/event handlers (a collection of which is called an "attachment")
473     to it. All such attachable objects support the following methods.
474    
475     In the following description, CLASS can be any of C<global>, C<object>
476     C<player>, C<client> or C<map> (i.e. the attachable objects in
477     crossfire+).
478 root 1.55
479     =over 4
480    
481 root 1.94 =item $attachable->attach ($attachment, key => $value...)
482    
483     =item $attachable->detach ($attachment)
484    
485     Attach/detach a pre-registered attachment to a specific object and give it
486     the specified key/value pairs as arguments.
487    
488     Example, attach a minesweeper attachment to the given object, making it a
489     10x10 minesweeper game:
490 root 1.46
491 root 1.94 $obj->attach (minesweeper => width => 10, height => 10);
492 root 1.53
493 root 1.93 =item $bool = $attachable->attached ($name)
494 root 1.46
495 root 1.93 Checks wether the named attachment is currently attached to the object.
496 root 1.46
497 root 1.94 =item cf::CLASS->attach ...
498 root 1.46
499 root 1.94 =item cf::CLASS->detach ...
500 root 1.92
501 root 1.94 Define an anonymous attachment and attach it to all objects of the given
502     CLASS. See the next function for an explanation of its arguments.
503 root 1.92
504 root 1.93 You can attach to global events by using the C<cf::global> class.
505 root 1.92
506 root 1.94 Example, log all player logins:
507    
508     cf::player->attach (
509     on_login => sub {
510     my ($pl) = @_;
511     ...
512     },
513     );
514    
515     Example, attach to the jeweler skill:
516    
517     cf::object->attach (
518     type => cf::SKILL,
519     subtype => cf::SK_JEWELER,
520     on_use_skill => sub {
521     my ($sk, $ob, $part, $dir, $msg) = @_;
522     ...
523     },
524     );
525    
526     =item cf::CLASS::attachment $name, ...
527    
528     Register an attachment by C<$name> through which attachable objects of the
529     given CLASS can refer to this attachment.
530    
531     Some classes such as crossfire maps and objects can specify attachments
532     that are attached at load/instantiate time, thus the need for a name.
533    
534     These calls expect any number of the following handler/hook descriptions:
535 root 1.46
536     =over 4
537    
538     =item prio => $number
539    
540     Set the priority for all following handlers/hooks (unless overwritten
541     by another C<prio> setting). Lower priority handlers get executed
542     earlier. The default priority is C<0>, and many built-in handlers are
543     registered at priority C<-1000>, so lower priorities should not be used
544     unless you know what you are doing.
545    
546 root 1.93 =item type => $type
547    
548     (Only for C<< cf::object->attach >> calls), limits the attachment to the
549     given type of objects only (the additional parameter C<subtype> can be
550     used to further limit to the given subtype).
551    
552 root 1.46 =item on_I<event> => \&cb
553    
554     Call the given code reference whenever the named event happens (event is
555     something like C<instantiate>, C<apply>, C<use_skill> and so on, and which
556     handlers are recognised generally depends on the type of object these
557     handlers attach to).
558    
559     See F<include/eventinc.h> for the full list of events supported, and their
560     class.
561    
562     =item package => package::
563    
564     Look for sub functions of the name C<< on_I<event> >> in the given
565     package and register them. Only handlers for eevents supported by the
566     object/class are recognised.
567    
568     =back
569    
570 root 1.94 Example, define an attachment called "sockpuppet" that calls the given
571     event handler when a monster attacks:
572    
573     cf::object::attachment sockpuppet =>
574     on_skill_attack => sub {
575     my ($self, $victim) = @_;
576     ...
577     }
578     }
579    
580 root 1.96 =item $attachable->valid
581    
582     Just because you have a perl object does not mean that the corresponding
583     C-level object still exists. If you try to access an object that has no
584     valid C counterpart anymore you get an exception at runtime. This method
585     can be used to test for existence of the C object part without causing an
586     exception.
587    
588 root 1.39 =cut
589    
590 root 1.40 # the following variables are defined in .xs and must not be re-created
591 root 1.100 our @CB_GLOBAL = (); # registry for all global events
592     our @CB_ATTACHABLE = (); # registry for all attachables
593     our @CB_OBJECT = (); # all objects (should not be used except in emergency)
594     our @CB_PLAYER = ();
595     our @CB_CLIENT = ();
596     our @CB_TYPE = (); # registry for type (cf-object class) based events
597     our @CB_MAP = ();
598 root 1.39
599 root 1.45 my %attachment;
600    
601 root 1.93 sub _attach_cb($$$$) {
602     my ($registry, $event, $prio, $cb) = @_;
603 root 1.39
604     use sort 'stable';
605    
606     $cb = [$prio, $cb];
607    
608     @{$registry->[$event]} = sort
609     { $a->[0] cmp $b->[0] }
610     @{$registry->[$event] || []}, $cb;
611     }
612    
613 root 1.100 # hack
614     my %attachable_klass = map +($_ => 1), KLASS_OBJECT, KLASS_CLIENT, KLASS_PLAYER, KLASS_MAP;
615    
616 root 1.39 # attach handles attaching event callbacks
617     # the only thing the caller has to do is pass the correct
618     # registry (== where the callback attaches to).
619 root 1.93 sub _attach {
620 root 1.45 my ($registry, $klass, @arg) = @_;
621 root 1.39
622 root 1.93 my $object_type;
623 root 1.39 my $prio = 0;
624     my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;
625    
626 root 1.100 #TODO: get rid of this hack
627     if ($attachable_klass{$klass}) {
628     %cb_id = (%cb_id, map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == KLASS_ATTACHABLE, 0 .. $#EVENT);
629     }
630    
631 root 1.45 while (@arg) {
632     my $type = shift @arg;
633 root 1.39
634     if ($type eq "prio") {
635 root 1.45 $prio = shift @arg;
636 root 1.39
637 root 1.93 } elsif ($type eq "type") {
638     $object_type = shift @arg;
639     $registry = $CB_TYPE[$object_type] ||= [];
640    
641     } elsif ($type eq "subtype") {
642     defined $object_type or Carp::croak "subtype specified without type";
643     my $object_subtype = shift @arg;
644     $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= [];
645    
646 root 1.39 } elsif ($type eq "package") {
647 root 1.45 my $pkg = shift @arg;
648 root 1.39
649     while (my ($name, $id) = each %cb_id) {
650     if (my $cb = $pkg->can ($name)) {
651 root 1.93 _attach_cb $registry, $id, $prio, $cb;
652 root 1.39 }
653     }
654    
655     } elsif (exists $cb_id{$type}) {
656 root 1.93 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
657 root 1.39
658     } elsif (ref $type) {
659     warn "attaching objects not supported, ignoring.\n";
660    
661     } else {
662 root 1.45 shift @arg;
663 root 1.39 warn "attach argument '$type' not supported, ignoring.\n";
664     }
665     }
666     }
667    
668 root 1.93 sub _object_attach {
669 root 1.48 my ($obj, $name, %arg) = @_;
670 root 1.46
671 root 1.55 return if exists $obj->{_attachment}{$name};
672    
673 root 1.46 if (my $attach = $attachment{$name}) {
674     my $registry = $obj->registry;
675    
676 root 1.47 for (@$attach) {
677     my ($klass, @attach) = @$_;
678 root 1.93 _attach $registry, $klass, @attach;
679 root 1.47 }
680 root 1.46
681 root 1.48 $obj->{$name} = \%arg;
682 root 1.46 } else {
683     warn "object uses attachment '$name' that is not available, postponing.\n";
684     }
685    
686 root 1.50 $obj->{_attachment}{$name} = undef;
687 root 1.46 }
688    
689 root 1.93 sub cf::attachable::attach {
690     if (ref $_[0]) {
691     _object_attach @_;
692     } else {
693     _attach shift->_attach_registry, @_;
694     }
695 root 1.55 };
696 root 1.46
697 root 1.54 # all those should be optimised
698 root 1.93 sub cf::attachable::detach {
699 root 1.54 my ($obj, $name) = @_;
700 root 1.46
701 root 1.93 if (ref $obj) {
702     delete $obj->{_attachment}{$name};
703     reattach ($obj);
704     } else {
705     Carp::croak "cannot, currently, detach class attachments";
706     }
707 root 1.55 };
708    
709 root 1.93 sub cf::attachable::attached {
710 root 1.55 my ($obj, $name) = @_;
711    
712     exists $obj->{_attachment}{$name}
713 root 1.39 }
714    
715 root 1.100 for my $klass (qw(ATTACHABLE GLOBAL OBJECT PLAYER CLIENT MAP)) {
716 root 1.93 eval "#line " . __LINE__ . " 'cf.pm'
717     sub cf::\L$klass\E::_attach_registry {
718     (\\\@CB_$klass, KLASS_$klass)
719     }
720 root 1.45
721 root 1.93 sub cf::\L$klass\E::attachment {
722     my \$name = shift;
723 root 1.39
724 root 1.93 \$attachment{\$name} = [[KLASS_$klass, \@_]];
725     }
726     ";
727     die if $@;
728 root 1.52 }
729    
730 root 1.39 our $override;
731 root 1.45 our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
732 root 1.39
733 root 1.45 sub override {
734     $override = 1;
735     @invoke_results = ();
736 root 1.39 }
737    
738 root 1.45 sub do_invoke {
739 root 1.39 my $event = shift;
740 root 1.40 my $callbacks = shift;
741 root 1.39
742 root 1.45 @invoke_results = ();
743    
744 root 1.39 local $override;
745    
746 root 1.40 for (@$callbacks) {
747 root 1.39 eval { &{$_->[1]} };
748    
749     if ($@) {
750     warn "$@";
751 root 1.64 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
752 root 1.39 override;
753     }
754    
755     return 1 if $override;
756     }
757    
758     0
759     }
760    
761 root 1.96 =item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...)
762 root 1.55
763 root 1.96 =item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
764 root 1.55
765 root 1.96 Generate an object-specific event with the given arguments.
766 root 1.55
767 root 1.96 This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
768 root 1.55 removed in future versions), and there is no public API to access override
769     results (if you must, access C<@cf::invoke_results> directly).
770    
771     =back
772    
773 root 1.71 =cut
774    
775 root 1.70 #############################################################################
776 root 1.45 # object support
777    
778 root 1.102 sub reattach {
779     # basically do the same as instantiate, without calling instantiate
780     my ($obj) = @_;
781    
782     my $registry = $obj->registry;
783    
784     @$registry = ();
785    
786     delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
787    
788     for my $name (keys %{ $obj->{_attachment} || {} }) {
789     if (my $attach = $attachment{$name}) {
790     for (@$attach) {
791     my ($klass, @attach) = @$_;
792     _attach $registry, $klass, @attach;
793     }
794     } else {
795     warn "object uses attachment '$name' that is not available, postponing.\n";
796     }
797     }
798     }
799    
800 root 1.100 cf::attachable->attach (
801     prio => -1000000,
802     on_instantiate => sub {
803     my ($obj, $data) = @_;
804 root 1.45
805 root 1.100 $data = from_json $data;
806 root 1.45
807 root 1.100 for (@$data) {
808     my ($name, $args) = @$_;
809 root 1.49
810 root 1.100 $obj->attach ($name, %{$args || {} });
811     }
812     },
813 root 1.102 on_reattach => \&reattach,
814 root 1.100 on_clone => sub {
815     my ($src, $dst) = @_;
816    
817     @{$dst->registry} = @{$src->registry};
818    
819     %$dst = %$src;
820    
821     %{$dst->{_attachment}} = %{$src->{_attachment}}
822     if exists $src->{_attachment};
823     },
824     );
825 root 1.45
826 root 1.46 sub object_freezer_save {
827 root 1.59 my ($filename, $rdata, $objs) = @_;
828 root 1.46
829 root 1.105 sync_job {
830     if (length $$rdata) {
831     warn sprintf "saving %s (%d,%d)\n",
832     $filename, length $$rdata, scalar @$objs;
833 root 1.60
834 root 1.105 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
835 root 1.60 chmod SAVE_MODE, $fh;
836 root 1.105 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
837     aio_fsync $fh;
838 root 1.60 close $fh;
839 root 1.105
840     if (@$objs) {
841     if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
842     chmod SAVE_MODE, $fh;
843     my $data = Storable::nfreeze { version => 1, objs => $objs };
844     aio_write $fh, 0, (length $data), $data, 0;
845     aio_fsync $fh;
846     close $fh;
847     aio_rename "$filename.pst~", "$filename.pst";
848     }
849     } else {
850     aio_unlink "$filename.pst";
851     }
852    
853     aio_rename "$filename~", $filename;
854 root 1.60 } else {
855 root 1.105 warn "FATAL: $filename~: $!\n";
856 root 1.60 }
857 root 1.59 } else {
858 root 1.105 aio_unlink $filename;
859     aio_unlink "$filename.pst";
860 root 1.59 }
861 root 1.45 }
862     }
863    
864 root 1.80 sub object_freezer_as_string {
865     my ($rdata, $objs) = @_;
866    
867     use Data::Dumper;
868    
869 root 1.81 $$rdata . Dumper $objs
870 root 1.80 }
871    
872 root 1.46 sub object_thawer_load {
873     my ($filename) = @_;
874    
875 root 1.105 my ($data, $av);
876 root 1.61
877 root 1.105 (aio_load $filename, $data) >= 0
878     or return;
879 root 1.61
880 root 1.105 unless (aio_stat "$filename.pst") {
881     (aio_load "$filename.pst", $av) >= 0
882     or return;
883 root 1.113 $av = eval { (Storable::thaw $av)->{objs} };
884 root 1.61 }
885 root 1.45
886 root 1.118 warn sprintf "loading %s (%d)\n",
887     $filename, length $data, scalar @{$av || []};#d#
888 root 1.105 return ($data, $av);
889 root 1.45 }
890    
891     #############################################################################
892 root 1.85 # command handling &c
893 root 1.39
894 root 1.85 =item cf::register_command $name => \&callback($ob,$args);
895 root 1.1
896 root 1.85 Register a callback for execution when the client sends the user command
897     $name.
898 root 1.5
899 root 1.85 =cut
900 root 1.5
901 root 1.85 sub register_command {
902     my ($name, $cb) = @_;
903 root 1.5
904 root 1.85 my $caller = caller;
905     #warn "registering command '$name/$time' to '$caller'";
906 root 1.1
907 root 1.85 push @{ $COMMAND{$name} }, [$caller, $cb];
908 root 1.1 }
909    
910 root 1.85 =item cf::register_extcmd $name => \&callback($pl,$packet);
911 root 1.1
912 root 1.85 Register a callbackf ro execution when the client sends an extcmd packet.
913 root 1.1
914 root 1.85 If the callback returns something, it is sent back as if reply was being
915     called.
916 root 1.1
917 root 1.85 =cut
918 root 1.1
919 root 1.16 sub register_extcmd {
920     my ($name, $cb) = @_;
921    
922     my $caller = caller;
923     #warn "registering extcmd '$name' to '$caller'";
924    
925 root 1.85 $EXTCMD{$name} = [$cb, $caller];
926 root 1.16 }
927    
928 root 1.93 cf::player->attach (
929 root 1.85 on_command => sub {
930     my ($pl, $name, $params) = @_;
931    
932     my $cb = $COMMAND{$name}
933     or return;
934    
935     for my $cmd (@$cb) {
936     $cmd->[1]->($pl->ob, $params);
937     }
938    
939     cf::override;
940     },
941     on_extcmd => sub {
942     my ($pl, $buf) = @_;
943    
944     my $msg = eval { from_json $buf };
945    
946     if (ref $msg) {
947     if (my $cb = $EXTCMD{$msg->{msgtype}}) {
948     if (my %reply = $cb->[0]->($pl, $msg)) {
949     $pl->ext_reply ($msg->{msgid}, %reply);
950     }
951     }
952     } else {
953     warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
954     }
955    
956     cf::override;
957     },
958 root 1.93 );
959 root 1.85
960 root 1.6 sub register {
961     my ($base, $pkg) = @_;
962    
963 root 1.45 #TODO
964 root 1.6 }
965    
966 root 1.1 sub load_extension {
967     my ($path) = @_;
968    
969     $path =~ /([^\/\\]+)\.ext$/ or die "$path";
970 root 1.5 my $base = $1;
971 root 1.1 my $pkg = $1;
972     $pkg =~ s/[^[:word:]]/_/g;
973 root 1.41 $pkg = "ext::$pkg";
974 root 1.1
975     warn "loading '$path' into '$pkg'\n";
976    
977     open my $fh, "<:utf8", $path
978     or die "$path: $!";
979    
980     my $source =
981     "package $pkg; use strict; use utf8;\n"
982     . "#line 1 \"$path\"\n{\n"
983     . (do { local $/; <$fh> })
984     . "\n};\n1";
985    
986     eval $source
987 root 1.82 or die $@ ? "$path: $@\n"
988     : "extension disabled.\n";
989 root 1.1
990     push @exts, $pkg;
991 root 1.5 $ext_pkg{$base} = $pkg;
992 root 1.1
993 root 1.6 # no strict 'refs';
994 root 1.23 # @{"$pkg\::ISA"} = ext::;
995 root 1.1
996 root 1.6 register $base, $pkg;
997 root 1.1 }
998    
999     sub unload_extension {
1000     my ($pkg) = @_;
1001    
1002     warn "removing extension $pkg\n";
1003    
1004     # remove hooks
1005 root 1.45 #TODO
1006     # for my $idx (0 .. $#PLUGIN_EVENT) {
1007     # delete $hook[$idx]{$pkg};
1008     # }
1009 root 1.1
1010     # remove commands
1011 root 1.85 for my $name (keys %COMMAND) {
1012     my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
1013 root 1.1
1014     if (@cb) {
1015 root 1.85 $COMMAND{$name} = \@cb;
1016 root 1.1 } else {
1017 root 1.85 delete $COMMAND{$name};
1018 root 1.1 }
1019     }
1020    
1021 root 1.15 # remove extcmds
1022 root 1.85 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
1023     delete $EXTCMD{$name};
1024 root 1.15 }
1025    
1026 root 1.43 if (my $cb = $pkg->can ("unload")) {
1027 elmex 1.31 eval {
1028     $cb->($pkg);
1029     1
1030     } or warn "$pkg unloaded, but with errors: $@";
1031     }
1032    
1033 root 1.1 Symbol::delete_package $pkg;
1034     }
1035    
1036     sub load_extensions {
1037     for my $ext (<$LIBDIR/*.ext>) {
1038 root 1.3 next unless -r $ext;
1039 root 1.2 eval {
1040     load_extension $ext;
1041     1
1042     } or warn "$ext not loaded: $@";
1043 root 1.1 }
1044     }
1045    
1046 root 1.8 #############################################################################
1047     # load/save/clean perl data associated with a map
1048    
1049 root 1.39 *cf::mapsupport::on_clean = sub {
1050 root 1.13 my ($map) = @_;
1051 root 1.7
1052     my $path = $map->tmpname;
1053     defined $path or return;
1054    
1055 root 1.46 unlink "$path.pst";
1056 root 1.7 };
1057    
1058 root 1.93 cf::map->attach (prio => -10000, package => cf::mapsupport::);
1059 root 1.39
1060 root 1.8 #############################################################################
1061     # load/save perl data associated with player->ob objects
1062    
1063 root 1.33 sub all_objects(@) {
1064     @_, map all_objects ($_->inv), @_
1065     }
1066    
1067 root 1.60 # TODO: compatibility cruft, remove when no longer needed
1068 root 1.93 cf::player->attach (
1069 root 1.39 on_load => sub {
1070     my ($pl, $path) = @_;
1071    
1072     for my $o (all_objects $pl->ob) {
1073     if (my $value = $o->get_ob_key_value ("_perl_data")) {
1074     $o->set_ob_key_value ("_perl_data");
1075 root 1.8
1076 root 1.39 %$o = %{ Storable::thaw pack "H*", $value };
1077     }
1078 root 1.11 }
1079 root 1.39 },
1080 root 1.93 );
1081 root 1.6
1082 root 1.22 #############################################################################
1083 root 1.70
1084     =head2 CORE EXTENSIONS
1085    
1086     Functions and methods that extend core crossfire objects.
1087    
1088 root 1.95 =head3 cf::player
1089    
1090 root 1.70 =over 4
1091 root 1.22
1092 root 1.23 =item cf::player::exists $login
1093    
1094     Returns true when the given account exists.
1095    
1096     =cut
1097    
1098     sub cf::player::exists($) {
1099     cf::player::find $_[0]
1100     or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
1101     }
1102    
1103 root 1.95 =item $player->ext_reply ($msgid, $msgtype, %msg)
1104    
1105     Sends an ext reply to the player.
1106    
1107     =cut
1108    
1109     sub cf::player::ext_reply($$$%) {
1110     my ($self, $id, %msg) = @_;
1111    
1112     $msg{msgid} = $id;
1113    
1114     $self->send ("ext " . to_json \%msg);
1115     }
1116    
1117     =back
1118    
1119 root 1.110
1120     =head3 cf::map
1121    
1122     =over 4
1123    
1124     =cut
1125    
1126     package cf::map;
1127    
1128     use Fcntl;
1129     use Coro::AIO;
1130    
1131     our $MAX_RESET = 7200;
1132     our $DEFAULT_RESET = 3600;
1133    
1134     sub generate_random_map {
1135     my ($path, $rmp) = @_;
1136    
1137     # mit "rum" bekleckern, nicht
1138     cf::map::_create_random_map
1139     $path,
1140     $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1141     $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1142     $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1143     $rmp->{exit_on_final_map},
1144     $rmp->{xsize}, $rmp->{ysize},
1145     $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1146     $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1147     $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1148     $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1149     $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1150     (cf::region::find $rmp->{region})
1151     }
1152    
1153     # and all this just because we cannot iterate over
1154     # all maps in C++...
1155     sub change_all_map_light {
1156     my ($change) = @_;
1157    
1158 root 1.122 $_->change_map_light ($change)
1159     for grep $_->outdoor, values %cf::MAP;
1160 root 1.110 }
1161    
1162     sub try_load_header($) {
1163     my ($path) = @_;
1164    
1165     utf8::encode $path;
1166     aio_open $path, O_RDONLY, 0
1167     or return;
1168    
1169     my $map = cf::map::new
1170     or return;
1171    
1172     $map->load_header ($path)
1173     or return;
1174    
1175     $map->{load_path} = $path;
1176    
1177     $map
1178     }
1179    
1180     sub find_map {
1181     my ($path, $origin) = @_;
1182    
1183     #warn "find_map<$path,$origin>\n";#d#
1184    
1185 root 1.112 $path = new cf::path $path, $origin && $origin->path;
1186 root 1.110 my $key = $path->as_string;
1187    
1188 root 1.120 cf::lock_wait "map_find:$key";
1189    
1190 root 1.110 $cf::MAP{$key} || do {
1191 root 1.120 my $guard = cf::lock_acquire "map_find:$key";
1192    
1193 root 1.110 # do it the slow way
1194     my $map = try_load_header $path->save_path;
1195    
1196     if ($map) {
1197     # safety
1198     $map->{instantiate_time} = $cf::RUNTIME
1199     if $map->{instantiate_time} > $cf::RUNTIME;
1200     } else {
1201     if (my $rmp = $path->random_map_params) {
1202     $map = generate_random_map $key, $rmp;
1203     } else {
1204     $map = try_load_header $path->load_path;
1205     }
1206    
1207     $map or return;
1208    
1209 root 1.111 $map->{load_original} = 1;
1210 root 1.110 $map->{instantiate_time} = $cf::RUNTIME;
1211     $map->instantiate;
1212    
1213     # per-player maps become, after loading, normal maps
1214     $map->per_player (0) if $path->{user_rel};
1215     }
1216    
1217     $map->path ($key);
1218     $map->{path} = $path;
1219 root 1.116 $map->{last_save} = $cf::RUNTIME;
1220 root 1.110 $map->last_access ($cf::RUNTIME);
1221    
1222 root 1.112 if ($map->should_reset) {
1223     $map->reset;
1224 root 1.123 undef $guard;
1225 root 1.112 $map = find_map $path;
1226     }
1227 root 1.110
1228     $cf::MAP{$key} = $map
1229     }
1230     }
1231    
1232     sub load {
1233     my ($self) = @_;
1234    
1235 root 1.120 my $path = $self->{path};
1236     my $guard = cf::lock_acquire "map_load:" . $path->as_string;
1237    
1238 root 1.110 return if $self->in_memory != cf::MAP_SWAPPED;
1239    
1240     $self->in_memory (cf::MAP_LOADING);
1241    
1242     $self->alloc;
1243     $self->load_objects ($self->{load_path}, 1)
1244     or return;
1245    
1246 root 1.112 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1247     if delete $self->{load_original};
1248 root 1.111
1249 root 1.110 if (my $uniq = $path->uniq_path) {
1250     utf8::encode $uniq;
1251     if (aio_open $uniq, O_RDONLY, 0) {
1252     $self->clear_unique_items;
1253     $self->load_objects ($uniq, 0);
1254     }
1255     }
1256    
1257     # now do the right thing for maps
1258     $self->link_multipart_objects;
1259    
1260     if ($self->{path}->is_style_map) {
1261     $self->{deny_save} = 1;
1262     $self->{deny_reset} = 1;
1263     } else {
1264     $self->fix_auto_apply;
1265     $self->decay_objects;
1266     $self->update_buttons;
1267     $self->set_darkness_map;
1268     $self->difficulty ($self->estimate_difficulty)
1269     unless $self->difficulty;
1270     $self->activate;
1271     }
1272    
1273     $self->in_memory (cf::MAP_IN_MEMORY);
1274     }
1275    
1276     sub load_map_sync {
1277     my ($path, $origin) = @_;
1278    
1279     #warn "load_map_sync<$path, $origin>\n";#d#
1280    
1281     cf::sync_job {
1282     my $map = cf::map::find_map $path, $origin
1283     or return;
1284     $map->load;
1285     $map
1286     }
1287     }
1288    
1289     sub save {
1290     my ($self) = @_;
1291    
1292     $self->{last_save} = $cf::RUNTIME;
1293    
1294     return unless $self->dirty;
1295    
1296 root 1.117 my $save = $self->{path}->save_path; utf8::encode $save;
1297     my $uniq = $self->{path}->uniq_path; utf8::encode $uniq;
1298    
1299 root 1.110 $self->{load_path} = $save;
1300    
1301     return if $self->{deny_save};
1302    
1303     if ($uniq) {
1304     $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1305     $self->save_objects ($uniq, cf::IO_UNIQUES);
1306     } else {
1307     $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
1308     }
1309     }
1310    
1311     sub swap_out {
1312     my ($self) = @_;
1313    
1314     return if $self->players;
1315     return if $self->in_memory != cf::MAP_IN_MEMORY;
1316     return if $self->{deny_save};
1317    
1318     $self->save;
1319     $self->clear;
1320     $self->in_memory (cf::MAP_SWAPPED);
1321     }
1322    
1323 root 1.112 sub reset_at {
1324     my ($self) = @_;
1325 root 1.110
1326     # TODO: safety, remove and allow resettable per-player maps
1327 root 1.114 return 1e99 if $self->{path}{user_rel};
1328     return 1e99 if $self->{deny_reset};
1329 root 1.110
1330 root 1.112 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1331 root 1.114 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1332 root 1.110
1333 root 1.112 $time + $to
1334     }
1335    
1336     sub should_reset {
1337     my ($self) = @_;
1338    
1339     $self->reset_at <= $cf::RUNTIME
1340 root 1.111 }
1341    
1342     sub unlink_save {
1343     my ($self) = @_;
1344    
1345     utf8::encode (my $save = $self->{path}->save_path);
1346     aioreq_pri 3; IO::AIO::aio_unlink $save;
1347     aioreq_pri 3; IO::AIO::aio_unlink "$save.pst";
1348 root 1.110 }
1349    
1350 root 1.113 sub rename {
1351     my ($self, $new_path) = @_;
1352    
1353     $self->unlink_save;
1354    
1355     delete $cf::MAP{$self->path};
1356     $self->{path} = new cf::path $new_path;
1357 root 1.114 $self->path ($self->{path}->as_string);
1358 root 1.113 $cf::MAP{$self->path} = $self;
1359    
1360     $self->save;
1361     }
1362    
1363 root 1.110 sub reset {
1364     my ($self) = @_;
1365    
1366     return if $self->players;
1367     return if $self->{path}{user_rel};#d#
1368    
1369     warn "resetting map ", $self->path;#d#
1370    
1371 root 1.111 delete $cf::MAP{$self->path};
1372 root 1.110
1373     $_->clear_links_to ($self) for values %cf::MAP;
1374    
1375 root 1.111 $self->unlink_save;
1376     $self->destroy;
1377 root 1.110 }
1378    
1379 root 1.114 my $nuke_counter = "aaaa";
1380    
1381     sub nuke {
1382     my ($self) = @_;
1383    
1384     $self->{deny_save} = 1;
1385     $self->reset_timeout (1);
1386     $self->rename ("{nuke}/" . ($nuke_counter++));
1387     $self->reset; # polite request, might not happen
1388     }
1389    
1390 root 1.110 sub customise_for {
1391     my ($map, $ob) = @_;
1392    
1393     if ($map->per_player) {
1394     return cf::map::find_map "~" . $ob->name . "/" . $map->{path}{path};
1395     }
1396    
1397     $map
1398     }
1399    
1400     sub emergency_save {
1401     local $cf::FREEZE = 1;
1402    
1403     warn "enter emergency map save\n";
1404    
1405     cf::sync_job {
1406     warn "begin emergency map save\n";
1407     $_->save for values %cf::MAP;
1408     };
1409    
1410     warn "end emergency map save\n";
1411     }
1412    
1413     package cf;
1414    
1415     =back
1416    
1417    
1418 root 1.95 =head3 cf::object::player
1419    
1420     =over 4
1421    
1422 root 1.79 =item $player_object->reply ($npc, $msg[, $flags])
1423 root 1.28
1424     Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
1425     can be C<undef>. Does the right thing when the player is currently in a
1426     dialogue with the given NPC character.
1427    
1428     =cut
1429    
1430 root 1.22 # rough implementation of a future "reply" method that works
1431     # with dialog boxes.
1432 root 1.95 #TODO: the first argument must go, split into a $npc->reply_to ( method
1433 root 1.23 sub cf::object::player::reply($$$;$) {
1434     my ($self, $npc, $msg, $flags) = @_;
1435    
1436     $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1437 root 1.22
1438 root 1.24 if ($self->{record_replies}) {
1439     push @{ $self->{record_replies} }, [$npc, $msg, $flags];
1440     } else {
1441     $msg = $npc->name . " says: $msg" if $npc;
1442     $self->message ($msg, $flags);
1443     }
1444 root 1.22 }
1445    
1446 root 1.79 =item $player_object->may ("access")
1447    
1448     Returns wether the given player is authorized to access resource "access"
1449     (e.g. "command_wizcast").
1450    
1451     =cut
1452    
1453     sub cf::object::player::may {
1454     my ($self, $access) = @_;
1455    
1456     $self->flag (cf::FLAG_WIZ) ||
1457     (ref $cf::CFG{"may_$access"}
1458     ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
1459     : $cf::CFG{"may_$access"})
1460     }
1461 root 1.70
1462 root 1.115 =item $player_object->enter_link
1463    
1464     Freezes the player and moves him/her to a special map (C<{link}>).
1465    
1466     The player should be reaosnably safe there for short amounts of time. You
1467     I<MUST> call C<leave_link> as soon as possible, though.
1468    
1469     =item $player_object->leave_link ($map, $x, $y)
1470    
1471     Moves the player out of the specila link map onto the given map. If the
1472     map is not valid (or omitted), the player will be moved back to the
1473     location he/she was before the call to C<enter_link>, or, if that fails,
1474     to the emergency map position.
1475    
1476     Might block.
1477    
1478     =cut
1479    
1480 root 1.110 sub cf::object::player::enter_link {
1481     my ($self) = @_;
1482    
1483 root 1.120 $self->deactivate_recursive;
1484    
1485 root 1.110 return if $self->map == $LINK_MAP;
1486    
1487 root 1.120 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1488 root 1.110 if $self->map;
1489    
1490     $self->enter_map ($LINK_MAP, 20, 20);
1491     }
1492    
1493     sub cf::object::player::leave_link {
1494     my ($self, $map, $x, $y) = @_;
1495    
1496     my $link_pos = delete $self->{_link_pos};
1497    
1498     unless ($map) {
1499     # restore original map position
1500     ($map, $x, $y) = @{ $link_pos || [] };
1501     $map = cf::map::find_map $map;
1502    
1503     unless ($map) {
1504     ($map, $x, $y) = @$EMERGENCY_POSITION;
1505     $map = cf::map::find_map $map
1506     or die "FATAL: cannot load emergency map\n";
1507     }
1508     }
1509    
1510     ($x, $y) = (-1, -1)
1511     unless (defined $x) && (defined $y);
1512    
1513     # use -1 or undef as default coordinates, not 0, 0
1514     ($x, $y) = ($map->enter_x, $map->enter_y)
1515     if $x <=0 && $y <= 0;
1516    
1517     $map->load;
1518    
1519     $self->activate_recursive;
1520     $self->enter_map ($map, $x, $y);
1521     }
1522    
1523 root 1.120 cf::player->attach (
1524     on_logout => sub {
1525     my ($pl) = @_;
1526    
1527     # abort map switching before logout
1528     if ($pl->ob->{_link_pos}) {
1529     cf::sync_job {
1530     $pl->ob->leave_link
1531     };
1532     }
1533     },
1534     on_login => sub {
1535     my ($pl) = @_;
1536    
1537     # try to abort aborted map switching on player login :)
1538     # should happen only on crashes
1539     if ($pl->ob->{_link_pos}) {
1540     $pl->ob->enter_link;
1541     Coro::async {
1542     # we need this sleep as the login has a concurrent enter_exit running
1543     # and this sleep increases chances of the player not ending up in scorn
1544     Coro::Timer::sleep 1;
1545     $pl->ob->leave_link;
1546     };
1547     }
1548     },
1549     );
1550    
1551 root 1.118 =item $player_object->goto_map ($path, $x, $y)
1552 root 1.110
1553     =cut
1554    
1555     sub cf::object::player::goto_map {
1556     my ($self, $path, $x, $y) = @_;
1557    
1558     $self->enter_link;
1559    
1560     (Coro::async {
1561     $path = new cf::path $path;
1562    
1563     my $map = cf::map::find_map $path->as_string;
1564     $map = $map->customise_for ($self) if $map;
1565    
1566 root 1.119 # warn "entering ", $map->path, " at ($x, $y)\n"
1567     # if $map;
1568 root 1.110
1569 root 1.115 $map or $self->message ("The exit is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1570    
1571 root 1.110 $self->leave_link ($map, $x, $y);
1572     })->prio (1);
1573     }
1574    
1575     =item $player_object->enter_exit ($exit_object)
1576    
1577     =cut
1578    
1579     sub parse_random_map_params {
1580     my ($spec) = @_;
1581    
1582     my $rmp = { # defaults
1583     xsize => 10,
1584     ysize => 10,
1585     };
1586    
1587     for (split /\n/, $spec) {
1588     my ($k, $v) = split /\s+/, $_, 2;
1589    
1590     $rmp->{lc $k} = $v if (length $k) && (length $v);
1591     }
1592    
1593     $rmp
1594     }
1595    
1596     sub prepare_random_map {
1597     my ($exit) = @_;
1598    
1599     # all this does is basically replace the /! path by
1600     # a new random map path (?random/...) with a seed
1601     # that depends on the exit object
1602    
1603     my $rmp = parse_random_map_params $exit->msg;
1604    
1605     if ($exit->map) {
1606     $rmp->{region} = $exit->map->region_name;
1607     $rmp->{origin_map} = $exit->map->path;
1608     $rmp->{origin_x} = $exit->x;
1609     $rmp->{origin_y} = $exit->y;
1610     }
1611    
1612     $rmp->{random_seed} ||= $exit->random_seed;
1613    
1614     my $data = cf::to_json $rmp;
1615     my $md5 = Digest::MD5::md5_hex $data;
1616    
1617     if (my $fh = aio_open "$cf::RANDOM_MAPS/$md5.meta", O_WRONLY | O_CREAT, 0666) {
1618     aio_write $fh, 0, (length $data), $data, 0;
1619    
1620     $exit->slaying ("?random/$md5");
1621     $exit->msg (undef);
1622     }
1623     }
1624    
1625     sub cf::object::player::enter_exit {
1626     my ($self, $exit) = @_;
1627    
1628     return unless $self->type == cf::PLAYER;
1629    
1630     $self->enter_link;
1631    
1632     (Coro::async {
1633     unless (eval {
1634    
1635     prepare_random_map $exit
1636     if $exit->slaying eq "/!";
1637    
1638     my $path = new cf::path $exit->slaying, $exit->map && $exit->map->path;
1639     $self->goto_map ($path, $exit->stats->hp, $exit->stats->sp);
1640    
1641     1;
1642     }) {
1643     $self->message ("Something went wrong deep within the crossfire server. "
1644     . "I'll try to bring you back to the map you were before. "
1645     . "Please report this to the dungeon master",
1646     cf::NDI_UNIQUE | cf::NDI_RED);
1647    
1648     warn "ERROR in enter_exit: $@";
1649     $self->leave_link;
1650     }
1651     })->prio (1);
1652     }
1653    
1654 root 1.95 =head3 cf::client
1655    
1656     =over 4
1657    
1658     =item $client->send_drawinfo ($text, $flags)
1659    
1660     Sends a drawinfo packet to the client. Circumvents output buffering so
1661     should not be used under normal circumstances.
1662    
1663 root 1.70 =cut
1664    
1665 root 1.95 sub cf::client::send_drawinfo {
1666     my ($self, $text, $flags) = @_;
1667    
1668     utf8::encode $text;
1669     $self->send_packet (sprintf "drawinfo %d %s", $flags, $text);
1670     }
1671    
1672    
1673     =item $success = $client->query ($flags, "text", \&cb)
1674    
1675     Queues a query to the client, calling the given callback with
1676     the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
1677     C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
1678    
1679     Queries can fail, so check the return code. Or don't, as queries will become
1680     reliable at some point in the future.
1681    
1682     =cut
1683    
1684     sub cf::client::query {
1685     my ($self, $flags, $text, $cb) = @_;
1686    
1687     return unless $self->state == ST_PLAYING
1688     || $self->state == ST_SETUP
1689     || $self->state == ST_CUSTOM;
1690    
1691     $self->state (ST_CUSTOM);
1692    
1693     utf8::encode $text;
1694     push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
1695    
1696     $self->send_packet ($self->{query_queue}[0][0])
1697     if @{ $self->{query_queue} } == 1;
1698     }
1699    
1700     cf::client->attach (
1701     on_reply => sub {
1702     my ($ns, $msg) = @_;
1703    
1704     # this weird shuffling is so that direct followup queries
1705     # get handled first
1706     my $queue = delete $ns->{query_queue};
1707    
1708     (shift @$queue)->[1]->($msg);
1709    
1710     push @{ $ns->{query_queue} }, @$queue;
1711    
1712     if (@{ $ns->{query_queue} } == @$queue) {
1713     if (@$queue) {
1714     $ns->send_packet ($ns->{query_queue}[0][0]);
1715     } else {
1716 root 1.98 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
1717 root 1.95 }
1718     }
1719     },
1720     );
1721    
1722 root 1.96 =item $client->coro (\&cb)
1723    
1724     Create a new coroutine, running the specified callback. The coroutine will
1725     be automatically cancelled when the client gets destroyed (e.g. on logout,
1726     or loss of connection).
1727    
1728     =cut
1729    
1730     sub cf::client::coro {
1731     my ($self, $cb) = @_;
1732    
1733     my $coro; $coro = async {
1734     eval {
1735     $cb->();
1736     };
1737     warn $@ if $@;
1738 root 1.103 };
1739    
1740     $coro->on_destroy (sub {
1741 root 1.96 delete $self->{_coro}{$coro+0};
1742 root 1.103 });
1743 root 1.96
1744     $self->{_coro}{$coro+0} = $coro;
1745 root 1.103
1746     $coro
1747 root 1.96 }
1748    
1749     cf::client->attach (
1750     on_destroy => sub {
1751     my ($ns) = @_;
1752    
1753 root 1.97 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
1754 root 1.96 },
1755     );
1756    
1757 root 1.95 =back
1758    
1759 root 1.70
1760     =head2 SAFE SCRIPTING
1761    
1762     Functions that provide a safe environment to compile and execute
1763     snippets of perl code without them endangering the safety of the server
1764     itself. Looping constructs, I/O operators and other built-in functionality
1765     is not available in the safe scripting environment, and the number of
1766 root 1.79 functions and methods that can be called is greatly reduced.
1767 root 1.70
1768     =cut
1769 root 1.23
1770 root 1.42 our $safe = new Safe "safe";
1771 root 1.23 our $safe_hole = new Safe::Hole;
1772    
1773     $SIG{FPE} = 'IGNORE';
1774    
1775     $safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));
1776    
1777 root 1.25 # here we export the classes and methods available to script code
1778    
1779 root 1.70 =pod
1780    
1781     The following fucntions and emthods are available within a safe environment:
1782    
1783 elmex 1.91 cf::object contr pay_amount pay_player map
1784 root 1.70 cf::object::player player
1785     cf::player peaceful
1786 elmex 1.91 cf::map trigger
1787 root 1.70
1788     =cut
1789    
1790 root 1.25 for (
1791 elmex 1.91 ["cf::object" => qw(contr pay_amount pay_player map)],
1792 root 1.25 ["cf::object::player" => qw(player)],
1793     ["cf::player" => qw(peaceful)],
1794 elmex 1.91 ["cf::map" => qw(trigger)],
1795 root 1.25 ) {
1796     no strict 'refs';
1797     my ($pkg, @funs) = @$_;
1798 root 1.41 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
1799 root 1.25 for @funs;
1800     }
1801 root 1.23
1802 root 1.70 =over 4
1803    
1804     =item @retval = safe_eval $code, [var => value, ...]
1805    
1806     Compiled and executes the given perl code snippet. additional var/value
1807     pairs result in temporary local (my) scalar variables of the given name
1808     that are available in the code snippet. Example:
1809    
1810     my $five = safe_eval '$first + $second', first => 1, second => 4;
1811    
1812     =cut
1813    
1814 root 1.23 sub safe_eval($;@) {
1815     my ($code, %vars) = @_;
1816    
1817     my $qcode = $code;
1818     $qcode =~ s/"/‟/g; # not allowed in #line filenames
1819     $qcode =~ s/\n/\\n/g;
1820    
1821     local $_;
1822 root 1.41 local @safe::cf::_safe_eval_args = values %vars;
1823 root 1.23
1824 root 1.42 my $eval =
1825 root 1.23 "do {\n"
1826     . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
1827     . "#line 0 \"{$qcode}\"\n"
1828     . $code
1829     . "\n}"
1830 root 1.25 ;
1831    
1832     sub_generation_inc;
1833 root 1.42 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
1834 root 1.25 sub_generation_inc;
1835    
1836 root 1.42 if ($@) {
1837     warn "$@";
1838     warn "while executing safe code '$code'\n";
1839     warn "with arguments " . (join " ", %vars) . "\n";
1840     }
1841    
1842 root 1.25 wantarray ? @res : $res[0]
1843 root 1.23 }
1844    
1845 root 1.69 =item cf::register_script_function $function => $cb
1846    
1847     Register a function that can be called from within map/npc scripts. The
1848     function should be reasonably secure and should be put into a package name
1849     like the extension.
1850    
1851     Example: register a function that gets called whenever a map script calls
1852     C<rent::overview>, as used by the C<rent> extension.
1853    
1854     cf::register_script_function "rent::overview" => sub {
1855     ...
1856     };
1857    
1858     =cut
1859    
1860 root 1.23 sub register_script_function {
1861     my ($fun, $cb) = @_;
1862    
1863     no strict 'refs';
1864 root 1.41 *{"safe::$fun"} = $safe_hole->wrap ($cb);
1865 root 1.23 }
1866    
1867 root 1.70 =back
1868    
1869 root 1.71 =cut
1870    
1871 root 1.23 #############################################################################
1872 root 1.65
1873     =head2 EXTENSION DATABASE SUPPORT
1874    
1875     Crossfire maintains a very simple database for extension use. It can
1876     currently store anything that can be serialised using Storable, which
1877     excludes objects.
1878    
1879     The parameter C<$family> should best start with the name of the extension
1880     using it, it should be unique.
1881    
1882     =over 4
1883    
1884     =item $hashref = cf::db_get $family
1885    
1886     Return a hashref for use by the extension C<$family>, which can be
1887     modified. After modifications, you have to call C<cf::db_dirty> or
1888     C<cf::db_sync>.
1889    
1890     =item $value = cf::db_get $family => $key
1891    
1892     Returns a single value from the database
1893    
1894     =item cf::db_put $family => $hashref
1895    
1896     Stores the given family hashref into the database. Updates are delayed, if
1897     you want the data to be synced to disk immediately, use C<cf::db_sync>.
1898    
1899     =item cf::db_put $family => $key => $value
1900    
1901     Stores the given C<$value> in the family hash. Updates are delayed, if you
1902     want the data to be synced to disk immediately, use C<cf::db_sync>.
1903    
1904     =item cf::db_dirty
1905    
1906     Marks the database as dirty, to be updated at a later time.
1907    
1908     =item cf::db_sync
1909    
1910     Immediately write the database to disk I<if it is dirty>.
1911    
1912     =cut
1913    
1914 root 1.78 our $DB;
1915    
1916 root 1.65 {
1917 root 1.66 my $path = cf::localdir . "/database.pst";
1918 root 1.65
1919     sub db_load() {
1920 root 1.78 $DB = stat $path ? Storable::retrieve $path : { };
1921 root 1.65 }
1922    
1923     my $pid;
1924    
1925     sub db_save() {
1926     waitpid $pid, 0 if $pid;
1927 root 1.67 if (0 == ($pid = fork)) {
1928 root 1.78 $DB->{_meta}{version} = 1;
1929     Storable::nstore $DB, "$path~";
1930 root 1.65 rename "$path~", $path;
1931     cf::_exit 0 if defined $pid;
1932     }
1933     }
1934    
1935     my $dirty;
1936    
1937     sub db_sync() {
1938     db_save if $dirty;
1939     undef $dirty;
1940     }
1941    
1942 root 1.87 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
1943 root 1.65 db_sync;
1944     });
1945    
1946     sub db_dirty() {
1947     $dirty = 1;
1948     $idle->start;
1949     }
1950    
1951     sub db_get($;$) {
1952     @_ >= 2
1953 root 1.78 ? $DB->{$_[0]}{$_[1]}
1954     : ($DB->{$_[0]} ||= { })
1955 root 1.65 }
1956    
1957     sub db_put($$;$) {
1958     if (@_ >= 3) {
1959 root 1.78 $DB->{$_[0]}{$_[1]} = $_[2];
1960 root 1.65 } else {
1961 root 1.78 $DB->{$_[0]} = $_[1];
1962 root 1.65 }
1963     db_dirty;
1964     }
1965 root 1.67
1966 root 1.93 cf::global->attach (
1967     prio => 10000,
1968 root 1.67 on_cleanup => sub {
1969     db_sync;
1970     },
1971 root 1.93 );
1972 root 1.65 }
1973    
1974     #############################################################################
1975 root 1.34 # the server's main()
1976    
1977 root 1.73 sub cfg_load {
1978 root 1.72 open my $fh, "<:utf8", cf::confdir . "/config"
1979     or return;
1980    
1981     local $/;
1982     *CFG = YAML::Syck::Load <$fh>;
1983     }
1984    
1985 root 1.39 sub main {
1986 root 1.108 # we must not ever block the main coroutine
1987     local $Coro::idle = sub {
1988 root 1.115 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
1989 root 1.108 (Coro::unblock_sub {
1990     Event::one_event;
1991     })->();
1992     };
1993    
1994 root 1.73 cfg_load;
1995 root 1.65 db_load;
1996 root 1.61 load_extensions;
1997 root 1.34 Event::loop;
1998     }
1999    
2000     #############################################################################
2001 root 1.22 # initialisation
2002    
2003 root 1.111 sub reload() {
2004 root 1.106 # can/must only be called in main
2005     if ($Coro::current != $Coro::main) {
2006     warn "can only reload from main coroutine\n";
2007     return;
2008     }
2009    
2010 root 1.103 warn "reloading...";
2011    
2012 root 1.106 local $FREEZE = 1;
2013     cf::emergency_save;
2014    
2015 root 1.103 eval {
2016 root 1.106 # if anything goes wrong in here, we should simply crash as we already saved
2017 root 1.65
2018     # cancel all watchers
2019 root 1.87 for (Event::all_watchers) {
2020     $_->cancel if $_->data & WF_AUTOCANCEL;
2021     }
2022 root 1.65
2023 root 1.103 # cancel all extension coros
2024     $_->cancel for values %EXT_CORO;
2025     %EXT_CORO = ();
2026    
2027 root 1.65 # unload all extensions
2028     for (@exts) {
2029 root 1.103 warn "unloading <$_>";
2030 root 1.65 unload_extension $_;
2031     }
2032    
2033     # unload all modules loaded from $LIBDIR
2034     while (my ($k, $v) = each %INC) {
2035     next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2036    
2037 root 1.103 warn "removing <$k>";
2038 root 1.65 delete $INC{$k};
2039    
2040     $k =~ s/\.pm$//;
2041     $k =~ s/\//::/g;
2042    
2043     if (my $cb = $k->can ("unload_module")) {
2044     $cb->();
2045     }
2046    
2047     Symbol::delete_package $k;
2048     }
2049    
2050     # sync database to disk
2051     cf::db_sync;
2052 root 1.103 IO::AIO::flush;
2053 root 1.65
2054     # get rid of safe::, as good as possible
2055     Symbol::delete_package "safe::$_"
2056 root 1.103 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2057 root 1.65
2058     # remove register_script_function callbacks
2059     # TODO
2060    
2061     # unload cf.pm "a bit"
2062     delete $INC{"cf.pm"};
2063    
2064     # don't, removes xs symbols, too,
2065     # and global variables created in xs
2066     #Symbol::delete_package __PACKAGE__;
2067    
2068     # reload cf.pm
2069 root 1.103 warn "reloading cf.pm";
2070 root 1.65 require cf;
2071 root 1.100 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2072    
2073 root 1.73 # load config and database again
2074     cf::cfg_load;
2075 root 1.65 cf::db_load;
2076    
2077     # load extensions
2078 root 1.103 warn "load extensions";
2079 root 1.65 cf::load_extensions;
2080    
2081     # reattach attachments to objects
2082 root 1.103 warn "reattach";
2083 root 1.65 _global_reattach;
2084     };
2085    
2086 root 1.106 if ($@) {
2087     warn $@;
2088     warn "error while reloading, exiting.";
2089     exit 1;
2090     }
2091    
2092     warn "reloaded successfully";
2093 root 1.65 };
2094    
2095 root 1.108 #############################################################################
2096    
2097     unless ($LINK_MAP) {
2098     $LINK_MAP = cf::map::new;
2099    
2100     $LINK_MAP->width (41);
2101     $LINK_MAP->height (41);
2102     $LINK_MAP->alloc;
2103     $LINK_MAP->path ("{link}");
2104     $LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";
2105     $LINK_MAP->in_memory (MAP_IN_MEMORY);
2106 root 1.110
2107     # dirty hack because... archetypes are not yet loaded
2108     Event->timer (
2109     after => 2,
2110     cb => sub {
2111     $_[0]->w->cancel;
2112    
2113     # provide some exits "home"
2114     my $exit = cf::object::new "exit";
2115    
2116     $exit->slaying ($EMERGENCY_POSITION->[0]);
2117     $exit->stats->hp ($EMERGENCY_POSITION->[1]);
2118     $exit->stats->sp ($EMERGENCY_POSITION->[2]);
2119    
2120     $LINK_MAP->insert ($exit->clone, 19, 19);
2121     $LINK_MAP->insert ($exit->clone, 19, 20);
2122     $LINK_MAP->insert ($exit->clone, 19, 21);
2123     $LINK_MAP->insert ($exit->clone, 20, 19);
2124     $LINK_MAP->insert ($exit->clone, 20, 21);
2125     $LINK_MAP->insert ($exit->clone, 21, 19);
2126     $LINK_MAP->insert ($exit->clone, 21, 20);
2127     $LINK_MAP->insert ($exit->clone, 21, 21);
2128    
2129     $exit->destroy;
2130     });
2131    
2132     $LINK_MAP->{deny_save} = 1;
2133     $LINK_MAP->{deny_reset} = 1;
2134    
2135     $cf::MAP{$LINK_MAP->path} = $LINK_MAP;
2136 root 1.108 }
2137    
2138 root 1.85 register "<global>", __PACKAGE__;
2139    
2140 root 1.111 register_command "reload" => sub {
2141 root 1.65 my ($who, $arg) = @_;
2142    
2143     if ($who->flag (FLAG_WIZ)) {
2144 root 1.107 $who->message ("start of reload.");
2145 root 1.111 reload;
2146 root 1.107 $who->message ("end of reload.");
2147 root 1.65 }
2148     };
2149    
2150 root 1.27 unshift @INC, $LIBDIR;
2151 root 1.17
2152 root 1.35 $TICK_WATCHER = Event->timer (
2153 root 1.104 reentrant => 0,
2154     prio => 0,
2155     at => $NEXT_TICK || $TICK,
2156     data => WF_AUTOCANCEL,
2157     cb => sub {
2158 root 1.103 unless ($FREEZE) {
2159     cf::server_tick; # one server iteration
2160     $RUNTIME += $TICK;
2161     }
2162 root 1.35
2163     $NEXT_TICK += $TICK;
2164    
2165 root 1.78 # if we are delayed by four ticks or more, skip them all
2166 root 1.103 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
2167 root 1.35
2168     $TICK_WATCHER->at ($NEXT_TICK);
2169     $TICK_WATCHER->start;
2170     },
2171     );
2172    
2173 root 1.80 IO::AIO::max_poll_time $TICK * 0.2;
2174 root 1.77
2175 root 1.108 Event->io (
2176     fd => IO::AIO::poll_fileno,
2177     poll => 'r',
2178     prio => 5,
2179     data => WF_AUTOCANCEL,
2180     cb => \&IO::AIO::poll_cb,
2181     );
2182    
2183     Event->timer (
2184     data => WF_AUTOCANCEL,
2185     after => 0,
2186     interval => 10,
2187     cb => sub {
2188     (Coro::unblock_sub {
2189     write_runtime
2190     or warn "ERROR: unable to write runtime file: $!";
2191     })->();
2192     },
2193     );
2194 root 1.103
2195 root 1.1 1
2196