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.512 by root, Sun Apr 11 04:52:07 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,2009,2010 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
… …
424 423
425=cut 424=cut
426 425
427our @SLOT_QUEUE; 426our @SLOT_QUEUE;
428our $SLOT_QUEUE; 427our $SLOT_QUEUE;
428our $SLOT_DECAY = 0.9;
429 429
430$SLOT_QUEUE->cancel if $SLOT_QUEUE; 430$SLOT_QUEUE->cancel if $SLOT_QUEUE;
431$SLOT_QUEUE = Coro::async { 431$SLOT_QUEUE = Coro::async {
432 $Coro::current->desc ("timeslot manager"); 432 $Coro::current->desc ("timeslot manager");
433 433
434 my $signal = new Coro::Signal; 434 my $signal = new Coro::Signal;
435 my $busy;
435 436
436 while () { 437 while () {
437 next_job: 438 next_job:
439
438 my $avail = cf::till_tick; 440 my $avail = cf::till_tick;
439 if ($avail > 0.01) { 441
440 for (0 .. $#SLOT_QUEUE) { 442 for (0 .. $#SLOT_QUEUE) {
441 if ($SLOT_QUEUE[$_][0] < $avail) { 443 if ($SLOT_QUEUE[$_][0] <= $avail) {
444 $busy = 0;
442 my $job = splice @SLOT_QUEUE, $_, 1, (); 445 my $job = splice @SLOT_QUEUE, $_, 1, ();
443 $job->[2]->send; 446 $job->[2]->send;
444 Coro::cede; 447 Coro::cede;
445 goto next_job; 448 goto next_job;
446 } 449 } else {
450 $SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
447 } 451 }
448 } 452 }
449 453
450 if (@SLOT_QUEUE) { 454 if (@SLOT_QUEUE) {
451 # we do not use wait_for_tick() as it returns immediately when tick is inactive 455 # we do not use wait_for_tick() as it returns immediately when tick is inactive
452 push @cf::WAIT_FOR_TICK, $signal; 456 push @cf::WAIT_FOR_TICK, $signal;
453 $signal->wait; 457 $signal->wait;
454 } else { 458 } else {
459 $busy = 0;
455 Coro::schedule; 460 Coro::schedule;
456 } 461 }
457 } 462 }
458}; 463};
459 464
460sub get_slot($;$$) { 465sub get_slot($;$$) {
461 return if tick_inhibit || $Coro::current == $Coro::main; 466 return if tick_inhibit || $Coro::current == $Coro::main;
462 467
463 my ($time, $pri, $name) = @_; 468 my ($time, $pri, $name) = @_;
464 469
465 $time = $TICK * .6 if $time > $TICK * .6; 470 $time = clamp $time, 0.01, $TICK * .6;
471
466 my $sig = new Coro::Signal; 472 my $sig = new Coro::Signal;
467 473
468 push @SLOT_QUEUE, [$time, $pri, $sig, $name]; 474 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
469 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE; 475 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
470 $SLOT_QUEUE->ready; 476 $SLOT_QUEUE->ready;
… …
497 503
498sub sync_job(&) { 504sub sync_job(&) {
499 my ($job) = @_; 505 my ($job) = @_;
500 506
501 if ($Coro::current == $Coro::main) { 507 if ($Coro::current == $Coro::main) {
502 my $time = EV::time; 508 my $time = AE::time;
503 509
504 # this is the main coro, too bad, we have to block 510 # this is the main coro, too bad, we have to block
505 # till the operation succeeds, freezing the server :/ 511 # till the operation succeeds, freezing the server :/
506 512
507 LOG llevError, Carp::longmess "sync job";#d# 513 LOG llevError, Carp::longmess "sync job";#d#
… …
524 } else { 530 } else {
525 EV::loop EV::LOOP_ONESHOT; 531 EV::loop EV::LOOP_ONESHOT;
526 } 532 }
527 } 533 }
528 534
529 my $time = EV::time - $time; 535 my $time = AE::time - $time;
530 536
531 $TICK_START += $time; # do not account sync jobs to server load 537 $TICK_START += $time; # do not account sync jobs to server load
532 538
533 wantarray ? @res : $res[0] 539 wantarray ? @res : $res[0]
534 } else { 540 } else {
… …
1173 $decname, length $$rdata, scalar @$objs; 1179 $decname, length $$rdata, scalar @$objs;
1174 1180
1175 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1181 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1176 aio_chmod $fh, SAVE_MODE; 1182 aio_chmod $fh, SAVE_MODE;
1177 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1183 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1178 aio_fsync $fh if $cf::USE_FSYNC; 1184 if ($cf::USE_FSYNC) {
1185 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;
1186 aio_fsync $fh;
1187 }
1179 aio_close $fh; 1188 aio_close $fh;
1180 1189
1181 if (@$objs) { 1190 if (@$objs) {
1182 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1191 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1183 aio_chmod $fh, SAVE_MODE; 1192 aio_chmod $fh, SAVE_MODE;
1184 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs }; 1193 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1185 aio_write $fh, 0, (length $data), $data, 0; 1194 aio_write $fh, 0, (length $data), $data, 0;
1186 aio_fsync $fh if $cf::USE_FSYNC; 1195 if ($cf::USE_FSYNC) {
1196 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;
1197 aio_fsync $fh;
1198 }
1187 aio_close $fh; 1199 aio_close $fh;
1188 aio_rename "$filename.pst~", "$filename.pst"; 1200 aio_rename "$filename.pst~", "$filename.pst";
1189 } 1201 }
1190 } else { 1202 } else {
1191 aio_unlink "$filename.pst"; 1203 aio_unlink "$filename.pst";
… …
1194 aio_rename "$filename~", $filename; 1206 aio_rename "$filename~", $filename;
1195 1207
1196 $filename =~ s%/[^/]+$%%; 1208 $filename =~ s%/[^/]+$%%;
1197 aio_pathsync $filename if $cf::USE_FSYNC; 1209 aio_pathsync $filename if $cf::USE_FSYNC;
1198 } else { 1210 } else {
1199 warn "FATAL: $filename~: $!\n"; 1211 warn "unable to save objects: $filename~: $!\n";
1200 } 1212 }
1201 } else { 1213 } else {
1202 aio_unlink $filename; 1214 aio_unlink $filename;
1203 aio_unlink "$filename.pst"; 1215 aio_unlink "$filename.pst";
1204 } 1216 }
… …
1298} 1310}
1299 1311
1300use File::Glob (); 1312use File::Glob ();
1301 1313
1302cf::player->attach ( 1314cf::player->attach (
1303 on_command => sub { 1315 on_unknown_command => sub {
1304 my ($pl, $name, $params) = @_; 1316 my ($pl, $name, $params) = @_;
1305 1317
1306 my $cb = $COMMAND{$name} 1318 my $cb = $COMMAND{$name}
1307 or return; 1319 or return;
1308 1320
… …
1342 1354
1343# "readahead" all extensions 1355# "readahead" all extensions
1344sub cache_extensions { 1356sub cache_extensions {
1345 my $grp = IO::AIO::aio_group; 1357 my $grp = IO::AIO::aio_group;
1346 1358
1347 add $grp IO::AIO::aio_readdir $LIBDIR, sub { 1359 add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
1348 for (grep /\.ext$/, @{$_[0]}) { 1360 for (grep /\.ext$/, @{$_[0]}) {
1349 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data; 1361 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
1350 } 1362 }
1351 }; 1363 };
1352 1364
… …
1387 . "\n};\n1"; 1399 . "\n};\n1";
1388 1400
1389 $todo{$base} = \%ext; 1401 $todo{$base} = \%ext;
1390 } 1402 }
1391 1403
1404 my $pass = 0;
1392 my %done; 1405 my %done;
1393 while (%todo) { 1406 while (%todo) {
1394 my $progress; 1407 my $progress;
1395 1408
1409 ++$pass;
1410
1411 ext:
1396 while (my ($k, $v) = each %todo) { 1412 while (my ($k, $v) = each %todo) {
1397 for (split /,\s*/, $v->{meta}{depends}) { 1413 for (split /,\s*/, $v->{meta}{depends}) {
1398 goto skip 1414 next ext
1399 unless exists $done{$_}; 1415 unless exists $done{$_};
1400 } 1416 }
1401 1417
1402 warn "... loading '$k' into '$v->{pkg}'\n"; 1418 warn "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1403 1419
1404 unless (eval $v->{source}) { 1420 my $active = eval $v->{source};
1421
1422 if (length $@) {
1405 my $msg = $@ ? "$v->{path}: $@\n" 1423 warn "$v->{path}: $@\n";
1406 : "$v->{base}: extension inactive.\n";
1407 1424
1408 if (exists $v->{meta}{mandatory}) {
1409 warn $msg;
1410 cf::cleanup "mandatory extension failed to load, exiting."; 1425 cf::cleanup "mandatory extension '$k' failed to load, exiting."
1411 } 1426 if exists $v->{meta}{mandatory};
1412 1427 } else {
1413 warn $msg; 1428 $done{$k} = delete $todo{$k};
1429 push @EXTS, $v->{pkg};
1430 $progress = 1;
1431
1432 warn "$v->{base}: extension inactive.\n"
1433 unless $active;
1414 } 1434 }
1415
1416 $done{$k} = delete $todo{$k};
1417 push @EXTS, $v->{pkg};
1418 $progress = 1;
1419 } 1435 }
1420 1436
1421 skip: 1437 unless ($progress) {
1422 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n" 1438 warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
1423 unless $progress; 1439
1440 while (my ($k, $v) = each %todo) {
1441 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
1442 if exists $v->{meta}{mandatory};
1443 }
1444 }
1424 } 1445 }
1425 }; 1446 };
1426} 1447}
1427 1448
1428############################################################################# 1449#############################################################################
… …
1512 $cf::PLAYER{$login} = $pl 1533 $cf::PLAYER{$login} = $pl
1513 } 1534 }
1514 } 1535 }
1515} 1536}
1516 1537
1538cf::player->attach (
1539 on_load => sub {
1540 my ($pl, $path) = @_;
1541
1542 # restore slots saved in save, below
1543 my $slots = delete $pl->{_slots};
1544
1545 $pl->ob->current_weapon ($slots->[0]);
1546 $pl->combat_ob ($slots->[1]);
1547 $pl->ranged_ob ($slots->[2]);
1548 },
1549);
1550
1517sub save($) { 1551sub save($) {
1518 my ($pl) = @_; 1552 my ($pl) = @_;
1519 1553
1520 return if $pl->{deny_save}; 1554 return if $pl->{deny_save};
1521 1555
… …
1526 1560
1527 aio_mkdir playerdir $pl, 0770; 1561 aio_mkdir playerdir $pl, 0770;
1528 $pl->{last_save} = $cf::RUNTIME; 1562 $pl->{last_save} = $cf::RUNTIME;
1529 1563
1530 cf::get_slot 0.01; 1564 cf::get_slot 0.01;
1565
1566 # save slots, to be restored later
1567 local $pl->{_slots} = [$pl->ob->current_weapon, $pl->combat_ob, $pl->ranged_ob];
1531 1568
1532 $pl->save_pl ($path); 1569 $pl->save_pl ($path);
1533 cf::cede_to_tick; 1570 cf::cede_to_tick;
1534} 1571}
1535 1572
… …
1748 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM 1785 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1749 1786
1750 # mit "rum" bekleckern, nicht 1787 # mit "rum" bekleckern, nicht
1751 $self->_create_random_map ( 1788 $self->_create_random_map (
1752 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1789 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1753 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1790 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, $rmp->{miningstyle},
1754 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1791 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1755 $rmp->{exit_on_final_map}, 1792 $rmp->{exit_on_final_map},
1756 $rmp->{xsize}, $rmp->{ysize}, 1793 $rmp->{xsize}, $rmp->{ysize},
1757 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1794 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1758 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1795 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
… …
1888 1925
1889 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go; 1926 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1890 "$UNIQUEDIR/$path" 1927 "$UNIQUEDIR/$path"
1891} 1928}
1892 1929
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 { 1930sub decay_objects {
1903 my ($self) = @_; 1931 my ($self) = @_;
1904 1932
1905 return if $self->{deny_reset}; 1933 return if $self->{deny_reset};
1906 1934
… …
1988sub find { 2016sub find {
1989 my ($path, $origin) = @_; 2017 my ($path, $origin) = @_;
1990 2018
1991 $path = normalise $path, $origin && $origin->path; 2019 $path = normalise $path, $origin && $origin->path;
1992 2020
1993 cf::lock_wait "map_data:$path";#d#remove 2021 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1994 cf::lock_wait "map_find:$path"; 2022 my $guard2 = cf::lock_acquire "map_find:$path";
1995 2023
1996 $cf::MAP{$path} || do { 2024 $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 2025 my $map = new_from_path cf::map $path
2001 or return; 2026 or return;
2002 2027
2003 $map->{last_save} = $cf::RUNTIME; 2028 $map->{last_save} = $cf::RUNTIME;
2004 2029
… …
2016 2041
2017 $cf::MAP{$path} = $map 2042 $cf::MAP{$path} = $map
2018 } 2043 }
2019} 2044}
2020 2045
2021sub pre_load { } 2046sub pre_load { }
2022sub post_load { } 2047#sub post_load { } # XS
2023 2048
2024sub load { 2049sub load {
2025 my ($self) = @_; 2050 my ($self) = @_;
2026 2051
2027 local $self->{deny_reset} = 1; # loading can take a long time 2052 local $self->{deny_reset} = 1; # loading can take a long time
… …
2072 unless ($self->{deny_activate}) { 2097 unless ($self->{deny_activate}) {
2073 $self->decay_objects; 2098 $self->decay_objects;
2074 $self->fix_auto_apply; 2099 $self->fix_auto_apply;
2075 $self->update_buttons; 2100 $self->update_buttons;
2076 cf::cede_to_tick; 2101 cf::cede_to_tick;
2077 $self->set_darkness_map;
2078 cf::cede_to_tick;
2079 $self->activate; 2102 $self->activate;
2080 } 2103 }
2081 2104
2082 $self->{last_save} = $cf::RUNTIME; 2105 $self->{last_save} = $cf::RUNTIME;
2083 $self->last_access ($cf::RUNTIME); 2106 $self->last_access ($cf::RUNTIME);
… …
2086 } 2109 }
2087 2110
2088 $self->post_load; 2111 $self->post_load;
2089} 2112}
2090 2113
2114# customize the map for a given player, i.e.
2115# return the _real_ map. used by e.g. per-player
2116# maps to change the path to ~playername/mappath
2091sub customise_for { 2117sub customise_for {
2092 my ($self, $ob) = @_; 2118 my ($self, $ob) = @_;
2093 2119
2094 return find "~" . $ob->name . "/" . $self->{path} 2120 return find "~" . $ob->name . "/" . $self->{path}
2095 if $self->per_player; 2121 if $self->per_player;
… …
2249 2275
2250 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2276 my $lock = cf::lock_acquire "map_data:$self->{path}";
2251 2277
2252 return if $self->players; 2278 return if $self->players;
2253 2279
2254 warn "resetting map ", $self->path; 2280 warn "resetting map ", $self->path, "\n";
2255 2281
2256 $self->in_memory (cf::MAP_SWAPPED); 2282 $self->in_memory (cf::MAP_SWAPPED);
2257 2283
2258 # need to save uniques path 2284 # need to save uniques path
2259 unless ($self->{deny_save}) { 2285 unless ($self->{deny_save}) {
… …
2350 : normalise $_ 2376 : normalise $_
2351 } @{ aio_readdir $UNIQUEDIR or [] } 2377 } @{ aio_readdir $UNIQUEDIR or [] }
2352 ] 2378 ]
2353} 2379}
2354 2380
2381=item cf::map::static_maps
2382
2383Returns an arrayref if paths of all static maps (all preinstalled F<.map>
2384file in the shared directory excluding F</styles> and F</editor>). May
2385block.
2386
2387=cut
2388
2389sub static_maps() {
2390 my @dirs = "";
2391 my @maps;
2392
2393 while (@dirs) {
2394 my $dir = shift @dirs;
2395
2396 next if $dir eq "/styles" || $dir eq "/editor";
2397
2398 my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
2399 or return;
2400
2401 for (@$files) {
2402 s/\.map$// or next;
2403 utf8::decode $_;
2404 push @maps, "$dir/$_";
2405 }
2406
2407 push @dirs, map "$dir/$_", @$dirs;
2408 }
2409
2410 \@maps
2411}
2412
2355=back 2413=back
2356 2414
2357=head3 cf::object 2415=head3 cf::object
2358 2416
2359=cut 2417=cut
… …
2424 2482
2425our $SAY_CHANNEL = { 2483our $SAY_CHANNEL = {
2426 id => "say", 2484 id => "say",
2427 title => "Map", 2485 title => "Map",
2428 reply => "say ", 2486 reply => "say ",
2429 tooltip => "Things said to and replied from npcs near you and other players on the same map only.", 2487 tooltip => "Things said to and replied from NPCs near you and other players on the same map only.",
2430}; 2488};
2431 2489
2432our $CHAT_CHANNEL = { 2490our $CHAT_CHANNEL = {
2433 id => "chat", 2491 id => "chat",
2434 title => "Chat", 2492 title => "Chat",
… …
2554 ($x, $y) = (-1, -1) 2612 ($x, $y) = (-1, -1)
2555 unless (defined $x) && (defined $y); 2613 unless (defined $x) && (defined $y);
2556 2614
2557 # use -1 or undef as default coordinates, not 0, 0 2615 # use -1 or undef as default coordinates, not 0, 0
2558 ($x, $y) = ($map->enter_x, $map->enter_y) 2616 ($x, $y) = ($map->enter_x, $map->enter_y)
2559 if $x <=0 && $y <= 0; 2617 if $x <= 0 && $y <= 0;
2560 2618
2561 $map->load; 2619 $map->load;
2562 $map->load_neighbours; 2620 $map->load_neighbours;
2563 2621
2564 return unless $self->contr->active; 2622 return unless $self->contr->active;
2565 $self->flag (cf::FLAG_DEBUG, 0);#d# temp
2566 $self->activate_recursive;
2567 2623
2568 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2624 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2569 $self->enter_map ($map, $x, $y); 2625 $self->enter_map ($map, $x, $y);
2626
2627 # only activate afterwards, to support waiting in hooks
2628 $self->activate_recursive;
2570} 2629}
2571 2630
2572=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]]) 2631=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2573 2632
2574Moves the player to the given map-path and coordinates by first freezing 2633Moves the player to the given map-path and coordinates by first freezing
… …
2762 2821
2763 utf8::encode $text; 2822 utf8::encode $text;
2764 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2823 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2765} 2824}
2766 2825
2826=item $client->send_big_packet ($pkt)
2827
2828Like C<send_packet>, but tries to compress large packets, and fragments
2829them as required.
2830
2831=cut
2832
2833our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
2834
2835sub cf::client::send_big_packet {
2836 my ($self, $pkt) = @_;
2837
2838 # try lzf for large packets
2839 $pkt = "lzf " . Compress::LZF::compress $pkt
2840 if 1024 <= length $pkt and $self->{can_lzf};
2841
2842 # split very large packets
2843 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
2844 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
2845 $pkt = "frag";
2846 }
2847
2848 $self->send_packet ($pkt);
2849}
2850
2767=item $client->send_msg ($channel, $msg, $color, [extra...]) 2851=item $client->send_msg ($channel, $msg, $color, [extra...])
2768 2852
2769Send a drawinfo or msg packet to the client, formatting the msg for the 2853Send 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 2854client 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 2855the message, with C<log> being the default. If C<$color> is negative, suppress
… …
2773 2857
2774=cut 2858=cut
2775 2859
2776# non-persistent channels (usually the info channel) 2860# non-persistent channels (usually the info channel)
2777our %CHANNEL = ( 2861our %CHANNEL = (
2862 "c/motd" => {
2863 id => "infobox",
2864 title => "MOTD",
2865 reply => undef,
2866 tooltip => "The message of the day",
2867 },
2778 "c/identify" => { 2868 "c/identify" => {
2779 id => "infobox", 2869 id => "infobox",
2780 title => "Identify", 2870 title => "Identify",
2781 reply => undef, 2871 reply => undef,
2782 tooltip => "Items recently identified", 2872 tooltip => "Items recently identified",
… …
2784 "c/examine" => { 2874 "c/examine" => {
2785 id => "infobox", 2875 id => "infobox",
2786 title => "Examine", 2876 title => "Examine",
2787 reply => undef, 2877 reply => undef,
2788 tooltip => "Signs and other items you examined", 2878 tooltip => "Signs and other items you examined",
2879 },
2880 "c/shopinfo" => {
2881 id => "infobox",
2882 title => "Shop Info",
2883 reply => undef,
2884 tooltip => "What your bargaining skill tells you about the shop",
2789 }, 2885 },
2790 "c/book" => { 2886 "c/book" => {
2791 id => "infobox", 2887 id => "infobox",
2792 title => "Book", 2888 title => "Book",
2793 reply => undef, 2889 reply => undef,
… …
2809 id => "infobox", 2905 id => "infobox",
2810 title => "Body Parts", 2906 title => "Body Parts",
2811 reply => undef, 2907 reply => undef,
2812 tooltip => "Shows which body parts you posess and are available", 2908 tooltip => "Shows which body parts you posess and are available",
2813 }, 2909 },
2910 "c/statistics" => {
2911 id => "infobox",
2912 title => "Statistics",
2913 reply => undef,
2914 tooltip => "Shows your primary statistics",
2915 },
2814 "c/skills" => { 2916 "c/skills" => {
2815 id => "infobox", 2917 id => "infobox",
2816 title => "Skills", 2918 title => "Skills",
2817 reply => undef, 2919 reply => undef,
2818 tooltip => "Shows your experience per skill and item power", 2920 tooltip => "Shows your experience per skill and item power",
2921 },
2922 "c/shopitems" => {
2923 id => "infobox",
2924 title => "Shop Items",
2925 reply => undef,
2926 tooltip => "Shows the items currently for sale in this shop",
2927 },
2928 "c/resistances" => {
2929 id => "infobox",
2930 title => "Resistances",
2931 reply => undef,
2932 tooltip => "Shows your resistances",
2933 },
2934 "c/pets" => {
2935 id => "infobox",
2936 title => "Pets",
2937 reply => undef,
2938 tooltip => "Shows information abotu your pets/a specific pet",
2939 },
2940 "c/perceiveself" => {
2941 id => "infobox",
2942 title => "Perceive Self",
2943 reply => undef,
2944 tooltip => "You gained detailed knowledge about yourself",
2819 }, 2945 },
2820 "c/uptime" => { 2946 "c/uptime" => {
2821 id => "infobox", 2947 id => "infobox",
2822 title => "Uptime", 2948 title => "Uptime",
2823 reply => undef, 2949 reply => undef,
… …
2833 id => "party", 2959 id => "party",
2834 title => "Party", 2960 title => "Party",
2835 reply => "gsay ", 2961 reply => "gsay ",
2836 tooltip => "Messages and chat related to your party", 2962 tooltip => "Messages and chat related to your party",
2837 }, 2963 },
2964 "c/death" => {
2965 id => "death",
2966 title => "Death",
2967 reply => undef,
2968 tooltip => "Reason for and more info about your most recent death",
2969 },
2970 "c/say" => $SAY_CHANNEL,
2971 "c/chat" => $CHAT_CHANNEL,
2838); 2972);
2839 2973
2840sub cf::client::send_msg { 2974sub cf::client::send_msg {
2841 my ($self, $channel, $msg, $color, @extra) = @_; 2975 my ($self, $channel, $msg, $color, @extra) = @_;
2842 2976
… …
2847 2981
2848 # check predefined channels, for the benefit of C 2982 # check predefined channels, for the benefit of C
2849 if ($CHANNEL{$channel}) { 2983 if ($CHANNEL{$channel}) {
2850 $channel = $CHANNEL{$channel}; 2984 $channel = $CHANNEL{$channel};
2851 2985
2852 $self->ext_msg (channel_info => $channel) 2986 $self->ext_msg (channel_info => $channel);
2853 if $self->can_msg;
2854
2855 $channel = $channel->{id}; 2987 $channel = $channel->{id};
2856 2988
2857 } elsif (ref $channel) { 2989 } elsif (ref $channel) {
2858 # send meta info to client, if not yet sent 2990 # send meta info to client, if not yet sent
2859 unless (exists $self->{channel}{$channel->{id}}) { 2991 unless (exists $self->{channel}{$channel->{id}}) {
2860 $self->{channel}{$channel->{id}} = $channel; 2992 $self->{channel}{$channel->{id}} = $channel;
2861 $self->ext_msg (channel_info => $channel) 2993 $self->ext_msg (channel_info => $channel);
2862 if $self->can_msg;
2863 } 2994 }
2864 2995
2865 $channel = $channel->{id}; 2996 $channel = $channel->{id};
2866 } 2997 }
2867 2998
2868 return unless @extra || length $msg; 2999 return unless @extra || length $msg;
2869 3000
2870 if ($self->can_msg) {
2871 # default colour, mask it out 3001 # default colour, mask it out
2872 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF) 3002 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2873 if $color & cf::NDI_DEF; 3003 if $color & cf::NDI_DEF;
2874 3004
2875 my $pkt = "msg " 3005 my $pkt = "msg "
2876 . $self->{json_coder}->encode ( 3006 . $self->{json_coder}->encode (
2877 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra] 3007 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2878 ); 3008 );
2879 3009
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); 3010 $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} 3011}
2917 3012
2918=item $client->ext_msg ($type, @msg) 3013=item $client->ext_msg ($type, @msg)
2919 3014
2920Sends an ext event to the client. 3015Sends an ext event to the client.
… …
2923 3018
2924sub cf::client::ext_msg($$@) { 3019sub cf::client::ext_msg($$@) {
2925 my ($self, $type, @msg) = @_; 3020 my ($self, $type, @msg) = @_;
2926 3021
2927 if ($self->extcmd == 2) { 3022 if ($self->extcmd == 2) {
2928 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 3023 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2929 } elsif ($self->extcmd == 1) { # TODO: remove 3024 } elsif ($self->extcmd == 1) { # TODO: remove
2930 push @msg, msgtype => "event_$type"; 3025 push @msg, msgtype => "event_$type";
2931 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3026 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2932 } 3027 }
2933} 3028}
2934 3029
2935=item $client->ext_reply ($msgid, @msg) 3030=item $client->ext_reply ($msgid, @msg)
2936 3031
… …
2940 3035
2941sub cf::client::ext_reply($$@) { 3036sub cf::client::ext_reply($$@) {
2942 my ($self, $id, @msg) = @_; 3037 my ($self, $id, @msg) = @_;
2943 3038
2944 if ($self->extcmd == 2) { 3039 if ($self->extcmd == 2) {
2945 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg])); 3040 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2946 } elsif ($self->extcmd == 1) { 3041 } elsif ($self->extcmd == 1) {
2947 #TODO: version 1, remove 3042 #TODO: version 1, remove
2948 unshift @msg, msgtype => "reply", msgid => $id; 3043 unshift @msg, msgtype => "reply", msgid => $id;
2949 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3044 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2950 } 3045 }
2951} 3046}
2952 3047
2953=item $success = $client->query ($flags, "text", \&cb) 3048=item $success = $client->query ($flags, "text", \&cb)
2954 3049
… …
3055 3150
3056 $coro 3151 $coro
3057} 3152}
3058 3153
3059cf::client->attach ( 3154cf::client->attach (
3060 on_destroy => sub { 3155 on_client_destroy => sub {
3061 my ($ns) = @_; 3156 my ($ns) = @_;
3062 3157
3063 $_->cancel for values %{ (delete $ns->{_coro}) || {} }; 3158 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
3064 }, 3159 },
3065); 3160);
… …
3081our $safe_hole = new Safe::Hole; 3176our $safe_hole = new Safe::Hole;
3082 3177
3083$SIG{FPE} = 'IGNORE'; 3178$SIG{FPE} = 'IGNORE';
3084 3179
3085$safe->permit_only (Opcode::opset qw( 3180$safe->permit_only (Opcode::opset qw(
3086 :base_core :base_mem :base_orig :base_math 3181 :base_core :base_mem :base_orig :base_math :base_loop
3087 grepstart grepwhile mapstart mapwhile 3182 grepstart grepwhile mapstart mapwhile
3088 sort time 3183 sort time
3089)); 3184));
3090 3185
3091# here we export the classes and methods available to script code 3186# here we export the classes and methods available to script code
… …
3095The following functions and methods are available within a safe environment: 3190The following functions and methods are available within a safe environment:
3096 3191
3097 cf::object 3192 cf::object
3098 contr pay_amount pay_player map x y force_find force_add destroy 3193 contr pay_amount pay_player map x y force_find force_add destroy
3099 insert remove name archname title slaying race decrease split 3194 insert remove name archname title slaying race decrease split
3195 value
3100 3196
3101 cf::object::player 3197 cf::object::player
3102 player 3198 player
3103 3199
3104 cf::player 3200 cf::player
… …
3110=cut 3206=cut
3111 3207
3112for ( 3208for (
3113 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3209 ["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 3210 insert remove inv nrof name archname title slaying race
3115 decrease split destroy change_exp)], 3211 decrease split destroy change_exp value msg lore send_msg)],
3116 ["cf::object::player" => qw(player)], 3212 ["cf::object::player" => qw(player)],
3117 ["cf::player" => qw(peaceful)], 3213 ["cf::player" => qw(peaceful send_msg)],
3118 ["cf::map" => qw(trigger)], 3214 ["cf::map" => qw(trigger)],
3119) { 3215) {
3120 no strict 'refs'; 3216 no strict 'refs';
3121 my ($pkg, @funs) = @$_; 3217 my ($pkg, @funs) = @$_;
3122 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3218 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
… …
3140 3236
3141 my $qcode = $code; 3237 my $qcode = $code;
3142 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3238 $qcode =~ s/"/‟/g; # not allowed in #line filenames
3143 $qcode =~ s/\n/\\n/g; 3239 $qcode =~ s/\n/\\n/g;
3144 3240
3241 %vars = (_dummy => 0) unless %vars;
3242
3243 my @res;
3145 local $_; 3244 local $_;
3146 local @safe::cf::_safe_eval_args = values %vars;
3147 3245
3148 my $eval = 3246 my $eval =
3149 "do {\n" 3247 "do {\n"
3150 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3248 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
3151 . "#line 0 \"{$qcode}\"\n" 3249 . "#line 0 \"{$qcode}\"\n"
3152 . $code 3250 . $code
3153 . "\n}" 3251 . "\n}"
3154 ; 3252 ;
3155 3253
3254 if ($CFG{safe_eval}) {
3156 sub_generation_inc; 3255 sub_generation_inc;
3256 local @safe::cf::_safe_eval_args = values %vars;
3157 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3257 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
3158 sub_generation_inc; 3258 sub_generation_inc;
3259 } else {
3260 local @cf::_safe_eval_args = values %vars;
3261 @res = wantarray ? eval eval : scalar eval $eval;
3262 }
3159 3263
3160 if ($@) { 3264 if ($@) {
3161 warn "$@"; 3265 warn "$@";
3162 warn "while executing safe code '$code'\n"; 3266 warn "while executing safe code '$code'\n";
3163 warn "with arguments " . (join " ", %vars) . "\n"; 3267 warn "with arguments " . (join " ", %vars) . "\n";
… …
3182=cut 3286=cut
3183 3287
3184sub register_script_function { 3288sub register_script_function {
3185 my ($fun, $cb) = @_; 3289 my ($fun, $cb) = @_;
3186 3290
3187 no strict 'refs'; 3291 $fun = "safe::$fun" if $CFG{safe_eval};
3188 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3292 *$fun = $safe_hole->wrap ($cb);
3189} 3293}
3190 3294
3191=back 3295=back
3192 3296
3193=cut 3297=cut
… …
3214 3318
3215 $facedata->{version} == 2 3319 $facedata->{version} == 2
3216 or cf::cleanup "$path: version mismatch, cannot proceed."; 3320 or cf::cleanup "$path: version mismatch, cannot proceed.";
3217 3321
3218 # patch in the exptable 3322 # patch in the exptable
3323 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3219 $facedata->{resource}{"res/exp_table"} = { 3324 $facedata->{resource}{"res/exp_table"} = {
3220 type => FT_RSRC, 3325 type => FT_RSRC,
3221 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]), 3326 data => $exp_table,
3327 hash => (Digest::MD5::md5 $exp_table),
3222 }; 3328 };
3223 cf::cede_to_tick; 3329 cf::cede_to_tick;
3224 3330
3225 { 3331 {
3226 my $faces = $facedata->{faceinfo}; 3332 my $faces = $facedata->{faceinfo};
… …
3228 while (my ($face, $info) = each %$faces) { 3334 while (my ($face, $info) = each %$faces) {
3229 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3335 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3230 3336
3231 cf::face::set_visibility $idx, $info->{visibility}; 3337 cf::face::set_visibility $idx, $info->{visibility};
3232 cf::face::set_magicmap $idx, $info->{magicmap}; 3338 cf::face::set_magicmap $idx, $info->{magicmap};
3233 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3339 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3234 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3340 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3235 3341
3236 cf::cede_to_tick; 3342 cf::cede_to_tick;
3237 } 3343 }
3238 3344
3239 while (my ($face, $info) = each %$faces) { 3345 while (my ($face, $info) = each %$faces) {
… …
3263 3369
3264 cf::anim::invalidate_all; # d'oh 3370 cf::anim::invalidate_all; # d'oh
3265 } 3371 }
3266 3372
3267 { 3373 {
3268 # TODO: for gcfclient pleasure, we should give resources
3269 # that gcfclient doesn't grok a >10000 face index.
3270 my $res = $facedata->{resource}; 3374 my $res = $facedata->{resource};
3271 3375
3272 while (my ($name, $info) = each %$res) { 3376 while (my ($name, $info) = each %$res) {
3273 if (defined $info->{type}) { 3377 if (defined $info->{type}) {
3274 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3378 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3275 my $data;
3276 3379
3277 if ($info->{type} & 1) { 3380 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}; 3381 cf::face::set_type $idx, $info->{type};
3292 } else { 3382 } else {
3293 $RESOURCE{$name} = $info; 3383 $RESOURCE{$name} = $info;
3294 } 3384 }
3295 3385
… …
3379 3469
3380 warn "finished reloading resource files\n"; 3470 warn "finished reloading resource files\n";
3381} 3471}
3382 3472
3383sub reload_config { 3473sub reload_config {
3474 warn "reloading config file...\n";
3475
3384 open my $fh, "<:utf8", "$CONFDIR/config" 3476 open my $fh, "<:utf8", "$CONFDIR/config"
3385 or return; 3477 or return;
3386 3478
3387 local $/; 3479 local $/;
3388 *CFG = YAML::Load <$fh>; 3480 *CFG = YAML::XS::Load scalar <$fh>;
3389 3481
3390 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3482 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
3391 3483
3392 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3484 $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}; 3485 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
… …
3397 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 3489 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3398 and die "WARNING: m(un)lockall failed: $!\n"; 3490 and die "WARNING: m(un)lockall failed: $!\n";
3399 }; 3491 };
3400 warn $@ if $@; 3492 warn $@ if $@;
3401 } 3493 }
3494
3495 warn "finished reloading resource files\n";
3402} 3496}
3403 3497
3404sub pidfile() { 3498sub pidfile() {
3405 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT 3499 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3406 or die "$PIDFILE: $!"; 3500 or die "$PIDFILE: $!";
… …
3418 3512
3419 seek $fh, 0, 0; 3513 seek $fh, 0, 0;
3420 print $fh $$; 3514 print $fh $$;
3421} 3515}
3422 3516
3517sub main_loop {
3518 warn "EV::loop starting\n";
3519 if (1) {
3520 EV::loop;
3521 }
3522 warn "EV::loop returned\n";
3523 goto &main_loop unless $REALLY_UNLOOP;
3524}
3525
3423sub main { 3526sub main {
3424 cf::init_globals; # initialise logging 3527 cf::init_globals; # initialise logging
3425 3528
3426 LOG llevInfo, "Welcome to Deliantra, v" . VERSION; 3529 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3427 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team."; 3530 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
… …
3430 3533
3431 cf::init_experience; 3534 cf::init_experience;
3432 cf::init_anim; 3535 cf::init_anim;
3433 cf::init_attackmess; 3536 cf::init_attackmess;
3434 cf::init_dynamic; 3537 cf::init_dynamic;
3435 cf::init_block;
3436 3538
3437 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3539 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3438 3540
3439 # we must not ever block the main coroutine 3541 # we must not ever block the main coroutine
3440 local $Coro::idle = sub { 3542 local $Coro::idle = sub {
… …
3446 }; 3548 };
3447 3549
3448 evthread_start IO::AIO::poll_fileno; 3550 evthread_start IO::AIO::poll_fileno;
3449 3551
3450 cf::sync_job { 3552 cf::sync_job {
3553 cf::load_settings;
3554 cf::load_materials;
3555
3451 reload_resources; 3556 reload_resources;
3452 reload_config; 3557 reload_config;
3453 db_init; 3558 db_init;
3454 3559
3455 cf::load_settings;
3456 cf::load_materials;
3457 cf::init_uuid; 3560 cf::init_uuid;
3458 cf::init_signals; 3561 cf::init_signals;
3459 cf::init_commands;
3460 cf::init_skills; 3562 cf::init_skills;
3461 3563
3462 cf::init_beforeplay; 3564 cf::init_beforeplay;
3463 3565
3464 atomic; 3566 atomic;
… …
3466 load_extensions; 3568 load_extensions;
3467 3569
3468 utime time, time, $RUNTIMEFILE; 3570 utime time, time, $RUNTIMEFILE;
3469 3571
3470 # no (long-running) fork's whatsoever before this point(!) 3572 # no (long-running) fork's whatsoever before this point(!)
3573 use POSIX ();
3471 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD}; 3574 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3472 3575
3473 (pop @POST_INIT)->(0) while @POST_INIT; 3576 (pop @POST_INIT)->(0) while @POST_INIT;
3474 }; 3577 };
3475 3578
3476 EV::loop; 3579 main_loop;
3477} 3580}
3478 3581
3479############################################################################# 3582#############################################################################
3480# initialisation and cleanup 3583# initialisation and cleanup
3481 3584
3482# install some emergency cleanup handlers 3585# install some emergency cleanup handlers
3483BEGIN { 3586BEGIN {
3484 our %SIGWATCHER = (); 3587 our %SIGWATCHER = ();
3485 for my $signal (qw(INT HUP TERM)) { 3588 for my $signal (qw(INT HUP TERM)) {
3486 $SIGWATCHER{$signal} = EV::signal $signal, sub { 3589 $SIGWATCHER{$signal} = AE::signal $signal, sub {
3487 cf::cleanup "SIG$signal"; 3590 cf::cleanup "SIG$signal";
3488 }; 3591 };
3489 } 3592 }
3490} 3593}
3491 3594
3492sub write_runtime_sync { 3595sub write_runtime_sync {
3596 my $t0 = AE::time;
3597
3493 # first touch the runtime file to show we are still running: 3598 # first touch the runtime file to show we are still running:
3494 # the fsync below can take a very very long time. 3599 # the fsync below can take a very very long time.
3495 3600
3496 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef; 3601 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3497 3602
3498 my $guard = cf::lock_acquire "write_runtime"; 3603 my $guard = cf::lock_acquire "write_runtime";
3499 3604
3500 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644 3605 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3501 or return; 3606 or return;
3502 3607
3503 my $value = $cf::RUNTIME + 90 + 10; 3608 my $value = $cf::RUNTIME + 90 + 10;
3504 # 10 is the runtime save interval, for a monotonic clock 3609 # 10 is the runtime save interval, for a monotonic clock
3505 # 60 allows for the watchdog to kill the server. 3610 # 60 allows for the watchdog to kill the server.
… …
3518 or return; 3623 or return;
3519 3624
3520 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE 3625 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3521 and return; 3626 and return;
3522 3627
3523 warn "runtime file written.\n"; 3628 warn sprintf "runtime file written (%gs).\n", AE::time - $t0;
3524 3629
3525 1 3630 1
3526} 3631}
3527 3632
3528our $uuid_lock; 3633our $uuid_lock;
… …
3666 return; 3771 return;
3667 } 3772 }
3668 3773
3669 return if $RELOAD++; 3774 return if $RELOAD++;
3670 3775
3671 my $t1 = EV::time; 3776 my $t1 = AE::time;
3672 3777
3673 while ($RELOAD) { 3778 while ($RELOAD) {
3674 warn "reloading..."; 3779 warn "reloading...";
3675 3780
3676 warn "entering sync_job"; 3781 warn "entering sync_job";
… …
3737 clear_package "safe::$_" 3842 clear_package "safe::$_"
3738 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3843 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3739 3844
3740 warn "unloading cf.pm \"a bit\""; 3845 warn "unloading cf.pm \"a bit\"";
3741 delete $INC{"cf.pm"}; 3846 delete $INC{"cf.pm"};
3742 delete $INC{"cf/pod.pm"}; 3847 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3743 3848
3744 # don't, removes xs symbols, too, 3849 # don't, removes xs symbols, too,
3745 # and global variables created in xs 3850 # and global variables created in xs
3746 #clear_package __PACKAGE__; 3851 #clear_package __PACKAGE__;
3747 3852
3748 warn "unload completed, starting to reload now"; 3853 warn "unload completed, starting to reload now";
3749 3854
3750 warn "reloading cf.pm"; 3855 warn "reloading cf.pm";
3751 require cf; 3856 require cf;
3752 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3857 cf::_connect_to_perl_1;
3753 3858
3754 warn "loading config and database again"; 3859 warn "loading config and database again";
3755 cf::reload_config; 3860 cf::reload_config;
3756 3861
3757 warn "loading extensions"; 3862 warn "loading extensions";
… …
3779 3884
3780 warn "reloaded"; 3885 warn "reloaded";
3781 --$RELOAD; 3886 --$RELOAD;
3782 } 3887 }
3783 3888
3784 $t1 = EV::time - $t1; 3889 $t1 = AE::time - $t1;
3785 warn "reload completed in ${t1}s\n"; 3890 warn "reload completed in ${t1}s\n";
3786}; 3891};
3787 3892
3788our $RELOAD_WATCHER; # used only during reload 3893our $RELOAD_WATCHER; # used only during reload
3789 3894
… …
3792 # coro crashes during coro_state_free->destroy here. 3897 # coro crashes during coro_state_free->destroy here.
3793 3898
3794 $RELOAD_WATCHER ||= cf::async { 3899 $RELOAD_WATCHER ||= cf::async {
3795 Coro::AIO::aio_wait cache_extensions; 3900 Coro::AIO::aio_wait cache_extensions;
3796 3901
3797 $RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub { 3902 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
3798 do_reload_perl; 3903 do_reload_perl;
3799 undef $RELOAD_WATCHER; 3904 undef $RELOAD_WATCHER;
3800 }; 3905 };
3801 }; 3906 };
3802} 3907}
… …
3819 3924
3820our @WAIT_FOR_TICK; 3925our @WAIT_FOR_TICK;
3821our @WAIT_FOR_TICK_BEGIN; 3926our @WAIT_FOR_TICK_BEGIN;
3822 3927
3823sub wait_for_tick { 3928sub wait_for_tick {
3824 return if tick_inhibit || $Coro::current == $Coro::main; 3929 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3825 3930
3826 my $signal = new Coro::Signal; 3931 my $signal = new Coro::Signal;
3827 push @WAIT_FOR_TICK, $signal; 3932 push @WAIT_FOR_TICK, $signal;
3828 $signal->wait; 3933 $signal->wait;
3829} 3934}
3830 3935
3831sub wait_for_tick_begin { 3936sub wait_for_tick_begin {
3832 return if tick_inhibit || $Coro::current == $Coro::main; 3937 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3833 3938
3834 my $signal = new Coro::Signal; 3939 my $signal = new Coro::Signal;
3835 push @WAIT_FOR_TICK_BEGIN, $signal; 3940 push @WAIT_FOR_TICK_BEGIN, $signal;
3836 $signal->wait; 3941 $signal->wait;
3837} 3942}
… …
3842 unless ++$bug_warning > 10; 3947 unless ++$bug_warning > 10;
3843 return; 3948 return;
3844 } 3949 }
3845 3950
3846 cf::server_tick; # one server iteration 3951 cf::server_tick; # one server iteration
3952
3953 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
3847 3954
3848 if ($NOW >= $NEXT_RUNTIME_WRITE) { 3955 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3849 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.; 3956 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3850 Coro::async_pool { 3957 Coro::async_pool {
3851 $Coro::current->{desc} = "runtime saver"; 3958 $Coro::current->{desc} = "runtime saver";
… …
3874} 3981}
3875 3982
3876{ 3983{
3877 # configure BDB 3984 # configure BDB
3878 3985
3879 BDB::min_parallel 8; 3986 BDB::min_parallel 16;
3880 BDB::max_poll_reqs $TICK * 0.1; 3987 BDB::max_poll_reqs $TICK * 0.1;
3881 $AnyEvent::BDB::WATCHER->priority (1); 3988 $AnyEvent::BDB::WATCHER->priority (1);
3882 3989
3883 unless ($DB_ENV) { 3990 unless ($DB_ENV) {
3884 $DB_ENV = BDB::db_env_create; 3991 $DB_ENV = BDB::db_env_create;
… …
3964 LOG llevInfo, "[ABT] [suppressed]\n"; 4071 LOG llevInfo, "[ABT] [suppressed]\n";
3965 } 4072 }
3966} 4073}
3967 4074
3968# load additional modules 4075# load additional modules
3969use cf::pod; 4076require "cf/$_.pm" for @EXTRA_MODULES;
4077cf::_connect_to_perl_2;
3970 4078
3971END { cf::emergency_save } 4079END { cf::emergency_save }
3972 4080
39731 40811
3974 4082

Diff Legend

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