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