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.40 by root, Fri Aug 25 15:21:57 2006 UTC vs.
Revision 1.234 by root, Thu Apr 5 13:44:31 2007 UTC

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

Diff Legend

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