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.275 by root, Thu Jun 7 19:12:22 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 cf::map::unique_maps
1782
1783Returns an arrayref of paths of all shared maps that have
1784instantiated unique items. May block.
1785
1786=cut
1787
1788sub unique_maps() {
1789 my $files = aio_readdir $UNIQUEDIR
1790 or return;
1791
1792 my @paths;
1793
1794 for (@$files) {
1795 utf8::decode $_;
1796 next if /\.pst$/;
1797 next unless /^$PATH_SEP/o;
1798
1799 push @paths, cf::map::normalise $_;
1800 }
1801
1802 \@paths
1803}
1804
1805package cf;
1806
1807=back
1808
1809=head3 cf::object
1810
1811=cut
1812
1813package cf::object;
762 1814
763=over 4 1815=over 4
764 1816
765=item cf::player::exists $login 1817=item $ob->inv_recursive
766 1818
767Returns true when the given account exists. 1819Returns the inventory of the object _and_ their inventories, recursively.
768 1820
769=cut 1821=cut
770 1822
771sub cf::player::exists($) { 1823sub inv_recursive_;
772 cf::player::find $_[0] 1824sub inv_recursive_ {
773 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 1825 map { $_, inv_recursive_ $_->inv } @_
774} 1826}
1827
1828sub inv_recursive {
1829 inv_recursive_ inv $_[0]
1830}
1831
1832package cf;
1833
1834=back
1835
1836=head3 cf::object::player
1837
1838=over 4
775 1839
776=item $player_object->reply ($npc, $msg[, $flags]) 1840=item $player_object->reply ($npc, $msg[, $flags])
777 1841
778Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 1842Sends 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 1843can be C<undef>. Does the right thing when the player is currently in a
… …
781 1845
782=cut 1846=cut
783 1847
784# rough implementation of a future "reply" method that works 1848# rough implementation of a future "reply" method that works
785# with dialog boxes. 1849# with dialog boxes.
1850#TODO: the first argument must go, split into a $npc->reply_to ( method
786sub cf::object::player::reply($$$;$) { 1851sub cf::object::player::reply($$$;$) {
787 my ($self, $npc, $msg, $flags) = @_; 1852 my ($self, $npc, $msg, $flags) = @_;
788 1853
789 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 1854 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
790 1855
… …
794 $msg = $npc->name . " says: $msg" if $npc; 1859 $msg = $npc->name . " says: $msg" if $npc;
795 $self->message ($msg, $flags); 1860 $self->message ($msg, $flags);
796 } 1861 }
797} 1862}
798 1863
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") 1864=item $player_object->may ("access")
814 1865
815Returns wether the given player is authorized to access resource "access" 1866Returns wether the given player is authorized to access resource "access"
816(e.g. "command_wizcast"). 1867(e.g. "command_wizcast").
817 1868
… …
824 (ref $cf::CFG{"may_$access"} 1875 (ref $cf::CFG{"may_$access"}
825 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}} 1876 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
826 : $cf::CFG{"may_$access"}) 1877 : $cf::CFG{"may_$access"})
827} 1878}
828 1879
829=cut 1880=item $player_object->enter_link
830 1881
831############################################################################# 1882Freezes the player and moves him/her to a special map (C<{link}>).
1883
1884The player should be reasonably safe there for short amounts of time. You
1885I<MUST> call C<leave_link> as soon as possible, though.
1886
1887Will never block.
1888
1889=item $player_object->leave_link ($map, $x, $y)
1890
1891Moves the player out of the special C<{link}> map onto the specified
1892map. If the map is not valid (or omitted), the player will be moved back
1893to the location he/she was before the call to C<enter_link>, or, if that
1894fails, to the emergency map position.
1895
1896Might block.
1897
1898=cut
1899
1900sub link_map {
1901 unless ($LINK_MAP) {
1902 $LINK_MAP = cf::map::find "{link}"
1903 or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
1904 $LINK_MAP->load;
1905 }
1906
1907 $LINK_MAP
1908}
1909
1910sub cf::object::player::enter_link {
1911 my ($self) = @_;
1912
1913 $self->deactivate_recursive;
1914
1915 return if UNIVERSAL::isa $self->map, "ext::map_link";
1916
1917 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1918 if $self->map && $self->map->{path} ne "{link}";
1919
1920 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1921}
1922
1923sub cf::object::player::leave_link {
1924 my ($self, $map, $x, $y) = @_;
1925
1926 return unless $self->contr->active;
1927
1928 my $link_pos = delete $self->{_link_pos};
1929
1930 unless ($map) {
1931 # restore original map position
1932 ($map, $x, $y) = @{ $link_pos || [] };
1933 $map = cf::map::find $map;
1934
1935 unless ($map) {
1936 ($map, $x, $y) = @$EMERGENCY_POSITION;
1937 $map = cf::map::find $map
1938 or die "FATAL: cannot load emergency map\n";
1939 }
1940 }
1941
1942 ($x, $y) = (-1, -1)
1943 unless (defined $x) && (defined $y);
1944
1945 # use -1 or undef as default coordinates, not 0, 0
1946 ($x, $y) = ($map->enter_x, $map->enter_y)
1947 if $x <=0 && $y <= 0;
1948
1949 $map->load;
1950 $map->load_diag;
1951
1952 return unless $self->contr->active;
1953 $self->activate_recursive;
1954
1955 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1956 $self->enter_map ($map, $x, $y);
1957}
1958
1959=item $player_object->goto ($path, $x, $y[, $check->($map)])
1960
1961Moves the player to the given map-path and coordinates by first freezing
1962her, loading and preparing them map, calling the provided $check callback
1963that has to return the map if sucecssful, and then unfreezes the player on
1964the new (success) or old (failed) map position.
1965
1966=cut
1967
1968our $GOTOGEN;
1969
1970sub cf::object::player::goto {
1971 my ($self, $path, $x, $y, $check) = @_;
1972
1973 # do generation counting so two concurrent goto's will be executed in-order
1974 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1975
1976 $self->enter_link;
1977
1978 (async {
1979 my $map = eval {
1980 my $map = cf::map::find $path;
1981
1982 if ($map) {
1983 $map = $map->customise_for ($self);
1984 $map = $check->($map) if $check && $map;
1985 } else {
1986 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1987 }
1988
1989 $map
1990 };
1991
1992 if ($@) {
1993 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
1994 LOG llevError | logBacktrace, Carp::longmess $@;
1995 }
1996
1997 if ($gen == $self->{_goto_generation}) {
1998 delete $self->{_goto_generation};
1999 $self->leave_link ($map, $x, $y);
2000 }
2001 })->prio (1);
2002}
2003
2004=item $player_object->enter_exit ($exit_object)
2005
2006=cut
2007
2008sub parse_random_map_params {
2009 my ($spec) = @_;
2010
2011 my $rmp = { # defaults
2012 xsize => (cf::rndm 15, 40),
2013 ysize => (cf::rndm 15, 40),
2014 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
2015 #layout => string,
2016 };
2017
2018 for (split /\n/, $spec) {
2019 my ($k, $v) = split /\s+/, $_, 2;
2020
2021 $rmp->{lc $k} = $v if (length $k) && (length $v);
2022 }
2023
2024 $rmp
2025}
2026
2027sub prepare_random_map {
2028 my ($exit) = @_;
2029
2030 my $guard = cf::lock_acquire "exit_prepare:$exit";
2031
2032 # all this does is basically replace the /! path by
2033 # a new random map path (?random/...) with a seed
2034 # that depends on the exit object
2035
2036 my $rmp = parse_random_map_params $exit->msg;
2037
2038 if ($exit->map) {
2039 $rmp->{region} = $exit->region->name;
2040 $rmp->{origin_map} = $exit->map->path;
2041 $rmp->{origin_x} = $exit->x;
2042 $rmp->{origin_y} = $exit->y;
2043 }
2044
2045 $rmp->{random_seed} ||= $exit->random_seed;
2046
2047 my $data = cf::to_json $rmp;
2048 my $md5 = Digest::MD5::md5_hex $data;
2049 my $meta = "$RANDOMDIR/$md5.meta";
2050
2051 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2052 aio_write $fh, 0, (length $data), $data, 0;
2053 undef $fh;
2054 aio_rename "$meta~", $meta;
2055
2056 $exit->slaying ("?random/$md5");
2057 $exit->msg (undef);
2058 }
2059}
2060
2061sub cf::object::player::enter_exit {
2062 my ($self, $exit) = @_;
2063
2064 return unless $self->type == cf::PLAYER;
2065
2066 if ($exit->slaying eq "/!") {
2067 #TODO: this should de-fi-ni-te-ly not be a sync-job
2068 # the problem is that $exit might not survive long enough
2069 # so it needs to be done right now, right here
2070 cf::sync_job { prepare_random_map $exit };
2071 }
2072
2073 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2074 my $hp = $exit->stats->hp;
2075 my $sp = $exit->stats->sp;
2076
2077 $self->enter_link;
2078
2079 (async {
2080 $self->deactivate_recursive; # just to be sure
2081 unless (eval {
2082 $self->goto ($slaying, $hp, $sp);
2083
2084 1;
2085 }) {
2086 $self->message ("Something went wrong deep within the crossfire server. "
2087 . "I'll try to bring you back to the map you were before. "
2088 . "Please report this to the dungeon master!",
2089 cf::NDI_UNIQUE | cf::NDI_RED);
2090
2091 warn "ERROR in enter_exit: $@";
2092 $self->leave_link;
2093 }
2094 })->prio (1);
2095}
2096
2097=head3 cf::client
2098
2099=over 4
2100
2101=item $client->send_drawinfo ($text, $flags)
2102
2103Sends a drawinfo packet to the client. Circumvents output buffering so
2104should not be used under normal circumstances.
2105
2106=cut
2107
2108sub cf::client::send_drawinfo {
2109 my ($self, $text, $flags) = @_;
2110
2111 utf8::encode $text;
2112 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2113}
2114
2115=item $client->ext_event ($type, %msg)
2116
2117Sends an exti event to the client.
2118
2119=cut
2120
2121sub cf::client::ext_event($$%) {
2122 my ($self, $type, %msg) = @_;
2123
2124 $msg{msgtype} = "event_$type";
2125 $self->send_packet ("ext " . cf::to_json \%msg);
2126}
2127
2128=item $success = $client->query ($flags, "text", \&cb)
2129
2130Queues a query to the client, calling the given callback with
2131the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
2132C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2133
2134Queries can fail, so check the return code. Or don't, as queries will become
2135reliable at some point in the future.
2136
2137=cut
2138
2139sub cf::client::query {
2140 my ($self, $flags, $text, $cb) = @_;
2141
2142 return unless $self->state == ST_PLAYING
2143 || $self->state == ST_SETUP
2144 || $self->state == ST_CUSTOM;
2145
2146 $self->state (ST_CUSTOM);
2147
2148 utf8::encode $text;
2149 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2150
2151 $self->send_packet ($self->{query_queue}[0][0])
2152 if @{ $self->{query_queue} } == 1;
2153}
2154
2155cf::client->attach (
2156 on_reply => sub {
2157 my ($ns, $msg) = @_;
2158
2159 # this weird shuffling is so that direct followup queries
2160 # get handled first
2161 my $queue = delete $ns->{query_queue}
2162 or return; # be conservative, not sure how that can happen, but we saw a crash here
2163
2164 (shift @$queue)->[1]->($msg);
2165 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
2166
2167 push @{ $ns->{query_queue} }, @$queue;
2168
2169 if (@{ $ns->{query_queue} } == @$queue) {
2170 if (@$queue) {
2171 $ns->send_packet ($ns->{query_queue}[0][0]);
2172 } else {
2173 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2174 }
2175 }
2176 },
2177);
2178
2179=item $client->async (\&cb)
2180
2181Create a new coroutine, running the specified callback. The coroutine will
2182be automatically cancelled when the client gets destroyed (e.g. on logout,
2183or loss of connection).
2184
2185=cut
2186
2187sub cf::client::async {
2188 my ($self, $cb) = @_;
2189
2190 my $coro = &Coro::async ($cb);
2191
2192 $coro->on_destroy (sub {
2193 delete $self->{_coro}{$coro+0};
2194 });
2195
2196 $self->{_coro}{$coro+0} = $coro;
2197
2198 $coro
2199}
2200
2201cf::client->attach (
2202 on_destroy => sub {
2203 my ($ns) = @_;
2204
2205 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
2206 },
2207);
2208
2209=back
2210
832 2211
833=head2 SAFE SCRIPTING 2212=head2 SAFE SCRIPTING
834 2213
835Functions that provide a safe environment to compile and execute 2214Functions that provide a safe environment to compile and execute
836snippets of perl code without them endangering the safety of the server 2215snippets of perl code without them endangering the safety of the server
… …
849 2228
850# here we export the classes and methods available to script code 2229# here we export the classes and methods available to script code
851 2230
852=pod 2231=pod
853 2232
854The following fucntions and emthods are available within a safe environment: 2233The following functions and methods are available within a safe environment:
855 2234
856 cf::object contr pay_amount pay_player map 2235 cf::object contr pay_amount pay_player map
857 cf::object::player player 2236 cf::object::player player
858 cf::player peaceful 2237 cf::player peaceful
859 cf::map trigger 2238 cf::map trigger
… …
944############################################################################# 2323#############################################################################
945 2324
946=head2 EXTENSION DATABASE SUPPORT 2325=head2 EXTENSION DATABASE SUPPORT
947 2326
948Crossfire maintains a very simple database for extension use. It can 2327Crossfire maintains a very simple database for extension use. It can
949currently store anything that can be serialised using Storable, which 2328currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
950excludes objects. 2329convert to/from binary).
951 2330
952The parameter C<$family> should best start with the name of the extension 2331The parameter C<$family> should best start with the name of the extension
953using it, it should be unique. 2332using it, it should be unique.
954 2333
955=over 4 2334=over 4
956 2335
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 2336=item $value = cf::db_get $family => $key
964 2337
965Returns a single value from the database 2338Returns 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 2339
972=item cf::db_put $family => $key => $value 2340=item cf::db_put $family => $key => $value
973 2341
974Stores the given C<$value> in the family hash. Updates are delayed, if you 2342Stores 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 2343
985=cut 2344=cut
986 2345
987our $DB; 2346our $DB;
988 2347
989{ 2348sub db_init {
990 my $path = cf::localdir . "/database.pst"; 2349 unless ($DB) {
2350 $DB = BDB::db_create $DB_ENV;
991 2351
992 sub db_load() { 2352 cf::sync_job {
993 warn "loading database $path\n";#d# remove later 2353 eval {
994 $DB = stat $path ? Storable::retrieve $path : { }; 2354 $DB->set_flags (BDB::CHKSUM);
995 }
996 2355
997 my $pid; 2356 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
998 2357 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
999 sub db_save() { 2358 cf::cleanup "db_open(db): $!" if $!;
1000 warn "saving database $path\n";#d# remove later 2359 };
1001 waitpid $pid, 0 if $pid; 2360 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 } 2361 };
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 }); 2362 }
2363}
1020 2364
1021 sub db_dirty() {
1022 $dirty = 1;
1023 $idle->start;
1024 }
1025
1026 sub db_get($;$) { 2365sub db_get($$) {
1027 @_ >= 2 2366 my $key = "$_[0]/$_[1]";
1028 ? $DB->{$_[0]}{$_[1]}
1029 : ($DB->{$_[0]} ||= { })
1030 }
1031 2367
2368 cf::sync_job {
2369 BDB::db_get $DB, undef, $key, my $data;
2370
2371 $! ? ()
2372 : $data
2373 }
2374}
2375
1032 sub db_put($$;$) { 2376sub db_put($$$) {
1033 if (@_ >= 3) { 2377 BDB::dbreq_pri 4;
1034 $DB->{$_[0]}{$_[1]} = $_[2]; 2378 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
1035 } else { 2379}
1036 $DB->{$_[0]} = $_[1];
1037 }
1038 db_dirty;
1039 }
1040 2380
1041 cf::global->attach ( 2381=item cf::cache $id => [$paths...], $processversion => $process
1042 prio => 10000, 2382
1043 on_cleanup => sub { 2383Generic caching function that returns the value of the resource $id,
1044 db_sync; 2384caching and regenerating as required.
2385
2386This function can block.
2387
2388=cut
2389
2390sub cache {
2391 my ($id, $src, $processversion, $process) = @_;
2392
2393 my $meta =
2394 join "\x00",
2395 $processversion,
2396 map {
2397 aio_stat $_
2398 and Carp::croak "$_: $!";
2399
2400 ($_, (stat _)[7,9])
2401 } @$src;
2402
2403 my $dbmeta = db_get cache => "$id/meta";
2404 if ($dbmeta ne $meta) {
2405 # changed, we may need to process
2406
2407 my @data;
2408 my $md5;
2409
2410 for (0 .. $#$src) {
2411 0 <= aio_load $src->[$_], $data[$_]
2412 or Carp::croak "$src->[$_]: $!";
1045 }, 2413 }
1046 ); 2414
2415 # if processing is expensive, check
2416 # checksum first
2417 if (1) {
2418 $md5 =
2419 join "\x00",
2420 $processversion,
2421 map {
2422 Coro::cede;
2423 ($src->[$_], Digest::MD5::md5_hex $data[$_])
2424 } 0.. $#$src;
2425
2426
2427 my $dbmd5 = db_get cache => "$id/md5";
2428 if ($dbmd5 eq $md5) {
2429 db_put cache => "$id/meta", $meta;
2430
2431 return db_get cache => "$id/data";
2432 }
2433 }
2434
2435 my $t1 = Time::HiRes::time;
2436 my $data = $process->(\@data);
2437 my $t2 = Time::HiRes::time;
2438
2439 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2440
2441 db_put cache => "$id/data", $data;
2442 db_put cache => "$id/md5" , $md5;
2443 db_put cache => "$id/meta", $meta;
2444
2445 return $data;
2446 }
2447
2448 db_get cache => "$id/data"
2449}
2450
2451=item fork_call { }, $args
2452
2453Executes the given code block with the given arguments in a seperate
2454process, returning the results. Everything must be serialisable with
2455Coro::Storable. May, of course, block. Note that the executed sub may
2456never block itself or use any form of Event handling.
2457
2458=cut
2459
2460sub fork_call(&@) {
2461 my ($cb, @args) = @_;
2462
2463# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2464# or die "socketpair: $!";
2465 pipe my $fh1, my $fh2
2466 or die "pipe: $!";
2467
2468 if (my $pid = fork) {
2469 close $fh2;
2470
2471 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2472 $res = Coro::Storable::thaw $res;
2473
2474 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2475
2476 die $$res unless "ARRAY" eq ref $res;
2477
2478 return wantarray ? @$res : $res->[-1];
2479 } else {
2480 reset_signals;
2481 local $SIG{__WARN__};
2482 local $SIG{__DIE__};
2483 eval {
2484 close $fh1;
2485
2486 my @res = eval { $cb->(@args) };
2487 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2488 };
2489
2490 warn $@ if $@;
2491 _exit 0;
2492 }
1047} 2493}
1048 2494
1049############################################################################# 2495#############################################################################
1050# the server's main() 2496# the server's init and main functions
2497
2498sub load_facedata($) {
2499 my ($path) = @_;
2500
2501 warn "loading facedata from $path\n";
2502
2503 my $facedata;
2504 0 < aio_load $path, $facedata
2505 or die "$path: $!";
2506
2507 $facedata = Coro::Storable::thaw $facedata;
2508
2509 $facedata->{version} == 2
2510 or cf::cleanup "$path: version mismatch, cannot proceed.";
2511
2512 {
2513 my $faces = $facedata->{faceinfo};
2514
2515 while (my ($face, $info) = each %$faces) {
2516 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2517 cf::face::set $idx, $info->{visibility}, $info->{magicmap};
2518 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2519 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2520 Coro::cede;
2521 }
2522
2523 while (my ($face, $info) = each %$faces) {
2524 next unless $info->{smooth};
2525 my $idx = cf::face::find $face
2526 or next;
2527 if (my $smooth = cf::face::find $info->{smooth}) {
2528 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel};
2529 } else {
2530 warn "smooth face '$info->{smooth}' not found for face '$face'";
2531 }
2532 Coro::cede;
2533 }
2534 }
2535
2536 {
2537 my $anims = $facedata->{animinfo};
2538
2539 while (my ($anim, $info) = each %$anims) {
2540 cf::anim::set $anim, $info->{frames}, $info->{facings};
2541 Coro::cede;
2542 }
2543
2544 cf::anim::invalidate_all; # d'oh
2545 }
2546
2547 1
2548}
2549
2550sub reload_regions {
2551 load_resource_file "$MAPDIR/regions"
2552 or die "unable to load regions file\n";
2553}
2554
2555sub reload_facedata {
2556 load_facedata "$DATADIR/facedata"
2557 or die "unable to load facedata\n";
2558}
2559
2560sub reload_archetypes {
2561 load_resource_file "$DATADIR/archetypes"
2562 or die "unable to load archetypes\n";
2563}
2564
2565sub reload_treasures {
2566 load_resource_file "$DATADIR/treasures"
2567 or die "unable to load treasurelists\n";
2568}
2569
2570sub reload_resources {
2571 warn "reloading resource files...\n";
2572
2573 reload_regions;
2574 reload_facedata;
2575 #reload_archetypes;#d#
2576 reload_archetypes;
2577 reload_treasures;
2578
2579 warn "finished reloading resource files\n";
2580}
2581
2582sub init {
2583 reload_resources;
2584}
1051 2585
1052sub cfg_load { 2586sub cfg_load {
1053 open my $fh, "<:utf8", cf::confdir . "/config" 2587 open my $fh, "<:utf8", "$CONFDIR/config"
1054 or return; 2588 or return;
1055 2589
1056 local $/; 2590 local $/;
1057 *CFG = YAML::Syck::Load <$fh>; 2591 *CFG = YAML::Syck::Load <$fh>;
2592
2593 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
2594
2595 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2596 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
2597
2598 if (exists $CFG{mlockall}) {
2599 eval {
2600 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
2601 and die "WARNING: m(un)lockall failed: $!\n";
2602 };
2603 warn $@ if $@;
2604 }
1058} 2605}
1059 2606
1060sub main { 2607sub main {
2608 # we must not ever block the main coroutine
2609 local $Coro::idle = sub {
2610 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2611 (async {
2612 Event::one_event;
2613 })->prio (Coro::PRIO_MAX);
2614 };
2615
1061 cfg_load; 2616 cfg_load;
1062 db_load; 2617 db_init;
1063 load_extensions; 2618 load_extensions;
2619
2620 $TICK_WATCHER->start;
1064 Event::loop; 2621 Event::loop;
1065} 2622}
1066 2623
1067############################################################################# 2624#############################################################################
1068# initialisation 2625# initialisation and cleanup
1069 2626
1070sub _perl_reload(&) { 2627# install some emergency cleanup handlers
2628BEGIN {
2629 for my $signal (qw(INT HUP TERM)) {
2630 Event->signal (
2631 reentrant => 0,
2632 data => WF_AUTOCANCEL,
2633 signal => $signal,
2634 prio => 0,
2635 cb => sub {
2636 cf::cleanup "SIG$signal";
2637 },
2638 );
2639 }
2640}
2641
2642sub emergency_save() {
2643 my $freeze_guard = cf::freeze_mainloop;
2644
2645 warn "enter emergency perl save\n";
2646
2647 cf::sync_job {
2648 # use a peculiar iteration method to avoid tripping on perl
2649 # refcount bugs in for. also avoids problems with players
2650 # and maps saved/destroyed asynchronously.
2651 warn "begin emergency player save\n";
2652 for my $login (keys %cf::PLAYER) {
2653 my $pl = $cf::PLAYER{$login} or next;
2654 $pl->valid or next;
2655 $pl->save;
2656 }
2657 warn "end emergency player save\n";
2658
2659 warn "begin emergency map save\n";
2660 for my $path (keys %cf::MAP) {
2661 my $map = $cf::MAP{$path} or next;
2662 $map->valid or next;
2663 $map->save;
2664 }
2665 warn "end emergency map save\n";
2666
2667 warn "begin emergency database checkpoint\n";
2668 BDB::db_env_txn_checkpoint $DB_ENV;
2669 warn "end emergency database checkpoint\n";
2670 };
2671
2672 warn "leave emergency perl save\n";
2673}
2674
2675sub post_cleanup {
1071 my ($msg) = @_; 2676 my ($make_core) = @_;
1072 2677
1073 $msg->("reloading..."); 2678 warn Carp::longmess "post_cleanup backtrace"
2679 if $make_core;
2680}
1074 2681
1075 eval { 2682sub do_reload_perl() {
1076 # cancel all watchers 2683 # can/must only be called in main
2684 if ($Coro::current != $Coro::main) {
2685 warn "can only reload from main coroutine";
2686 return;
2687 }
2688
2689 warn "reloading...";
2690
2691 warn "entering sync_job";
2692
2693 cf::sync_job {
2694 cf::write_runtime; # external watchdog should not bark
2695 cf::emergency_save;
2696 cf::write_runtime; # external watchdog should not bark
2697
2698 warn "syncing database to disk";
2699 BDB::db_env_txn_checkpoint $DB_ENV;
2700
2701 # if anything goes wrong in here, we should simply crash as we already saved
2702
2703 warn "cancelling all WF_AUTOCANCEL watchers";
1077 for (Event::all_watchers) { 2704 for (Event::all_watchers) {
1078 $_->cancel if $_->data & WF_AUTOCANCEL; 2705 $_->cancel if $_->data & WF_AUTOCANCEL;
1079 } 2706 }
1080 2707
1081 # unload all extensions 2708 warn "flushing outstanding aio requests";
1082 for (@exts) { 2709 for (;;) {
1083 $msg->("unloading <$_>"); 2710 BDB::flush;
1084 unload_extension $_; 2711 IO::AIO::flush;
2712 Coro::cede;
2713 last unless IO::AIO::nreqs || BDB::nreqs;
2714 warn "iterate...";
2715 }
2716
2717 ++$RELOAD;
2718
2719 warn "cancelling all extension coros";
2720 $_->cancel for values %EXT_CORO;
2721 %EXT_CORO = ();
2722
2723 warn "removing commands";
2724 %COMMAND = ();
2725
2726 warn "removing ext commands";
2727 %EXTCMD = ();
2728
2729 warn "unloading/nuking all extensions";
2730 for my $pkg (@EXTS) {
2731 warn "... unloading $pkg";
2732
2733 if (my $cb = $pkg->can ("unload")) {
2734 eval {
2735 $cb->($pkg);
2736 1
2737 } or warn "$pkg unloaded, but with errors: $@";
1085 } 2738 }
1086 2739
2740 warn "... nuking $pkg";
2741 Symbol::delete_package $pkg;
2742 }
2743
1087 # unload all modules loaded from $LIBDIR 2744 warn "unloading all perl modules loaded from $LIBDIR";
1088 while (my ($k, $v) = each %INC) { 2745 while (my ($k, $v) = each %INC) {
1089 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2746 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
1090 2747
1091 $msg->("removing <$k>"); 2748 warn "... unloading $k";
1092 delete $INC{$k}; 2749 delete $INC{$k};
1093 2750
1094 $k =~ s/\.pm$//; 2751 $k =~ s/\.pm$//;
1095 $k =~ s/\//::/g; 2752 $k =~ s/\//::/g;
1096 2753
… …
1099 } 2756 }
1100 2757
1101 Symbol::delete_package $k; 2758 Symbol::delete_package $k;
1102 } 2759 }
1103 2760
1104 # sync database to disk
1105 cf::db_sync;
1106
1107 # get rid of safe::, as good as possible 2761 warn "getting rid of safe::, as good as possible";
1108 Symbol::delete_package "safe::$_" 2762 Symbol::delete_package "safe::$_"
1109 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region); 2763 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
1110 2764
1111 # remove register_script_function callbacks
1112 # TODO
1113
1114 # unload cf.pm "a bit" 2765 warn "unloading cf.pm \"a bit\"";
1115 delete $INC{"cf.pm"}; 2766 delete $INC{"cf.pm"};
2767 delete $INC{"cf/pod.pm"};
1116 2768
1117 # don't, removes xs symbols, too, 2769 # don't, removes xs symbols, too,
1118 # and global variables created in xs 2770 # and global variables created in xs
1119 #Symbol::delete_package __PACKAGE__; 2771 #Symbol::delete_package __PACKAGE__;
1120 2772
1121 # reload cf.pm 2773 warn "unload completed, starting to reload now";
2774
1122 $msg->("reloading cf.pm"); 2775 warn "reloading cf.pm";
1123 require cf; 2776 require cf;
2777 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
1124 2778
1125 # load config and database again 2779 warn "loading config and database again";
1126 cf::cfg_load; 2780 cf::cfg_load;
1127 cf::db_load;
1128 2781
1129 # load extensions 2782 warn "loading extensions";
1130 $msg->("load extensions");
1131 cf::load_extensions; 2783 cf::load_extensions;
1132 2784
1133 # reattach attachments to objects 2785 warn "reattaching attachments to objects/players";
1134 $msg->("reattach"); 2786 _global_reattach; # objects, sockets
1135 _global_reattach; 2787 warn "reattaching attachments to maps";
2788 reattach $_ for values %MAP;
2789 warn "reattaching attachments to players";
2790 reattach $_ for values %PLAYER;
2791
2792 warn "leaving sync_job";
2793
2794 1
2795 } or do {
2796 warn $@;
2797 warn "error while reloading, exiting.";
2798 exit 1;
1136 }; 2799 };
1137 $msg->($@) if $@;
1138 2800
1139 $msg->("reloaded"); 2801 warn "reloaded";
1140}; 2802};
1141 2803
1142sub perl_reload() { 2804our $RELOAD_WATCHER; # used only during reload
1143 _perl_reload { 2805
1144 warn $_[0]; 2806sub reload_perl() {
1145 print "$_[0]\n"; 2807 # doing reload synchronously and two reloads happen back-to-back,
2808 # coro crashes during coro_state_free->destroy here.
2809
2810 $RELOAD_WATCHER ||= Event->timer (
2811 reentrant => 0,
2812 after => 0,
2813 data => WF_AUTOCANCEL,
2814 cb => sub {
2815 do_reload_perl;
2816 undef $RELOAD_WATCHER;
2817 },
1146 }; 2818 );
1147} 2819}
1148 2820
1149register "<global>", __PACKAGE__;
1150
1151register_command "perl-reload" => sub { 2821register_command "reload" => sub {
1152 my ($who, $arg) = @_; 2822 my ($who, $arg) = @_;
1153 2823
1154 if ($who->flag (FLAG_WIZ)) { 2824 if ($who->flag (FLAG_WIZ)) {
1155 _perl_reload { 2825 $who->message ("reloading server.");
1156 warn $_[0]; 2826 async { reload_perl };
1157 $who->message ($_[0]); 2827 }
2828};
2829
2830unshift @INC, $LIBDIR;
2831
2832my $bug_warning = 0;
2833
2834our @WAIT_FOR_TICK;
2835our @WAIT_FOR_TICK_BEGIN;
2836
2837sub wait_for_tick {
2838 return unless $TICK_WATCHER->is_active;
2839 return if $Coro::current == $Coro::main;
2840
2841 my $signal = new Coro::Signal;
2842 push @WAIT_FOR_TICK, $signal;
2843 $signal->wait;
2844}
2845
2846sub wait_for_tick_begin {
2847 return unless $TICK_WATCHER->is_active;
2848 return if $Coro::current == $Coro::main;
2849
2850 my $signal = new Coro::Signal;
2851 push @WAIT_FOR_TICK_BEGIN, $signal;
2852 $signal->wait;
2853}
2854
2855 my $min = 1e6;#d#
2856 my $avg = 10;
2857$TICK_WATCHER = Event->timer (
2858 reentrant => 0,
2859 parked => 1,
2860 prio => 0,
2861 at => $NEXT_TICK || $TICK,
2862 data => WF_AUTOCANCEL,
2863 cb => sub {
2864 if ($Coro::current != $Coro::main) {
2865 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2866 unless ++$bug_warning > 10;
2867 return;
2868 }
2869
2870 $NOW = $tick_start = Event::time;
2871
2872 cf::server_tick; # one server iteration
2873
2874 0 && sync_job {#d#
2875 for(1..10) {
2876 my $t = Event::time;
2877 my $map = my $map = new_from_path cf::map "/tmp/x.map"
2878 or die;
2879
2880 $map->width (50);
2881 $map->height (50);
2882 $map->alloc;
2883 $map->_load_objects ("/tmp/x.map", 1);
2884 my $t = Event::time - $t;
2885
2886 #next unless $t < 0.0013;#d#
2887 if ($t < $min) {
2888 $min = $t;
2889 }
2890 $avg = $avg * 0.99 + $t * 0.01;
2891 }
2892 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
2893 exit 0;
2894 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
1158 }; 2895 };
1159 }
1160};
1161 2896
1162unshift @INC, $LIBDIR; 2897 $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; 2898 $NEXT_TICK += $TICK;
2899
2900 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2901 $NEXT_RUNTIME_WRITE = $NOW + 10;
2902 Coro::async_pool {
2903 write_runtime
2904 or warn "ERROR: unable to write runtime file: $!";
2905 };
2906 }
2907
2908# my $AFTER = Event::time;
2909# warn $AFTER - $NOW;#d#
2910
2911 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
2912 $sig->send;
2913 }
2914 while (my $sig = shift @WAIT_FOR_TICK) {
2915 $sig->send;
2916 }
2917
2918 $NOW = Event::time;
1173 2919
1174 # if we are delayed by four ticks or more, skip them all 2920 # if we are delayed by four ticks or more, skip them all
1175 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 2921 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
1176 2922
1177 $TICK_WATCHER->at ($NEXT_TICK); 2923 $TICK_WATCHER->at ($NEXT_TICK);
1178 $TICK_WATCHER->start; 2924 $TICK_WATCHER->start;
2925
2926 $LOAD = ($NOW - $tick_start) / $TICK;
2927 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
2928
2929 _post_tick;
2930
2931
1179 }, 2932 },
1180); 2933);
1181 2934
2935{
2936 BDB::max_poll_time $TICK * 0.1;
2937 $BDB_POLL_WATCHER = Event->io (
2938 reentrant => 0,
2939 fd => BDB::poll_fileno,
2940 poll => 'r',
2941 prio => 0,
2942 data => WF_AUTOCANCEL,
2943 cb => \&BDB::poll_cb,
2944 );
2945 BDB::min_parallel 8;
2946
2947 BDB::set_sync_prepare {
2948 my $status;
2949 my $current = $Coro::current;
2950 (
2951 sub {
2952 $status = $!;
2953 $current->ready; undef $current;
2954 },
2955 sub {
2956 Coro::schedule while defined $current;
2957 $! = $status;
2958 },
2959 )
2960 };
2961
2962 unless ($DB_ENV) {
2963 $DB_ENV = BDB::db_env_create;
2964
2965 cf::sync_job {
2966 eval {
2967 BDB::db_env_open
2968 $DB_ENV,
2969 $BDBDIR,
2970 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2971 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2972 0666;
2973
2974 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2975
2976 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2977 $DB_ENV->set_lk_detect;
2978 };
2979
2980 cf::cleanup "db_env_open(db): $@" if $@;
2981 };
2982 }
2983}
2984
2985{
2986 IO::AIO::min_parallel 8;
2987
2988 undef $Coro::AIO::WATCHER;
1182IO::AIO::max_poll_time $TICK * 0.2; 2989 IO::AIO::max_poll_time $TICK * 0.1;
1183 2990 $AIO_POLL_WATCHER = Event->io (
1184Event->io (fd => IO::AIO::poll_fileno, 2991 reentrant => 0,
1185 poll => 'r',
1186 prio => 5,
1187 data => WF_AUTOCANCEL, 2992 data => WF_AUTOCANCEL,
2993 fd => IO::AIO::poll_fileno,
2994 poll => 'r',
2995 prio => 6,
1188 cb => \&IO::AIO::poll_cb); 2996 cb => \&IO::AIO::poll_cb,
2997 );
2998}
2999
3000my $_log_backtrace;
3001
3002sub _log_backtrace {
3003 my ($msg, @addr) = @_;
3004
3005 $msg =~ s/\n//;
3006
3007 # limit the # of concurrent backtraces
3008 if ($_log_backtrace < 2) {
3009 ++$_log_backtrace;
3010 async {
3011 my @bt = fork_call {
3012 @addr = map { sprintf "%x", $_ } @addr;
3013 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3014 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3015 or die "addr2line: $!";
3016
3017 my @funcs;
3018 my @res = <$fh>;
3019 chomp for @res;
3020 while (@res) {
3021 my ($func, $line) = splice @res, 0, 2, ();
3022 push @funcs, "[$func] $line";
3023 }
3024
3025 @funcs
3026 };
3027
3028 LOG llevInfo, "[ABT] $msg\n";
3029 LOG llevInfo, "[ABT] $_\n" for @bt;
3030 --$_log_backtrace;
3031 };
3032 } else {
3033 LOG llevInfo, "[ABT] $msg\n";
3034 LOG llevInfo, "[ABT] [suppressed]\n";
3035 }
3036}
3037
3038# load additional modules
3039use cf::pod;
3040
3041END { cf::emergency_save }
1189 3042
11901 30431
1191 3044

Diff Legend

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