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.301 by root, Tue Jul 10 07:01:51 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 ();
… …
237 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 238 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
238 $d 239 $d
239 } || "[unable to dump $_[0]: '$@']"; 240 } || "[unable to dump $_[0]: '$@']";
240} 241}
241 242
242use JSON::XS ();
243
244=item $ref = cf::from_json $json 243=item $ref = cf::from_json $json
245 244
246Converts a JSON string into the corresponding perl data structure. 245Converts a JSON string into the corresponding perl data structure.
247 246
248=item $json = cf::to_json $ref 247=item $json = cf::to_json $ref
249 248
250Converts a perl data structure into its JSON representation. 249Converts a perl data structure into its JSON representation.
251 250
252=cut 251=cut
253 252
254our $json_coder = JSON::XS->new->convert_blessed->utf8; 253our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
255 254
256sub to_json ($) { $json_coder->encode ($_[0]) } 255sub to_json ($) { $json_coder->encode ($_[0]) }
257sub from_json ($) { $json_coder->decode ($_[0]) } 256sub from_json ($) { $json_coder->decode ($_[0]) }
258 257
259=item cf::lock_wait $string 258=item cf::lock_wait $string
… …
410Coro::Storable. May, of course, block. Note that the executed sub may 409Coro::Storable. May, of course, block. Note that the executed sub may
411never block itself or use any form of Event handling. 410never block itself or use any form of Event handling.
412 411
413=cut 412=cut
414 413
414sub _store_scalar {
415 open my $fh, ">", \my $buf
416 or die "fork_call: cannot open fh-to-buf in child : $!";
417 Storable::store_fd $_[0], $fh;
418 close $fh;
419
420 $buf
421}
422
415sub fork_call(&@) { 423sub fork_call(&@) {
416 my ($cb, @args) = @_; 424 my ($cb, @args) = @_;
417 425
418# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC 426# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
419# or die "socketpair: $!"; 427# or die "socketpair: $!";
… …
422 430
423 if (my $pid = fork) { 431 if (my $pid = fork) {
424 close $fh2; 432 close $fh2;
425 433
426 my $res = (Coro::Handle::unblock $fh1)->readline (undef); 434 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
435 warn "pst<$res>" unless $res =~ /^pst/;
427 $res = Coro::Storable::thaw $res; 436 $res = Coro::Storable::thaw $res;
428 437
429 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave 438 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
430 439
431 die $$res unless "ARRAY" eq ref $res; 440 Carp::confess $$res unless "ARRAY" eq ref $res;
432 441
433 return wantarray ? @$res : $res->[-1]; 442 return wantarray ? @$res : $res->[-1];
434 } else { 443 } else {
435 reset_signals; 444 reset_signals;
436 local $SIG{__WARN__}; 445 local $SIG{__WARN__};
437 local $SIG{__DIE__}; 446 local $SIG{__DIE__};
447 # just in case, this hack effectively disables event
448 # in the child. cleaner and slower would be canceling all watchers,
449 # but this works for the time being.
450 local $Coro::idle;
451 $Coro::current->prio (Coro::PRIO_MAX);
452
438 eval { 453 eval {
439 close $fh1; 454 close $fh1;
440 455
441 my @res = eval { $cb->(@args) }; 456 my @res = eval { $cb->(@args) };
457
442 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res); 458 syswrite $fh2, _store_scalar $@ ? \"$@" : \@res;
459 close $fh2;
443 }; 460 };
444 461
445 warn $@ if $@; 462 warn $@ if $@;
446 _exit 0; 463 _exit 0;
447 } 464 }
… …
1087 cf::override; 1104 cf::override;
1088 }, 1105 },
1089 on_extcmd => sub { 1106 on_extcmd => sub {
1090 my ($pl, $buf) = @_; 1107 my ($pl, $buf) = @_;
1091 1108
1092 my $msg = eval { from_json $buf }; 1109 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1093 1110
1094 if (ref $msg) { 1111 if (ref $msg) {
1095 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1112 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
1096 if (my %reply = $cb->($pl, $msg)) { 1113 if (my %reply = $cb->($pl, $msg)) {
1097 $pl->ext_reply ($msg->{msgid}, %reply); 1114 $pl->ext_reply ($msg->{msgid}, %reply);
… …
1401 # replace G<male|female> tags 1418 # replace G<male|female> tags
1402 || s{G<([^>|]*)\|([^>]*)>}{ 1419 || s{G<([^>|]*)\|([^>]*)>}{
1403 $self->gender ? $2 : $1 1420 $self->gender ? $2 : $1
1404 }ge 1421 }ge
1405 # replace H<hint text> 1422 # replace H<hint text>
1406 || s/H<([^\>]*)>/<fg name="lightblue">[$1]<\/fg>/g; 1423 || s{H<([^\>]*)>}
1424 {
1425 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
1426 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1427 "")
1428 [$self->{hintmode}]
1429 }ge;
1407 1430
1408 # create single paragraphs (very hackish) 1431 # create single paragraphs (very hackish)
1409 s/(?<=\S)\n(?=\w)/ /g; 1432 s/(?<=\S)\n(?=\w)/ /g;
1410 1433
1434 # compress some whitespace
1435 s/\s+\n/\n/g; # ws line-ends
1436 s/\n\n+/\n/g; # double lines
1437 s/^\n+//; # beginning lines
1438 s/\n+$//; # ending lines
1439
1411 $_ 1440 $_
1441}
1442
1443sub hintmode {
1444 $_[0]{hintmode} = $_[1] if @_ > 1;
1445 $_[0]{hintmode}
1412} 1446}
1413 1447
1414=item $player->ext_reply ($msgid, %msg) 1448=item $player->ext_reply ($msgid, %msg)
1415 1449
1416Sends an ext reply to the player. 1450Sends an ext reply to the player.
… …
1419 1453
1420sub ext_reply($$%) { 1454sub ext_reply($$%) {
1421 my ($self, $id, %msg) = @_; 1455 my ($self, $id, %msg) = @_;
1422 1456
1423 $msg{msgid} = $id; 1457 $msg{msgid} = $id;
1424 $self->send ("ext " . cf::to_json \%msg); 1458 $self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));
1425} 1459}
1426 1460
1427=item $player->ext_event ($type, %msg) 1461=item $player->ext_event ($type, %msg)
1428 1462
1429Sends an ext event to the client. 1463Sends an ext event to the client.
… …
2341 my $hp = $exit->stats->hp; 2375 my $hp = $exit->stats->hp;
2342 my $sp = $exit->stats->sp; 2376 my $sp = $exit->stats->sp;
2343 2377
2344 $self->enter_link; 2378 $self->enter_link;
2345 2379
2380 # if exit is damned, update players death & WoR home-position
2381 $self->contr->savebed ($slaying, $hp, $sp)
2382 if $exit->flag (FLAG_DAMNED);
2383
2346 (async { 2384 (async {
2347 $self->deactivate_recursive; # just to be sure 2385 $self->deactivate_recursive; # just to be sure
2348 unless (eval { 2386 unless (eval {
2349 $self->goto ($slaying, $hp, $sp); 2387 $self->goto ($slaying, $hp, $sp);
2350 2388
… …
2391sub cf::client::send_msg { 2429sub cf::client::send_msg {
2392 my ($self, $color, $type, $msg, @extra) = @_; 2430 my ($self, $color, $type, $msg, @extra) = @_;
2393 2431
2394 $msg = $self->pl->expand_cfpod ($msg); 2432 $msg = $self->pl->expand_cfpod ($msg);
2395 2433
2434 return unless @extra || length $msg;
2435
2396 if ($self->can_msg) { 2436 if ($self->can_msg) {
2397 $self->send_packet ("msg " . cf::to_json [$color, $type, $msg, @extra]); 2437 $self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $type, $msg, @extra]));
2398 } else { 2438 } else {
2399 # replace some tags by gcfclient-compatible ones 2439 # replace some tags by gcfclient-compatible ones
2400 for ($msg) { 2440 for ($msg) {
2401 1 while 2441 1 while
2402 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/ 2442 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
… …
2425 2465
2426sub cf::client::ext_event($$%) { 2466sub cf::client::ext_event($$%) {
2427 my ($self, $type, %msg) = @_; 2467 my ($self, $type, %msg) = @_;
2428 2468
2429 $msg{msgtype} = "event_$type"; 2469 $msg{msgtype} = "event_$type";
2430 $self->send_packet ("ext " . cf::to_json \%msg); 2470 $self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));
2431} 2471}
2432 2472
2433=item $success = $client->query ($flags, "text", \&cb) 2473=item $success = $client->query ($flags, "text", \&cb)
2434 2474
2435Queues a query to the client, calling the given callback with 2475Queues a query to the client, calling the given callback with
… …
2458 2498
2459 1 2499 1
2460} 2500}
2461 2501
2462cf::client->attach ( 2502cf::client->attach (
2503 on_connect => sub {
2504 my ($ns) = @_;
2505
2506 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2507 },
2463 on_reply => sub { 2508 on_reply => sub {
2464 my ($ns, $msg) = @_; 2509 my ($ns, $msg) = @_;
2465 2510
2466 # this weird shuffling is so that direct followup queries 2511 # this weird shuffling is so that direct followup queries
2467 # get handled first 2512 # get handled first
… …
2482 } 2527 }
2483 }, 2528 },
2484 on_exticmd => sub { 2529 on_exticmd => sub {
2485 my ($ns, $buf) = @_; 2530 my ($ns, $buf) = @_;
2486 2531
2487 my $msg = eval { from_json $buf }; 2532 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2488 2533
2489 if (ref $msg) { 2534 if (ref $msg) {
2490 if (my $cb = $EXTICMD{$msg->{msgtype}}) { 2535 if (my $cb = $EXTICMD{$msg->{msgtype}}) {
2491 if (my %reply = $cb->($ns, $msg)) { 2536 if (my %reply = $cb->($ns, $msg)) {
2492 $reply{msgid} = $msg->{msgid}; 2537 $reply{msgid} = $msg->{msgid};
2493 $ns->send ("ext " . cf::to_json \%reply); 2538 $ns->send ("ext " . $ns->{json_coder}->encode (\%reply));
2494 } 2539 }
2495 } 2540 }
2496 } else { 2541 } else {
2497 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 2542 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2498 } 2543 }
… …
2555 2600
2556=pod 2601=pod
2557 2602
2558The following functions and methods are available within a safe environment: 2603The following functions and methods are available within a safe environment:
2559 2604
2560 cf::object contr pay_amount pay_player map 2605 cf::object
2606 contr pay_amount pay_player map x y force_find force_add
2607 insert remove
2608
2561 cf::object::player player 2609 cf::object::player
2562 cf::player peaceful 2610 player
2563 cf::map trigger 2611
2612 cf::player
2613 peaceful
2614
2615 cf::map
2616 trigger
2564 2617
2565=cut 2618=cut
2566 2619
2567for ( 2620for (
2568 ["cf::object" => qw(contr pay_amount pay_player map)], 2621 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2622 insert remove)],
2569 ["cf::object::player" => qw(player)], 2623 ["cf::object::player" => qw(player)],
2570 ["cf::player" => qw(peaceful)], 2624 ["cf::player" => qw(peaceful)],
2571 ["cf::map" => qw(trigger)], 2625 ["cf::map" => qw(trigger)],
2572) { 2626) {
2573 no strict 'refs'; 2627 no strict 'refs';
… …
2709 load_facedata "$DATADIR/facedata" 2763 load_facedata "$DATADIR/facedata"
2710 or die "unable to load facedata\n"; 2764 or die "unable to load facedata\n";
2711} 2765}
2712 2766
2713sub reload_archetypes { 2767sub reload_archetypes {
2768 load_resource_file "$DATADIR/archetypes"
2769 or die "unable to load archetypes\n";
2770 #d# NEED to laod twice to resolve forward references
2771 # this really needs to be done in an extra post-pass
2772 # (which needs to be synchronous, so solve it differently)
2714 load_resource_file "$DATADIR/archetypes" 2773 load_resource_file "$DATADIR/archetypes"
2715 or die "unable to load archetypes\n"; 2774 or die "unable to load archetypes\n";
2716} 2775}
2717 2776
2718sub reload_treasures { 2777sub reload_treasures {

Diff Legend

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