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.287 by root, Mon Jun 25 05:43:45 2007 UTC vs.
Revision 1.303 by root, Wed Jul 11 15:57:31 2007 UTC

… …
20use Coro::Signal; 20use Coro::Signal;
21use Coro::Semaphore; 21use Coro::Semaphore;
22use Coro::AIO; 22use Coro::AIO;
23use Coro::Storable; 23use Coro::Storable;
24 24
25use JSON::XS 1.4 ();
25use BDB (); 26use BDB ();
26use Data::Dumper; 27use Data::Dumper;
27use Digest::MD5; 28use Digest::MD5;
28use Fcntl; 29use Fcntl;
29use YAML::Syck (); 30use YAML::Syck ();
30use IO::AIO 2.32 (); 31use IO::AIO 2.32 ();
31use Time::HiRes; 32use Time::HiRes;
32use Compress::LZF; 33use Compress::LZF;
34use Digest::MD5 ();
33 35
34# configure various modules to our taste 36# configure various modules to our taste
35# 37#
36$Storable::canonical = 1; # reduce rsync transfers 38$Storable::canonical = 1; # reduce rsync transfers
37Coro::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
… …
237 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 239 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
238 $d 240 $d
239 } || "[unable to dump $_[0]: '$@']"; 241 } || "[unable to dump $_[0]: '$@']";
240} 242}
241 243
242use JSON::XS ();
243
244=item $ref = cf::from_json $json 244=item $ref = cf::from_json $json
245 245
246Converts a JSON string into the corresponding perl data structure. 246Converts a JSON string into the corresponding perl data structure.
247 247
248=item $json = cf::to_json $ref 248=item $json = cf::to_json $ref
249 249
250Converts a perl data structure into its JSON representation. 250Converts a perl data structure into its JSON representation.
251 251
252=cut 252=cut
253 253
254our $json_coder = JSON::XS->new->convert_blessed->utf8; 254our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
255 255
256sub to_json ($) { $json_coder->encode ($_[0]) } 256sub to_json ($) { $json_coder->encode ($_[0]) }
257sub from_json ($) { $json_coder->decode ($_[0]) } 257sub from_json ($) { $json_coder->decode ($_[0]) }
258 258
259=item cf::lock_wait $string 259=item cf::lock_wait $string
… …
410Coro::Storable. May, of course, block. Note that the executed sub may 410Coro::Storable. May, of course, block. Note that the executed sub may
411never block itself or use any form of Event handling. 411never block itself or use any form of Event handling.
412 412
413=cut 413=cut
414 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
415sub fork_call(&@) { 424sub fork_call(&@) {
416 my ($cb, @args) = @_; 425 my ($cb, @args) = @_;
417 426
418# 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
419# or die "socketpair: $!"; 428# or die "socketpair: $!";
… …
422 431
423 if (my $pid = fork) { 432 if (my $pid = fork) {
424 close $fh2; 433 close $fh2;
425 434
426 my $res = (Coro::Handle::unblock $fh1)->readline (undef); 435 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
436 warn "pst<$res>" unless $res =~ /^pst/;
427 $res = Coro::Storable::thaw $res; 437 $res = Coro::Storable::thaw $res;
428 438
429 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
430 440
431 die $$res unless "ARRAY" eq ref $res; 441 Carp::confess $$res unless "ARRAY" eq ref $res;
432 442
433 return wantarray ? @$res : $res->[-1]; 443 return wantarray ? @$res : $res->[-1];
434 } else { 444 } else {
435 reset_signals; 445 reset_signals;
436 local $SIG{__WARN__}; 446 local $SIG{__WARN__};
437 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
438 eval { 454 eval {
439 close $fh1; 455 close $fh1;
440 456
441 my @res = eval { $cb->(@args) }; 457 my @res = eval { $cb->(@args) };
458
442 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res); 459 syswrite $fh2, _store_scalar $@ ? \"$@" : \@res;
460 close $fh2;
443 }; 461 };
444 462
445 warn $@ if $@; 463 warn $@ if $@;
446 _exit 0; 464 _exit 0;
447 } 465 }
… …
1087 cf::override; 1105 cf::override;
1088 }, 1106 },
1089 on_extcmd => sub { 1107 on_extcmd => sub {
1090 my ($pl, $buf) = @_; 1108 my ($pl, $buf) = @_;
1091 1109
1092 my $msg = eval { from_json $buf }; 1110 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1093 1111
1094 if (ref $msg) { 1112 if (ref $msg) {
1095 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1113 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
1096 if (my %reply = $cb->($pl, $msg)) { 1114 if (my %reply = $cb->($pl, $msg)) {
1097 $pl->ext_reply ($msg->{msgid}, %reply); 1115 $pl->ext_reply ($msg->{msgid}, %reply);
… …
1401 # replace G<male|female> tags 1419 # replace G<male|female> tags
1402 || s{G<([^>|]*)\|([^>]*)>}{ 1420 || s{G<([^>|]*)\|([^>]*)>}{
1403 $self->gender ? $2 : $1 1421 $self->gender ? $2 : $1
1404 }ge 1422 }ge
1405 # replace H<hint text> 1423 # replace H<hint text>
1406 || 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;
1407 1431
1408 # create single paragraphs (very hackish) 1432 # create single paragraphs (very hackish)
1409 s/(?<=\S)\n(?=\w)/ /g; 1433 s/(?<=\S)\n(?=\w)/ /g;
1410 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
1411 $_ 1441 $_
1442}
1443
1444sub hintmode {
1445 $_[0]{hintmode} = $_[1] if @_ > 1;
1446 $_[0]{hintmode}
1412} 1447}
1413 1448
1414=item $player->ext_reply ($msgid, %msg) 1449=item $player->ext_reply ($msgid, %msg)
1415 1450
1416Sends an ext reply to the player. 1451Sends an ext reply to the player.
… …
1419 1454
1420sub ext_reply($$%) { 1455sub ext_reply($$%) {
1421 my ($self, $id, %msg) = @_; 1456 my ($self, $id, %msg) = @_;
1422 1457
1423 $msg{msgid} = $id; 1458 $msg{msgid} = $id;
1424 $self->send ("ext " . cf::to_json \%msg); 1459 $self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));
1425} 1460}
1426 1461
1427=item $player->ext_event ($type, %msg) 1462=item $player->ext_event ($type, %msg)
1428 1463
1429Sends an ext event to the client. 1464Sends an ext event to the client.
… …
2341 my $hp = $exit->stats->hp; 2376 my $hp = $exit->stats->hp;
2342 my $sp = $exit->stats->sp; 2377 my $sp = $exit->stats->sp;
2343 2378
2344 $self->enter_link; 2379 $self->enter_link;
2345 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
2346 (async { 2385 (async {
2347 $self->deactivate_recursive; # just to be sure 2386 $self->deactivate_recursive; # just to be sure
2348 unless (eval { 2387 unless (eval {
2349 $self->goto ($slaying, $hp, $sp); 2388 $self->goto ($slaying, $hp, $sp);
2350 2389
… …
2391sub cf::client::send_msg { 2430sub cf::client::send_msg {
2392 my ($self, $color, $type, $msg, @extra) = @_; 2431 my ($self, $color, $type, $msg, @extra) = @_;
2393 2432
2394 $msg = $self->pl->expand_cfpod ($msg); 2433 $msg = $self->pl->expand_cfpod ($msg);
2395 2434
2435 return unless @extra || length $msg;
2436
2396 if ($self->can_msg) { 2437 if ($self->can_msg) {
2397 $self->send_packet ("msg " . cf::to_json [$color, $type, $msg, @extra]); 2438 $self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $type, $msg, @extra]));
2398 } else { 2439 } else {
2399 # replace some tags by gcfclient-compatible ones 2440 # replace some tags by gcfclient-compatible ones
2400 for ($msg) { 2441 for ($msg) {
2401 1 while 2442 1 while
2402 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/ 2443 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
… …
2425 2466
2426sub cf::client::ext_event($$%) { 2467sub cf::client::ext_event($$%) {
2427 my ($self, $type, %msg) = @_; 2468 my ($self, $type, %msg) = @_;
2428 2469
2429 $msg{msgtype} = "event_$type"; 2470 $msg{msgtype} = "event_$type";
2430 $self->send_packet ("ext " . cf::to_json \%msg); 2471 $self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));
2431} 2472}
2432 2473
2433=item $success = $client->query ($flags, "text", \&cb) 2474=item $success = $client->query ($flags, "text", \&cb)
2434 2475
2435Queues a query to the client, calling the given callback with 2476Queues a query to the client, calling the given callback with
… …
2458 2499
2459 1 2500 1
2460} 2501}
2461 2502
2462cf::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 },
2463 on_reply => sub { 2509 on_reply => sub {
2464 my ($ns, $msg) = @_; 2510 my ($ns, $msg) = @_;
2465 2511
2466 # this weird shuffling is so that direct followup queries 2512 # this weird shuffling is so that direct followup queries
2467 # get handled first 2513 # get handled first
… …
2482 } 2528 }
2483 }, 2529 },
2484 on_exticmd => sub { 2530 on_exticmd => sub {
2485 my ($ns, $buf) = @_; 2531 my ($ns, $buf) = @_;
2486 2532
2487 my $msg = eval { from_json $buf }; 2533 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2488 2534
2489 if (ref $msg) { 2535 if (ref $msg) {
2490 if (my $cb = $EXTICMD{$msg->{msgtype}}) { 2536 if (my $cb = $EXTICMD{$msg->{msgtype}}) {
2491 if (my %reply = $cb->($ns, $msg)) { 2537 if (my %reply = $cb->($ns, $msg)) {
2492 $reply{msgid} = $msg->{msgid}; 2538 $reply{msgid} = $msg->{msgid};
2493 $ns->send ("ext " . cf::to_json \%reply); 2539 $ns->send ("ext " . $ns->{json_coder}->encode (\%reply));
2494 } 2540 }
2495 } 2541 }
2496 } else { 2542 } else {
2497 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";
2498 } 2544 }
… …
2555 2601
2556=pod 2602=pod
2557 2603
2558The following functions and methods are available within a safe environment: 2604The following functions and methods are available within a safe environment:
2559 2605
2560 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
2561 cf::object::player player 2610 cf::object::player
2562 cf::player peaceful 2611 player
2563 cf::map trigger 2612
2613 cf::player
2614 peaceful
2615
2616 cf::map
2617 trigger
2564 2618
2565=cut 2619=cut
2566 2620
2567for ( 2621for (
2568 ["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)],
2569 ["cf::object::player" => qw(player)], 2624 ["cf::object::player" => qw(player)],
2570 ["cf::player" => qw(peaceful)], 2625 ["cf::player" => qw(peaceful)],
2571 ["cf::map" => qw(trigger)], 2626 ["cf::map" => qw(trigger)],
2572) { 2627) {
2573 no strict 'refs'; 2628 no strict 'refs';
… …
2665 { 2720 {
2666 my $faces = $facedata->{faceinfo}; 2721 my $faces = $facedata->{faceinfo};
2667 2722
2668 while (my ($face, $info) = each %$faces) { 2723 while (my ($face, $info) = each %$faces) {
2669 my $idx = (cf::face::find $face) || cf::face::alloc $face; 2724 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2670 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 2725 cf::face::set_visibility $idx, $info->{visibility};
2726 cf::face::set_magicmap $idx, $info->{magicmap};
2671 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 2727 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2672 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 2728 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2673 Coro::cede; 2729
2730 cf::cede_to_tick;
2674 } 2731 }
2675 2732
2676 while (my ($face, $info) = each %$faces) { 2733 while (my ($face, $info) = each %$faces) {
2677 next unless $info->{smooth}; 2734 next unless $info->{smooth};
2678 my $idx = cf::face::find $face 2735 my $idx = cf::face::find $face
2679 or next; 2736 or next;
2680 if (my $smooth = cf::face::find $info->{smooth}) { 2737 if (my $smooth = cf::face::find $info->{smooth}) {
2738 cf::face::set_smooth $idx, $smooth;
2681 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel}; 2739 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2682 } else { 2740 } else {
2683 warn "smooth face '$info->{smooth}' not found for face '$face'"; 2741 warn "smooth face '$info->{smooth}' not found for face '$face'";
2684 } 2742 }
2685 Coro::cede; 2743
2744 cf::cede_to_tick;
2686 } 2745 }
2687 } 2746 }
2688 2747
2689 { 2748 {
2690 my $anims = $facedata->{animinfo}; 2749 my $anims = $facedata->{animinfo};
2691 2750
2692 while (my ($anim, $info) = each %$anims) { 2751 while (my ($anim, $info) = each %$anims) {
2693 cf::anim::set $anim, $info->{frames}, $info->{facings}; 2752 cf::anim::set $anim, $info->{frames}, $info->{facings};
2694 Coro::cede; 2753 cf::cede_to_tick;
2695 } 2754 }
2696 2755
2697 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}, #TODO#
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 my $idx = (cf::face::find $name) || cf::face::alloc $name;
2775 cf::face::set_type $idx, 1;
2776 cf::face::set_data $idx, 0, $data, $chk;
2777
2778 cf::cede_to_tick;
2779 }
2698 } 2780 }
2699 2781
2700 1 2782 1
2701} 2783}
2702 2784
… …
2709 load_facedata "$DATADIR/facedata" 2791 load_facedata "$DATADIR/facedata"
2710 or die "unable to load facedata\n"; 2792 or die "unable to load facedata\n";
2711} 2793}
2712 2794
2713sub reload_archetypes { 2795sub reload_archetypes {
2796 load_resource_file "$DATADIR/archetypes"
2797 or die "unable to load archetypes\n";
2798 #d# NEED to laod twice to resolve forward references
2799 # this really needs to be done in an extra post-pass
2800 # (which needs to be synchronous, so solve it differently)
2714 load_resource_file "$DATADIR/archetypes" 2801 load_resource_file "$DATADIR/archetypes"
2715 or die "unable to load archetypes\n"; 2802 or die "unable to load archetypes\n";
2716} 2803}
2717 2804
2718sub reload_treasures { 2805sub reload_treasures {

Diff Legend

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