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.288 by root, Mon Jun 25 07:40:53 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';
… …
248 255
249Converts a perl data structure into its JSON representation. 256Converts a perl data structure into its JSON representation.
250 257
251=cut 258=cut
252 259
253our $json_coder = JSON::XS->new->convert_blessed->utf8->max_size (1e6); # accept ~1mb max 260our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
254 261
255sub to_json ($) { $json_coder->encode ($_[0]) } 262sub to_json ($) { $json_coder->encode ($_[0]) }
256sub from_json ($) { $json_coder->decode ($_[0]) } 263sub from_json ($) { $json_coder->decode ($_[0]) }
257 264
258=item cf::lock_wait $string 265=item cf::lock_wait $string
… …
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
… …
1086 cf::override; 1162 cf::override;
1087 }, 1163 },
1088 on_extcmd => sub { 1164 on_extcmd => sub {
1089 my ($pl, $buf) = @_; 1165 my ($pl, $buf) = @_;
1090 1166
1091 my $msg = eval { from_json $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>
1405 || s/H<([^\>]*)>/<fg name="lightblue">[$1]<\/fg>/g; 1526 || s{H<([^\>]*)>}
1527 {
1528 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
1529 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1530 "")
1531 [$self->{hintmode}]
1532 }ge;
1406 1533
1407 # create single paragraphs (very hackish) 1534 # create single paragraphs (very hackish)
1408 s/(?<=\S)\n(?=\w)/ /g; 1535 s/(?<=\S)\n(?=\w)/ /g;
1409 1536
1537 # compress some whitespace
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
1542
1410 $_ 1543 $_
1411} 1544}
1412 1545
1546sub hintmode {
1547 $_[0]{hintmode} = $_[1] if @_ > 1;
1548 $_[0]{hintmode}
1549}
1550
1413=item $player->ext_reply ($msgid, %msg) 1551=item $player->ext_reply ($msgid, @msg)
1414 1552
1415Sends an ext reply to the player. 1553Sends an ext reply to the player.
1416 1554
1417=cut 1555=cut
1418 1556
1419sub ext_reply($$%) { 1557sub ext_reply($$@) {
1420 my ($self, $id, %msg) = @_; 1558 my ($self, $id, @msg) = @_;
1421 1559
1422 $msg{msgid} = $id; 1560 $self->ns->ext_reply ($id, @msg)
1423 $self->send ("ext " . cf::to_json \%msg);
1424} 1561}
1425 1562
1426=item $player->ext_event ($type, %msg) 1563=item $player->ext_msg ($type, @msg)
1427 1564
1428Sends an ext event to the client. 1565Sends an ext event to the client.
1429 1566
1430=cut 1567=cut
1431 1568
1432sub ext_event($$%) { 1569sub ext_msg($$@) {
1433 my ($self, $type, %msg) = @_; 1570 my ($self, $type, @msg) = @_;
1434 1571
1435 $self->ns->ext_event ($type, %msg); 1572 $self->ns->ext_msg ($type, @msg);
1436} 1573}
1437 1574
1438=head3 cf::region 1575=head3 cf::region
1439 1576
1440=over 4 1577=over 4
… …
1453 my ($path) = @_; 1590 my ($path) = @_;
1454 1591
1455 my ($match, $specificity); 1592 my ($match, $specificity);
1456 1593
1457 for my $region (list) { 1594 for my $region (list) {
1458 if ($region->match && $path =~ $region->match) { 1595 if ($region->{match} && $path =~ $region->{match}) {
1459 ($match, $specificity) = ($region, $region->specificity) 1596 ($match, $specificity) = ($region, $region->specificity)
1460 if $region->specificity > $specificity; 1597 if $region->specificity > $specificity;
1461 } 1598 }
1462 } 1599 }
1463 1600
… …
1583 $self->init; # pass $1 etc. 1720 $self->init; # pass $1 etc.
1584 return $self; 1721 return $self;
1585 } 1722 }
1586 } 1723 }
1587 1724
1588 Carp::carp "unable to resolve path '$path' (base '$base')."; 1725 Carp::cluck "unable to resolve path '$path' (base '$base').";
1589 () 1726 ()
1590} 1727}
1591 1728
1592sub init { 1729sub init {
1593 my ($self) = @_; 1730 my ($self) = @_;
… …
1656 1793
1657sub load_header_from($) { 1794sub load_header_from($) {
1658 my ($self, $path) = @_; 1795 my ($self, $path) = @_;
1659 1796
1660 utf8::encode $path; 1797 utf8::encode $path;
1661 #aio_open $path, O_RDONLY, 0 1798 my $f = new_from_file cf::object::thawer $path
1662 # or return;
1663
1664 $self->_load_header ($path)
1665 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;
1666 1806
1667 $self->{load_path} = $path; 1807 $self->{load_path} = $path;
1668 1808
1669 1 1809 1
1670} 1810}
… …
1724sub find { 1864sub find {
1725 my ($path, $origin) = @_; 1865 my ($path, $origin) = @_;
1726 1866
1727 $path = normalise $path, $origin && $origin->path; 1867 $path = normalise $path, $origin && $origin->path;
1728 1868
1869 cf::lock_wait "map_data:$path";#d#remove
1729 cf::lock_wait "map_find:$path"; 1870 cf::lock_wait "map_find:$path";
1730 1871
1731 $cf::MAP{$path} || do { 1872 $cf::MAP{$path} || do {
1732 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
1733 my $map = new_from_path cf::map $path 1876 my $map = new_from_path cf::map $path
1734 or return; 1877 or return;
1735 1878
1736 $map->{last_save} = $cf::RUNTIME; 1879 $map->{last_save} = $cf::RUNTIME;
1737 1880
… …
1739 or return; 1882 or return;
1740 1883
1741 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 1884 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1742 # doing this can freeze the server in a sync job, obviously 1885 # doing this can freeze the server in a sync job, obviously
1743 #$cf::WAIT_FOR_TICK->wait; 1886 #$cf::WAIT_FOR_TICK->wait;
1887 undef $guard1;
1888 undef $guard2;
1744 $map->reset; 1889 $map->reset;
1745 undef $guard;
1746 return find $path; 1890 return find $path;
1747 } 1891 }
1748 1892
1749 $cf::MAP{$path} = $map 1893 $cf::MAP{$path} = $map
1750 } 1894 }
… …
1759 local $self->{deny_reset} = 1; # loading can take a long time 1903 local $self->{deny_reset} = 1; # loading can take a long time
1760 1904
1761 my $path = $self->{path}; 1905 my $path = $self->{path};
1762 1906
1763 { 1907 {
1764 my $guard = cf::lock_acquire "map_load:$path"; 1908 my $guard = cf::lock_acquire "map_data:$path";
1765 1909
1910 return unless $self->valid;
1766 return if $self->in_memory != cf::MAP_SWAPPED; 1911 return unless $self->in_memory == cf::MAP_SWAPPED;
1767 1912
1768 $self->in_memory (cf::MAP_LOADING); 1913 $self->in_memory (cf::MAP_LOADING);
1769 1914
1770 $self->alloc; 1915 $self->alloc;
1771 1916
1772 $self->pre_load; 1917 $self->pre_load;
1773 Coro::cede; 1918 cf::cede_to_tick;
1774 1919
1920 my $f = new_from_file cf::object::thawer $self->{load_path};
1921 $f->skip_block;
1775 $self->_load_objects ($self->{load_path}, 1) 1922 $self->_load_objects ($f)
1776 or return; 1923 or return;
1777 1924
1778 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 1925 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1779 if delete $self->{load_original}; 1926 if delete $self->{load_original};
1780 1927
1781 if (my $uniq = $self->uniq_path) { 1928 if (my $uniq = $self->uniq_path) {
1782 utf8::encode $uniq; 1929 utf8::encode $uniq;
1783 if (aio_open $uniq, O_RDONLY, 0) { 1930 unless (aio_stat $uniq) {
1931 if (my $f = new_from_file cf::object::thawer $uniq) {
1784 $self->clear_unique_items; 1932 $self->clear_unique_items;
1785 $self->_load_objects ($uniq, 0); 1933 $self->_load_objects ($f);
1934 $f->resolve_delayed_derefs;
1935 }
1786 } 1936 }
1787 } 1937 }
1788 1938
1789 Coro::cede; 1939 $f->resolve_delayed_derefs;
1940
1941 cf::cede_to_tick;
1790 # now do the right thing for maps 1942 # now do the right thing for maps
1791 $self->link_multipart_objects; 1943 $self->link_multipart_objects;
1792 $self->difficulty ($self->estimate_difficulty) 1944 $self->difficulty ($self->estimate_difficulty)
1793 unless $self->difficulty; 1945 unless $self->difficulty;
1794 Coro::cede; 1946 cf::cede_to_tick;
1795 1947
1796 unless ($self->{deny_activate}) { 1948 unless ($self->{deny_activate}) {
1797 $self->decay_objects; 1949 $self->decay_objects;
1798 $self->fix_auto_apply; 1950 $self->fix_auto_apply;
1799 $self->update_buttons; 1951 $self->update_buttons;
1800 Coro::cede; 1952 cf::cede_to_tick;
1801 $self->set_darkness_map; 1953 $self->set_darkness_map;
1802 Coro::cede; 1954 cf::cede_to_tick;
1803 $self->activate; 1955 $self->activate;
1804 } 1956 }
1957
1958 $self->{last_save} = $cf::RUNTIME;
1959 $self->last_access ($cf::RUNTIME);
1805 1960
1806 $self->in_memory (cf::MAP_IN_MEMORY); 1961 $self->in_memory (cf::MAP_IN_MEMORY);
1807 } 1962 }
1808 1963
1809 $self->post_load; 1964 $self->post_load;
… …
1820 1975
1821 $self 1976 $self
1822} 1977}
1823 1978
1824# 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
1825sub load_diag { 1980sub load_neighbours {
1826 my ($map) = @_; 1981 my ($map) = @_;
1827 1982
1828 my @diag; # diagonal neighbours 1983 my @neigh; # diagonal neighbours
1829 1984
1830 for (0 .. 3) { 1985 for (0 .. 3) {
1831 my $neigh = $map->tile_path ($_) 1986 my $neigh = $map->tile_path ($_)
1832 or next; 1987 or next;
1833 $neigh = find $neigh, $map 1988 $neigh = find $neigh, $map
1834 or next; 1989 or next;
1835 $neigh->load; 1990 $neigh->load;
1836 1991
1992 push @neigh,
1837 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 1993 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1838 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 1994 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1839 } 1995 }
1840 1996
1841 for (@diag) { 1997 for (grep defined $_->[0], @neigh) {
1998 my ($path, $origin) = @$_;
1842 my $neigh = find @$_ 1999 my $neigh = find $path, $origin
1843 or next; 2000 or next;
1844 $neigh->load; 2001 $neigh->load;
1845 } 2002 }
1846} 2003}
1847 2004
… …
1852} 2009}
1853 2010
1854sub do_load_sync { 2011sub do_load_sync {
1855 my ($map) = @_; 2012 my ($map) = @_;
1856 2013
2014 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
2015 if $Coro::current == $Coro::main;
2016
1857 cf::sync_job { $map->load }; 2017 cf::sync_job { $map->load };
1858} 2018}
1859 2019
1860our %MAP_PREFETCH; 2020our %MAP_PREFETCH;
1861our $MAP_PREFETCHER = undef; 2021our $MAP_PREFETCHER = undef;
1862 2022
1863sub find_async { 2023sub find_async {
1864 my ($path, $origin) = @_; 2024 my ($path, $origin, $load) = @_;
1865 2025
1866 $path = normalise $path, $origin && $origin->{path}; 2026 $path = normalise $path, $origin && $origin->{path};
1867 2027
1868 if (my $map = $cf::MAP{$path}) { 2028 if (my $map = $cf::MAP{$path}) {
1869 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 2029 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY;
1870 } 2030 }
1871 2031
1872 undef $MAP_PREFETCH{$path}; 2032 $MAP_PREFETCH{$path} |= $load;
2033
1873 $MAP_PREFETCHER ||= cf::async { 2034 $MAP_PREFETCHER ||= cf::async {
1874 while (%MAP_PREFETCH) { 2035 while (%MAP_PREFETCH) {
1875 for my $path (keys %MAP_PREFETCH) { 2036 while (my ($k, $v) = each %MAP_PREFETCH) {
1876 my $map = find $path 2037 if (my $map = find $k) {
1877 or next;
1878 $map->load; 2038 $map->load if $v;
2039 }
1879 2040
1880 delete $MAP_PREFETCH{$path}; 2041 delete $MAP_PREFETCH{$k};
1881 } 2042 }
1882 } 2043 }
1883 undef $MAP_PREFETCHER; 2044 undef $MAP_PREFETCHER;
1884 }; 2045 };
1885 $MAP_PREFETCHER->prio (6); 2046 $MAP_PREFETCHER->prio (6);
… …
1888} 2049}
1889 2050
1890sub save { 2051sub save {
1891 my ($self) = @_; 2052 my ($self) = @_;
1892 2053
1893 my $lock = cf::lock_acquire "map_data:" . $self->path; 2054 my $lock = cf::lock_acquire "map_data:$self->{path}";
1894 2055
1895 $self->{last_save} = $cf::RUNTIME; 2056 $self->{last_save} = $cf::RUNTIME;
1896 2057
1897 return unless $self->dirty; 2058 return unless $self->dirty;
1898 2059
… …
1921 my ($self) = @_; 2082 my ($self) = @_;
1922 2083
1923 # save first because save cedes 2084 # save first because save cedes
1924 $self->save; 2085 $self->save;
1925 2086
1926 my $lock = cf::lock_acquire "map_data:" . $self->path; 2087 my $lock = cf::lock_acquire "map_data:$self->{path}";
1927 2088
1928 return if $self->players; 2089 return if $self->players;
1929 return if $self->in_memory != cf::MAP_IN_MEMORY; 2090 return if $self->in_memory != cf::MAP_IN_MEMORY;
1930 return if $self->{deny_save}; 2091 return if $self->{deny_save};
1931 2092
2093 $self->in_memory (cf::MAP_SWAPPED);
2094
2095 $self->deactivate;
2096 $_->clear_links_to ($self) for values %cf::MAP;
1932 $self->clear; 2097 $self->clear;
1933 $self->in_memory (cf::MAP_SWAPPED);
1934} 2098}
1935 2099
1936sub reset_at { 2100sub reset_at {
1937 my ($self) = @_; 2101 my ($self) = @_;
1938 2102
… …
1970 if $uniq; 2134 if $uniq;
1971 } 2135 }
1972 2136
1973 delete $cf::MAP{$self->path}; 2137 delete $cf::MAP{$self->path};
1974 2138
2139 $self->deactivate;
2140 $_->clear_links_to ($self) for values %cf::MAP;
1975 $self->clear; 2141 $self->clear;
1976
1977 $_->clear_links_to ($self) for values %cf::MAP;
1978 2142
1979 $self->unlink_save; 2143 $self->unlink_save;
1980 $self->destroy; 2144 $self->destroy;
1981} 2145}
1982 2146
1983my $nuke_counter = "aaaa"; 2147my $nuke_counter = "aaaa";
1984 2148
1985sub nuke { 2149sub nuke {
1986 my ($self) = @_; 2150 my ($self) = @_;
1987 2151
2152 {
2153 my $lock = cf::lock_acquire "map_data:$self->{path}";
2154
1988 delete $cf::MAP{$self->path}; 2155 delete $cf::MAP{$self->path};
1989 2156
1990 $self->unlink_save; 2157 $self->unlink_save;
1991 2158
1992 bless $self, "cf::map"; 2159 bless $self, "cf::map";
1993 delete $self->{deny_reset}; 2160 delete $self->{deny_reset};
1994 $self->{deny_save} = 1; 2161 $self->{deny_save} = 1;
1995 $self->reset_timeout (1); 2162 $self->reset_timeout (1);
1996 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2163 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1997 2164
1998 $cf::MAP{$self->path} = $self; 2165 $cf::MAP{$self->path} = $self;
2166 }
1999 2167
2000 $self->reset; # polite request, might not happen 2168 $self->reset; # polite request, might not happen
2001} 2169}
2002 2170
2003=item $maps = cf::map::tmp_maps 2171=item $maps = cf::map::tmp_maps
… …
2079 2247
2080sub inv_recursive { 2248sub inv_recursive {
2081 inv_recursive_ inv $_[0] 2249 inv_recursive_ inv $_[0]
2082} 2250}
2083 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
2084package cf; 2283package cf;
2085 2284
2086=back 2285=back
2087 2286
2088=head3 cf::object::player 2287=head3 cf::object::player
… …
2110 2309
2111 } else { 2310 } else {
2112 my $pl = $self->contr; 2311 my $pl = $self->contr;
2113 2312
2114 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) { 2313 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2115 my $diag = $pl->{npc_dialog}; 2314 my $dialog = $pl->{npc_dialog};
2116 $diag->{pl}->ext_reply ( 2315 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2117 $diag->{id},
2118 msgtype => "reply",
2119 msg => $diag->{pl}->expand_cfpod ($msg),
2120 add_topics => []
2121 );
2122 2316
2123 } else { 2317 } else {
2124 $msg = $npc->name . " says: $msg" if $npc; 2318 $msg = $npc->name . " says: $msg" if $npc;
2125 $self->message ($msg, $flags); 2319 $self->message ($msg, $flags);
2126 } 2320 }
2127 } 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 (@_);
2128} 2332}
2129 2333
2130=item $player_object->may ("access") 2334=item $player_object->may ("access")
2131 2335
2132Returns wether the given player is authorized to access resource "access" 2336Returns wether the given player is authorized to access resource "access"
… …
2211 # use -1 or undef as default coordinates, not 0, 0 2415 # use -1 or undef as default coordinates, not 0, 0
2212 ($x, $y) = ($map->enter_x, $map->enter_y) 2416 ($x, $y) = ($map->enter_x, $map->enter_y)
2213 if $x <=0 && $y <= 0; 2417 if $x <=0 && $y <= 0;
2214 2418
2215 $map->load; 2419 $map->load;
2216 $map->load_diag; 2420 $map->load_neighbours;
2217 2421
2218 return unless $self->contr->active; 2422 return unless $self->contr->active;
2219 $self->activate_recursive; 2423 $self->activate_recursive;
2220 2424
2221 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2425 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2222 $self->enter_map ($map, $x, $y); 2426 $self->enter_map ($map, $x, $y);
2223} 2427}
2224 2428
2225=item $player_object->goto ($path, $x, $y[, $check->($map)]) 2429=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2226 2430
2227Moves 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
2228her, loading and preparing them map, calling the provided $check callback 2432her, loading and preparing them map, calling the provided $check callback
2229that 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
2230the 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.
2231 2436
2232=cut 2437=cut
2233 2438
2234our $GOTOGEN; 2439our $GOTOGEN;
2235 2440
2236sub cf::object::player::goto { 2441sub cf::object::player::goto {
2237 my ($self, $path, $x, $y, $check) = @_; 2442 my ($self, $path, $x, $y, $check, $done) = @_;
2238 2443
2239 # 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
2240 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2445 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2241 2446
2242 $self->enter_link; 2447 $self->enter_link;
… …
2262 2467
2263 if ($gen == $self->{_goto_generation}) { 2468 if ($gen == $self->{_goto_generation}) {
2264 delete $self->{_goto_generation}; 2469 delete $self->{_goto_generation};
2265 $self->leave_link ($map, $x, $y); 2470 $self->leave_link ($map, $x, $y);
2266 } 2471 }
2472
2473 $done->() if $done;
2267 })->prio (1); 2474 })->prio (1);
2268} 2475}
2269 2476
2270=item $player_object->enter_exit ($exit_object) 2477=item $player_object->enter_exit ($exit_object)
2271 2478
… …
2340 my $hp = $exit->stats->hp; 2547 my $hp = $exit->stats->hp;
2341 my $sp = $exit->stats->sp; 2548 my $sp = $exit->stats->sp;
2342 2549
2343 $self->enter_link; 2550 $self->enter_link;
2344 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
2345 (async { 2556 (async {
2346 $self->deactivate_recursive; # just to be sure 2557 $self->deactivate_recursive; # just to be sure
2347 unless (eval { 2558 unless (eval {
2348 $self->goto ($slaying, $hp, $sp); 2559 $self->goto ($slaying, $hp, $sp);
2349 2560
… …
2376 2587
2377 utf8::encode $text; 2588 utf8::encode $text;
2378 $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);
2379} 2590}
2380 2591
2381=item $client->send_msg ($color, $type, $msg, [extra...]) 2592=item $client->send_msg ($channel, $msg, $color, [extra...])
2382 2593
2383Send 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
2384client 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
2385the 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
2386the message unless the client supports the msg packet. 2597the message unless the client supports the msg packet.
2387 2598
2388=cut 2599=cut
2389 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
2390sub cf::client::send_msg { 2616sub cf::client::send_msg {
2391 my ($self, $color, $type, $msg, @extra) = @_; 2617 my ($self, $channel, $msg, $color, @extra) = @_;
2392 2618
2393 $msg = $self->pl->expand_cfpod ($msg); 2619 $msg = $self->pl->expand_cfpod ($msg);
2394 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
2395 if ($self->can_msg) { 2639 if ($self->can_msg) {
2396 $self->send_packet ("msg " . cf::to_json [$color, $type, $msg, @extra]); 2640 # default colour, mask it out
2641 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2642 if $color & cf::NDI_DEF;
2643
2644 $self->send_packet ("msg " . $self->{json_coder}->encode (
2645 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2397 } else { 2646 } else {
2398 # replace some tags by gcfclient-compatible ones
2399 for ($msg) {
2400 1 while
2401 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2402 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2403 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2404 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2405 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2406 }
2407
2408 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
2409 if (0 && $msg =~ /\[/) { 2662 if (0 && $msg =~ /\[/) {
2663 # COMMAND/INFO
2410 $self->send_packet ("drawextinfo $color 4 0 $msg") 2664 $self->send_packet ("drawextinfo $color 10 8 $msg")
2411 } else { 2665 } else {
2412 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g; 2666 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2413 $self->send_packet ("drawinfo $color $msg") 2667 $self->send_packet ("drawinfo $color $msg")
2414 } 2668 }
2415 } 2669 }
2416 } 2670 }
2417} 2671}
2418 2672
2419=item $client->ext_event ($type, %msg) 2673=item $client->ext_msg ($type, @msg)
2420 2674
2421Sends an ext event to the client. 2675Sends an ext event to the client.
2422 2676
2423=cut 2677=cut
2424 2678
2425sub cf::client::ext_event($$%) { 2679sub cf::client::ext_msg($$@) {
2426 my ($self, $type, %msg) = @_; 2680 my ($self, $type, @msg) = @_;
2427 2681
2682 if ($self->extcmd == 2) {
2683 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2684 } elsif ($self->extcmd == 1) { # TODO: remove
2428 $msg{msgtype} = "event_$type"; 2685 push @msg, msgtype => "event_$type";
2429 $self->send_packet ("ext " . cf::to_json \%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 }
2430} 2706}
2431 2707
2432=item $success = $client->query ($flags, "text", \&cb) 2708=item $success = $client->query ($flags, "text", \&cb)
2433 2709
2434Queues a query to the client, calling the given callback with 2710Queues a query to the client, calling the given callback with
… …
2457 2733
2458 1 2734 1
2459} 2735}
2460 2736
2461cf::client->attach ( 2737cf::client->attach (
2738 on_connect => sub {
2739 my ($ns) = @_;
2740
2741 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2742 },
2462 on_reply => sub { 2743 on_reply => sub {
2463 my ($ns, $msg) = @_; 2744 my ($ns, $msg) = @_;
2464 2745
2465 # this weird shuffling is so that direct followup queries 2746 # this weird shuffling is so that direct followup queries
2466 # get handled first 2747 # get handled first
… …
2481 } 2762 }
2482 }, 2763 },
2483 on_exticmd => sub { 2764 on_exticmd => sub {
2484 my ($ns, $buf) = @_; 2765 my ($ns, $buf) = @_;
2485 2766
2486 my $msg = eval { from_json $buf }; 2767 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2487 2768
2488 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
2489 if (my $cb = $EXTICMD{$msg->{msgtype}}) { 2777 if (my $cb = $EXTICMD{$type}) {
2490 if (my %reply = $cb->($ns, $msg)) { 2778 @reply = $cb->($ns, @payload);
2491 $reply{msgid} = $msg->{msgid};
2492 $ns->send ("ext " . cf::to_json \%reply);
2493 }
2494 } 2779 }
2780
2781 $ns->ext_reply ($reply, @reply)
2782 if $reply;
2783
2495 } else { 2784 } else {
2496 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";
2497 } 2786 }
2498 2787
2499 cf::override; 2788 cf::override;
… …
2546our $safe = new Safe "safe"; 2835our $safe = new Safe "safe";
2547our $safe_hole = new Safe::Hole; 2836our $safe_hole = new Safe::Hole;
2548 2837
2549$SIG{FPE} = 'IGNORE'; 2838$SIG{FPE} = 'IGNORE';
2550 2839
2551$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));
2552 2845
2553# here we export the classes and methods available to script code 2846# here we export the classes and methods available to script code
2554 2847
2555=pod 2848=pod
2556 2849
2557The following functions and methods are available within a safe environment: 2850The following functions and methods are available within a safe environment:
2558 2851
2559 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
2560 cf::object::player player 2856 cf::object::player
2561 cf::player peaceful 2857 player
2562 cf::map trigger 2858
2859 cf::player
2860 peaceful
2861
2862 cf::map
2863 trigger
2563 2864
2564=cut 2865=cut
2565 2866
2566for ( 2867for (
2567 ["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)],
2568 ["cf::object::player" => qw(player)], 2871 ["cf::object::player" => qw(player)],
2569 ["cf::player" => qw(peaceful)], 2872 ["cf::player" => qw(peaceful)],
2570 ["cf::map" => qw(trigger)], 2873 ["cf::map" => qw(trigger)],
2571) { 2874) {
2572 no strict 'refs'; 2875 no strict 'refs';
… …
2648# the server's init and main functions 2951# the server's init and main functions
2649 2952
2650sub load_facedata($) { 2953sub load_facedata($) {
2651 my ($path) = @_; 2954 my ($path) = @_;
2652 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
2653 warn "loading facedata from $path\n"; 2962 warn "loading facedata from $path\n";
2654 2963
2655 my $facedata; 2964 my $facedata;
2656 0 < aio_load $path, $facedata 2965 0 < aio_load $path, $facedata
2657 or die "$path: $!"; 2966 or die "$path: $!";
… …
2659 $facedata = Coro::Storable::thaw $facedata; 2968 $facedata = Coro::Storable::thaw $facedata;
2660 2969
2661 $facedata->{version} == 2 2970 $facedata->{version} == 2
2662 or cf::cleanup "$path: version mismatch, cannot proceed."; 2971 or cf::cleanup "$path: version mismatch, cannot proceed.";
2663 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
2664 { 2980 {
2665 my $faces = $facedata->{faceinfo}; 2981 my $faces = $facedata->{faceinfo};
2666 2982
2667 while (my ($face, $info) = each %$faces) { 2983 while (my ($face, $info) = each %$faces) {
2668 my $idx = (cf::face::find $face) || cf::face::alloc $face; 2984 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2669 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 2985 cf::face::set_visibility $idx, $info->{visibility};
2986 cf::face::set_magicmap $idx, $info->{magicmap};
2670 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 2987 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2671 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 2988 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2672 Coro::cede; 2989
2990 cf::cede_to_tick;
2673 } 2991 }
2674 2992
2675 while (my ($face, $info) = each %$faces) { 2993 while (my ($face, $info) = each %$faces) {
2676 next unless $info->{smooth}; 2994 next unless $info->{smooth};
2677 my $idx = cf::face::find $face 2995 my $idx = cf::face::find $face
2678 or next; 2996 or next;
2679 if (my $smooth = cf::face::find $info->{smooth}) { 2997 if (my $smooth = cf::face::find $info->{smooth}) {
2998 cf::face::set_smooth $idx, $smooth;
2680 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel}; 2999 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2681 } else { 3000 } else {
2682 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3001 warn "smooth face '$info->{smooth}' not found for face '$face'";
2683 } 3002 }
2684 Coro::cede; 3003
3004 cf::cede_to_tick;
2685 } 3005 }
2686 } 3006 }
2687 3007
2688 { 3008 {
2689 my $anims = $facedata->{animinfo}; 3009 my $anims = $facedata->{animinfo};
2690 3010
2691 while (my ($anim, $info) = each %$anims) { 3011 while (my ($anim, $info) = each %$anims) {
2692 cf::anim::set $anim, $info->{frames}, $info->{facings}; 3012 cf::anim::set $anim, $info->{frames}, $info->{facings};
2693 Coro::cede; 3013 cf::cede_to_tick;
2694 } 3014 }
2695 3015
2696 cf::anim::invalidate_all; # d'oh 3016 cf::anim::invalidate_all; # d'oh
2697 } 3017 }
2698 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
2699 1 3068 1
2700} 3069}
2701 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
2702sub 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
2703 load_resource_file "$MAPDIR/regions" 3084 load_resource_file "$MAPDIR/regions"
2704 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 }
2705} 3091}
2706 3092
2707sub reload_facedata { 3093sub reload_facedata {
2708 load_facedata "$DATADIR/facedata" 3094 load_facedata "$DATADIR/facedata"
2709 or die "unable to load facedata\n"; 3095 or die "unable to load facedata\n";
2710} 3096}
2711 3097
2712sub reload_archetypes { 3098sub reload_archetypes {
3099 load_resource_file "$DATADIR/archetypes"
3100 or die "unable to load archetypes\n";
3101 #d# NEED to laod twice to resolve forward references
3102 # this really needs to be done in an extra post-pass
3103 # (which needs to be synchronous, so solve it differently)
2713 load_resource_file "$DATADIR/archetypes" 3104 load_resource_file "$DATADIR/archetypes"
2714 or die "unable to load archetypes\n"; 3105 or die "unable to load archetypes\n";
2715} 3106}
2716 3107
2717sub reload_treasures { 3108sub reload_treasures {
… …
2733 3124
2734sub init { 3125sub init {
2735 reload_resources; 3126 reload_resources;
2736} 3127}
2737 3128
2738sub cfg_load { 3129sub reload_config {
2739 open my $fh, "<:utf8", "$CONFDIR/config" 3130 open my $fh, "<:utf8", "$CONFDIR/config"
2740 or return; 3131 or return;
2741 3132
2742 local $/; 3133 local $/;
2743 *CFG = YAML::Syck::Load <$fh>; 3134 *CFG = YAML::Syck::Load <$fh>;
… …
2763 (async { 3154 (async {
2764 Event::one_event; 3155 Event::one_event;
2765 })->prio (Coro::PRIO_MAX); 3156 })->prio (Coro::PRIO_MAX);
2766 }; 3157 };
2767 3158
2768 cfg_load; 3159 reload_config;
2769 db_init; 3160 db_init;
2770 load_extensions; 3161 load_extensions;
2771 3162
2772 $TICK_WATCHER->start; 3163 $TICK_WATCHER->start;
2773 Event::loop; 3164 Event::loop;
… …
2966 warn "reloading cf.pm"; 3357 warn "reloading cf.pm";
2967 require cf; 3358 require cf;
2968 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3359 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2969 3360
2970 warn "loading config and database again"; 3361 warn "loading config and database again";
2971 cf::cfg_load; 3362 cf::reload_config;
2972 3363
2973 warn "loading extensions"; 3364 warn "loading extensions";
2974 cf::load_extensions; 3365 cf::load_extensions;
2975 3366
2976 warn "reattaching attachments to objects/players"; 3367 warn "reattaching attachments to objects/players";
… …
3069 or die; 3460 or die;
3070 3461
3071 $map->width (50); 3462 $map->width (50);
3072 $map->height (50); 3463 $map->height (50);
3073 $map->alloc; 3464 $map->alloc;
3074 $map->_load_objects ("/tmp/x.map", 1); 3465 $map->_load_objects ("/tmp/x.map", 1); #TODO: does not work
3075 my $t = Event::time - $t; 3466 my $t = Event::time - $t;
3076 3467
3077 #next unless $t < 0.0013;#d# 3468 #next unless $t < 0.0013;#d#
3078 if ($t < $min) { 3469 if ($t < $min) {
3079 $min = $t; 3470 $min = $t;

Diff Legend

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