From 4406c0040dafb2f3cda6d093b5b0a23918351f18 Mon Sep 17 00:00:00 2001 From: Ben Date: Mon, 16 Nov 2009 18:12:19 -0500 Subject: [PATCH] Handle outgoing chatstates. --- perl/lib/Thrasher/Component.pm | 65 ++++++++++++++++------- perl/lib/Thrasher/Protocol.pm | 17 +++++++ perl/lib/Thrasher/Protocol/Purple.pm | 22 ++++++++ perl/lib/Thrasher/Protocol/Test.pm | 12 ++++- perl/lib/Thrasher/Test.pm | 3 +- perl/lib/Thrasher/XML.pm | 99 +++++++++++++++++++----------------- perl/tests/component.pl | 51 ++++++++++++++++++- thconversations.c | 29 +++++++++++ thconversations.h | 1 + thperl.c | 26 ++++++++++ thperl.h | 1 + 11 files changed, 259 insertions(+), 67 deletions(-) diff --git a/perl/lib/Thrasher/Component.pm b/perl/lib/Thrasher/Component.pm index 9061107..4194419 100644 --- a/perl/lib/Thrasher/Component.pm +++ b/perl/lib/Thrasher/Component.pm @@ -445,15 +445,26 @@ sub xml_in_connected { from => save('from'), type => save('type', 1), }, - save_match('body', - [[undef, 'body'], undef, undef])] => + [ + save_match('chatstate', + [[$NS_CHATSTATES, undef], undef, undef], + 1), + save_match('body', + [[undef, 'body'], undef, undef], + 1), + ]] => sub { my $message_params = shift; $message_params->{'type'} ||= 'chat'; + if ($message_params->{'chatstate'}) { + $message_params->{'chatstate'} + = $message_params->{'chatstate'}->[0]->[1]; + } $self->handle_message($message_params->{to}, $message_params->{from}, $message_params->{body}, - $message_params->{'type'}); + $message_params->{'type'}, + $message_params->{'chatstate'}); }, # Stream error @@ -1125,6 +1136,7 @@ sub handle_message { my $from = shift; my $body_xml = shift; my $type = shift; + my $chatstate = shift; if (defined($type) && $type eq 'error') { log("Got an error message from a user."); @@ -1177,26 +1189,45 @@ sub handle_message { return; } - local $@ = ''; + my $converted_to = $self->xmpp_name_to_legacy($session->{jid}, + strip_resource($to)); + # Tie successful call to the protocol to the successful extraction # of the message from the input - eval { - my $body = extract([undef, undef, - save_sub("text", \&text_extractor)], - $body_xml); + if ($body_xml) { + eval { + my $body = extract([undef, undef, + save_sub("text", \&text_extractor)], + $body_xml); - my $body_text = join '', @{$body->{text} || []}; + my $body_text = join '', @{$body->{text} || []}; - my $converted_to = $self->xmpp_name_to_legacy - ($session->{jid}, strip_resource($to)); + $self->{protocol}->send_message($session, + $converted_to, + $body_text, + $type, + $error_handler); + }; + if ($@) { + log("Error in extracting message from " + . Dumper($body_xml) . ":\n" . $@); + } + } - $self->{protocol}->send_message($session, $converted_to, - $body_text, $type, $error_handler); - }; + if ($chatstate) { + eval { + $self->{protocol}->outgoing_chatstate($session, + $converted_to, + $chatstate); + }; + if ($@) { + log("Error in outgoing_chatstate:\n$@"); + } + } - if ($@) { - log "Error in extracting message from " . - Dumper($body_xml) . ":\n" . $@; + if (! ($body_xml || $chatstate)) { + log('Message without usable child.'); + return; } } diff --git a/perl/lib/Thrasher/Protocol.pm b/perl/lib/Thrasher/Protocol.pm index ab9dd14..6e23bcf 100644 --- a/perl/lib/Thrasher/Protocol.pm +++ b/perl/lib/Thrasher/Protocol.pm @@ -557,6 +557,23 @@ sub send_message { =item * +C($session, $to, $chatstate): +Called when a chatstates stanza is received from the XMPP user +directed at the legacy username C<$to>. C<$to> is as for send_message. + +The default implementation is to ignore chatstates. + +=cut + +sub outgoing_chatstate { + my ($self, $session, $to, $chatstate) = @_; + # ignore! +} + +=pod + +=item * + C($session, $component, $legacy_username): The user has accepted the subscription request by the given legacy username; handle it as you should. ::Session actually takes care of the presence tags. diff --git a/perl/lib/Thrasher/Protocol/Purple.pm b/perl/lib/Thrasher/Protocol/Purple.pm index 6a78c4c..98051d8 100644 --- a/perl/lib/Thrasher/Protocol/Purple.pm +++ b/perl/lib/Thrasher/Protocol/Purple.pm @@ -735,6 +735,28 @@ sub send_message { debug("Message send result: $result\n"); } +sub outgoing_chatstate { + my ($self, $session, $to, $chatstate) = @_; + debug("###outgoing_chatstate($session->{jid}, $to, $chatstate)\n"); + + our $chatstate_to_purple ||= { + 'composing' => $THPPW::PURPLE_TYPING, + 'paused' => $THPPW::PURPLE_TYPED, + 'inactive' => $THPPW::PURPLE_NOT_TYPING, + 'active' => $THPPW::PURPLE_NOT_TYPING, + }; + my $purple_typing_state = $chatstate_to_purple->{$chatstate}; + if (! defined($purple_typing_state)) { + debug("Untranslated chatstate: '$chatstate'\n"); + return; + } + + THPPW::thrasher_action_outgoing_chatstate($session->{'jid'}, + $to, + $purple_typing_state); + return; +} + sub subscribed { my $self = shift; my $session = shift; diff --git a/perl/lib/Thrasher/Protocol/Test.pm b/perl/lib/Thrasher/Protocol/Test.pm index a78dfa1..8a55f65 100644 --- a/perl/lib/Thrasher/Protocol/Test.pm +++ b/perl/lib/Thrasher/Protocol/Test.pm @@ -169,6 +169,7 @@ sub send_message { my $body_text = shift; my $type = shift; my $error_sub = shift; + my $chatstate = shift; if (my ($error) = ($body_text =~ /^Error: ([a-z_]+)/)) { $error_sub->($error); @@ -176,7 +177,8 @@ sub send_message { } # Record a message was sent - push @{$session->{messages}}, [$to, $body_text, $type]; + my $message = [$to, $body_text, $type]; + push(@{$session->{messages}}, $message); my $from = $session->{jid}; @@ -213,6 +215,14 @@ sub send_message { return undef; } +sub outgoing_chatstate { + my ($self, $session, $to, $chatstate) = @_; + if ($session->{'chatstates'}) { + push(@{$session->{'chatstates'}}, $chatstate); + } + return; +} + sub subscribed { my $self = shift; my $session = shift; diff --git a/perl/lib/Thrasher/Test.pm b/perl/lib/Thrasher/Test.pm index f6c25d1..f7ebaf9 100644 --- a/perl/lib/Thrasher/Test.pm +++ b/perl/lib/Thrasher/Test.pm @@ -121,7 +121,8 @@ sub new_component { $test_protocol->{component} = $comp; cmp_deeply(\@accum, - [""]); + [""], + 'stream open tag accumulated'); clear; diff --git a/perl/lib/Thrasher/XML.pm b/perl/lib/Thrasher/XML.pm index b8c52c5..b44b2c4 100644 --- a/perl/lib/Thrasher/XML.pm +++ b/perl/lib/Thrasher/XML.pm @@ -253,7 +253,7 @@ sub extract { my $final_hash = {}; - my ($pat_element, $pat_atts, $pat_children) = @$xml_pattern; + my ($pat_element, $pat_atts, $pats_children) = @$xml_pattern; my ($element, $atts, $children) = @$xml; my $string_equal = sub { $_[0] eq $_[1] }; @@ -377,57 +377,62 @@ sub extract { } } - CHILDREN: { - if (!defined($pat_children)) { - # deliberately blank, no action - } else { - # Special case: [] means "no children" - if (ref($pat_children) eq 'ARRAY' && - scalar(@$pat_children) == 0 && - scalar(@$children) == 0) { - # that's all fine then. - last CHILDREN; - } + my $match_children1 = sub { + my ($pat_children) = @_; - my $final_children = []; - for my $child (@$children) { - my $match_result = undef; - - { - local $@ = undef; - eval { - $match_result = $compare->($pat_children, - $child); - }; - if (!$@ && defined($match_result)) { - if (ref($pat_children) eq - 'Thrasher::XMPPStreamIn::Placeholder::Match' && - $pat_children->{name}) { - $final_hash->{$pat_children->{name}} = $match_result; - last CHILDREN; - } - push @$final_children, $match_result; - } + my $final_children = []; + for my $child (@$children) { + my $match_result = eval { + $compare->($pat_children, + $child); + }; + if (!$@ && defined($match_result)) { + if (ref($pat_children) eq + 'Thrasher::XMPPStreamIn::Placeholder::Match' && + $pat_children->{name}) { + return $match_result; } + push @$final_children, $match_result; } + } - if (!@$final_children && !spec_is_optional($pat_children)) { - $cleanup->(); - confess "In attempting to match children, none matched."; - } - - # Transfer the matching results into the name for the - # sub if needed - if (ref($pat_children) eq - 'Thrasher::XMPPStreamIn::Placeholder::Sub') { - $final_hash->{$pat_children->{name}} = $final_children; - } - if (ref($pat_children) eq - 'Thrasher::XMPPStreamIn::Placeholder') { - $final_hash->{$pat_children->{name}} = $final_children; - } + if (!@$final_children && !spec_is_optional($pat_children)) { + $cleanup->(); + confess "In attempting to match children, none matched."; } - } + # Transfer the matching results into the name for the sub if needed + if (ref($pat_children) eq 'Thrasher::XMPPStreamIn::Placeholder::Sub') { + return $final_children; + } + elsif (ref($pat_children) eq 'Thrasher::XMPPStreamIn::Placeholder') { + return $final_children; + } + else { + return; + } + }; + + CHILDREN: { + if (defined($pats_children)) { + if (ref($pats_children) ne 'ARRAY') { + $pats_children = [ $pats_children ]; + } + elsif (scalar(@{$pats_children}) == 0) { + # Special case: [] means "no children" + if (scalar(@{$children}) != 0) { + $cleanup->(); + confess('Match wanted no children.'); + } + last CHILDREN; + } + for my $pat_children (@{$pats_children}) { + my $to_save = $match_children1->($pat_children); + if ($to_save) { + $final_hash->{$pat_children->{name}} = $to_save; + } + } + } + } $cleanup->(); return $final_hash; diff --git a/perl/tests/component.pl b/perl/tests/component.pl index 3618f42..e71e808 100644 --- a/perl/tests/component.pl +++ b/perl/tests/component.pl @@ -747,7 +747,7 @@ MESSAGE type='chat'/> MESSAGE $comp->xml_in($message); - logged("Unexpected packet:", + logged('Message without usable child', "doesn't try to process message without body"); # diag("Beginning message type tests"); @@ -778,6 +778,55 @@ XML @{${$messages}} = (); # diag("End of message type tests"); + diag("Beginning chatstates parsing tests"); + clear_log(); + output(); + @{${$messages}} = (); + my $chatstates + = $comp->session_for('romeo@montague.lit/orchard')->{chatstates} + = []; + $comp->xml_in(< + no chatstates + +XML + cmp_deeply(${$messages}->[0], + [ 'juliet', 'no chatstates', 'chat' ], + 'message w/no chatstates: body parsed correctly'); + ok(scalar(@{$chatstates}) == 0, + 'message w/no chatstates: no chatstate passed'); + $comp->xml_in(< + + active chatstate and body + + + + +XML + cmp_deeply(${$messages}->[1], + [ 'juliet', 'active chatstate and body', 'chat' ], + 'message w/body and chatstate: body parsed correctly'); + is($chatstates->[0], + 'active', + 'message w/body and chatstate: chatstate parsed correctly'); + ok(! exists(${$messages}->[2]), + 'message w/chatstate but no body: no message sent'); + is($chatstates->[1], + 'composing', + 'message w/chatstate but no body: chatstate handled'); + clear_log(); + output(); + @{${$messages}} = (); + delete($comp->session_for('romeo@montague.lit/orchard')->{chatstates}); + diag("End of chatstates parsing tests"); + # Fake up an error to see that we handle that correctly $message = <