ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/server/lib/cf.pm
Revision: 1.145
Committed: Sun Jan 7 21:54:59 2007 UTC (17 years, 5 months ago) by root
Branch: MAIN
Changes since 1.144: +33 -4 lines
Log Message:
implement quit

File Contents

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