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.308 by root, Mon Jul 16 14:09:40 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
… …
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 }
… …
1470 my ($path) = @_; 1489 my ($path) = @_;
1471 1490
1472 my ($match, $specificity); 1491 my ($match, $specificity);
1473 1492
1474 for my $region (list) { 1493 for my $region (list) {
1475 if ($region->match && $path =~ $region->match) { 1494 if ($region->{match} && $path =~ $region->{match}) {
1476 ($match, $specificity) = ($region, $region->specificity) 1495 ($match, $specificity) = ($region, $region->specificity)
1477 if $region->specificity > $specificity; 1496 if $region->specificity > $specificity;
1478 } 1497 }
1479 } 1498 }
1480 1499
… …
1600 $self->init; # pass $1 etc. 1619 $self->init; # pass $1 etc.
1601 return $self; 1620 return $self;
1602 } 1621 }
1603 } 1622 }
1604 1623
1605 Carp::carp "unable to resolve path '$path' (base '$base')."; 1624 Carp::cluck "unable to resolve path '$path' (base '$base').";
1606 () 1625 ()
1607} 1626}
1608 1627
1609sub init { 1628sub init {
1610 my ($self) = @_; 1629 my ($self) = @_;
… …
1888 1907
1889 undef $MAP_PREFETCH{$path}; 1908 undef $MAP_PREFETCH{$path};
1890 $MAP_PREFETCHER ||= cf::async { 1909 $MAP_PREFETCHER ||= cf::async {
1891 while (%MAP_PREFETCH) { 1910 while (%MAP_PREFETCH) {
1892 for my $path (keys %MAP_PREFETCH) { 1911 for my $path (keys %MAP_PREFETCH) {
1893 my $map = find $path 1912 if (my $map = find $path) {
1894 or next;
1895 $map->load; 1913 $map->load;
1914 }
1896 1915
1897 delete $MAP_PREFETCH{$path}; 1916 delete $MAP_PREFETCH{$path};
1898 } 1917 }
1899 } 1918 }
1900 undef $MAP_PREFETCHER; 1919 undef $MAP_PREFETCHER;
… …
2237 2256
2238 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2257 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2239 $self->enter_map ($map, $x, $y); 2258 $self->enter_map ($map, $x, $y);
2240} 2259}
2241 2260
2242=item $player_object->goto ($path, $x, $y[, $check->($map)]) 2261=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2243 2262
2244Moves 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
2245her, loading and preparing them map, calling the provided $check callback 2264her, loading and preparing them map, calling the provided $check callback
2246that 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
2247the 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.
2248 2268
2249=cut 2269=cut
2250 2270
2251our $GOTOGEN; 2271our $GOTOGEN;
2252 2272
2253sub cf::object::player::goto { 2273sub cf::object::player::goto {
2254 my ($self, $path, $x, $y, $check) = @_; 2274 my ($self, $path, $x, $y, $check, $done) = @_;
2255 2275
2256 # 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
2257 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2277 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2258 2278
2259 $self->enter_link; 2279 $self->enter_link;
… …
2279 2299
2280 if ($gen == $self->{_goto_generation}) { 2300 if ($gen == $self->{_goto_generation}) {
2281 delete $self->{_goto_generation}; 2301 delete $self->{_goto_generation};
2282 $self->leave_link ($map, $x, $y); 2302 $self->leave_link ($map, $x, $y);
2283 } 2303 }
2304
2305 $done->() if $done;
2284 })->prio (1); 2306 })->prio (1);
2285} 2307}
2286 2308
2287=item $player_object->enter_exit ($exit_object) 2309=item $player_object->enter_exit ($exit_object)
2288 2310
… …
2446=cut 2468=cut
2447 2469
2448sub cf::client::ext_event($$%) { 2470sub cf::client::ext_event($$%) {
2449 my ($self, $type, %msg) = @_; 2471 my ($self, $type, %msg) = @_;
2450 2472
2473 return unless $self->extcmd;
2474
2451 $msg{msgtype} = "event_$type"; 2475 $msg{msgtype} = "event_$type";
2452 $self->send_packet ("ext " . $self->{json_coder}->encode (\%msg)); 2476 $self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));
2453} 2477}
2454 2478
2455=item $success = $client->query ($flags, "text", \&cb) 2479=item $success = $client->query ($flags, "text", \&cb)
… …
2582 2606
2583=pod 2607=pod
2584 2608
2585The following functions and methods are available within a safe environment: 2609The following functions and methods are available within a safe environment:
2586 2610
2587 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
2588 cf::object::player player 2615 cf::object::player
2589 cf::player peaceful 2616 player
2590 cf::map trigger 2617
2618 cf::player
2619 peaceful
2620
2621 cf::map
2622 trigger
2591 2623
2592=cut 2624=cut
2593 2625
2594for ( 2626for (
2595 ["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)],
2596 ["cf::object::player" => qw(player)], 2629 ["cf::object::player" => qw(player)],
2597 ["cf::player" => qw(peaceful)], 2630 ["cf::player" => qw(peaceful)],
2598 ["cf::map" => qw(trigger)], 2631 ["cf::map" => qw(trigger)],
2599) { 2632) {
2600 no strict 'refs'; 2633 no strict 'refs';
… …
2692 { 2725 {
2693 my $faces = $facedata->{faceinfo}; 2726 my $faces = $facedata->{faceinfo};
2694 2727
2695 while (my ($face, $info) = each %$faces) { 2728 while (my ($face, $info) = each %$faces) {
2696 my $idx = (cf::face::find $face) || cf::face::alloc $face; 2729 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2697 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 2730 cf::face::set_visibility $idx, $info->{visibility};
2731 cf::face::set_magicmap $idx, $info->{magicmap};
2698 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 2732 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2699 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 2733 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2700 Coro::cede; 2734
2735 cf::cede_to_tick;
2701 } 2736 }
2702 2737
2703 while (my ($face, $info) = each %$faces) { 2738 while (my ($face, $info) = each %$faces) {
2704 next unless $info->{smooth}; 2739 next unless $info->{smooth};
2705 my $idx = cf::face::find $face 2740 my $idx = cf::face::find $face
2706 or next; 2741 or next;
2707 if (my $smooth = cf::face::find $info->{smooth}) { 2742 if (my $smooth = cf::face::find $info->{smooth}) {
2743 cf::face::set_smooth $idx, $smooth;
2708 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel}; 2744 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2709 } else { 2745 } else {
2710 warn "smooth face '$info->{smooth}' not found for face '$face'"; 2746 warn "smooth face '$info->{smooth}' not found for face '$face'";
2711 } 2747 }
2712 Coro::cede; 2748
2749 cf::cede_to_tick;
2713 } 2750 }
2714 } 2751 }
2715 2752
2716 { 2753 {
2717 my $anims = $facedata->{animinfo}; 2754 my $anims = $facedata->{animinfo};
2718 2755
2719 while (my ($anim, $info) = each %$anims) { 2756 while (my ($anim, $info) = each %$anims) {
2720 cf::anim::set $anim, $info->{frames}, $info->{facings}; 2757 cf::anim::set $anim, $info->{frames}, $info->{facings};
2721 Coro::cede; 2758 cf::cede_to_tick;
2722 } 2759 }
2723 2760
2724 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 }
2725 } 2792 }
2726 2793
2727 1 2794 1
2728} 2795}
2729 2796
2730sub reload_regions { 2797sub reload_regions {
2731 load_resource_file "$MAPDIR/regions" 2798 load_resource_file "$MAPDIR/regions"
2732 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 }
2733} 2805}
2734 2806
2735sub reload_facedata { 2807sub reload_facedata {
2736 load_facedata "$DATADIR/facedata" 2808 load_facedata "$DATADIR/facedata"
2737 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