--- deliantra/server/lib/cf.pm 2007/06/24 04:21:42 1.285 +++ deliantra/server/lib/cf.pm 2007/07/04 05:08:15 1.295 @@ -22,6 +22,7 @@ use Coro::AIO; use Coro::Storable; +use JSON::XS 1.4 (); use BDB (); use Data::Dumper; use Digest::MD5; @@ -51,6 +52,7 @@ our @EXTS = (); # list of extension package names our %EXTCMD = (); +our %EXTICMD = (); our %EXT_CORO = (); # coroutines bound to extensions our %EXT_MAP = (); # pluggable maps @@ -238,8 +240,6 @@ } || "[unable to dump $_[0]: '$@']"; } -use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working - =item $ref = cf::from_json $json Converts a JSON string into the corresponding perl data structure. @@ -248,6 +248,13 @@ Converts a perl data structure into its JSON representation. +=cut + +our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max + +sub to_json ($) { $json_coder->encode ($_[0]) } +sub from_json ($) { $json_coder->decode ($_[0]) } + =item cf::lock_wait $string Wait until the given lock is available. See cf::lock_acquire. @@ -1031,7 +1038,22 @@ =item cf::register_extcmd $name => \&callback($pl,$packet); -Register a callback fro execution when the client sends an extcmd packet. +Register a callback for execution when the client sends an (synchronous) +extcmd packet. Ext commands will be processed in the order they are +received by the server, like other user commands. The first argument is +the logged-in player. Ext commands can only be processed after a player +has logged in successfully. + +If the callback returns something, it is sent back as if reply was being +called. + +=item cf::register_exticmd $name => \&callback($ns,$packet); + +Register a callback for execution when the client sends an (asynchronous) +exticmd packet. Exti commands are processed by the server as soon as they +are received, i.e. out of order w.r.t. other commands. The first argument +is a client socket. Exti commands can be received anytime, even before +log-in. If the callback returns something, it is sent back as if reply was being called. @@ -1044,6 +1066,12 @@ $EXTCMD{$name} = $cb; } +sub register_exticmd { + my ($name, $cb) = @_; + + $EXTICMD{$name} = $cb; +} + cf::player->attach ( on_command => sub { my ($pl, $name, $params) = @_; @@ -1060,7 +1088,7 @@ on_extcmd => sub { my ($pl, $buf) = @_; - my $msg = eval { from_json $buf }; + my $msg = eval { $pl->ns->{json_coder}->decode ($buf) }; if (ref $msg) { if (my $cb = $EXTCMD{$msg->{msgtype}}) { @@ -1374,14 +1402,31 @@ $self->gender ? $2 : $1 }ge # replace H - || s/H<([^\>]*)>/[$1]<\/fg>/g; + || s{H<([^\>]*)>} + { + ("[$1 (Use hintmode to suppress hints)]", + "[Hint suppressed, see hintmode]", + "") + [$self->{hintmode}] + }ge; # create single paragraphs (very hackish) s/(?<=\S)\n(?=\w)/ /g; + # compress some whitespace + s/\s+\n/\n/g; # ws line-ends + s/\n\n+/\n/g; # double lines + s/^\n+//; # beginning lines + s/\n+$//; # ending lines + $_ } +sub hintmode { + $_[0]{hintmode} = $_[1] if @_ > 1; + $_[0]{hintmode} +} + =item $player->ext_reply ($msgid, %msg) Sends an ext reply to the player. @@ -1392,8 +1437,7 @@ my ($self, $id, %msg) = @_; $msg{msgid} = $id; - - $self->send ("ext " . cf::to_json \%msg); + $self->send ("ext " . $self->ns->{json_coder}->encode (\%msg)); } =item $player->ext_event ($type, %msg) @@ -2365,8 +2409,10 @@ $msg = $self->pl->expand_cfpod ($msg); + return unless @extra || length $msg; + if ($self->can_msg) { - $self->send_packet ("msg " . cf::to_json [$color, $type, $msg, @extra]); + $self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $type, $msg, @extra])); } else { # replace some tags by gcfclient-compatible ones for ($msg) { @@ -2382,7 +2428,7 @@ if (0 && $msg =~ /\[/) { $self->send_packet ("drawextinfo $color 4 0 $msg") } else { - s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g; + $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g; $self->send_packet ("drawinfo $color $msg") } } @@ -2391,7 +2437,7 @@ =item $client->ext_event ($type, %msg) -Sends an exti event to the client. +Sends an ext event to the client. =cut @@ -2399,7 +2445,7 @@ my ($self, $type, %msg) = @_; $msg{msgtype} = "event_$type"; - $self->send_packet ("ext " . cf::to_json \%msg); + $self->send_packet ("ext " . $self->{json_coder}->encode (\%msg)); } =item $success = $client->query ($flags, "text", \&cb) @@ -2408,8 +2454,8 @@ the reply text on a reply. flags can be C, C or C or C<0>. -Queries can fail, so check the return code. Or don't, as queries will become -reliable at some point in the future. +Queries can fail, so check the return code. Or don't, as queries will +become reliable at some point in the future. =cut @@ -2427,9 +2473,16 @@ $self->send_packet ($self->{query_queue}[0][0]) if @{ $self->{query_queue} } == 1; + + 1 } cf::client->attach ( + on_connect => sub { + my ($ns) = @_; + + $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed; + }, on_reply => sub { my ($ns, $msg) = @_; @@ -2451,6 +2504,24 @@ } } }, + on_exticmd => sub { + my ($ns, $buf) = @_; + + my $msg = eval { $ns->{json_coder}->decode ($buf) }; + + if (ref $msg) { + if (my $cb = $EXTICMD{$msg->{msgtype}}) { + if (my %reply = $cb->($ns, $msg)) { + $reply{msgid} = $msg->{msgid}; + $ns->send ("ext " . $ns->{json_coder}->encode (\%reply)); + } + } + } else { + warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; + } + + cf::override; + }, ); =item $client->async (\&cb) @@ -2665,6 +2736,11 @@ sub reload_archetypes { load_resource_file "$DATADIR/archetypes" or die "unable to load archetypes\n"; + #d# NEED to laod twice to resolve forward references + # this really needs to be done in an extra post-pass + # (which needs to be synchronous, so solve it differently) + load_resource_file "$DATADIR/archetypes" + or die "unable to load archetypes\n"; } sub reload_treasures { @@ -2866,8 +2942,9 @@ warn "removing commands"; %COMMAND = (); - warn "removing ext commands"; - %EXTCMD = (); + warn "removing ext/exti commands"; + %EXTCMD = (); + %EXTICMD = (); warn "unloading/nuking all extensions"; for my $pkg (@EXTS) {