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.296 by root, Wed Jul 4 07:09:06 2007 UTC vs.
Revision 1.362 by root, Mon Sep 10 12:44:06 2007 UTC

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

Diff Legend

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