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.38 by root, Thu Aug 24 17:29:30 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;
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 ();
10use Time::HiRes; 31use Time::HiRes;
11use Event; 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
12$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
13 41
14use strict; 42# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
43$YAML::Syck::ImplicitUnicode = 1;
15 44
16our %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
17our @EVENT; 58our @EVENT;
18our @PLUGIN_EVENT;
19our %PROP_TYPE;
20our %PROP_IDX;
21our $LIBDIR = maps_directory "perl";
22 59
23our $TICK = MAX_TIME * 1e-6; 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(!)
24our $TICK_WATCHER; 73our $TICK_WATCHER;
74our $AIO_POLL_WATCHER;
75our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
25our $NEXT_TICK; 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
26 158
27BEGIN { 159BEGIN {
28 @PLUGIN_EVENT = map lc, @PLUGIN_EVENT;
29
30 *CORE::GLOBAL::warn = sub { 160 *CORE::GLOBAL::warn = sub {
31 my $msg = join "", @_; 161 my $msg = join "", @_;
162
32 $msg .= "\n" 163 $msg .= "\n"
33 unless $msg =~ /\n$/; 164 unless $msg =~ /\n$/;
34 165
35 print STDERR "cfperl: $msg"; 166 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
167
168 utf8::encode $msg;
36 LOG llevError, "cfperl: $msg"; 169 LOG llevError, $msg;
37 }; 170 };
38} 171}
39 172
40my %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';
41 179
42# generate property mutators 180# we bless all objects into (empty) derived classes to force a method lookup
43sub prop_gen { 181# within the Safe compartment.
44 my ($prefix, $class) = @_; 182for my $pkg (qw(
45 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)) {
46 no strict 'refs'; 189 no strict 'refs';
47
48 for my $prop (keys %PROP_TYPE) {
49 $prop =~ /^\Q$prefix\E_(.*$)/ or next;
50 my $sub = lc $1;
51
52 my $type = $PROP_TYPE{$prop};
53 my $idx = $PROP_IDX {$prop};
54
55 *{"$class\::get_$sub"} = *{"$class\::$sub"} = sub {
56 $_[0]->get_property ($type, $idx)
57 };
58
59 *{"$class\::set_$sub"} = sub {
60 $_[0]->set_property ($type, $idx, $_[1]);
61 } unless $ignore_set{$prop};
62 }
63}
64
65# auto-generate most of the API
66
67prop_gen OBJECT_PROP => "cf::object";
68# CFAPI_OBJECT_ANIMATION?
69prop_gen PLAYER_PROP => "cf::object::player";
70
71prop_gen MAP_PROP => "cf::map";
72prop_gen ARCH_PROP => "cf::arch";
73
74# guessed hierarchies
75
76@ext::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
77@ext::cf::object::map::ISA = @cf::object::map::ISA = 'cf::object';
78
79# we bless all objects into derived classes to force a method lookup
80# within the Safe compartment.
81for my $pkg (qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region cf::arch)) {
82 no strict 'refs';
83 @{"ext::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 190 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
84} 191}
85 192
86$Event::DIED = sub { 193$Event::DIED = sub {
87 warn "error in event callback: @_"; 194 warn "error in event callback: @_";
88}; 195};
89 196
90my %ext_pkg; 197=head2 UTILITY FUNCTIONS
91my @exts;
92my @hook;
93my %command;
94my %extcmd;
95 198
96sub inject_event { 199=over 4
97 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(&) {
98 my $event_code = shift; 359 my $cb = shift;
99 360
100 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
101 or return; 377 or return;
102 378
103 &$cb 379 my $value = $cf::RUNTIME + 90 + 10;
104} 380 # 10 is the runtime save interval, for a monotonic clock
381 # 60 allows for the watchdog to kill the server.
105 382
106sub 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 {
107 my $event = shift; 692 my $event = shift;
693 my $callbacks = shift;
108 694
109 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
110 or return; 833 or return;
111 834
112 List::Util::max map &$_, values %$cb 835 unless (aio_stat "$filename.pst") {
113} 836 (aio_load "$filename.pst", $av) >= 0
114 837 or return;
115sub inject_command { 838 $av = eval { (Storable::thaw $av)->{objs} };
116 my ($name, $obj, $params) = @_;
117
118 for my $cmd (@{ $command{$name} }) {
119 $cmd->[1]->($obj, $params);
120 } 839 }
121 840
122 -1 841 warn sprintf "loading %s (%d)\n",
842 $filename, length $data, scalar @{$av || []};#d#
843 return ($data, $av);
123} 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
124 855
125sub register_command { 856sub register_command {
126 my ($name, $time, $cb) = @_; 857 my ($name, $cb) = @_;
127 858
128 my $caller = caller; 859 my $caller = caller;
129 #warn "registering command '$name/$time' to '$caller'"; 860 #warn "registering command '$name/$time' to '$caller'";
130 861
131 push @{ $command{$name} }, [$time, $cb, $caller]; 862 push @{ $COMMAND{$name} }, [$caller, $cb];
132 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
133} 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
134 873
135sub register_extcmd { 874sub register_extcmd {
136 my ($name, $cb) = @_; 875 my ($name, $cb) = @_;
137 876
138 my $caller = caller; 877 $EXTCMD{$name} = $cb;
139 #warn "registering extcmd '$name' to '$caller'";
140
141 $extcmd{$name} = [$cb, $caller];
142} 878}
143 879
144sub register { 880cf::player->attach (
145 my ($base, $pkg) = @_; 881 on_command => sub {
882 my ($pl, $name, $params) = @_;
146 883
147 for my $idx (0 .. $#PLUGIN_EVENT) { 884 my $cb = $COMMAND{$name}
148 if (my $ref = $pkg->can ("on_$PLUGIN_EVENT[$idx]")) { 885 or return;
149 #warn "registering $PLUGIN_EVENT[$idx] hook to '$pkg'\n"; 886
150 $hook[$idx]{$base} = $ref; 887 for my $cmd (@$cb) {
888 $cmd->[1]->($pl->ob, $params);
151 } 889 }
890
891 cf::override;
152 } 892 },
153} 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);
154 911
155sub load_extension { 912sub load_extension {
156 my ($path) = @_; 913 my ($path) = @_;
157 914
158 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 915 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
159 my $base = $1; 916 my $base = $1;
160 my $pkg = $1; 917 my $pkg = $1;
161 $pkg =~ s/[^[:word:]]/_/g; 918 $pkg =~ s/[^[:word:]]/_/g;
162 $pkg = "cf::ext::$pkg"; 919 $pkg = "ext::$pkg";
163 920
164 warn "loading '$path' into '$pkg'\n"; 921 warn "... loading '$path' into '$pkg'\n";
165 922
166 open my $fh, "<:utf8", $path 923 open my $fh, "<:utf8", $path
167 or die "$path: $!"; 924 or die "$path: $!";
168 925
169 my $source = 926 my $source =
170 "package $pkg; use strict; use utf8;\n" 927 "package $pkg; use strict; use utf8;\n"
171 . "#line 1 \"$path\"\n{\n" 928 . "#line 1 \"$path\"\n{\n"
172 . (do { local $/; <$fh> }) 929 . (do { local $/; <$fh> })
173 . "\n};\n1"; 930 . "\n};\n1";
174 931
175 eval $source 932 unless (eval $source) {
176 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 }
177 942
178 push @exts, $pkg; 943 push @EXTS, $pkg;
179 $ext_pkg{$base} = $pkg;
180
181# no strict 'refs';
182# @{"$pkg\::ISA"} = ext::;
183
184 register $base, $pkg;
185}
186
187sub unload_extension {
188 my ($pkg) = @_;
189
190 warn "removing extension $pkg\n";
191
192 # remove hooks
193 for my $idx (0 .. $#PLUGIN_EVENT) {
194 delete $hook[$idx]{$pkg};
195 }
196
197 # remove commands
198 for my $name (keys %command) {
199 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} };
200
201 if (@cb) {
202 $command{$name} = \@cb;
203 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
204 } else {
205 delete $command{$name};
206 delete $COMMAND{"$name\000"};
207 }
208 }
209
210 # remove extcmds
211 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) {
212 delete $extcmd{$name};
213 }
214
215 if (my $cb = $pkg->can ("on_unload")) {
216 eval {
217 $cb->($pkg);
218 1
219 } or warn "$pkg unloaded, but with errors: $@";
220 }
221
222 Symbol::delete_package $pkg;
223} 944}
224 945
225sub load_extensions { 946sub load_extensions {
226 my $LIBDIR = maps_directory "perl";
227
228 for my $ext (<$LIBDIR/*.ext>) { 947 for my $ext (<$LIBDIR/*.ext>) {
229 next unless -r $ext; 948 next unless -r $ext;
230 eval { 949 eval {
231 load_extension $ext; 950 load_extension $ext;
232 1 951 1
233 } or warn "$ext not loaded: $@"; 952 } or warn "$ext not loaded: $@";
234 } 953 }
235} 954}
236 955
237sub _perl_reload(&) { 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($) {
996 my ($login) = @_;
997
998 $cf::PLAYER{$login}
999 or cf::sync_job { !aio_stat path $login }
1000}
1001
1002sub find($) {
1003 return $cf::PLAYER{$_[0]} || do {
1004 my $login = $_[0];
1005
1006 my $guard = cf::lock_acquire "user_find:$login";
1007
1008 $cf::PLAYER{$_[0]} || do {
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";
1015
1016 my $pl = load_pl path $login
1017 or return;
1018 $cf::PLAYER{$login} = $pl
1019 }
1020 }
1021}
1022
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 {
238 my ($msg) = @_; 1337 my ($self) = @_;
239 1338
240 $msg->("reloading..."); 1339 $self
1340}
241 1341
242 eval { 1342sub as_string {
243 # 1. cancel all watchers 1343 my ($self) = @_;
244 $_->cancel for Event::all_watchers;
245 1344
246 # 2. unload all extensions 1345 "$self->{path}"
247 for (@exts) { 1346}
248 $msg->("unloading <$_>");
249 unload_extension $_;
250 }
251 1347
252 # 3. unload all modules loaded from $LIBDIR 1348# the displayed name, this is a one way mapping
253 while (my ($k, $v) = each %INC) { 1349sub visible_name {
254 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 1350 &as_string
1351}
255 1352
256 $msg->("removing <$k>"); 1353# the original (read-only) location
257 delete $INC{$k}; 1354sub load_path {
1355 my ($self) = @_;
258 1356
259 $k =~ s/\.pm$//; 1357 "$MAPDIR/$self->{path}.map"
260 $k =~ s/\//::/g; 1358}
261 1359
262 if (my $cb = $k->can ("unload_module")) { 1360# the temporary/swap location
263 $cb->(); 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;
1444 } else {
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
1453 1
1454}
1455
1456sub find;
1457sub find {
1458 my ($path, $origin) = @_;
1459
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);
264 } 1519 }
265
266 Symbol::delete_package $k;
267 }
268
269 # 4. get rid of ext::, as good as possible
270 Symbol::delete_package "ext::$_"
271 for qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region);
272
273 # 5. remove register_script_function callbacks
274 # TODO
275 1520 }
276 # 6. unload cf.pm "a bit"
277 delete $INC{"cf.pm"};
278 1521
279 # don't, removes xs symbols, too 1522 Coro::cede;
280 #Symbol::delete_package __PACKAGE__; 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;
281 1528
282 # 7. reload cf.pm 1529 unless ($self->{deny_activate}) {
283 $msg->("reloading cf.pm"); 1530 $self->decay_objects;
284 require cf; 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 {
1548 my ($self, $ob) = @_;
1549
1550 return find "~" . $ob->name . "/" . $self->{path}
1551 if $self->per_player;
1552
1553 $self
1554}
1555
1556# find and load all maps in the 3x3 area around a map
1557sub load_diag {
1558 my ($map) = @_;
1559
1560 my @diag; # diagonal neighbours
1561
1562 for (0 .. 3) {
1563 my $neigh = $map->tile_path ($_)
1564 or next;
1565 $neigh = find $neigh, $map
1566 or next;
1567 $neigh->load;
1568
1569 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],
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 {
1587 my ($map) = @_;
1588
1589 cf::sync_job { $map->load };
1590}
1591
1592our %MAP_PREFETCH;
1593our $MAP_PREFETCHER = undef;
1594
1595sub find_async {
1596 my ($path, $origin) = @_;
1597
1598 $path = normalise $path, $origin && $origin->{path};
1599
1600 if (my $map = $cf::MAP{$path}) {
1601 return $map if $map->in_memory == cf::MAP_IN_MEMORY;
1602 }
1603
1604 undef $MAP_PREFETCH{$path};
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;
1611
1612 delete $MAP_PREFETCH{$path};
1613 }
1614 }
1615 undef $MAP_PREFETCHER;
285 }; 1616 };
286 $msg->($@) if $@; 1617 $MAP_PREFETCHER->prio (6);
287 1618
288 $msg->("reloaded"); 1619 ()
289}; 1620}
290 1621
291sub perl_reload() { 1622sub save {
292 _perl_reload { 1623 my ($self) = @_;
293 warn $_[0]; 1624
294 print "$_[0]\n"; 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;
295 }; 1642 };
296}
297 1643
298register_command "perl-reload", 0, sub { 1644 if ($uniq) {
299 my ($who, $arg) = @_; 1645 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
300 1646 $self->_save_objects ($uniq, cf::IO_UNIQUES);
301 if ($who->flag (FLAG_WIZ)) {
302 _perl_reload {
303 warn $_[0];
304 $who->message ($_[0]);
305 };
306 }
307};
308
309#############################################################################
310# utility functions
311
312use JSON::Syck (); # TODO# replace by JSON::PC once working
313
314sub from_json($) {
315 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
316 JSON::Syck::Load $_[0]
317}
318
319sub to_json($) {
320 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
321 JSON::Syck::Dump $_[0]
322}
323
324#############################################################################
325# extcmd framework, basically convert ext <msg>
326# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
327
328sub on_extcmd {
329 my ($pl, $buf) = @_;
330
331 my $msg = eval { from_json $buf };
332
333 if (ref $msg) {
334 if (my $cb = $extcmd{$msg->{msgtype}}) {
335 if (my %reply = $cb->[0]->($pl, $msg)) {
336 $pl->ext_reply ($msg->{msgid}, %reply);
337 }
338 }
339 } else { 1647 } else {
340 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1648 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
341 }
342
343 1 1649 }
344} 1650}
345 1651
346############################################################################# 1652sub swap_out {
347# load/save/clean perl data associated with a map
348
349*on_mapclean = sub {
350 my ($map) = @_; 1653 my ($self) = @_;
351 1654
352 my $path = $map->tmpname; 1655 # save first because save cedes
353 defined $path or return; 1656 $self->save;
354 1657
355 unlink "$path.cfperl"; 1658 my $lock = cf::lock_acquire "map_data:" . $self->path;
356};
357 1659
358*on_mapin = 1660 return if $self->players;
359*on_mapload = sub { 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 {
360 my ($map) = @_; 1669 my ($self) = @_;
361 1670
362 my $path = $map->tmpname; 1671 # TODO: safety, remove and allow resettable per-player maps
363 $path = $map->path unless defined $path; 1672 return 1e99 if $self->isa ("ext::map_per_player");#d#
1673 return 1e99 if $self->{deny_reset};
364 1674
365 open my $fh, "<:raw", "$path.cfperl" 1675 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
366 or return; # no perl data 1676 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
367 1677
368 my $data = Storable::thaw do { local $/; <$fh> }; 1678 $time + $to
1679}
369 1680
370 $data->{version} <= 1 1681sub should_reset {
371 or return; # too new
372
373 $map->_set_obs ($data->{obs});
374};
375
376*on_mapout = sub {
377 my ($map) = @_; 1682 my ($self) = @_;
378 1683
379 my $path = $map->tmpname; 1684 $self->reset_at <= $cf::RUNTIME
380 $path = $map->path unless defined $path;
381
382 my $obs = $map->_get_obs;
383
384 if (defined $obs) {
385 open my $fh, ">:raw", "$path.cfperl"
386 or die "$path.cfperl: $!";
387
388 stat $path;
389
390 print $fh Storable::nfreeze {
391 size => (stat _)[7],
392 time => (stat _)[9],
393 version => 1,
394 obs => $obs,
395 };
396
397 chmod SAVE_MODE, "$path.cfperl"; # very racy, but cf-compatible *g*
398 } else {
399 unlink "$path.cfperl";
400 }
401};
402
403#############################################################################
404# load/save perl data associated with player->ob objects
405
406sub all_objects(@) {
407 @_, map all_objects ($_->inv), @_
408} 1685}
409 1686
410*on_player_load = sub { 1687sub reset {
411 my ($ob, $path) = @_; 1688 my ($self) = @_;
412 1689
413 for my $o (all_objects $ob) { 1690 my $lock = cf::lock_acquire "map_data:$self->{path}";
414 if (my $value = $o->get_ob_key_value ("_perl_data")) {
415 $o->set_ob_key_value ("_perl_data");
416 1691
417 %$o = %{ Storable::thaw pack "H*", $value }; 1692 return if $self->players;
418 } 1693 return if $self->isa ("ext::map_per_player");#d#
419 }
420};
421 1694
422*on_player_save = sub { 1695 warn "resetting map ", $self->path;#d#
423 my ($ob, $path) = @_;
424 1696
425 $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_) 1697 $self->in_memory (cf::MAP_SWAPPED);
426 for grep %$_, all_objects $ob;
427};
428 1698
429############################################################################# 1699 # need to save uniques path
430# core extensions - in perl 1700 unless ($self->{deny_save}) {
1701 my $uniq = $self->uniq_path; utf8::encode $uniq;
431 1702
432=item cf::player::exists $login 1703 $self->_save_objects ($uniq, cf::IO_UNIQUES)
1704 if $uniq;
1705 }
433 1706
434Returns true when the given account exists. 1707 delete $cf::MAP{$self->path};
435 1708
436=cut 1709 $self->clear;
437 1710
438sub cf::player::exists($) { 1711 $_->clear_links_to ($self) for values %cf::MAP;
439 cf::player::find $_[0]
440 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
441}
442 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
443=item $player->reply ($npc, $msg[, $flags]) 1796=item $player_object->reply ($npc, $msg[, $flags])
444 1797
445Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 1798Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
446can be C<undef>. Does the right thing when the player is currently in a 1799can be C<undef>. Does the right thing when the player is currently in a
447dialogue with the given NPC character. 1800dialogue with the given NPC character.
448 1801
449=cut 1802=cut
450 1803
451# rough implementation of a future "reply" method that works 1804# rough implementation of a future "reply" method that works
452# with dialog boxes. 1805# with dialog boxes.
1806#TODO: the first argument must go, split into a $npc->reply_to ( method
453sub cf::object::player::reply($$$;$) { 1807sub cf::object::player::reply($$$;$) {
454 my ($self, $npc, $msg, $flags) = @_; 1808 my ($self, $npc, $msg, $flags) = @_;
455 1809
456 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 1810 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
457 1811
… …
461 $msg = $npc->name . " says: $msg" if $npc; 1815 $msg = $npc->name . " says: $msg" if $npc;
462 $self->message ($msg, $flags); 1816 $self->message ($msg, $flags);
463 } 1817 }
464} 1818}
465 1819
466=item $player->ext_reply ($msgid, $msgtype, %msg) 1820=item $player_object->may ("access")
467 1821
468Sends an ext reply to the player. 1822Returns wether the given player is authorized to access resource "access"
1823(e.g. "command_wizcast").
469 1824
470=cut 1825=cut
471 1826
472sub cf::player::ext_reply($$$%) { 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($$%) {
473 my ($self, $id, %msg) = @_; 2084 my ($self, $type, %msg) = @_;
474 2085
475 $msg{msgid} = $id; 2086 $msg{msgtype} = "event_$type";
476
477 $self->send ("ext " . to_json \%msg); 2087 $self->send_packet ("ext " . cf::to_json \%msg);
478} 2088}
479 2089
480############################################################################# 2090=item $success = $client->query ($flags, "text", \&cb)
481# map scripting support
482 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
483our $safe = new Safe "ext"; 2184our $safe = new Safe "safe";
484our $safe_hole = new Safe::Hole; 2185our $safe_hole = new Safe::Hole;
485 2186
486$SIG{FPE} = 'IGNORE'; 2187$SIG{FPE} = 'IGNORE';
487 2188
488$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));
489 2190
490# here we export the classes and methods available to script code 2191# here we export the classes and methods available to script code
491 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
492for ( 2204for (
493 ["cf::object" => qw(contr pay_amount pay_player)], 2205 ["cf::object" => qw(contr pay_amount pay_player map)],
494 ["cf::object::player" => qw(player)], 2206 ["cf::object::player" => qw(player)],
495 ["cf::player" => qw(peaceful)], 2207 ["cf::player" => qw(peaceful)],
2208 ["cf::map" => qw(trigger)],
496) { 2209) {
497 no strict 'refs'; 2210 no strict 'refs';
498 my ($pkg, @funs) = @$_; 2211 my ($pkg, @funs) = @$_;
499 *{"ext::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 2212 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
500 for @funs; 2213 for @funs;
501} 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
502 2227
503sub safe_eval($;@) { 2228sub safe_eval($;@) {
504 my ($code, %vars) = @_; 2229 my ($code, %vars) = @_;
505 2230
506 my $qcode = $code; 2231 my $qcode = $code;
507 $qcode =~ s/"/‟/g; # not allowed in #line filenames 2232 $qcode =~ s/"/‟/g; # not allowed in #line filenames
508 $qcode =~ s/\n/\\n/g; 2233 $qcode =~ s/\n/\\n/g;
509 2234
510 local $_; 2235 local $_;
511 local @ext::cf::_safe_eval_args = values %vars; 2236 local @safe::cf::_safe_eval_args = values %vars;
512 2237
513 $code = 2238 my $eval =
514 "do {\n" 2239 "do {\n"
515 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 2240 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
516 . "#line 0 \"{$qcode}\"\n" 2241 . "#line 0 \"{$qcode}\"\n"
517 . $code 2242 . $code
518 . "\n}" 2243 . "\n}"
519 ; 2244 ;
520 2245
521 sub_generation_inc; 2246 sub_generation_inc;
522 my @res = wantarray ? $safe->reval ($code) : scalar $safe->reval ($code); 2247 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
523 sub_generation_inc; 2248 sub_generation_inc;
524 2249
2250 if ($@) {
2251 warn "$@";
2252 warn "while executing safe code '$code'\n";
2253 warn "with arguments " . (join " ", %vars) . "\n";
2254 }
2255
525 wantarray ? @res : $res[0] 2256 wantarray ? @res : $res[0]
526} 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
527 2273
528sub register_script_function { 2274sub register_script_function {
529 my ($fun, $cb) = @_; 2275 my ($fun, $cb) = @_;
530 2276
531 no strict 'refs'; 2277 no strict 'refs';
532 *{"ext::$fun"} = $safe_hole->wrap ($cb); 2278 *{"safe::$fun"} = $safe_hole->wrap ($cb);
533} 2279}
2280
2281=back
2282
2283=cut
534 2284
535############################################################################# 2285#############################################################################
536# the server's main()
537 2286
538sub run { 2287=head2 EXTENSION DATABASE SUPPORT
2288
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).
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;
2580 load_extensions;
2581
2582 $TICK_WATCHER->start;
539 Event::loop; 2583 Event::loop;
540} 2584}
541 2585
542############################################################################# 2586#############################################################################
543# initialisation 2587# initialisation and cleanup
544 2588
545register "<global>", __PACKAGE__; 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};
546 2791
547unshift @INC, $LIBDIR; 2792unshift @INC, $LIBDIR;
548 2793
549load_extensions; 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}
550 2816
551$TICK_WATCHER = Event->timer ( 2817$TICK_WATCHER = Event->timer (
2818 reentrant => 0,
2819 parked => 1,
552 prio => 1, 2820 prio => 0,
553 at => $NEXT_TICK || 1, 2821 at => $NEXT_TICK || $TICK,
2822 data => WF_AUTOCANCEL,
554 cb => sub { 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
555 cf::server_tick; # one server iteration 2832 cf::server_tick; # one server iteration
556 2833
557 my $NOW = Event::time; 2834 $RUNTIME += $TICK;
558 $NEXT_TICK += $TICK; 2835 $NEXT_TICK += $TICK;
559 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
560 # if we are delayed by four ticks, skip them all 2848 # if we are delayed by four ticks or more, skip them all
561 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 2849 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
562 2850
563 $TICK_WATCHER->at ($NEXT_TICK); 2851 $TICK_WATCHER->at ($NEXT_TICK);
564 $TICK_WATCHER->start; 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;
565 }, 2862 },
566); 2863);
567 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 }
2934
5681 29351
569 2936

Diff Legend

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