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.298 by root, Sun Jul 8 14:50:07 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 warn "pst<$res>" unless $res =~ /^pst/;
427 $res = Coro::Storable::thaw $res;
428
429 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
430
431 Carp::confess $$res unless "ARRAY" eq ref $res;
432
433 return wantarray ? @$res : $res->[-1];
434 } else {
435 reset_signals; 496 reset_signals;
436 local $SIG{__WARN__}; 497 &$cb
437 local $SIG{__DIE__}; 498 }, @args;
438 local $Coro::idle;
439 $Coro::current->prio (Coro::PRIO_MAX);
440 eval {
441 close $fh1;
442 499
443 my @res = eval { $cb->(@args) }; 500 wantarray ? @res : $res[-1]
444
445 open my $fh, ">", \my $buf
446 or die "fork_call: cannot open fh-to-buf in child : $!";
447 Storable::store_fd +($@ ? \"$@" : \@res), $fh;
448 close $fh;
449
450 warn "writing ", length $buf;
451 my $x;
452 (length $buf) == ($x = syswrite $fh2, $buf)
453 or warn "error writing ".(length $buf)." != $x\n";
454 close $fh2;
455 };
456
457 warn $@ if $@;
458 _exit 0;
459 }
460} 501}
461 502
462=item $value = cf::db_get $family => $key 503=item $value = cf::db_get $family => $key
463 504
464Returns a single value from the environment database. 505Returns a single value from the environment database.
… …
544 if (1) { 585 if (1) {
545 $md5 = 586 $md5 =
546 join "\x00", 587 join "\x00",
547 $processversion, 588 $processversion,
548 map { 589 map {
549 Coro::cede; 590 cf::cede_to_tick;
550 ($src->[$_], Digest::MD5::md5_hex $data[$_]) 591 ($src->[$_], Digest::MD5::md5_hex $data[$_])
551 } 0.. $#$src; 592 } 0.. $#$src;
552 593
553 594
554 my $dbmd5 = db_get cache => "$id/md5"; 595 my $dbmd5 = db_get cache => "$id/md5";
… …
860 "; 901 ";
861 die if $@; 902 die if $@;
862} 903}
863 904
864our $override; 905our $override;
865our @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?
866 907
867sub override { 908sub override {
868 $override = 1; 909 $override = 1;
869 @invoke_results = (); 910 @INVOKE_RESULTS = (@_);
870} 911}
871 912
872sub do_invoke { 913sub do_invoke {
873 my $event = shift; 914 my $event = shift;
874 my $callbacks = shift; 915 my $callbacks = shift;
875 916
876 @invoke_results = (); 917 @INVOKE_RESULTS = ();
877 918
878 local $override; 919 local $override;
879 920
880 for (@$callbacks) { 921 for (@$callbacks) {
881 eval { &{$_->[1]} }; 922 eval { &{$_->[1]} };
… …
898 939
899Generate an object-specific event with the given arguments. 940Generate an object-specific event with the given arguments.
900 941
901This 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
902removed 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
903results (if you must, access C<@cf::invoke_results> directly). 944results (if you must, access C<@cf::INVOKE_RESULTS> directly).
904 945
905=back 946=back
906 947
907=cut 948=cut
908 949
909############################################################################# 950#############################################################################
910# 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}
911 963
912sub reattach { 964sub reattach {
913 # basically do the same as instantiate, without calling instantiate 965 # basically do the same as instantiate, without calling instantiate
914 my ($obj) = @_; 966 my ($obj) = @_;
915 967
… …
960); 1012);
961 1013
962sub object_freezer_save { 1014sub object_freezer_save {
963 my ($filename, $rdata, $objs) = @_; 1015 my ($filename, $rdata, $objs) = @_;
964 1016
1017 my $guard = cf::lock_acquire "io";
1018
965 sync_job { 1019 sync_job {
966 if (length $$rdata) { 1020 if (length $$rdata) {
1021 utf8::decode (my $decname = $filename);
967 warn sprintf "saving %s (%d,%d)\n", 1022 warn sprintf "saving %s (%d,%d)\n",
968 $filename, length $$rdata, scalar @$objs; 1023 $decname, length $$rdata, scalar @$objs;
969 1024
970 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1025 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
971 chmod SAVE_MODE, $fh; 1026 chmod SAVE_MODE, $fh;
972 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1027 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
973 aio_fsync $fh if $cf::USE_FSYNC; 1028 aio_fsync $fh if $cf::USE_FSYNC;
… …
992 } 1047 }
993 } else { 1048 } else {
994 aio_unlink $filename; 1049 aio_unlink $filename;
995 aio_unlink "$filename.pst"; 1050 aio_unlink "$filename.pst";
996 } 1051 }
997 } 1052 };
1053
1054 undef $guard;
998} 1055}
999 1056
1000sub object_freezer_as_string { 1057sub object_freezer_as_string {
1001 my ($rdata, $objs) = @_; 1058 my ($rdata, $objs) = @_;
1002 1059
… …
1007 1064
1008sub object_thawer_load { 1065sub object_thawer_load {
1009 my ($filename) = @_; 1066 my ($filename) = @_;
1010 1067
1011 my ($data, $av); 1068 my ($data, $av);
1069
1070 my $guard = cf::lock_acquire "io";
1012 1071
1013 (aio_load $filename, $data) >= 0 1072 (aio_load $filename, $data) >= 0
1014 or return; 1073 or return;
1015 1074
1016 unless (aio_stat "$filename.pst") { 1075 unless (aio_stat "$filename.pst") {
1017 (aio_load "$filename.pst", $av) >= 0 1076 (aio_load "$filename.pst", $av) >= 0
1018 or return; 1077 or return;
1078
1079 undef $guard;
1019 $av = eval { (Storable::thaw $av)->{objs} }; 1080 $av = eval { (Storable::thaw $av)->{objs} };
1020 } 1081 }
1021 1082
1083 utf8::decode (my $decname = $filename);
1022 warn sprintf "loading %s (%d)\n", 1084 warn sprintf "loading %s (%d,%d)\n",
1023 $filename, length $data, scalar @{$av || []}; 1085 $decname, length $data, scalar @{$av || []};
1086
1024 return ($data, $av); 1087 ($data, $av)
1025} 1088}
1026 1089
1027=head2 COMMAND CALLBACKS 1090=head2 COMMAND CALLBACKS
1028 1091
1029=over 4 1092=over 4
… …
1102 my ($pl, $buf) = @_; 1165 my ($pl, $buf) = @_;
1103 1166
1104 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) }; 1167 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1105 1168
1106 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
1107 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1177 if (my $cb = $EXTCMD{$type}) {
1108 if (my %reply = $cb->($pl, $msg)) { 1178 @reply = $cb->($pl, @payload);
1109 $pl->ext_reply ($msg->{msgid}, %reply);
1110 }
1111 } 1179 }
1180
1181 $pl->ext_reply ($reply, @reply)
1182 if $reply;
1183
1112 } else { 1184 } else {
1113 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1185 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1114 } 1186 }
1115 1187
1116 cf::override; 1188 cf::override;
… …
1206 1278
1207=head3 cf::player 1279=head3 cf::player
1208 1280
1209=over 4 1281=over 4
1210 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
1211=item cf::player::find $login 1297=item cf::player::find $login
1212 1298
1213Returns the given player object, loading it if necessary (might block). 1299Returns the given player object, loading it if necessary (might block).
1214 1300
1215=cut 1301=cut
… …
1250 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst"; 1336 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1251 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata"; 1337 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1252 aio_unlink +(playerdir $login) . "/$login.pl.pst"; 1338 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1253 aio_unlink +(playerdir $login) . "/$login.pl"; 1339 aio_unlink +(playerdir $login) . "/$login.pl";
1254 1340
1255 my $pl = load_pl path $login 1341 my $f = new_from_file cf::object::thawer path $login
1256 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;
1257 $cf::PLAYER{$login} = $pl 1349 $cf::PLAYER{$login} = $pl
1258 } 1350 }
1259 } 1351 }
1260} 1352}
1261 1353
… …
1271 1363
1272 aio_mkdir playerdir $pl, 0770; 1364 aio_mkdir playerdir $pl, 0770;
1273 $pl->{last_save} = $cf::RUNTIME; 1365 $pl->{last_save} = $cf::RUNTIME;
1274 1366
1275 $pl->save_pl ($path); 1367 $pl->save_pl ($path);
1276 Coro::cede; 1368 cf::cede_to_tick;
1277} 1369}
1278 1370
1279sub new($) { 1371sub new($) {
1280 my ($login) = @_; 1372 my ($login) = @_;
1281 1373
… …
1285 $self->{deny_save} = 1; 1377 $self->{deny_save} = 1;
1286 1378
1287 $cf::PLAYER{$login} = $self; 1379 $cf::PLAYER{$login} = $self;
1288 1380
1289 $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 (@_);
1290} 1392}
1291 1393
1292=item $pl->quit_character 1394=item $pl->quit_character
1293 1395
1294Nukes the player without looking back. If logged in, the connection will 1396Nukes the player without looking back. If logged in, the connection will
… …
1349 or return []; 1451 or return [];
1350 1452
1351 my @logins; 1453 my @logins;
1352 1454
1353 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") {
1354 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1460 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1355 aio_read $fh, 0, 512, my $buf, 0 or next; 1461 aio_read $fh, 0, 512, my $buf, 0 or next;
1356 $buf !~ /^password -------------$/m or next; # official not-valid tag 1462 $buf !~ /^password -------------$/m or next; # official not-valid tag
1463 }
1357 1464
1358 utf8::decode $login; 1465 utf8::decode $login;
1359 push @logins, $login; 1466 push @logins, $login;
1360 } 1467 }
1361 1468
… …
1399sub expand_cfpod { 1506sub expand_cfpod {
1400 ((my $self), (local $_)) = @_; 1507 ((my $self), (local $_)) = @_;
1401 1508
1402 # escape & and < 1509 # escape & and <
1403 s/&/&amp;/g; 1510 s/&/&amp;/g;
1404 s/(?<![BIUGH])</&lt;/g; 1511 s/(?<![BIUGHT])</&lt;/g;
1405 1512
1406 # 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
1407 1514
1408 1 while 1515 1 while
1409 # replace B<>, I<>, U<> etc. 1516 # replace B<>, I<>, U<> etc.
1410 s/B<([^\>]*)>/<b>$1<\/b>/ 1517 s/B<([^\>]*)>/<b>$1<\/b>/
1411 || s/I<([^\>]*)>/<i>$1<\/i>/ 1518 || s/I<([^\>]*)>/<i>$1<\/i>/
1412 || s/U<([^\>]*)>/<u>$1<\/u>/ 1519 || s/U<([^\>]*)>/<u>$1<\/u>/
1520 || s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/
1413 # replace G<male|female> tags 1521 # replace G<male|female> tags
1414 || s{G<([^>|]*)\|([^>]*)>}{ 1522 || s{G<([^>|]*)\|([^>]*)>}{
1415 $self->gender ? $2 : $1 1523 $self->gender ? $2 : $1
1416 }ge 1524 }ge
1417 # replace H<hint text> 1525 # replace H<hint text>
… …
1438sub hintmode { 1546sub hintmode {
1439 $_[0]{hintmode} = $_[1] if @_ > 1; 1547 $_[0]{hintmode} = $_[1] if @_ > 1;
1440 $_[0]{hintmode} 1548 $_[0]{hintmode}
1441} 1549}
1442 1550
1443=item $player->ext_reply ($msgid, %msg) 1551=item $player->ext_reply ($msgid, @msg)
1444 1552
1445Sends an ext reply to the player. 1553Sends an ext reply to the player.
1446 1554
1447=cut 1555=cut
1448 1556
1449sub ext_reply($$%) { 1557sub ext_reply($$@) {
1450 my ($self, $id, %msg) = @_; 1558 my ($self, $id, @msg) = @_;
1451 1559
1452 $msg{msgid} = $id; 1560 $self->ns->ext_reply ($id, @msg)
1453 $self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));
1454} 1561}
1455 1562
1456=item $player->ext_event ($type, %msg) 1563=item $player->ext_msg ($type, @msg)
1457 1564
1458Sends an ext event to the client. 1565Sends an ext event to the client.
1459 1566
1460=cut 1567=cut
1461 1568
1462sub ext_event($$%) { 1569sub ext_msg($$@) {
1463 my ($self, $type, %msg) = @_; 1570 my ($self, $type, @msg) = @_;
1464 1571
1465 $self->ns->ext_event ($type, %msg); 1572 $self->ns->ext_msg ($type, @msg);
1466} 1573}
1467 1574
1468=head3 cf::region 1575=head3 cf::region
1469 1576
1470=over 4 1577=over 4
… …
1483 my ($path) = @_; 1590 my ($path) = @_;
1484 1591
1485 my ($match, $specificity); 1592 my ($match, $specificity);
1486 1593
1487 for my $region (list) { 1594 for my $region (list) {
1488 if ($region->match && $path =~ $region->match) { 1595 if ($region->{match} && $path =~ $region->{match}) {
1489 ($match, $specificity) = ($region, $region->specificity) 1596 ($match, $specificity) = ($region, $region->specificity)
1490 if $region->specificity > $specificity; 1597 if $region->specificity > $specificity;
1491 } 1598 }
1492 } 1599 }
1493 1600
… …
1613 $self->init; # pass $1 etc. 1720 $self->init; # pass $1 etc.
1614 return $self; 1721 return $self;
1615 } 1722 }
1616 } 1723 }
1617 1724
1618 Carp::carp "unable to resolve path '$path' (base '$base')."; 1725 Carp::cluck "unable to resolve path '$path' (base '$base').";
1619 () 1726 ()
1620} 1727}
1621 1728
1622sub init { 1729sub init {
1623 my ($self) = @_; 1730 my ($self) = @_;
… …
1686 1793
1687sub load_header_from($) { 1794sub load_header_from($) {
1688 my ($self, $path) = @_; 1795 my ($self, $path) = @_;
1689 1796
1690 utf8::encode $path; 1797 utf8::encode $path;
1691 #aio_open $path, O_RDONLY, 0 1798 my $f = new_from_file cf::object::thawer $path
1692 # or return;
1693
1694 $self->_load_header ($path)
1695 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;
1696 1806
1697 $self->{load_path} = $path; 1807 $self->{load_path} = $path;
1698 1808
1699 1 1809 1
1700} 1810}
… …
1754sub find { 1864sub find {
1755 my ($path, $origin) = @_; 1865 my ($path, $origin) = @_;
1756 1866
1757 $path = normalise $path, $origin && $origin->path; 1867 $path = normalise $path, $origin && $origin->path;
1758 1868
1869 cf::lock_wait "map_data:$path";#d#remove
1759 cf::lock_wait "map_find:$path"; 1870 cf::lock_wait "map_find:$path";
1760 1871
1761 $cf::MAP{$path} || do { 1872 $cf::MAP{$path} || do {
1762 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
1763 my $map = new_from_path cf::map $path 1876 my $map = new_from_path cf::map $path
1764 or return; 1877 or return;
1765 1878
1766 $map->{last_save} = $cf::RUNTIME; 1879 $map->{last_save} = $cf::RUNTIME;
1767 1880
… …
1769 or return; 1882 or return;
1770 1883
1771 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 1884 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1772 # doing this can freeze the server in a sync job, obviously 1885 # doing this can freeze the server in a sync job, obviously
1773 #$cf::WAIT_FOR_TICK->wait; 1886 #$cf::WAIT_FOR_TICK->wait;
1887 undef $guard1;
1888 undef $guard2;
1774 $map->reset; 1889 $map->reset;
1775 undef $guard;
1776 return find $path; 1890 return find $path;
1777 } 1891 }
1778 1892
1779 $cf::MAP{$path} = $map 1893 $cf::MAP{$path} = $map
1780 } 1894 }
… …
1789 local $self->{deny_reset} = 1; # loading can take a long time 1903 local $self->{deny_reset} = 1; # loading can take a long time
1790 1904
1791 my $path = $self->{path}; 1905 my $path = $self->{path};
1792 1906
1793 { 1907 {
1794 my $guard = cf::lock_acquire "map_load:$path"; 1908 my $guard = cf::lock_acquire "map_data:$path";
1795 1909
1910 return unless $self->valid;
1796 return if $self->in_memory != cf::MAP_SWAPPED; 1911 return unless $self->in_memory == cf::MAP_SWAPPED;
1797 1912
1798 $self->in_memory (cf::MAP_LOADING); 1913 $self->in_memory (cf::MAP_LOADING);
1799 1914
1800 $self->alloc; 1915 $self->alloc;
1801 1916
1802 $self->pre_load; 1917 $self->pre_load;
1803 Coro::cede; 1918 cf::cede_to_tick;
1804 1919
1920 my $f = new_from_file cf::object::thawer $self->{load_path};
1921 $f->skip_block;
1805 $self->_load_objects ($self->{load_path}, 1) 1922 $self->_load_objects ($f)
1806 or return; 1923 or return;
1807 1924
1808 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 1925 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1809 if delete $self->{load_original}; 1926 if delete $self->{load_original};
1810 1927
1811 if (my $uniq = $self->uniq_path) { 1928 if (my $uniq = $self->uniq_path) {
1812 utf8::encode $uniq; 1929 utf8::encode $uniq;
1813 if (aio_open $uniq, O_RDONLY, 0) { 1930 unless (aio_stat $uniq) {
1931 if (my $f = new_from_file cf::object::thawer $uniq) {
1814 $self->clear_unique_items; 1932 $self->clear_unique_items;
1815 $self->_load_objects ($uniq, 0); 1933 $self->_load_objects ($f);
1934 $f->resolve_delayed_derefs;
1935 }
1816 } 1936 }
1817 } 1937 }
1818 1938
1819 Coro::cede; 1939 $f->resolve_delayed_derefs;
1940
1941 cf::cede_to_tick;
1820 # now do the right thing for maps 1942 # now do the right thing for maps
1821 $self->link_multipart_objects; 1943 $self->link_multipart_objects;
1822 $self->difficulty ($self->estimate_difficulty) 1944 $self->difficulty ($self->estimate_difficulty)
1823 unless $self->difficulty; 1945 unless $self->difficulty;
1824 Coro::cede; 1946 cf::cede_to_tick;
1825 1947
1826 unless ($self->{deny_activate}) { 1948 unless ($self->{deny_activate}) {
1827 $self->decay_objects; 1949 $self->decay_objects;
1828 $self->fix_auto_apply; 1950 $self->fix_auto_apply;
1829 $self->update_buttons; 1951 $self->update_buttons;
1830 Coro::cede; 1952 cf::cede_to_tick;
1831 $self->set_darkness_map; 1953 $self->set_darkness_map;
1832 Coro::cede; 1954 cf::cede_to_tick;
1833 $self->activate; 1955 $self->activate;
1834 } 1956 }
1957
1958 $self->{last_save} = $cf::RUNTIME;
1959 $self->last_access ($cf::RUNTIME);
1835 1960
1836 $self->in_memory (cf::MAP_IN_MEMORY); 1961 $self->in_memory (cf::MAP_IN_MEMORY);
1837 } 1962 }
1838 1963
1839 $self->post_load; 1964 $self->post_load;
… …
1850 1975
1851 $self 1976 $self
1852} 1977}
1853 1978
1854# 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
1855sub load_diag { 1980sub load_neighbours {
1856 my ($map) = @_; 1981 my ($map) = @_;
1857 1982
1858 my @diag; # diagonal neighbours 1983 my @neigh; # diagonal neighbours
1859 1984
1860 for (0 .. 3) { 1985 for (0 .. 3) {
1861 my $neigh = $map->tile_path ($_) 1986 my $neigh = $map->tile_path ($_)
1862 or next; 1987 or next;
1863 $neigh = find $neigh, $map 1988 $neigh = find $neigh, $map
1864 or next; 1989 or next;
1865 $neigh->load; 1990 $neigh->load;
1866 1991
1992 push @neigh,
1867 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 1993 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1868 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 1994 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1869 } 1995 }
1870 1996
1871 for (@diag) { 1997 for (grep defined $_->[0], @neigh) {
1998 my ($path, $origin) = @$_;
1872 my $neigh = find @$_ 1999 my $neigh = find $path, $origin
1873 or next; 2000 or next;
1874 $neigh->load; 2001 $neigh->load;
1875 } 2002 }
1876} 2003}
1877 2004
… …
1882} 2009}
1883 2010
1884sub do_load_sync { 2011sub do_load_sync {
1885 my ($map) = @_; 2012 my ($map) = @_;
1886 2013
2014 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
2015 if $Coro::current == $Coro::main;
2016
1887 cf::sync_job { $map->load }; 2017 cf::sync_job { $map->load };
1888} 2018}
1889 2019
1890our %MAP_PREFETCH; 2020our %MAP_PREFETCH;
1891our $MAP_PREFETCHER = undef; 2021our $MAP_PREFETCHER = undef;
1892 2022
1893sub find_async { 2023sub find_async {
1894 my ($path, $origin) = @_; 2024 my ($path, $origin, $load) = @_;
1895 2025
1896 $path = normalise $path, $origin && $origin->{path}; 2026 $path = normalise $path, $origin && $origin->{path};
1897 2027
1898 if (my $map = $cf::MAP{$path}) { 2028 if (my $map = $cf::MAP{$path}) {
1899 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 2029 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY;
1900 } 2030 }
1901 2031
1902 undef $MAP_PREFETCH{$path}; 2032 $MAP_PREFETCH{$path} |= $load;
2033
1903 $MAP_PREFETCHER ||= cf::async { 2034 $MAP_PREFETCHER ||= cf::async {
1904 while (%MAP_PREFETCH) { 2035 while (%MAP_PREFETCH) {
1905 for my $path (keys %MAP_PREFETCH) { 2036 while (my ($k, $v) = each %MAP_PREFETCH) {
1906 my $map = find $path 2037 if (my $map = find $k) {
1907 or next;
1908 $map->load; 2038 $map->load if $v;
2039 }
1909 2040
1910 delete $MAP_PREFETCH{$path}; 2041 delete $MAP_PREFETCH{$k};
1911 } 2042 }
1912 } 2043 }
1913 undef $MAP_PREFETCHER; 2044 undef $MAP_PREFETCHER;
1914 }; 2045 };
1915 $MAP_PREFETCHER->prio (6); 2046 $MAP_PREFETCHER->prio (6);
… …
1918} 2049}
1919 2050
1920sub save { 2051sub save {
1921 my ($self) = @_; 2052 my ($self) = @_;
1922 2053
1923 my $lock = cf::lock_acquire "map_data:" . $self->path; 2054 my $lock = cf::lock_acquire "map_data:$self->{path}";
1924 2055
1925 $self->{last_save} = $cf::RUNTIME; 2056 $self->{last_save} = $cf::RUNTIME;
1926 2057
1927 return unless $self->dirty; 2058 return unless $self->dirty;
1928 2059
… …
1951 my ($self) = @_; 2082 my ($self) = @_;
1952 2083
1953 # save first because save cedes 2084 # save first because save cedes
1954 $self->save; 2085 $self->save;
1955 2086
1956 my $lock = cf::lock_acquire "map_data:" . $self->path; 2087 my $lock = cf::lock_acquire "map_data:$self->{path}";
1957 2088
1958 return if $self->players; 2089 return if $self->players;
1959 return if $self->in_memory != cf::MAP_IN_MEMORY; 2090 return if $self->in_memory != cf::MAP_IN_MEMORY;
1960 return if $self->{deny_save}; 2091 return if $self->{deny_save};
1961 2092
2093 $self->in_memory (cf::MAP_SWAPPED);
2094
2095 $self->deactivate;
2096 $_->clear_links_to ($self) for values %cf::MAP;
1962 $self->clear; 2097 $self->clear;
1963 $self->in_memory (cf::MAP_SWAPPED);
1964} 2098}
1965 2099
1966sub reset_at { 2100sub reset_at {
1967 my ($self) = @_; 2101 my ($self) = @_;
1968 2102
… …
2000 if $uniq; 2134 if $uniq;
2001 } 2135 }
2002 2136
2003 delete $cf::MAP{$self->path}; 2137 delete $cf::MAP{$self->path};
2004 2138
2139 $self->deactivate;
2140 $_->clear_links_to ($self) for values %cf::MAP;
2005 $self->clear; 2141 $self->clear;
2006
2007 $_->clear_links_to ($self) for values %cf::MAP;
2008 2142
2009 $self->unlink_save; 2143 $self->unlink_save;
2010 $self->destroy; 2144 $self->destroy;
2011} 2145}
2012 2146
2013my $nuke_counter = "aaaa"; 2147my $nuke_counter = "aaaa";
2014 2148
2015sub nuke { 2149sub nuke {
2016 my ($self) = @_; 2150 my ($self) = @_;
2017 2151
2152 {
2153 my $lock = cf::lock_acquire "map_data:$self->{path}";
2154
2018 delete $cf::MAP{$self->path}; 2155 delete $cf::MAP{$self->path};
2019 2156
2020 $self->unlink_save; 2157 $self->unlink_save;
2021 2158
2022 bless $self, "cf::map"; 2159 bless $self, "cf::map";
2023 delete $self->{deny_reset}; 2160 delete $self->{deny_reset};
2024 $self->{deny_save} = 1; 2161 $self->{deny_save} = 1;
2025 $self->reset_timeout (1); 2162 $self->reset_timeout (1);
2026 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2163 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2027 2164
2028 $cf::MAP{$self->path} = $self; 2165 $cf::MAP{$self->path} = $self;
2166 }
2029 2167
2030 $self->reset; # polite request, might not happen 2168 $self->reset; # polite request, might not happen
2031} 2169}
2032 2170
2033=item $maps = cf::map::tmp_maps 2171=item $maps = cf::map::tmp_maps
… …
2109 2247
2110sub inv_recursive { 2248sub inv_recursive {
2111 inv_recursive_ inv $_[0] 2249 inv_recursive_ inv $_[0]
2112} 2250}
2113 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
2114package cf; 2283package cf;
2115 2284
2116=back 2285=back
2117 2286
2118=head3 cf::object::player 2287=head3 cf::object::player
… …
2140 2309
2141 } else { 2310 } else {
2142 my $pl = $self->contr; 2311 my $pl = $self->contr;
2143 2312
2144 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) { 2313 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2145 my $diag = $pl->{npc_dialog}; 2314 my $dialog = $pl->{npc_dialog};
2146 $diag->{pl}->ext_reply ( 2315 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2147 $diag->{id},
2148 msgtype => "reply",
2149 msg => $diag->{pl}->expand_cfpod ($msg),
2150 add_topics => []
2151 );
2152 2316
2153 } else { 2317 } else {
2154 $msg = $npc->name . " says: $msg" if $npc; 2318 $msg = $npc->name . " says: $msg" if $npc;
2155 $self->message ($msg, $flags); 2319 $self->message ($msg, $flags);
2156 } 2320 }
2157 } 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 (@_);
2158} 2332}
2159 2333
2160=item $player_object->may ("access") 2334=item $player_object->may ("access")
2161 2335
2162Returns wether the given player is authorized to access resource "access" 2336Returns wether the given player is authorized to access resource "access"
… …
2241 # use -1 or undef as default coordinates, not 0, 0 2415 # use -1 or undef as default coordinates, not 0, 0
2242 ($x, $y) = ($map->enter_x, $map->enter_y) 2416 ($x, $y) = ($map->enter_x, $map->enter_y)
2243 if $x <=0 && $y <= 0; 2417 if $x <=0 && $y <= 0;
2244 2418
2245 $map->load; 2419 $map->load;
2246 $map->load_diag; 2420 $map->load_neighbours;
2247 2421
2248 return unless $self->contr->active; 2422 return unless $self->contr->active;
2249 $self->activate_recursive; 2423 $self->activate_recursive;
2250 2424
2251 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2425 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2252 $self->enter_map ($map, $x, $y); 2426 $self->enter_map ($map, $x, $y);
2253} 2427}
2254 2428
2255=item $player_object->goto ($path, $x, $y[, $check->($map)]) 2429=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2256 2430
2257Moves 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
2258her, loading and preparing them map, calling the provided $check callback 2432her, loading and preparing them map, calling the provided $check callback
2259that 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
2260the 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.
2261 2436
2262=cut 2437=cut
2263 2438
2264our $GOTOGEN; 2439our $GOTOGEN;
2265 2440
2266sub cf::object::player::goto { 2441sub cf::object::player::goto {
2267 my ($self, $path, $x, $y, $check) = @_; 2442 my ($self, $path, $x, $y, $check, $done) = @_;
2268 2443
2269 # 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
2270 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2445 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2271 2446
2272 $self->enter_link; 2447 $self->enter_link;
… …
2292 2467
2293 if ($gen == $self->{_goto_generation}) { 2468 if ($gen == $self->{_goto_generation}) {
2294 delete $self->{_goto_generation}; 2469 delete $self->{_goto_generation};
2295 $self->leave_link ($map, $x, $y); 2470 $self->leave_link ($map, $x, $y);
2296 } 2471 }
2472
2473 $done->() if $done;
2297 })->prio (1); 2474 })->prio (1);
2298} 2475}
2299 2476
2300=item $player_object->enter_exit ($exit_object) 2477=item $player_object->enter_exit ($exit_object)
2301 2478
… …
2410 2587
2411 utf8::encode $text; 2588 utf8::encode $text;
2412 $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);
2413} 2590}
2414 2591
2415=item $client->send_msg ($color, $type, $msg, [extra...]) 2592=item $client->send_msg ($channel, $msg, $color, [extra...])
2416 2593
2417Send 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
2418client 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
2419the 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
2420the message unless the client supports the msg packet. 2597the message unless the client supports the msg packet.
2421 2598
2422=cut 2599=cut
2423 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
2424sub cf::client::send_msg { 2616sub cf::client::send_msg {
2425 my ($self, $color, $type, $msg, @extra) = @_; 2617 my ($self, $channel, $msg, $color, @extra) = @_;
2426 2618
2427 $msg = $self->pl->expand_cfpod ($msg); 2619 $msg = $self->pl->expand_cfpod ($msg);
2428 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
2429 return unless @extra || length $msg; 2637 return unless @extra || length $msg;
2430 2638
2431 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
2432 $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]));
2433 } else { 2646 } else {
2434 # replace some tags by gcfclient-compatible ones
2435 for ($msg) {
2436 1 while
2437 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2438 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2439 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2440 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2441 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2442 }
2443
2444 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
2445 if (0 && $msg =~ /\[/) { 2662 if (0 && $msg =~ /\[/) {
2663 # COMMAND/INFO
2446 $self->send_packet ("drawextinfo $color 4 0 $msg") 2664 $self->send_packet ("drawextinfo $color 10 8 $msg")
2447 } else { 2665 } else {
2448 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g; 2666 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2449 $self->send_packet ("drawinfo $color $msg") 2667 $self->send_packet ("drawinfo $color $msg")
2450 } 2668 }
2451 } 2669 }
2452 } 2670 }
2453} 2671}
2454 2672
2455=item $client->ext_event ($type, %msg) 2673=item $client->ext_msg ($type, @msg)
2456 2674
2457Sends an ext event to the client. 2675Sends an ext event to the client.
2458 2676
2459=cut 2677=cut
2460 2678
2461sub cf::client::ext_event($$%) { 2679sub cf::client::ext_msg($$@) {
2462 my ($self, $type, %msg) = @_; 2680 my ($self, $type, @msg) = @_;
2463 2681
2682 if ($self->extcmd == 2) {
2683 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2684 } elsif ($self->extcmd == 1) { # TODO: remove
2464 $msg{msgtype} = "event_$type"; 2685 push @msg, msgtype => "event_$type";
2465 $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 }
2466} 2706}
2467 2707
2468=item $success = $client->query ($flags, "text", \&cb) 2708=item $success = $client->query ($flags, "text", \&cb)
2469 2709
2470Queues a query to the client, calling the given callback with 2710Queues a query to the client, calling the given callback with
… …
2525 my ($ns, $buf) = @_; 2765 my ($ns, $buf) = @_;
2526 2766
2527 my $msg = eval { $ns->{json_coder}->decode ($buf) }; 2767 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2528 2768
2529 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
2530 if (my $cb = $EXTICMD{$msg->{msgtype}}) { 2777 if (my $cb = $EXTICMD{$type}) {
2531 if (my %reply = $cb->($ns, $msg)) { 2778 @reply = $cb->($ns, @payload);
2532 $reply{msgid} = $msg->{msgid};
2533 $ns->send ("ext " . $ns->{json_coder}->encode (\%reply));
2534 }
2535 } 2779 }
2780
2781 $ns->ext_reply ($reply, @reply)
2782 if $reply;
2783
2536 } else { 2784 } else {
2537 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";
2538 } 2786 }
2539 2787
2540 cf::override; 2788 cf::override;
… …
2587our $safe = new Safe "safe"; 2835our $safe = new Safe "safe";
2588our $safe_hole = new Safe::Hole; 2836our $safe_hole = new Safe::Hole;
2589 2837
2590$SIG{FPE} = 'IGNORE'; 2838$SIG{FPE} = 'IGNORE';
2591 2839
2592$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));
2593 2845
2594# here we export the classes and methods available to script code 2846# here we export the classes and methods available to script code
2595 2847
2596=pod 2848=pod
2597 2849
2598The following functions and methods are available within a safe environment: 2850The following functions and methods are available within a safe environment:
2599 2851
2600 cf::object 2852 cf::object
2601 contr pay_amount pay_player map x y force_find force_add 2853 contr pay_amount pay_player map x y force_find force_add
2602 insert remove 2854 insert remove name archname title slaying race decrease_ob_nr
2603 2855
2604 cf::object::player 2856 cf::object::player
2605 player 2857 player
2606 2858
2607 cf::player 2859 cf::player
… …
2612 2864
2613=cut 2865=cut
2614 2866
2615for ( 2867for (
2616 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 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
2617 insert remove)], 2870 decrease_ob_nr)],
2618 ["cf::object::player" => qw(player)], 2871 ["cf::object::player" => qw(player)],
2619 ["cf::player" => qw(peaceful)], 2872 ["cf::player" => qw(peaceful)],
2620 ["cf::map" => qw(trigger)], 2873 ["cf::map" => qw(trigger)],
2621) { 2874) {
2622 no strict 'refs'; 2875 no strict 'refs';
… …
2698# the server's init and main functions 2951# the server's init and main functions
2699 2952
2700sub load_facedata($) { 2953sub load_facedata($) {
2701 my ($path) = @_; 2954 my ($path) = @_;
2702 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
2703 warn "loading facedata from $path\n"; 2962 warn "loading facedata from $path\n";
2704 2963
2705 my $facedata; 2964 my $facedata;
2706 0 < aio_load $path, $facedata 2965 0 < aio_load $path, $facedata
2707 or die "$path: $!"; 2966 or die "$path: $!";
… …
2709 $facedata = Coro::Storable::thaw $facedata; 2968 $facedata = Coro::Storable::thaw $facedata;
2710 2969
2711 $facedata->{version} == 2 2970 $facedata->{version} == 2
2712 or cf::cleanup "$path: version mismatch, cannot proceed."; 2971 or cf::cleanup "$path: version mismatch, cannot proceed.";
2713 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
2714 { 2980 {
2715 my $faces = $facedata->{faceinfo}; 2981 my $faces = $facedata->{faceinfo};
2716 2982
2717 while (my ($face, $info) = each %$faces) { 2983 while (my ($face, $info) = each %$faces) {
2718 my $idx = (cf::face::find $face) || cf::face::alloc $face; 2984 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2719 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 2985 cf::face::set_visibility $idx, $info->{visibility};
2986 cf::face::set_magicmap $idx, $info->{magicmap};
2720 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 2987 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2721 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 2988 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2722 Coro::cede; 2989
2990 cf::cede_to_tick;
2723 } 2991 }
2724 2992
2725 while (my ($face, $info) = each %$faces) { 2993 while (my ($face, $info) = each %$faces) {
2726 next unless $info->{smooth}; 2994 next unless $info->{smooth};
2727 my $idx = cf::face::find $face 2995 my $idx = cf::face::find $face
2728 or next; 2996 or next;
2729 if (my $smooth = cf::face::find $info->{smooth}) { 2997 if (my $smooth = cf::face::find $info->{smooth}) {
2998 cf::face::set_smooth $idx, $smooth;
2730 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel}; 2999 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2731 } else { 3000 } else {
2732 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3001 warn "smooth face '$info->{smooth}' not found for face '$face'";
2733 } 3002 }
2734 Coro::cede; 3003
3004 cf::cede_to_tick;
2735 } 3005 }
2736 } 3006 }
2737 3007
2738 { 3008 {
2739 my $anims = $facedata->{animinfo}; 3009 my $anims = $facedata->{animinfo};
2740 3010
2741 while (my ($anim, $info) = each %$anims) { 3011 while (my ($anim, $info) = each %$anims) {
2742 cf::anim::set $anim, $info->{frames}, $info->{facings}; 3012 cf::anim::set $anim, $info->{frames}, $info->{facings};
2743 Coro::cede; 3013 cf::cede_to_tick;
2744 } 3014 }
2745 3015
2746 cf::anim::invalidate_all; # d'oh 3016 cf::anim::invalidate_all; # d'oh
2747 } 3017 }
2748 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
2749 1 3068 1
2750} 3069}
2751 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
2752sub 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
2753 load_resource_file "$MAPDIR/regions" 3084 load_resource_file "$MAPDIR/regions"
2754 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 }
2755} 3091}
2756 3092
2757sub reload_facedata { 3093sub reload_facedata {
2758 load_facedata "$DATADIR/facedata" 3094 load_facedata "$DATADIR/facedata"
2759 or die "unable to load facedata\n"; 3095 or die "unable to load facedata\n";
… …
2788 3124
2789sub init { 3125sub init {
2790 reload_resources; 3126 reload_resources;
2791} 3127}
2792 3128
2793sub cfg_load { 3129sub reload_config {
2794 open my $fh, "<:utf8", "$CONFDIR/config" 3130 open my $fh, "<:utf8", "$CONFDIR/config"
2795 or return; 3131 or return;
2796 3132
2797 local $/; 3133 local $/;
2798 *CFG = YAML::Syck::Load <$fh>; 3134 *CFG = YAML::Syck::Load <$fh>;
… …
2818 (async { 3154 (async {
2819 Event::one_event; 3155 Event::one_event;
2820 })->prio (Coro::PRIO_MAX); 3156 })->prio (Coro::PRIO_MAX);
2821 }; 3157 };
2822 3158
2823 cfg_load; 3159 reload_config;
2824 db_init; 3160 db_init;
2825 load_extensions; 3161 load_extensions;
2826 3162
2827 $TICK_WATCHER->start; 3163 $TICK_WATCHER->start;
2828 Event::loop; 3164 Event::loop;
… …
3021 warn "reloading cf.pm"; 3357 warn "reloading cf.pm";
3022 require cf; 3358 require cf;
3023 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3359 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3024 3360
3025 warn "loading config and database again"; 3361 warn "loading config and database again";
3026 cf::cfg_load; 3362 cf::reload_config;
3027 3363
3028 warn "loading extensions"; 3364 warn "loading extensions";
3029 cf::load_extensions; 3365 cf::load_extensions;
3030 3366
3031 warn "reattaching attachments to objects/players"; 3367 warn "reattaching attachments to objects/players";
… …
3124 or die; 3460 or die;
3125 3461
3126 $map->width (50); 3462 $map->width (50);
3127 $map->height (50); 3463 $map->height (50);
3128 $map->alloc; 3464 $map->alloc;
3129 $map->_load_objects ("/tmp/x.map", 1); 3465 $map->_load_objects ("/tmp/x.map", 1); #TODO: does not work
3130 my $t = Event::time - $t; 3466 my $t = Event::time - $t;
3131 3467
3132 #next unless $t < 0.0013;#d# 3468 #next unless $t < 0.0013;#d#
3133 if ($t < $min) { 3469 if ($t < $min) {
3134 $min = $t; 3470 $min = $t;

Diff Legend

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