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.292 by root, Tue Jul 3 00:54:57 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 }
… …
1412 1431
1413 # create single paragraphs (very hackish) 1432 # create single paragraphs (very hackish)
1414 s/(?<=\S)\n(?=\w)/ /g; 1433 s/(?<=\S)\n(?=\w)/ /g;
1415 1434
1416 # compress some whitespace 1435 # compress some whitespace
1417 1 while s/\s*\n\s*\n\s*/\n/; 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
1418 1440
1419 $_ 1441 $_
1420} 1442}
1421 1443
1422sub hintmode { 1444sub hintmode {
… …
1467 my ($path) = @_; 1489 my ($path) = @_;
1468 1490
1469 my ($match, $specificity); 1491 my ($match, $specificity);
1470 1492
1471 for my $region (list) { 1493 for my $region (list) {
1472 if ($region->match && $path =~ $region->match) { 1494 if ($region->{match} && $path =~ $region->{match}) {
1473 ($match, $specificity) = ($region, $region->specificity) 1495 ($match, $specificity) = ($region, $region->specificity)
1474 if $region->specificity > $specificity; 1496 if $region->specificity > $specificity;
1475 } 1497 }
1476 } 1498 }
1477 1499
… …
1597 $self->init; # pass $1 etc. 1619 $self->init; # pass $1 etc.
1598 return $self; 1620 return $self;
1599 } 1621 }
1600 } 1622 }
1601 1623
1602 Carp::carp "unable to resolve path '$path' (base '$base')."; 1624 Carp::cluck "unable to resolve path '$path' (base '$base').";
1603 () 1625 ()
1604} 1626}
1605 1627
1606sub init { 1628sub init {
1607 my ($self) = @_; 1629 my ($self) = @_;
… …
1885 1907
1886 undef $MAP_PREFETCH{$path}; 1908 undef $MAP_PREFETCH{$path};
1887 $MAP_PREFETCHER ||= cf::async { 1909 $MAP_PREFETCHER ||= cf::async {
1888 while (%MAP_PREFETCH) { 1910 while (%MAP_PREFETCH) {
1889 for my $path (keys %MAP_PREFETCH) { 1911 for my $path (keys %MAP_PREFETCH) {
1890 my $map = find $path 1912 if (my $map = find $path) {
1891 or next;
1892 $map->load; 1913 $map->load;
1914 }
1893 1915
1894 delete $MAP_PREFETCH{$path}; 1916 delete $MAP_PREFETCH{$path};
1895 } 1917 }
1896 } 1918 }
1897 undef $MAP_PREFETCHER; 1919 undef $MAP_PREFETCHER;
… …
2234 2256
2235 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2257 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2236 $self->enter_map ($map, $x, $y); 2258 $self->enter_map ($map, $x, $y);
2237} 2259}
2238 2260
2239=item $player_object->goto ($path, $x, $y[, $check->($map)]) 2261=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2240 2262
2241Moves 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
2242her, loading and preparing them map, calling the provided $check callback 2264her, loading and preparing them map, calling the provided $check callback
2243that 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
2244the 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.
2245 2268
2246=cut 2269=cut
2247 2270
2248our $GOTOGEN; 2271our $GOTOGEN;
2249 2272
2250sub cf::object::player::goto { 2273sub cf::object::player::goto {
2251 my ($self, $path, $x, $y, $check) = @_; 2274 my ($self, $path, $x, $y, $check, $done) = @_;
2252 2275
2253 # 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
2254 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2277 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2255 2278
2256 $self->enter_link; 2279 $self->enter_link;
… …
2276 2299
2277 if ($gen == $self->{_goto_generation}) { 2300 if ($gen == $self->{_goto_generation}) {
2278 delete $self->{_goto_generation}; 2301 delete $self->{_goto_generation};
2279 $self->leave_link ($map, $x, $y); 2302 $self->leave_link ($map, $x, $y);
2280 } 2303 }
2304
2305 $done->() if $done;
2281 })->prio (1); 2306 })->prio (1);
2282} 2307}
2283 2308
2284=item $player_object->enter_exit ($exit_object) 2309=item $player_object->enter_exit ($exit_object)
2285 2310
… …
2354 my $hp = $exit->stats->hp; 2379 my $hp = $exit->stats->hp;
2355 my $sp = $exit->stats->sp; 2380 my $sp = $exit->stats->sp;
2356 2381
2357 $self->enter_link; 2382 $self->enter_link;
2358 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
2359 (async { 2388 (async {
2360 $self->deactivate_recursive; # just to be sure 2389 $self->deactivate_recursive; # just to be sure
2361 unless (eval { 2390 unless (eval {
2362 $self->goto ($slaying, $hp, $sp); 2391 $self->goto ($slaying, $hp, $sp);
2363 2392
… …
2403 2432
2404sub cf::client::send_msg { 2433sub cf::client::send_msg {
2405 my ($self, $color, $type, $msg, @extra) = @_; 2434 my ($self, $color, $type, $msg, @extra) = @_;
2406 2435
2407 $msg = $self->pl->expand_cfpod ($msg); 2436 $msg = $self->pl->expand_cfpod ($msg);
2437
2438 return unless @extra || length $msg;
2408 2439
2409 if ($self->can_msg) { 2440 if ($self->can_msg) {
2410 $self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $type, $msg, @extra])); 2441 $self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $type, $msg, @extra]));
2411 } else { 2442 } else {
2412 # replace some tags by gcfclient-compatible ones 2443 # replace some tags by gcfclient-compatible ones
… …
2437=cut 2468=cut
2438 2469
2439sub cf::client::ext_event($$%) { 2470sub cf::client::ext_event($$%) {
2440 my ($self, $type, %msg) = @_; 2471 my ($self, $type, %msg) = @_;
2441 2472
2473 return unless $self->extcmd;
2474
2442 $msg{msgtype} = "event_$type"; 2475 $msg{msgtype} = "event_$type";
2443 $self->send_packet ("ext " . $self->{json_coder}->encode (\%msg)); 2476 $self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));
2444} 2477}
2445 2478
2446=item $success = $client->query ($flags, "text", \&cb) 2479=item $success = $client->query ($flags, "text", \&cb)
… …
2573 2606
2574=pod 2607=pod
2575 2608
2576The following functions and methods are available within a safe environment: 2609The following functions and methods are available within a safe environment:
2577 2610
2578 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
2579 cf::object::player player 2615 cf::object::player
2580 cf::player peaceful 2616 player
2581 cf::map trigger 2617
2618 cf::player
2619 peaceful
2620
2621 cf::map
2622 trigger
2582 2623
2583=cut 2624=cut
2584 2625
2585for ( 2626for (
2586 ["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)],
2587 ["cf::object::player" => qw(player)], 2629 ["cf::object::player" => qw(player)],
2588 ["cf::player" => qw(peaceful)], 2630 ["cf::player" => qw(peaceful)],
2589 ["cf::map" => qw(trigger)], 2631 ["cf::map" => qw(trigger)],
2590) { 2632) {
2591 no strict 'refs'; 2633 no strict 'refs';
… …
2683 { 2725 {
2684 my $faces = $facedata->{faceinfo}; 2726 my $faces = $facedata->{faceinfo};
2685 2727
2686 while (my ($face, $info) = each %$faces) { 2728 while (my ($face, $info) = each %$faces) {
2687 my $idx = (cf::face::find $face) || cf::face::alloc $face; 2729 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2688 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 2730 cf::face::set_visibility $idx, $info->{visibility};
2731 cf::face::set_magicmap $idx, $info->{magicmap};
2689 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 2732 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2690 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 2733 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2691 Coro::cede; 2734
2735 cf::cede_to_tick;
2692 } 2736 }
2693 2737
2694 while (my ($face, $info) = each %$faces) { 2738 while (my ($face, $info) = each %$faces) {
2695 next unless $info->{smooth}; 2739 next unless $info->{smooth};
2696 my $idx = cf::face::find $face 2740 my $idx = cf::face::find $face
2697 or next; 2741 or next;
2698 if (my $smooth = cf::face::find $info->{smooth}) { 2742 if (my $smooth = cf::face::find $info->{smooth}) {
2743 cf::face::set_smooth $idx, $smooth;
2699 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel}; 2744 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2700 } else { 2745 } else {
2701 warn "smooth face '$info->{smooth}' not found for face '$face'"; 2746 warn "smooth face '$info->{smooth}' not found for face '$face'";
2702 } 2747 }
2703 Coro::cede; 2748
2749 cf::cede_to_tick;
2704 } 2750 }
2705 } 2751 }
2706 2752
2707 { 2753 {
2708 my $anims = $facedata->{animinfo}; 2754 my $anims = $facedata->{animinfo};
2709 2755
2710 while (my ($anim, $info) = each %$anims) { 2756 while (my ($anim, $info) = each %$anims) {
2711 cf::anim::set $anim, $info->{frames}, $info->{facings}; 2757 cf::anim::set $anim, $info->{frames}, $info->{facings};
2712 Coro::cede; 2758 cf::cede_to_tick;
2713 } 2759 }
2714 2760
2715 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 }
2716 } 2792 }
2717 2793
2718 1 2794 1
2719} 2795}
2720 2796
2721sub reload_regions { 2797sub reload_regions {
2722 load_resource_file "$MAPDIR/regions" 2798 load_resource_file "$MAPDIR/regions"
2723 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 }
2724} 2805}
2725 2806
2726sub reload_facedata { 2807sub reload_facedata {
2727 load_facedata "$DATADIR/facedata" 2808 load_facedata "$DATADIR/facedata"
2728 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