perl/lib/Thrasher/Protocol/Purple.pm

   1 package Thrasher::Protocol::Purple;
   2 use strict;
   3 use warnings;
   4
   5 =head1 NAME
   6
   7 Thrasher::Protocol::Purple - test protocol for Thrasher Bird
   8
   9 =head1 DESCRIPTION
  10
  11 This package is the base class for protocols using libpurple.
  12 Each protocol may have slightly different details w.r.t. how they work
  13 with Thrasher, which is handled by specializing them further,
  14 such as with Thrasher::Protocol::Purple::AIM. As you find such
  15 differences, please be sure to add hooks in here, not hack on
  16 this module directly.
  17
  18 =cut
  19
  20 use base 'Thrasher::Protocol';
  21
  22 use Thrasher::Component qw(strip_resource);
  23 use Thrasher::Log qw(log logger debug);
  24 use Thrasher::Roster;
  25 use Thrasher::Session;
  26 use Thrasher::XMPPStreamIn;
  27 use Glib qw(G_PRIORITY_DEFAULT);
  28 use Carp qw(confess);
  29 use Data::Dumper;
  30 use Switch;
  31 use Encode;
  32
  33 use Thrasher::Protocol::Purple::Vars qw(:all);
  34 use THPPW;
  35
  36 # Plugins we use
  37 use Thrasher::Plugin::Vcard;
  38 use Thrasher::Plugin::EntityCapabilities;
  39
  40 my $DEBUG = 1;
  41
  42 # Initialize the wrapper
  43 THPPW::thrasher_wrapper_init
  44     (Thrasher::error_wrap("timeout_add", \&_timeout_add),
  45      Thrasher::error_wrap("input_add", \&_input_add),
  46      Thrasher::error_wrap("source_remove", \&_source_remove),
  47      Thrasher::error_wrap("incoming_msg", \&_incoming_msg),
  48      Thrasher::error_wrap("presence_in", \&_presence_in),
  49      Thrasher::error_wrap("subscription_add", \&_subscription_add),
  50      Thrasher::error_wrap("legacy_user_adding_user", \&_legacy_user_adding_user),
  51      Thrasher::error_wrap("connection_error", \&_connection_error),
  52      Thrasher::error_wrap("connection", \&_connection),
  53      Thrasher::error_wrap("incoming_chatstate", \&_incoming_chatstate),
  54 );
  55
  56
  57 # Internal debugging
  58 THPPW::thrasher_purple_debug($DEBUG);
  59
  60 # Initialize the remainder
  61 THPPW::thrasher_init();
  62
  63 # Globalize component object so we can receive messages
  64 our $global_component;
  65
  66 sub event_loop {
  67     return 'Thrasher::EventLoop::Glib';
  68 }
  69
  70 # This internal routine allows us to group the initial
  71 # subscribe additions and throw them back.
  72 sub _initial_roster {
  73     my $session = shift;
  74
  75     if (! $session || !$session->{'jid'}) {
  76         debug("_initial_roster: No session. Must be post-logoff?");
  77         return 0;
  78     }
  79
  80     debug("_initial_roster($session->{jid}) called\n");
  81
  82     my $roster;
  83
  84     foreach my $username (keys %{$session->{initial_roster}}) {
  85         $username = $session->{protocol}->process_remote_username($username);
  86         $roster->{$username} = Thrasher::Roster::subscribed();
  87         # We should also handle presence info here (?)
  88     }
  89
  90     $session->{protocol}->set_current_legacy_roster($session, $roster);
  91
  92     delete $session->{initial_roster_timeout_active};
  93     $session->{initial_roster} = [];
  94
  95     # Thrasher can now be sure the protocol is completely online and
  96     # ready to e.g. send IMs queued while login was in progress.
  97     if ($session->{'protocol_state'} eq 'logging in') {
  98         $session->{'protocol'}->set_session_state($session, 'online');
  99     }
 100
 101     # We don't want the timeout to loop, so destroy with 0
 102     return 0;
 103 }
 104
 105 # This appears to only be called for things on our initial roster.
 106 # FIXME: If that's true, change this.
 107 sub _subscription_add {
 108     my $orig_jid    = shift;
 109     my $orig_sender = shift;
 110     my $status = shift;
 111
 112     my $jid = Encode::decode("UTF-8", $orig_jid);
 113     my $sender = Encode::decode("UTF-8", $orig_sender);
 114
 115     debug("_subscription_add($orig_jid, $orig_sender) called\n");
 116
 117     my $session = $global_component->session_for($jid);
 118
 119     # Set a timeout if we have no previous jid information
 120     if (not defined $session->{initial_roster}) {
 121
 122         # Set a flag so we don't push subscription additions
 123         # to an unused array
 124         $session->{initial_roster_timeout_active} = 1;
 125
 126         # Heuristically manage our initial roster as we cannot
 127         # tell when the libpurple protocols are done giving us the
 128         # subscribe user list.
 129         Glib::Timeout->add(5000,
 130                            \&_initial_roster,
 131                            $session,
 132                            G_PRIORITY_DEFAULT);
 133     }
 134
 135     # Verify we're actually within a timeout
 136     if ($session->{initial_roster_timeout_active}) {
 137         # This is a bit ugly, but it allows us to bind sender/status
 138         # info to JIDs for timeouts
 139         $session->{initial_roster}{$sender} = $status;
 140     }
 141     # We aren't in a timeout, we need to send new subscribe info up
 142     else {
 143     }
 144
 145     # Subscription-in information has the presence information
 146     # loaded onto it too, at least for AIM
 147     if ($status) {
 148         _presence_in($orig_jid, $orig_sender, undef, undef, $status);
 149     }
 150
 151     debug("_subscription_add done\n");
 152
 153     return 1;
 154 }
 155
 156 sub _legacy_user_adding_user {
 157     my $jid_target = shift;
 158     my $legacy_username_adding = shift;
 159
 160     $jid_target = Encode::decode("UTF-8", $jid_target);
 161     $legacy_username_adding = Encode::decode("UTF-8", $legacy_username_adding);
 162
 163     log("$legacy_username_adding requesting add for $jid_target");
 164
 165     my $session = $global_component->session_for($jid_target);
 166
 167     if ($session) {
 168         $session->{protocol}->adding_contact($legacy_username_adding,
 169                                              $jid_target);
 170     } else {
 171         log("Got request to add user $jid_target, but $jid_target is "
 172             ."not logged in.");
 173     }
 174 }
 175
 176 sub process_message { return $_[1]; }
 177 sub process_remote_username { return $_[1]; }
 178
 179 # Callback of presence in
 180 sub _presence_in {
 181     my $jid     = shift;
 182     my $sender  = shift;
 183     my $alias   = shift;
 184     my $group   = shift;
 185     my $status  = shift;
 186     my $message = shift;
 187
 188     $jid = Encode::decode("UTF-8", $jid);
 189     $sender = Encode::decode("UTF-8", $sender);
 190     $alias = Encode::decode("UTF-8", $alias);
 191     $group = Encode::decode("UTF-8", $group);
 192     $status = Encode::decode("UTF-8", $status);
 193     $message = Encode::decode("UTF-8", $message);
 194
 195     debug("_presence_in($jid, $sender, $status) called\n");
 196
 197     my $session = $global_component->session_for($jid);
 198     my $self = $session->{protocol};
 199     if (!defined($self)) {
 200         debug("No session defined for $jid, must be post-logoff?");
 201         return 0;
 202     }
 203
 204     my $clean_sender = $self->process_remote_username($sender);
 205
 206     # Nothing is done with protocol?
 207     if ($status eq $purple_presence{offline}) {
 208         $self->legacy_presence_update
 209             ($session, $clean_sender, 'unavailable',
 210              '', $message);
 211     }
 212     elsif ($status eq $purple_presence{'available'}) {
 213         $self->legacy_presence_update
 214             ($session, $clean_sender, '',
 215              '', $message);
 216     }
 217     elsif ($status eq $purple_presence{'away'}) {
 218         $self->legacy_presence_update
 219             ($session, $clean_sender, '',
 220              'away', $message);
 221     }
 222     elsif ($status eq $purple_presence{'xaway'}) {
 223         $self->legacy_presence_update
 224             ($session, $clean_sender, '',
 225              'xa', $message);
 226     }
 227     else {
 228         log("Unknown presence status of $status was sent by "
 229             ."$clean_sender to $jid.");
 230         return 0;
 231     }
 232
 233     debug("_presence_in done\n");
 234     return 1;
 235 }
 236
 237 sub _incoming_chatstate {
 238     my ($orig_jid, $orig_sender, $state) = @_;
 239     debug("_incoming_chatstate($orig_jid, $orig_sender, $state) called\n");
 240
 241     my $state_tag;
 242     # loosely <http://xmpp.org/extensions/xep-0085.html>
 243     if ($state == $THPPW::PURPLE_TYPING) {
 244         $state_tag = 'composing';
 245     }
 246     elsif ($state == $THPPW::PURPLE_TYPED) {
 247         $state_tag = 'paused';
 248     }
 249     elsif ($state == $THPPW::PURPLE_NOT_TYPING) {
 250         $state_tag = 'inactive';
 251     }
 252     else {
 253         return;
 254     }
 255
 256     my $jid = Encode::decode('UTF-8', $orig_jid);
 257     my $sender = Encode::decode('UTF-8', $orig_sender);
 258
 259     my $session = $global_component->session_for($jid);
 260     if (! $session) {
 261         debug("No session?!!\n");
 262         return;
 263     }
 264     if (! $session->{'protocol'}) {
 265         debug("No session protocol?!!\n");
 266         return;
 267     }
 268     $session->{'protocol'}->incoming_chatstate($session, $sender, $state_tag);
 269     return;
 270 }
 271
 272 sub _connection {
 273     my ($orig_jid) = @_;
 274     my $jid = Encode::decode("UTF-8", $orig_jid);
 275     debug("_connection($jid) called\n");
 276
 277     my $session = $global_component->session_for($jid);
 278     if (! $session) {
 279         # Component::logout and thrasher.c:thrasher_logout() will
 280         # happily destroy the session and thrasher_connection while
 281         # libpurple is waiting asynchronously for connection events.
 282         # Once the connection completes and libpurple starts firing
 283         # callbacks, weird errors arise because the session is gone
 284         # and Thrasher has lost track of what is connected.
 285         #
 286         # Maybe we should reject the logout and defer it to
 287         # _connection{,_error}, relying on one of them always being
 288         # called eventually?
 289         log("_connection($jid): No session? Assuming already logged out.");
 290         # Ensure the thrasher_connection gets gone.
 291         Glib::Timeout->add(1,
 292                            sub {
 293                                # Log off just after logon finishes, not during.
 294                                #
 295                                # Turns out purple_connection_set_state()
 296                                # (which called the connected ui_op) crashes
 297                                # if prpl_info is yanked out from under it.
 298                                THPPW::thrasher_action_logout($orig_jid);
 299                            },
 300                            undef,
 301                            G_PRIORITY_DEFAULT);
 302         return 1;
 303     }
 304
 305     my $protocol = $session->{'protocol'};
 306     if (! $protocol) {
 307         log("_connection($jid): No protocol?!!");
 308         return 0;
 309     }
 310
 311     $session->{'purple_connection_created'} = 1;
 312     my $continuation = delete($session->{'connection_cb'});
 313     if ($continuation) {
 314         $continuation->($session);
 315     }
 316     else {
 317         log("_connection($jid): No connection_cb?!!");
 318         return 0;
 319     }
 320
 321     # But libpurple prpl might not be ready to send IMs queued during
 322     # login. Wait until _initial_roster() for online protocol_state.
 323     Glib::Timeout->add(
 324         # If after no _subscription_add()/_initial_roster() happens
 325         # (perhaps the account has no current legacy roster at all?)
 326         # ensure session is eventually set online anyway.
 327         15000,
 328         sub {
 329             if (! $session->{'initial_roster_timeout_active'}
 330                   && ! $session->{'initial_roster'}
 331                   && $session->{'protocol_state'} eq 'logging in') {
 332                 debug("Never called _initial_roster($session->{jid})?\n");
 333                 $protocol->set_session_state($session, 'online');
 334             }
 335             return 0; # No repeat
 336         },
 337         undef,
 338         G_PRIORITY_DEFAULT
 339     );
 340
 341     return 1;
 342 }
 343
 344 sub _connection_error {
 345     my $jid        = shift;
 346     my $error_code = shift;
 347     my $message    = shift;
 348
 349     $jid = Encode::decode("UTF-8", $jid);
 350     $message = Encode::decode("UTF-8", $message);
 351
 352     debug("_connection_error($jid)\n");
 353
 354     my $session = $global_component->session_for($jid);
 355     if (! $session) {
 356         log("No session?!! Error was $error_code/'$message'.");
 357         return 0;
 358     }
 359     my $protocol = $session->{protocol};
 360
 361     my $attempt_reconnect = 0;
 362     my $error = '';
 363
 364     if ($session->{status} =~ /disconnecting/) {
 365         log("Got error code $error_code, but ignoring it since "
 366             ."we're in the middle of disconnecting.");
 367         return 1;
 368     }
 369
 370     # Some of these cases are poorly tested since it's either
 371     # hard or borderline impossible for them to occur.
 372     # We also have to think about whether to attempt reconnection
 373     # or not.
 374     switch ($error_code) {
 375         case ($ERROR_NETWORK_ERROR) {
 376             $protocol->network_error($jid);
 377             $error = "Network error, attempting reconnection";
 378             $attempt_reconnect = 1;
 379         }
 380         case ($ERROR_INVALID_USERNAME) {
 381             $protocol->invalid_username($jid);
 382             $error = "Remote server reports invalid username; please reregister";
 383         }
 384         case ($ERROR_AUTHENTICATION_FAILED) {
 385             $protocol->wrong_authentication($jid);
 386             $error = "Username or password invalid; please register with correct information";
 387         }
 388         case ($ERROR_AUTHENTICATION_IMPOSSIBLE) {
 389             $protocol->_handle_error
 390                 ($jid, 'Thrasher Bird can not negotiate an '
 391                  .'authentication technique with the remote '
 392                  .'service', 'service_unavailable');
 393             # This is a bad one, we don't know what to do.
 394             $error = "Authentication impossible";
 395         }
 396         case ($ERROR_NO_SSL_SUPPORT) {
 397             $protocol->_handle_error
 398                 ($jid, 'libpurple was compiled without SSL '
 399                  .'support, but SSL is required by the '
 400                  .'remote service.', 'service_unavailable');
 401             $error = "Thrasher Bird is unable to connect";
 402         }
 403         case ($ERROR_ENCRYPTION_ERROR) {
 404             $protocol->_handle_error
 405                 ($jid, 'There was an error negotiating SSL with '
 406                  .'the remote service, or the remote service '
 407                  .'does not support encryption but an account '
 408                  .'option was set to require it.',
 409                  'service_unavailable');
 410             $error = "Thrasher Bird is unable to connect";
 411         }
 412         case ($ERROR_NAME_IN_USE) {
 413             $protocol->name_in_use($jid);
 414             $error = "The remote service reports your username is in use";
 415         }
 416         case ($ERROR_INVALID_SETTINGS) {
 417             $protocol->invalid_username($jid);
 418             $error = "Remote server reports invalid username; please reregister";
 419         }
 420         case ($ERROR_OTHER_ERROR) {
 421             my $error_message = "Unknown connection error.";
 422             if ($message) {
 423                 $error_message .= ' The legacy service reported: '
 424                     . $message;
 425             }
 426             $protocol->_handle_error
 427                 ($jid, $error_message, 'internal_server_error');
 428         }
 429         else {
 430             log("Got connection error: $error_code for $jid");
 431         }
 432     }
 433
 434     # This needs to be kept in sync with libpurple's
 435     # connection.c -> purple_connection_is_fatal, which
 436     # tracks whether libpurple is going to automatically
 437     # log out our connection in purple_connection_error_reason.
 438     my $purple_will_kill = !($error_code == $ERROR_NETWORK_ERROR ||
 439                              $error_code == $ERROR_ENCRYPTION_ERROR);
 440     $session->{purple_will_kill} = $purple_will_kill;
 441     $session->{purple_will_kill} ||= $protocol->purple_forces_kill;
 442
 443     $protocol->{component}->logout($session, undef,
 444                                    $error);
 445
 446     # Probe the user's presence to trigger a re-connect attempt
 447     # if they are still online. They may have gone offline in the
 448     # meantime, in which case we don't want to reconnect.
 449     if ($attempt_reconnect) {
 450         my $full_jid = $session->{full_jid};
 451         my $callback = sub {
 452             $protocol->{component}->send_presence_xml($full_jid,
 453                                    'probe');
 454             return 0;
 455         };
 456
 457         log("Going to attempt reconnect in 15 seconds for $session->{full_jid}");
 458
 459         _timeout_add(15000, $callback, undef, "Reconnect $session->{full_jid}");
 460     }
 461     # If you want C-end handling, we need to throw some returns above
 462     return 1;
 463 }
 464
 465 # Callback for incoming messages
 466 sub _incoming_msg {
 467     my $jid     = shift;
 468     my $sender  = shift;
 469     my $alias   = shift;
 470     my $message = shift;
 471
 472     $jid = Encode::decode("UTF-8", $jid);
 473     $sender = Encode::decode("UTF-8", $sender);
 474     $message = Encode::decode("UTF-8", $message);
 475
 476     debug("_incoming_msg from $sender for $jid\n");
 477
 478     my $session = $global_component->session_for($jid);
 479     my $protocol = $session->{protocol};
 480
 481     my $clean_sender = $session->{protocol}->process_remote_username($sender);
 482
 483     # Type is currently hard coded...
 484     $protocol->sending_message($clean_sender, $session->{legacy_login},
 485                                $message, 1);
 486
 487     debug("_incoming_msg done\n");
 488
 489     # Thrasher::Protocol::sending_message currently has no returned value
 490     return 1;
 491 }
 492
 493 sub registration {
 494     my $self = shift;
 495     my $jid = shift;
 496     my $registration_info = shift;
 497
 498     debug("###registration($jid) called");
 499
 500     # As a special case, if the registration info's username is
 501     # "fail", we return an error given by $registration_info->{password}.
 502     if ($registration_info->{username} eq 'fail') {
 503         return 0, $registration_info->{password};
 504     } else {
 505         return $self->SUPER::registration($jid, $registration_info);
 506     }
 507 }
 508
 509 # This really should be overridden
 510 sub name { 'Purple' }
 511
 512 sub identifier { 'aim' }
 513
 514 # This method identifies which protocol we're using in Pidgin.
 515 sub prpl {
 516     my $self = shift;
 517
 518     die "prpl not set up for " . ref($self);
 519 }
 520
 521 sub create_login_session {
 522     my $self = shift;
 523     my $continuation = shift;
 524     my $registration_info = shift;
 525     my $full_jid = shift;
 526     my $component = shift;
 527     my $jid = strip_resource($full_jid);
 528
 529     debug("###create_login_session($full_jid)");
 530
 531     # FIXME: Check for existing logins.
 532     my $session = new Thrasher::Session($full_jid,
 533                                         $component,
 534                                         $self,
 535                                         $registration_info->{username});
 536     $global_component = $component;
 537     $self->set_session_state($session, 'logging in');
 538     $component->set_session_for($jid, $session);
 539
 540     for my $key (keys %$registration_info) {
 541         $registration_info->{$key} =
 542             Encode::encode("UTF-8", $registration_info->{$key});
 543     }
 544
 545     if (!$self->valid_id($registration_info->{username}) ||
 546         !$self->valid_password($registration_info->{password})) {
 547         $self->wrong_authentication($full_jid);
 548         $continuation->('not_acceptable');
 549         $component->logout($session);
 550         return;
 551     }
 552
 553     # 0 => no thrasher_action_login error.
 554     my $login_error = THPPW::thrasher_action_login({
 555         jid => Encode::encode("UTF-8", $jid),
 556         proto => $self->prpl,
 557         %$registration_info,
 558     });
 559     if ($login_error == 2) {
 560         # PurpleAccount already exists. But if component called here,
 561         # the session must already be gone. Thus, must have logged out
 562         # during the async libpurple connection attempt and now trying
 563         # to log back in.
 564         #
 565         # Reject for now. Eventually _connection or _connection_error
 566         # will come back and login attempts will be possible again.
 567         #
 568         # Must not be confused with the bad credentials case lest
 569         # Component put the failure in authentication_errors and lock
 570         # logins until the registration changes.
 571         #
 572         # Could have this session "take over" the PurpleAccount, but
 573         # what if credentials differ?
 574         $continuation->('conflict');
 575         $component->logout($session);
 576         return;
 577     }
 578     elsif ($login_error != 0) {
 579         # Rejected before we're even trying to connect pretty
 580         # much means syntactically invalid credentials
 581         $continuation->('not_acceptable');
 582         $component->logout($session);
 583         return;
 584     }
 585
 586     $session->{'connection_cb'} = $continuation;
 587 }
 588
 589 sub initial_login {
 590     my $self = shift;
 591     my $session = shift;
 592
 593     debug("###initial_login called");
 594
 595     $session->{logged_in} = 1;
 596 }
 597
 598 sub remove {
 599     my $self = shift;
 600     my $jid = shift;
 601
 602     # FIXME: Can occur if the first action after aim.transport comes
 603     # online is to unregister.
 604     if ($global_component) {
 605         my $session = $global_component->session_for($jid);
 606         if ($session) {
 607             $self->{component}->logout($session);
 608         }
 609     }
 610     else {
 611         log("What? No \$global_component in remove?!?");
 612     }
 613
 614     # A user who attempted to unregister while the transport was
 615     # offline won't log in when it comes back up (and thus doesn't
 616     # need to log out) but might still be registered with the backend.
 617     $self->{backend}->remove($jid);
 618 }
 619
 620 sub subscribe {
 621     my $self = shift;
 622     my $session = shift;
 623     my $target_name = shift;
 624     my $continuation = shift;
 625
 626     debug("###subscribe($session->{jid}, $target_name) called");
 627
 628     $session->{subscribed}->{$target_name} = 1;
 629
 630     THPPW::thrasher_action_buddy_add(Encode::encode("UTF-8",
 631                                                     $session->{jid}),
 632                                      Encode::encode("UTF-8", $target_name));
 633
 634     $continuation->(1);
 635 }
 636
 637 sub unsubscribe {
 638     my $self = shift;
 639     my $session = shift;
 640     my $target_name = shift;
 641     my $continuation = shift;
 642
 643     debug("###unsubscribe($session->{jid}, $target_name) called");
 644
 645     if (!(delete $session->{subscribed}->{$target_name})) {
 646         print STDERR "Warning, removing nonexistant contact\n";
 647     }
 648
 649     THPPW::thrasher_action_buddy_remove(Encode::encode("UTF-8",
 650                                                        $session->{jid}),
 651                                         Encode::encode("UTF-8", $target_name));
 652
 653     $continuation->();
 654 }
 655
 656 sub logout {
 657     my $self = shift;
 658     my ($session, $continuation) = @_;
 659
 660     debug("###logout($session->{jid}) called");
 661
 662     if ($session->{purple_connection_created}
 663         && !$session->{purple_will_kill}) {
 664         THPPW::thrasher_action_logout(Encode::encode("UTF-8", $session->{jid}));
 665     }
 666     elsif (! $session->{purple_connection_created}) {
 667         debug('No purple connection created to log out.');
 668     }
 669
 670     $continuation->($session);
 671     return $self->SUPER::logout(@_);
 672 }
 673
 674 sub debug_logged_in {
 675     my $component = $global_component;
 676     if (! $component) {
 677         debug("No component?!!\n");
 678         return;
 679     }
 680
 681     my $protocol = $component->{'protocol'};
 682     if (! $protocol) {
 683         debug("No protocol?!!\n");
 684         return;
 685     }
 686
 687     print STDERR 'prpl = ' . $protocol->prpl() . "\n";
 688
 689     if ($protocol->{'username_to_session'}) {
 690         print STDERR "protocol->username_to_session:\n";
 691         while (my ($legacy_name, $session)
 692                  = each(%{$protocol->{'username_to_session'}})) {
 693             print STDERR "\t$legacy_name => $session\n";
 694         }
 695     }
 696     else {
 697         debug("No username_to_session?!!\n");
 698     }
 699
 700     if ($component->{'sessions'}) {
 701         print STDERR "component->sessions:\n";
 702         while (my ($jid, $session) = each(%{$component->{'sessions'}})) {
 703             print STDERR "\t$jid => $session\n";
 704         }
 705     }
 706     else {
 707         debug("No component sessions?!!\n");
 708     }
 709
 710     THPPW::thrasher_action_debug_logged_in();
 711 }
 712
 713 sub send_message {
 714     my $self = shift;
 715     my @orig_args = @_;
 716     my ($session, $to, $body_text, $type, $error_sub) = @_;
 717
 718     debug("###send_message called");
 719     if ($session->{'protocol_state'} eq 'logging in') {
 720         debug("###send_message deferred; $session->{jid} still logging in.\n");
 721         $session->on_connection_complete(sub {
 722                                              $self->send_message(@orig_args);
 723                                          });
 724         return;
 725     }
 726
 727     $body_text = $self->process_message($body_text);
 728
 729     debug("###Message From: ".$session->{jid}.", To: $to, body: $body_text\n");
 730
 731     my $result = THPPW::thrasher_action_outgoing_msg
 732         (Encode::encode("UTF-8", $session->{jid}),
 733          Encode::encode("UTF-8", $to),
 734          Encode::encode("UTF-8", $body_text));
 735     debug("Message send result: $result\n");
 736 }
 737
 738 sub outgoing_chatstate {
 739     my ($self, $session, $to, $chatstate) = @_;
 740     debug("###outgoing_chatstate($session->{jid}, $to, $chatstate)\n");
 741
 742     our $chatstate_to_purple ||= {
 743         'composing' => $THPPW::PURPLE_TYPING,
 744         'paused' => $THPPW::PURPLE_TYPED,
 745         'inactive' => $THPPW::PURPLE_NOT_TYPING,
 746         'active' => $THPPW::PURPLE_NOT_TYPING,
 747     };
 748     my $purple_typing_state = $chatstate_to_purple->{$chatstate};
 749     if (! defined($purple_typing_state)) {
 750         debug("Untranslated chatstate: '$chatstate'\n");
 751         return;
 752     }
 753
 754     THPPW::thrasher_action_outgoing_chatstate($session->{'jid'},
 755                                               $to,
 756                                               $purple_typing_state);
 757     return;
 758 }
 759
 760 sub subscribed {
 761     my $self = shift;
 762     my $session = shift;
 763     my $component = shift;
 764     my $legacy_username = shift;
 765
 766     debug("###subscribed called: $legacy_username permitted for $session->{jid}");
 767
 768     THPPW::thrasher_action_buddy_authorize
 769         (Encode::encode("UTF-8", $session->{jid}),
 770          Encode::encode("UTF-8", $legacy_username));
 771
 772     $self->SUPER::subscribed($session, $component, $legacy_username);
 773 }
 774
 775 sub unsubscribed {
 776     my $self = shift;
 777     my $session = shift;
 778     my $component = shift;
 779     my $legacy_username = shift;
 780
 781     debug("###unsubscribed($session->{jid}, $legacy_username) called");
 782
 783     if (!defined($legacy_username)) {
 784         confess "Unsubscribing an undef user; shouldn't be called.";
 785     }
 786
 787     THPPW::thrasher_action_buddy_deauthorize
 788         (Encode::encode("UTF-8", $session->{jid}),
 789          Encode::encode("UTF-8", $legacy_username));
 790 }
 791
 792 sub ft_local_ready {
 793     my ($self, $id) = @_;
 794
 795     THPPW::thrasher_action_ft_ui_ready($id);
 796     return 1;                   # repeat this notification.
 797 }
 798
 799 sub gateway_prompt {
 800     my $self = shift;
 801     my $lang = shift;
 802
 803     return "Gateway prompt";
 804 }
 805
 806 sub gateway_desc {
 807     my $self = shift;
 808
 809     return $self->{gateway_desc};
 810 }
 811
 812 sub user_presence_update {
 813     my $self = shift;
 814     my $session = shift;
 815     my $type = shift || '';
 816     my $show = shift || '';
 817     my $status = shift || '';
 818
 819     debug("user_presence_update called\n");
 820
 821     my $purple_status;
 822
 823     # State table for type/show to purple_status
 824     if ($show eq 'away') {
 825         if ($type eq '') {
 826             if ($status) {
 827                 # 'xaway'
 828                 $purple_status = $purple_presence{'xaway'};
 829             }
 830             else {
 831                 # 'away'
 832                 $purple_status = $purple_presence{'away'};
 833             }
 834         }
 835         else {
 836             logger("Unknown type/show of [$type/$show]");
 837         }
 838     }
 839     elsif ($show eq 'chat' || $show eq '') {
 840         if ($type eq '') {
 841             # 'available'
 842             # This seems like it might have more states
 843             $purple_status = $purple_presence{'available'};
 844         }
 845         elsif ($type eq 'unavailable') {
 846             # 'offline'
 847             $purple_status = $purple_presence{'offline'};
 848         }
 849         else {
 850             logger("Unknown type/show of [$type/$show]");
 851         }
 852     }
 853     else {
 854         logger("Unknown type/show of [$type/$show] (show is completely unrecognized)");
 855     }
 856
 857     THPPW::thrasher_action_presence
 858         (Encode::encode("UTF-8", $session->{jid}),
 859          $purple_status, # integer does not need encoding
 860          Encode::encode("UTF-8", $status));
 861
 862     #debug("User presence update: type: $type, show: $show, purple: $purple_status, status: $status");
 863 }
 864
 865 # Don't do anything with this right now.
 866 sub user_targeted_presence_update {
 867     return;
 868     my $self = shift;
 869     my $session = shift;
 870     my $type = shift || '';
 871     my $show = shift || '';
 872     my $status = shift || '';
 873     my $target_user = shift || '';
 874
 875     #log("User presence update to $target_user: type: $type, show: $show, status: $status");
 876 }
 877
 878 # Subrefs for which to satiate the libpurple monster
 879 sub _timeout_add {
 880     my $interval = shift;
 881     my $code     = shift;
 882     my $trigger  = shift;
 883
 884     debug("perl::timeout_add called\n", 3);
 885
 886     debug("\tinterval = $interval\n", 3) if $interval;
 887     debug("\tcode     = $code\n", 3)     if $code;
 888     debug("\ttrigger  = $trigger\n", 3)  if $trigger;
 889
 890     my $ret = Glib::Timeout->add($interval,
 891                                  ($code, $trigger),
 892                                  G_PRIORITY_DEFAULT);
 893
 894     debug("Glib::Timeout->add returned [$ret]\n", 3);
 895     return $ret;
 896 };
 897
 898
 899 sub _source_remove {
 900     debug("perl::timeout_remove called with $_[0]\n", 3);
 901
 902     return Glib::Source->remove($_[0]);
 903 }
 904
 905
 906 sub _input_add {
 907     my $fd       = shift;
 908     my $cond     = shift;
 909     my $code     = shift;
 910     my $trigger  = shift;
 911
 912     debug("_input_add\n", 3);
 913
 914     my $i = 0;
 915     foreach (@_) {
 916         debug("\t$i = $_\n");
 917         $i++;
 918     }
 919
 920
 921     debug("\tfd       = $fd\n", 3)      if $fd;
 922     debug("\tcond     = $cond\n", 3)    if $cond;
 923     debug("\tcode     = $code\n", 3)    if $code;
 924     debug("\ttrigger  = $trigger\n", 3) if $trigger;
 925
 926     $cond = ($cond == 1) ? 'G_IO_IN' : 'G_IO_OUT';
 927
 928     $cond = [$cond, 'G_IO_ERR', 'G_IO_HUP', 'G_IO_NVAL'];
 929
 930     my $ret = Glib::IO->add_watch($fd,
 931                                   $cond,
 932                                   $code,
 933                                   $trigger,
 934                                   G_PRIORITY_DEFAULT);
 935
 936     debug("Glib::IO->add_watch returned [$ret]\n", 3);
 937
 938     debug("_input_add done\n", 3);
 939
 940     return $ret;
 941 }
 942
 943 # Returns if the given ID is a valid id for the service. This avoids
 944 # some problems that services have when you jam illegal logins in.
 945 # For instance, log in to Yahoo with a Japanese username, and it
 946 # just hangs on the connection, rather than doing anything.
 947 # Note that this is more about not sending in logins that confuse
 948 # the remote services so badly we get no errors, NOT about precisely
 949 # labelling which fields are possible. If the remote service correctly
 950 # determines the password is invalid, then everything's fine.
 951 sub valid_id {
 952     return 1;
 953 }
 954
 955 sub valid_password {
 956     my ($self, $password) = @_;
 957
 958     # If the prpl requires a password, _purple_connection_new() will
 959     # fail when password is NULL or zero-length without returning an
 960     # error thrasher_login() can detect. Worse, the check in
 961     # purple_account_connect() is slightly different so it wouldn't
 962     # even be detectable through purple_account_request_password() and
 963     # request_fields().
 964     #
 965     # Registering with an empty password therefore begins an
 966     # apparently successful async login that never completes or
 967     # errors. The user also can't re-register or log out because
 968     # they're already "logging in". :(
 969     #
 970     # If the prpl has OPT_PROTO_PASSWORD_OPTIONAL or OPT_PROTO_NO_PASSWORD
 971     # the corresponding subclass should override this.
 972     return !!$password;
 973 }
 974
 975 sub purple_forces_kill { return 0; }
 976
 977 1;