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.287 by root, Mon Jun 25 05:43:45 2007 UTC vs.
Revision 1.314 by root, Mon Jul 23 16:53:15 2007 UTC

… …
20use Coro::Signal; 20use Coro::Signal;
21use Coro::Semaphore; 21use Coro::Semaphore;
22use Coro::AIO; 22use Coro::AIO;
23use Coro::Storable; 23use Coro::Storable;
24 24
25use JSON::XS 1.4 ();
25use BDB (); 26use BDB ();
26use Data::Dumper; 27use Data::Dumper;
27use Digest::MD5; 28use Digest::MD5;
28use Fcntl; 29use Fcntl;
29use YAML::Syck (); 30use YAML::Syck ();
30use IO::AIO 2.32 (); 31use IO::AIO 2.32 ();
31use Time::HiRes; 32use Time::HiRes;
32use Compress::LZF; 33use Compress::LZF;
34use Digest::MD5 ();
33 35
34# configure various modules to our taste 36# configure various modules to our taste
35# 37#
36$Storable::canonical = 1; # reduce rsync transfers 38$Storable::canonical = 1; # reduce rsync transfers
37Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 39Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
… …
164=item cf::wait_for_tick, cf::wait_for_tick_begin 166=item cf::wait_for_tick, cf::wait_for_tick_begin
165 167
166These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 168These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
167returns directly I<after> the tick processing (and consequently, can only wake one process 169returns directly I<after> the tick processing (and consequently, can only wake one process
168per tick), while cf::wait_for_tick wakes up all waiters after tick processing. 170per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
171
172=item @cf::INVOKE_RESULTS
173
174This array contains the results of the last C<invoke ()> call. When
175C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
176that call.
169 177
170=back 178=back
171 179
172=cut 180=cut
173 181
… …
237 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 245 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
238 $d 246 $d
239 } || "[unable to dump $_[0]: '$@']"; 247 } || "[unable to dump $_[0]: '$@']";
240} 248}
241 249
242use JSON::XS ();
243
244=item $ref = cf::from_json $json 250=item $ref = cf::from_json $json
245 251
246Converts a JSON string into the corresponding perl data structure. 252Converts a JSON string into the corresponding perl data structure.
247 253
248=item $json = cf::to_json $ref 254=item $json = cf::to_json $ref
249 255
250Converts a perl data structure into its JSON representation. 256Converts a perl data structure into its JSON representation.
251 257
252=cut 258=cut
253 259
254our $json_coder = JSON::XS->new->convert_blessed->utf8; 260our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
255 261
256sub to_json ($) { $json_coder->encode ($_[0]) } 262sub to_json ($) { $json_coder->encode ($_[0]) }
257sub from_json ($) { $json_coder->decode ($_[0]) } 263sub from_json ($) { $json_coder->decode ($_[0]) }
258 264
259=item cf::lock_wait $string 265=item cf::lock_wait $string
… …
314 my $guard = Coro::guard { 320 my $guard = Coro::guard {
315 $TICK_WATCHER->start; 321 $TICK_WATCHER->start;
316 }; 322 };
317 $TICK_WATCHER->stop; 323 $TICK_WATCHER->stop;
318 $guard 324 $guard
325}
326
327=item cf::get_slot $time[, $priority]
328
329Allocate $time seconds of blocking CPU time at priority C<$priority>:
330This call blocks and returns only when you have at least C<$time> seconds
331of cpu time till the next tick. The slot is only valid till the next cede.
332
333Useful for short background jobs.
334
335=cut
336
337our @SLOT_QUEUE;
338our $SLOT_QUEUE;
339
340$SLOT_QUEUE->cancel if $SLOT_QUEUE;
341$SLOT_QUEUE = Coro::async {
342 my $signal = new Coro::Signal;
343
344 while () {
345 next_job:
346 my $avail = cf::till_tick;
347 if ($avail > 0.01) {
348 for (0 .. $#SLOT_QUEUE) {
349 if ($SLOT_QUEUE[$_][0] < $avail) {
350 my $job = splice @SLOT_QUEUE, $_, 1, ();
351 $job->[2]->send;
352 Coro::cede;
353 goto next_job;
354 }
355 }
356 }
357
358 if (@SLOT_QUEUE) {
359 # we do not use wait_For_tick() as it returns immediately when tick is inactive
360 push @cf::WAIT_FOR_TICK, $signal;
361 $signal->wait;
362 } else {
363 Coro::schedule;
364 }
365 }
366};
367
368sub get_slot($;$) {
369 my ($time, $pri) = @_;
370
371 push @SLOT_QUEUE, [$time, $pri, my $sig = new Coro::Signal];
372 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
373 $SLOT_QUEUE->ready;
374 $sig->wait;
319} 375}
320 376
321=item cf::async { BLOCK } 377=item cf::async { BLOCK }
322 378
323Currently the same as Coro::async_pool, meaning you cannot use 379Currently the same as Coro::async_pool, meaning you cannot use
… …
410Coro::Storable. May, of course, block. Note that the executed sub may 466Coro::Storable. May, of course, block. Note that the executed sub may
411never block itself or use any form of Event handling. 467never block itself or use any form of Event handling.
412 468
413=cut 469=cut
414 470
471sub _store_scalar {
472 open my $fh, ">", \my $buf
473 or die "fork_call: cannot open fh-to-buf in child : $!";
474 Storable::store_fd $_[0], $fh;
475 close $fh;
476
477 $buf
478}
479
415sub fork_call(&@) { 480sub fork_call(&@) {
416 my ($cb, @args) = @_; 481 my ($cb, @args) = @_;
417 482
418# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC 483# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
419# or die "socketpair: $!"; 484# or die "socketpair: $!";
… …
422 487
423 if (my $pid = fork) { 488 if (my $pid = fork) {
424 close $fh2; 489 close $fh2;
425 490
426 my $res = (Coro::Handle::unblock $fh1)->readline (undef); 491 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
492 warn "pst<$res>" unless $res =~ /^pst/;
427 $res = Coro::Storable::thaw $res; 493 $res = Coro::Storable::thaw $res;
428 494
429 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave 495 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
430 496
431 die $$res unless "ARRAY" eq ref $res; 497 Carp::confess $$res unless "ARRAY" eq ref $res;
432 498
433 return wantarray ? @$res : $res->[-1]; 499 return wantarray ? @$res : $res->[-1];
434 } else { 500 } else {
435 reset_signals; 501 reset_signals;
436 local $SIG{__WARN__}; 502 local $SIG{__WARN__};
437 local $SIG{__DIE__}; 503 local $SIG{__DIE__};
504 # just in case, this hack effectively disables event
505 # in the child. cleaner and slower would be canceling all watchers,
506 # but this works for the time being.
507 local $Coro::idle;
508 $Coro::current->prio (Coro::PRIO_MAX);
509
438 eval { 510 eval {
439 close $fh1; 511 close $fh1;
440 512
441 my @res = eval { $cb->(@args) }; 513 my @res = eval { $cb->(@args) };
514
442 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res); 515 syswrite $fh2, _store_scalar $@ ? \"$@" : \@res;
516 close $fh2;
443 }; 517 };
444 518
445 warn $@ if $@; 519 warn $@ if $@;
446 _exit 0; 520 _exit 0;
447 } 521 }
… …
848 "; 922 ";
849 die if $@; 923 die if $@;
850} 924}
851 925
852our $override; 926our $override;
853our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 927our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
854 928
855sub override { 929sub override {
856 $override = 1; 930 $override = 1;
857 @invoke_results = (); 931 @INVOKE_RESULTS = (@_);
858} 932}
859 933
860sub do_invoke { 934sub do_invoke {
861 my $event = shift; 935 my $event = shift;
862 my $callbacks = shift; 936 my $callbacks = shift;
863 937
864 @invoke_results = (); 938 @INVOKE_RESULTS = ();
865 939
866 local $override; 940 local $override;
867 941
868 for (@$callbacks) { 942 for (@$callbacks) {
869 eval { &{$_->[1]} }; 943 eval { &{$_->[1]} };
… …
886 960
887Generate an object-specific event with the given arguments. 961Generate an object-specific event with the given arguments.
888 962
889This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be 963This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
890removed in future versions), and there is no public API to access override 964removed in future versions), and there is no public API to access override
891results (if you must, access C<@cf::invoke_results> directly). 965results (if you must, access C<@cf::INVOKE_RESULTS> directly).
892 966
893=back 967=back
894 968
895=cut 969=cut
896 970
897############################################################################# 971#############################################################################
898# object support 972# object support
973#
974
975sub _can_merge {
976 my ($ob1, $ob2) = @_;
977
978 local $Storable::canonical = 1;
979 my $fob1 = Storable::freeze $ob1;
980 my $fob2 = Storable::freeze $ob2;
981
982 $fob1 eq $fob2
983}
899 984
900sub reattach { 985sub reattach {
901 # basically do the same as instantiate, without calling instantiate 986 # basically do the same as instantiate, without calling instantiate
902 my ($obj) = @_; 987 my ($obj) = @_;
903 988
… …
1087 cf::override; 1172 cf::override;
1088 }, 1173 },
1089 on_extcmd => sub { 1174 on_extcmd => sub {
1090 my ($pl, $buf) = @_; 1175 my ($pl, $buf) = @_;
1091 1176
1092 my $msg = eval { from_json $buf }; 1177 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1093 1178
1094 if (ref $msg) { 1179 if (ref $msg) {
1095 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1180 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
1096 if (my %reply = $cb->($pl, $msg)) { 1181 if (my %reply = $cb->($pl, $msg)) {
1097 $pl->ext_reply ($msg->{msgid}, %reply); 1182 $pl->ext_reply ($msg->{msgid}, %reply);
… …
1401 # replace G<male|female> tags 1486 # replace G<male|female> tags
1402 || s{G<([^>|]*)\|([^>]*)>}{ 1487 || s{G<([^>|]*)\|([^>]*)>}{
1403 $self->gender ? $2 : $1 1488 $self->gender ? $2 : $1
1404 }ge 1489 }ge
1405 # replace H<hint text> 1490 # replace H<hint text>
1406 || s/H<([^\>]*)>/<fg name="lightblue">[$1]<\/fg>/g; 1491 || s{H<([^\>]*)>}
1492 {
1493 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
1494 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1495 "")
1496 [$self->{hintmode}]
1497 }ge;
1407 1498
1408 # create single paragraphs (very hackish) 1499 # create single paragraphs (very hackish)
1409 s/(?<=\S)\n(?=\w)/ /g; 1500 s/(?<=\S)\n(?=\w)/ /g;
1410 1501
1502 # compress some whitespace
1503 s/\s+\n/\n/g; # ws line-ends
1504 s/\n\n+/\n/g; # double lines
1505 s/^\n+//; # beginning lines
1506 s/\n+$//; # ending lines
1507
1411 $_ 1508 $_
1509}
1510
1511sub hintmode {
1512 $_[0]{hintmode} = $_[1] if @_ > 1;
1513 $_[0]{hintmode}
1412} 1514}
1413 1515
1414=item $player->ext_reply ($msgid, %msg) 1516=item $player->ext_reply ($msgid, %msg)
1415 1517
1416Sends an ext reply to the player. 1518Sends an ext reply to the player.
… …
1419 1521
1420sub ext_reply($$%) { 1522sub ext_reply($$%) {
1421 my ($self, $id, %msg) = @_; 1523 my ($self, $id, %msg) = @_;
1422 1524
1423 $msg{msgid} = $id; 1525 $msg{msgid} = $id;
1424 $self->send ("ext " . cf::to_json \%msg); 1526 $self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));
1425} 1527}
1426 1528
1427=item $player->ext_event ($type, %msg) 1529=item $player->ext_event ($type, %msg)
1428 1530
1429Sends an ext event to the client. 1531Sends an ext event to the client.
… …
1454 my ($path) = @_; 1556 my ($path) = @_;
1455 1557
1456 my ($match, $specificity); 1558 my ($match, $specificity);
1457 1559
1458 for my $region (list) { 1560 for my $region (list) {
1459 if ($region->match && $path =~ $region->match) { 1561 if ($region->{match} && $path =~ $region->{match}) {
1460 ($match, $specificity) = ($region, $region->specificity) 1562 ($match, $specificity) = ($region, $region->specificity)
1461 if $region->specificity > $specificity; 1563 if $region->specificity > $specificity;
1462 } 1564 }
1463 } 1565 }
1464 1566
… …
1584 $self->init; # pass $1 etc. 1686 $self->init; # pass $1 etc.
1585 return $self; 1687 return $self;
1586 } 1688 }
1587 } 1689 }
1588 1690
1589 Carp::carp "unable to resolve path '$path' (base '$base')."; 1691 Carp::cluck "unable to resolve path '$path' (base '$base').";
1590 () 1692 ()
1591} 1693}
1592 1694
1593sub init { 1695sub init {
1594 my ($self) = @_; 1696 my ($self) = @_;
… …
1872 1974
1873 undef $MAP_PREFETCH{$path}; 1975 undef $MAP_PREFETCH{$path};
1874 $MAP_PREFETCHER ||= cf::async { 1976 $MAP_PREFETCHER ||= cf::async {
1875 while (%MAP_PREFETCH) { 1977 while (%MAP_PREFETCH) {
1876 for my $path (keys %MAP_PREFETCH) { 1978 for my $path (keys %MAP_PREFETCH) {
1877 my $map = find $path 1979 if (my $map = find $path) {
1878 or next;
1879 $map->load; 1980 $map->load;
1981 }
1880 1982
1881 delete $MAP_PREFETCH{$path}; 1983 delete $MAP_PREFETCH{$path};
1882 } 1984 }
1883 } 1985 }
1884 undef $MAP_PREFETCHER; 1986 undef $MAP_PREFETCHER;
… …
2221 2323
2222 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2324 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2223 $self->enter_map ($map, $x, $y); 2325 $self->enter_map ($map, $x, $y);
2224} 2326}
2225 2327
2226=item $player_object->goto ($path, $x, $y[, $check->($map)]) 2328=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2227 2329
2228Moves the player to the given map-path and coordinates by first freezing 2330Moves the player to the given map-path and coordinates by first freezing
2229her, loading and preparing them map, calling the provided $check callback 2331her, loading and preparing them map, calling the provided $check callback
2230that has to return the map if sucecssful, and then unfreezes the player on 2332that has to return the map if sucecssful, and then unfreezes the player on
2231the new (success) or old (failed) map position. 2333the new (success) or old (failed) map position. In either case, $done will
2334be called at the end of this process.
2232 2335
2233=cut 2336=cut
2234 2337
2235our $GOTOGEN; 2338our $GOTOGEN;
2236 2339
2237sub cf::object::player::goto { 2340sub cf::object::player::goto {
2238 my ($self, $path, $x, $y, $check) = @_; 2341 my ($self, $path, $x, $y, $check, $done) = @_;
2239 2342
2240 # do generation counting so two concurrent goto's will be executed in-order 2343 # do generation counting so two concurrent goto's will be executed in-order
2241 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2344 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2242 2345
2243 $self->enter_link; 2346 $self->enter_link;
… …
2263 2366
2264 if ($gen == $self->{_goto_generation}) { 2367 if ($gen == $self->{_goto_generation}) {
2265 delete $self->{_goto_generation}; 2368 delete $self->{_goto_generation};
2266 $self->leave_link ($map, $x, $y); 2369 $self->leave_link ($map, $x, $y);
2267 } 2370 }
2371
2372 $done->() if $done;
2268 })->prio (1); 2373 })->prio (1);
2269} 2374}
2270 2375
2271=item $player_object->enter_exit ($exit_object) 2376=item $player_object->enter_exit ($exit_object)
2272 2377
… …
2341 my $hp = $exit->stats->hp; 2446 my $hp = $exit->stats->hp;
2342 my $sp = $exit->stats->sp; 2447 my $sp = $exit->stats->sp;
2343 2448
2344 $self->enter_link; 2449 $self->enter_link;
2345 2450
2451 # if exit is damned, update players death & WoR home-position
2452 $self->contr->savebed ($slaying, $hp, $sp)
2453 if $exit->flag (FLAG_DAMNED);
2454
2346 (async { 2455 (async {
2347 $self->deactivate_recursive; # just to be sure 2456 $self->deactivate_recursive; # just to be sure
2348 unless (eval { 2457 unless (eval {
2349 $self->goto ($slaying, $hp, $sp); 2458 $self->goto ($slaying, $hp, $sp);
2350 2459
… …
2377 2486
2378 utf8::encode $text; 2487 utf8::encode $text;
2379 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2488 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2380} 2489}
2381 2490
2382=item $client->send_msg ($color, $type, $msg, [extra...]) 2491=item $client->send_msg ($channel, $msg, $color, [extra...])
2383 2492
2384Send a drawinfo or msg packet to the client, formatting the msg for the 2493Send a drawinfo or msg packet to the client, formatting the msg for the
2385client if neccessary. C<$type> should be a string identifying the type of 2494client if neccessary. C<$type> should be a string identifying the type of
2386the message, with C<log> being the default. If C<$color> is negative, suppress 2495the message, with C<log> being the default. If C<$color> is negative, suppress
2387the message unless the client supports the msg packet. 2496the message unless the client supports the msg packet.
2388 2497
2389=cut 2498=cut
2390 2499
2391sub cf::client::send_msg { 2500sub cf::client::send_msg {
2392 my ($self, $color, $type, $msg, @extra) = @_; 2501 my ($self, $channel, $msg, $color, @extra) = @_;
2393 2502
2394 $msg = $self->pl->expand_cfpod ($msg); 2503 $msg = $self->pl->expand_cfpod ($msg);
2395 2504
2505 $color &= ~cf::NDI_UNIQUE; # just in case...
2506
2507 if (ref $channel) {
2508 # send meta info to client, if not yet sent
2509 unless (exists $self->{channel}{$channel->{id}}) {
2510 $self->{channel}{$channel->{id}} = $channel;
2511 $self->ext_event (channel_info => %$channel);
2512 }
2513
2514 $channel = $channel->{id};
2515 }
2516
2517 return unless @extra || length $msg;
2518
2396 if ($self->can_msg) { 2519 if ($self->can_msg) {
2397 $self->send_packet ("msg " . cf::to_json [$color, $type, $msg, @extra]); 2520 $self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $channel, $msg, @extra]));
2398 } else { 2521 } else {
2399 # replace some tags by gcfclient-compatible ones 2522 # replace some tags by gcfclient-compatible ones
2400 for ($msg) { 2523 for ($msg) {
2401 1 while 2524 1 while
2402 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/ 2525 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
… …
2424=cut 2547=cut
2425 2548
2426sub cf::client::ext_event($$%) { 2549sub cf::client::ext_event($$%) {
2427 my ($self, $type, %msg) = @_; 2550 my ($self, $type, %msg) = @_;
2428 2551
2552 return unless $self->extcmd;
2553
2429 $msg{msgtype} = "event_$type"; 2554 $msg{msgtype} = "event_$type";
2430 $self->send_packet ("ext " . cf::to_json \%msg); 2555 $self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));
2431} 2556}
2432 2557
2433=item $success = $client->query ($flags, "text", \&cb) 2558=item $success = $client->query ($flags, "text", \&cb)
2434 2559
2435Queues a query to the client, calling the given callback with 2560Queues a query to the client, calling the given callback with
… …
2458 2583
2459 1 2584 1
2460} 2585}
2461 2586
2462cf::client->attach ( 2587cf::client->attach (
2588 on_connect => sub {
2589 my ($ns) = @_;
2590
2591 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2592 },
2463 on_reply => sub { 2593 on_reply => sub {
2464 my ($ns, $msg) = @_; 2594 my ($ns, $msg) = @_;
2465 2595
2466 # this weird shuffling is so that direct followup queries 2596 # this weird shuffling is so that direct followup queries
2467 # get handled first 2597 # get handled first
… …
2482 } 2612 }
2483 }, 2613 },
2484 on_exticmd => sub { 2614 on_exticmd => sub {
2485 my ($ns, $buf) = @_; 2615 my ($ns, $buf) = @_;
2486 2616
2487 my $msg = eval { from_json $buf }; 2617 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2488 2618
2489 if (ref $msg) { 2619 if (ref $msg) {
2490 if (my $cb = $EXTICMD{$msg->{msgtype}}) { 2620 if (my $cb = $EXTICMD{$msg->{msgtype}}) {
2491 if (my %reply = $cb->($ns, $msg)) { 2621 if (my %reply = $cb->($ns, $msg)) {
2492 $reply{msgid} = $msg->{msgid}; 2622 $reply{msgid} = $msg->{msgid};
2493 $ns->send ("ext " . cf::to_json \%reply); 2623 $ns->send ("ext " . $ns->{json_coder}->encode (\%reply));
2494 } 2624 }
2495 } 2625 }
2496 } else { 2626 } else {
2497 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 2627 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2498 } 2628 }
… …
2555 2685
2556=pod 2686=pod
2557 2687
2558The following functions and methods are available within a safe environment: 2688The following functions and methods are available within a safe environment:
2559 2689
2560 cf::object contr pay_amount pay_player map 2690 cf::object
2691 contr pay_amount pay_player map x y force_find force_add
2692 insert remove
2693
2561 cf::object::player player 2694 cf::object::player
2562 cf::player peaceful 2695 player
2563 cf::map trigger 2696
2697 cf::player
2698 peaceful
2699
2700 cf::map
2701 trigger
2564 2702
2565=cut 2703=cut
2566 2704
2567for ( 2705for (
2568 ["cf::object" => qw(contr pay_amount pay_player map)], 2706 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2707 insert remove)],
2569 ["cf::object::player" => qw(player)], 2708 ["cf::object::player" => qw(player)],
2570 ["cf::player" => qw(peaceful)], 2709 ["cf::player" => qw(peaceful)],
2571 ["cf::map" => qw(trigger)], 2710 ["cf::map" => qw(trigger)],
2572) { 2711) {
2573 no strict 'refs'; 2712 no strict 'refs';
… …
2665 { 2804 {
2666 my $faces = $facedata->{faceinfo}; 2805 my $faces = $facedata->{faceinfo};
2667 2806
2668 while (my ($face, $info) = each %$faces) { 2807 while (my ($face, $info) = each %$faces) {
2669 my $idx = (cf::face::find $face) || cf::face::alloc $face; 2808 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2670 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 2809 cf::face::set_visibility $idx, $info->{visibility};
2810 cf::face::set_magicmap $idx, $info->{magicmap};
2671 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 2811 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2672 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 2812 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2673 Coro::cede; 2813
2814 cf::cede_to_tick;
2674 } 2815 }
2675 2816
2676 while (my ($face, $info) = each %$faces) { 2817 while (my ($face, $info) = each %$faces) {
2677 next unless $info->{smooth}; 2818 next unless $info->{smooth};
2678 my $idx = cf::face::find $face 2819 my $idx = cf::face::find $face
2679 or next; 2820 or next;
2680 if (my $smooth = cf::face::find $info->{smooth}) { 2821 if (my $smooth = cf::face::find $info->{smooth}) {
2822 cf::face::set_smooth $idx, $smooth;
2681 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel}; 2823 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2682 } else { 2824 } else {
2683 warn "smooth face '$info->{smooth}' not found for face '$face'"; 2825 warn "smooth face '$info->{smooth}' not found for face '$face'";
2684 } 2826 }
2685 Coro::cede; 2827
2828 cf::cede_to_tick;
2686 } 2829 }
2687 } 2830 }
2688 2831
2689 { 2832 {
2690 my $anims = $facedata->{animinfo}; 2833 my $anims = $facedata->{animinfo};
2691 2834
2692 while (my ($anim, $info) = each %$anims) { 2835 while (my ($anim, $info) = each %$anims) {
2693 cf::anim::set $anim, $info->{frames}, $info->{facings}; 2836 cf::anim::set $anim, $info->{frames}, $info->{facings};
2694 Coro::cede; 2837 cf::cede_to_tick;
2695 } 2838 }
2696 2839
2697 cf::anim::invalidate_all; # d'oh 2840 cf::anim::invalidate_all; # d'oh
2841 }
2842
2843 {
2844 # TODO: for gcfclient pleasure, we should give resources
2845 # that gcfclient doesn't grok a >10000 face index.
2846 my $res = $facedata->{resource};
2847 my $enc = JSON::XS->new->utf8->canonical;
2848
2849 while (my ($name, $info) = each %$res) {
2850 my $meta = $enc->encode ({
2851 name => $name,
2852 type => $info->{type},
2853 copyright => $info->{copyright}, #TODO#
2854 });
2855
2856 my $idx = (cf::face::find $name) || cf::face::alloc $name;
2857
2858 if ($name =~ /\.jpg$/) {
2859 cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};#d# temp hack
2860 cf::face::set_data $idx, 1, $info->{data}, $info->{chksum};#d# temp hack
2861 } else {
2862 my $data = pack "(w/a*)*", $meta, $info->{data};
2863 my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
2864
2865 cf::face::set_type $idx, 1;
2866 cf::face::set_data $idx, 0, $data, $chk;
2867 }
2868
2869 cf::cede_to_tick;
2870 }
2698 } 2871 }
2699 2872
2700 1 2873 1
2701} 2874}
2702 2875
2703sub reload_regions { 2876sub reload_regions {
2704 load_resource_file "$MAPDIR/regions" 2877 load_resource_file "$MAPDIR/regions"
2705 or die "unable to load regions file\n"; 2878 or die "unable to load regions file\n";
2879
2880 for (cf::region::list) {
2881 $_->{match} = qr/$_->{match}/
2882 if exists $_->{match};
2883 }
2706} 2884}
2707 2885
2708sub reload_facedata { 2886sub reload_facedata {
2709 load_facedata "$DATADIR/facedata" 2887 load_facedata "$DATADIR/facedata"
2710 or die "unable to load facedata\n"; 2888 or die "unable to load facedata\n";
2711} 2889}
2712 2890
2713sub reload_archetypes { 2891sub reload_archetypes {
2892 load_resource_file "$DATADIR/archetypes"
2893 or die "unable to load archetypes\n";
2894 #d# NEED to laod twice to resolve forward references
2895 # this really needs to be done in an extra post-pass
2896 # (which needs to be synchronous, so solve it differently)
2714 load_resource_file "$DATADIR/archetypes" 2897 load_resource_file "$DATADIR/archetypes"
2715 or die "unable to load archetypes\n"; 2898 or die "unable to load archetypes\n";
2716} 2899}
2717 2900
2718sub reload_treasures { 2901sub reload_treasures {

Diff Legend

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