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.546 by root, Thu May 6 22:57:49 2010 UTC vs.
Revision 1.574 by root, Sun May 8 21:51:27 2011 UTC

1# 1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG. 2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3# 3#
4# Copyright (©) 2006,2007,2008,2009,2010 Marc Alexander Lehmann / Robin Redeker / the Deliantra team 4# Copyright (©) 2006,2007,2008,2009,2010,2011 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5# 5#
6# Deliantra is free software: you can redistribute it and/or modify it under 6# Deliantra is free software: you can redistribute it and/or modify it under
7# the terms of the Affero GNU General Public License as published by the 7# the terms of the Affero GNU General Public License as published by the
8# Free Software Foundation, either version 3 of the License, or (at your 8# Free Software Foundation, either version 3 of the License, or (at your
9# option) any later version. 9# option) any later version.
… …
93our @EVENT; 93our @EVENT;
94our @REFLECT; # set by XS 94our @REFLECT; # set by XS
95our %REFLECT; # set by us 95our %REFLECT; # set by us
96 96
97our $CONFDIR = confdir; 97our $CONFDIR = confdir;
98
98our $DATADIR = datadir; 99our $DATADIR = datadir;
99our $LIBDIR = "$DATADIR/ext"; 100our $LIBDIR = "$DATADIR/ext";
100our $PODDIR = "$DATADIR/pod"; 101our $PODDIR = "$DATADIR/pod";
101our $MAPDIR = "$DATADIR/" . mapdir; 102our $MAPDIR = "$DATADIR/" . mapdir;
103
102our $LOCALDIR = localdir; 104our $LOCALDIR = localdir;
103our $TMPDIR = "$LOCALDIR/" . tmpdir; 105our $TMPDIR = "$LOCALDIR/" . tmpdir;
104our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 106our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
105our $PLAYERDIR = "$LOCALDIR/" . playerdir; 107our $PLAYERDIR = "$LOCALDIR/" . playerdir;
106our $RANDOMDIR = "$LOCALDIR/random"; 108our $RANDOMDIR = "$LOCALDIR/random";
… …
129our @EXTRA_MODULES = qw(pod match mapscript incloader); 131our @EXTRA_MODULES = qw(pod match mapscript incloader);
130 132
131our %CFG; 133our %CFG;
132 134
133our $UPTIME; $UPTIME ||= time; 135our $UPTIME; $UPTIME ||= time;
134our $RUNTIME; 136our $RUNTIME = 0;
137our $SERVER_TICK = 0;
135our $NOW; 138our $NOW;
136 139
137our (%PLAYER, %PLAYER_LOADING); # all users 140our (%PLAYER, %PLAYER_LOADING); # all users
138our (%MAP, %MAP_LOADING ); # all maps 141our (%MAP, %MAP_LOADING ); # all maps
139our $LINK_MAP; # the special {link} map, which is always available 142our $LINK_MAP; # the special {link} map, which is always available
… …
148 151
149our @POST_INIT; 152our @POST_INIT;
150 153
151our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow) 154our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
152our $REALLY_UNLOOP; # never set to true, please :) 155our $REALLY_UNLOOP; # never set to true, please :)
156
157our $WAIT_FOR_TICK = new Coro::Signal;
158our @WAIT_FOR_TICK_BEGIN;
153 159
154binmode STDOUT; 160binmode STDOUT;
155binmode STDERR; 161binmode STDERR;
156 162
157# read virtual server time, if available 163# read virtual server time, if available
… …
191 197
192=over 4 198=over 4
193 199
194=item $cf::UPTIME 200=item $cf::UPTIME
195 201
196The timestamp of the server start (so not actually an uptime). 202The timestamp of the server start (so not actually an "uptime").
203
204=item $cf::SERVER_TICK
205
206An unsigned integer that starts at zero when the server is started and is
207incremented on every tick.
208
209=item $cf::NOW
210
211The (real) time of the last (current) server tick - updated before and
212after tick processing, so this is useful only as a rough "what time is it
213now" estimate.
214
215=item $cf::TICK
216
217The interval between each server tick, in seconds.
197 218
198=item $cf::RUNTIME 219=item $cf::RUNTIME
199 220
200The time this server has run, starts at 0 and is increased by $cf::TICK on 221The time this server has run, starts at 0 and is increased by $cf::TICK on
201every server tick. 222every server tick.
… …
207Various directories - "/etc", read-only install directory, perl-library 228Various directories - "/etc", read-only install directory, perl-library
208directory, pod-directory, read-only maps directory, "/var", "/var/tmp", 229directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
209unique-items directory, player file directory, random maps directory and 230unique-items directory, player file directory, random maps directory and
210database environment. 231database environment.
211 232
212=item $cf::NOW
213
214The time of the last (current) server tick.
215
216=item $cf::TICK
217
218The interval between server ticks, in seconds.
219
220=item $cf::LOADAVG 233=item $cf::LOADAVG
221 234
222The current CPU load on the server (alpha-smoothed), as a value between 0 235The current CPU load on the server (alpha-smoothed), as a value between 0
223(none) and 1 (overloaded), indicating how much time is spent on processing 236(none) and 1 (overloaded), indicating how much time is spent on processing
224objects per tick. Healthy values are < 0.5. 237objects per tick. Healthy values are < 0.5.
… …
235=item cf::wait_for_tick, cf::wait_for_tick_begin 248=item cf::wait_for_tick, cf::wait_for_tick_begin
236 249
237These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 250These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
238returns directly I<after> the tick processing (and consequently, can only wake one thread 251returns directly I<after> the tick processing (and consequently, can only wake one thread
239per tick), while cf::wait_for_tick wakes up all waiters after tick processing. 252per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
253
254Note that cf::Wait_for_tick will immediately return when the server is not
255ticking, making it suitable for small pauses in threads that need to run
256when the server is paused. If that is not applicable (i.e. you I<really>
257want to wait, use C<$cf::WAIT_FOR_TICK>).
258
259=item $cf::WAIT_FOR_TICK
260
261Note that C<cf::wait_for_tick> is probably the correct thing to use. This
262variable contains a L<Coro::Signal> that is broadcats after every server
263tick. Calling C<< ->wait >> on it will suspend the caller until after the
264next server tick.
240 265
241=cut 266=cut
242 267
243sub wait_for_tick(); 268sub wait_for_tick();
244sub wait_for_tick_begin(); 269sub wait_for_tick_begin();
… …
312} 337}
313 338
314$EV::DIED = sub { 339$EV::DIED = sub {
315 Carp::cluck "error in event callback: @_"; 340 Carp::cluck "error in event callback: @_";
316}; 341};
342
343#############################################################################
344
345sub fork_call(&@);
346sub get_slot($;$$);
317 347
318############################################################################# 348#############################################################################
319 349
320=head2 UTILITY FUNCTIONS 350=head2 UTILITY FUNCTIONS
321 351
… …
342 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 372 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
343 $d 373 $d
344 } || "[unable to dump $_[0]: '$@']"; 374 } || "[unable to dump $_[0]: '$@']";
345} 375}
346 376
377=item $scalar = load_file $path
378
379Loads the given file from path and returns its contents. Croaks on error
380and can block.
381
382=cut
383
384sub load_file($) {
385 0 <= aio_load $_[0], my $data
386 or Carp::croak "$_[0]: $!";
387
388 $data
389}
390
347=item $ref = cf::decode_json $json 391=item $ref = cf::decode_json $json
348 392
349Converts a JSON string into the corresponding perl data structure. 393Converts a JSON string into the corresponding perl data structure.
350 394
351=item $json = cf::encode_json $ref 395=item $json = cf::encode_json $ref
… …
357our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max 401our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
358 402
359sub encode_json($) { $json_coder->encode ($_[0]) } 403sub encode_json($) { $json_coder->encode ($_[0]) }
360sub decode_json($) { $json_coder->decode ($_[0]) } 404sub decode_json($) { $json_coder->decode ($_[0]) }
361 405
406=item $ref = cf::decode_storable $scalar
407
408Same as Coro::Storable::thaw, so blocks.
409
410=cut
411
412BEGIN { *decode_storable = \&Coro::Storable::thaw }
413
414=item $ref = cf::decode_yaml $scalar
415
416Same as YAML::XS::Load, but doesn't leak, because it forks (and thus blocks).
417
418=cut
419
420sub decode_yaml($) {
421 fork_call { YAML::XS::Load $_[0] } @_
422}
423
424=item $scalar = cf::unlzf $scalar
425
426Same as Compress::LZF::compress, but takes server ticks into account, so
427blocks.
428
429=cut
430
431sub unlzf($) {
432 # we assume 100mb/s minimum decompression speed (noncompressible data on a ~2ghz machine)
433 cf::get_slot +(length $_[0]) / 100_000_000, 0, "unlzf";
434 Compress::LZF::decompress $_[0]
435}
436
362=item cf::post_init { BLOCK } 437=item cf::post_init { BLOCK }
363 438
364Execute the given codeblock, I<after> all extensions have been (re-)loaded, 439Execute the given codeblock, I<after> all extensions have been (re-)loaded,
365but I<before> the server starts ticking again. 440but I<before> the server starts ticking again.
366 441
367The cdoeblock will have a single boolean argument to indicate whether this 442The codeblock will have a single boolean argument to indicate whether this
368is a reload or not. 443is a reload or not.
369 444
370=cut 445=cut
371 446
372sub post_init(&) { 447sub post_init(&) {
373 push @POST_INIT, shift; 448 push @POST_INIT, shift;
449}
450
451sub _post_init {
452 trace "running post_init jobs";
453
454 # run them in parallel...
455
456 my @join;
457
458 while () {
459 push @join, map &Coro::async ($_, 0), @POST_INIT;
460 @POST_INIT = ();
461
462 @join or last;
463
464 (pop @join)->join;
465 }
374} 466}
375 467
376=item cf::lock_wait $string 468=item cf::lock_wait $string
377 469
378Wait until the given lock is available. See cf::lock_acquire. 470Wait until the given lock is available. See cf::lock_acquire.
… …
431 EV::periodic $start, $interval, 0, $cb 523 EV::periodic $start, $interval, 0, $cb
432} 524}
433 525
434=item cf::get_slot $time[, $priority[, $name]] 526=item cf::get_slot $time[, $priority[, $name]]
435 527
436Allocate $time seconds of blocking CPU time at priority C<$priority>: 528Allocate $time seconds of blocking CPU time at priority C<$priority>
437This call blocks and returns only when you have at least C<$time> seconds 529(default: 0): This call blocks and returns only when you have at least
438of cpu time till the next tick. The slot is only valid till the next cede. 530C<$time> seconds of cpu time till the next tick. The slot is only valid
531till the next cede.
532
533Background jobs should use a priority les than zero, interactive jobs
534should use 100 or more.
439 535
440The optional C<$name> can be used to identify the job to run. It might be 536The optional C<$name> can be used to identify the job to run. It might be
441used for statistical purposes and should identify the same time-class. 537used for statistical purposes and should identify the same time-class.
442 538
443Useful for short background jobs. 539Useful for short background jobs.
… …
472 } 568 }
473 } 569 }
474 570
475 if (@SLOT_QUEUE) { 571 if (@SLOT_QUEUE) {
476 # we do not use wait_for_tick() as it returns immediately when tick is inactive 572 # we do not use wait_for_tick() as it returns immediately when tick is inactive
477 push @cf::WAIT_FOR_TICK, $signal; 573 $WAIT_FOR_TICK->wait;
478 $signal->wait;
479 } else { 574 } else {
480 $busy = 0; 575 $busy = 0;
481 Coro::schedule; 576 Coro::schedule;
482 } 577 }
483 } 578 }
… …
583 $EXT_CORO{$coro+0} = $coro; 678 $EXT_CORO{$coro+0} = $coro;
584 679
585 $coro 680 $coro
586} 681}
587 682
588=item fork_call { }, $args 683=item fork_call { }, @args
589 684
590Executes the given code block with the given arguments in a seperate 685Executes the given code block with the given arguments in a seperate
591process, returning the results. Everything must be serialisable with 686process, returning the results. Everything must be serialisable with
592Coro::Storable. May, of course, block. Note that the executed sub may 687Coro::Storable. May, of course, block. Note that the executed sub may
593never block itself or use any form of event handling. 688never block itself or use any form of event handling.
594 689
595=cut 690=cut
596 691
692sub post_fork {
693 reset_signals;
694}
695
597sub fork_call(&@) { 696sub fork_call(&@) {
598 my ($cb, @args) = @_; 697 my ($cb, @args) = @_;
599 698
600 # we seemingly have to make a local copy of the whole thing, 699 # we seemingly have to make a local copy of the whole thing,
601 # otherwise perl prematurely frees the stuff :/ 700 # otherwise perl prematurely frees the stuff :/
602 # TODO: investigate and fix (likely this will be rather laborious) 701 # TODO: investigate and fix (likely this will be rather laborious)
603 702
604 my @res = Coro::Util::fork_eval { 703 my @res = Coro::Util::fork_eval {
605 reset_signals; 704 cf::post_fork;
606 &$cb 705 &$cb
607 }, @args; 706 } @args;
608 707
609 wantarray ? @res : $res[-1] 708 wantarray ? @res : $res[-1]
610} 709}
611 710
612sub objinfo { 711sub objinfo {
… …
734 833
735 my @data; 834 my @data;
736 my $md5; 835 my $md5;
737 836
738 for (0 .. $#$src) { 837 for (0 .. $#$src) {
739 0 <= aio_load $src->[$_], $data[$_] 838 $data[$_] = load_file $src->[$_];
740 or Carp::croak "$src->[$_]: $!";
741 } 839 }
742 840
743 # if processing is expensive, check 841 # if processing is expensive, check
744 # checksum first 842 # checksum first
745 if (1) { 843 if (1) {
… …
1479 1577
1480 while (my ($k, $v) = each %todo) { 1578 while (my ($k, $v) = each %todo) {
1481 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting." 1579 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
1482 if exists $v->{meta}{mandatory}; 1580 if exists $v->{meta}{mandatory};
1483 } 1581 }
1582
1583 last;
1484 } 1584 }
1485 } 1585 }
1486 }; 1586 };
1487} 1587}
1488 1588
… …
1646 my $name = $pl->ob->name; 1746 my $name = $pl->ob->name;
1647 1747
1648 $pl->{deny_save} = 1; 1748 $pl->{deny_save} = 1;
1649 $pl->password ("*"); # this should lock out the player until we have nuked the dir 1749 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1650 1750
1651 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1751 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->ns;
1652 $pl->deactivate; 1752 $pl->deactivate;
1753
1653 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy; 1754 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1654 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1755 $pl->invoke (cf::EVENT_PLAYER_QUIT) if $pl->ns;
1756 ext::highscore::check ($pl->ob);
1757
1655 $pl->ns->destroy if $pl->ns; 1758 $pl->ns->destroy if $pl->ns;
1656 1759
1657 my $path = playerdir $pl; 1760 my $path = playerdir $pl;
1658 my $temp = "$path~$cf::RUNTIME~deleting~"; 1761 my $temp = "$path~$cf::RUNTIME~deleting~";
1659 aio_rename $path, $temp; 1762 aio_rename $path, $temp;
… …
1825sub generate_random_map { 1928sub generate_random_map {
1826 my ($self, $rmp) = @_; 1929 my ($self, $rmp) = @_;
1827 1930
1828 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM 1931 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1829 1932
1830 # mit "rum" bekleckern, nicht
1831 $self->_create_random_map ( 1933 $self->_create_random_map ($rmp);
1832 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1833 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, $rmp->{miningstyle},
1834 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1835 $rmp->{exit_on_final_map},
1836 $rmp->{xsize}, $rmp->{ysize},
1837 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1838 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1839 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1840 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1841 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1842 (cf::region::find $rmp->{region}), $rmp->{custom}
1843 )
1844} 1934}
1845 1935
1846=item cf::map->register ($regex, $prio) 1936=item cf::map->register ($regex, $prio)
1847 1937
1848Register a handler for the map path matching the given regex at the 1938Register a handler for the map path matching the given regex at the
… …
1899 $base =~ s{[^/]+/?$}{}; 1989 $base =~ s{[^/]+/?$}{};
1900 $path = "$base/$path"; 1990 $path = "$base/$path";
1901 } 1991 }
1902 1992
1903 for ($path) { 1993 for ($path) {
1904 redo if s{//}{/};
1905 redo if s{/\.?/}{/}; 1994 redo if s{/\.?/}{/};
1906 redo if s{/[^/]+/\.\./}{/}; 1995 redo if s{/[^/]+/\.\./}{/};
1907 } 1996 }
1908 1997
1909 $path 1998 $path
… …
1927 2016
1928 Carp::cluck "unable to resolve path '$path' (base '$base')"; 2017 Carp::cluck "unable to resolve path '$path' (base '$base')";
1929 () 2018 ()
1930} 2019}
1931 2020
2021# may re-bless or do other evil things
1932sub init { 2022sub init {
1933 my ($self) = @_; 2023 my ($self) = @_;
1934 2024
1935 $self 2025 $self
1936} 2026}
… …
2001 $self->{load_path} = $path; 2091 $self->{load_path} = $path;
2002 2092
2003 1 2093 1
2004} 2094}
2005 2095
2096# used to laod the header of an original map
2006sub load_header_orig { 2097sub load_header_orig {
2007 my ($self) = @_; 2098 my ($self) = @_;
2008 2099
2009 $self->load_header_from ($self->load_path) 2100 $self->load_header_from ($self->load_path)
2010} 2101}
2011 2102
2103# used to laod the header of an instantiated map
2012sub load_header_temp { 2104sub load_header_temp {
2013 my ($self) = @_; 2105 my ($self) = @_;
2014 2106
2015 $self->load_header_from ($self->save_path) 2107 $self->load_header_from ($self->save_path)
2016} 2108}
2017 2109
2110# called after loading the header from an instantiated map
2018sub prepare_temp { 2111sub prepare_temp {
2019 my ($self) = @_; 2112 my ($self) = @_;
2020 2113
2021 $self->last_access ((delete $self->{last_access}) 2114 $self->last_access ((delete $self->{last_access})
2022 || $cf::RUNTIME); #d# 2115 || $cf::RUNTIME); #d#
2023 # safety 2116 # safety
2024 $self->{instantiate_time} = $cf::RUNTIME 2117 $self->{instantiate_time} = $cf::RUNTIME
2025 if $self->{instantiate_time} > $cf::RUNTIME; 2118 if $self->{instantiate_time} > $cf::RUNTIME;
2026} 2119}
2027 2120
2121# called after loading the header from an original map
2028sub prepare_orig { 2122sub prepare_orig {
2029 my ($self) = @_; 2123 my ($self) = @_;
2030 2124
2031 $self->{load_original} = 1; 2125 $self->{load_original} = 1;
2032 $self->{instantiate_time} = $cf::RUNTIME; 2126 $self->{instantiate_time} = $cf::RUNTIME;
… …
2058sub find { 2152sub find {
2059 my ($path, $origin) = @_; 2153 my ($path, $origin) = @_;
2060 2154
2061 cf::cede_to_tick; 2155 cf::cede_to_tick;
2062 2156
2063 $path = normalise $path, $origin && $origin->path; 2157 $path = normalise $path, $origin;
2064 2158
2065 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove 2159 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
2066 my $guard2 = cf::lock_acquire "map_find:$path"; 2160 my $guard2 = cf::lock_acquire "map_find:$path";
2067 2161
2068 $cf::MAP{$path} || do { 2162 $cf::MAP{$path} || do {
… …
2099 2193
2100 { 2194 {
2101 my $guard = cf::lock_acquire "map_data:$path"; 2195 my $guard = cf::lock_acquire "map_data:$path";
2102 2196
2103 return unless $self->valid; 2197 return unless $self->valid;
2104 return unless $self->in_memory == cf::MAP_SWAPPED; 2198 return unless $self->state == cf::MAP_SWAPPED;
2105
2106 $self->in_memory (cf::MAP_LOADING);
2107 2199
2108 $self->alloc; 2200 $self->alloc;
2109 2201
2110 $self->pre_load; 2202 $self->pre_load;
2111 cf::cede_to_tick; 2203 cf::cede_to_tick;
2112 2204
2205 if (exists $self->{load_path}) {
2113 my $f = new_from_file cf::object::thawer $self->{load_path}; 2206 my $f = new_from_file cf::object::thawer $self->{load_path};
2114 $f->skip_block; 2207 $f->skip_block;
2115 $self->_load_objects ($f) 2208 $self->_load_objects ($f)
2116 or return; 2209 or return;
2117 2210
2118 $self->post_load_original 2211 $self->post_load_original
2119 if delete $self->{load_original}; 2212 if delete $self->{load_original};
2120 2213
2121 if (my $uniq = $self->uniq_path) { 2214 if (my $uniq = $self->uniq_path) {
2122 utf8::encode $uniq; 2215 utf8::encode $uniq;
2123 unless (aio_stat $uniq) { 2216 unless (aio_stat $uniq) {
2124 if (my $f = new_from_file cf::object::thawer $uniq) { 2217 if (my $f = new_from_file cf::object::thawer $uniq) {
2125 $self->clear_unique_items; 2218 $self->clear_unique_items;
2126 $self->_load_objects ($f); 2219 $self->_load_objects ($f);
2127 $f->resolve_delayed_derefs; 2220 $f->resolve_delayed_derefs;
2221 }
2128 } 2222 }
2129 } 2223 }
2130 }
2131 2224
2132 $f->resolve_delayed_derefs; 2225 $f->resolve_delayed_derefs;
2226 } else {
2227 $self->post_load_original
2228 if delete $self->{load_original};
2229 }
2230
2231 $self->state (cf::MAP_INACTIVE);
2133 2232
2134 cf::cede_to_tick; 2233 cf::cede_to_tick;
2135 # now do the right thing for maps 2234 # now do the right thing for maps
2136 $self->link_multipart_objects; 2235 $self->link_multipart_objects;
2137 $self->difficulty ($self->estimate_difficulty) 2236 $self->difficulty ($self->estimate_difficulty)
… …
2141 unless ($self->{deny_activate}) { 2240 unless ($self->{deny_activate}) {
2142 $self->decay_objects; 2241 $self->decay_objects;
2143 $self->fix_auto_apply; 2242 $self->fix_auto_apply;
2144 $self->update_buttons; 2243 $self->update_buttons;
2145 cf::cede_to_tick; 2244 cf::cede_to_tick;
2146 $self->activate; 2245 #$self->activate; # no longer activate maps automatically
2147 } 2246 }
2148 2247
2149 $self->{last_save} = $cf::RUNTIME; 2248 $self->{last_save} = $cf::RUNTIME;
2150 $self->last_access ($cf::RUNTIME); 2249 $self->last_access ($cf::RUNTIME);
2151
2152 $self->in_memory (cf::MAP_ACTIVE);
2153 } 2250 }
2154 2251
2155 $self->post_load; 2252 $self->post_load;
2253
2254 1
2156} 2255}
2157 2256
2158# customize the map for a given player, i.e. 2257# customize the map for a given player, i.e.
2159# return the _real_ map. used by e.g. per-player 2258# return the _real_ map. used by e.g. per-player
2160# maps to change the path to ~playername/mappath 2259# maps to change the path to ~playername/mappath
… …
2168# if $self->per_party; 2267# if $self->per_party;
2169 2268
2170 $self 2269 $self
2171} 2270}
2172 2271
2173# find and load all maps in the 3x3 area around a map
2174sub load_neighbours {
2175 my ($map) = @_;
2176
2177 my @neigh; # diagonal neighbours
2178
2179 for (0 .. 3) {
2180 my $neigh = $map->tile_path ($_)
2181 or next;
2182 $neigh = find $neigh, $map
2183 or next;
2184 $neigh->load;
2185
2186 # now find the diagonal neighbours
2187 push @neigh,
2188 [$neigh->tile_path (($_ + 3) % 4), $neigh],
2189 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2190 }
2191
2192 for (grep defined $_->[0], @neigh) {
2193 my ($path, $origin) = @$_;
2194 my $neigh = find $path, $origin
2195 or next;
2196 $neigh->load;
2197 }
2198}
2199
2200sub find_sync { 2272sub find_sync {
2201 my ($path, $origin) = @_; 2273 my ($path, $origin) = @_;
2202 2274
2275 # it's a bug to call this from the main context
2203 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync" 2276 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync"
2204 if $Coro::current == $Coro::main; 2277 if $Coro::current == $Coro::main;
2205 2278
2206 find $path, $origin 2279 find $path, $origin
2207} 2280}
2208 2281
2209sub do_load_sync { 2282sub do_load_sync {
2210 my ($map) = @_; 2283 my ($map) = @_;
2211 2284
2285 # it's a bug to call this from the main context
2212 return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync" 2286 return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync"
2213 if $Coro::current == $Coro::main; 2287 if $Coro::current == $Coro::main;
2214 2288
2215 $map->load; 2289 $map->load;
2216} 2290}
… …
2219our $MAP_PREFETCHER = undef; 2293our $MAP_PREFETCHER = undef;
2220 2294
2221sub find_async { 2295sub find_async {
2222 my ($path, $origin, $load) = @_; 2296 my ($path, $origin, $load) = @_;
2223 2297
2224 $path = normalise $path, $origin && $origin->{path}; 2298 $path = normalise $path, $origin;
2225 2299
2226 if (my $map = $cf::MAP{$path}) { 2300 if (my $map = $cf::MAP{$path}) {
2227 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE; 2301 return $map if !$load || $map->linkable;
2228 } 2302 }
2229 2303
2230 $MAP_PREFETCH{$path} |= $load; 2304 $MAP_PREFETCH{$path} |= $load;
2231 2305
2232 $MAP_PREFETCHER ||= cf::async { 2306 $MAP_PREFETCHER ||= cf::async {
… …
2291sub swap_out { 2365sub swap_out {
2292 my ($self) = @_; 2366 my ($self) = @_;
2293 2367
2294 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2368 my $lock = cf::lock_acquire "map_data:$self->{path}";
2295 2369
2296 return if $self->in_memory != cf::MAP_ACTIVE; 2370 return if !$self->linkable;
2297 return if $self->{deny_save}; 2371 return if $self->{deny_save};
2298 return if $self->players; 2372 return if $self->players;
2299 2373
2300 # first deactivate the map and "unlink" it from the core 2374 # first deactivate the map and "unlink" it from the core
2301 $self->deactivate; 2375 $self->deactivate;
2302 $_->clear_links_to ($self) for values %cf::MAP; 2376 $_->clear_links_to ($self) for values %cf::MAP;
2303 $self->in_memory (cf::MAP_SWAPPED); 2377 $self->state (cf::MAP_SWAPPED);
2304 2378
2305 # then atomically save 2379 # then atomically save
2306 $self->_save; 2380 $self->_save;
2307 2381
2308 # then free the map 2382 # then free the map
… …
2334 2408
2335 return if $self->players; 2409 return if $self->players;
2336 2410
2337 cf::trace "resetting map ", $self->path, "\n"; 2411 cf::trace "resetting map ", $self->path, "\n";
2338 2412
2339 $self->in_memory (cf::MAP_SWAPPED); 2413 $self->state (cf::MAP_SWAPPED);
2340 2414
2341 # need to save uniques path 2415 # need to save uniques path
2342 unless ($self->{deny_save}) { 2416 unless ($self->{deny_save}) {
2343 my $uniq = $self->uniq_path; utf8::encode $uniq; 2417 my $uniq = $self->uniq_path; utf8::encode $uniq;
2344 2418
… …
2674 # use -1 or undef as default coordinates, not 0, 0 2748 # use -1 or undef as default coordinates, not 0, 0
2675 ($x, $y) = ($map->enter_x, $map->enter_y) 2749 ($x, $y) = ($map->enter_x, $map->enter_y)
2676 if $x <= 0 && $y <= 0; 2750 if $x <= 0 && $y <= 0;
2677 2751
2678 $map->load; 2752 $map->load;
2679 $map->load_neighbours;
2680 2753
2681 return unless $self->contr->active; 2754 return unless $self->contr->active;
2682 2755
2683 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2756 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2684 if ($self->enter_map ($map, $x, $y)) { 2757 if ($self->enter_map ($map, $x, $y)) {
… …
2740 ($path, $x, $y) = (undef, undef, undef); 2813 ($path, $x, $y) = (undef, undef, undef);
2741 } 2814 }
2742 } 2815 }
2743 2816
2744 my $map = eval { 2817 my $map = eval {
2745 my $map = defined $path ? cf::map::find $path : undef; 2818 my $map = defined $path ? cf::map::find $path, $self->map : undef;
2746 2819
2747 if ($map) { 2820 if ($map) {
2748 $map = $map->customise_for ($self); 2821 $map = $map->customise_for ($self);
2749 $map = $check->($map, $x, $y, $self) if $check && $map; 2822 $map = $check->($map, $x, $y, $self) if $check && $map;
2750 } else { 2823 } else {
… …
2840 $Coro::current->{desc} = "enter_exit"; 2913 $Coro::current->{desc} = "enter_exit";
2841 2914
2842 unless (eval { 2915 unless (eval {
2843 $self->deactivate_recursive; # just to be sure 2916 $self->deactivate_recursive; # just to be sure
2844 2917
2845 # random map handling
2846 {
2847 my $guard = cf::lock_acquire "exit_prepare:$exit";
2848
2849 prepare_random_map $exit
2850 if $exit->slaying eq "/!";
2851 }
2852
2853 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path; 2918 my $map = cf::map::normalise $exit->slaying, $exit->map;
2854 my $x = $exit->stats->hp; 2919 my $x = $exit->stats->hp;
2855 my $y = $exit->stats->sp; 2920 my $y = $exit->stats->sp;
2921
2922 # special map handling
2923 my $slaying = $exit->slaying;
2924
2925 # special map handling
2926 if ($slaying eq "/!") {
2927 my $guard = cf::lock_acquire "exit_prepare:$exit";
2928
2929 prepare_random_map $exit
2930 if $exit->slaying eq "/!"; # need to re-check after getting the lock
2931
2932 $map = $exit->slaying;
2933
2934 } elsif ($slaying eq '!up') {
2935 $map = $exit->map->tile_path (cf::TILE_UP);
2936 $x = $exit->x;
2937 $y = $exit->y;
2938
2939 } elsif ($slaying eq '!down') {
2940 $map = $exit->map->tile_path (cf::TILE_DOWN);
2941 $x = $exit->x;
2942 $y = $exit->y;
2943 }
2856 2944
2857 $self->goto ($map, $x, $y); 2945 $self->goto ($map, $x, $y);
2858 2946
2859 # if exit is damned, update players death & WoR home-position 2947 # if exit is damned, update players death & WoR home-position
2860 $self->contr->savebed ($map, $x, $y) 2948 $self->contr->savebed ($map, $x, $y)
… …
3375 3463
3376 my $enc = JSON::XS->new->utf8->canonical->relaxed; 3464 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3377 3465
3378 trace "loading facedata from $path\n"; 3466 trace "loading facedata from $path\n";
3379 3467
3380 0 < aio_load $path, my $facedata 3468 my $facedata = decode_storable load_file $path;
3381 or die "$path: $!";
3382
3383 $facedata = Coro::Storable::thaw $facedata;
3384 3469
3385 $facedata->{version} == 2 3470 $facedata->{version} == 2
3386 or cf::cleanup "$path: version mismatch, cannot proceed."; 3471 or cf::cleanup "$path: version mismatch, cannot proceed.";
3387 3472
3388 # patch in the exptable 3473 # patch in the exptable
… …
3402 3487
3403 cf::face::set_visibility $idx, $info->{visibility}; 3488 cf::face::set_visibility $idx, $info->{visibility};
3404 cf::face::set_magicmap $idx, $info->{magicmap}; 3489 cf::face::set_magicmap $idx, $info->{magicmap};
3405 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32}; 3490 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3406 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64}; 3491 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3492 cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph} ;
3407 3493
3408 cf::cede_to_tick; 3494 cf::cede_to_tick;
3409 } 3495 }
3410 3496
3411 while (my ($face, $info) = each %$faces) { 3497 while (my ($face, $info) = each %$faces) {
… …
3506} 3592}
3507 3593
3508sub reload_sound { 3594sub reload_sound {
3509 trace "loading sound config from $DATADIR/sound\n"; 3595 trace "loading sound config from $DATADIR/sound\n";
3510 3596
3511 0 < Coro::AIO::aio_load "$DATADIR/sound", my $data
3512 or die "$DATADIR/sound $!";
3513
3514 my $soundconf = JSON::XS->new->utf8->relaxed->decode ($data); 3597 my $soundconf = JSON::XS->new->utf8->relaxed->decode (load_file "$DATADIR/sound");
3515 3598
3516 for (0 .. SOUND_CAST_SPELL_0 - 1) { 3599 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3517 my $sound = $soundconf->{compat}[$_] 3600 my $sound = $soundconf->{compat}[$_]
3518 or next; 3601 or next;
3519 3602
… …
3543} 3626}
3544 3627
3545sub reload_config { 3628sub reload_config {
3546 trace "reloading config file...\n"; 3629 trace "reloading config file...\n";
3547 3630
3548 0 < aio_load "$CONFDIR/config", my $config 3631 my $config = load_file "$CONFDIR/config";
3549 or die "$CONFDIR/config: $!";
3550
3551 utf8::decode $config; 3632 utf8::decode $config;
3552 3633 *CFG = decode_yaml $config;
3553 cf::get_slot 0.1, 10, "reload_config"; # yaml might be slow...
3554 *CFG = YAML::XS::Load $config;
3555 3634
3556 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38]; 3635 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3557 3636
3558 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3637 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3559 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3638 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
… …
3597 3676
3598sub main { 3677sub main {
3599 cf::init_globals; # initialise logging 3678 cf::init_globals; # initialise logging
3600 3679
3601 LOG llevInfo, "Welcome to Deliantra, v" . VERSION; 3680 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3602 LOG llevInfo, "Copyright (C) 2005-2010 Marc Alexander Lehmann / Robin Redeker / the Deliantra team."; 3681 LOG llevInfo, "Copyright (C) 2005-2011 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3603 LOG llevInfo, "Copyright (C) 1994 Mark Wedel."; 3682 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3604 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen."; 3683 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3605 3684
3606 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3685 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3607 3686
… …
3643 3722
3644 # no (long-running) fork's whatsoever before this point(!) 3723 # no (long-running) fork's whatsoever before this point(!)
3645 use POSIX (); 3724 use POSIX ();
3646 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD}; 3725 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3647 3726
3648 (pop @POST_INIT)->(0) while @POST_INIT; 3727 cf::_post_init 0;
3649 }; 3728 };
3650 3729
3651 cf::object::thawer::errors_are_fatal 0; 3730 cf::object::thawer::errors_are_fatal 0;
3652 info "parse errors in files are no longer fatal from this point on.\n"; 3731 info "parse errors in files are no longer fatal from this point on.\n";
3653 3732
… …
3876 3955
3877 my $t1 = AE::time; 3956 my $t1 = AE::time;
3878 3957
3879 while ($RELOAD) { 3958 while ($RELOAD) {
3880 cf::get_slot 0.1, -1, "reload_perl"; 3959 cf::get_slot 0.1, -1, "reload_perl";
3881 info "reloading..."; 3960 info "perl_reload: reloading...";
3882 3961
3883 trace "entering sync_job"; 3962 trace "perl_reload: entering sync_job";
3884 3963
3885 cf::sync_job { 3964 cf::sync_job {
3886 #cf::emergency_save; 3965 #cf::emergency_save;
3887 3966
3888 trace "cancelling all extension coros"; 3967 trace "perl_reload: cancelling all extension coros";
3889 $_->cancel for values %EXT_CORO; 3968 $_->cancel for values %EXT_CORO;
3890 %EXT_CORO = (); 3969 %EXT_CORO = ();
3891 3970
3892 trace "removing commands"; 3971 trace "perl_reload: removing commands";
3893 %COMMAND = (); 3972 %COMMAND = ();
3894 3973
3895 trace "removing ext/exti commands"; 3974 trace "perl_reload: removing ext/exti commands";
3896 %EXTCMD = (); 3975 %EXTCMD = ();
3897 %EXTICMD = (); 3976 %EXTICMD = ();
3898 3977
3899 trace "unloading/nuking all extensions"; 3978 trace "perl_reload: unloading/nuking all extensions";
3900 for my $pkg (@EXTS) { 3979 for my $pkg (@EXTS) {
3901 trace "... unloading $pkg"; 3980 trace "... unloading $pkg";
3902 3981
3903 if (my $cb = $pkg->can ("unload")) { 3982 if (my $cb = $pkg->can ("unload")) {
3904 eval { 3983 eval {
… …
3909 3988
3910 trace "... clearing $pkg"; 3989 trace "... clearing $pkg";
3911 clear_package $pkg; 3990 clear_package $pkg;
3912 } 3991 }
3913 3992
3914 trace "unloading all perl modules loaded from $LIBDIR"; 3993 trace "perl_reload: unloading all perl modules loaded from $LIBDIR";
3915 while (my ($k, $v) = each %INC) { 3994 while (my ($k, $v) = each %INC) {
3916 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 3995 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3917 3996
3918 trace "... unloading $k"; 3997 trace "... unloading $k";
3919 delete $INC{$k}; 3998 delete $INC{$k};
… …
3926 } 4005 }
3927 4006
3928 clear_package $k; 4007 clear_package $k;
3929 } 4008 }
3930 4009
3931 trace "getting rid of safe::, as good as possible"; 4010 trace "perl_reload: getting rid of safe::, as good as possible";
3932 clear_package "safe::$_" 4011 clear_package "safe::$_"
3933 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 4012 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3934 4013
3935 trace "unloading cf.pm \"a bit\""; 4014 trace "perl_reload: unloading cf.pm \"a bit\"";
3936 delete $INC{"cf.pm"}; 4015 delete $INC{"cf.pm"};
3937 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES; 4016 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3938 4017
3939 # don't, removes xs symbols, too, 4018 # don't, removes xs symbols, too,
3940 # and global variables created in xs 4019 # and global variables created in xs
3941 #clear_package __PACKAGE__; 4020 #clear_package __PACKAGE__;
3942 4021
3943 info "unload completed, starting to reload now"; 4022 info "perl_reload: unload completed, starting to reload now";
3944 4023
3945 trace "reloading cf.pm"; 4024 trace "perl_reload: reloading cf.pm";
3946 require cf; 4025 require cf;
3947 cf::_connect_to_perl_1; 4026 cf::_connect_to_perl_1;
3948 4027
3949 trace "loading config and database again"; 4028 trace "perl_reload: loading config and database again";
3950 cf::reload_config; 4029 cf::reload_config;
3951 4030
3952 trace "loading extensions"; 4031 trace "perl_reload: loading extensions";
3953 cf::load_extensions; 4032 cf::load_extensions;
3954 4033
3955 if ($REATTACH_ON_RELOAD) { 4034 if ($REATTACH_ON_RELOAD) {
3956 trace "reattaching attachments to objects/players"; 4035 trace "perl_reload: reattaching attachments to objects/players";
3957 _global_reattach; # objects, sockets 4036 _global_reattach; # objects, sockets
3958 trace "reattaching attachments to maps"; 4037 trace "perl_reload: reattaching attachments to maps";
3959 reattach $_ for values %MAP; 4038 reattach $_ for values %MAP;
3960 trace "reattaching attachments to players"; 4039 trace "perl_reload: reattaching attachments to players";
3961 reattach $_ for values %PLAYER; 4040 reattach $_ for values %PLAYER;
3962 } 4041 }
3963 4042
3964 trace "running post_init jobs"; 4043 cf::_post_init 1;
3965 (pop @POST_INIT)->(1) while @POST_INIT;
3966 4044
3967 trace "leaving sync_job"; 4045 trace "perl_reload: leaving sync_job";
3968 4046
3969 1 4047 1
3970 } or do { 4048 } or do {
3971 error $@; 4049 error $@;
3972 cf::cleanup "error while reloading, exiting."; 4050 cf::cleanup "perl_reload: error, exiting.";
3973 }; 4051 };
3974 4052
3975 info "reloaded";
3976 --$RELOAD; 4053 --$RELOAD;
3977 } 4054 }
3978 4055
3979 $t1 = AE::time - $t1; 4056 $t1 = AE::time - $t1;
3980 info "reload completed in ${t1}s\n"; 4057 info "perl_reload: completed in ${t1}s\n";
3981}; 4058};
3982 4059
3983our $RELOAD_WATCHER; # used only during reload 4060our $RELOAD_WATCHER; # used only during reload
3984 4061
3985sub reload_perl() { 4062sub reload_perl() {
… …
4010 4087
4011############################################################################# 4088#############################################################################
4012 4089
4013my $bug_warning = 0; 4090my $bug_warning = 0;
4014 4091
4015our @WAIT_FOR_TICK;
4016our @WAIT_FOR_TICK_BEGIN;
4017
4018sub wait_for_tick() { 4092sub wait_for_tick() {
4019 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main; 4093 return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
4020 4094
4021 my $signal = new Coro::Signal; 4095 $WAIT_FOR_TICK->wait;
4022 push @WAIT_FOR_TICK, $signal;
4023 $signal->wait;
4024} 4096}
4025 4097
4026sub wait_for_tick_begin() { 4098sub wait_for_tick_begin() {
4027 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main; 4099 return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
4028 4100
4029 my $signal = new Coro::Signal; 4101 my $signal = new Coro::Signal;
4030 push @WAIT_FOR_TICK_BEGIN, $signal; 4102 push @WAIT_FOR_TICK_BEGIN, $signal;
4031 $signal->wait; 4103 $signal->wait;
4032} 4104}
… …
4036 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 4108 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
4037 unless ++$bug_warning > 10; 4109 unless ++$bug_warning > 10;
4038 return; 4110 return;
4039 } 4111 }
4040 4112
4041 cf::server_tick; # one server iteration 4113 cf::one_tick; # one server iteration
4042 4114
4043 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d# 4115 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
4044 4116
4045 if ($NOW >= $NEXT_RUNTIME_WRITE) { 4117 if ($NOW >= $NEXT_RUNTIME_WRITE) {
4046 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.; 4118 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
… …
4052 } 4124 }
4053 4125
4054 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 4126 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
4055 $sig->send; 4127 $sig->send;
4056 } 4128 }
4057 while (my $sig = shift @WAIT_FOR_TICK) { 4129 $WAIT_FOR_TICK->broadcast;
4058 $sig->send;
4059 }
4060 4130
4061 $LOAD = ($NOW - $TICK_START) / $TICK; 4131 $LOAD = ($NOW - $TICK_START) / $TICK;
4062 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 4132 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
4063 4133
4064 if (0) { 4134 if (0) {
… …
4118 IO::AIO::min_parallel 8; 4188 IO::AIO::min_parallel 8;
4119 IO::AIO::max_poll_time $TICK * 0.1; 4189 IO::AIO::max_poll_time $TICK * 0.1;
4120 undef $AnyEvent::AIO::WATCHER; 4190 undef $AnyEvent::AIO::WATCHER;
4121} 4191}
4122 4192
4123my $_log_backtrace; 4193our $_log_backtrace;
4194our $_log_backtrace_last;
4124 4195
4125sub _log_backtrace { 4196sub _log_backtrace {
4126 my ($msg, @addr) = @_; 4197 my ($msg, @addr) = @_;
4127 4198
4128 $msg =~ s/\n//; 4199 $msg =~ s/\n$//;
4129 4200
4201 if ($_log_backtrace_last eq $msg) {
4202 LOG llevInfo, "[ABT] $msg\n";
4203 LOG llevInfo, "[ABT] [duplicate, suppressed]\n";
4130 # limit the # of concurrent backtraces 4204 # limit the # of concurrent backtraces
4131 if ($_log_backtrace < 2) { 4205 } elsif ($_log_backtrace < 2) {
4206 $_log_backtrace_last = $msg;
4132 ++$_log_backtrace; 4207 ++$_log_backtrace;
4133 my $perl_bt = Carp::longmess $msg; 4208 my $perl_bt = Carp::longmess $msg;
4134 async { 4209 async {
4135 $Coro::current->{desc} = "abt $msg"; 4210 $Coro::current->{desc} = "abt $msg";
4136 4211
… …
4156 LOG llevInfo, "[ABT] $_\n" for @bt; 4231 LOG llevInfo, "[ABT] $_\n" for @bt;
4157 --$_log_backtrace; 4232 --$_log_backtrace;
4158 }; 4233 };
4159 } else { 4234 } else {
4160 LOG llevInfo, "[ABT] $msg\n"; 4235 LOG llevInfo, "[ABT] $msg\n";
4161 LOG llevInfo, "[ABT] [suppressed]\n"; 4236 LOG llevInfo, "[ABT] [overload, suppressed]\n";
4162 } 4237 }
4163} 4238}
4164 4239
4165# load additional modules 4240# load additional modules
4166require "cf/$_.pm" for @EXTRA_MODULES; 4241require "cf/$_.pm" for @EXTRA_MODULES;

Diff Legend

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