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.538 by root, Tue May 4 21:45:43 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.
… …
20# The authors can be reached via e-mail to <support@deliantra.net> 20# The authors can be reached via e-mail to <support@deliantra.net>
21# 21#
22 22
23package cf; 23package cf;
24 24
25use 5.10.0; 25use common::sense;
26use utf8;
27use strict qw(vars subs);
28 26
29use Symbol; 27use Symbol;
30use List::Util; 28use List::Util;
31use Socket; 29use Socket;
32use EV; 30use EV;
… …
78# strictly for debugging 76# strictly for debugging
79$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" }; 77$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
80 78
81sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 79sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
82 80
81our @ORIG_INC;
82
83our %COMMAND = (); 83our %COMMAND = ();
84our %COMMAND_TIME = (); 84our %COMMAND_TIME = ();
85 85
86our @EXTS = (); # list of extension package names 86our @EXTS = (); # list of extension package names
87our %EXTCMD = (); 87our %EXTCMD = ();
… …
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";
… …
124our $BDB_DEADLOCK_WATCHER; 126our $BDB_DEADLOCK_WATCHER;
125our $BDB_CHECKPOINT_WATCHER; 127our $BDB_CHECKPOINT_WATCHER;
126our $BDB_TRICKLE_WATCHER; 128our $BDB_TRICKLE_WATCHER;
127our $DB_ENV; 129our $DB_ENV;
128 130
129our @EXTRA_MODULES = qw(pod match mapscript); 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.
… …
233from wherever your confdir points to. 246from wherever your confdir points to.
234 247
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 process 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.
265
266=cut
267
268sub wait_for_tick();
269sub wait_for_tick_begin();
240 270
241=item @cf::INVOKE_RESULTS 271=item @cf::INVOKE_RESULTS
242 272
243This array contains the results of the last C<invoke ()> call. When 273This array contains the results of the last C<invoke ()> call. When
244C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of 274C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
… …
307} 337}
308 338
309$EV::DIED = sub { 339$EV::DIED = sub {
310 Carp::cluck "error in event callback: @_"; 340 Carp::cluck "error in event callback: @_";
311}; 341};
342
343#############################################################################
344
345sub fork_call(&@);
346sub get_slot($;$$);
312 347
313############################################################################# 348#############################################################################
314 349
315=head2 UTILITY FUNCTIONS 350=head2 UTILITY FUNCTIONS
316 351
… …
337 $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;
338 $d 373 $d
339 } || "[unable to dump $_[0]: '$@']"; 374 } || "[unable to dump $_[0]: '$@']";
340} 375}
341 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
342=item $ref = cf::decode_json $json 391=item $ref = cf::decode_json $json
343 392
344Converts a JSON string into the corresponding perl data structure. 393Converts a JSON string into the corresponding perl data structure.
345 394
346=item $json = cf::encode_json $ref 395=item $json = cf::encode_json $ref
… …
352our $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
353 402
354sub encode_json($) { $json_coder->encode ($_[0]) } 403sub encode_json($) { $json_coder->encode ($_[0]) }
355sub decode_json($) { $json_coder->decode ($_[0]) } 404sub decode_json($) { $json_coder->decode ($_[0]) }
356 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
357=item cf::post_init { BLOCK } 437=item cf::post_init { BLOCK }
358 438
359Execute the given codeblock, I<after> all extensions have been (re-)loaded, 439Execute the given codeblock, I<after> all extensions have been (re-)loaded,
360but I<before> the server starts ticking again. 440but I<before> the server starts ticking again.
361 441
362The cdoeblock will have a single boolean argument to indicate whether this 442The codeblock will have a single boolean argument to indicate whether this
363is a reload or not. 443is a reload or not.
364 444
365=cut 445=cut
366 446
367sub post_init(&) { 447sub post_init(&) {
368 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 }
369} 466}
370 467
371=item cf::lock_wait $string 468=item cf::lock_wait $string
372 469
373Wait until the given lock is available. See cf::lock_acquire. 470Wait until the given lock is available. See cf::lock_acquire.
… …
426 EV::periodic $start, $interval, 0, $cb 523 EV::periodic $start, $interval, 0, $cb
427} 524}
428 525
429=item cf::get_slot $time[, $priority[, $name]] 526=item cf::get_slot $time[, $priority[, $name]]
430 527
431Allocate $time seconds of blocking CPU time at priority C<$priority>: 528Allocate $time seconds of blocking CPU time at priority C<$priority>
432This 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
433of 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.
434 535
435The 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
436used for statistical purposes and should identify the same time-class. 537used for statistical purposes and should identify the same time-class.
437 538
438Useful for short background jobs. 539Useful for short background jobs.
… …
467 } 568 }
468 } 569 }
469 570
470 if (@SLOT_QUEUE) { 571 if (@SLOT_QUEUE) {
471 # 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
472 push @cf::WAIT_FOR_TICK, $signal; 573 $WAIT_FOR_TICK->wait;
473 $signal->wait;
474 } else { 574 } else {
475 $busy = 0; 575 $busy = 0;
476 Coro::schedule; 576 Coro::schedule;
477 } 577 }
478 } 578 }
… …
578 $EXT_CORO{$coro+0} = $coro; 678 $EXT_CORO{$coro+0} = $coro;
579 679
580 $coro 680 $coro
581} 681}
582 682
583=item fork_call { }, $args 683=item fork_call { }, @args
584 684
585Executes the given code block with the given arguments in a seperate 685Executes the given code block with the given arguments in a seperate
586process, returning the results. Everything must be serialisable with 686process, returning the results. Everything must be serialisable with
587Coro::Storable. May, of course, block. Note that the executed sub may 687Coro::Storable. May, of course, block. Note that the executed sub may
588never block itself or use any form of event handling. 688never block itself or use any form of event handling.
589 689
590=cut 690=cut
591 691
692sub post_fork {
693 reset_signals;
694}
695
592sub fork_call(&@) { 696sub fork_call(&@) {
593 my ($cb, @args) = @_; 697 my ($cb, @args) = @_;
594 698
595 # 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,
596 # otherwise perl prematurely frees the stuff :/ 700 # otherwise perl prematurely frees the stuff :/
597 # TODO: investigate and fix (likely this will be rather laborious) 701 # TODO: investigate and fix (likely this will be rather laborious)
598 702
599 my @res = Coro::Util::fork_eval { 703 my @res = Coro::Util::fork_eval {
600 reset_signals; 704 cf::post_fork;
601 &$cb 705 &$cb
602 }, @args; 706 } @args;
603 707
604 wantarray ? @res : $res[-1] 708 wantarray ? @res : $res[-1]
605} 709}
606 710
607sub objinfo { 711sub objinfo {
… …
729 833
730 my @data; 834 my @data;
731 my $md5; 835 my $md5;
732 836
733 for (0 .. $#$src) { 837 for (0 .. $#$src) {
734 0 <= aio_load $src->[$_], $data[$_] 838 $data[$_] = load_file $src->[$_];
735 or Carp::croak "$src->[$_]: $!";
736 } 839 }
737 840
738 # if processing is expensive, check 841 # if processing is expensive, check
739 # checksum first 842 # checksum first
740 if (1) { 843 if (1) {
… …
1451 1554
1452 my $active = eval $v->{source}; 1555 my $active = eval $v->{source};
1453 1556
1454 if (length $@) { 1557 if (length $@) {
1455 error "$v->{path}: $@\n"; 1558 error "$v->{path}: $@\n";
1456 undef $@; # work around perl 5.10.0 utf-8 caching bug
1457 1559
1458 cf::cleanup "mandatory extension '$k' failed to load, exiting." 1560 cf::cleanup "mandatory extension '$k' failed to load, exiting."
1459 if exists $v->{meta}{mandatory}; 1561 if exists $v->{meta}{mandatory};
1460 1562
1461 warn "$v->{base}: optional extension cannot be loaded, skipping.\n"; 1563 warn "$v->{base}: optional extension cannot be loaded, skipping.\n";
… …
1475 1577
1476 while (my ($k, $v) = each %todo) { 1578 while (my ($k, $v) = each %todo) {
1477 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting." 1579 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
1478 if exists $v->{meta}{mandatory}; 1580 if exists $v->{meta}{mandatory};
1479 } 1581 }
1582
1583 last;
1480 } 1584 }
1481 } 1585 }
1482 }; 1586 };
1483} 1587}
1484 1588
… …
1642 my $name = $pl->ob->name; 1746 my $name = $pl->ob->name;
1643 1747
1644 $pl->{deny_save} = 1; 1748 $pl->{deny_save} = 1;
1645 $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
1646 1750
1647 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1751 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->ns;
1648 $pl->deactivate; 1752 $pl->deactivate;
1753
1649 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;
1650 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1755 $pl->invoke (cf::EVENT_PLAYER_QUIT) if $pl->ns;
1756 ext::highscore::check ($pl->ob);
1757
1651 $pl->ns->destroy if $pl->ns; 1758 $pl->ns->destroy if $pl->ns;
1652 1759
1653 my $path = playerdir $pl; 1760 my $path = playerdir $pl;
1654 my $temp = "$path~$cf::RUNTIME~deleting~"; 1761 my $temp = "$path~$cf::RUNTIME~deleting~";
1655 aio_rename $path, $temp; 1762 aio_rename $path, $temp;
… …
1821sub generate_random_map { 1928sub generate_random_map {
1822 my ($self, $rmp) = @_; 1929 my ($self, $rmp) = @_;
1823 1930
1824 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
1825 1932
1826 # mit "rum" bekleckern, nicht
1827 $self->_create_random_map ( 1933 $self->_create_random_map ($rmp);
1828 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1829 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, $rmp->{miningstyle},
1830 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1831 $rmp->{exit_on_final_map},
1832 $rmp->{xsize}, $rmp->{ysize},
1833 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1834 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1835 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1836 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1837 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1838 (cf::region::find $rmp->{region}), $rmp->{custom}
1839 )
1840} 1934}
1841 1935
1842=item cf::map->register ($regex, $prio) 1936=item cf::map->register ($regex, $prio)
1843 1937
1844Register 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
… …
1849 1943
1850sub register { 1944sub register {
1851 my (undef, $regex, $prio) = @_; 1945 my (undef, $regex, $prio) = @_;
1852 my $pkg = caller; 1946 my $pkg = caller;
1853 1947
1854 no strict;
1855 push @{"$pkg\::ISA"}, __PACKAGE__; 1948 push @{"$pkg\::ISA"}, __PACKAGE__;
1856 1949
1857 $EXT_MAP{$pkg} = [$prio, qr<$regex>]; 1950 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1858} 1951}
1859 1952
… …
1871} 1964}
1872 1965
1873sub normalise { 1966sub normalise {
1874 my ($path, $base) = @_; 1967 my ($path, $base) = @_;
1875 1968
1876 $path = "$path"; # make sure its a string 1969 $path = "$path"; # make sure it's a string
1877 1970
1878 $path =~ s/\.map$//; 1971 $path =~ s/\.map$//;
1879 1972
1880 # map plan: 1973 # map plan:
1881 # 1974 #
… …
1896 $base =~ s{[^/]+/?$}{}; 1989 $base =~ s{[^/]+/?$}{};
1897 $path = "$base/$path"; 1990 $path = "$base/$path";
1898 } 1991 }
1899 1992
1900 for ($path) { 1993 for ($path) {
1901 redo if s{//}{/};
1902 redo if s{/\.?/}{/}; 1994 redo if s{/\.?/}{/};
1903 redo if s{/[^/]+/\.\./}{/}; 1995 redo if s{/[^/]+/\.\./}{/};
1904 } 1996 }
1905 1997
1906 $path 1998 $path
… …
1920 $self->init; # pass $1 etc. 2012 $self->init; # pass $1 etc.
1921 return $self; 2013 return $self;
1922 } 2014 }
1923 } 2015 }
1924 2016
1925 Carp::cluck "unable to resolve path '$path' (base '$base')."; 2017 Carp::cluck "unable to resolve path '$path' (base '$base')";
1926 () 2018 ()
1927} 2019}
1928 2020
2021# may re-bless or do other evil things
1929sub init { 2022sub init {
1930 my ($self) = @_; 2023 my ($self) = @_;
1931 2024
1932 $self 2025 $self
1933} 2026}
… …
1998 $self->{load_path} = $path; 2091 $self->{load_path} = $path;
1999 2092
2000 1 2093 1
2001} 2094}
2002 2095
2096# used to laod the header of an original map
2003sub load_header_orig { 2097sub load_header_orig {
2004 my ($self) = @_; 2098 my ($self) = @_;
2005 2099
2006 $self->load_header_from ($self->load_path) 2100 $self->load_header_from ($self->load_path)
2007} 2101}
2008 2102
2103# used to laod the header of an instantiated map
2009sub load_header_temp { 2104sub load_header_temp {
2010 my ($self) = @_; 2105 my ($self) = @_;
2011 2106
2012 $self->load_header_from ($self->save_path) 2107 $self->load_header_from ($self->save_path)
2013} 2108}
2014 2109
2110# called after loading the header from an instantiated map
2015sub prepare_temp { 2111sub prepare_temp {
2016 my ($self) = @_; 2112 my ($self) = @_;
2017 2113
2018 $self->last_access ((delete $self->{last_access}) 2114 $self->last_access ((delete $self->{last_access})
2019 || $cf::RUNTIME); #d# 2115 || $cf::RUNTIME); #d#
2020 # safety 2116 # safety
2021 $self->{instantiate_time} = $cf::RUNTIME 2117 $self->{instantiate_time} = $cf::RUNTIME
2022 if $self->{instantiate_time} > $cf::RUNTIME; 2118 if $self->{instantiate_time} > $cf::RUNTIME;
2023} 2119}
2024 2120
2121# called after loading the header from an original map
2025sub prepare_orig { 2122sub prepare_orig {
2026 my ($self) = @_; 2123 my ($self) = @_;
2027 2124
2028 $self->{load_original} = 1; 2125 $self->{load_original} = 1;
2029 $self->{instantiate_time} = $cf::RUNTIME; 2126 $self->{instantiate_time} = $cf::RUNTIME;
… …
2053 2150
2054sub find; 2151sub find;
2055sub find { 2152sub find {
2056 my ($path, $origin) = @_; 2153 my ($path, $origin) = @_;
2057 2154
2155 cf::cede_to_tick;
2156
2058 $path = normalise $path, $origin && $origin->path; 2157 $path = normalise $path, $origin;
2059 2158
2060 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove 2159 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
2061 my $guard2 = cf::lock_acquire "map_find:$path"; 2160 my $guard2 = cf::lock_acquire "map_find:$path";
2062 2161
2063 $cf::MAP{$path} || do { 2162 $cf::MAP{$path} || do {
… …
2094 2193
2095 { 2194 {
2096 my $guard = cf::lock_acquire "map_data:$path"; 2195 my $guard = cf::lock_acquire "map_data:$path";
2097 2196
2098 return unless $self->valid; 2197 return unless $self->valid;
2099 return unless $self->in_memory == cf::MAP_SWAPPED; 2198 return unless $self->state == cf::MAP_SWAPPED;
2100
2101 $self->in_memory (cf::MAP_LOADING);
2102 2199
2103 $self->alloc; 2200 $self->alloc;
2104 2201
2105 $self->pre_load; 2202 $self->pre_load;
2106 cf::cede_to_tick; 2203 cf::cede_to_tick;
2107 2204
2205 if (exists $self->{load_path}) {
2108 my $f = new_from_file cf::object::thawer $self->{load_path}; 2206 my $f = new_from_file cf::object::thawer $self->{load_path};
2109 $f->skip_block; 2207 $f->skip_block;
2110 $self->_load_objects ($f) 2208 $self->_load_objects ($f)
2111 or return; 2209 or return;
2112 2210
2113 $self->post_load_original 2211 $self->post_load_original
2114 if delete $self->{load_original}; 2212 if delete $self->{load_original};
2115 2213
2116 if (my $uniq = $self->uniq_path) { 2214 if (my $uniq = $self->uniq_path) {
2117 utf8::encode $uniq; 2215 utf8::encode $uniq;
2118 unless (aio_stat $uniq) { 2216 unless (aio_stat $uniq) {
2119 if (my $f = new_from_file cf::object::thawer $uniq) { 2217 if (my $f = new_from_file cf::object::thawer $uniq) {
2120 $self->clear_unique_items; 2218 $self->clear_unique_items;
2121 $self->_load_objects ($f); 2219 $self->_load_objects ($f);
2122 $f->resolve_delayed_derefs; 2220 $f->resolve_delayed_derefs;
2221 }
2123 } 2222 }
2124 } 2223 }
2125 }
2126 2224
2127 $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);
2128 2232
2129 cf::cede_to_tick; 2233 cf::cede_to_tick;
2130 # now do the right thing for maps 2234 # now do the right thing for maps
2131 $self->link_multipart_objects; 2235 $self->link_multipart_objects;
2132 $self->difficulty ($self->estimate_difficulty) 2236 $self->difficulty ($self->estimate_difficulty)
… …
2136 unless ($self->{deny_activate}) { 2240 unless ($self->{deny_activate}) {
2137 $self->decay_objects; 2241 $self->decay_objects;
2138 $self->fix_auto_apply; 2242 $self->fix_auto_apply;
2139 $self->update_buttons; 2243 $self->update_buttons;
2140 cf::cede_to_tick; 2244 cf::cede_to_tick;
2141 $self->activate; 2245 #$self->activate; # no longer activate maps automatically
2142 } 2246 }
2143 2247
2144 $self->{last_save} = $cf::RUNTIME; 2248 $self->{last_save} = $cf::RUNTIME;
2145 $self->last_access ($cf::RUNTIME); 2249 $self->last_access ($cf::RUNTIME);
2146
2147 $self->in_memory (cf::MAP_ACTIVE);
2148 } 2250 }
2149 2251
2150 $self->post_load; 2252 $self->post_load;
2253
2254 1
2151} 2255}
2152 2256
2153# customize the map for a given player, i.e. 2257# customize the map for a given player, i.e.
2154# return the _real_ map. used by e.g. per-player 2258# return the _real_ map. used by e.g. per-player
2155# maps to change the path to ~playername/mappath 2259# maps to change the path to ~playername/mappath
… …
2163# if $self->per_party; 2267# if $self->per_party;
2164 2268
2165 $self 2269 $self
2166} 2270}
2167 2271
2168# find and load all maps in the 3x3 area around a map
2169sub load_neighbours {
2170 my ($map) = @_;
2171
2172 my @neigh; # diagonal neighbours
2173
2174 for (0 .. 3) {
2175 my $neigh = $map->tile_path ($_)
2176 or next;
2177 $neigh = find $neigh, $map
2178 or next;
2179 $neigh->load;
2180
2181 # now find the diagonal neighbours
2182 push @neigh,
2183 [$neigh->tile_path (($_ + 3) % 4), $neigh],
2184 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2185 }
2186
2187 for (grep defined $_->[0], @neigh) {
2188 my ($path, $origin) = @$_;
2189 my $neigh = find $path, $origin
2190 or next;
2191 $neigh->load;
2192 }
2193}
2194
2195sub find_sync { 2272sub find_sync {
2196 my ($path, $origin) = @_; 2273 my ($path, $origin) = @_;
2197 2274
2275 # it's a bug to call this from the main context
2198 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync" 2276 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync"
2199 if $Coro::current == $Coro::main; 2277 if $Coro::current == $Coro::main;
2200 2278
2201 find $path, $origin 2279 find $path, $origin
2202} 2280}
2203 2281
2204sub do_load_sync { 2282sub do_load_sync {
2205 my ($map) = @_; 2283 my ($map) = @_;
2206 2284
2285 # it's a bug to call this from the main context
2207 return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync" 2286 return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync"
2208 if $Coro::current == $Coro::main; 2287 if $Coro::current == $Coro::main;
2209 2288
2210 $map->load; 2289 $map->load;
2211} 2290}
… …
2214our $MAP_PREFETCHER = undef; 2293our $MAP_PREFETCHER = undef;
2215 2294
2216sub find_async { 2295sub find_async {
2217 my ($path, $origin, $load) = @_; 2296 my ($path, $origin, $load) = @_;
2218 2297
2219 $path = normalise $path, $origin && $origin->{path}; 2298 $path = normalise $path, $origin;
2220 2299
2221 if (my $map = $cf::MAP{$path}) { 2300 if (my $map = $cf::MAP{$path}) {
2222 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE; 2301 return $map if !$load || $map->linkable;
2223 } 2302 }
2224 2303
2225 $MAP_PREFETCH{$path} |= $load; 2304 $MAP_PREFETCH{$path} |= $load;
2226 2305
2227 $MAP_PREFETCHER ||= cf::async { 2306 $MAP_PREFETCHER ||= cf::async {
… …
2286sub swap_out { 2365sub swap_out {
2287 my ($self) = @_; 2366 my ($self) = @_;
2288 2367
2289 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2368 my $lock = cf::lock_acquire "map_data:$self->{path}";
2290 2369
2291 return if $self->in_memory != cf::MAP_ACTIVE; 2370 return if !$self->linkable;
2292 return if $self->{deny_save}; 2371 return if $self->{deny_save};
2293 return if $self->players; 2372 return if $self->players;
2294 2373
2295 # first deactivate the map and "unlink" it from the core 2374 # first deactivate the map and "unlink" it from the core
2296 $self->deactivate; 2375 $self->deactivate;
2297 $_->clear_links_to ($self) for values %cf::MAP; 2376 $_->clear_links_to ($self) for values %cf::MAP;
2298 $self->in_memory (cf::MAP_SWAPPED); 2377 $self->state (cf::MAP_SWAPPED);
2299 2378
2300 # then atomically save 2379 # then atomically save
2301 $self->_save; 2380 $self->_save;
2302 2381
2303 # then free the map 2382 # then free the map
… …
2329 2408
2330 return if $self->players; 2409 return if $self->players;
2331 2410
2332 cf::trace "resetting map ", $self->path, "\n"; 2411 cf::trace "resetting map ", $self->path, "\n";
2333 2412
2334 $self->in_memory (cf::MAP_SWAPPED); 2413 $self->state (cf::MAP_SWAPPED);
2335 2414
2336 # need to save uniques path 2415 # need to save uniques path
2337 unless ($self->{deny_save}) { 2416 unless ($self->{deny_save}) {
2338 my $uniq = $self->uniq_path; utf8::encode $uniq; 2417 my $uniq = $self->uniq_path; utf8::encode $uniq;
2339 2418
… …
2669 # use -1 or undef as default coordinates, not 0, 0 2748 # use -1 or undef as default coordinates, not 0, 0
2670 ($x, $y) = ($map->enter_x, $map->enter_y) 2749 ($x, $y) = ($map->enter_x, $map->enter_y)
2671 if $x <= 0 && $y <= 0; 2750 if $x <= 0 && $y <= 0;
2672 2751
2673 $map->load; 2752 $map->load;
2674 $map->load_neighbours;
2675 2753
2676 return unless $self->contr->active; 2754 return unless $self->contr->active;
2677 2755
2678 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2756 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2679 if ($self->enter_map ($map, $x, $y)) { 2757 if ($self->enter_map ($map, $x, $y)) {
… …
2735 ($path, $x, $y) = (undef, undef, undef); 2813 ($path, $x, $y) = (undef, undef, undef);
2736 } 2814 }
2737 } 2815 }
2738 2816
2739 my $map = eval { 2817 my $map = eval {
2740 my $map = defined $path ? cf::map::find $path : undef; 2818 my $map = defined $path ? cf::map::find $path, $self->map : undef;
2741 2819
2742 if ($map) { 2820 if ($map) {
2743 $map = $map->customise_for ($self); 2821 $map = $map->customise_for ($self);
2744 $map = $check->($map, $x, $y, $self) if $check && $map; 2822 $map = $check->($map, $x, $y, $self) if $check && $map;
2745 } else { 2823 } else {
… …
2835 $Coro::current->{desc} = "enter_exit"; 2913 $Coro::current->{desc} = "enter_exit";
2836 2914
2837 unless (eval { 2915 unless (eval {
2838 $self->deactivate_recursive; # just to be sure 2916 $self->deactivate_recursive; # just to be sure
2839 2917
2840 # random map handling
2841 {
2842 my $guard = cf::lock_acquire "exit_prepare:$exit";
2843
2844 prepare_random_map $exit
2845 if $exit->slaying eq "/!";
2846 }
2847
2848 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path; 2918 my $map = cf::map::normalise $exit->slaying, $exit->map;
2849 my $x = $exit->stats->hp; 2919 my $x = $exit->stats->hp;
2850 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 }
2851 2944
2852 $self->goto ($map, $x, $y); 2945 $self->goto ($map, $x, $y);
2853 2946
2854 # if exit is damned, update players death & WoR home-position 2947 # if exit is damned, update players death & WoR home-position
2855 $self->contr->savebed ($map, $x, $y) 2948 $self->contr->savebed ($map, $x, $y)
… …
3274 decrease split destroy change_exp value msg lore send_msg)], 3367 decrease split destroy change_exp value msg lore send_msg)],
3275 ["cf::object::player" => qw(player)], 3368 ["cf::object::player" => qw(player)],
3276 ["cf::player" => qw(peaceful send_msg)], 3369 ["cf::player" => qw(peaceful send_msg)],
3277 ["cf::map" => qw(trigger)], 3370 ["cf::map" => qw(trigger)],
3278) { 3371) {
3279 no strict 'refs';
3280 my ($pkg, @funs) = @$_; 3372 my ($pkg, @funs) = @$_;
3281 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3373 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
3282 for @funs; 3374 for @funs;
3283} 3375}
3284 3376
… …
3371 3463
3372 my $enc = JSON::XS->new->utf8->canonical->relaxed; 3464 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3373 3465
3374 trace "loading facedata from $path\n"; 3466 trace "loading facedata from $path\n";
3375 3467
3376 my $facedata; 3468 my $facedata = decode_storable load_file $path;
3377 0 < aio_load $path, $facedata
3378 or die "$path: $!";
3379
3380 $facedata = Coro::Storable::thaw $facedata;
3381 3469
3382 $facedata->{version} == 2 3470 $facedata->{version} == 2
3383 or cf::cleanup "$path: version mismatch, cannot proceed."; 3471 or cf::cleanup "$path: version mismatch, cannot proceed.";
3384 3472
3385 # patch in the exptable 3473 # patch in the exptable
… …
3399 3487
3400 cf::face::set_visibility $idx, $info->{visibility}; 3488 cf::face::set_visibility $idx, $info->{visibility};
3401 cf::face::set_magicmap $idx, $info->{magicmap}; 3489 cf::face::set_magicmap $idx, $info->{magicmap};
3402 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32}; 3490 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3403 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} ;
3404 3493
3405 cf::cede_to_tick; 3494 cf::cede_to_tick;
3406 } 3495 }
3407 3496
3408 while (my ($face, $info) = each %$faces) { 3497 while (my ($face, $info) = each %$faces) {
… …
3503} 3592}
3504 3593
3505sub reload_sound { 3594sub reload_sound {
3506 trace "loading sound config from $DATADIR/sound\n"; 3595 trace "loading sound config from $DATADIR/sound\n";
3507 3596
3508 0 < Coro::AIO::aio_load "$DATADIR/sound", my $data
3509 or die "$DATADIR/sound $!";
3510
3511 my $soundconf = JSON::XS->new->utf8->relaxed->decode ($data); 3597 my $soundconf = JSON::XS->new->utf8->relaxed->decode (load_file "$DATADIR/sound");
3512 3598
3513 for (0 .. SOUND_CAST_SPELL_0 - 1) { 3599 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3514 my $sound = $soundconf->{compat}[$_] 3600 my $sound = $soundconf->{compat}[$_]
3515 or next; 3601 or next;
3516 3602
… …
3526} 3612}
3527 3613
3528sub reload_resources { 3614sub reload_resources {
3529 trace "reloading resource files...\n"; 3615 trace "reloading resource files...\n";
3530 3616
3617 reload_exp_table;
3618 reload_materials;
3531 reload_facedata; 3619 reload_facedata;
3532 reload_sound; 3620 reload_sound;
3533 reload_archetypes; 3621 reload_archetypes;
3534 reload_regions; 3622 reload_regions;
3535 reload_treasures; 3623 reload_treasures;
… …
3538} 3626}
3539 3627
3540sub reload_config { 3628sub reload_config {
3541 trace "reloading config file...\n"; 3629 trace "reloading config file...\n";
3542 3630
3543 open my $fh, "<:utf8", "$CONFDIR/config" 3631 my $config = load_file "$CONFDIR/config";
3544 or return; 3632 utf8::decode $config;
3545 3633 *CFG = decode_yaml $config;
3546 local $/;
3547 *CFG = YAML::XS::Load scalar <$fh>;
3548 3634
3549 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38]; 3635 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3550 3636
3551 $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};
3552 $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};
… …
3556 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 3642 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3557 and die "WARNING: m(un)lockall failed: $!\n"; 3643 and die "WARNING: m(un)lockall failed: $!\n";
3558 }; 3644 };
3559 warn $@ if $@; 3645 warn $@ if $@;
3560 } 3646 }
3561
3562 trace "finished reloading resource files\n";
3563} 3647}
3564 3648
3565sub pidfile() { 3649sub pidfile() {
3566 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT 3650 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3567 or die "$PIDFILE: $!"; 3651 or die "$PIDFILE: $!";
… …
3592 3676
3593sub main { 3677sub main {
3594 cf::init_globals; # initialise logging 3678 cf::init_globals; # initialise logging
3595 3679
3596 LOG llevInfo, "Welcome to Deliantra, v" . VERSION; 3680 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3597 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team."; 3681 LOG llevInfo, "Copyright (C) 2005-2011 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3598 LOG llevInfo, "Copyright (C) 1994 Mark Wedel."; 3682 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3599 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen."; 3683 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3600 3684
3601 $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
3602 3686
… …
3610 }; 3694 };
3611 3695
3612 evthread_start IO::AIO::poll_fileno; 3696 evthread_start IO::AIO::poll_fileno;
3613 3697
3614 cf::sync_job { 3698 cf::sync_job {
3615 cf::init_experience; 3699 cf::incloader::init ();
3700
3616 cf::init_anim; 3701 cf::init_anim;
3617 cf::init_attackmess; 3702 cf::init_attackmess;
3618 cf::init_dynamic; 3703 cf::init_dynamic;
3619 3704
3620 cf::load_settings; 3705 cf::load_settings;
3621 cf::load_materials;
3622 3706
3623 reload_resources; 3707 reload_resources;
3624 reload_config; 3708 reload_config;
3625 db_init; 3709 db_init;
3626 3710
… …
3638 3722
3639 # no (long-running) fork's whatsoever before this point(!) 3723 # no (long-running) fork's whatsoever before this point(!)
3640 use POSIX (); 3724 use POSIX ();
3641 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};
3642 3726
3643 (pop @POST_INIT)->(0) while @POST_INIT; 3727 cf::_post_init 0;
3644 }; 3728 };
3645 3729
3646 cf::object::thawer::errors_are_fatal 0; 3730 cf::object::thawer::errors_are_fatal 0;
3647 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";
3648 3732
3733 my $free_main; $free_main = EV::idle sub {
3734 undef $free_main;
3735 undef &main; # free gobs of memory :)
3736 };
3737
3649 main_loop; 3738 goto &main_loop;
3650} 3739}
3651 3740
3652############################################################################# 3741#############################################################################
3653# initialisation and cleanup 3742# initialisation and cleanup
3654 3743
… …
3855 } 3944 }
3856} 3945}
3857 3946
3858sub do_reload_perl() { 3947sub do_reload_perl() {
3859 # can/must only be called in main 3948 # can/must only be called in main
3860 if (in_main) { 3949 unless (in_main) {
3861 error "can only reload from main coroutine"; 3950 error "can only reload from main coroutine";
3862 return; 3951 return;
3863 } 3952 }
3864 3953
3865 return if $RELOAD++; 3954 return if $RELOAD++;
3866 3955
3867 my $t1 = AE::time; 3956 my $t1 = AE::time;
3868 3957
3869 while ($RELOAD) { 3958 while ($RELOAD) {
3959 cf::get_slot 0.1, -1, "reload_perl";
3870 info "reloading..."; 3960 info "perl_reload: reloading...";
3871 3961
3872 trace "entering sync_job"; 3962 trace "perl_reload: entering sync_job";
3873 3963
3874 cf::sync_job { 3964 cf::sync_job {
3875 cf::emergency_save; 3965 #cf::emergency_save;
3876 3966
3877 trace "cancelling all extension coros"; 3967 trace "perl_reload: cancelling all extension coros";
3878 $_->cancel for values %EXT_CORO; 3968 $_->cancel for values %EXT_CORO;
3879 %EXT_CORO = (); 3969 %EXT_CORO = ();
3880 3970
3881 trace "removing commands"; 3971 trace "perl_reload: removing commands";
3882 %COMMAND = (); 3972 %COMMAND = ();
3883 3973
3884 trace "removing ext/exti commands"; 3974 trace "perl_reload: removing ext/exti commands";
3885 %EXTCMD = (); 3975 %EXTCMD = ();
3886 %EXTICMD = (); 3976 %EXTICMD = ();
3887 3977
3888 trace "unloading/nuking all extensions"; 3978 trace "perl_reload: unloading/nuking all extensions";
3889 for my $pkg (@EXTS) { 3979 for my $pkg (@EXTS) {
3890 trace "... unloading $pkg"; 3980 trace "... unloading $pkg";
3891 3981
3892 if (my $cb = $pkg->can ("unload")) { 3982 if (my $cb = $pkg->can ("unload")) {
3893 eval { 3983 eval {
… …
3898 3988
3899 trace "... clearing $pkg"; 3989 trace "... clearing $pkg";
3900 clear_package $pkg; 3990 clear_package $pkg;
3901 } 3991 }
3902 3992
3903 trace "unloading all perl modules loaded from $LIBDIR"; 3993 trace "perl_reload: unloading all perl modules loaded from $LIBDIR";
3904 while (my ($k, $v) = each %INC) { 3994 while (my ($k, $v) = each %INC) {
3905 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 3995 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3906 3996
3907 trace "... unloading $k"; 3997 trace "... unloading $k";
3908 delete $INC{$k}; 3998 delete $INC{$k};
… …
3915 } 4005 }
3916 4006
3917 clear_package $k; 4007 clear_package $k;
3918 } 4008 }
3919 4009
3920 trace "getting rid of safe::, as good as possible"; 4010 trace "perl_reload: getting rid of safe::, as good as possible";
3921 clear_package "safe::$_" 4011 clear_package "safe::$_"
3922 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);
3923 4013
3924 trace "unloading cf.pm \"a bit\""; 4014 trace "perl_reload: unloading cf.pm \"a bit\"";
3925 delete $INC{"cf.pm"}; 4015 delete $INC{"cf.pm"};
3926 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES; 4016 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3927 4017
3928 # don't, removes xs symbols, too, 4018 # don't, removes xs symbols, too,
3929 # and global variables created in xs 4019 # and global variables created in xs
3930 #clear_package __PACKAGE__; 4020 #clear_package __PACKAGE__;
3931 4021
3932 info "unload completed, starting to reload now"; 4022 info "perl_reload: unload completed, starting to reload now";
3933 4023
3934 trace "reloading cf.pm"; 4024 trace "perl_reload: reloading cf.pm";
3935 require cf; 4025 require cf;
3936 cf::_connect_to_perl_1; 4026 cf::_connect_to_perl_1;
3937 4027
3938 trace "loading config and database again"; 4028 trace "perl_reload: loading config and database again";
3939 cf::reload_config; 4029 cf::reload_config;
3940 4030
3941 trace "loading extensions"; 4031 trace "perl_reload: loading extensions";
3942 cf::load_extensions; 4032 cf::load_extensions;
3943 4033
3944 if ($REATTACH_ON_RELOAD) { 4034 if ($REATTACH_ON_RELOAD) {
3945 trace "reattaching attachments to objects/players"; 4035 trace "perl_reload: reattaching attachments to objects/players";
3946 _global_reattach; # objects, sockets 4036 _global_reattach; # objects, sockets
3947 trace "reattaching attachments to maps"; 4037 trace "perl_reload: reattaching attachments to maps";
3948 reattach $_ for values %MAP; 4038 reattach $_ for values %MAP;
3949 trace "reattaching attachments to players"; 4039 trace "perl_reload: reattaching attachments to players";
3950 reattach $_ for values %PLAYER; 4040 reattach $_ for values %PLAYER;
3951 } 4041 }
3952 4042
3953 trace "running post_init jobs"; 4043 cf::_post_init 1;
3954 (pop @POST_INIT)->(1) while @POST_INIT;
3955 4044
3956 trace "leaving sync_job"; 4045 trace "perl_reload: leaving sync_job";
3957 4046
3958 1 4047 1
3959 } or do { 4048 } or do {
3960 error $@; 4049 error $@;
3961 cf::cleanup "error while reloading, exiting."; 4050 cf::cleanup "perl_reload: error, exiting.";
3962 }; 4051 };
3963 4052
3964 info "reloaded";
3965 --$RELOAD; 4053 --$RELOAD;
3966 } 4054 }
3967 4055
3968 $t1 = AE::time - $t1; 4056 $t1 = AE::time - $t1;
3969 info "reload completed in ${t1}s\n"; 4057 info "perl_reload: completed in ${t1}s\n";
3970}; 4058};
3971 4059
3972our $RELOAD_WATCHER; # used only during reload 4060our $RELOAD_WATCHER; # used only during reload
3973 4061
3974sub reload_perl() { 4062sub reload_perl() {
… …
3995 reload_perl; 4083 reload_perl;
3996 }; 4084 };
3997 } 4085 }
3998}; 4086};
3999 4087
4000unshift @INC, $LIBDIR; 4088#############################################################################
4001 4089
4002my $bug_warning = 0; 4090my $bug_warning = 0;
4003 4091
4004our @WAIT_FOR_TICK;
4005our @WAIT_FOR_TICK_BEGIN;
4006
4007sub wait_for_tick { 4092sub wait_for_tick() {
4008 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main; 4093 return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
4009 4094
4010 my $signal = new Coro::Signal; 4095 $WAIT_FOR_TICK->wait;
4011 push @WAIT_FOR_TICK, $signal;
4012 $signal->wait;
4013} 4096}
4014 4097
4015sub wait_for_tick_begin { 4098sub wait_for_tick_begin() {
4016 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main; 4099 return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
4017 4100
4018 my $signal = new Coro::Signal; 4101 my $signal = new Coro::Signal;
4019 push @WAIT_FOR_TICK_BEGIN, $signal; 4102 push @WAIT_FOR_TICK_BEGIN, $signal;
4020 $signal->wait; 4103 $signal->wait;
4021} 4104}
… …
4025 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"
4026 unless ++$bug_warning > 10; 4109 unless ++$bug_warning > 10;
4027 return; 4110 return;
4028 } 4111 }
4029 4112
4030 cf::server_tick; # one server iteration 4113 cf::one_tick; # one server iteration
4031 4114
4032 #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#
4033 4116
4034 if ($NOW >= $NEXT_RUNTIME_WRITE) { 4117 if ($NOW >= $NEXT_RUNTIME_WRITE) {
4035 $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.;
… …
4041 } 4124 }
4042 4125
4043 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 4126 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
4044 $sig->send; 4127 $sig->send;
4045 } 4128 }
4046 while (my $sig = shift @WAIT_FOR_TICK) { 4129 $WAIT_FOR_TICK->broadcast;
4047 $sig->send;
4048 }
4049 4130
4050 $LOAD = ($NOW - $TICK_START) / $TICK; 4131 $LOAD = ($NOW - $TICK_START) / $TICK;
4051 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 4132 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
4052 4133
4053 if (0) { 4134 if (0) {
… …
4107 IO::AIO::min_parallel 8; 4188 IO::AIO::min_parallel 8;
4108 IO::AIO::max_poll_time $TICK * 0.1; 4189 IO::AIO::max_poll_time $TICK * 0.1;
4109 undef $AnyEvent::AIO::WATCHER; 4190 undef $AnyEvent::AIO::WATCHER;
4110} 4191}
4111 4192
4112my $_log_backtrace; 4193our $_log_backtrace;
4194our $_log_backtrace_last;
4113 4195
4114sub _log_backtrace { 4196sub _log_backtrace {
4115 my ($msg, @addr) = @_; 4197 my ($msg, @addr) = @_;
4116 4198
4117 $msg =~ s/\n//; 4199 $msg =~ s/\n$//;
4118 4200
4201 if ($_log_backtrace_last eq $msg) {
4202 LOG llevInfo, "[ABT] $msg\n";
4203 LOG llevInfo, "[ABT] [duplicate, suppressed]\n";
4119 # limit the # of concurrent backtraces 4204 # limit the # of concurrent backtraces
4120 if ($_log_backtrace < 2) { 4205 } elsif ($_log_backtrace < 2) {
4206 $_log_backtrace_last = $msg;
4121 ++$_log_backtrace; 4207 ++$_log_backtrace;
4122 my $perl_bt = Carp::longmess $msg; 4208 my $perl_bt = Carp::longmess $msg;
4123 async { 4209 async {
4124 $Coro::current->{desc} = "abt $msg"; 4210 $Coro::current->{desc} = "abt $msg";
4125 4211
… …
4145 LOG llevInfo, "[ABT] $_\n" for @bt; 4231 LOG llevInfo, "[ABT] $_\n" for @bt;
4146 --$_log_backtrace; 4232 --$_log_backtrace;
4147 }; 4233 };
4148 } else { 4234 } else {
4149 LOG llevInfo, "[ABT] $msg\n"; 4235 LOG llevInfo, "[ABT] $msg\n";
4150 LOG llevInfo, "[ABT] [suppressed]\n"; 4236 LOG llevInfo, "[ABT] [overload, suppressed]\n";
4151 } 4237 }
4152} 4238}
4153 4239
4154# load additional modules 4240# load additional modules
4155require "cf/$_.pm" for @EXTRA_MODULES; 4241require "cf/$_.pm" for @EXTRA_MODULES;

Diff Legend

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