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.299 by root, Sun Jul 8 14:56:05 2007 UTC vs.
Revision 1.313 by root, Sun Jul 22 14:17:58 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
… …
165=item cf::wait_for_tick, cf::wait_for_tick_begin 166=item cf::wait_for_tick, cf::wait_for_tick_begin
166 167
167These 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
168returns 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
169per 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.
170 177
171=back 178=back
172 179
173=cut 180=cut
174 181
… …
865 "; 872 ";
866 die if $@; 873 die if $@;
867} 874}
868 875
869our $override; 876our $override;
870our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 877our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
871 878
872sub override { 879sub override {
873 $override = 1; 880 $override = 1;
874 @invoke_results = (); 881 @INVOKE_RESULTS = (@_);
875} 882}
876 883
877sub do_invoke { 884sub do_invoke {
878 my $event = shift; 885 my $event = shift;
879 my $callbacks = shift; 886 my $callbacks = shift;
880 887
881 @invoke_results = (); 888 @INVOKE_RESULTS = ();
882 889
883 local $override; 890 local $override;
884 891
885 for (@$callbacks) { 892 for (@$callbacks) {
886 eval { &{$_->[1]} }; 893 eval { &{$_->[1]} };
… …
903 910
904Generate an object-specific event with the given arguments. 911Generate an object-specific event with the given arguments.
905 912
906This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be 913This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
907removed in future versions), and there is no public API to access override 914removed in future versions), and there is no public API to access override
908results (if you must, access C<@cf::invoke_results> directly). 915results (if you must, access C<@cf::INVOKE_RESULTS> directly).
909 916
910=back 917=back
911 918
912=cut 919=cut
913 920
914############################################################################# 921#############################################################################
915# object support 922# object support
923#
924
925sub _can_merge {
926 my ($ob1, $ob2) = @_;
927
928 local $Storable::canonical = 1;
929 my $fob1 = Storable::freeze $ob1;
930 my $fob2 = Storable::freeze $ob2;
931
932 $fob1 eq $fob2
933}
916 934
917sub reattach { 935sub reattach {
918 # basically do the same as instantiate, without calling instantiate 936 # basically do the same as instantiate, without calling instantiate
919 my ($obj) = @_; 937 my ($obj) = @_;
920 938
… …
1488 my ($path) = @_; 1506 my ($path) = @_;
1489 1507
1490 my ($match, $specificity); 1508 my ($match, $specificity);
1491 1509
1492 for my $region (list) { 1510 for my $region (list) {
1493 if ($region->match && $path =~ $region->match) { 1511 if ($region->{match} && $path =~ $region->{match}) {
1494 ($match, $specificity) = ($region, $region->specificity) 1512 ($match, $specificity) = ($region, $region->specificity)
1495 if $region->specificity > $specificity; 1513 if $region->specificity > $specificity;
1496 } 1514 }
1497 } 1515 }
1498 1516
… …
1618 $self->init; # pass $1 etc. 1636 $self->init; # pass $1 etc.
1619 return $self; 1637 return $self;
1620 } 1638 }
1621 } 1639 }
1622 1640
1623 Carp::carp "unable to resolve path '$path' (base '$base')."; 1641 Carp::cluck "unable to resolve path '$path' (base '$base').";
1624 () 1642 ()
1625} 1643}
1626 1644
1627sub init { 1645sub init {
1628 my ($self) = @_; 1646 my ($self) = @_;
… …
1906 1924
1907 undef $MAP_PREFETCH{$path}; 1925 undef $MAP_PREFETCH{$path};
1908 $MAP_PREFETCHER ||= cf::async { 1926 $MAP_PREFETCHER ||= cf::async {
1909 while (%MAP_PREFETCH) { 1927 while (%MAP_PREFETCH) {
1910 for my $path (keys %MAP_PREFETCH) { 1928 for my $path (keys %MAP_PREFETCH) {
1911 my $map = find $path 1929 if (my $map = find $path) {
1912 or next;
1913 $map->load; 1930 $map->load;
1931 }
1914 1932
1915 delete $MAP_PREFETCH{$path}; 1933 delete $MAP_PREFETCH{$path};
1916 } 1934 }
1917 } 1935 }
1918 undef $MAP_PREFETCHER; 1936 undef $MAP_PREFETCHER;
… …
2255 2273
2256 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2274 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2257 $self->enter_map ($map, $x, $y); 2275 $self->enter_map ($map, $x, $y);
2258} 2276}
2259 2277
2260=item $player_object->goto ($path, $x, $y[, $check->($map)]) 2278=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2261 2279
2262Moves the player to the given map-path and coordinates by first freezing 2280Moves the player to the given map-path and coordinates by first freezing
2263her, loading and preparing them map, calling the provided $check callback 2281her, loading and preparing them map, calling the provided $check callback
2264that has to return the map if sucecssful, and then unfreezes the player on 2282that has to return the map if sucecssful, and then unfreezes the player on
2265the new (success) or old (failed) map position. 2283the new (success) or old (failed) map position. In either case, $done will
2284be called at the end of this process.
2266 2285
2267=cut 2286=cut
2268 2287
2269our $GOTOGEN; 2288our $GOTOGEN;
2270 2289
2271sub cf::object::player::goto { 2290sub cf::object::player::goto {
2272 my ($self, $path, $x, $y, $check) = @_; 2291 my ($self, $path, $x, $y, $check, $done) = @_;
2273 2292
2274 # do generation counting so two concurrent goto's will be executed in-order 2293 # do generation counting so two concurrent goto's will be executed in-order
2275 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2294 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2276 2295
2277 $self->enter_link; 2296 $self->enter_link;
… …
2297 2316
2298 if ($gen == $self->{_goto_generation}) { 2317 if ($gen == $self->{_goto_generation}) {
2299 delete $self->{_goto_generation}; 2318 delete $self->{_goto_generation};
2300 $self->leave_link ($map, $x, $y); 2319 $self->leave_link ($map, $x, $y);
2301 } 2320 }
2321
2322 $done->() if $done;
2302 })->prio (1); 2323 })->prio (1);
2303} 2324}
2304 2325
2305=item $player_object->enter_exit ($exit_object) 2326=item $player_object->enter_exit ($exit_object)
2306 2327
… …
2415 2436
2416 utf8::encode $text; 2437 utf8::encode $text;
2417 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2438 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2418} 2439}
2419 2440
2420=item $client->send_msg ($color, $type, $msg, [extra...]) 2441=item $client->send_msg ($channel, $msg, $color, [extra...])
2421 2442
2422Send a drawinfo or msg packet to the client, formatting the msg for the 2443Send a drawinfo or msg packet to the client, formatting the msg for the
2423client if neccessary. C<$type> should be a string identifying the type of 2444client if neccessary. C<$type> should be a string identifying the type of
2424the message, with C<log> being the default. If C<$color> is negative, suppress 2445the message, with C<log> being the default. If C<$color> is negative, suppress
2425the message unless the client supports the msg packet. 2446the message unless the client supports the msg packet.
2426 2447
2427=cut 2448=cut
2428 2449
2429sub cf::client::send_msg { 2450sub cf::client::send_msg {
2430 my ($self, $color, $type, $msg, @extra) = @_; 2451 my ($self, $channel, $msg, $color, @extra) = @_;
2431 2452
2432 $msg = $self->pl->expand_cfpod ($msg); 2453 $msg = $self->pl->expand_cfpod ($msg);
2433 2454
2455 $color &= ~cf::NDI_UNIQUE; # just in case...
2456
2457 if (ref $channel) {
2458 # send meta info to client, if not yet sent
2459 unless (exists $self->{channel}{$channel->{id}}) {
2460 $self->{channel}{$channel->{id}} = $channel;
2461 $self->ext_event (channel_info => %$channel);
2462 }
2463
2464 $channel = $channel->{id};
2465 }
2466
2434 return unless @extra || length $msg; 2467 return unless @extra || length $msg;
2435 2468
2436 if ($self->can_msg) { 2469 if ($self->can_msg) {
2437 $self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $type, $msg, @extra])); 2470 $self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $channel, $msg, @extra]));
2438 } else { 2471 } else {
2439 # replace some tags by gcfclient-compatible ones 2472 # replace some tags by gcfclient-compatible ones
2440 for ($msg) { 2473 for ($msg) {
2441 1 while 2474 1 while
2442 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/ 2475 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
… …
2463 2496
2464=cut 2497=cut
2465 2498
2466sub cf::client::ext_event($$%) { 2499sub cf::client::ext_event($$%) {
2467 my ($self, $type, %msg) = @_; 2500 my ($self, $type, %msg) = @_;
2501
2502 return unless $self->extcmd;
2468 2503
2469 $msg{msgtype} = "event_$type"; 2504 $msg{msgtype} = "event_$type";
2470 $self->send_packet ("ext " . $self->{json_coder}->encode (\%msg)); 2505 $self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));
2471} 2506}
2472 2507
… …
2719 { 2754 {
2720 my $faces = $facedata->{faceinfo}; 2755 my $faces = $facedata->{faceinfo};
2721 2756
2722 while (my ($face, $info) = each %$faces) { 2757 while (my ($face, $info) = each %$faces) {
2723 my $idx = (cf::face::find $face) || cf::face::alloc $face; 2758 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2724 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 2759 cf::face::set_visibility $idx, $info->{visibility};
2760 cf::face::set_magicmap $idx, $info->{magicmap};
2725 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 2761 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2726 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 2762 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2727 Coro::cede; 2763
2764 cf::cede_to_tick;
2728 } 2765 }
2729 2766
2730 while (my ($face, $info) = each %$faces) { 2767 while (my ($face, $info) = each %$faces) {
2731 next unless $info->{smooth}; 2768 next unless $info->{smooth};
2732 my $idx = cf::face::find $face 2769 my $idx = cf::face::find $face
2733 or next; 2770 or next;
2734 if (my $smooth = cf::face::find $info->{smooth}) { 2771 if (my $smooth = cf::face::find $info->{smooth}) {
2772 cf::face::set_smooth $idx, $smooth;
2735 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel}; 2773 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2736 } else { 2774 } else {
2737 warn "smooth face '$info->{smooth}' not found for face '$face'"; 2775 warn "smooth face '$info->{smooth}' not found for face '$face'";
2738 } 2776 }
2739 Coro::cede; 2777
2778 cf::cede_to_tick;
2740 } 2779 }
2741 } 2780 }
2742 2781
2743 { 2782 {
2744 my $anims = $facedata->{animinfo}; 2783 my $anims = $facedata->{animinfo};
2745 2784
2746 while (my ($anim, $info) = each %$anims) { 2785 while (my ($anim, $info) = each %$anims) {
2747 cf::anim::set $anim, $info->{frames}, $info->{facings}; 2786 cf::anim::set $anim, $info->{frames}, $info->{facings};
2748 Coro::cede; 2787 cf::cede_to_tick;
2749 } 2788 }
2750 2789
2751 cf::anim::invalidate_all; # d'oh 2790 cf::anim::invalidate_all; # d'oh
2791 }
2792
2793 {
2794 # TODO: for gcfclient pleasure, we should give resources
2795 # that gcfclient doesn't grok a >10000 face index.
2796 my $res = $facedata->{resource};
2797 my $enc = JSON::XS->new->utf8->canonical;
2798
2799 while (my ($name, $info) = each %$res) {
2800 my $meta = $enc->encode ({
2801 name => $name,
2802 type => $info->{type},
2803 copyright => $info->{copyright}, #TODO#
2804 });
2805
2806 my $idx = (cf::face::find $name) || cf::face::alloc $name;
2807
2808 if ($name =~ /\.jpg$/) {
2809 cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};#d# temp hack
2810 cf::face::set_data $idx, 1, $info->{data}, $info->{chksum};#d# temp hack
2811 } else {
2812 my $data = pack "(w/a*)*", $meta, $info->{data};
2813 my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
2814
2815 cf::face::set_type $idx, 1;
2816 cf::face::set_data $idx, 0, $data, $chk;
2817 }
2818
2819 cf::cede_to_tick;
2820 }
2752 } 2821 }
2753 2822
2754 1 2823 1
2755} 2824}
2756 2825
2757sub reload_regions { 2826sub reload_regions {
2758 load_resource_file "$MAPDIR/regions" 2827 load_resource_file "$MAPDIR/regions"
2759 or die "unable to load regions file\n"; 2828 or die "unable to load regions file\n";
2829
2830 for (cf::region::list) {
2831 $_->{match} = qr/$_->{match}/
2832 if exists $_->{match};
2833 }
2760} 2834}
2761 2835
2762sub reload_facedata { 2836sub reload_facedata {
2763 load_facedata "$DATADIR/facedata" 2837 load_facedata "$DATADIR/facedata"
2764 or die "unable to load facedata\n"; 2838 or die "unable to load facedata\n";

Diff Legend

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