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

Diff Legend

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