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

Diff Legend

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