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.458 by root, Sat Dec 13 20:34:37 2008 UTC vs.
Revision 1.501 by root, Sat Jan 16 23:27:21 2010 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 Marc Alexander Lehmann / Robin Redeker / the Deliantra team 4# Copyright (©) 2006,2007,2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5# 5#
6# Deliantra is free software: you can redistribute it and/or modify 6# Deliantra is free software: you can redistribute it and/or modify it under
7# it under the terms of the GNU General Public License as published by 7# the terms of the Affero GNU General Public License as published by the
8# the Free Software Foundation, either version 3 of the License, or 8# Free Software Foundation, either version 3 of the License, or (at your
9# (at your option) any later version. 9# option) any later version.
10# 10#
11# This program is distributed in the hope that it will be useful, 11# This program is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of 12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14# GNU General Public License for more details. 14# GNU General Public License for more details.
15# 15#
16# You should have received a copy of the GNU General Public License 16# You should have received a copy of the Affero GNU General Public License
17# along with this program. If not, see <http://www.gnu.org/licenses/>. 17# and the GNU General Public License along with this program. If not, see
18# <http://www.gnu.org/licenses/>.
18# 19#
19# 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>
20# 21#
21 22
22package cf; 23package cf;
23 24
24use 5.10.0; 25use 5.10.0;
25use utf8; 26use utf8;
26use strict "vars", "subs"; 27use strict qw(vars subs);
27 28
28use Symbol; 29use Symbol;
29use List::Util; 30use List::Util;
30use Socket; 31use Socket;
31use EV; 32use EV;
32use Opcode; 33use Opcode;
33use Safe; 34use Safe;
34use Safe::Hole; 35use Safe::Hole;
35use Storable (); 36use Storable ();
37use Carp ();
36 38
37use Guard (); 39use Guard ();
38use Coro (); 40use Coro ();
39use Coro::State; 41use Coro::State;
40use Coro::Handle; 42use Coro::Handle;
41use Coro::EV; 43use Coro::EV;
42use Coro::AnyEvent; 44use Coro::AnyEvent;
43use Coro::Timer; 45use Coro::Timer;
44use Coro::Signal; 46use Coro::Signal;
45use Coro::Semaphore; 47use Coro::Semaphore;
48use Coro::SemaphoreSet;
46use Coro::AnyEvent; 49use Coro::AnyEvent;
47use Coro::AIO; 50use Coro::AIO;
48use Coro::BDB 1.6; 51use Coro::BDB 1.6;
49use Coro::Storable; 52use Coro::Storable;
50use Coro::Util (); 53use Coro::Util ();
51 54
52use JSON::XS 2.01 (); 55use JSON::XS 2.01 ();
53use BDB (); 56use BDB ();
54use Data::Dumper; 57use Data::Dumper;
55use Digest::MD5;
56use Fcntl; 58use Fcntl;
57use YAML (); 59use YAML::XS ();
58use IO::AIO (); 60use IO::AIO ();
59use Time::HiRes; 61use Time::HiRes;
60use Compress::LZF; 62use Compress::LZF;
61use Digest::MD5 (); 63use Digest::MD5 ();
62 64
… …
70$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 72$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
71 73
72# make sure c-lzf reinitialises itself 74# make sure c-lzf reinitialises itself
73Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve"; 75Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";
74Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 76Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
77
78# strictly for debugging
79$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
75 80
76sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 81sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
77 82
78our %COMMAND = (); 83our %COMMAND = ();
79our %COMMAND_TIME = (); 84our %COMMAND_TIME = ();
… …
84our %EXT_CORO = (); # coroutines bound to extensions 89our %EXT_CORO = (); # coroutines bound to extensions
85our %EXT_MAP = (); # pluggable maps 90our %EXT_MAP = (); # pluggable maps
86 91
87our $RELOAD; # number of reloads so far, non-zero while in reload 92our $RELOAD; # number of reloads so far, non-zero while in reload
88our @EVENT; 93our @EVENT;
94our @REFLECT; # set by XS
95our %REFLECT; # set by us
89 96
90our $CONFDIR = confdir; 97our $CONFDIR = confdir;
91our $DATADIR = datadir; 98our $DATADIR = datadir;
92our $LIBDIR = "$DATADIR/ext"; 99our $LIBDIR = "$DATADIR/ext";
93our $PODDIR = "$DATADIR/pod"; 100our $PODDIR = "$DATADIR/pod";
… …
104our %RESOURCE; 111our %RESOURCE;
105 112
106our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 113our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
107our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 114our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
108our $NEXT_TICK; 115our $NEXT_TICK;
109our $USE_FSYNC = 1; # use fsync to write maps - default off 116our $USE_FSYNC = 1; # use fsync to write maps - default on
110 117
111our $BDB_DEADLOCK_WATCHER; 118our $BDB_DEADLOCK_WATCHER;
112our $BDB_CHECKPOINT_WATCHER; 119our $BDB_CHECKPOINT_WATCHER;
113our $BDB_TRICKLE_WATCHER; 120our $BDB_TRICKLE_WATCHER;
114our $DB_ENV; 121our $DB_ENV;
115 122
123our @EXTRA_MODULES = qw(pod match mapscript);
124
116our %CFG; 125our %CFG;
117 126
118our $UPTIME; $UPTIME ||= time; 127our $UPTIME; $UPTIME ||= time;
119our $RUNTIME; 128our $RUNTIME;
120our $NOW; 129our $NOW;
… …
131our $JITTER; # average jitter 140our $JITTER; # average jitter
132our $TICK_START; # for load detecting purposes 141our $TICK_START; # for load detecting purposes
133 142
134our @POST_INIT; 143our @POST_INIT;
135 144
136our $REATTACH_ON_RELOAD; # ste to true to force object reattach on reload (slow) 145our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
146our $REALLY_UNLOOP; # never set to true, please :)
137 147
138binmode STDOUT; 148binmode STDOUT;
139binmode STDERR; 149binmode STDERR;
140 150
141# read virtual server time, if available 151# read virtual server time, if available
… …
143 open my $fh, "<", $RUNTIMEFILE 153 open my $fh, "<", $RUNTIMEFILE
144 or die "unable to read $RUNTIMEFILE file: $!"; 154 or die "unable to read $RUNTIMEFILE file: $!";
145 $RUNTIME = <$fh> + 0.; 155 $RUNTIME = <$fh> + 0.;
146} 156}
147 157
158eval "sub TICK() { $TICK } 1" or die;
159
148mkdir $_ 160mkdir $_
149 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR; 161 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
150 162
151our $EMERGENCY_POSITION; 163our $EMERGENCY_POSITION;
152 164
153sub cf::map::normalise; 165sub cf::map::normalise;
166
167#############################################################################
168
169%REFLECT = ();
170for (@REFLECT) {
171 my $reflect = JSON::XS::decode_json $_;
172 $REFLECT{$reflect->{class}} = $reflect;
173}
174
175# this is decidedly evil
176$REFLECT{object}{flags} = { map +($_ => undef), grep $_, map /^FLAG_([A-Z0-9_]+)$/ && lc $1, keys %{"cf::"} };
154 177
155############################################################################# 178#############################################################################
156 179
157=head2 GLOBAL VARIABLES 180=head2 GLOBAL VARIABLES
158 181
… …
205returns directly I<after> the tick processing (and consequently, can only wake one process 228returns directly I<after> the tick processing (and consequently, can only wake one process
206per tick), while cf::wait_for_tick wakes up all waiters after tick processing. 229per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
207 230
208=item @cf::INVOKE_RESULTS 231=item @cf::INVOKE_RESULTS
209 232
210This array contains the results of the last C<invoke ()> call. When 233This array contains the results of the last C<invoke ()> call. When
211C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of 234C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
212that call. 235that call.
213 236
237=item %cf::REFLECT
238
239Contains, for each (C++) class name, a hash reference with information
240about object members (methods, scalars, arrays and flags) and other
241metadata, which is useful for introspection.
242
214=back 243=back
215 244
216=cut 245=cut
217 246
218BEGIN { 247$Coro::State::WARNHOOK = sub {
219 *CORE::GLOBAL::warn = sub {
220 my $msg = join "", @_; 248 my $msg = join "", @_;
221 249
222 $msg .= "\n" 250 $msg .= "\n"
223 unless $msg =~ /\n$/; 251 unless $msg =~ /\n$/;
224 252
225 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 253 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
226 254
227 LOG llevError, $msg; 255 LOG llevError, $msg;
228 }; 256};
229}
230 257
231$Coro::State::DIEHOOK = sub { 258$Coro::State::DIEHOOK = sub {
232 return unless $^S eq 0; # "eq", not "==" 259 return unless $^S eq 0; # "eq", not "=="
260
261 warn Carp::longmess $_[0];
233 262
234 if ($Coro::current == $Coro::main) {#d# 263 if ($Coro::current == $Coro::main) {#d#
235 warn "DIEHOOK called in main context, Coro bug?\n";#d# 264 warn "DIEHOOK called in main context, Coro bug?\n";#d#
236 return;#d# 265 return;#d#
237 }#d# 266 }#d#
238 267
239 # kill coroutine otherwise 268 # kill coroutine otherwise
240 warn Carp::longmess $_[0];
241 Coro::terminate 269 Coro::terminate
242}; 270};
243
244$SIG{__DIE__} = sub { }; #d#?
245 271
246@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 272@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
247@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 273@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
248@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 274@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
249@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 275@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
… …
263)) { 289)) {
264 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 290 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
265} 291}
266 292
267$EV::DIED = sub { 293$EV::DIED = sub {
268 warn "error in event callback: @_"; 294 Carp::cluck "error in event callback: @_";
269}; 295};
270 296
271############################################################################# 297#############################################################################
272 298
273=head2 UTILITY FUNCTIONS 299=head2 UTILITY FUNCTIONS
… …
347 373
348Return true if the lock is currently active, i.e. somebody has locked it. 374Return true if the lock is currently active, i.e. somebody has locked it.
349 375
350=cut 376=cut
351 377
352our %LOCK; 378our $LOCKS = new Coro::SemaphoreSet;
353our %LOCKER;#d#
354 379
355sub lock_wait($) { 380sub lock_wait($) {
356 my ($key) = @_; 381 $LOCKS->wait ($_[0]);
357
358 if ($LOCKER{$key} == $Coro::current) {#d#
359 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
360 return;#d#
361 }#d#
362
363 # wait for lock, if any
364 while ($LOCK{$key}) {
365 #local $Coro::current->{desc} = "$Coro::current->{desc} <waiting for lock $key>";
366 push @{ $LOCK{$key} }, $Coro::current;
367 Coro::schedule;
368 }
369} 382}
370 383
371sub lock_acquire($) { 384sub lock_acquire($) {
372 my ($key) = @_; 385 $LOCKS->guard ($_[0])
373
374 # wait, to be sure we are not locked
375 lock_wait $key;
376
377 $LOCK{$key} = [];
378 $LOCKER{$key} = $Coro::current;#d#
379
380 Guard::guard {
381 delete $LOCKER{$key};#d#
382 # wake up all waiters, to be on the safe side
383 $_->ready for @{ delete $LOCK{$key} };
384 }
385} 386}
386 387
387sub lock_active($) { 388sub lock_active($) {
388 my ($key) = @_; 389 $LOCKS->count ($_[0]) < 1
389
390 ! ! $LOCK{$key}
391} 390}
392 391
393sub freeze_mainloop { 392sub freeze_mainloop {
394 tick_inhibit_inc; 393 tick_inhibit_inc;
395 394
… …
1173 $decname, length $$rdata, scalar @$objs; 1172 $decname, length $$rdata, scalar @$objs;
1174 1173
1175 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1174 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1176 aio_chmod $fh, SAVE_MODE; 1175 aio_chmod $fh, SAVE_MODE;
1177 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1176 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1178 aio_fsync $fh if $cf::USE_FSYNC; 1177 if ($cf::USE_FSYNC) {
1178 aio_sync_file_range $fh, 0, 0, IO::AIO::SYNC_FILE_RANGE_WAIT_BEFORE | IO::AIO::SYNC_FILE_RANGE_WRITE | IO::AIO::SYNC_FILE_RANGE_WAIT_AFTER;
1179 aio_fsync $fh;
1180 }
1179 aio_close $fh; 1181 aio_close $fh;
1180 1182
1181 if (@$objs) { 1183 if (@$objs) {
1182 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1184 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1183 aio_chmod $fh, SAVE_MODE; 1185 aio_chmod $fh, SAVE_MODE;
1184 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs }; 1186 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1185 aio_write $fh, 0, (length $data), $data, 0; 1187 aio_write $fh, 0, (length $data), $data, 0;
1186 aio_fsync $fh if $cf::USE_FSYNC; 1188 if ($cf::USE_FSYNC) {
1189 aio_sync_file_range $fh, 0, 0, IO::AIO::SYNC_FILE_RANGE_WAIT_BEFORE | IO::AIO::SYNC_FILE_RANGE_WRITE | IO::AIO::SYNC_FILE_RANGE_WAIT_AFTER;
1190 aio_fsync $fh;
1191 }
1187 aio_close $fh; 1192 aio_close $fh;
1188 aio_rename "$filename.pst~", "$filename.pst"; 1193 aio_rename "$filename.pst~", "$filename.pst";
1189 } 1194 }
1190 } else { 1195 } else {
1191 aio_unlink "$filename.pst"; 1196 aio_unlink "$filename.pst";
… …
1194 aio_rename "$filename~", $filename; 1199 aio_rename "$filename~", $filename;
1195 1200
1196 $filename =~ s%/[^/]+$%%; 1201 $filename =~ s%/[^/]+$%%;
1197 aio_pathsync $filename if $cf::USE_FSYNC; 1202 aio_pathsync $filename if $cf::USE_FSYNC;
1198 } else { 1203 } else {
1199 warn "FATAL: $filename~: $!\n"; 1204 warn "unable to save objects: $filename~: $!\n";
1200 } 1205 }
1201 } else { 1206 } else {
1202 aio_unlink $filename; 1207 aio_unlink $filename;
1203 aio_unlink "$filename.pst"; 1208 aio_unlink "$filename.pst";
1204 } 1209 }
… …
1342 1347
1343# "readahead" all extensions 1348# "readahead" all extensions
1344sub cache_extensions { 1349sub cache_extensions {
1345 my $grp = IO::AIO::aio_group; 1350 my $grp = IO::AIO::aio_group;
1346 1351
1347 add $grp IO::AIO::aio_readdir $LIBDIR, sub { 1352 add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
1348 for (grep /\.ext$/, @{$_[0]}) { 1353 for (grep /\.ext$/, @{$_[0]}) {
1349 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data; 1354 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
1350 } 1355 }
1351 }; 1356 };
1352 1357
… …
1888 1893
1889 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go; 1894 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1890 "$UNIQUEDIR/$path" 1895 "$UNIQUEDIR/$path"
1891} 1896}
1892 1897
1893# and all this just because we cannot iterate over
1894# all maps in C++...
1895sub change_all_map_light {
1896 my ($change) = @_;
1897
1898 $_->change_map_light ($change)
1899 for grep $_->outdoor, values %cf::MAP;
1900}
1901
1902sub decay_objects { 1898sub decay_objects {
1903 my ($self) = @_; 1899 my ($self) = @_;
1904 1900
1905 return if $self->{deny_reset}; 1901 return if $self->{deny_reset};
1906 1902
… …
1988sub find { 1984sub find {
1989 my ($path, $origin) = @_; 1985 my ($path, $origin) = @_;
1990 1986
1991 $path = normalise $path, $origin && $origin->path; 1987 $path = normalise $path, $origin && $origin->path;
1992 1988
1993 cf::lock_wait "map_data:$path";#d#remove 1989 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1994 cf::lock_wait "map_find:$path"; 1990 my $guard2 = cf::lock_acquire "map_find:$path";
1995 1991
1996 $cf::MAP{$path} || do { 1992 $cf::MAP{$path} || do {
1997 my $guard1 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1998 my $guard2 = cf::lock_acquire "map_find:$path";
1999
2000 my $map = new_from_path cf::map $path 1993 my $map = new_from_path cf::map $path
2001 or return; 1994 or return;
2002 1995
2003 $map->{last_save} = $cf::RUNTIME; 1996 $map->{last_save} = $cf::RUNTIME;
2004 1997
… …
2016 2009
2017 $cf::MAP{$path} = $map 2010 $cf::MAP{$path} = $map
2018 } 2011 }
2019} 2012}
2020 2013
2021sub pre_load { } 2014sub pre_load { }
2022sub post_load { } 2015#sub post_load { } # XS
2023 2016
2024sub load { 2017sub load {
2025 my ($self) = @_; 2018 my ($self) = @_;
2026 2019
2027 local $self->{deny_reset} = 1; # loading can take a long time 2020 local $self->{deny_reset} = 1; # loading can take a long time
… …
2072 unless ($self->{deny_activate}) { 2065 unless ($self->{deny_activate}) {
2073 $self->decay_objects; 2066 $self->decay_objects;
2074 $self->fix_auto_apply; 2067 $self->fix_auto_apply;
2075 $self->update_buttons; 2068 $self->update_buttons;
2076 cf::cede_to_tick; 2069 cf::cede_to_tick;
2077 $self->set_darkness_map;
2078 cf::cede_to_tick;
2079 $self->activate; 2070 $self->activate;
2080 } 2071 }
2081 2072
2082 $self->{last_save} = $cf::RUNTIME; 2073 $self->{last_save} = $cf::RUNTIME;
2083 $self->last_access ($cf::RUNTIME); 2074 $self->last_access ($cf::RUNTIME);
… …
2249 2240
2250 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2241 my $lock = cf::lock_acquire "map_data:$self->{path}";
2251 2242
2252 return if $self->players; 2243 return if $self->players;
2253 2244
2254 warn "resetting map ", $self->path; 2245 warn "resetting map ", $self->path, "\n";
2255 2246
2256 $self->in_memory (cf::MAP_SWAPPED); 2247 $self->in_memory (cf::MAP_SWAPPED);
2257 2248
2258 # need to save uniques path 2249 # need to save uniques path
2259 unless ($self->{deny_save}) { 2250 unless ($self->{deny_save}) {
… …
2350 : normalise $_ 2341 : normalise $_
2351 } @{ aio_readdir $UNIQUEDIR or [] } 2342 } @{ aio_readdir $UNIQUEDIR or [] }
2352 ] 2343 ]
2353} 2344}
2354 2345
2346=item cf::map::static_maps
2347
2348Returns an arrayref if paths of all static maps (all preinstalled F<.map>
2349file in the shared directory excluding F</styles> and F</editor>). May
2350block.
2351
2352=cut
2353
2354sub static_maps() {
2355 my @dirs = "";
2356 my @maps;
2357
2358 while (@dirs) {
2359 my $dir = shift @dirs;
2360
2361 next if $dir eq "/styles" || $dir eq "/editor";
2362
2363 my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
2364 or return;
2365
2366 for (@$files) {
2367 s/\.map$// or next;
2368 utf8::decode $_;
2369 push @maps, "$dir/$_";
2370 }
2371
2372 push @dirs, map "$dir/$_", @$dirs;
2373 }
2374
2375 \@maps
2376}
2377
2355=back 2378=back
2356 2379
2357=head3 cf::object 2380=head3 cf::object
2358 2381
2359=cut 2382=cut
… …
2424 2447
2425our $SAY_CHANNEL = { 2448our $SAY_CHANNEL = {
2426 id => "say", 2449 id => "say",
2427 title => "Map", 2450 title => "Map",
2428 reply => "say ", 2451 reply => "say ",
2429 tooltip => "Things said to and replied from npcs near you and other players on the same map only.", 2452 tooltip => "Things said to and replied from NPCs near you and other players on the same map only.",
2430}; 2453};
2431 2454
2432our $CHAT_CHANNEL = { 2455our $CHAT_CHANNEL = {
2433 id => "chat", 2456 id => "chat",
2434 title => "Chat", 2457 title => "Chat",
… …
2554 ($x, $y) = (-1, -1) 2577 ($x, $y) = (-1, -1)
2555 unless (defined $x) && (defined $y); 2578 unless (defined $x) && (defined $y);
2556 2579
2557 # use -1 or undef as default coordinates, not 0, 0 2580 # use -1 or undef as default coordinates, not 0, 0
2558 ($x, $y) = ($map->enter_x, $map->enter_y) 2581 ($x, $y) = ($map->enter_x, $map->enter_y)
2559 if $x <=0 && $y <= 0; 2582 if $x <= 0 && $y <= 0;
2560 2583
2561 $map->load; 2584 $map->load;
2562 $map->load_neighbours; 2585 $map->load_neighbours;
2563 2586
2564 return unless $self->contr->active; 2587 return unless $self->contr->active;
2565 $self->flag (cf::FLAG_DEBUG, 0);#d# temp
2566 $self->activate_recursive;
2567 2588
2568 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2589 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2569 $self->enter_map ($map, $x, $y); 2590 $self->enter_map ($map, $x, $y);
2591
2592 # only activate afterwards, to support waiting in hooks
2593 $self->activate_recursive;
2570} 2594}
2571 2595
2572=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]]) 2596=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2573 2597
2574Moves the player to the given map-path and coordinates by first freezing 2598Moves the player to the given map-path and coordinates by first freezing
… …
2762 2786
2763 utf8::encode $text; 2787 utf8::encode $text;
2764 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2788 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2765} 2789}
2766 2790
2791=item $client->send_big_packet ($pkt)
2792
2793Like C<send_packet>, but tries to compress large packets, and fragments
2794them as required.
2795
2796=cut
2797
2798our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
2799
2800sub cf::client::send_big_packet {
2801 my ($self, $pkt) = @_;
2802
2803 # try lzf for large packets
2804 $pkt = "lzf " . Compress::LZF::compress $pkt
2805 if 1024 <= length $pkt and $self->{can_lzf};
2806
2807 # split very large packets
2808 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
2809 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
2810 $pkt = "frag";
2811 }
2812
2813 $self->send_packet ($pkt);
2814}
2815
2767=item $client->send_msg ($channel, $msg, $color, [extra...]) 2816=item $client->send_msg ($channel, $msg, $color, [extra...])
2768 2817
2769Send a drawinfo or msg packet to the client, formatting the msg for the 2818Send a drawinfo or msg packet to the client, formatting the msg for the
2770client if neccessary. C<$type> should be a string identifying the type of 2819client if neccessary. C<$type> should be a string identifying the type of
2771the message, with C<log> being the default. If C<$color> is negative, suppress 2820the message, with C<log> being the default. If C<$color> is negative, suppress
… …
2773 2822
2774=cut 2823=cut
2775 2824
2776# non-persistent channels (usually the info channel) 2825# non-persistent channels (usually the info channel)
2777our %CHANNEL = ( 2826our %CHANNEL = (
2827 "c/motd" => {
2828 id => "infobox",
2829 title => "MOTD",
2830 reply => undef,
2831 tooltip => "The message of the day",
2832 },
2778 "c/identify" => { 2833 "c/identify" => {
2779 id => "infobox", 2834 id => "infobox",
2780 title => "Identify", 2835 title => "Identify",
2781 reply => undef, 2836 reply => undef,
2782 tooltip => "Items recently identified", 2837 tooltip => "Items recently identified",
… …
2784 "c/examine" => { 2839 "c/examine" => {
2785 id => "infobox", 2840 id => "infobox",
2786 title => "Examine", 2841 title => "Examine",
2787 reply => undef, 2842 reply => undef,
2788 tooltip => "Signs and other items you examined", 2843 tooltip => "Signs and other items you examined",
2844 },
2845 "c/shopinfo" => {
2846 id => "infobox",
2847 title => "Shop Info",
2848 reply => undef,
2849 tooltip => "What your bargaining skill tells you about the shop",
2789 }, 2850 },
2790 "c/book" => { 2851 "c/book" => {
2791 id => "infobox", 2852 id => "infobox",
2792 title => "Book", 2853 title => "Book",
2793 reply => undef, 2854 reply => undef,
… …
2809 id => "infobox", 2870 id => "infobox",
2810 title => "Body Parts", 2871 title => "Body Parts",
2811 reply => undef, 2872 reply => undef,
2812 tooltip => "Shows which body parts you posess and are available", 2873 tooltip => "Shows which body parts you posess and are available",
2813 }, 2874 },
2875 "c/statistics" => {
2876 id => "infobox",
2877 title => "Statistics",
2878 reply => undef,
2879 tooltip => "Shows your primary statistics",
2880 },
2814 "c/skills" => { 2881 "c/skills" => {
2815 id => "infobox", 2882 id => "infobox",
2816 title => "Skills", 2883 title => "Skills",
2817 reply => undef, 2884 reply => undef,
2818 tooltip => "Shows your experience per skill and item power", 2885 tooltip => "Shows your experience per skill and item power",
2886 },
2887 "c/shopitems" => {
2888 id => "infobox",
2889 title => "Shop Items",
2890 reply => undef,
2891 tooltip => "Shows the items currently for sale in this shop",
2892 },
2893 "c/resistances" => {
2894 id => "infobox",
2895 title => "Resistances",
2896 reply => undef,
2897 tooltip => "Shows your resistances",
2898 },
2899 "c/pets" => {
2900 id => "infobox",
2901 title => "Pets",
2902 reply => undef,
2903 tooltip => "Shows information abotu your pets/a specific pet",
2904 },
2905 "c/perceiveself" => {
2906 id => "infobox",
2907 title => "Perceive Self",
2908 reply => undef,
2909 tooltip => "You gained detailed knowledge about yourself",
2819 }, 2910 },
2820 "c/uptime" => { 2911 "c/uptime" => {
2821 id => "infobox", 2912 id => "infobox",
2822 title => "Uptime", 2913 title => "Uptime",
2823 reply => undef, 2914 reply => undef,
… …
2833 id => "party", 2924 id => "party",
2834 title => "Party", 2925 title => "Party",
2835 reply => "gsay ", 2926 reply => "gsay ",
2836 tooltip => "Messages and chat related to your party", 2927 tooltip => "Messages and chat related to your party",
2837 }, 2928 },
2929 "c/death" => {
2930 id => "death",
2931 title => "Death",
2932 reply => undef,
2933 tooltip => "Reason for and more info about your most recent death",
2934 },
2935 "c/say" => $SAY_CHANNEL,
2936 "c/chat" => $CHAT_CHANNEL,
2838); 2937);
2839 2938
2840sub cf::client::send_msg { 2939sub cf::client::send_msg {
2841 my ($self, $channel, $msg, $color, @extra) = @_; 2940 my ($self, $channel, $msg, $color, @extra) = @_;
2842 2941
… …
2847 2946
2848 # check predefined channels, for the benefit of C 2947 # check predefined channels, for the benefit of C
2849 if ($CHANNEL{$channel}) { 2948 if ($CHANNEL{$channel}) {
2850 $channel = $CHANNEL{$channel}; 2949 $channel = $CHANNEL{$channel};
2851 2950
2852 $self->ext_msg (channel_info => $channel) 2951 $self->ext_msg (channel_info => $channel);
2853 if $self->can_msg;
2854
2855 $channel = $channel->{id}; 2952 $channel = $channel->{id};
2856 2953
2857 } elsif (ref $channel) { 2954 } elsif (ref $channel) {
2858 # send meta info to client, if not yet sent 2955 # send meta info to client, if not yet sent
2859 unless (exists $self->{channel}{$channel->{id}}) { 2956 unless (exists $self->{channel}{$channel->{id}}) {
2860 $self->{channel}{$channel->{id}} = $channel; 2957 $self->{channel}{$channel->{id}} = $channel;
2861 $self->ext_msg (channel_info => $channel) 2958 $self->ext_msg (channel_info => $channel);
2862 if $self->can_msg;
2863 } 2959 }
2864 2960
2865 $channel = $channel->{id}; 2961 $channel = $channel->{id};
2866 } 2962 }
2867 2963
2868 return unless @extra || length $msg; 2964 return unless @extra || length $msg;
2869 2965
2870 if ($self->can_msg) {
2871 # default colour, mask it out 2966 # default colour, mask it out
2872 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF) 2967 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2873 if $color & cf::NDI_DEF; 2968 if $color & cf::NDI_DEF;
2874 2969
2875 my $pkt = "msg " 2970 my $pkt = "msg "
2876 . $self->{json_coder}->encode ( 2971 . $self->{json_coder}->encode (
2877 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra] 2972 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2878 ); 2973 );
2879 2974
2880 # try lzf for large packets
2881 $pkt = "lzf " . Compress::LZF::compress $pkt
2882 if 1024 <= length $pkt and $self->{can_lzf};
2883
2884 # split very large packets
2885 if (8192 < length $pkt and $self->{can_lzf}) {
2886 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2887 $pkt = "frag";
2888 }
2889
2890 $self->send_packet ($pkt); 2975 $self->send_big_packet ($pkt);
2891 } else {
2892 if ($color >= 0) {
2893 # replace some tags by gcfclient-compatible ones
2894 for ($msg) {
2895 1 while
2896 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2897 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2898 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2899 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2900 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2901 }
2902
2903 $color &= cf::NDI_COLOR_MASK;
2904
2905 utf8::encode $msg;
2906
2907 if (0 && $msg =~ /\[/) {
2908 # COMMAND/INFO
2909 $self->send_packet ("drawextinfo $color 10 8 $msg")
2910 } else {
2911 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2912 $self->send_packet ("drawinfo $color $msg")
2913 }
2914 }
2915 }
2916} 2976}
2917 2977
2918=item $client->ext_msg ($type, @msg) 2978=item $client->ext_msg ($type, @msg)
2919 2979
2920Sends an ext event to the client. 2980Sends an ext event to the client.
… …
2923 2983
2924sub cf::client::ext_msg($$@) { 2984sub cf::client::ext_msg($$@) {
2925 my ($self, $type, @msg) = @_; 2985 my ($self, $type, @msg) = @_;
2926 2986
2927 if ($self->extcmd == 2) { 2987 if ($self->extcmd == 2) {
2928 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 2988 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2929 } elsif ($self->extcmd == 1) { # TODO: remove 2989 } elsif ($self->extcmd == 1) { # TODO: remove
2930 push @msg, msgtype => "event_$type"; 2990 push @msg, msgtype => "event_$type";
2931 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 2991 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2932 } 2992 }
2933} 2993}
2934 2994
2935=item $client->ext_reply ($msgid, @msg) 2995=item $client->ext_reply ($msgid, @msg)
2936 2996
… …
2940 3000
2941sub cf::client::ext_reply($$@) { 3001sub cf::client::ext_reply($$@) {
2942 my ($self, $id, @msg) = @_; 3002 my ($self, $id, @msg) = @_;
2943 3003
2944 if ($self->extcmd == 2) { 3004 if ($self->extcmd == 2) {
2945 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg])); 3005 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2946 } elsif ($self->extcmd == 1) { 3006 } elsif ($self->extcmd == 1) {
2947 #TODO: version 1, remove 3007 #TODO: version 1, remove
2948 unshift @msg, msgtype => "reply", msgid => $id; 3008 unshift @msg, msgtype => "reply", msgid => $id;
2949 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3009 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2950 } 3010 }
2951} 3011}
2952 3012
2953=item $success = $client->query ($flags, "text", \&cb) 3013=item $success = $client->query ($flags, "text", \&cb)
2954 3014
… …
3081our $safe_hole = new Safe::Hole; 3141our $safe_hole = new Safe::Hole;
3082 3142
3083$SIG{FPE} = 'IGNORE'; 3143$SIG{FPE} = 'IGNORE';
3084 3144
3085$safe->permit_only (Opcode::opset qw( 3145$safe->permit_only (Opcode::opset qw(
3086 :base_core :base_mem :base_orig :base_math 3146 :base_core :base_mem :base_orig :base_math :base_loop
3087 grepstart grepwhile mapstart mapwhile 3147 grepstart grepwhile mapstart mapwhile
3088 sort time 3148 sort time
3089)); 3149));
3090 3150
3091# here we export the classes and methods available to script code 3151# here we export the classes and methods available to script code
… …
3095The following functions and methods are available within a safe environment: 3155The following functions and methods are available within a safe environment:
3096 3156
3097 cf::object 3157 cf::object
3098 contr pay_amount pay_player map x y force_find force_add destroy 3158 contr pay_amount pay_player map x y force_find force_add destroy
3099 insert remove name archname title slaying race decrease split 3159 insert remove name archname title slaying race decrease split
3160 value
3100 3161
3101 cf::object::player 3162 cf::object::player
3102 player 3163 player
3103 3164
3104 cf::player 3165 cf::player
… …
3110=cut 3171=cut
3111 3172
3112for ( 3173for (
3113 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3174 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3114 insert remove inv nrof name archname title slaying race 3175 insert remove inv nrof name archname title slaying race
3115 decrease split destroy change_exp)], 3176 decrease split destroy change_exp value msg lore send_msg)],
3116 ["cf::object::player" => qw(player)], 3177 ["cf::object::player" => qw(player)],
3117 ["cf::player" => qw(peaceful)], 3178 ["cf::player" => qw(peaceful send_msg)],
3118 ["cf::map" => qw(trigger)], 3179 ["cf::map" => qw(trigger)],
3119) { 3180) {
3120 no strict 'refs'; 3181 no strict 'refs';
3121 my ($pkg, @funs) = @$_; 3182 my ($pkg, @funs) = @$_;
3122 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3183 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
… …
3140 3201
3141 my $qcode = $code; 3202 my $qcode = $code;
3142 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3203 $qcode =~ s/"/‟/g; # not allowed in #line filenames
3143 $qcode =~ s/\n/\\n/g; 3204 $qcode =~ s/\n/\\n/g;
3144 3205
3206 %vars = (_dummy => 0) unless %vars;
3207
3208 my @res;
3145 local $_; 3209 local $_;
3146 local @safe::cf::_safe_eval_args = values %vars;
3147 3210
3148 my $eval = 3211 my $eval =
3149 "do {\n" 3212 "do {\n"
3150 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3213 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
3151 . "#line 0 \"{$qcode}\"\n" 3214 . "#line 0 \"{$qcode}\"\n"
3152 . $code 3215 . $code
3153 . "\n}" 3216 . "\n}"
3154 ; 3217 ;
3155 3218
3219 if ($CFG{safe_eval}) {
3156 sub_generation_inc; 3220 sub_generation_inc;
3221 local @safe::cf::_safe_eval_args = values %vars;
3157 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3222 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
3158 sub_generation_inc; 3223 sub_generation_inc;
3224 } else {
3225 local @cf::_safe_eval_args = values %vars;
3226 @res = wantarray ? eval eval : scalar eval $eval;
3227 }
3159 3228
3160 if ($@) { 3229 if ($@) {
3161 warn "$@"; 3230 warn "$@";
3162 warn "while executing safe code '$code'\n"; 3231 warn "while executing safe code '$code'\n";
3163 warn "with arguments " . (join " ", %vars) . "\n"; 3232 warn "with arguments " . (join " ", %vars) . "\n";
… …
3182=cut 3251=cut
3183 3252
3184sub register_script_function { 3253sub register_script_function {
3185 my ($fun, $cb) = @_; 3254 my ($fun, $cb) = @_;
3186 3255
3187 no strict 'refs'; 3256 $fun = "safe::$fun" if $CFG{safe_eval};
3188 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3257 *$fun = $safe_hole->wrap ($cb);
3189} 3258}
3190 3259
3191=back 3260=back
3192 3261
3193=cut 3262=cut
… …
3214 3283
3215 $facedata->{version} == 2 3284 $facedata->{version} == 2
3216 or cf::cleanup "$path: version mismatch, cannot proceed."; 3285 or cf::cleanup "$path: version mismatch, cannot proceed.";
3217 3286
3218 # patch in the exptable 3287 # patch in the exptable
3288 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3219 $facedata->{resource}{"res/exp_table"} = { 3289 $facedata->{resource}{"res/exp_table"} = {
3220 type => FT_RSRC, 3290 type => FT_RSRC,
3221 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]), 3291 data => $exp_table,
3292 hash => (Digest::MD5::md5 $exp_table),
3222 }; 3293 };
3223 cf::cede_to_tick; 3294 cf::cede_to_tick;
3224 3295
3225 { 3296 {
3226 my $faces = $facedata->{faceinfo}; 3297 my $faces = $facedata->{faceinfo};
… …
3228 while (my ($face, $info) = each %$faces) { 3299 while (my ($face, $info) = each %$faces) {
3229 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3300 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3230 3301
3231 cf::face::set_visibility $idx, $info->{visibility}; 3302 cf::face::set_visibility $idx, $info->{visibility};
3232 cf::face::set_magicmap $idx, $info->{magicmap}; 3303 cf::face::set_magicmap $idx, $info->{magicmap};
3233 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3304 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3234 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3305 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3235 3306
3236 cf::cede_to_tick; 3307 cf::cede_to_tick;
3237 } 3308 }
3238 3309
3239 while (my ($face, $info) = each %$faces) { 3310 while (my ($face, $info) = each %$faces) {
… …
3263 3334
3264 cf::anim::invalidate_all; # d'oh 3335 cf::anim::invalidate_all; # d'oh
3265 } 3336 }
3266 3337
3267 { 3338 {
3268 # TODO: for gcfclient pleasure, we should give resources
3269 # that gcfclient doesn't grok a >10000 face index.
3270 my $res = $facedata->{resource}; 3339 my $res = $facedata->{resource};
3271 3340
3272 while (my ($name, $info) = each %$res) { 3341 while (my ($name, $info) = each %$res) {
3273 if (defined $info->{type}) { 3342 if (defined $info->{type}) {
3274 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3343 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3275 my $data;
3276 3344
3277 if ($info->{type} & 1) { 3345 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3278 # prepend meta info
3279
3280 my $meta = $enc->encode ({
3281 name => $name,
3282 %{ $info->{meta} || {} },
3283 });
3284
3285 $data = pack "(w/a*)*", $meta, $info->{data};
3286 } else {
3287 $data = $info->{data};
3288 }
3289
3290 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3291 cf::face::set_type $idx, $info->{type}; 3346 cf::face::set_type $idx, $info->{type};
3292 } else { 3347 } else {
3293 $RESOURCE{$name} = $info; 3348 $RESOURCE{$name} = $info;
3294 } 3349 }
3295 3350
… …
3379 3434
3380 warn "finished reloading resource files\n"; 3435 warn "finished reloading resource files\n";
3381} 3436}
3382 3437
3383sub reload_config { 3438sub reload_config {
3439 warn "reloading config file...\n";
3440
3384 open my $fh, "<:utf8", "$CONFDIR/config" 3441 open my $fh, "<:utf8", "$CONFDIR/config"
3385 or return; 3442 or return;
3386 3443
3387 local $/; 3444 local $/;
3388 *CFG = YAML::Load <$fh>; 3445 *CFG = YAML::XS::Load scalar <$fh>;
3389 3446
3390 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3447 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
3391 3448
3392 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3449 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3393 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3450 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
… …
3397 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 3454 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3398 and die "WARNING: m(un)lockall failed: $!\n"; 3455 and die "WARNING: m(un)lockall failed: $!\n";
3399 }; 3456 };
3400 warn $@ if $@; 3457 warn $@ if $@;
3401 } 3458 }
3459
3460 warn "finished reloading resource files\n";
3402} 3461}
3403 3462
3404sub pidfile() { 3463sub pidfile() {
3405 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT 3464 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3406 or die "$PIDFILE: $!"; 3465 or die "$PIDFILE: $!";
… …
3418 3477
3419 seek $fh, 0, 0; 3478 seek $fh, 0, 0;
3420 print $fh $$; 3479 print $fh $$;
3421} 3480}
3422 3481
3482sub main_loop {
3483 warn "EV::loop starting\n";
3484 if (1) {
3485 EV::loop;
3486 }
3487 warn "EV::loop returned\n";
3488 goto &main_loop unless $REALLY_UNLOOP;
3489}
3490
3423sub main { 3491sub main {
3424 cf::init_globals; # initialise logging 3492 cf::init_globals; # initialise logging
3425 3493
3426 LOG llevInfo, "Welcome to Deliantra, v" . VERSION; 3494 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3427 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team."; 3495 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
… …
3430 3498
3431 cf::init_experience; 3499 cf::init_experience;
3432 cf::init_anim; 3500 cf::init_anim;
3433 cf::init_attackmess; 3501 cf::init_attackmess;
3434 cf::init_dynamic; 3502 cf::init_dynamic;
3435 cf::init_block;
3436 3503
3437 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3504 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3438 3505
3439 # we must not ever block the main coroutine 3506 # we must not ever block the main coroutine
3440 local $Coro::idle = sub { 3507 local $Coro::idle = sub {
… …
3446 }; 3513 };
3447 3514
3448 evthread_start IO::AIO::poll_fileno; 3515 evthread_start IO::AIO::poll_fileno;
3449 3516
3450 cf::sync_job { 3517 cf::sync_job {
3518 cf::load_settings;
3519 cf::load_materials;
3520
3451 reload_resources; 3521 reload_resources;
3452 reload_config; 3522 reload_config;
3453 db_init; 3523 db_init;
3454 3524
3455 cf::load_settings;
3456 cf::load_materials;
3457 cf::init_uuid; 3525 cf::init_uuid;
3458 cf::init_signals; 3526 cf::init_signals;
3459 cf::init_commands; 3527 cf::init_commands;
3460 cf::init_skills; 3528 cf::init_skills;
3461 3529
… …
3466 load_extensions; 3534 load_extensions;
3467 3535
3468 utime time, time, $RUNTIMEFILE; 3536 utime time, time, $RUNTIMEFILE;
3469 3537
3470 # no (long-running) fork's whatsoever before this point(!) 3538 # no (long-running) fork's whatsoever before this point(!)
3539 use POSIX ();
3471 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD}; 3540 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3472 3541
3473 (pop @POST_INIT)->(0) while @POST_INIT; 3542 (pop @POST_INIT)->(0) while @POST_INIT;
3474 }; 3543 };
3475 3544
3476 EV::loop; 3545 main_loop;
3477} 3546}
3478 3547
3479############################################################################# 3548#############################################################################
3480# initialisation and cleanup 3549# initialisation and cleanup
3481 3550
… …
3737 clear_package "safe::$_" 3806 clear_package "safe::$_"
3738 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3807 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3739 3808
3740 warn "unloading cf.pm \"a bit\""; 3809 warn "unloading cf.pm \"a bit\"";
3741 delete $INC{"cf.pm"}; 3810 delete $INC{"cf.pm"};
3742 delete $INC{"cf/pod.pm"}; 3811 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3743 3812
3744 # don't, removes xs symbols, too, 3813 # don't, removes xs symbols, too,
3745 # and global variables created in xs 3814 # and global variables created in xs
3746 #clear_package __PACKAGE__; 3815 #clear_package __PACKAGE__;
3747 3816
3748 warn "unload completed, starting to reload now"; 3817 warn "unload completed, starting to reload now";
3749 3818
3750 warn "reloading cf.pm"; 3819 warn "reloading cf.pm";
3751 require cf; 3820 require cf;
3752 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3821 cf::_connect_to_perl_1;
3753 3822
3754 warn "loading config and database again"; 3823 warn "loading config and database again";
3755 cf::reload_config; 3824 cf::reload_config;
3756 3825
3757 warn "loading extensions"; 3826 warn "loading extensions";
… …
3819 3888
3820our @WAIT_FOR_TICK; 3889our @WAIT_FOR_TICK;
3821our @WAIT_FOR_TICK_BEGIN; 3890our @WAIT_FOR_TICK_BEGIN;
3822 3891
3823sub wait_for_tick { 3892sub wait_for_tick {
3824 return if tick_inhibit || $Coro::current == $Coro::main; 3893 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3825 3894
3826 my $signal = new Coro::Signal; 3895 my $signal = new Coro::Signal;
3827 push @WAIT_FOR_TICK, $signal; 3896 push @WAIT_FOR_TICK, $signal;
3828 $signal->wait; 3897 $signal->wait;
3829} 3898}
3830 3899
3831sub wait_for_tick_begin { 3900sub wait_for_tick_begin {
3832 return if tick_inhibit || $Coro::current == $Coro::main; 3901 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3833 3902
3834 my $signal = new Coro::Signal; 3903 my $signal = new Coro::Signal;
3835 push @WAIT_FOR_TICK_BEGIN, $signal; 3904 push @WAIT_FOR_TICK_BEGIN, $signal;
3836 $signal->wait; 3905 $signal->wait;
3837} 3906}
… …
3964 LOG llevInfo, "[ABT] [suppressed]\n"; 4033 LOG llevInfo, "[ABT] [suppressed]\n";
3965 } 4034 }
3966} 4035}
3967 4036
3968# load additional modules 4037# load additional modules
3969use cf::pod; 4038require "cf/$_.pm" for @EXTRA_MODULES;
4039cf::_connect_to_perl_2;
3970 4040
3971END { cf::emergency_save } 4041END { cf::emergency_save }
3972 4042
39731 40431
3974 4044

Diff Legend

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