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.26 by root, Thu Jul 20 22:03:36 2006 UTC vs.
Revision 1.256 by root, Sat Apr 21 16:56:32 2007 UTC

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

Diff Legend

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