perl/tests/component.pl

   1 #!/usr/bin/perl
   2
   3 # While throwing around XML fragments results in some ugly source
   4 # code, it seem safer and more correct than trying to do anything
   5 # else fancy.
   6
   7 use Test::More 'no_plan';
   8 use Test::Deep;
   9
  10 use strict;
  11 use warnings;
  12
  13 use Data::Dumper;
  14
  15 BEGIN {
  16     use_ok 'Thrasher', qw(:all);
  17     use_ok 'Thrasher::Component';
  18     use_ok 'Thrasher::Constants', qw(:all);
  19     use_ok 'Thrasher::Protocol';
  20     use_ok 'Thrasher::Protocol::Test';
  21     use_ok 'Thrasher::Backend';
  22     use_ok 'Thrasher::Backend::Test';
  23     use_ok 'Thrasher::Test', qw(:all);
  24     use_ok 'Thrasher::Roster', qw(:constants);
  25     use_ok 'Thrasher::ConnectionManager', qw(:all);
  26 }
  27
  28 # This test was written before the connection manager, and really
  29 # doesn't depend on it.
  30 $Thrasher::Component::USE_CONNECTION_MANAGER = 0;
  31
  32 my $JID = transport_jid;
  33
  34 # Test the connection and binding process.
  35 CONNECTION_AND_BINDING: {
  36     my $comp = new_component;
  37
  38     is(ref($comp->{protocol}), 'Thrasher::Protocol::Test',
  39        'component has a test protocol in it');
  40
  41     # Send in the initial stream tag, check the resulting handshake
  42     # for correctness
  43     send_server_stream($comp);
  44 }
  45
  46 # Test that we correct detect bad handshake errors.
  47 BAD_HANDSHAKE: {
  48     my $comp = new_component;
  49
  50     no strict qw(refs);
  51     no warnings qw(redefine);
  52     local *{'Thrasher::Component::reconnect_stream'} = sub {
  53         die('calling reconnect_stream()');
  54     };
  55
  56     send_server_stream($comp);
  57     #$comp->xml_in('<stream:error>Invalid Handshake</stream:error>'
  58     #.'</stream:stream>');
  59     dies {
  60         $comp->xml_in('<stream:error>Invalid Handshake</stream:error>'
  61                       .'</stream:stream>');
  62     } 'calling reconnect_stream()',
  63     'bad handshakes correctly detected';
  64 }
  65
  66 IQ_HANDLING: {
  67     my $comp = connected_component;
  68     my $test_ns = 'xxx';
  69
  70     my $test_ns_handler_fired = 0;
  71     my $test_ns_handler = sub {
  72         $test_ns_handler_fired = 1;
  73     };
  74     my $plugin_data = {
  75         'component_iq_handlers' => {
  76             $test_ns => { 'get' => $test_ns_handler },
  77         },
  78     };
  79     Thrasher::Plugin::register_plugin($plugin_data);
  80
  81     my $expect_id = 'id' . $Thrasher::Component::id;
  82     my $result_handler_fired = 0;
  83     $comp->iq_query([[ $NS_COMPONENT, 'iq' ],
  84                      {
  85                          to => 'nowhere',
  86                          from => $comp->{'component_name'},
  87                          type => 'get',
  88                      },
  89                      [[[ $test_ns, 'query' ], {}, []]]],
  90                     sub { $result_handler_fired = 1; });
  91
  92         $comp->xml_in(<<IQ);
  93 <iq type='get'
  94     from='romeo\@montague.lit/orchard'
  95     to='$JID'
  96     id='${expect_id}'>
  97     <query xmlns='${test_ns}' />
  98 </iq>
  99 IQ
 100     ok((! $result_handler_fired),
 101        'handler expecting a result must not be confused with requests');
 102     ok($test_ns_handler_fired,
 103        'handler for test NS result was fired instead');
 104     Thrasher::Plugin::unregister_plugin($plugin_data);
 105
 106     $result_handler_fired = 0;
 107     $comp->xml_in(<<IQ);
 108 <iq type='get'
 109     from='nowhere'
 110     to='$JID'
 111     id='${expect_id}'>
 112     <query xmlns='${test_ns}' />
 113 </iq>
 114 IQ
 115     ok((! $result_handler_fired),
 116        'non-result IQs do not fire result handler');
 117
 118     $result_handler_fired = 0;
 119     $comp->xml_in(<<IQ);
 120 <iq type='result'
 121     from='nowhere'
 122     to='$JID'
 123     id='${expect_id}'>
 124     <query xmlns='${test_ns}' />
 125 </iq>
 126 IQ
 127     ok($result_handler_fired,
 128        'result IQs do fire the result handler');
 129
 130     $result_handler_fired = 0;
 131     $expect_id = 'id' . $Thrasher::Component::id;
 132     $comp->iq_query([[ $NS_COMPONENT, 'iq' ],
 133                      {
 134                          to => 'nowhere',
 135                          from => $comp->{'component_name'},
 136                          type => 'get',
 137                      },
 138                      [[[ $test_ns, 'query' ], {}, []]]],
 139                     sub { $result_handler_fired = 1; });
 140     $comp->xml_in(<<IQ);
 141 <iq type='error'
 142     from='nowhere'
 143     to='$JID'
 144     id='${expect_id}'>
 145     <query xmlns='${test_ns}' />
 146 </iq>
 147 IQ
 148     ok($result_handler_fired,
 149        'error IQs do fire the result handler');
 150 }
 151
 152 # Test the two types of discovery, using the discovery and the
 153 # agents protocol. Section 4.1 of the protocol.
 154 DISCOVERY: {
 155     COMPONENT_DISCOVERY: {
 156         my $comp = connected_component;
 157         $comp->xml_in(<<DISCO);
 158 <iq type='get'
 159     from='romeo\@montague.lit/orchard'
 160     to='$JID'
 161     id='disco1'>
 162     <query xmlns='http://jabber.org/protocol/disco#info'
 163            node='http://testnode/#test' />
 164 </iq>
 165 DISCO
 166
 167         my $disco_result = clean_xml(<<DISCO_RESULT);
 168 <iq
 169   from='test.transport'
 170   id='disco1'
 171   to='romeo\@montague.lit/orchard'
 172   type='result'>
 173     <query node='http://testnode/#test'
 174            xmlns='http://jabber.org/protocol/disco#info'>
 175        <identity category='gateway' name='Test Gateway' type='aim'/>
 176        <feature var='http://jabber.org/protocol/chatstates'/>
 177        <feature var='http://jabber.org/protocol/disco#info'/>
 178        <feature var='http://jabber.org/protocol/disco#items'/>
 179        <feature var='jabber:iq:register'/>
 180        <feature var='jabber:iq:time'/>
 181        <feature var='jabber:iq:version'/>
 182     </query>
 183 </iq>
 184 DISCO_RESULT
 185
 186         is(output, $disco_result, 'proper discovery reply');
 187
 188         $comp->xml_in(<<DISCO);
 189 <iq type='get'
 190     from='romeo\@montague.lit/orchard'
 191     to='$JID'
 192     id='disco1'>
 193     <query xmlns='http://jabber.org/protocol/disco#items' />
 194 </iq>
 195 DISCO
 196         my $disco_items_result = clean_xml(<<DISCO_RESULT);
 197 <iq
 198   from='test.transport'
 199   id='disco1'
 200   to='romeo\@montague.lit/orchard'
 201   type='result'>
 202     <query xmlns='http://jabber.org/protocol/disco#items'/>
 203 </iq>
 204 DISCO_RESULT
 205
 206         is(output, $disco_items_result,
 207            'proper discovery items reply');
 208     }
 209
 210     # Test a discovery request fired against the virtual client
 211     # that a legacy user represents.
 212     # We're cheating a bit here, in that we'll answer the same
 213     # to all queries, regardless of whether there's an actual
 214     # user behind the given username.
 215     CLIENT_DISCOVERY: {
 216         my $comp = connected_component;
 217         $comp->xml_in(<<DISCO);
 218 <iq type='get'
 219     from='romeo\@montague.lit/orchard'
 220     to='juliet\@$JID'
 221     id='disco1'>
 222     <query xmlns='http://jabber.org/protocol/disco#info'
 223            node='http://testnode/#test' />
 224 </iq>
 225 DISCO
 226
 227         my $disco_result = clean_xml(<<DISCO_RESULT);
 228 <iq
 229   from='juliet\@$JID'
 230   id='disco1'
 231   to='romeo\@montague.lit/orchard'
 232   type='result'>
 233     <query node='http://testnode/#test'
 234            xmlns='http://jabber.org/protocol/disco#info'>
 235        <identity category='gateway' name='Test Gateway' type='aim'/>
 236        <feature var='http://jabber.org/protocol/disco#info'/>
 237        <feature var='http://jabber.org/protocol/disco#items'/>
 238        <feature var='jabber:iq:register'/>
 239        <feature var='jabber:iq:time'/>
 240        <feature var='jabber:iq:version'/>
 241     </query>
 242 </iq>
 243 DISCO_RESULT
 244
 245         is(output(),
 246            $disco_result,
 247            'proper discovery reply for the virtual clients');
 248
 249         $comp->xml_in(<<DISCO);
 250 <iq type='get'
 251     from='romeo\@montague.lit/orchard'
 252     to='juliet\@$JID'
 253     id='disco1'>
 254     <query xmlns='http://jabber.org/protocol/disco#items' />
 255 </iq>
 256 DISCO
 257         my $disco_items_result = clean_xml(<<DISCO_RESULT);
 258 <iq
 259   from='juliet\@$JID'
 260   id='disco1'
 261   to='romeo\@montague.lit/orchard'
 262   type='result'>
 263     <query xmlns='http://jabber.org/protocol/disco#items'/>
 264 </iq>
 265 DISCO_RESULT
 266
 267         is(output, $disco_items_result,
 268            'proper discovery items reply from the virtual client');
 269
 270     }
 271 }
 272
 273 REGISTRATION: {
 274     CORRECT_REGISTRATION: {
 275         my $comp = connected_component;
 276
 277         my $registration_query = <<REGISTRATION_QUERY;
 278 <iq type='get'
 279     from='romeo\@montague.lit/orchard'
 280     to='$JID'
 281     id='reg1'>
 282   <query xmlns='$NS_REGISTER' />
 283 </iq>
 284 REGISTRATION_QUERY
 285
 286         $comp->xml_in($registration_query);
 287
 288         my $register_query_result = clean_xml(<<DISCO_RESULT);
 289 <iq from='test.transport'
 290     id='reg1'
 291     to='romeo\@montague.lit/orchard'
 292     type='result'>
 293     <query xmlns='jabber:iq:register'>
 294         <instructions>Please provide your username and password for Test</instructions>
 295         <username/>
 296         <password/>
 297     </query>
 298 </iq>
 299 DISCO_RESULT
 300
 301         clear;
 302
 303         # Send back a good username and password
 304         $comp->xml_in(<<GOOD_PASSWORD);
 305 <iq type='set'
 306     from='romeo\@montague.lit/orchard'
 307     to='$JID'
 308     id='reg2'>
 309     <query xmlns='jabber:iq:register'>
 310         <username>RomeoMyRomeo</username>
 311         <password>ILoveJuliet</password>
 312     </query>
 313 </iq>
 314 GOOD_PASSWORD
 315
 316         cmp_deeply($comp->{protocol}->{backend}->{registered},
 317                    {'romeo@montague.lit' => {username => 'RomeoMyRomeo',
 318                      password => 'ILoveJuliet'}});
 319         my $expected = clean_xml(<<EXPECTED);
 320 <iq from='test.transport'
 321     id='reg2'
 322     to='romeo\@montague.lit/orchard'
 323     type='result'/>
 324 <presence from='$JID' to='romeo\@montague.lit' type='subscribe'/>
 325 <presence from='$JID' to='romeo\@montague.lit' type='probe'/>
 326 EXPECTED
 327         is(output, $expected,
 328            'correctly replies that registration is successful');
 329
 330         # Verify the registration info is correct.
 331         $comp->xml_in($registration_query);
 332         $register_query_result = clean_xml(<<REGISTRATION_QUERY_RESULT);
 333 <iq from='test.transport'
 334     id='reg1'
 335     to='romeo\@montague.lit/orchard'
 336     type='result'>
 337     <query xmlns='jabber:iq:register'>
 338         <instructions>Please provide your username and password for Test</instructions>
 339         <registered/>
 340         <username>RomeoMyRomeo</username>
 341         <password>ILoveJuliet</password>
 342     </query>
 343 </iq>
 344 REGISTRATION_QUERY_RESULT
 345
 346         is(output, $register_query_result,
 347            'correctly returns username and password info');
 348         is($comp->{protocol}->{backend}->{registered}->{'romeo@montague.lit/orchard'},
 349            undef, 'protocol doesn\'t register with jid');
 350         cmp_deeply($comp->{protocol}->{backend}->{registered}->{'romeo@montague.lit'},
 351                    {username => 'RomeoMyRomeo',
 352                     password => 'ILoveJuliet'},
 353                    'protocol correctly registers with the backend');
 354
 355         # And now, I can unregister
 356         $comp->xml_in(<<UNREGISTER);
 357 <iq type='get'
 358     from='romeo\@montague.lit/orchard'
 359     to='$JID'
 360     id='reg3'>
 361   <query xmlns='$NS_REGISTER'>
 362     <remove/>
 363   </query>
 364 </iq>
 365 UNREGISTER
 366
 367         $expected = clean_xml(<<UNREGISTRATION);
 368 <iq from='test.transport'
 369     id='reg3'
 370     to='romeo\@montague.lit/orchard'
 371     type='result'/>
 372 <presence from='test.transport'
 373           to='romeo\@montague.lit'
 374           type='unsubscribe'/>
 375 <presence from='test.transport'
 376           to='romeo\@montague.lit'
 377           type='unsubscribed'/>
 378 <presence from='test.transport'
 379           to='romeo\@montague.lit'
 380           type='unavailable'/>
 381 UNREGISTRATION
 382         is(output, $expected,
 383            "unregistering from the transport gets correct XML");
 384         is(undef,
 385            $comp->{protocol}->{backend}->{registered}->{'romeo@montague.lit'},
 386            'protocol unregistered');
 387     }
 388
 389     # This actually covers all the failure code paths in the spec
 390     # for registration; it may document them separately but they
 391     # are the same path
 392     FAILED_REGISTRATION: {
 393         my $comp = connected_component;
 394
 395         # Note we don't actually have to discover the registration
 396         # requirements, we can just know them
 397         $comp->xml_in(<<BAD_PASSWORD);
 398 <iq type='set'
 399     from='romeo\@montague.lit/orchard'
 400     to='$JID'
 401     id='reg2'>
 402     <query xmlns='jabber:iq:register'>
 403         <username>fail</username>
 404         <password>forbidden</password>
 405     </query>
 406 </iq>
 407 BAD_PASSWORD
 408
 409         my $expected_response = clean_xml(<<EXPECTED);
 410 <iq from='test.transport'
 411     id='reg2'
 412     to='romeo\@montague.lit/orchard'
 413     type='error'>
 414     <query xmlns='jabber:iq:register'>
 415         <username>fail</username>
 416         <password>forbidden</password>
 417     </query>
 418     <error code='403' type='auth'><forbidden xmlns='urn:ietf:params:xml:ns:xmpp-stanzas'/></error>
 419 </iq>
 420 EXPECTED
 421         is(clean_xml(output), $expected_response,
 422            'component can handle protocol registration failures');
 423     }
 424
 425     # A real bug encountered by our client; if you send in too
 426     # much information the registration fails miserably.
 427     TOO_DETAILED_REGISTRATION: {
 428         my $comp = connected_component;
 429
 430         # Note we don't actually have to discover the registration
 431         # requirements, we can just know them
 432         $comp->xml_in(<<TMI);
 433 <iq type='set'
 434     from='romeo\@montague.lit/orchard'
 435     to='$JID'
 436     id='reg2'>
 437     <query xmlns='jabber:iq:register'>
 438         <username>RomeoMyRomeo</username>
 439         <nick>Nickname</nick>
 440         <password>ILoveJuliet</password>
 441     </query>
 442 </iq>
 443 TMI
 444
 445         my $expected_response = clean_xml(<<EXPECTED);
 446 <iq from='test.transport'
 447     id='reg2'
 448     to='romeo\@montague.lit/orchard'
 449     type='result'/>
 450 <presence from='$JID' to='romeo\@montague.lit' type='subscribe'/>
 451 <presence from='$JID' to='romeo\@montague.lit' type='probe'/>
 452 EXPECTED
 453
 454         is(output, $expected_response,
 455            'successfully registered with transport with TMI');
 456         my $registration = $comp->{protocol}->{backend}->{registered}->{'romeo@montague.lit'};
 457         cmp_deeply($registration,
 458                    {username => 'RomeoMyRomeo',
 459                     nick => 'Nickname',
 460                     password => 'ILoveJuliet'},
 461                    'protocol correctly registers with the backend');
 462     }
 463 }
 464
 465 LOG_IN: {
 466     # This tests the simple case, where we are directly logging in
 467     # by telling the component we are present.
 468     INITIAL: {
 469         my $comp = get_registered_comp;
 470         $comp->xml_in(<<LOGIN);
 471 <presence from='romeo\@montague.lit/orchard'
 472           to='$JID'/>
 473 LOGIN
 474         is(scalar(@{$comp->{protocol}->{logged_in}}), 1,
 475                   'have a logged in user');
 476         my $expected_response = clean_xml(<<EXPECTED);
 477 <iq from='test.transport'
 478     id='id1'
 479     to='romeo\@montague.lit/orchard'
 480     type='get'>
 481     <query xmlns='http://jabber.org/protocol/disco#info'/>
 482 </iq>
 483 <presence from='test.transport' to='romeo\@montague.lit'/>
 484 EXPECTED
 485         is(output, $expected_response,
 486            'gateway indicated it is online and fired disco query.');
 487     }
 488
 489     BAD_LOGIN: {
 490         my $comp = get_registered_comp;
 491         $comp->xml_in(<<LOGIN);
 492 <presence from='juliet\@capulet.lit' to='$JID'/>
 493 LOGIN
 494         is($comp->{protocol}->{logged_in}, undef,
 495                   'log in failed');
 496         my $expected_response = clean_xml(<<EXPECTED);
 497 <presence from='test.transport'
 498           to='juliet\@capulet.lit'
 499           type='error'>
 500     <error code='504' type='wait'>
 501         <remote-server-timeout xmlns='urn:ietf:params:xml:ns:xmpp-stanzas'/>
 502     </error>
 503 </presence>
 504 EXPECTED
 505
 506         is(output, $expected_response,
 507            'gateway returned error as expected');
 508
 509         $comp = connected_component;
 510         # BAD LOGIN due to corruption in the backend resulting
 511         # in not having all the required pieces. Hack away the
 512         # username for this user.
 513         $comp->{protocol}->registration('romeo@montague.lit',
 514                                         {password => 'ILoveJuliet'});
 515         $comp->xml_in(<<LOGIN);
 516 <presence from='romeo\@montague.lit' to='$JID'/>
 517 LOGIN
 518
 519         is($comp->{protocol}->{logged_in}, undef, 'log in failed');
 520         $expected_response = clean_xml(<<EXPECTED);
 521 <presence from='test.transport'
 522           to='romeo\@montague.lit'
 523           type='error'>
 524     <error code='407' type='auth'>
 525         <registration-required xmlns='urn:ietf:params:xml:ns:xmpp-stanzas'/>
 526     </error>
 527 </presence>
 528 EXPECTED
 529
 530         is(output, $expected_response,
 531            'spontaneously unregistered user with bad reg data');
 532     }
 533 }
 534
 535 LOG_OUT_AND_UNREGISTRATION: {
 536     NORMAL_LOG_OUT: {
 537         # The normal log out procedure
 538         my $comp = logged_in_comp;
 539         $comp->xml_in(<<LOGOUT);
 540 <presence from='romeo\@montague.lit/orchard'
 541           to='$JID'
 542           type='unavailable'/>
 543 LOGOUT
 544
 545         my $expected = clean_xml(<<EXPECTED);
 546 <presence from='test.transport'
 547           to='romeo\@montague.lit'
 548           type='unavailable'/>
 549 EXPECTED
 550         is(output, $expected,
 551            "upon logging out, get expected presence unavailable");
 552         is($comp->session_for('romeo@montague.lit'),
 553            undef, "session has been removed for the user");
 554     }
 555
 556     UNREGISTER_NOT_LOGGED_IN: {
 557         my $comp = get_registered_comp;
 558         $comp->xml_in(<<UNREGISTER);
 559 <iq type='get'
 560     from='romeo\@montague.lit/orchard'
 561     to='$JID'
 562     id='reg3'>
 563   <query xmlns='$NS_REGISTER'>
 564     <remove/>
 565   </query>
 566 </iq>
 567 UNREGISTER
 568
 569         my $expected = clean_xml(<<UNREGISTER);
 570 <iq from='test.transport'
 571     id='reg3'
 572     to='romeo\@montague.lit/orchard'
 573     type='result'/>
 574 <presence from='test.transport'
 575           to='romeo\@montague.lit'
 576           type='unsubscribe'/>
 577 <presence from='test.transport'
 578           to='romeo\@montague.lit'
 579           type='unsubscribed'/>
 580 <presence from='test.transport'
 581           to='romeo\@montague.lit'
 582           type='unavailable'/>
 583 UNREGISTER
 584         is(output, $expected,
 585            "unregistering while not logged in works as expected");
 586     }
 587
 588     # Unregistering while logged in is covered above, in the
 589     # registration sequence
 590
 591     # An error case, basically: The user is unregistering,
 592     # but they aren't registered in the first place.
 593     UNREGISTER_NOT_REGISTERED: {
 594         my $comp = get_registered_comp;
 595         $comp->xml_in(<<UNREGISTER);
 596 <iq type='get'
 597     from='balthasar\@montague.lit/tomb'
 598     to='$JID'
 599     id='reg3'>
 600   <query xmlns='$NS_REGISTER'>
 601     <remove/>
 602   </query>
 603 </iq>
 604 UNREGISTER
 605
 606         my $expected = clean_xml(<<EXPECTED);
 607 <iq from='test.transport'
 608     id='reg3'
 609     to='balthasar\@montague.lit/tomb'
 610     type='error'>
 611     <query xmlns='jabber:iq:register'>
 612         <remove/>
 613     </query>
 614     <error code='407'
 615            type='auth'>
 616         <registration-required xmlns='urn:ietf:params:xml:ns:xmpp-stanzas'/>
 617     </error>
 618 </iq>
 619 EXPECTED
 620         is(clean_xml(output), $expected,
 621            'correct error for unregistering a not-registered user')
 622     }
 623 }
 624
 625 SUBSCRIBING: {
 626     SUCCESS: {
 627         my $comp = logged_in_comp;
 628
 629         my $get_roster = sub {
 630             $comp->{protocol}->{backend}->get_roster('romeo@montague.lit')
 631         };
 632         # Verify the initial roster is empty.
 633         cmp_deeply($get_roster->(), {},
 634                    'initial roster for romeo is confirmed empty');
 635
 636         my $subscribe_xml = <<SUBSCRIBE;
 637 <presence type='subscribe'
 638           from='romeo\@montague.lit'
 639           to='CapuletNurse\@$JID'/>
 640 SUBSCRIBE
 641         $comp->xml_in($subscribe_xml);
 642
 643         my $expected = clean_xml(<<EXPECTED);
 644 <presence from='CapuletNurse\@$JID'
 645           to='romeo\@montague.lit'
 646           type='subscribed'/>
 647 <presence from='CapuletNurse\@$JID'
 648           to='romeo\@montague.lit'
 649           type='subscribe'/>
 650 EXPECTED
 651         is(output, $expected,
 652            'proper response to successful subscriptions');
 653         cmp_deeply($get_roster->(),
 654                    {CapuletNurse => subscribed},
 655                    'correctly subscribed to CapuletNurse');
 656
 657         # Unsubscribing.
 658
 659         my $unsubscribe_xml = <<UNSUBSCRIBE;
 660 <presence type='unsubscribe'
 661           from='romeo\@montague.lit'
 662           to='CapuletNurse\@$JID'/>
 663 UNSUBSCRIBE
 664         $comp->xml_in($unsubscribe_xml);
 665
 666         $expected = clean_xml(<<EXPECTED);
 667 <presence from='romeo\@montague.lit'
 668           to='CapuletNurse\@test.transport'
 669           type='unsubscribe'/>
 670 <presence from='romeo\@montague.lit'
 671           to='CapuletNurse\@test.transport'
 672           type='unsubscribed'/>
 673 <presence from='CapuletNurse\@test.transport'
 674           to='romeo\@montague.lit'
 675           type='unavailable'/>
 676 EXPECTED
 677         is(output, $expected,
 678            'proper response to unsubscriptions');
 679         cmp_deeply($get_roster->(), {},
 680                    'and once again unsubscribed from CapuletNurse');
 681     }
 682
 683     FAILURE: {
 684         my $comp = logged_in_comp;
 685         my $subscribe_xml = <<SUBSCRIBE;
 686 <presence type='subscribe'
 687           from='romeo\@montague.lit'
 688           to='fail\@$JID'/>
 689 SUBSCRIBE
 690         $comp->xml_in($subscribe_xml);
 691         is(output,
 692            "<presence from='fail\@$JID' to='romeo\@montague.lit' "
 693            ."type='unsubscribed'/>",
 694            "correctly responds to failing to subscribe");
 695     }
 696 }
 697
 698 MESSAGES: {
 699     # This should also test an "out-of-the-blue" sending, we try to
 700     # guess the remote transport id even though we don't really
 701     # know. This really shouldn't come up; even if the client
 702     # supports "out-of-the-blue" sending on a transport, it
 703     # should still use the gateway protocol.
 704
 705     my $comp = logged_in_comp;
 706
 707     # FIXME: Address above, think about the next line
 708     $comp->legacy_name_to_xmpp('romeo@montague.lit', 'juliet');
 709
 710     my $message = <<MESSAGE;
 711 <message from='romeo\@montague.lit/orchard'
 712          to='juliet\@$JID'
 713          type='chat'>
 714   <body>Neither, fair saint, if either thee dislike.</body>
 715 </message>
 716 MESSAGE
 717
 718     $comp->xml_in($message);
 719
 720     my $messages = \($comp->session_for('romeo@montague.lit/orchard')->{messages});
 721     cmp_deeply($$messages,
 722                [["juliet", 'Neither, fair saint, if either '
 723                 .'thee dislike.', 'chat']]);
 724     @$$messages = ();
 725
 726     # BAD INPUT: Message bodies with more tags.
 727     # This shouldn't be possible, so the main goal is to
 728     # not crash.
 729     $message = <<MESSAGE;
 730 <message from='romeo\@montague.lit/orchard'
 731          to='juliet\@$JID'
 732          type='chat'>
 733   <body>Neither, <b>fair</b> saint, if either thee dislike.</body>
 734 </message>
 735 MESSAGE
 736     $comp->xml_in($message);
 737     cmp_deeply($$messages,
 738                [["juliet", 'Neither,  saint, if either thee dislike.',
 739                  'chat']],
 740                "don't crash on bad message bodies");
 741
 742     clear_log;
 743     # BAD INPUT: An otherwise-correct message with no body.
 744     $message = <<MESSAGE;
 745 <message from='romeo\@montague.lit/orchard'
 746          to='juliet\@$JID'
 747          type='chat'/>
 748 MESSAGE
 749     $comp->xml_in($message);
 750     logged('Message without usable child',
 751            "doesn't try to process message without body");
 752
 753     # diag("Beginning message type tests");
 754     clear_log();
 755     output();
 756     @{${$messages}} = ();
 757     my $random_type = rand_string(6, [ 'A'..'Z' ]);
 758     $comp->xml_in(<<XML);
 759 <message from='romeo\@montague.lit/orchard'
 760          to='juliet\@$JID'
 761          >
 762   <body>no type</body>
 763 </message>
 764 <message from='romeo\@montague.lit/orchard'
 765          to='juliet\@$JID'
 766          type='$random_type'>
 767   <body>type is a random string</body>
 768 </message>
 769 XML
 770     cmp_deeply(${$messages}->[0],
 771                [ 'juliet', 'no type', 'chat' ],
 772                'no message type => chat');
 773     cmp_deeply(${$messages}->[1],
 774                [ 'juliet', 'type is a random string', $random_type ],
 775                'message type attribute pulled out correctly');
 776     clear_log();
 777     output();
 778     @{${$messages}} = ();
 779     # diag("End of message type tests");
 780
 781     diag("Beginning chatstates parsing tests");
 782     clear_log();
 783     output();
 784     @{${$messages}} = ();
 785     my $chatstates
 786       = $comp->session_for('romeo@montague.lit/orchard')->{chatstates}
 787       = [];
 788     $comp->xml_in(<<XML);
 789 <message from='romeo\@montague.lit/orchard'
 790          to='juliet\@$JID'
 791          >
 792   <body>no chatstates</body>
 793 </message>
 794 XML
 795     cmp_deeply(${$messages}->[0],
 796                [ 'juliet', 'no chatstates', 'chat' ],
 797                'message w/no chatstates: body parsed correctly');
 798     ok(scalar(@{$chatstates}) == 0,
 799        'message w/no chatstates: no chatstate passed');
 800     $comp->xml_in(<<XML);
 801 <message from='romeo\@montague.lit/orchard'
 802          to='juliet\@$JID'
 803          type='chat'>
 804   <active xmlns='http://jabber.org/protocol/chatstates'/>
 805   <body>active chatstate and body</body>
 806 </message>
 807 <message from='romeo\@montague.lit/orchard'
 808          to='juliet\@$JID'
 809          type='chat'>
 810   <composing xmlns='http://jabber.org/protocol/chatstates'/>
 811 </message>
 812 XML
 813     cmp_deeply(${$messages}->[1],
 814                [ 'juliet', 'active chatstate and body', 'chat' ],
 815                'message w/body and chatstate: body parsed correctly');
 816     is($chatstates->[0],
 817        'active',
 818        'message w/body and chatstate: chatstate parsed correctly');
 819     ok(! exists(${$messages}->[2]),
 820        'message w/chatstate but no body: no message sent');
 821     is($chatstates->[1],
 822        'composing',
 823        'message w/chatstate but no body: chatstate handled');
 824     clear_log();
 825     output();
 826     @{${$messages}} = ();
 827     delete($comp->session_for('romeo@montague.lit/orchard')->{chatstates});
 828     diag("End of chatstates parsing tests");
 829
 830     # Fake up an error to see that we handle that correctly
 831     $message = <<MESSAGE;
 832 <message from='romeo\@montague.lit/orchard'
 833          to='juliet\@$JID'
 834          type='chat'>
 835   <body>Error: item_not_found</body>
 836 </message>
 837 MESSAGE
 838
 839     $comp->xml_in($message);
 840     my $result = clean_xml(<<RESULT);
 841 <message from='juliet\@test.transport'
 842          to='romeo\@montague.lit/orchard'
 843          type='error'>
 844     <error code='404' type='cancel'>
 845         <item-not-found xmlns='urn:ietf:params:xml:ns:xmpp-stanzas'/>
 846     </error>
 847 </message>
 848 RESULT
 849     is(output, $result,
 850        "message errors correctly sends out error packets");
 851
 852     # BAD INPUT: Sending a message when the component doesn't
 853     # know who you are sends back an error message
 854     $message = <<MESSAGE;
 855 <message from='steel\@flenser.tine'
 856          to='juliet\@test.transport'
 857          type='chat'>
 858     <body>Hey, what are you doing in my reality?</body>
 859 </message>
 860 MESSAGE
 861     $comp->xml_in($message);
 862
 863     $result = clean_xml(<<RESULT);
 864 <message from='juliet\@test.transport'
 865          to='steel\@flenser.tine'
 866          type='error'>
 867     <error code='407' type='auth'>
 868         <registration-required xmlns='urn:ietf:params:xml:ns:xmpp-stanzas'/>
 869     </error>
 870     <body>Hey, what are you doing in my reality?</body>
 871 </message>
 872 RESULT
 873     is(output, $result,
 874        'error message when sending messages and not registered is correct');
 875
 876 }
 877
 878 PROTOCOL_TESTS:
 879 {
 880     # Main flow of a subscription request: Permit it
 881     SUBSCRIPTION_PERMITTED: {
 882         my $comp = logged_in_comp;
 883         my $get_roster = sub {
 884             $comp->{protocol}->{backend}->get_roster('romeo@montague.lit')
 885         };
 886         my $protocol = $comp->{protocol};
 887         $protocol->adding_contact('juliet', 'romeo@montague.lit');
 888         is(output,
 889            "<presence from='juliet\@$JID' to='romeo\@montague.lit' type='subscribe'/>",
 890            "correct reflects legacy subscription requests to user");
 891
 892         cmp_deeply($get_roster->(),
 893                    {'juliet@test.transport' => want_subscribe},
 894                    'correctly recorded that juliet wants a subscription');
 895
 896         my $session =
 897             $comp->session_for('romeo@montague.lit/orchard');
 898         is($session->{subscribed}->{'juliet'}, undef);
 899         my $subscribed = <<SUBSCRIBED;
 900 <presence from='romeo\@montague.lit/orchard'
 901           to='juliet\@$JID'
 902           type='subscribed'/>
 903 SUBSCRIBED
 904         $comp->xml_in($subscribed);
 905         is($session->{subscribed}->{'juliet'}, 'subscribed',
 906            'correctly handles subscription acceptance requests');
 907         print Dumper($get_roster->());
 908         cmp_deeply($get_roster->(),
 909                    {'juliet@test.transport' => subscribed},
 910                    'correctly notes juliet as subscribed');
 911
 912         my $expected_subscription = clean_xml(<<EXPECTED);
 913 <presence from='juliet\@$JID'
 914           to='romeo\@montague.lit'
 915           type='subscribed'/>
 916 <presence from='juliet\@$JID'
 917           to='romeo\@montague.lit'>
 918     <show>Online</show>
 919 </presence>
 920 EXPECTED
 921
 922         is(output, $expected_subscription,
 923            'gateway correctly says the other user is '
 924            .'subscribed');
 925     }
 926
 927     # Test 5.1.2, where the foreign user requests a subscription
 928     # and the XMPP user says no
 929     SUBSCRIPTION_REJECTED: {
 930         my $comp = logged_in_comp;
 931         my $get_roster = sub {
 932             $comp->{protocol}->{backend}->get_roster('romeo@montague.lit')
 933         };
 934         my $protocol = $comp->{protocol};
 935
 936         $protocol->adding_contact('juliet', 'romeo@montague.lit');
 937         clear;
 938
 939         print Dumper($get_roster->());
 940         cmp_deeply($get_roster->(), {'juliet@test.transport' => want_subscribe});
 941
 942         my $unsubscribed = <<UNSUBSCRIBED;
 943 <presence from='romeo\@montague.lit/orchard'
 944           to='juliet\@$JID'
 945           type='unsubscribed'/>
 946 UNSUBSCRIBED
 947         $comp->xml_in($unsubscribed);
 948
 949         my $session =
 950             $comp->session_for('romeo@montague.lit/orchard');
 951
 952         print Dumper($get_roster->());
 953         cmp_deeply($get_roster->(), {},
 954                    'rejected subscriptions go back to not subscribed');
 955
 956         is($session->{subscribed}->{'juliet'}, 'unsubscribed',
 957            'correctly rejects subscription requests');
 958     }
 959
 960     LEGACY_UNSUBSCRIPTION: {
 961         my $comp = logged_in_comp;
 962         my $protocol = $comp->{protocol};
 963         my $session = $comp->session_for('romeo@montague.lit/orchard');
 964
 965         # Bit of a cheat here; we aren't actually "subscribed"
 966         $protocol->deleting_contact('juliet', 'RomeoMyRomeo');
 967         my $expected = clean_xml(<<EXPECTED);
 968 <presence from='juliet\@$JID'
 969           to='romeo\@montague.lit'
 970           type='unsubscribe'/>
 971 <presence from='juliet\@$JID'
 972           to='romeo\@montague.lit'
 973           type='unsubscribed'/>
 974 <presence from='juliet\@$JID'
 975           to='romeo\@montague.lit'
 976           type='unavailable'/>
 977 EXPECTED
 978         is(output, $expected,
 979            'correct XML emitted when a user unsubscribes.');
 980     }
 981
 982     # oh, yeah, right, did we want to receive legacy user's messages?
 983     MESSAGE: {
 984         my $comp = logged_in_comp;
 985         my $protocol = $comp->{protocol};
 986         $protocol->sending_message('juliet', 'RomeoMyRomeo',
 987                                    'sucks!');
 988         my $expected = clean_xml(<<EXPECTED);
 989 <message from='juliet\@$JID' to='romeo\@montague.lit' type='chat'>
 990     <body>sucks!</body>
 991     <active xmlns='http://jabber.org/protocol/chatstates'/>
 992 </message>
 993 EXPECTED
 994         is(output, $expected,
 995            'correctly sends a message when we receive one');
 996     }
 997 }
 998
 999 GATEWAY_PROTOCOL: {
1000     my $comp = logged_in_comp;
1001     my $protocol = $comp->{protocol};
1002
1003     my $query = <<QUERY;
1004 <iq from='romeo\@montague.lit' to='$JID' type='get' id='one'>
1005   <query xmlns='$NS_GATEWAY'/>
1006 </iq>
1007 QUERY
1008
1009     $comp->xml_in($query);
1010     my $expected = clean_xml(<<EXPECTED);
1011 <iq from='$JID' id='one' to='romeo\@montague.lit' type='result'>
1012   <query xmlns='$NS_GATEWAY'>
1013     <prompt>Prompt en</prompt>
1014   </query>
1015 </iq>
1016 EXPECTED
1017
1018     is(output, $expected);
1019
1020     $protocol->{gateway_desc} = 'Desc';
1021     $comp->xml_in($query);
1022     $expected = clean_xml(<<EXPECTED);
1023 <iq from='$JID' id='one' to='romeo\@montague.lit' type='result'>
1024
1025   <query xmlns='$NS_GATEWAY'>
1026     <prompt>Prompt en</prompt>
1027     <desc>Desc</desc>
1028   </query>
1029 </iq>
1030 EXPECTED
1031     is(output, $expected);
1032
1033     clear;
1034     # I think this is the right place for the XML lang
1035     my $lang_query = <<QUERY;
1036 <iq from='romeo\@montague.lit' to='$JID' type='get' id='one' xml:lang='fr'>
1037   <query xmlns='$NS_GATEWAY'/>
1038 </iq>
1039 QUERY
1040     $comp->xml_in($lang_query);
1041     $expected = clean_xml(<<EXPECTED);
1042 <iq from='$JID' id='one' to='romeo\@montague.lit' type='result'>
1043   <query xmlns='$NS_GATEWAY'>
1044     <prompt>Prompt fr</prompt>
1045     <desc>Desc</desc>
1046   </query>
1047 </iq>
1048 EXPECTED
1049     is(output, $expected, 'langs handled as expected');
1050
1051     # Test the translation
1052     $query = <<QUERY;
1053 <iq from='romeo\@montague.lit' to='$JID' type='get' id='two'>
1054   <query xmlns='$NS_GATEWAY'>
1055     <prompt>marklar\@schmoo.hut</prompt>
1056   </query>
1057 </iq>
1058 QUERY
1059     $comp->xml_in($query);
1060
1061     $expected = clean_xml(<<EXPECTED);
1062 <iq from='$JID' id='two' to='romeo\@montague.lit' type='result'>
1063   <query xmlns='$NS_GATEWAY'>
1064     <jid>marklar\%schmoo.hut\@test.transport</jid>
1065     <prompt>marklar\%schmoo.hut\@test.transport</prompt>
1066   </query>
1067 </iq>
1068 EXPECTED
1069     is(output, $expected);
1070
1071     is($comp->{protocol}->{backend}->{jid_to_legacy}
1072        ->{'romeo@montague.lit'}->{'marklar%schmoo.hut@test.transport'},
1073        'marklar@schmoo.hut');
1074     is($comp->{protocol}->{backend}->{legacy_to_jid}
1075        ->{'romeo@montague.lit'}->{'marklar@schmoo.hut'},
1076        'marklar%schmoo.hut@test.transport');
1077
1078     clear;
1079
1080     # Check whether JID dupes get handled correctly
1081     $query = <<QUERY;
1082 <iq from='romeo\@montague.lit' to='$JID' type='get' id='two'>
1083   <query xmlns='$NS_GATEWAY'>
1084     <prompt>marklar\%schmoo.hut</prompt>
1085   </query>
1086 </iq>
1087 QUERY
1088     $comp->xml_in($query);
1089     $expected = clean_xml(<<EXPECTED);
1090 <iq from='$JID' id='two' to='romeo\@montague.lit' type='result'>
1091   <query xmlns='$NS_GATEWAY'>
1092     <jid>marklar\%schmoo.hut2\@test.transport</jid>
1093     <prompt>marklar\%schmoo.hut2\@test.transport</prompt>
1094   </query>
1095 </iq>
1096 EXPECTED
1097     is(output, $expected);
1098
1099     # Check that the JIDs stay stable
1100     $query = <<QUERY;
1101 <iq from='romeo\@montague.lit' to='$JID' type='get' id='two'>
1102   <query xmlns='$NS_GATEWAY'>
1103     <prompt>marklar\%schmoo.hut</prompt>
1104   </query>
1105 </iq>
1106 QUERY
1107     $comp->xml_in($query);
1108     $expected = clean_xml(<<EXPECTED);
1109 <iq from='$JID' id='two' to='romeo\@montague.lit' type='result'>
1110   <query xmlns='$NS_GATEWAY'>
1111     <jid>marklar\%schmoo.hut2\@test.transport</jid>
1112     <prompt>marklar\%schmoo.hut2\@test.transport</prompt>
1113   </query>
1114 </iq>
1115 EXPECTED
1116     is(output, $expected,
1117        'gateway protocol-selected JIDs stay stable');
1118
1119
1120     # Bad input: Incorrect query with no prompt gets error
1121     my $bad_query = <<BAD;
1122 <iq from='romeo\@montague.lit' to='$JID' type='get' id='two'>
1123   <query xmlns='$NS_GATEWAY'>
1124     <bangleford/>
1125   </query>
1126 </iq>
1127 BAD
1128
1129     $comp->xml_in($bad_query);
1130     $expected = clean_xml(<<EXPECTED);
1131 <iq from='$JID' id='two' to='romeo\@montague.lit' type='error'>
1132   <query xmlns='$NS_GATEWAY'>
1133     <bangleford/>
1134   </query>
1135   <error code='400' type='modify'>
1136       <bad-request xmlns='urn:ietf:params:xml:ns:xmpp-stanzas'/>
1137   </error>
1138 </iq>
1139 EXPECTED
1140     is(clean_xml(output), $expected,
1141        'properly handles errors');
1142 }
1143
1144 # Now that the gateway protocol is tested, verify that we can use
1145 # it to make subscriptions to foreign users.
1146 WITH_CONTACTS: {
1147     SUBSCRIBE_WHILE_NOT_LOGGED_IN: {
1148         my $comp = get_registered_comp;
1149         # Get the ID for the subscription
1150         my $initial_gateway_query = <<GATEWAY_QUERY;
1151 <iq from='romeo\@montague.lit' to='$JID' type='get' id='two'>
1152   <query xmlns='$NS_GATEWAY'>
1153     <prompt>marklar\@schmoo.hut</prompt>
1154   </query>
1155 </iq>
1156 GATEWAY_QUERY
1157         $comp->xml_in($initial_gateway_query);
1158
1159         # We already tested this above, assume we got
1160         # marklar%schmoo.hut .
1161         clear;
1162
1163         my $add_subscription = <<SUBSCRIPTION;
1164 <presence from='romeo\@montague.lit'
1165           to='marklar\%schmoo.hut\@$JID'
1166           type='subscribed'/>
1167 SUBSCRIPTION
1168         $comp->xml_in($add_subscription);
1169
1170         my $expected = clean_xml(<<EXPECTED);
1171 <presence from='test.transport'
1172           to='romeo\@montague.lit'
1173           type='error'>
1174     <error code='401' type='auth'>
1175         <not-authorized xmlns='urn:ietf:params:xml:ns:xmpp-stanzas'/>
1176     </error>
1177 </presence>
1178 EXPECTED
1179
1180         # currently disabled in Thrasher::Component:
1181         # "This gets sent out after logging off..."
1182         is(output, $expected, 'correct error when trying to '
1183            .'subscribe without being logged in');
1184     }
1185
1186     SUBSCRIBE_WHILE_LOGGED_IN: {
1187         my $comp = logged_in_comp;
1188         # Get the ID for the subscription
1189         my $initial_gateway_query = <<GATEWAY_QUERY;
1190 <iq from='romeo\@montague.lit' to='$JID' type='get' id='two'>
1191   <query xmlns='$NS_GATEWAY'>
1192     <prompt>marklar\@schmoo.hut</prompt>
1193   </query>
1194 </iq>
1195 GATEWAY_QUERY
1196         $comp->xml_in($initial_gateway_query);
1197
1198         # We already tested this above, assume we got
1199         # marklar%schmoo.hut .
1200         clear;
1201
1202         my $add_subscription = <<SUBSCRIPTION;
1203 <presence from='romeo\@montague.lit'
1204           to='marklar\%schmoo.hut\@$JID'
1205           type='subscribed'/>
1206 SUBSCRIPTION
1207         $comp->xml_in($add_subscription);
1208
1209         # Note that the "online" comes from the Test
1210         # protocol itself.
1211         my $expected = clean_xml(<<EXPECTED);
1212 <presence from='marklar\%schmoo.hut\@test.transport'
1213           to='romeo\@montague.lit'
1214           type='subscribed'/>
1215 <presence from='marklar\%schmoo.hut\@test.transport'
1216           to='romeo\@montague.lit'>
1217     <show>Online</show>
1218 </presence>
1219 EXPECTED
1220         is(output, $expected, "got correct response for subscription");
1221     }
1222
1223     UNSUBSCRIBE_WHILE_UNKNOWN: {
1224         my $comp = get_registered_comp;
1225         # Unsubscribe from somebody I'm not subscribed to.
1226         # This is an error condition, but I'm trying to handle it.
1227         my $unsubscribe = <<UNSUBSCRIBE;
1228 <presence from='romeo\@montague.lit'
1229           to='nobody\@$JID'
1230           type='unsubscribe'/>
1231 UNSUBSCRIBE
1232         clear;
1233         $comp->xml_in($unsubscribe);
1234         my $expected = clean_xml(<<EXPECTED);
1235 <presence from='nobody\@$JID'
1236           to='romeo\@montague.lit'
1237           type='unsubscribed'/>
1238 EXPECTED
1239         is(output, $expected,
1240            "can correctly unsubscribe people I don't even know about");
1241     }
1242 }
1243
1244 VARIOUS_ERRORS: {
1245     my $comp = logged_in_comp;
1246
1247     # Unexpected iq - get error
1248     my $unexpected = <<UNEXPECTED;
1249 <iq from='romeo\@montague.lit' to='$JID' type='get' id='a'>
1250   <query xmlns='complete:gibberish'/>
1251 </iq>
1252 UNEXPECTED
1253
1254     $comp->xml_in($unexpected);
1255     my $expected = <<EXPECTED;
1256 <iq from='$JID' id='a' to='romeo\@montague.lit' type='error'>
1257   <ns1:query xmlns:ns1='complete:gibberish'/>
1258   <error code='503' type='cancel'>
1259     <service-unavailable xmlns='$NS_ERROR'/>
1260   </error>
1261 </iq>
1262 EXPECTED
1263     is(clean_xml(output),
1264        clean_xml($expected),
1265        "properly handles IQs of a namespace I don't understand");
1266 }
1267
1268 OTHER_XEP_SUPPORT: {
1269     XEP_0090: {
1270         # Time support
1271         my $comp = logged_in_comp;
1272         my $query = <<QUERY;
1273 <iq from='romeo\@montague.lit' to='$JID' type='get' id='a'>
1274   <query xmlns='$NS_TIME'/>
1275 </iq>
1276 QUERY
1277         $comp->xml_in($query);
1278         my $response = output;
1279         ok($response =~ m|\<iq from='$JID' id='a' to='romeo\@montague.lit' type='result'\>\<query xmlns='$NS_TIME'\>\<utc\>\d{8}T\d\d:\d\d:\d\d\<\/utc\>\<\/query\>\<\/iq\>|,
1280            'got a time as expected');
1281     }
1282
1283     XEP_0092: {
1284         # Version support
1285         my $comp = logged_in_comp;
1286         my $query = <<QUERY;
1287 <iq from='romeo\@montague.lit' to='$JID' type='get' id='a'>
1288   <query xmlns='$NS_VERSION'/>
1289 </iq>
1290 QUERY
1291
1292         $comp->xml_in($query);
1293         my $expected = clean_xml(<<EXPECTED);
1294 <iq from='$JID' id='a' to='romeo\@montague.lit' type='result'>
1295   <query xmlns='$NS_VERSION'>
1296     <name>Thrasher - $comp->{component_name}</name>
1297     <version>$Thrasher::VERSION</version>
1298   </query>
1299 </iq>
1300 EXPECTED
1301         is(output, $expected,
1302            'correctly responds to version requests');
1303     }
1304 }
1305
1306 # Simulate what happens when the protocol disconnects from us; verify
1307 # the transport immediately tries to re-login if we're connected,
1308 # but doesn't try to re-login if we're not.
1309 PROTOCOL_DISCONNECTED: {
1310     my $comp = logged_in_comp;
1311     my $session = $comp->session_for('romeo@montague.lit');
1312
1313     is($session->{protocol_state}, 'online',
1314        "we're showing as online as I expect");
1315     $comp->{protocol}->disconnecting($session);
1316     is($session->{protocol_state}, 'online',
1317        "still online after a second connection");
1318     logged("unexpectedly dropped, scheduling re-connection",
1319            "correctly re-established the connection after "
1320            ."unexpected droppage");
1321 }
1322
1323 # Checking sending messages, especially with XHTML-ish on.
1324 SENDING_MESSAGES: {
1325     my $comp = logged_in_comp;
1326
1327     $comp->send_message('romeo@montague.lit',
1328                         'juliet@capulet.lit',
1329                         "look, to hell with this shakespeare stuff "
1330                         ."lets screw",
1331                         {nick => 'romeo'});
1332     my $expected = clean_xml(<<EXPECTED);
1333 <message from='romeo\@montague.lit'
1334          to='juliet\@capulet.lit'
1335          type='chat'>
1336     <body>look, to hell with this shakespeare stuff lets screw</body>
1337     <nick xmlns='http://jabber.org/protocol/nick'>romeo</nick>
1338 </message>
1339 EXPECTED
1340
1341     is(output, $expected, "message without xhtml works");
1342
1343     $comp->send_message('juliet@capulet.lit',
1344                         'romeo@montague.lit',
1345                         "<h1>hell yeah</h1>\n\n<p>been waiting to "
1346                         ."hear you say that for hundreds of years",
1347                         {is_xhtml_ish => 1});
1348     $expected = clean_xml(<<EXPECTED);
1349 <message from='juliet\@capulet.lit'
1350          to='romeo\@montague.lit'
1351          type='chat'>
1352     <body>hell yeah
1353
1354 been waiting to hear you say that for hundreds of years</body>
1355     <html xmlns='http://jabber.org/protocol/xhtml-im'>
1356         <body xmlns='http://www.w3.org/1999/xhtml'>
1357             <h1>hell yeah</h1>
1358
1359             <p>been waiting to hear you say that for hundreds of years</p>
1360         </body>
1361     </html>
1362 </message>
1363 EXPECTED
1364
1365      is(clean_xml(output), $expected,
1366         'xhtml output works as expected');
1367
1368 }