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.302 by root, Tue Jul 10 16:23:59 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 }
… …
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.
… …
2340 my $hp = $exit->stats->hp; 2376 my $hp = $exit->stats->hp;
2341 my $sp = $exit->stats->sp; 2377 my $sp = $exit->stats->sp;
2342 2378
2343 $self->enter_link; 2379 $self->enter_link;
2344 2380
2381 # if exit is damned, update players death & WoR home-position
2382 $self->contr->savebed ($slaying, $hp, $sp)
2383 if $exit->flag (FLAG_DAMNED);
2384
2345 (async { 2385 (async {
2346 $self->deactivate_recursive; # just to be sure 2386 $self->deactivate_recursive; # just to be sure
2347 unless (eval { 2387 unless (eval {
2348 $self->goto ($slaying, $hp, $sp); 2388 $self->goto ($slaying, $hp, $sp);
2349 2389
… …
2390sub cf::client::send_msg { 2430sub cf::client::send_msg {
2391 my ($self, $color, $type, $msg, @extra) = @_; 2431 my ($self, $color, $type, $msg, @extra) = @_;
2392 2432
2393 $msg = $self->pl->expand_cfpod ($msg); 2433 $msg = $self->pl->expand_cfpod ($msg);
2394 2434
2435 return unless @extra || length $msg;
2436
2395 if ($self->can_msg) { 2437 if ($self->can_msg) {
2396 $self->send_packet ("msg " . cf::to_json [$color, $type, $msg, @extra]); 2438 $self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $type, $msg, @extra]));
2397 } else { 2439 } else {
2398 # replace some tags by gcfclient-compatible ones 2440 # replace some tags by gcfclient-compatible ones
2399 for ($msg) { 2441 for ($msg) {
2400 1 while 2442 1 while
2401 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/ 2443 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
… …
2424 2466
2425sub cf::client::ext_event($$%) { 2467sub cf::client::ext_event($$%) {
2426 my ($self, $type, %msg) = @_; 2468 my ($self, $type, %msg) = @_;
2427 2469
2428 $msg{msgtype} = "event_$type"; 2470 $msg{msgtype} = "event_$type";
2429 $self->send_packet ("ext " . cf::to_json \%msg); 2471 $self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));
2430} 2472}
2431 2473
2432=item $success = $client->query ($flags, "text", \&cb) 2474=item $success = $client->query ($flags, "text", \&cb)
2433 2475
2434Queues a query to the client, calling the given callback with 2476Queues a query to the client, calling the given callback with
… …
2457 2499
2458 1 2500 1
2459} 2501}
2460 2502
2461cf::client->attach ( 2503cf::client->attach (
2504 on_connect => sub {
2505 my ($ns) = @_;
2506
2507 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2508 },
2462 on_reply => sub { 2509 on_reply => sub {
2463 my ($ns, $msg) = @_; 2510 my ($ns, $msg) = @_;
2464 2511
2465 # this weird shuffling is so that direct followup queries 2512 # this weird shuffling is so that direct followup queries
2466 # get handled first 2513 # get handled first
… …
2481 } 2528 }
2482 }, 2529 },
2483 on_exticmd => sub { 2530 on_exticmd => sub {
2484 my ($ns, $buf) = @_; 2531 my ($ns, $buf) = @_;
2485 2532
2486 my $msg = eval { from_json $buf }; 2533 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2487 2534
2488 if (ref $msg) { 2535 if (ref $msg) {
2489 if (my $cb = $EXTICMD{$msg->{msgtype}}) { 2536 if (my $cb = $EXTICMD{$msg->{msgtype}}) {
2490 if (my %reply = $cb->($ns, $msg)) { 2537 if (my %reply = $cb->($ns, $msg)) {
2491 $reply{msgid} = $msg->{msgid}; 2538 $reply{msgid} = $msg->{msgid};
2492 $ns->send ("ext " . cf::to_json \%reply); 2539 $ns->send ("ext " . $ns->{json_coder}->encode (\%reply));
2493 } 2540 }
2494 } 2541 }
2495 } else { 2542 } else {
2496 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 2543 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2497 } 2544 }
… …
2554 2601
2555=pod 2602=pod
2556 2603
2557The following functions and methods are available within a safe environment: 2604The following functions and methods are available within a safe environment:
2558 2605
2559 cf::object contr pay_amount pay_player map 2606 cf::object
2607 contr pay_amount pay_player map x y force_find force_add
2608 insert remove
2609
2560 cf::object::player player 2610 cf::object::player
2561 cf::player peaceful 2611 player
2562 cf::map trigger 2612
2613 cf::player
2614 peaceful
2615
2616 cf::map
2617 trigger
2563 2618
2564=cut 2619=cut
2565 2620
2566for ( 2621for (
2567 ["cf::object" => qw(contr pay_amount pay_player map)], 2622 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2623 insert remove)],
2568 ["cf::object::player" => qw(player)], 2624 ["cf::object::player" => qw(player)],
2569 ["cf::player" => qw(peaceful)], 2625 ["cf::player" => qw(peaceful)],
2570 ["cf::map" => qw(trigger)], 2626 ["cf::map" => qw(trigger)],
2571) { 2627) {
2572 no strict 'refs'; 2628 no strict 'refs';
… …
2664 { 2720 {
2665 my $faces = $facedata->{faceinfo}; 2721 my $faces = $facedata->{faceinfo};
2666 2722
2667 while (my ($face, $info) = each %$faces) { 2723 while (my ($face, $info) = each %$faces) {
2668 my $idx = (cf::face::find $face) || cf::face::alloc $face; 2724 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2669 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 2725 cf::face::set_visibility $idx, $info->{visibility};
2726 cf::face::set_magicmap $idx, $info->{magicmap};
2670 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 2727 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2671 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 2728 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2672 Coro::cede; 2729
2730 cf::cede_to_tick;
2673 } 2731 }
2674 2732
2675 while (my ($face, $info) = each %$faces) { 2733 while (my ($face, $info) = each %$faces) {
2676 next unless $info->{smooth}; 2734 next unless $info->{smooth};
2677 my $idx = cf::face::find $face 2735 my $idx = cf::face::find $face
2678 or next; 2736 or next;
2679 if (my $smooth = cf::face::find $info->{smooth}) { 2737 if (my $smooth = cf::face::find $info->{smooth}) {
2738 cf::face::set_smooth $idx, $smooth;
2680 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel}; 2739 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2681 } else { 2740 } else {
2682 warn "smooth face '$info->{smooth}' not found for face '$face'"; 2741 warn "smooth face '$info->{smooth}' not found for face '$face'";
2683 } 2742 }
2684 Coro::cede; 2743
2744 cf::cede_to_tick;
2685 } 2745 }
2686 } 2746 }
2687 2747
2688 { 2748 {
2689 my $anims = $facedata->{animinfo}; 2749 my $anims = $facedata->{animinfo};
2690 2750
2691 while (my ($anim, $info) = each %$anims) { 2751 while (my ($anim, $info) = each %$anims) {
2692 cf::anim::set $anim, $info->{frames}, $info->{facings}; 2752 cf::anim::set $anim, $info->{frames}, $info->{facings};
2693 Coro::cede; 2753 cf::cede_to_tick;
2694 } 2754 }
2695 2755
2696 cf::anim::invalidate_all; # d'oh 2756 cf::anim::invalidate_all; # d'oh
2757 }
2758
2759 {
2760 # TODO: for gcfclient pleasure, we should give resources
2761 # that gcfclient doesn't grok a >10000 face index.
2762 my $res = $facedata->{resource};
2763 my $enc = JSON::XS->new->utf8->canonical;
2764
2765 while (my ($name, $info) = each %$res) {
2766 my $meta = $enc->encode ({
2767 name => $name,
2768 type => $info->{type},
2769 copyright => $info->{copyright},
2770 });
2771 my $data = pack "(w/a*)*", $meta, $info->{data};
2772 my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
2773
2774 use Data::Dumper; warn Dumper substr $data, 0, 100;#d#
2775
2776 my $idx = (cf::face::find $name) || cf::face::alloc $name;
2777 cf::face::set_type $idx, 1;
2778 cf::face::set_data $idx, 0, $data, $chk;
2779
2780 # TODO
2781 cf::cede_to_tick;
2782 }
2697 } 2783 }
2698 2784
2699 1 2785 1
2700} 2786}
2701 2787

Diff Legend

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