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.289 by root, Sat Jun 30 03:00:54 2007 UTC vs.
Revision 1.309 by elmex, Mon Jul 16 15:27:06 2007 UTC

… …
29use Fcntl; 29use Fcntl;
30use YAML::Syck (); 30use YAML::Syck ();
31use IO::AIO 2.32 (); 31use IO::AIO 2.32 ();
32use Time::HiRes; 32use Time::HiRes;
33use Compress::LZF; 33use Compress::LZF;
34use Digest::MD5 ();
34 35
35# configure various modules to our taste 36# configure various modules to our taste
36# 37#
37$Storable::canonical = 1; # reduce rsync transfers 38$Storable::canonical = 1; # reduce rsync transfers
38Coro::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
… …
248 249
249Converts a perl data structure into its JSON representation. 250Converts a perl data structure into its JSON representation.
250 251
251=cut 252=cut
252 253
253our $json_coder = JSON::XS->new->convert_blessed->utf8->max_size (1e6); # accept ~1mb max 254our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
254 255
255sub to_json ($) { $json_coder->encode ($_[0]) } 256sub to_json ($) { $json_coder->encode ($_[0]) }
256sub from_json ($) { $json_coder->decode ($_[0]) } 257sub from_json ($) { $json_coder->decode ($_[0]) }
257 258
258=item cf::lock_wait $string 259=item cf::lock_wait $string
… …
409Coro::Storable. May, of course, block. Note that the executed sub may 410Coro::Storable. May, of course, block. Note that the executed sub may
410never block itself or use any form of Event handling. 411never block itself or use any form of Event handling.
411 412
412=cut 413=cut
413 414
415sub _store_scalar {
416 open my $fh, ">", \my $buf
417 or die "fork_call: cannot open fh-to-buf in child : $!";
418 Storable::store_fd $_[0], $fh;
419 close $fh;
420
421 $buf
422}
423
414sub fork_call(&@) { 424sub fork_call(&@) {
415 my ($cb, @args) = @_; 425 my ($cb, @args) = @_;
416 426
417# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC 427# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
418# or die "socketpair: $!"; 428# or die "socketpair: $!";
… …
421 431
422 if (my $pid = fork) { 432 if (my $pid = fork) {
423 close $fh2; 433 close $fh2;
424 434
425 my $res = (Coro::Handle::unblock $fh1)->readline (undef); 435 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
436 warn "pst<$res>" unless $res =~ /^pst/;
426 $res = Coro::Storable::thaw $res; 437 $res = Coro::Storable::thaw $res;
427 438
428 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave 439 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
429 440
430 die $$res unless "ARRAY" eq ref $res; 441 Carp::confess $$res unless "ARRAY" eq ref $res;
431 442
432 return wantarray ? @$res : $res->[-1]; 443 return wantarray ? @$res : $res->[-1];
433 } else { 444 } else {
434 reset_signals; 445 reset_signals;
435 local $SIG{__WARN__}; 446 local $SIG{__WARN__};
436 local $SIG{__DIE__}; 447 local $SIG{__DIE__};
448 # just in case, this hack effectively disables event
449 # in the child. cleaner and slower would be canceling all watchers,
450 # but this works for the time being.
451 local $Coro::idle;
452 $Coro::current->prio (Coro::PRIO_MAX);
453
437 eval { 454 eval {
438 close $fh1; 455 close $fh1;
439 456
440 my @res = eval { $cb->(@args) }; 457 my @res = eval { $cb->(@args) };
458
441 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res); 459 syswrite $fh2, _store_scalar $@ ? \"$@" : \@res;
460 close $fh2;
442 }; 461 };
443 462
444 warn $@ if $@; 463 warn $@ if $@;
445 _exit 0; 464 _exit 0;
446 } 465 }
… …
851our $override; 870our $override;
852our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 871our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
853 872
854sub override { 873sub override {
855 $override = 1; 874 $override = 1;
856 @invoke_results = (); 875 @invoke_results = (@_);
857} 876}
858 877
859sub do_invoke { 878sub do_invoke {
860 my $event = shift; 879 my $event = shift;
861 my $callbacks = shift; 880 my $callbacks = shift;
… …
1086 cf::override; 1105 cf::override;
1087 }, 1106 },
1088 on_extcmd => sub { 1107 on_extcmd => sub {
1089 my ($pl, $buf) = @_; 1108 my ($pl, $buf) = @_;
1090 1109
1091 my $msg = eval { from_json $buf }; 1110 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1092 1111
1093 if (ref $msg) { 1112 if (ref $msg) {
1094 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1113 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
1095 if (my %reply = $cb->($pl, $msg)) { 1114 if (my %reply = $cb->($pl, $msg)) {
1096 $pl->ext_reply ($msg->{msgid}, %reply); 1115 $pl->ext_reply ($msg->{msgid}, %reply);
… …
1400 # replace G<male|female> tags 1419 # replace G<male|female> tags
1401 || s{G<([^>|]*)\|([^>]*)>}{ 1420 || s{G<([^>|]*)\|([^>]*)>}{
1402 $self->gender ? $2 : $1 1421 $self->gender ? $2 : $1
1403 }ge 1422 }ge
1404 # replace H<hint text> 1423 # replace H<hint text>
1405 || s/H<([^\>]*)>/<fg name="lightblue">[$1]<\/fg>/g; 1424 || s{H<([^\>]*)>}
1425 {
1426 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
1427 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1428 "")
1429 [$self->{hintmode}]
1430 }ge;
1406 1431
1407 # create single paragraphs (very hackish) 1432 # create single paragraphs (very hackish)
1408 s/(?<=\S)\n(?=\w)/ /g; 1433 s/(?<=\S)\n(?=\w)/ /g;
1409 1434
1435 # compress some whitespace
1436 s/\s+\n/\n/g; # ws line-ends
1437 s/\n\n+/\n/g; # double lines
1438 s/^\n+//; # beginning lines
1439 s/\n+$//; # ending lines
1440
1410 $_ 1441 $_
1442}
1443
1444sub hintmode {
1445 $_[0]{hintmode} = $_[1] if @_ > 1;
1446 $_[0]{hintmode}
1411} 1447}
1412 1448
1413=item $player->ext_reply ($msgid, %msg) 1449=item $player->ext_reply ($msgid, %msg)
1414 1450
1415Sends an ext reply to the player. 1451Sends an ext reply to the player.
… …
1418 1454
1419sub ext_reply($$%) { 1455sub ext_reply($$%) {
1420 my ($self, $id, %msg) = @_; 1456 my ($self, $id, %msg) = @_;
1421 1457
1422 $msg{msgid} = $id; 1458 $msg{msgid} = $id;
1423 $self->send ("ext " . cf::to_json \%msg); 1459 $self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));
1424} 1460}
1425 1461
1426=item $player->ext_event ($type, %msg) 1462=item $player->ext_event ($type, %msg)
1427 1463
1428Sends an ext event to the client. 1464Sends an ext event to the client.
… …
1453 my ($path) = @_; 1489 my ($path) = @_;
1454 1490
1455 my ($match, $specificity); 1491 my ($match, $specificity);
1456 1492
1457 for my $region (list) { 1493 for my $region (list) {
1458 if ($region->match && $path =~ $region->match) { 1494 if ($region->{match} && $path =~ $region->{match}) {
1459 ($match, $specificity) = ($region, $region->specificity) 1495 ($match, $specificity) = ($region, $region->specificity)
1460 if $region->specificity > $specificity; 1496 if $region->specificity > $specificity;
1461 } 1497 }
1462 } 1498 }
1463 1499
… …
1583 $self->init; # pass $1 etc. 1619 $self->init; # pass $1 etc.
1584 return $self; 1620 return $self;
1585 } 1621 }
1586 } 1622 }
1587 1623
1588 Carp::carp "unable to resolve path '$path' (base '$base')."; 1624 Carp::cluck "unable to resolve path '$path' (base '$base').";
1589 () 1625 ()
1590} 1626}
1591 1627
1592sub init { 1628sub init {
1593 my ($self) = @_; 1629 my ($self) = @_;
… …
1871 1907
1872 undef $MAP_PREFETCH{$path}; 1908 undef $MAP_PREFETCH{$path};
1873 $MAP_PREFETCHER ||= cf::async { 1909 $MAP_PREFETCHER ||= cf::async {
1874 while (%MAP_PREFETCH) { 1910 while (%MAP_PREFETCH) {
1875 for my $path (keys %MAP_PREFETCH) { 1911 for my $path (keys %MAP_PREFETCH) {
1876 my $map = find $path 1912 if (my $map = find $path) {
1877 or next;
1878 $map->load; 1913 $map->load;
1914 }
1879 1915
1880 delete $MAP_PREFETCH{$path}; 1916 delete $MAP_PREFETCH{$path};
1881 } 1917 }
1882 } 1918 }
1883 undef $MAP_PREFETCHER; 1919 undef $MAP_PREFETCHER;
… …
2220 2256
2221 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2257 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2222 $self->enter_map ($map, $x, $y); 2258 $self->enter_map ($map, $x, $y);
2223} 2259}
2224 2260
2225=item $player_object->goto ($path, $x, $y[, $check->($map)]) 2261=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2226 2262
2227Moves the player to the given map-path and coordinates by first freezing 2263Moves the player to the given map-path and coordinates by first freezing
2228her, loading and preparing them map, calling the provided $check callback 2264her, loading and preparing them map, calling the provided $check callback
2229that has to return the map if sucecssful, and then unfreezes the player on 2265that has to return the map if sucecssful, and then unfreezes the player on
2230the new (success) or old (failed) map position. 2266the new (success) or old (failed) map position. In either case, $done will
2267be called at the end of this process.
2231 2268
2232=cut 2269=cut
2233 2270
2234our $GOTOGEN; 2271our $GOTOGEN;
2235 2272
2236sub cf::object::player::goto { 2273sub cf::object::player::goto {
2237 my ($self, $path, $x, $y, $check) = @_; 2274 my ($self, $path, $x, $y, $check, $done) = @_;
2238 2275
2239 # do generation counting so two concurrent goto's will be executed in-order 2276 # do generation counting so two concurrent goto's will be executed in-order
2240 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2277 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2241 2278
2242 $self->enter_link; 2279 $self->enter_link;
… …
2262 2299
2263 if ($gen == $self->{_goto_generation}) { 2300 if ($gen == $self->{_goto_generation}) {
2264 delete $self->{_goto_generation}; 2301 delete $self->{_goto_generation};
2265 $self->leave_link ($map, $x, $y); 2302 $self->leave_link ($map, $x, $y);
2266 } 2303 }
2304
2305 $done->() if $done;
2267 })->prio (1); 2306 })->prio (1);
2268} 2307}
2269 2308
2270=item $player_object->enter_exit ($exit_object) 2309=item $player_object->enter_exit ($exit_object)
2271 2310
… …
2340 my $hp = $exit->stats->hp; 2379 my $hp = $exit->stats->hp;
2341 my $sp = $exit->stats->sp; 2380 my $sp = $exit->stats->sp;
2342 2381
2343 $self->enter_link; 2382 $self->enter_link;
2344 2383
2384 # if exit is damned, update players death & WoR home-position
2385 $self->contr->savebed ($slaying, $hp, $sp)
2386 if $exit->flag (FLAG_DAMNED);
2387
2345 (async { 2388 (async {
2346 $self->deactivate_recursive; # just to be sure 2389 $self->deactivate_recursive; # just to be sure
2347 unless (eval { 2390 unless (eval {
2348 $self->goto ($slaying, $hp, $sp); 2391 $self->goto ($slaying, $hp, $sp);
2349 2392
… …
2390sub cf::client::send_msg { 2433sub cf::client::send_msg {
2391 my ($self, $color, $type, $msg, @extra) = @_; 2434 my ($self, $color, $type, $msg, @extra) = @_;
2392 2435
2393 $msg = $self->pl->expand_cfpod ($msg); 2436 $msg = $self->pl->expand_cfpod ($msg);
2394 2437
2438 return unless @extra || length $msg;
2439
2395 if ($self->can_msg) { 2440 if ($self->can_msg) {
2396 $self->send_packet ("msg " . cf::to_json [$color, $type, $msg, @extra]); 2441 $self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $type, $msg, @extra]));
2397 } else { 2442 } else {
2398 # replace some tags by gcfclient-compatible ones 2443 # replace some tags by gcfclient-compatible ones
2399 for ($msg) { 2444 for ($msg) {
2400 1 while 2445 1 while
2401 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/ 2446 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
… …
2423=cut 2468=cut
2424 2469
2425sub cf::client::ext_event($$%) { 2470sub cf::client::ext_event($$%) {
2426 my ($self, $type, %msg) = @_; 2471 my ($self, $type, %msg) = @_;
2427 2472
2473 return unless $self->extcmd;
2474
2428 $msg{msgtype} = "event_$type"; 2475 $msg{msgtype} = "event_$type";
2429 $self->send_packet ("ext " . cf::to_json \%msg); 2476 $self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));
2430} 2477}
2431 2478
2432=item $success = $client->query ($flags, "text", \&cb) 2479=item $success = $client->query ($flags, "text", \&cb)
2433 2480
2434Queues a query to the client, calling the given callback with 2481Queues a query to the client, calling the given callback with
… …
2457 2504
2458 1 2505 1
2459} 2506}
2460 2507
2461cf::client->attach ( 2508cf::client->attach (
2509 on_connect => sub {
2510 my ($ns) = @_;
2511
2512 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2513 },
2462 on_reply => sub { 2514 on_reply => sub {
2463 my ($ns, $msg) = @_; 2515 my ($ns, $msg) = @_;
2464 2516
2465 # this weird shuffling is so that direct followup queries 2517 # this weird shuffling is so that direct followup queries
2466 # get handled first 2518 # get handled first
… …
2481 } 2533 }
2482 }, 2534 },
2483 on_exticmd => sub { 2535 on_exticmd => sub {
2484 my ($ns, $buf) = @_; 2536 my ($ns, $buf) = @_;
2485 2537
2486 my $msg = eval { from_json $buf }; 2538 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2487 2539
2488 if (ref $msg) { 2540 if (ref $msg) {
2489 if (my $cb = $EXTICMD{$msg->{msgtype}}) { 2541 if (my $cb = $EXTICMD{$msg->{msgtype}}) {
2490 if (my %reply = $cb->($ns, $msg)) { 2542 if (my %reply = $cb->($ns, $msg)) {
2491 $reply{msgid} = $msg->{msgid}; 2543 $reply{msgid} = $msg->{msgid};
2492 $ns->send ("ext " . cf::to_json \%reply); 2544 $ns->send ("ext " . $ns->{json_coder}->encode (\%reply));
2493 } 2545 }
2494 } 2546 }
2495 } else { 2547 } else {
2496 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 2548 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2497 } 2549 }
… …
2554 2606
2555=pod 2607=pod
2556 2608
2557The following functions and methods are available within a safe environment: 2609The following functions and methods are available within a safe environment:
2558 2610
2559 cf::object contr pay_amount pay_player map 2611 cf::object
2612 contr pay_amount pay_player map x y force_find force_add
2613 insert remove
2614
2560 cf::object::player player 2615 cf::object::player
2561 cf::player peaceful 2616 player
2562 cf::map trigger 2617
2618 cf::player
2619 peaceful
2620
2621 cf::map
2622 trigger
2563 2623
2564=cut 2624=cut
2565 2625
2566for ( 2626for (
2567 ["cf::object" => qw(contr pay_amount pay_player map)], 2627 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2628 insert remove)],
2568 ["cf::object::player" => qw(player)], 2629 ["cf::object::player" => qw(player)],
2569 ["cf::player" => qw(peaceful)], 2630 ["cf::player" => qw(peaceful)],
2570 ["cf::map" => qw(trigger)], 2631 ["cf::map" => qw(trigger)],
2571) { 2632) {
2572 no strict 'refs'; 2633 no strict 'refs';
… …
2664 { 2725 {
2665 my $faces = $facedata->{faceinfo}; 2726 my $faces = $facedata->{faceinfo};
2666 2727
2667 while (my ($face, $info) = each %$faces) { 2728 while (my ($face, $info) = each %$faces) {
2668 my $idx = (cf::face::find $face) || cf::face::alloc $face; 2729 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2669 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 2730 cf::face::set_visibility $idx, $info->{visibility};
2731 cf::face::set_magicmap $idx, $info->{magicmap};
2670 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 2732 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2671 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 2733 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2672 Coro::cede; 2734
2735 cf::cede_to_tick;
2673 } 2736 }
2674 2737
2675 while (my ($face, $info) = each %$faces) { 2738 while (my ($face, $info) = each %$faces) {
2676 next unless $info->{smooth}; 2739 next unless $info->{smooth};
2677 my $idx = cf::face::find $face 2740 my $idx = cf::face::find $face
2678 or next; 2741 or next;
2679 if (my $smooth = cf::face::find $info->{smooth}) { 2742 if (my $smooth = cf::face::find $info->{smooth}) {
2743 cf::face::set_smooth $idx, $smooth;
2680 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel}; 2744 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2681 } else { 2745 } else {
2682 warn "smooth face '$info->{smooth}' not found for face '$face'"; 2746 warn "smooth face '$info->{smooth}' not found for face '$face'";
2683 } 2747 }
2684 Coro::cede; 2748
2749 cf::cede_to_tick;
2685 } 2750 }
2686 } 2751 }
2687 2752
2688 { 2753 {
2689 my $anims = $facedata->{animinfo}; 2754 my $anims = $facedata->{animinfo};
2690 2755
2691 while (my ($anim, $info) = each %$anims) { 2756 while (my ($anim, $info) = each %$anims) {
2692 cf::anim::set $anim, $info->{frames}, $info->{facings}; 2757 cf::anim::set $anim, $info->{frames}, $info->{facings};
2693 Coro::cede; 2758 cf::cede_to_tick;
2694 } 2759 }
2695 2760
2696 cf::anim::invalidate_all; # d'oh 2761 cf::anim::invalidate_all; # d'oh
2762 }
2763
2764 {
2765 # TODO: for gcfclient pleasure, we should give resources
2766 # that gcfclient doesn't grok a >10000 face index.
2767 my $res = $facedata->{resource};
2768 my $enc = JSON::XS->new->utf8->canonical;
2769
2770 while (my ($name, $info) = each %$res) {
2771 my $meta = $enc->encode ({
2772 name => $name,
2773 type => $info->{type},
2774 copyright => $info->{copyright}, #TODO#
2775 });
2776
2777 my $idx = (cf::face::find $name) || cf::face::alloc $name;
2778
2779 if ($name =~ /\.jpg$/) {
2780 cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};#d# temp hack
2781 cf::face::set_data $idx, 1, $info->{data}, $info->{chksum};#d# temp hack
2782 } else {
2783 my $data = pack "(w/a*)*", $meta, $info->{data};
2784 my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
2785
2786 cf::face::set_type $idx, 1;
2787 cf::face::set_data $idx, 0, $data, $chk;
2788 }
2789
2790 cf::cede_to_tick;
2791 }
2697 } 2792 }
2698 2793
2699 1 2794 1
2700} 2795}
2701 2796
2702sub reload_regions { 2797sub reload_regions {
2703 load_resource_file "$MAPDIR/regions" 2798 load_resource_file "$MAPDIR/regions"
2704 or die "unable to load regions file\n"; 2799 or die "unable to load regions file\n";
2800
2801 for (cf::region::list) {
2802 $_->{match} = qr/$_->{match}/
2803 if exists $_->{match};
2804 }
2705} 2805}
2706 2806
2707sub reload_facedata { 2807sub reload_facedata {
2708 load_facedata "$DATADIR/facedata" 2808 load_facedata "$DATADIR/facedata"
2709 or die "unable to load facedata\n"; 2809 or die "unable to load facedata\n";

Diff Legend

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