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.292 by root, Tue Jul 3 00:54:57 2007 UTC vs.
Revision 1.362 by root, Mon Sep 10 12:44:06 2007 UTC

… …
10use Event; 10use Event;
11use Opcode; 11use Opcode;
12use Safe; 12use Safe;
13use Safe::Hole; 13use Safe::Hole;
14 14
15use Coro 3.61 (); 15use Coro 3.64 ();
16use Coro::State; 16use Coro::State;
17use Coro::Handle; 17use Coro::Handle;
18use Coro::Event; 18use Coro::Event;
19use Coro::Timer; 19use Coro::Timer;
20use Coro::Signal; 20use Coro::Signal;
21use Coro::Semaphore; 21use Coro::Semaphore;
22use Coro::AIO; 22use Coro::AIO;
23use Coro::Storable; 23use Coro::Storable;
24use Coro::Util ();
24 25
25use JSON::XS 1.4 (); 26use JSON::XS ();
26use BDB (); 27use BDB ();
27use Data::Dumper; 28use Data::Dumper;
28use Digest::MD5; 29use Digest::MD5;
29use Fcntl; 30use Fcntl;
30use YAML::Syck (); 31use YAML::Syck ();
31use IO::AIO 2.32 (); 32use IO::AIO 2.32 ();
32use Time::HiRes; 33use Time::HiRes;
33use Compress::LZF; 34use Compress::LZF;
35use Digest::MD5 ();
34 36
35# configure various modules to our taste 37# configure various modules to our taste
36# 38#
37$Storable::canonical = 1; # reduce rsync transfers 39$Storable::canonical = 1; # reduce rsync transfers
38Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 40Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
… …
85our %CFG; 87our %CFG;
86 88
87our $UPTIME; $UPTIME ||= time; 89our $UPTIME; $UPTIME ||= time;
88our $RUNTIME; 90our $RUNTIME;
89 91
90our %PLAYER; # all users 92our (%PLAYER, %PLAYER_LOADING); # all users
91our %MAP; # all maps 93our (%MAP, %MAP_LOADING ); # all maps
92our $LINK_MAP; # the special {link} map, which is always available 94our $LINK_MAP; # the special {link} map, which is always available
93 95
94# used to convert map paths into valid unix filenames by replacing / by ∕ 96# used to convert map paths into valid unix filenames by replacing / by ∕
95our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 97our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
96 98
… …
166 168
167These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 169These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
168returns directly I<after> the tick processing (and consequently, can only wake one process 170returns directly I<after> the tick processing (and consequently, can only wake one process
169per tick), while cf::wait_for_tick wakes up all waiters after tick processing. 171per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
170 172
173=item @cf::INVOKE_RESULTS
174
175This array contains the results of the last C<invoke ()> call. When
176C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
177that call.
178
171=back 179=back
172 180
173=cut 181=cut
174 182
175BEGIN { 183BEGIN {
… …
179 $msg .= "\n" 187 $msg .= "\n"
180 unless $msg =~ /\n$/; 188 unless $msg =~ /\n$/;
181 189
182 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 190 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
183 191
184 utf8::encode $msg;
185 LOG llevError, $msg; 192 LOG llevError, $msg;
186 }; 193 };
187} 194}
188 195
189@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 196@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
… …
264Wait until the given lock is available and then acquires it and returns 271Wait until the given lock is available and then acquires it and returns
265a Coro::guard object. If the guard object gets destroyed (goes out of scope, 272a Coro::guard object. If the guard object gets destroyed (goes out of scope,
266for example when the coroutine gets canceled), the lock is automatically 273for example when the coroutine gets canceled), the lock is automatically
267returned. 274returned.
268 275
276Locks are *not* recursive, locking from the same coro twice results in a
277deadlocked coro.
278
269Lock names should begin with a unique identifier (for example, cf::map::find 279Lock names should begin with a unique identifier (for example, cf::map::find
270uses map_find and cf::map::load uses map_load). 280uses map_find and cf::map::load uses map_load).
271 281
272=item $locked = cf::lock_active $string 282=item $locked = cf::lock_active $string
273 283
274Return true if the lock is currently active, i.e. somebody has locked it. 284Return true if the lock is currently active, i.e. somebody has locked it.
275 285
276=cut 286=cut
277 287
278our %LOCK; 288our %LOCK;
289our %LOCKER;#d#
279 290
280sub lock_wait($) { 291sub lock_wait($) {
281 my ($key) = @_; 292 my ($key) = @_;
293
294 if ($LOCKER{$key} == $Coro::current) {#d#
295 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
296 return;#d#
297 }#d#
282 298
283 # wait for lock, if any 299 # wait for lock, if any
284 while ($LOCK{$key}) { 300 while ($LOCK{$key}) {
285 push @{ $LOCK{$key} }, $Coro::current; 301 push @{ $LOCK{$key} }, $Coro::current;
286 Coro::schedule; 302 Coro::schedule;
… …
292 308
293 # wait, to be sure we are not locked 309 # wait, to be sure we are not locked
294 lock_wait $key; 310 lock_wait $key;
295 311
296 $LOCK{$key} = []; 312 $LOCK{$key} = [];
313 $LOCKER{$key} = $Coro::current;#d#
297 314
298 Coro::guard { 315 Coro::guard {
316 delete $LOCKER{$key};#d#
299 # wake up all waiters, to be on the safe side 317 # wake up all waiters, to be on the safe side
300 $_->ready for @{ delete $LOCK{$key} }; 318 $_->ready for @{ delete $LOCK{$key} };
301 } 319 }
302} 320}
303 321
… …
313 my $guard = Coro::guard { 331 my $guard = Coro::guard {
314 $TICK_WATCHER->start; 332 $TICK_WATCHER->start;
315 }; 333 };
316 $TICK_WATCHER->stop; 334 $TICK_WATCHER->stop;
317 $guard 335 $guard
336}
337
338=item cf::get_slot $time[, $priority[, $name]]
339
340Allocate $time seconds of blocking CPU time at priority C<$priority>:
341This call blocks and returns only when you have at least C<$time> seconds
342of cpu time till the next tick. The slot is only valid till the next cede.
343
344The optional C<$name> can be used to identify the job to run. It might be
345used for statistical purposes and should identify the same time-class.
346
347Useful for short background jobs.
348
349=cut
350
351our @SLOT_QUEUE;
352our $SLOT_QUEUE;
353
354$SLOT_QUEUE->cancel if $SLOT_QUEUE;
355$SLOT_QUEUE = Coro::async {
356 my $signal = new Coro::Signal;
357
358 while () {
359 next_job:
360 my $avail = cf::till_tick;
361 if ($avail > 0.01) {
362 for (0 .. $#SLOT_QUEUE) {
363 if ($SLOT_QUEUE[$_][0] < $avail) {
364 my $job = splice @SLOT_QUEUE, $_, 1, ();
365 $job->[2]->send;
366 Coro::cede;
367 goto next_job;
368 }
369 }
370 }
371
372 if (@SLOT_QUEUE) {
373 # we do not use wait_For_tick() as it returns immediately when tick is inactive
374 push @cf::WAIT_FOR_TICK, $signal;
375 $signal->wait;
376 } else {
377 Coro::schedule;
378 }
379 }
380};
381
382sub get_slot($;$$) {
383 my ($time, $pri, $name) = @_;
384
385 $time = $TICK * .6 if $time > $TICK * .6;
386 my $sig = new Coro::Signal;
387
388 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
389 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
390 $SLOT_QUEUE->ready;
391 $sig->wait;
318} 392}
319 393
320=item cf::async { BLOCK } 394=item cf::async { BLOCK }
321 395
322Currently the same as Coro::async_pool, meaning you cannot use 396Currently the same as Coro::async_pool, meaning you cannot use
… …
412=cut 486=cut
413 487
414sub fork_call(&@) { 488sub fork_call(&@) {
415 my ($cb, @args) = @_; 489 my ($cb, @args) = @_;
416 490
417# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC 491 # we seemingly have to make a local copy of the whole thing,
418# or die "socketpair: $!"; 492 # otherwise perl prematurely frees the stuff :/
419 pipe my $fh1, my $fh2 493 # TODO: investigate and fix (likely this will be rather laborious)
420 or die "pipe: $!";
421 494
422 if (my $pid = fork) { 495 my @res = Coro::Util::fork_eval {
423 close $fh2;
424
425 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
426 $res = Coro::Storable::thaw $res;
427
428 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
429
430 die $$res unless "ARRAY" eq ref $res;
431
432 return wantarray ? @$res : $res->[-1];
433 } else {
434 reset_signals; 496 reset_signals;
435 local $SIG{__WARN__}; 497 &$cb
436 local $SIG{__DIE__}; 498 }, @args;
437 eval {
438 close $fh1;
439 499
440 my @res = eval { $cb->(@args) }; 500 wantarray ? @res : $res[-1]
441 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
442 };
443
444 warn $@ if $@;
445 _exit 0;
446 }
447} 501}
448 502
449=item $value = cf::db_get $family => $key 503=item $value = cf::db_get $family => $key
450 504
451Returns a single value from the environment database. 505Returns a single value from the environment database.
… …
531 if (1) { 585 if (1) {
532 $md5 = 586 $md5 =
533 join "\x00", 587 join "\x00",
534 $processversion, 588 $processversion,
535 map { 589 map {
536 Coro::cede; 590 cf::cede_to_tick;
537 ($src->[$_], Digest::MD5::md5_hex $data[$_]) 591 ($src->[$_], Digest::MD5::md5_hex $data[$_])
538 } 0.. $#$src; 592 } 0.. $#$src;
539 593
540 594
541 my $dbmd5 = db_get cache => "$id/md5"; 595 my $dbmd5 = db_get cache => "$id/md5";
… …
847 "; 901 ";
848 die if $@; 902 die if $@;
849} 903}
850 904
851our $override; 905our $override;
852our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 906our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
853 907
854sub override { 908sub override {
855 $override = 1; 909 $override = 1;
856 @invoke_results = (); 910 @INVOKE_RESULTS = (@_);
857} 911}
858 912
859sub do_invoke { 913sub do_invoke {
860 my $event = shift; 914 my $event = shift;
861 my $callbacks = shift; 915 my $callbacks = shift;
862 916
863 @invoke_results = (); 917 @INVOKE_RESULTS = ();
864 918
865 local $override; 919 local $override;
866 920
867 for (@$callbacks) { 921 for (@$callbacks) {
868 eval { &{$_->[1]} }; 922 eval { &{$_->[1]} };
… …
885 939
886Generate an object-specific event with the given arguments. 940Generate an object-specific event with the given arguments.
887 941
888This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be 942This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
889removed in future versions), and there is no public API to access override 943removed in future versions), and there is no public API to access override
890results (if you must, access C<@cf::invoke_results> directly). 944results (if you must, access C<@cf::INVOKE_RESULTS> directly).
891 945
892=back 946=back
893 947
894=cut 948=cut
895 949
896############################################################################# 950#############################################################################
897# object support 951# object support
952#
953
954sub _can_merge {
955 my ($ob1, $ob2) = @_;
956
957 local $Storable::canonical = 1;
958 my $fob1 = Storable::freeze $ob1;
959 my $fob2 = Storable::freeze $ob2;
960
961 $fob1 eq $fob2
962}
898 963
899sub reattach { 964sub reattach {
900 # basically do the same as instantiate, without calling instantiate 965 # basically do the same as instantiate, without calling instantiate
901 my ($obj) = @_; 966 my ($obj) = @_;
902 967
… …
947); 1012);
948 1013
949sub object_freezer_save { 1014sub object_freezer_save {
950 my ($filename, $rdata, $objs) = @_; 1015 my ($filename, $rdata, $objs) = @_;
951 1016
1017 my $guard = cf::lock_acquire "io";
1018
952 sync_job { 1019 sync_job {
953 if (length $$rdata) { 1020 if (length $$rdata) {
1021 utf8::decode (my $decname = $filename);
954 warn sprintf "saving %s (%d,%d)\n", 1022 warn sprintf "saving %s (%d,%d)\n",
955 $filename, length $$rdata, scalar @$objs; 1023 $decname, length $$rdata, scalar @$objs;
956 1024
957 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1025 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
958 chmod SAVE_MODE, $fh; 1026 chmod SAVE_MODE, $fh;
959 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1027 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
960 aio_fsync $fh if $cf::USE_FSYNC; 1028 aio_fsync $fh if $cf::USE_FSYNC;
… …
979 } 1047 }
980 } else { 1048 } else {
981 aio_unlink $filename; 1049 aio_unlink $filename;
982 aio_unlink "$filename.pst"; 1050 aio_unlink "$filename.pst";
983 } 1051 }
984 } 1052 };
1053
1054 undef $guard;
985} 1055}
986 1056
987sub object_freezer_as_string { 1057sub object_freezer_as_string {
988 my ($rdata, $objs) = @_; 1058 my ($rdata, $objs) = @_;
989 1059
… …
994 1064
995sub object_thawer_load { 1065sub object_thawer_load {
996 my ($filename) = @_; 1066 my ($filename) = @_;
997 1067
998 my ($data, $av); 1068 my ($data, $av);
1069
1070 my $guard = cf::lock_acquire "io";
999 1071
1000 (aio_load $filename, $data) >= 0 1072 (aio_load $filename, $data) >= 0
1001 or return; 1073 or return;
1002 1074
1003 unless (aio_stat "$filename.pst") { 1075 unless (aio_stat "$filename.pst") {
1004 (aio_load "$filename.pst", $av) >= 0 1076 (aio_load "$filename.pst", $av) >= 0
1005 or return; 1077 or return;
1078
1079 undef $guard;
1006 $av = eval { (Storable::thaw $av)->{objs} }; 1080 $av = eval { (Storable::thaw $av)->{objs} };
1007 } 1081 }
1008 1082
1083 utf8::decode (my $decname = $filename);
1009 warn sprintf "loading %s (%d)\n", 1084 warn sprintf "loading %s (%d,%d)\n",
1010 $filename, length $data, scalar @{$av || []}; 1085 $decname, length $data, scalar @{$av || []};
1086
1011 return ($data, $av); 1087 ($data, $av)
1012} 1088}
1013 1089
1014=head2 COMMAND CALLBACKS 1090=head2 COMMAND CALLBACKS
1015 1091
1016=over 4 1092=over 4
… …
1089 my ($pl, $buf) = @_; 1165 my ($pl, $buf) = @_;
1090 1166
1091 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) }; 1167 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1092 1168
1093 if (ref $msg) { 1169 if (ref $msg) {
1170 my ($type, $reply, @payload) =
1171 "ARRAY" eq ref $msg
1172 ? @$msg
1173 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1174
1175 my @reply;
1176
1094 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1177 if (my $cb = $EXTCMD{$type}) {
1095 if (my %reply = $cb->($pl, $msg)) { 1178 @reply = $cb->($pl, @payload);
1096 $pl->ext_reply ($msg->{msgid}, %reply);
1097 }
1098 } 1179 }
1180
1181 $pl->ext_reply ($reply, @reply)
1182 if $reply;
1183
1099 } else { 1184 } else {
1100 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1185 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1101 } 1186 }
1102 1187
1103 cf::override; 1188 cf::override;
… …
1193 1278
1194=head3 cf::player 1279=head3 cf::player
1195 1280
1196=over 4 1281=over 4
1197 1282
1283=item cf::player::num_playing
1284
1285Returns the official number of playing players, as per the Crossfire metaserver rules.
1286
1287=cut
1288
1289sub num_playing {
1290 scalar grep
1291 $_->ob->map
1292 && !$_->hidden
1293 && !$_->ob->flag (cf::FLAG_WIZ),
1294 cf::player::list
1295}
1296
1198=item cf::player::find $login 1297=item cf::player::find $login
1199 1298
1200Returns the given player object, loading it if necessary (might block). 1299Returns the given player object, loading it if necessary (might block).
1201 1300
1202=cut 1301=cut
… …
1237 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst"; 1336 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1238 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata"; 1337 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1239 aio_unlink +(playerdir $login) . "/$login.pl.pst"; 1338 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1240 aio_unlink +(playerdir $login) . "/$login.pl"; 1339 aio_unlink +(playerdir $login) . "/$login.pl";
1241 1340
1242 my $pl = load_pl path $login 1341 my $f = new_from_file cf::object::thawer path $login
1243 or return; 1342 or return;
1343
1344 $f->next;
1345 my $pl = cf::player::load_pl $f
1346 or return;
1347 local $cf::PLAYER_LOADING{$login} = $pl;
1348 $f->resolve_delayed_derefs;
1244 $cf::PLAYER{$login} = $pl 1349 $cf::PLAYER{$login} = $pl
1245 } 1350 }
1246 } 1351 }
1247} 1352}
1248 1353
… …
1258 1363
1259 aio_mkdir playerdir $pl, 0770; 1364 aio_mkdir playerdir $pl, 0770;
1260 $pl->{last_save} = $cf::RUNTIME; 1365 $pl->{last_save} = $cf::RUNTIME;
1261 1366
1262 $pl->save_pl ($path); 1367 $pl->save_pl ($path);
1263 Coro::cede; 1368 cf::cede_to_tick;
1264} 1369}
1265 1370
1266sub new($) { 1371sub new($) {
1267 my ($login) = @_; 1372 my ($login) = @_;
1268 1373
… …
1272 $self->{deny_save} = 1; 1377 $self->{deny_save} = 1;
1273 1378
1274 $cf::PLAYER{$login} = $self; 1379 $cf::PLAYER{$login} = $self;
1275 1380
1276 $self 1381 $self
1382}
1383
1384=item $player->send_msg ($channel, $msg, $color, [extra...])
1385
1386=cut
1387
1388sub send_msg {
1389 my $ns = shift->ns
1390 or return;
1391 $ns->send_msg (@_);
1277} 1392}
1278 1393
1279=item $pl->quit_character 1394=item $pl->quit_character
1280 1395
1281Nukes the player without looking back. If logged in, the connection will 1396Nukes the player without looking back. If logged in, the connection will
… …
1336 or return []; 1451 or return [];
1337 1452
1338 my @logins; 1453 my @logins;
1339 1454
1340 for my $login (@$dirs) { 1455 for my $login (@$dirs) {
1456 my $path = path $login;
1457
1458 # a .pst is a dead give-away for a valid player
1459 unless (-e "$path.pst") {
1341 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1460 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1342 aio_read $fh, 0, 512, my $buf, 0 or next; 1461 aio_read $fh, 0, 512, my $buf, 0 or next;
1343 $buf !~ /^password -------------$/m or next; # official not-valid tag 1462 $buf !~ /^password -------------$/m or next; # official not-valid tag
1463 }
1344 1464
1345 utf8::decode $login; 1465 utf8::decode $login;
1346 push @logins, $login; 1466 push @logins, $login;
1347 } 1467 }
1348 1468
… …
1386sub expand_cfpod { 1506sub expand_cfpod {
1387 ((my $self), (local $_)) = @_; 1507 ((my $self), (local $_)) = @_;
1388 1508
1389 # escape & and < 1509 # escape & and <
1390 s/&/&amp;/g; 1510 s/&/&amp;/g;
1391 s/(?<![BIUGH])</&lt;/g; 1511 s/(?<![BIUGHT])</&lt;/g;
1392 1512
1393 # this is buggy, it needs to properly take care of nested <'s 1513 # this is buggy, it needs to properly take care of nested <'s
1394 1514
1395 1 while 1515 1 while
1396 # replace B<>, I<>, U<> etc. 1516 # replace B<>, I<>, U<> etc.
1397 s/B<([^\>]*)>/<b>$1<\/b>/ 1517 s/B<([^\>]*)>/<b>$1<\/b>/
1398 || s/I<([^\>]*)>/<i>$1<\/i>/ 1518 || s/I<([^\>]*)>/<i>$1<\/i>/
1399 || s/U<([^\>]*)>/<u>$1<\/u>/ 1519 || s/U<([^\>]*)>/<u>$1<\/u>/
1520 || s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/
1400 # replace G<male|female> tags 1521 # replace G<male|female> tags
1401 || s{G<([^>|]*)\|([^>]*)>}{ 1522 || s{G<([^>|]*)\|([^>]*)>}{
1402 $self->gender ? $2 : $1 1523 $self->gender ? $2 : $1
1403 }ge 1524 }ge
1404 # replace H<hint text> 1525 # replace H<hint text>
… …
1412 1533
1413 # create single paragraphs (very hackish) 1534 # create single paragraphs (very hackish)
1414 s/(?<=\S)\n(?=\w)/ /g; 1535 s/(?<=\S)\n(?=\w)/ /g;
1415 1536
1416 # compress some whitespace 1537 # compress some whitespace
1417 1 while s/\s*\n\s*\n\s*/\n/; 1538 s/\s+\n/\n/g; # ws line-ends
1539 s/\n\n+/\n/g; # double lines
1540 s/^\n+//; # beginning lines
1541 s/\n+$//; # ending lines
1418 1542
1419 $_ 1543 $_
1420} 1544}
1421 1545
1422sub hintmode { 1546sub hintmode {
1423 $_[0]{hintmode} = $_[1] if @_ > 1; 1547 $_[0]{hintmode} = $_[1] if @_ > 1;
1424 $_[0]{hintmode} 1548 $_[0]{hintmode}
1425} 1549}
1426 1550
1427=item $player->ext_reply ($msgid, %msg) 1551=item $player->ext_reply ($msgid, @msg)
1428 1552
1429Sends an ext reply to the player. 1553Sends an ext reply to the player.
1430 1554
1431=cut 1555=cut
1432 1556
1433sub ext_reply($$%) { 1557sub ext_reply($$@) {
1434 my ($self, $id, %msg) = @_; 1558 my ($self, $id, @msg) = @_;
1435 1559
1436 $msg{msgid} = $id; 1560 $self->ns->ext_reply ($id, @msg)
1437 $self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));
1438} 1561}
1439 1562
1440=item $player->ext_event ($type, %msg) 1563=item $player->ext_msg ($type, @msg)
1441 1564
1442Sends an ext event to the client. 1565Sends an ext event to the client.
1443 1566
1444=cut 1567=cut
1445 1568
1446sub ext_event($$%) { 1569sub ext_msg($$@) {
1447 my ($self, $type, %msg) = @_; 1570 my ($self, $type, @msg) = @_;
1448 1571
1449 $self->ns->ext_event ($type, %msg); 1572 $self->ns->ext_msg ($type, @msg);
1450} 1573}
1451 1574
1452=head3 cf::region 1575=head3 cf::region
1453 1576
1454=over 4 1577=over 4
… …
1467 my ($path) = @_; 1590 my ($path) = @_;
1468 1591
1469 my ($match, $specificity); 1592 my ($match, $specificity);
1470 1593
1471 for my $region (list) { 1594 for my $region (list) {
1472 if ($region->match && $path =~ $region->match) { 1595 if ($region->{match} && $path =~ $region->{match}) {
1473 ($match, $specificity) = ($region, $region->specificity) 1596 ($match, $specificity) = ($region, $region->specificity)
1474 if $region->specificity > $specificity; 1597 if $region->specificity > $specificity;
1475 } 1598 }
1476 } 1599 }
1477 1600
… …
1597 $self->init; # pass $1 etc. 1720 $self->init; # pass $1 etc.
1598 return $self; 1721 return $self;
1599 } 1722 }
1600 } 1723 }
1601 1724
1602 Carp::carp "unable to resolve path '$path' (base '$base')."; 1725 Carp::cluck "unable to resolve path '$path' (base '$base').";
1603 () 1726 ()
1604} 1727}
1605 1728
1606sub init { 1729sub init {
1607 my ($self) = @_; 1730 my ($self) = @_;
… …
1670 1793
1671sub load_header_from($) { 1794sub load_header_from($) {
1672 my ($self, $path) = @_; 1795 my ($self, $path) = @_;
1673 1796
1674 utf8::encode $path; 1797 utf8::encode $path;
1675 #aio_open $path, O_RDONLY, 0 1798 my $f = new_from_file cf::object::thawer $path
1676 # or return;
1677
1678 $self->_load_header ($path)
1679 or return; 1799 or return;
1800
1801 $self->_load_header ($f)
1802 or return;
1803
1804 local $MAP_LOADING{$self->{path}} = $self;
1805 $f->resolve_delayed_derefs;
1680 1806
1681 $self->{load_path} = $path; 1807 $self->{load_path} = $path;
1682 1808
1683 1 1809 1
1684} 1810}
… …
1738sub find { 1864sub find {
1739 my ($path, $origin) = @_; 1865 my ($path, $origin) = @_;
1740 1866
1741 $path = normalise $path, $origin && $origin->path; 1867 $path = normalise $path, $origin && $origin->path;
1742 1868
1869 cf::lock_wait "map_data:$path";#d#remove
1743 cf::lock_wait "map_find:$path"; 1870 cf::lock_wait "map_find:$path";
1744 1871
1745 $cf::MAP{$path} || do { 1872 $cf::MAP{$path} || do {
1746 my $guard = cf::lock_acquire "map_find:$path"; 1873 my $guard1 = cf::lock_acquire "map_find:$path";
1874 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1875
1747 my $map = new_from_path cf::map $path 1876 my $map = new_from_path cf::map $path
1748 or return; 1877 or return;
1749 1878
1750 $map->{last_save} = $cf::RUNTIME; 1879 $map->{last_save} = $cf::RUNTIME;
1751 1880
… …
1753 or return; 1882 or return;
1754 1883
1755 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 1884 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1756 # doing this can freeze the server in a sync job, obviously 1885 # doing this can freeze the server in a sync job, obviously
1757 #$cf::WAIT_FOR_TICK->wait; 1886 #$cf::WAIT_FOR_TICK->wait;
1887 undef $guard1;
1888 undef $guard2;
1758 $map->reset; 1889 $map->reset;
1759 undef $guard;
1760 return find $path; 1890 return find $path;
1761 } 1891 }
1762 1892
1763 $cf::MAP{$path} = $map 1893 $cf::MAP{$path} = $map
1764 } 1894 }
… …
1773 local $self->{deny_reset} = 1; # loading can take a long time 1903 local $self->{deny_reset} = 1; # loading can take a long time
1774 1904
1775 my $path = $self->{path}; 1905 my $path = $self->{path};
1776 1906
1777 { 1907 {
1778 my $guard = cf::lock_acquire "map_load:$path"; 1908 my $guard = cf::lock_acquire "map_data:$path";
1779 1909
1910 return unless $self->valid;
1780 return if $self->in_memory != cf::MAP_SWAPPED; 1911 return unless $self->in_memory == cf::MAP_SWAPPED;
1781 1912
1782 $self->in_memory (cf::MAP_LOADING); 1913 $self->in_memory (cf::MAP_LOADING);
1783 1914
1784 $self->alloc; 1915 $self->alloc;
1785 1916
1786 $self->pre_load; 1917 $self->pre_load;
1787 Coro::cede; 1918 cf::cede_to_tick;
1788 1919
1920 my $f = new_from_file cf::object::thawer $self->{load_path};
1921 $f->skip_block;
1789 $self->_load_objects ($self->{load_path}, 1) 1922 $self->_load_objects ($f)
1790 or return; 1923 or return;
1791 1924
1792 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 1925 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1793 if delete $self->{load_original}; 1926 if delete $self->{load_original};
1794 1927
1795 if (my $uniq = $self->uniq_path) { 1928 if (my $uniq = $self->uniq_path) {
1796 utf8::encode $uniq; 1929 utf8::encode $uniq;
1797 if (aio_open $uniq, O_RDONLY, 0) { 1930 unless (aio_stat $uniq) {
1931 if (my $f = new_from_file cf::object::thawer $uniq) {
1798 $self->clear_unique_items; 1932 $self->clear_unique_items;
1799 $self->_load_objects ($uniq, 0); 1933 $self->_load_objects ($f);
1934 $f->resolve_delayed_derefs;
1935 }
1800 } 1936 }
1801 } 1937 }
1802 1938
1803 Coro::cede; 1939 $f->resolve_delayed_derefs;
1940
1941 cf::cede_to_tick;
1804 # now do the right thing for maps 1942 # now do the right thing for maps
1805 $self->link_multipart_objects; 1943 $self->link_multipart_objects;
1806 $self->difficulty ($self->estimate_difficulty) 1944 $self->difficulty ($self->estimate_difficulty)
1807 unless $self->difficulty; 1945 unless $self->difficulty;
1808 Coro::cede; 1946 cf::cede_to_tick;
1809 1947
1810 unless ($self->{deny_activate}) { 1948 unless ($self->{deny_activate}) {
1811 $self->decay_objects; 1949 $self->decay_objects;
1812 $self->fix_auto_apply; 1950 $self->fix_auto_apply;
1813 $self->update_buttons; 1951 $self->update_buttons;
1814 Coro::cede; 1952 cf::cede_to_tick;
1815 $self->set_darkness_map; 1953 $self->set_darkness_map;
1816 Coro::cede; 1954 cf::cede_to_tick;
1817 $self->activate; 1955 $self->activate;
1818 } 1956 }
1957
1958 $self->{last_save} = $cf::RUNTIME;
1959 $self->last_access ($cf::RUNTIME);
1819 1960
1820 $self->in_memory (cf::MAP_IN_MEMORY); 1961 $self->in_memory (cf::MAP_IN_MEMORY);
1821 } 1962 }
1822 1963
1823 $self->post_load; 1964 $self->post_load;
… …
1834 1975
1835 $self 1976 $self
1836} 1977}
1837 1978
1838# find and load all maps in the 3x3 area around a map 1979# find and load all maps in the 3x3 area around a map
1839sub load_diag { 1980sub load_neighbours {
1840 my ($map) = @_; 1981 my ($map) = @_;
1841 1982
1842 my @diag; # diagonal neighbours 1983 my @neigh; # diagonal neighbours
1843 1984
1844 for (0 .. 3) { 1985 for (0 .. 3) {
1845 my $neigh = $map->tile_path ($_) 1986 my $neigh = $map->tile_path ($_)
1846 or next; 1987 or next;
1847 $neigh = find $neigh, $map 1988 $neigh = find $neigh, $map
1848 or next; 1989 or next;
1849 $neigh->load; 1990 $neigh->load;
1850 1991
1992 push @neigh,
1851 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 1993 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1852 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 1994 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1853 } 1995 }
1854 1996
1855 for (@diag) { 1997 for (grep defined $_->[0], @neigh) {
1998 my ($path, $origin) = @$_;
1856 my $neigh = find @$_ 1999 my $neigh = find $path, $origin
1857 or next; 2000 or next;
1858 $neigh->load; 2001 $neigh->load;
1859 } 2002 }
1860} 2003}
1861 2004
… …
1866} 2009}
1867 2010
1868sub do_load_sync { 2011sub do_load_sync {
1869 my ($map) = @_; 2012 my ($map) = @_;
1870 2013
2014 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
2015 if $Coro::current == $Coro::main;
2016
1871 cf::sync_job { $map->load }; 2017 cf::sync_job { $map->load };
1872} 2018}
1873 2019
1874our %MAP_PREFETCH; 2020our %MAP_PREFETCH;
1875our $MAP_PREFETCHER = undef; 2021our $MAP_PREFETCHER = undef;
1876 2022
1877sub find_async { 2023sub find_async {
1878 my ($path, $origin) = @_; 2024 my ($path, $origin, $load) = @_;
1879 2025
1880 $path = normalise $path, $origin && $origin->{path}; 2026 $path = normalise $path, $origin && $origin->{path};
1881 2027
1882 if (my $map = $cf::MAP{$path}) { 2028 if (my $map = $cf::MAP{$path}) {
1883 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 2029 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY;
1884 } 2030 }
1885 2031
1886 undef $MAP_PREFETCH{$path}; 2032 $MAP_PREFETCH{$path} |= $load;
2033
1887 $MAP_PREFETCHER ||= cf::async { 2034 $MAP_PREFETCHER ||= cf::async {
1888 while (%MAP_PREFETCH) { 2035 while (%MAP_PREFETCH) {
1889 for my $path (keys %MAP_PREFETCH) { 2036 while (my ($k, $v) = each %MAP_PREFETCH) {
1890 my $map = find $path 2037 if (my $map = find $k) {
1891 or next;
1892 $map->load; 2038 $map->load if $v;
2039 }
1893 2040
1894 delete $MAP_PREFETCH{$path}; 2041 delete $MAP_PREFETCH{$k};
1895 } 2042 }
1896 } 2043 }
1897 undef $MAP_PREFETCHER; 2044 undef $MAP_PREFETCHER;
1898 }; 2045 };
1899 $MAP_PREFETCHER->prio (6); 2046 $MAP_PREFETCHER->prio (6);
… …
1902} 2049}
1903 2050
1904sub save { 2051sub save {
1905 my ($self) = @_; 2052 my ($self) = @_;
1906 2053
1907 my $lock = cf::lock_acquire "map_data:" . $self->path; 2054 my $lock = cf::lock_acquire "map_data:$self->{path}";
1908 2055
1909 $self->{last_save} = $cf::RUNTIME; 2056 $self->{last_save} = $cf::RUNTIME;
1910 2057
1911 return unless $self->dirty; 2058 return unless $self->dirty;
1912 2059
… …
1935 my ($self) = @_; 2082 my ($self) = @_;
1936 2083
1937 # save first because save cedes 2084 # save first because save cedes
1938 $self->save; 2085 $self->save;
1939 2086
1940 my $lock = cf::lock_acquire "map_data:" . $self->path; 2087 my $lock = cf::lock_acquire "map_data:$self->{path}";
1941 2088
1942 return if $self->players; 2089 return if $self->players;
1943 return if $self->in_memory != cf::MAP_IN_MEMORY; 2090 return if $self->in_memory != cf::MAP_IN_MEMORY;
1944 return if $self->{deny_save}; 2091 return if $self->{deny_save};
1945 2092
2093 $self->in_memory (cf::MAP_SWAPPED);
2094
2095 $self->deactivate;
2096 $_->clear_links_to ($self) for values %cf::MAP;
1946 $self->clear; 2097 $self->clear;
1947 $self->in_memory (cf::MAP_SWAPPED);
1948} 2098}
1949 2099
1950sub reset_at { 2100sub reset_at {
1951 my ($self) = @_; 2101 my ($self) = @_;
1952 2102
… …
1984 if $uniq; 2134 if $uniq;
1985 } 2135 }
1986 2136
1987 delete $cf::MAP{$self->path}; 2137 delete $cf::MAP{$self->path};
1988 2138
2139 $self->deactivate;
2140 $_->clear_links_to ($self) for values %cf::MAP;
1989 $self->clear; 2141 $self->clear;
1990
1991 $_->clear_links_to ($self) for values %cf::MAP;
1992 2142
1993 $self->unlink_save; 2143 $self->unlink_save;
1994 $self->destroy; 2144 $self->destroy;
1995} 2145}
1996 2146
1997my $nuke_counter = "aaaa"; 2147my $nuke_counter = "aaaa";
1998 2148
1999sub nuke { 2149sub nuke {
2000 my ($self) = @_; 2150 my ($self) = @_;
2001 2151
2152 {
2153 my $lock = cf::lock_acquire "map_data:$self->{path}";
2154
2002 delete $cf::MAP{$self->path}; 2155 delete $cf::MAP{$self->path};
2003 2156
2004 $self->unlink_save; 2157 $self->unlink_save;
2005 2158
2006 bless $self, "cf::map"; 2159 bless $self, "cf::map";
2007 delete $self->{deny_reset}; 2160 delete $self->{deny_reset};
2008 $self->{deny_save} = 1; 2161 $self->{deny_save} = 1;
2009 $self->reset_timeout (1); 2162 $self->reset_timeout (1);
2010 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2163 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2011 2164
2012 $cf::MAP{$self->path} = $self; 2165 $cf::MAP{$self->path} = $self;
2166 }
2013 2167
2014 $self->reset; # polite request, might not happen 2168 $self->reset; # polite request, might not happen
2015} 2169}
2016 2170
2017=item $maps = cf::map::tmp_maps 2171=item $maps = cf::map::tmp_maps
… …
2093 2247
2094sub inv_recursive { 2248sub inv_recursive {
2095 inv_recursive_ inv $_[0] 2249 inv_recursive_ inv $_[0]
2096} 2250}
2097 2251
2252=item $ref = $ob->ref
2253
2254creates and returns a persistent reference to an objetc that can be stored as a string.
2255
2256=item $ob = cf::object::deref ($refstring)
2257
2258returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2259even if the object actually exists. May block.
2260
2261=cut
2262
2263sub deref {
2264 my ($ref) = @_;
2265
2266 # temporary compatibility#TODO#remove
2267 $ref =~ s{^<}{player/<};
2268
2269 if ($ref =~ m{^player\/(<1\.\d+>)/(.*)$}) {
2270 my ($uuid, $name) = ($1, $2);
2271 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2272 or return;
2273 $pl->ob->uuid eq $uuid
2274 or return;
2275
2276 $pl->ob
2277 } else {
2278 warn "$ref: cannot resolve object reference\n";
2279 undef
2280 }
2281}
2282
2098package cf; 2283package cf;
2099 2284
2100=back 2285=back
2101 2286
2102=head3 cf::object::player 2287=head3 cf::object::player
… …
2124 2309
2125 } else { 2310 } else {
2126 my $pl = $self->contr; 2311 my $pl = $self->contr;
2127 2312
2128 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) { 2313 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2129 my $diag = $pl->{npc_dialog}; 2314 my $dialog = $pl->{npc_dialog};
2130 $diag->{pl}->ext_reply ( 2315 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2131 $diag->{id},
2132 msgtype => "reply",
2133 msg => $diag->{pl}->expand_cfpod ($msg),
2134 add_topics => []
2135 );
2136 2316
2137 } else { 2317 } else {
2138 $msg = $npc->name . " says: $msg" if $npc; 2318 $msg = $npc->name . " says: $msg" if $npc;
2139 $self->message ($msg, $flags); 2319 $self->message ($msg, $flags);
2140 } 2320 }
2141 } 2321 }
2322}
2323
2324=item $object->send_msg ($channel, $msg, $color, [extra...])
2325
2326=cut
2327
2328sub cf::object::send_msg {
2329 my $pl = shift->contr
2330 or return;
2331 $pl->send_msg (@_);
2142} 2332}
2143 2333
2144=item $player_object->may ("access") 2334=item $player_object->may ("access")
2145 2335
2146Returns wether the given player is authorized to access resource "access" 2336Returns wether the given player is authorized to access resource "access"
… …
2225 # use -1 or undef as default coordinates, not 0, 0 2415 # use -1 or undef as default coordinates, not 0, 0
2226 ($x, $y) = ($map->enter_x, $map->enter_y) 2416 ($x, $y) = ($map->enter_x, $map->enter_y)
2227 if $x <=0 && $y <= 0; 2417 if $x <=0 && $y <= 0;
2228 2418
2229 $map->load; 2419 $map->load;
2230 $map->load_diag; 2420 $map->load_neighbours;
2231 2421
2232 return unless $self->contr->active; 2422 return unless $self->contr->active;
2233 $self->activate_recursive; 2423 $self->activate_recursive;
2234 2424
2235 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2425 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2236 $self->enter_map ($map, $x, $y); 2426 $self->enter_map ($map, $x, $y);
2237} 2427}
2238 2428
2239=item $player_object->goto ($path, $x, $y[, $check->($map)]) 2429=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2240 2430
2241Moves the player to the given map-path and coordinates by first freezing 2431Moves the player to the given map-path and coordinates by first freezing
2242her, loading and preparing them map, calling the provided $check callback 2432her, loading and preparing them map, calling the provided $check callback
2243that has to return the map if sucecssful, and then unfreezes the player on 2433that has to return the map if sucecssful, and then unfreezes the player on
2244the new (success) or old (failed) map position. 2434the new (success) or old (failed) map position. In either case, $done will
2435be called at the end of this process.
2245 2436
2246=cut 2437=cut
2247 2438
2248our $GOTOGEN; 2439our $GOTOGEN;
2249 2440
2250sub cf::object::player::goto { 2441sub cf::object::player::goto {
2251 my ($self, $path, $x, $y, $check) = @_; 2442 my ($self, $path, $x, $y, $check, $done) = @_;
2252 2443
2253 # do generation counting so two concurrent goto's will be executed in-order 2444 # do generation counting so two concurrent goto's will be executed in-order
2254 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2445 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2255 2446
2256 $self->enter_link; 2447 $self->enter_link;
… …
2276 2467
2277 if ($gen == $self->{_goto_generation}) { 2468 if ($gen == $self->{_goto_generation}) {
2278 delete $self->{_goto_generation}; 2469 delete $self->{_goto_generation};
2279 $self->leave_link ($map, $x, $y); 2470 $self->leave_link ($map, $x, $y);
2280 } 2471 }
2472
2473 $done->() if $done;
2281 })->prio (1); 2474 })->prio (1);
2282} 2475}
2283 2476
2284=item $player_object->enter_exit ($exit_object) 2477=item $player_object->enter_exit ($exit_object)
2285 2478
… …
2354 my $hp = $exit->stats->hp; 2547 my $hp = $exit->stats->hp;
2355 my $sp = $exit->stats->sp; 2548 my $sp = $exit->stats->sp;
2356 2549
2357 $self->enter_link; 2550 $self->enter_link;
2358 2551
2552 # if exit is damned, update players death & WoR home-position
2553 $self->contr->savebed ($slaying, $hp, $sp)
2554 if $exit->flag (FLAG_DAMNED);
2555
2359 (async { 2556 (async {
2360 $self->deactivate_recursive; # just to be sure 2557 $self->deactivate_recursive; # just to be sure
2361 unless (eval { 2558 unless (eval {
2362 $self->goto ($slaying, $hp, $sp); 2559 $self->goto ($slaying, $hp, $sp);
2363 2560
… …
2390 2587
2391 utf8::encode $text; 2588 utf8::encode $text;
2392 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2589 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2393} 2590}
2394 2591
2395=item $client->send_msg ($color, $type, $msg, [extra...]) 2592=item $client->send_msg ($channel, $msg, $color, [extra...])
2396 2593
2397Send a drawinfo or msg packet to the client, formatting the msg for the 2594Send a drawinfo or msg packet to the client, formatting the msg for the
2398client if neccessary. C<$type> should be a string identifying the type of 2595client if neccessary. C<$type> should be a string identifying the type of
2399the message, with C<log> being the default. If C<$color> is negative, suppress 2596the message, with C<log> being the default. If C<$color> is negative, suppress
2400the message unless the client supports the msg packet. 2597the message unless the client supports the msg packet.
2401 2598
2402=cut 2599=cut
2403 2600
2601our %CHANNEL = (
2602 "c/identify" => {
2603 id => "identify",
2604 title => "Identify",
2605 reply => undef,
2606 tooltip => "Items recently identified",
2607 },
2608 "c/examine" => {
2609 id => "examine",
2610 title => "Examine",
2611 reply => undef,
2612 tooltip => "Signs and other items you examined",
2613 },
2614);
2615
2404sub cf::client::send_msg { 2616sub cf::client::send_msg {
2405 my ($self, $color, $type, $msg, @extra) = @_; 2617 my ($self, $channel, $msg, $color, @extra) = @_;
2406 2618
2407 $msg = $self->pl->expand_cfpod ($msg); 2619 $msg = $self->pl->expand_cfpod ($msg);
2408 2620
2621 $color &= cf::NDI_CLIENT_MASK; # just in case...
2622
2623 # check predefined channels, for the benefit of C
2624 $channel = $CHANNEL{$channel} if $CHANNEL{$channel};
2625
2626 if (ref $channel) {
2627 # send meta info to client, if not yet sent
2628 unless (exists $self->{channel}{$channel->{id}}) {
2629 $self->{channel}{$channel->{id}} = $channel;
2630 $self->ext_msg (channel_info => $channel)
2631 if $self->can_msg;
2632 }
2633
2634 $channel = $channel->{id};
2635 }
2636
2637 return unless @extra || length $msg;
2638
2409 if ($self->can_msg) { 2639 if ($self->can_msg) {
2640 # default colour, mask it out
2641 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2642 if $color & cf::NDI_DEF;
2643
2410 $self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $type, $msg, @extra])); 2644 $self->send_packet ("msg " . $self->{json_coder}->encode (
2645 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2411 } else { 2646 } else {
2412 # replace some tags by gcfclient-compatible ones
2413 for ($msg) {
2414 1 while
2415 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2416 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2417 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2418 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2419 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2420 }
2421
2422 if ($color >= 0) { 2647 if ($color >= 0) {
2648 # replace some tags by gcfclient-compatible ones
2649 for ($msg) {
2650 1 while
2651 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2652 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2653 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2654 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2655 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2656 }
2657
2658 $color &= cf::NDI_COLOR_MASK;
2659
2660 utf8::encode $msg;
2661
2423 if (0 && $msg =~ /\[/) { 2662 if (0 && $msg =~ /\[/) {
2663 # COMMAND/INFO
2424 $self->send_packet ("drawextinfo $color 4 0 $msg") 2664 $self->send_packet ("drawextinfo $color 10 8 $msg")
2425 } else { 2665 } else {
2426 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g; 2666 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2427 $self->send_packet ("drawinfo $color $msg") 2667 $self->send_packet ("drawinfo $color $msg")
2428 } 2668 }
2429 } 2669 }
2430 } 2670 }
2431} 2671}
2432 2672
2433=item $client->ext_event ($type, %msg) 2673=item $client->ext_msg ($type, @msg)
2434 2674
2435Sends an ext event to the client. 2675Sends an ext event to the client.
2436 2676
2437=cut 2677=cut
2438 2678
2439sub cf::client::ext_event($$%) { 2679sub cf::client::ext_msg($$@) {
2440 my ($self, $type, %msg) = @_; 2680 my ($self, $type, @msg) = @_;
2441 2681
2682 if ($self->extcmd == 2) {
2683 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2684 } elsif ($self->extcmd == 1) { # TODO: remove
2442 $msg{msgtype} = "event_$type"; 2685 push @msg, msgtype => "event_$type";
2443 $self->send_packet ("ext " . $self->{json_coder}->encode (\%msg)); 2686 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2687 }
2688}
2689
2690=item $client->ext_reply ($msgid, @msg)
2691
2692Sends an ext reply to the client.
2693
2694=cut
2695
2696sub cf::client::ext_reply($$@) {
2697 my ($self, $id, @msg) = @_;
2698
2699 if ($self->extcmd == 2) {
2700 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2701 } elsif ($self->extcmd == 1) {
2702 #TODO: version 1, remove
2703 unshift @msg, msgtype => "reply", msgid => $id;
2704 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2705 }
2444} 2706}
2445 2707
2446=item $success = $client->query ($flags, "text", \&cb) 2708=item $success = $client->query ($flags, "text", \&cb)
2447 2709
2448Queues a query to the client, calling the given callback with 2710Queues a query to the client, calling the given callback with
… …
2503 my ($ns, $buf) = @_; 2765 my ($ns, $buf) = @_;
2504 2766
2505 my $msg = eval { $ns->{json_coder}->decode ($buf) }; 2767 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2506 2768
2507 if (ref $msg) { 2769 if (ref $msg) {
2770 my ($type, $reply, @payload) =
2771 "ARRAY" eq ref $msg
2772 ? @$msg
2773 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
2774
2775 my @reply;
2776
2508 if (my $cb = $EXTICMD{$msg->{msgtype}}) { 2777 if (my $cb = $EXTICMD{$type}) {
2509 if (my %reply = $cb->($ns, $msg)) { 2778 @reply = $cb->($ns, @payload);
2510 $reply{msgid} = $msg->{msgid};
2511 $ns->send ("ext " . $ns->{json_coder}->encode (\%reply));
2512 }
2513 } 2779 }
2780
2781 $ns->ext_reply ($reply, @reply)
2782 if $reply;
2783
2514 } else { 2784 } else {
2515 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 2785 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2516 } 2786 }
2517 2787
2518 cf::override; 2788 cf::override;
… …
2565our $safe = new Safe "safe"; 2835our $safe = new Safe "safe";
2566our $safe_hole = new Safe::Hole; 2836our $safe_hole = new Safe::Hole;
2567 2837
2568$SIG{FPE} = 'IGNORE'; 2838$SIG{FPE} = 'IGNORE';
2569 2839
2570$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 2840$safe->permit_only (Opcode::opset qw(
2841 :base_core :base_mem :base_orig :base_math
2842 grepstart grepwhile mapstart mapwhile
2843 sort time
2844));
2571 2845
2572# here we export the classes and methods available to script code 2846# here we export the classes and methods available to script code
2573 2847
2574=pod 2848=pod
2575 2849
2576The following functions and methods are available within a safe environment: 2850The following functions and methods are available within a safe environment:
2577 2851
2578 cf::object contr pay_amount pay_player map 2852 cf::object
2853 contr pay_amount pay_player map x y force_find force_add
2854 insert remove name archname title slaying race decrease_ob_nr
2855
2579 cf::object::player player 2856 cf::object::player
2580 cf::player peaceful 2857 player
2581 cf::map trigger 2858
2859 cf::player
2860 peaceful
2861
2862 cf::map
2863 trigger
2582 2864
2583=cut 2865=cut
2584 2866
2585for ( 2867for (
2586 ["cf::object" => qw(contr pay_amount pay_player map)], 2868 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2869 insert remove inv name archname title slaying race
2870 decrease_ob_nr)],
2587 ["cf::object::player" => qw(player)], 2871 ["cf::object::player" => qw(player)],
2588 ["cf::player" => qw(peaceful)], 2872 ["cf::player" => qw(peaceful)],
2589 ["cf::map" => qw(trigger)], 2873 ["cf::map" => qw(trigger)],
2590) { 2874) {
2591 no strict 'refs'; 2875 no strict 'refs';
… …
2667# the server's init and main functions 2951# the server's init and main functions
2668 2952
2669sub load_facedata($) { 2953sub load_facedata($) {
2670 my ($path) = @_; 2954 my ($path) = @_;
2671 2955
2956 # HACK to clear player env face cache, we need some signal framework
2957 # for this (global event?)
2958 %ext::player_env::MUSIC_FACE_CACHE = ();
2959
2960 my $enc = JSON::XS->new->utf8->canonical->relaxed;
2961
2672 warn "loading facedata from $path\n"; 2962 warn "loading facedata from $path\n";
2673 2963
2674 my $facedata; 2964 my $facedata;
2675 0 < aio_load $path, $facedata 2965 0 < aio_load $path, $facedata
2676 or die "$path: $!"; 2966 or die "$path: $!";
… …
2678 $facedata = Coro::Storable::thaw $facedata; 2968 $facedata = Coro::Storable::thaw $facedata;
2679 2969
2680 $facedata->{version} == 2 2970 $facedata->{version} == 2
2681 or cf::cleanup "$path: version mismatch, cannot proceed."; 2971 or cf::cleanup "$path: version mismatch, cannot proceed.";
2682 2972
2973 # patch in the exptable
2974 $facedata->{resource}{"res/exp_table"} = {
2975 type => FT_RSRC,
2976 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
2977 };
2978 cf::cede_to_tick;
2979
2683 { 2980 {
2684 my $faces = $facedata->{faceinfo}; 2981 my $faces = $facedata->{faceinfo};
2685 2982
2686 while (my ($face, $info) = each %$faces) { 2983 while (my ($face, $info) = each %$faces) {
2687 my $idx = (cf::face::find $face) || cf::face::alloc $face; 2984 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2688 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 2985 cf::face::set_visibility $idx, $info->{visibility};
2986 cf::face::set_magicmap $idx, $info->{magicmap};
2689 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 2987 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2690 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 2988 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2691 Coro::cede; 2989
2990 cf::cede_to_tick;
2692 } 2991 }
2693 2992
2694 while (my ($face, $info) = each %$faces) { 2993 while (my ($face, $info) = each %$faces) {
2695 next unless $info->{smooth}; 2994 next unless $info->{smooth};
2696 my $idx = cf::face::find $face 2995 my $idx = cf::face::find $face
2697 or next; 2996 or next;
2698 if (my $smooth = cf::face::find $info->{smooth}) { 2997 if (my $smooth = cf::face::find $info->{smooth}) {
2998 cf::face::set_smooth $idx, $smooth;
2699 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel}; 2999 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2700 } else { 3000 } else {
2701 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3001 warn "smooth face '$info->{smooth}' not found for face '$face'";
2702 } 3002 }
2703 Coro::cede; 3003
3004 cf::cede_to_tick;
2704 } 3005 }
2705 } 3006 }
2706 3007
2707 { 3008 {
2708 my $anims = $facedata->{animinfo}; 3009 my $anims = $facedata->{animinfo};
2709 3010
2710 while (my ($anim, $info) = each %$anims) { 3011 while (my ($anim, $info) = each %$anims) {
2711 cf::anim::set $anim, $info->{frames}, $info->{facings}; 3012 cf::anim::set $anim, $info->{frames}, $info->{facings};
2712 Coro::cede; 3013 cf::cede_to_tick;
2713 } 3014 }
2714 3015
2715 cf::anim::invalidate_all; # d'oh 3016 cf::anim::invalidate_all; # d'oh
2716 } 3017 }
2717 3018
3019 {
3020 # TODO: for gcfclient pleasure, we should give resources
3021 # that gcfclient doesn't grok a >10000 face index.
3022 my $res = $facedata->{resource};
3023
3024 my $soundconf = delete $res->{"res/sound.conf"};
3025
3026 while (my ($name, $info) = each %$res) {
3027 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3028 my $data;
3029
3030 if ($info->{type} & 1) {
3031 # prepend meta info
3032
3033 my $meta = $enc->encode ({
3034 name => $name,
3035 %{ $info->{meta} || {} },
3036 });
3037
3038 $data = pack "(w/a*)*", $meta, $info->{data};
3039 } else {
3040 $data = $info->{data};
3041 }
3042
3043 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3044 cf::face::set_type $idx, $info->{type};
3045
3046 cf::cede_to_tick;
3047 }
3048
3049 if ($soundconf) {
3050 $soundconf = $enc->decode (delete $soundconf->{data});
3051
3052 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3053 my $sound = $soundconf->{compat}[$_]
3054 or next;
3055
3056 my $face = cf::face::find "sound/$sound->[1]";
3057 cf::sound::set $sound->[0] => $face;
3058 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3059 }
3060
3061 while (my ($k, $v) = each %{$soundconf->{event}}) {
3062 my $face = cf::face::find "sound/$v";
3063 cf::sound::set $k => $face;
3064 }
3065 }
3066 }
3067
2718 1 3068 1
2719} 3069}
2720 3070
3071register_exticmd fx_want => sub {
3072 my ($ns, $want) = @_;
3073
3074 while (my ($k, $v) = each %$want) {
3075 $ns->fx_want ($k, $v);
3076 }
3077};
3078
2721sub reload_regions { 3079sub reload_regions {
3080 # HACK to clear player env face cache, we need some signal framework
3081 # for this (global event?)
3082 %ext::player_env::MUSIC_FACE_CACHE = ();
3083
2722 load_resource_file "$MAPDIR/regions" 3084 load_resource_file "$MAPDIR/regions"
2723 or die "unable to load regions file\n"; 3085 or die "unable to load regions file\n";
3086
3087 for (cf::region::list) {
3088 $_->{match} = qr/$_->{match}/
3089 if exists $_->{match};
3090 }
2724} 3091}
2725 3092
2726sub reload_facedata { 3093sub reload_facedata {
2727 load_facedata "$DATADIR/facedata" 3094 load_facedata "$DATADIR/facedata"
2728 or die "unable to load facedata\n"; 3095 or die "unable to load facedata\n";
… …
2757 3124
2758sub init { 3125sub init {
2759 reload_resources; 3126 reload_resources;
2760} 3127}
2761 3128
2762sub cfg_load { 3129sub reload_config {
2763 open my $fh, "<:utf8", "$CONFDIR/config" 3130 open my $fh, "<:utf8", "$CONFDIR/config"
2764 or return; 3131 or return;
2765 3132
2766 local $/; 3133 local $/;
2767 *CFG = YAML::Syck::Load <$fh>; 3134 *CFG = YAML::Syck::Load <$fh>;
… …
2787 (async { 3154 (async {
2788 Event::one_event; 3155 Event::one_event;
2789 })->prio (Coro::PRIO_MAX); 3156 })->prio (Coro::PRIO_MAX);
2790 }; 3157 };
2791 3158
2792 cfg_load; 3159 reload_config;
2793 db_init; 3160 db_init;
2794 load_extensions; 3161 load_extensions;
2795 3162
2796 $TICK_WATCHER->start; 3163 $TICK_WATCHER->start;
2797 Event::loop; 3164 Event::loop;
… …
2990 warn "reloading cf.pm"; 3357 warn "reloading cf.pm";
2991 require cf; 3358 require cf;
2992 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3359 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2993 3360
2994 warn "loading config and database again"; 3361 warn "loading config and database again";
2995 cf::cfg_load; 3362 cf::reload_config;
2996 3363
2997 warn "loading extensions"; 3364 warn "loading extensions";
2998 cf::load_extensions; 3365 cf::load_extensions;
2999 3366
3000 warn "reattaching attachments to objects/players"; 3367 warn "reattaching attachments to objects/players";
… …
3093 or die; 3460 or die;
3094 3461
3095 $map->width (50); 3462 $map->width (50);
3096 $map->height (50); 3463 $map->height (50);
3097 $map->alloc; 3464 $map->alloc;
3098 $map->_load_objects ("/tmp/x.map", 1); 3465 $map->_load_objects ("/tmp/x.map", 1); #TODO: does not work
3099 my $t = Event::time - $t; 3466 my $t = Event::time - $t;
3100 3467
3101 #next unless $t < 0.0013;#d# 3468 #next unless $t < 0.0013;#d#
3102 if ($t < $min) { 3469 if ($t < $min) {
3103 $min = $t; 3470 $min = $t;

Diff Legend

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