ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/server/lib/cf.pm
(Generate patch)

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.9 by root, Fri Mar 17 03:22:00 2006 UTC vs.
Revision 1.264 by root, Sun May 6 05:44:48 2007 UTC

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

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines