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.494 by root, Mon Oct 26 05:18:00 2009 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 ();
… …
52use JSON::XS 2.01 (); 55use JSON::XS 2.01 ();
53use BDB (); 56use BDB ();
54use Data::Dumper; 57use Data::Dumper;
55use Digest::MD5; 58use Digest::MD5;
56use Fcntl; 59use Fcntl;
57use YAML (); 60use YAML::XS ();
58use IO::AIO (); 61use IO::AIO ();
59use Time::HiRes; 62use Time::HiRes;
60use Compress::LZF; 63use Compress::LZF;
61use Digest::MD5 (); 64use Digest::MD5 ();
62 65
… …
70$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 73$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
71 74
72# make sure c-lzf reinitialises itself 75# make sure c-lzf reinitialises itself
73Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve"; 76Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";
74Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 77Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
78
79# strictly for debugging
80$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
75 81
76sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 82sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
77 83
78our %COMMAND = (); 84our %COMMAND = ();
79our %COMMAND_TIME = (); 85our %COMMAND_TIME = ();
… …
84our %EXT_CORO = (); # coroutines bound to extensions 90our %EXT_CORO = (); # coroutines bound to extensions
85our %EXT_MAP = (); # pluggable maps 91our %EXT_MAP = (); # pluggable maps
86 92
87our $RELOAD; # number of reloads so far, non-zero while in reload 93our $RELOAD; # number of reloads so far, non-zero while in reload
88our @EVENT; 94our @EVENT;
95our @REFLECT; # set by XS
96our %REFLECT; # set by us
89 97
90our $CONFDIR = confdir; 98our $CONFDIR = confdir;
91our $DATADIR = datadir; 99our $DATADIR = datadir;
92our $LIBDIR = "$DATADIR/ext"; 100our $LIBDIR = "$DATADIR/ext";
93our $PODDIR = "$DATADIR/pod"; 101our $PODDIR = "$DATADIR/pod";
… …
104our %RESOURCE; 112our %RESOURCE;
105 113
106our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 114our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
107our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 115our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
108our $NEXT_TICK; 116our $NEXT_TICK;
109our $USE_FSYNC = 1; # use fsync to write maps - default off 117our $USE_FSYNC = 1; # use fsync to write maps - default on
110 118
111our $BDB_DEADLOCK_WATCHER; 119our $BDB_DEADLOCK_WATCHER;
112our $BDB_CHECKPOINT_WATCHER; 120our $BDB_CHECKPOINT_WATCHER;
113our $BDB_TRICKLE_WATCHER; 121our $BDB_TRICKLE_WATCHER;
114our $DB_ENV; 122our $DB_ENV;
115 123
124our @EXTRA_MODULES = qw(pod match mapscript);
125
116our %CFG; 126our %CFG;
117 127
118our $UPTIME; $UPTIME ||= time; 128our $UPTIME; $UPTIME ||= time;
119our $RUNTIME; 129our $RUNTIME;
120our $NOW; 130our $NOW;
… …
131our $JITTER; # average jitter 141our $JITTER; # average jitter
132our $TICK_START; # for load detecting purposes 142our $TICK_START; # for load detecting purposes
133 143
134our @POST_INIT; 144our @POST_INIT;
135 145
136our $REATTACH_ON_RELOAD; # ste to true to force object reattach on reload (slow) 146our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
147our $REALLY_UNLOOP; # never set to true, please :)
137 148
138binmode STDOUT; 149binmode STDOUT;
139binmode STDERR; 150binmode STDERR;
140 151
141# read virtual server time, if available 152# read virtual server time, if available
… …
143 open my $fh, "<", $RUNTIMEFILE 154 open my $fh, "<", $RUNTIMEFILE
144 or die "unable to read $RUNTIMEFILE file: $!"; 155 or die "unable to read $RUNTIMEFILE file: $!";
145 $RUNTIME = <$fh> + 0.; 156 $RUNTIME = <$fh> + 0.;
146} 157}
147 158
159eval "sub TICK() { $TICK } 1" or die;
160
148mkdir $_ 161mkdir $_
149 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR; 162 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
150 163
151our $EMERGENCY_POSITION; 164our $EMERGENCY_POSITION;
152 165
153sub cf::map::normalise; 166sub cf::map::normalise;
167
168#############################################################################
169
170%REFLECT = ();
171for (@REFLECT) {
172 my $reflect = JSON::XS::decode_json $_;
173 $REFLECT{$reflect->{class}} = $reflect;
174}
175
176# this is decidedly evil
177$REFLECT{object}{flags} = { map +($_ => undef), grep $_, map /^FLAG_([A-Z0-9_]+)$/ && lc $1, keys %{"cf::"} };
154 178
155############################################################################# 179#############################################################################
156 180
157=head2 GLOBAL VARIABLES 181=head2 GLOBAL VARIABLES
158 182
… …
205returns directly I<after> the tick processing (and consequently, can only wake one process 229returns 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. 230per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
207 231
208=item @cf::INVOKE_RESULTS 232=item @cf::INVOKE_RESULTS
209 233
210This array contains the results of the last C<invoke ()> call. When 234This 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 235C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
212that call. 236that call.
213 237
238=item %cf::REFLECT
239
240Contains, for each (C++) class name, a hash reference with information
241about object members (methods, scalars, arrays and flags) and other
242metadata, which is useful for introspection.
243
214=back 244=back
215 245
216=cut 246=cut
217 247
218BEGIN { 248$Coro::State::WARNHOOK = sub {
219 *CORE::GLOBAL::warn = sub {
220 my $msg = join "", @_; 249 my $msg = join "", @_;
221 250
222 $msg .= "\n" 251 $msg .= "\n"
223 unless $msg =~ /\n$/; 252 unless $msg =~ /\n$/;
224 253
225 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 254 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
226 255
227 LOG llevError, $msg; 256 LOG llevError, $msg;
228 }; 257};
229}
230 258
231$Coro::State::DIEHOOK = sub { 259$Coro::State::DIEHOOK = sub {
232 return unless $^S eq 0; # "eq", not "==" 260 return unless $^S eq 0; # "eq", not "=="
261
262 warn Carp::longmess $_[0];
233 263
234 if ($Coro::current == $Coro::main) {#d# 264 if ($Coro::current == $Coro::main) {#d#
235 warn "DIEHOOK called in main context, Coro bug?\n";#d# 265 warn "DIEHOOK called in main context, Coro bug?\n";#d#
236 return;#d# 266 return;#d#
237 }#d# 267 }#d#
238 268
239 # kill coroutine otherwise 269 # kill coroutine otherwise
240 warn Carp::longmess $_[0];
241 Coro::terminate 270 Coro::terminate
242}; 271};
243
244$SIG{__DIE__} = sub { }; #d#?
245 272
246@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 273@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
247@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 274@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
248@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 275@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
249@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 276@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
… …
263)) { 290)) {
264 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 291 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
265} 292}
266 293
267$EV::DIED = sub { 294$EV::DIED = sub {
268 warn "error in event callback: @_"; 295 Carp::cluck "error in event callback: @_";
269}; 296};
270 297
271############################################################################# 298#############################################################################
272 299
273=head2 UTILITY FUNCTIONS 300=head2 UTILITY FUNCTIONS
… …
347 374
348Return true if the lock is currently active, i.e. somebody has locked it. 375Return true if the lock is currently active, i.e. somebody has locked it.
349 376
350=cut 377=cut
351 378
352our %LOCK; 379our $LOCKS = new Coro::SemaphoreSet;
353our %LOCKER;#d#
354 380
355sub lock_wait($) { 381sub lock_wait($) {
356 my ($key) = @_; 382 $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} 383}
370 384
371sub lock_acquire($) { 385sub lock_acquire($) {
372 my ($key) = @_; 386 $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} 387}
386 388
387sub lock_active($) { 389sub lock_active($) {
388 my ($key) = @_; 390 $LOCKS->count ($_[0]) < 1
389
390 ! ! $LOCK{$key}
391} 391}
392 392
393sub freeze_mainloop { 393sub freeze_mainloop {
394 tick_inhibit_inc; 394 tick_inhibit_inc;
395 395
… …
1173 $decname, length $$rdata, scalar @$objs; 1173 $decname, length $$rdata, scalar @$objs;
1174 1174
1175 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1175 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1176 aio_chmod $fh, SAVE_MODE; 1176 aio_chmod $fh, SAVE_MODE;
1177 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1177 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1178 aio_fsync $fh if $cf::USE_FSYNC; 1178 if ($cf::USE_FSYNC) {
1179 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;
1180 aio_fsync $fh;
1181 }
1179 aio_close $fh; 1182 aio_close $fh;
1180 1183
1181 if (@$objs) { 1184 if (@$objs) {
1182 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1185 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1183 aio_chmod $fh, SAVE_MODE; 1186 aio_chmod $fh, SAVE_MODE;
1184 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs }; 1187 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1185 aio_write $fh, 0, (length $data), $data, 0; 1188 aio_write $fh, 0, (length $data), $data, 0;
1186 aio_fsync $fh if $cf::USE_FSYNC; 1189 if ($cf::USE_FSYNC) {
1190 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;
1191 aio_fsync $fh;
1192 }
1187 aio_close $fh; 1193 aio_close $fh;
1188 aio_rename "$filename.pst~", "$filename.pst"; 1194 aio_rename "$filename.pst~", "$filename.pst";
1189 } 1195 }
1190 } else { 1196 } else {
1191 aio_unlink "$filename.pst"; 1197 aio_unlink "$filename.pst";
… …
1194 aio_rename "$filename~", $filename; 1200 aio_rename "$filename~", $filename;
1195 1201
1196 $filename =~ s%/[^/]+$%%; 1202 $filename =~ s%/[^/]+$%%;
1197 aio_pathsync $filename if $cf::USE_FSYNC; 1203 aio_pathsync $filename if $cf::USE_FSYNC;
1198 } else { 1204 } else {
1199 warn "FATAL: $filename~: $!\n"; 1205 warn "unable to save objects: $filename~: $!\n";
1200 } 1206 }
1201 } else { 1207 } else {
1202 aio_unlink $filename; 1208 aio_unlink $filename;
1203 aio_unlink "$filename.pst"; 1209 aio_unlink "$filename.pst";
1204 } 1210 }
… …
1342 1348
1343# "readahead" all extensions 1349# "readahead" all extensions
1344sub cache_extensions { 1350sub cache_extensions {
1345 my $grp = IO::AIO::aio_group; 1351 my $grp = IO::AIO::aio_group;
1346 1352
1347 add $grp IO::AIO::aio_readdir $LIBDIR, sub { 1353 add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
1348 for (grep /\.ext$/, @{$_[0]}) { 1354 for (grep /\.ext$/, @{$_[0]}) {
1349 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data; 1355 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
1350 } 1356 }
1351 }; 1357 };
1352 1358
… …
1888 1894
1889 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go; 1895 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1890 "$UNIQUEDIR/$path" 1896 "$UNIQUEDIR/$path"
1891} 1897}
1892 1898
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 { 1899sub decay_objects {
1903 my ($self) = @_; 1900 my ($self) = @_;
1904 1901
1905 return if $self->{deny_reset}; 1902 return if $self->{deny_reset};
1906 1903
… …
1988sub find { 1985sub find {
1989 my ($path, $origin) = @_; 1986 my ($path, $origin) = @_;
1990 1987
1991 $path = normalise $path, $origin && $origin->path; 1988 $path = normalise $path, $origin && $origin->path;
1992 1989
1993 cf::lock_wait "map_data:$path";#d#remove 1990 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1994 cf::lock_wait "map_find:$path"; 1991 my $guard2 = cf::lock_acquire "map_find:$path";
1995 1992
1996 $cf::MAP{$path} || do { 1993 $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 1994 my $map = new_from_path cf::map $path
2001 or return; 1995 or return;
2002 1996
2003 $map->{last_save} = $cf::RUNTIME; 1997 $map->{last_save} = $cf::RUNTIME;
2004 1998
… …
2072 unless ($self->{deny_activate}) { 2066 unless ($self->{deny_activate}) {
2073 $self->decay_objects; 2067 $self->decay_objects;
2074 $self->fix_auto_apply; 2068 $self->fix_auto_apply;
2075 $self->update_buttons; 2069 $self->update_buttons;
2076 cf::cede_to_tick; 2070 cf::cede_to_tick;
2077 $self->set_darkness_map;
2078 cf::cede_to_tick;
2079 $self->activate; 2071 $self->activate;
2080 } 2072 }
2081 2073
2082 $self->{last_save} = $cf::RUNTIME; 2074 $self->{last_save} = $cf::RUNTIME;
2083 $self->last_access ($cf::RUNTIME); 2075 $self->last_access ($cf::RUNTIME);
… …
2249 2241
2250 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2242 my $lock = cf::lock_acquire "map_data:$self->{path}";
2251 2243
2252 return if $self->players; 2244 return if $self->players;
2253 2245
2254 warn "resetting map ", $self->path; 2246 warn "resetting map ", $self->path, "\n";
2255 2247
2256 $self->in_memory (cf::MAP_SWAPPED); 2248 $self->in_memory (cf::MAP_SWAPPED);
2257 2249
2258 # need to save uniques path 2250 # need to save uniques path
2259 unless ($self->{deny_save}) { 2251 unless ($self->{deny_save}) {
… …
2350 : normalise $_ 2342 : normalise $_
2351 } @{ aio_readdir $UNIQUEDIR or [] } 2343 } @{ aio_readdir $UNIQUEDIR or [] }
2352 ] 2344 ]
2353} 2345}
2354 2346
2347=item cf::map::static_maps
2348
2349Returns an arrayref if paths of all static maps (all preinstalled F<.map>
2350file in the shared directory excluding F</styles> and F</editor>). May
2351block.
2352
2353=cut
2354
2355sub static_maps() {
2356 my @dirs = "";
2357 my @maps;
2358
2359 while (@dirs) {
2360 my $dir = shift @dirs;
2361
2362 next if $dir eq "/styles" || $dir eq "/editor";
2363
2364 my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
2365 or return;
2366
2367 for (@$files) {
2368 s/\.map$// or next;
2369 utf8::decode $_;
2370 push @maps, "$dir/$_";
2371 }
2372
2373 push @dirs, map "$dir/$_", @$dirs;
2374 }
2375
2376 \@maps
2377}
2378
2355=back 2379=back
2356 2380
2357=head3 cf::object 2381=head3 cf::object
2358 2382
2359=cut 2383=cut
… …
2424 2448
2425our $SAY_CHANNEL = { 2449our $SAY_CHANNEL = {
2426 id => "say", 2450 id => "say",
2427 title => "Map", 2451 title => "Map",
2428 reply => "say ", 2452 reply => "say ",
2429 tooltip => "Things said to and replied from npcs near you and other players on the same map only.", 2453 tooltip => "Things said to and replied from NPCs near you and other players on the same map only.",
2430}; 2454};
2431 2455
2432our $CHAT_CHANNEL = { 2456our $CHAT_CHANNEL = {
2433 id => "chat", 2457 id => "chat",
2434 title => "Chat", 2458 title => "Chat",
… …
2554 ($x, $y) = (-1, -1) 2578 ($x, $y) = (-1, -1)
2555 unless (defined $x) && (defined $y); 2579 unless (defined $x) && (defined $y);
2556 2580
2557 # use -1 or undef as default coordinates, not 0, 0 2581 # use -1 or undef as default coordinates, not 0, 0
2558 ($x, $y) = ($map->enter_x, $map->enter_y) 2582 ($x, $y) = ($map->enter_x, $map->enter_y)
2559 if $x <=0 && $y <= 0; 2583 if $x <= 0 && $y <= 0;
2560 2584
2561 $map->load; 2585 $map->load;
2562 $map->load_neighbours; 2586 $map->load_neighbours;
2563 2587
2564 return unless $self->contr->active; 2588 return unless $self->contr->active;
2565 $self->flag (cf::FLAG_DEBUG, 0);#d# temp
2566 $self->activate_recursive;
2567 2589
2568 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2590 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2569 $self->enter_map ($map, $x, $y); 2591 $self->enter_map ($map, $x, $y);
2592
2593 # only activate afterwards, to support waiting in hooks
2594 $self->activate_recursive;
2570} 2595}
2571 2596
2572=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]]) 2597=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2573 2598
2574Moves the player to the given map-path and coordinates by first freezing 2599Moves the player to the given map-path and coordinates by first freezing
… …
2762 2787
2763 utf8::encode $text; 2788 utf8::encode $text;
2764 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2789 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2765} 2790}
2766 2791
2792=item $client->send_big_packet ($pkt)
2793
2794Like C<send_packet>, but tries to compress large packets, and fragments
2795them as required.
2796
2797=cut
2798
2799our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
2800
2801sub cf::client::send_big_packet {
2802 my ($self, $pkt) = @_;
2803
2804 # try lzf for large packets
2805 $pkt = "lzf " . Compress::LZF::compress $pkt
2806 if 1024 <= length $pkt and $self->{can_lzf};
2807
2808 # split very large packets
2809 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
2810 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
2811 $pkt = "frag";
2812 }
2813
2814 $self->send_packet ($pkt);
2815}
2816
2767=item $client->send_msg ($channel, $msg, $color, [extra...]) 2817=item $client->send_msg ($channel, $msg, $color, [extra...])
2768 2818
2769Send a drawinfo or msg packet to the client, formatting the msg for the 2819Send 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 2820client 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 2821the message, with C<log> being the default. If C<$color> is negative, suppress
… …
2773 2823
2774=cut 2824=cut
2775 2825
2776# non-persistent channels (usually the info channel) 2826# non-persistent channels (usually the info channel)
2777our %CHANNEL = ( 2827our %CHANNEL = (
2828 "c/motd" => {
2829 id => "infobox",
2830 title => "MOTD",
2831 reply => undef,
2832 tooltip => "The message of the day",
2833 },
2778 "c/identify" => { 2834 "c/identify" => {
2779 id => "infobox", 2835 id => "infobox",
2780 title => "Identify", 2836 title => "Identify",
2781 reply => undef, 2837 reply => undef,
2782 tooltip => "Items recently identified", 2838 tooltip => "Items recently identified",
… …
2784 "c/examine" => { 2840 "c/examine" => {
2785 id => "infobox", 2841 id => "infobox",
2786 title => "Examine", 2842 title => "Examine",
2787 reply => undef, 2843 reply => undef,
2788 tooltip => "Signs and other items you examined", 2844 tooltip => "Signs and other items you examined",
2845 },
2846 "c/shopinfo" => {
2847 id => "infobox",
2848 title => "Shop Info",
2849 reply => undef,
2850 tooltip => "What your bargaining skill tells you about the shop",
2789 }, 2851 },
2790 "c/book" => { 2852 "c/book" => {
2791 id => "infobox", 2853 id => "infobox",
2792 title => "Book", 2854 title => "Book",
2793 reply => undef, 2855 reply => undef,
… …
2809 id => "infobox", 2871 id => "infobox",
2810 title => "Body Parts", 2872 title => "Body Parts",
2811 reply => undef, 2873 reply => undef,
2812 tooltip => "Shows which body parts you posess and are available", 2874 tooltip => "Shows which body parts you posess and are available",
2813 }, 2875 },
2876 "c/statistics" => {
2877 id => "infobox",
2878 title => "Statistics",
2879 reply => undef,
2880 tooltip => "Shows your primary statistics",
2881 },
2814 "c/skills" => { 2882 "c/skills" => {
2815 id => "infobox", 2883 id => "infobox",
2816 title => "Skills", 2884 title => "Skills",
2817 reply => undef, 2885 reply => undef,
2818 tooltip => "Shows your experience per skill and item power", 2886 tooltip => "Shows your experience per skill and item power",
2887 },
2888 "c/shopitems" => {
2889 id => "infobox",
2890 title => "Shop Items",
2891 reply => undef,
2892 tooltip => "Shows the items currently for sale in this shop",
2893 },
2894 "c/resistances" => {
2895 id => "infobox",
2896 title => "Resistances",
2897 reply => undef,
2898 tooltip => "Shows your resistances",
2899 },
2900 "c/pets" => {
2901 id => "infobox",
2902 title => "Pets",
2903 reply => undef,
2904 tooltip => "Shows information abotu your pets/a specific pet",
2905 },
2906 "c/perceiveself" => {
2907 id => "infobox",
2908 title => "Perceive Self",
2909 reply => undef,
2910 tooltip => "You gained detailed knowledge about yourself",
2819 }, 2911 },
2820 "c/uptime" => { 2912 "c/uptime" => {
2821 id => "infobox", 2913 id => "infobox",
2822 title => "Uptime", 2914 title => "Uptime",
2823 reply => undef, 2915 reply => undef,
… …
2833 id => "party", 2925 id => "party",
2834 title => "Party", 2926 title => "Party",
2835 reply => "gsay ", 2927 reply => "gsay ",
2836 tooltip => "Messages and chat related to your party", 2928 tooltip => "Messages and chat related to your party",
2837 }, 2929 },
2930 "c/death" => {
2931 id => "death",
2932 title => "Death",
2933 reply => undef,
2934 tooltip => "Reason for and more info about your most recent death",
2935 },
2936 "c/say" => $SAY_CHANNEL,
2937 "c/chat" => $CHAT_CHANNEL,
2838); 2938);
2839 2939
2840sub cf::client::send_msg { 2940sub cf::client::send_msg {
2841 my ($self, $channel, $msg, $color, @extra) = @_; 2941 my ($self, $channel, $msg, $color, @extra) = @_;
2842 2942
… …
2847 2947
2848 # check predefined channels, for the benefit of C 2948 # check predefined channels, for the benefit of C
2849 if ($CHANNEL{$channel}) { 2949 if ($CHANNEL{$channel}) {
2850 $channel = $CHANNEL{$channel}; 2950 $channel = $CHANNEL{$channel};
2851 2951
2852 $self->ext_msg (channel_info => $channel) 2952 $self->ext_msg (channel_info => $channel);
2853 if $self->can_msg;
2854
2855 $channel = $channel->{id}; 2953 $channel = $channel->{id};
2856 2954
2857 } elsif (ref $channel) { 2955 } elsif (ref $channel) {
2858 # send meta info to client, if not yet sent 2956 # send meta info to client, if not yet sent
2859 unless (exists $self->{channel}{$channel->{id}}) { 2957 unless (exists $self->{channel}{$channel->{id}}) {
2860 $self->{channel}{$channel->{id}} = $channel; 2958 $self->{channel}{$channel->{id}} = $channel;
2861 $self->ext_msg (channel_info => $channel) 2959 $self->ext_msg (channel_info => $channel);
2862 if $self->can_msg;
2863 } 2960 }
2864 2961
2865 $channel = $channel->{id}; 2962 $channel = $channel->{id};
2866 } 2963 }
2867 2964
2868 return unless @extra || length $msg; 2965 return unless @extra || length $msg;
2869 2966
2870 if ($self->can_msg) {
2871 # default colour, mask it out 2967 # default colour, mask it out
2872 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF) 2968 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2873 if $color & cf::NDI_DEF; 2969 if $color & cf::NDI_DEF;
2874 2970
2875 my $pkt = "msg " 2971 my $pkt = "msg "
2876 . $self->{json_coder}->encode ( 2972 . $self->{json_coder}->encode (
2877 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra] 2973 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2878 ); 2974 );
2879 2975
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); 2976 $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} 2977}
2917 2978
2918=item $client->ext_msg ($type, @msg) 2979=item $client->ext_msg ($type, @msg)
2919 2980
2920Sends an ext event to the client. 2981Sends an ext event to the client.
… …
2923 2984
2924sub cf::client::ext_msg($$@) { 2985sub cf::client::ext_msg($$@) {
2925 my ($self, $type, @msg) = @_; 2986 my ($self, $type, @msg) = @_;
2926 2987
2927 if ($self->extcmd == 2) { 2988 if ($self->extcmd == 2) {
2928 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 2989 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2929 } elsif ($self->extcmd == 1) { # TODO: remove 2990 } elsif ($self->extcmd == 1) { # TODO: remove
2930 push @msg, msgtype => "event_$type"; 2991 push @msg, msgtype => "event_$type";
2931 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 2992 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2932 } 2993 }
2933} 2994}
2934 2995
2935=item $client->ext_reply ($msgid, @msg) 2996=item $client->ext_reply ($msgid, @msg)
2936 2997
… …
2940 3001
2941sub cf::client::ext_reply($$@) { 3002sub cf::client::ext_reply($$@) {
2942 my ($self, $id, @msg) = @_; 3003 my ($self, $id, @msg) = @_;
2943 3004
2944 if ($self->extcmd == 2) { 3005 if ($self->extcmd == 2) {
2945 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg])); 3006 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2946 } elsif ($self->extcmd == 1) { 3007 } elsif ($self->extcmd == 1) {
2947 #TODO: version 1, remove 3008 #TODO: version 1, remove
2948 unshift @msg, msgtype => "reply", msgid => $id; 3009 unshift @msg, msgtype => "reply", msgid => $id;
2949 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3010 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2950 } 3011 }
2951} 3012}
2952 3013
2953=item $success = $client->query ($flags, "text", \&cb) 3014=item $success = $client->query ($flags, "text", \&cb)
2954 3015
… …
3095The following functions and methods are available within a safe environment: 3156The following functions and methods are available within a safe environment:
3096 3157
3097 cf::object 3158 cf::object
3098 contr pay_amount pay_player map x y force_find force_add destroy 3159 contr pay_amount pay_player map x y force_find force_add destroy
3099 insert remove name archname title slaying race decrease split 3160 insert remove name archname title slaying race decrease split
3161 value
3100 3162
3101 cf::object::player 3163 cf::object::player
3102 player 3164 player
3103 3165
3104 cf::player 3166 cf::player
… …
3110=cut 3172=cut
3111 3173
3112for ( 3174for (
3113 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3175 ["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 3176 insert remove inv nrof name archname title slaying race
3115 decrease split destroy change_exp)], 3177 decrease split destroy change_exp value msg lore send_msg)],
3116 ["cf::object::player" => qw(player)], 3178 ["cf::object::player" => qw(player)],
3117 ["cf::player" => qw(peaceful)], 3179 ["cf::player" => qw(peaceful send_msg)],
3118 ["cf::map" => qw(trigger)], 3180 ["cf::map" => qw(trigger)],
3119) { 3181) {
3120 no strict 'refs'; 3182 no strict 'refs';
3121 my ($pkg, @funs) = @$_; 3183 my ($pkg, @funs) = @$_;
3122 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3184 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
… …
3139 my ($code, %vars) = @_; 3201 my ($code, %vars) = @_;
3140 3202
3141 my $qcode = $code; 3203 my $qcode = $code;
3142 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3204 $qcode =~ s/"/‟/g; # not allowed in #line filenames
3143 $qcode =~ s/\n/\\n/g; 3205 $qcode =~ s/\n/\\n/g;
3206
3207 %vars = (_dummy => 0) unless %vars;
3144 3208
3145 local $_; 3209 local $_;
3146 local @safe::cf::_safe_eval_args = values %vars; 3210 local @safe::cf::_safe_eval_args = values %vars;
3147 3211
3148 my $eval = 3212 my $eval =
… …
3379 3443
3380 warn "finished reloading resource files\n"; 3444 warn "finished reloading resource files\n";
3381} 3445}
3382 3446
3383sub reload_config { 3447sub reload_config {
3448 warn "reloading config file...\n";
3449
3384 open my $fh, "<:utf8", "$CONFDIR/config" 3450 open my $fh, "<:utf8", "$CONFDIR/config"
3385 or return; 3451 or return;
3386 3452
3387 local $/; 3453 local $/;
3388 *CFG = YAML::Load <$fh>; 3454 *CFG = YAML::XS::Load scalar <$fh>;
3389 3455
3390 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3456 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
3391 3457
3392 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3458 $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}; 3459 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
… …
3397 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 3463 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3398 and die "WARNING: m(un)lockall failed: $!\n"; 3464 and die "WARNING: m(un)lockall failed: $!\n";
3399 }; 3465 };
3400 warn $@ if $@; 3466 warn $@ if $@;
3401 } 3467 }
3468
3469 warn "finished reloading resource files\n";
3402} 3470}
3403 3471
3404sub pidfile() { 3472sub pidfile() {
3405 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT 3473 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3406 or die "$PIDFILE: $!"; 3474 or die "$PIDFILE: $!";
… …
3418 3486
3419 seek $fh, 0, 0; 3487 seek $fh, 0, 0;
3420 print $fh $$; 3488 print $fh $$;
3421} 3489}
3422 3490
3491sub main_loop {
3492 warn "EV::loop starting\n";
3493 if (1) {
3494 EV::loop;
3495 }
3496 warn "EV::loop returned\n";
3497 goto &main_loop unless $REALLY_UNLOOP;
3498}
3499
3423sub main { 3500sub main {
3424 cf::init_globals; # initialise logging 3501 cf::init_globals; # initialise logging
3425 3502
3426 LOG llevInfo, "Welcome to Deliantra, v" . VERSION; 3503 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3427 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team."; 3504 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
… …
3430 3507
3431 cf::init_experience; 3508 cf::init_experience;
3432 cf::init_anim; 3509 cf::init_anim;
3433 cf::init_attackmess; 3510 cf::init_attackmess;
3434 cf::init_dynamic; 3511 cf::init_dynamic;
3435 cf::init_block;
3436 3512
3437 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3513 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3438 3514
3439 # we must not ever block the main coroutine 3515 # we must not ever block the main coroutine
3440 local $Coro::idle = sub { 3516 local $Coro::idle = sub {
… …
3466 load_extensions; 3542 load_extensions;
3467 3543
3468 utime time, time, $RUNTIMEFILE; 3544 utime time, time, $RUNTIMEFILE;
3469 3545
3470 # no (long-running) fork's whatsoever before this point(!) 3546 # no (long-running) fork's whatsoever before this point(!)
3547 use POSIX ();
3471 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD}; 3548 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3472 3549
3473 (pop @POST_INIT)->(0) while @POST_INIT; 3550 (pop @POST_INIT)->(0) while @POST_INIT;
3474 }; 3551 };
3475 3552
3476 EV::loop; 3553 main_loop;
3477} 3554}
3478 3555
3479############################################################################# 3556#############################################################################
3480# initialisation and cleanup 3557# initialisation and cleanup
3481 3558
… …
3737 clear_package "safe::$_" 3814 clear_package "safe::$_"
3738 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3815 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3739 3816
3740 warn "unloading cf.pm \"a bit\""; 3817 warn "unloading cf.pm \"a bit\"";
3741 delete $INC{"cf.pm"}; 3818 delete $INC{"cf.pm"};
3742 delete $INC{"cf/pod.pm"}; 3819 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3743 3820
3744 # don't, removes xs symbols, too, 3821 # don't, removes xs symbols, too,
3745 # and global variables created in xs 3822 # and global variables created in xs
3746 #clear_package __PACKAGE__; 3823 #clear_package __PACKAGE__;
3747 3824
3748 warn "unload completed, starting to reload now"; 3825 warn "unload completed, starting to reload now";
3749 3826
3750 warn "reloading cf.pm"; 3827 warn "reloading cf.pm";
3751 require cf; 3828 require cf;
3752 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3829 cf::_connect_to_perl_1;
3753 3830
3754 warn "loading config and database again"; 3831 warn "loading config and database again";
3755 cf::reload_config; 3832 cf::reload_config;
3756 3833
3757 warn "loading extensions"; 3834 warn "loading extensions";
… …
3964 LOG llevInfo, "[ABT] [suppressed]\n"; 4041 LOG llevInfo, "[ABT] [suppressed]\n";
3965 } 4042 }
3966} 4043}
3967 4044
3968# load additional modules 4045# load additional modules
3969use cf::pod; 4046require "cf/$_.pm" for @EXTRA_MODULES;
4047cf::_connect_to_perl_2;
3970 4048
3971END { cf::emergency_save } 4049END { cf::emergency_save }
3972 4050
39731 40511
3974 4052

Diff Legend

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