Net::REPL::Client: Allow read/print portions to be overridden separately.

[thrasher.git] / perl / lib / Thrasher / Protocol / Purple.pm

package Thrasher::Protocol::Purple;
use strict;
use warnings;

=head1 NAME

Thrasher::Protocol::Purple - test protocol for Thrasher Bird

=head1 DESCRIPTION

This package is the base class for protocols using libpurple. 
Each protocol may have slightly different details w.r.t. how they work
with Thrasher, which is handled by specializing them further,
such as with Thrasher::Protocol::Purple::AIM. As you find such
differences, please be sure to add hooks in here, not hack on
this module directly.

=cut

use base 'Thrasher::Protocol';

use Thrasher::Component qw(strip_resource);
use Thrasher::Log qw(log logger debug);
use Thrasher::Roster;
use Thrasher::Session;
use Thrasher::XMPPStreamIn;
use Glib qw(G_PRIORITY_DEFAULT);
use Carp qw(confess);
use Data::Dumper;
use Switch;
use Encode;

use Thrasher::Protocol::Purple::Vars qw(:all);
use THPPW;

# Plugins we use
use Thrasher::Plugin::Vcard;
use Thrasher::Plugin::EntityCapabilities;

my $DEBUG = 1;

# Internal debugging
THPPW::thrasher_purple_debug($DEBUG);

# Initialize the wrapper
THPPW::thrasher_wrapper_init
    (Thrasher::error_wrap("timeout_add", \&_timeout_add),
     Thrasher::error_wrap("input_add", \&_input_add),
     Thrasher::error_wrap("source_remove", \&_source_remove),
     Thrasher::error_wrap("incoming_msg", \&_incoming_msg),
     Thrasher::error_wrap("presence_in", \&_presence_in),
     Thrasher::error_wrap("subscription_add", \&_subscription_add),
     Thrasher::error_wrap("legacy_user_adding_user", \&_legacy_user_adding_user),
     Thrasher::error_wrap("connection_error", \&_connection_error),
     Thrasher::error_wrap("connection", \&_connection),
     Thrasher::error_wrap("incoming_chatstate", \&_incoming_chatstate),
);

# Initialize the remainder
THPPW::thrasher_init();

# Globalize component object so we can receive messages
our $global_component;

sub event_loop {
    return 'Thrasher::EventLoop::Glib';
}

# This internal routine allows us to group the initial
# subscribe additions and throw them back.
sub _initial_roster {
    my $session = shift;

    if (! $session || !$session->{'jid'}) {
        debug("_initial_roster: No session. Must be post-logoff?");
        return 0;
    }

    debug("_initial_roster($session->{jid}) called\n");

    my $roster;

    foreach my $username (keys %{$session->{initial_roster}}) {
        $username = $session->{protocol}->process_remote_username($username);
        $roster->{$username} = Thrasher::Roster::subscribed();
        # We should also handle presence info here (?)
    }

    $session->{protocol}->set_current_legacy_roster($session, $roster);

    delete $session->{initial_roster_timeout_active};
    $session->{initial_roster} = [];

    # Thrasher can now be sure the protocol is completely online and
    # ready to e.g. send IMs queued while login was in progress.
    if ($session->{'protocol_state'} eq 'logging in') {
        $session->{'protocol'}->set_session_state($session, 'online');
    }

    # We don't want the timeout to loop, so destroy with 0
    return 0;
}

# This appears to only be called for things on our initial roster.
# FIXME: If that's true, change this.
sub _subscription_add {
    my $orig_jid    = shift;
    my $orig_sender = shift;
    my $status = shift;

    my $jid = Encode::decode("UTF-8", $orig_jid);
    my $sender = Encode::decode("UTF-8", $orig_sender);

    debug("_subscription_add($orig_jid, $orig_sender) called\n");

    my $session = $global_component->session_for($jid);

    # Set a timeout if we have no previous jid information
    if (not defined $session->{initial_roster}) {

        # Set a flag so we don't push subscription additions
        # to an unused array
        $session->{initial_roster_timeout_active} = 1;

        # Heuristically manage our initial roster as we cannot
        # tell when the libpurple protocols are done giving us the
        # subscribe user list.
        Glib::Timeout->add(5000,
                           \&_initial_roster,
                           $session,
                           G_PRIORITY_DEFAULT);
    }

    # Verify we're actually within a timeout
    if ($session->{initial_roster_timeout_active}) {
        # This is a bit ugly, but it allows us to bind sender/status
        # info to JIDs for timeouts
        $session->{initial_roster}{$sender} = $status;
    }
    # We aren't in a timeout, we need to send new subscribe info up
    else {
    }

    # Subscription-in information has the presence information
    # loaded onto it too, at least for AIM
    if ($status) {
        _presence_in($orig_jid, $orig_sender, undef, undef, $status);
    }

    debug("_subscription_add done\n");

    return 1;
}

sub _legacy_user_adding_user {
    my $jid_target = shift;
    my $legacy_username_adding = shift;

    $jid_target = Encode::decode("UTF-8", $jid_target);
    $legacy_username_adding = Encode::decode("UTF-8", $legacy_username_adding);

    log("$legacy_username_adding requesting add for $jid_target");

    my $session = $global_component->session_for($jid_target);

    if ($session) {
        $session->{protocol}->adding_contact($legacy_username_adding,
                                             $jid_target);
    } else {
        log("Got request to add user $jid_target, but $jid_target is "
            ."not logged in.");
    }
}

sub process_message { return $_[1]; }
sub process_remote_username { return $_[1]; }

# Callback of presence in
sub _presence_in {
    my $jid     = shift;
    my $sender  = shift;
    my $alias   = shift;
    my $group   = shift;
    my $status  = shift;
    my $message = shift;

    $jid = Encode::decode("UTF-8", $jid);
    $sender = Encode::decode("UTF-8", $sender);
    $alias = Encode::decode("UTF-8", $alias);
    $group = Encode::decode("UTF-8", $group);
    $status = Encode::decode("UTF-8", $status);
    $message = Encode::decode("UTF-8", $message);

    debug("_presence_in($jid, $sender, $status) called\n");

    my $session = $global_component->session_for($jid);
    my $self = $session->{protocol};
    if (!defined($self)) {
        debug("No session defined for $jid, must be post-logoff?");
        return 0;
    }

    my $clean_sender = $self->process_remote_username($sender);

    if ($message) {
        $message =~ s/([\x80-\xff])/'&#' . ord($1) . ';'/ge;
    }

    # Nothing is done with protocol?
    my $xmpp_presence = $purple_presence_to_xmpp{$status};
    if ($xmpp_presence) {
        my ($type, $show) = @{$xmpp_presence};
        $self->legacy_presence_update($session,
                                      $clean_sender,
                                      $type,
                                      $show,
                                      $message);
    }
    else {
        log("Unknown presence status of $status was sent by "
            ."$clean_sender to $jid.");
        return 0;
    }

    debug("_presence_in done\n");
    return 1;
}

sub _incoming_chatstate {
    my ($orig_jid, $orig_sender, $state) = @_;
    debug("_incoming_chatstate($orig_jid, $orig_sender, $state) called\n");

    my $state_tag;
    # loosely <http://xmpp.org/extensions/xep-0085.html>
    if ($state == $THPPW::PURPLE_TYPING) {
        $state_tag = 'composing';
    }
    elsif ($state == $THPPW::PURPLE_TYPED) {
        $state_tag = 'paused';
    }
    elsif ($state == $THPPW::PURPLE_NOT_TYPING) {
        $state_tag = 'inactive';
    }
    else {
        return;
    }

    my $jid = Encode::decode('UTF-8', $orig_jid);
    my $sender = Encode::decode('UTF-8', $orig_sender);

    my $session = $global_component->session_for($jid);
    if (! $session) {
        debug("No session?!!\n");
        return;
    }
    if (! $session->{'protocol'}) {
        debug("No session protocol?!!\n");
        return;
    }
    $session->{'protocol'}->incoming_chatstate($session, $sender, $state_tag);
    return;
}

sub _connection {
    my ($orig_jid) = @_;
    my $jid = Encode::decode("UTF-8", $orig_jid);
    debug("_connection($jid) called\n");

    my $session = $global_component->session_for($jid);
    if (! $session) {
        # Component::logout and thrasher.c:thrasher_logout() will
        # happily destroy the session and thrasher_connection while
        # libpurple is waiting asynchronously for connection events.
        # Once the connection completes and libpurple starts firing
        # callbacks, weird errors arise because the session is gone
        # and Thrasher has lost track of what is connected.
        #
        # Maybe we should reject the logout and defer it to
        # _connection{,_error}, relying on one of them always being
        # called eventually?
        log("_connection($jid): No session? Assuming already logged out.");
        # Ensure the thrasher_connection gets gone.
        Glib::Timeout->add(1,
                           sub {
                               # Log off just after logon finishes, not during.
                               #
                               # Turns out purple_connection_set_state()
                               # (which called the connected ui_op) crashes
                               # if prpl_info is yanked out from under it.
                               THPPW::thrasher_action_logout($orig_jid);
                           },
                           undef,
                           G_PRIORITY_DEFAULT);
        return 1;
    }

    my $protocol = $session->{'protocol'};
    if (! $protocol) {
        log("_connection($jid): No protocol?!!");
        return 0;
    }

    $session->{'purple_connection_created'} = 1;
    delete($protocol->{'connection_started_at'}->{$jid});
    my $continuation = delete($session->{'connection_cb'});
    if ($continuation) {
        $continuation->($session);
    }
    else {
        log("_connection($jid): No connection_cb?!!");
        return 0;
    }

    # But libpurple prpl might not be ready to send IMs queued during
    # login. Wait until _initial_roster() for online protocol_state.
    Glib::Timeout->add(
        # If after no _subscription_add()/_initial_roster() happens
        # (perhaps the account has no current legacy roster at all?)
        # ensure session is eventually set online anyway.
        15000,
        sub {
            if (! $session->{'initial_roster_timeout_active'}
                  && ! $session->{'initial_roster'}
                  && $session->{'protocol_state'} eq 'logging in') {
                debug("Never called _initial_roster($session->{jid})?\n");
                $protocol->set_session_state($session, 'online');
            }
            return 0; # No repeat
        },
        undef,
        G_PRIORITY_DEFAULT
    );

    return 1;
}

sub _connection_error {
    my $jid        = shift;
    my $error_code = shift;
    my $message    = shift;

    $jid = Encode::decode("UTF-8", $jid);
    $message = Encode::decode("UTF-8", $message);

    debug("_connection_error($jid)\n");

    my $session = $global_component->session_for($jid);
    if (! $session) {
        log("No session?!! Error was $error_code/'$message'.");
        return 0;
    }
    my $protocol = $session->{protocol};
    if ($protocol) {
        # Clear connection state.
        delete($session->{'connection_cb'});
        delete($protocol->{'connection_started_at'}->{$jid});
    }
    else {
        log("_connection($jid): No protocol?!!");
        return 0;
    }

    my $attempt_reconnect = 0;
    my $error = '';

    if ($session->{status} =~ /disconnecting/) {
        log("Got error code $error_code, but ignoring it since "
            ."we're in the middle of disconnecting.");
        return 1;
    }

    # Some of these cases are poorly tested since it's either 
    # hard or borderline impossible for them to occur. 
    # We also have to think about whether to attempt reconnection
    # or not.
    switch ($error_code) {
        case ($ERROR_NETWORK_ERROR) {
            $protocol->network_error($jid);
            $error = "Network error, attempting reconnection";
            $attempt_reconnect = 1;
        }
        case ($ERROR_INVALID_USERNAME) {
            $protocol->invalid_username($jid); 
            $error = "Remote server reports invalid username; please reregister";
        }
        case ($ERROR_AUTHENTICATION_FAILED) {
            $protocol->wrong_authentication($jid);
            $error = "Username or password invalid; please register with correct information";
        }
        case ($ERROR_AUTHENTICATION_IMPOSSIBLE) {
            $protocol->_handle_error
                ($jid, 'Thrasher Bird can not negotiate an '
                 .'authentication technique with the remote '
                 .'service', 'service_unavailable');
            # This is a bad one, we don't know what to do.
            $error = "Authentication impossible";
        }
        case ($ERROR_NO_SSL_SUPPORT) {
            $protocol->_handle_error
                ($jid, 'libpurple was compiled without SSL '
                 .'support, but SSL is required by the '
                 .'remote service.', 'service_unavailable');
            $error = "Thrasher Bird is unable to connect";
        }
        case ($ERROR_ENCRYPTION_ERROR) {
            $protocol->_handle_error
                ($jid, 'There was an error negotiating SSL with '
                 .'the remote service, or the remote service ' 
                 .'does not support encryption but an account '
                 .'option was set to require it.',
                 'service_unavailable');
            $error = "Thrasher Bird is unable to connect";
        }
        case ($ERROR_NAME_IN_USE) {
            $protocol->name_in_use($jid);
            $error = "The remote service reports your username is in use";
        }
        case ($ERROR_INVALID_SETTINGS) {
            $protocol->invalid_username($jid);
            $error = "Remote server reports invalid username; please reregister";
        }
        case ($ERROR_OTHER_ERROR) {
            my $error_message = "Unknown connection error.";
            if ($message) {
                $error_message .= ' The legacy service reported: '
                    . $message;
            }
            $protocol->_handle_error
                ($jid, $error_message, 'internal_server_error');
        }
        else {
            log("Got connection error: $error_code for $jid");
        }
    }

    # This needs to be kept in sync with libpurple's
    # connection.c -> purple_connection_is_fatal, which
    # tracks whether libpurple is going to automatically
    # log out our connection in purple_connection_error_reason.
    my $purple_will_kill = !($error_code == $ERROR_NETWORK_ERROR ||
                             $error_code == $ERROR_ENCRYPTION_ERROR);
    $session->{purple_will_kill} = $purple_will_kill;
    $session->{purple_will_kill} ||= $protocol->purple_forces_kill;
    
    $protocol->{component}->logout($session, undef, 
                                   $error);
    
    # Probe the user's presence to trigger a re-connect attempt
    # if they are still online. They may have gone offline in the
    # meantime, in which case we don't want to reconnect.
    if ($attempt_reconnect) {
        my $full_jid = $session->{full_jid};
        my $callback = sub {
            $protocol->{component}->send_presence_xml($full_jid,
                                   'probe');
            return 0;
        };

        log("Going to attempt reconnect in 15 seconds for $session->{full_jid}");

        _timeout_add(15000, $callback, undef, "Reconnect $session->{full_jid}");
    }
    # If you want C-end handling, we need to throw some returns above
    return 1;
}

# Callback for incoming messages
sub _incoming_msg {
    my ($jid, $sender, $alias, $message, $flags) = @_;

    $jid = Encode::decode("UTF-8", $jid);
    $sender = Encode::decode("UTF-8", $sender);
    $message = Encode::decode("UTF-8", $message);

    debug("_incoming_msg from $sender for $jid\n");

    my $session = $global_component->session_for($jid);
    my $protocol = $session->{protocol};

    my $clean_sender = $session->{protocol}->process_remote_username($sender);

    $message =~ s/([\x80-\xff])/'&#' . ord($1) . ';'/ge;

    if ($flags & $THPPW::PURPLE_MESSAGE_AUTO_RESP) {
        $message = '(auto-reply) ' . $message;
    }

    # Type is currently hard coded...
    $protocol->sending_message($clean_sender, $session->{legacy_login},
                               $message, 1);

    debug("_incoming_msg done\n");

    # Thrasher::Protocol::sending_message currently has no returned value
    return 1;
}

sub registration {
    my $self = shift;
    my $jid = shift;
    my $registration_info = shift;

    debug("###registration($jid) called");

    # As a special case, if the registration info's username is 
    # "fail", we return an error given by $registration_info->{password}.
    if ($registration_info->{username} eq 'fail') {
        return 0, $registration_info->{password};
    } else {
        return $self->SUPER::registration($jid, $registration_info);
    }
}

# This really should be overridden
sub name { 'Purple' }

sub identifier { 'aim' }

# This method identifies which protocol we're using in Pidgin.
sub prpl {
    my $self = shift;

    die "prpl not set up for " . ref($self);
}

sub create_login_session {
    my $self = shift;
    my $continuation = shift;
    my $registration_info = shift;
    my $full_jid = shift;
    my $component = shift;
    my $jid = strip_resource($full_jid);

    debug("###create_login_session($full_jid)");

    # FIXME: Check for existing logins.
    my $session = new Thrasher::Session($full_jid,
                                        $component,
                                        $self,
                                        $registration_info->{username});
    $global_component = $component;
    $self->set_session_state($session, 'logging in');
    $component->set_session_for($jid, $session);

    for my $key (keys %$registration_info) {
        $registration_info->{$key} = 
            Encode::encode("UTF-8", $registration_info->{$key});
    }

    if (!$self->valid_id($registration_info->{username}) ||
        !$self->valid_password($registration_info->{password})) {
        $self->wrong_authentication($full_jid);
        $continuation->('not_acceptable');
        $component->logout($session);
        return;
    }

    my $jid_enc = Encode::encode('UTF-8', $jid);
    my %login_args = (
        jid => $jid_enc,
        proto => $self->prpl,
        %$registration_info,
        %{ $self->{'configuration'}->{'extra_login_args'} || {} },
    );
    my $login_error = THPPW::thrasher_action_login(\%login_args);
    my $last_connection_started_at = $self->{'connection_started_at'}->{$jid};

    # PurpleAccount already exists. But if component called here,
    # the session must already be gone. Thus, must have logged out
    # during the async libpurple connection attempt and now trying
    # to re-log in.
    if ($login_error == 2
          && $last_connection_started_at
          && time() - $last_connection_started_at > 600) {
        # Async libpurple login started more than 10 minutes ago but
        # _connection{,_error} has still not come back. Destroy the
        # old login attempt and start a new one.
        #
        # E.g. the PURPLE_CONNECTED state was never reached due to a
        # MSN ADL/FQY counting bug?
        debug('Discarding aged PurpleAccount attempt from '
                . $last_connection_started_at);
        THPPW::thrasher_action_logout($jid_enc);
        $login_error = THPPW::thrasher_action_login(\%login_args);
        # In theory, logout removed the PurpleAccount so the new
        # $login_error can't be 2. But--don't risk it!
    }
    if ($login_error == 2) {
        # Reject for now. Eventually _connection or _connection_error
        # will come back and login attempts will be possible again.
        #
        # Must not be confused with the bad credentials case lest
        # Component put the failure in authentication_errors and lock
        # logins until the registration changes.
        #
        # Could have this session "take over" the PurpleAccount, but
        # what if credentials differ? Or if libpurple never finishes?
        $continuation->('conflict');
        $component->logout($session);
        return;
    }

    elsif ($login_error != 0) {
        # Rejected before we're even trying to connect pretty
        # much means syntactically invalid credentials
        $continuation->('not_acceptable');
        $component->logout($session);
        return;
    }

    $self->{'connection_started_at'}->{$jid} = time();
    $session->{'connection_cb'} = $continuation;
}

sub initial_login {
    my $self = shift;
    my $session = shift;

    debug("###initial_login called");

    $session->{logged_in} = 1;
}

sub remove {
    my $self = shift;
    my $jid = shift;

    # FIXME: Can occur if the first action after aim.transport comes
    # online is to unregister.
    if ($global_component) {
        my $session = $global_component->session_for($jid);
        if ($session) {
            $self->{component}->logout($session);
        }
    }
    else {
        log("What? No \$global_component in remove?!?");
    }

    # A user who attempted to unregister while the transport was
    # offline won't log in when it comes back up (and thus doesn't
    # need to log out) but might still be registered with the backend.
    $self->{backend}->remove($jid);
}

sub subscribe {
    my $self = shift;
    my $session = shift;
    my $target_name = shift;
    my $continuation = shift;

    debug("###subscribe($session->{jid}, $target_name) called");

    $session->{subscribed}->{$target_name} = 1;

    THPPW::thrasher_action_buddy_add(Encode::encode("UTF-8",
                                                    $session->{jid}),
                                     Encode::encode("UTF-8", $target_name));

    $continuation->(1);
}

sub unsubscribe {
    my $self = shift;
    my $session = shift;
    my $target_name = shift;
    my $continuation = shift;

    debug("###unsubscribe($session->{jid}, $target_name) called");

    if (!(delete $session->{subscribed}->{$target_name})) {
        print STDERR "Warning, removing nonexistant contact\n";
    }

    THPPW::thrasher_action_buddy_remove(Encode::encode("UTF-8",
                                                       $session->{jid}), 
                                        Encode::encode("UTF-8", $target_name));

    $continuation->();
}

sub logout {
    my $self = shift;
    my ($session, $continuation) = @_;

    debug("###logout($session->{jid}) called");

    if ($session->{purple_connection_created} 
        && !$session->{purple_will_kill}) {
        THPPW::thrasher_action_logout(Encode::encode("UTF-8", $session->{jid}));
    }
    elsif (! $session->{purple_connection_created}) {
        debug('No purple connection created to log out.');
    }

    $continuation->($session);
    return $self->SUPER::logout(@_);
}

sub debug_logged_in {
    my $component = $global_component;
    if (! $component) {
        debug("No component?!!\n");
        return;
    }

    my $protocol = $component->{'protocol'};
    if (! $protocol) {
        debug("No protocol?!!\n");
        return;
    }

    print STDERR 'prpl = ' . $protocol->prpl() . "\n";

    if ($protocol->{'username_to_session'}) {
        print STDERR "protocol->username_to_session:\n";
        while (my ($legacy_name, $session)
                 = each(%{$protocol->{'username_to_session'}})) {
            print STDERR "\t$legacy_name => $session\n";
        }
    }
    else {
        debug("No username_to_session?!!\n");
    }

    if ($component->{'sessions'}) {
        print STDERR "component->sessions:\n";
        while (my ($jid, $session) = each(%{$component->{'sessions'}})) {
            print STDERR "\t$jid => $session\n";
        }
    }
    else {
        debug("No component sessions?!!\n");
    }

    THPPW::thrasher_action_debug_logged_in();
}

sub send_message {
    my $self = shift;
    my @orig_args = @_;
    my ($session, $to, $body_text, $type, $error_sub) = @_;

    debug("###send_message called");
    if ($session->{'protocol_state'} eq 'logging in') {
        debug("###send_message deferred; $session->{jid} still logging in.\n");
        $session->on_connection_complete(sub {
                                             $self->send_message(@orig_args);
                                         });
        return;
    }

    $body_text = $self->process_message($body_text);

    debug("###Message From: ".$session->{jid}.", To: $to, body: $body_text\n");

    my $result = THPPW::thrasher_action_outgoing_msg
        (Encode::encode("UTF-8", $session->{jid}), 
         Encode::encode("UTF-8", $to), 
         Encode::encode("UTF-8", $body_text));
    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;
    my $component = shift;
    my $legacy_username = shift;

    debug("###subscribed called: $legacy_username permitted for $session->{jid}");

    THPPW::thrasher_action_buddy_authorize
        (Encode::encode("UTF-8", $session->{jid}),
         Encode::encode("UTF-8", $legacy_username));

    $self->SUPER::subscribed($session, $component, $legacy_username);
}

sub unsubscribed {
    my $self = shift;
    my $session = shift;
    my $component = shift;
    my $legacy_username = shift;

    debug("###unsubscribed($session->{jid}, $legacy_username) called");

    if (!defined($legacy_username)) {
        confess "Unsubscribing an undef user; shouldn't be called.";
    }

    THPPW::thrasher_action_buddy_deauthorize
        (Encode::encode("UTF-8", $session->{jid}),
         Encode::encode("UTF-8", $legacy_username));
}

sub ft_local_ready {
    my ($self, $id) = @_;

    THPPW::thrasher_action_ft_ui_ready($id);
    return 1;                   # repeat this notification.
}

sub gateway_prompt {
    my $self = shift;
    my $lang = shift;

    return "Gateway prompt";
}

sub gateway_desc {
    my $self = shift;

    return $self->{gateway_desc};
}

sub user_presence_update {
    my $self = shift;
    my $session = shift;
    my $type = shift || '';
    my $show = shift || '';
    my $status = shift || '';

    debug("user_presence_update called\n");

    my $purple_status;

    # State table for type/show to purple_status
    if ($show eq 'away') {
        if ($type eq '') {
            if ($status) {
                # 'xaway'
                $purple_status = $purple_presence{'xaway'};
            }
            else {
                # 'away'
                $purple_status = $purple_presence{'away'};
            }
        }
        else {
            logger("Unknown type/show of [$type/$show]");
        }
    }
    elsif ($show eq 'chat' || $show eq '') {
        if ($type eq '') {
            # 'available'
            # This seems like it might have more states
            $purple_status = $purple_presence{'available'};
        }
        elsif ($type eq 'unavailable') {
            # 'offline'
            $purple_status = $purple_presence{'offline'};
        }
        else {
            logger("Unknown type/show of [$type/$show]");
        }
    }
    elsif ($show eq 'xa' || $show eq 'xaway') {
        $purple_status = $purple_presence{'xaway'};
    }
    else {
        logger("Unknown type/show of [$type/$show] (show is completely unrecognized)");
    }

    if (defined($purple_status)) {
        THPPW::thrasher_action_presence(
            Encode::encode("UTF-8", $session->{jid}),
            $purple_status,     # integer does not need encoding
            Encode::encode("UTF-8", $status),
        );
    }

    #debug("User presence update: type: $type, show: $show, purple: $purple_status, status: $status");
}

# Don't do anything with this right now.
sub user_targeted_presence_update {
    return;
    my $self = shift;
    my $session = shift;
    my $type = shift || '';
    my $show = shift || '';
    my $status = shift || '';
    my $target_user = shift || '';

    #log("User presence update to $target_user: type: $type, show: $show, status: $status");
}

# Subrefs for which to satiate the libpurple monster
sub _timeout_add {
    my $interval = shift;
    my $code     = shift;
    my $trigger  = shift;

    debug("perl::timeout_add called\n", 3);

    debug("\tinterval = $interval\n", 3) if $interval;
    debug("\tcode     = $code\n", 3)     if $code;
    debug("\ttrigger  = $trigger\n", 3)  if $trigger;

    my $ret = Glib::Timeout->add($interval,
                                 ($code, $trigger),
                                 G_PRIORITY_DEFAULT);

    debug("Glib::Timeout->add returned [$ret]\n", 3);
    return $ret;
};


sub _source_remove {
    debug("perl::timeout_remove called with $_[0]\n", 3);

    return Glib::Source->remove($_[0]);
}


sub _input_add {
    my $fd       = shift;
    my $cond     = shift;
    my $code     = shift;
    my $trigger  = shift;

    debug("_input_add\n", 3);

    my $i = 0;
    foreach (@_) {
        debug("\t$i = $_\n");
        $i++;
    }


    debug("\tfd       = $fd\n", 3)      if $fd;
    debug("\tcond     = $cond\n", 3)    if $cond;
    debug("\tcode     = $code\n", 3)    if $code;
    debug("\ttrigger  = $trigger\n", 3) if $trigger;

    $cond = ($cond == 1) ? 'G_IO_IN' : 'G_IO_OUT';

    $cond = [$cond, 'G_IO_ERR', 'G_IO_HUP', 'G_IO_NVAL'];
    
    my $ret = Glib::IO->add_watch($fd,
                                  $cond,
                                  $code,
                                  $trigger,
                                  G_PRIORITY_DEFAULT);

    debug("Glib::IO->add_watch returned [$ret]\n", 3);

    debug("_input_add done\n", 3);

    return $ret;
}

# Returns if the given ID is a valid id for the service. This avoids
# some problems that services have when you jam illegal logins in.
# For instance, log in to Yahoo with a Japanese username, and it
# just hangs on the connection, rather than doing anything.
# Note that this is more about not sending in logins that confuse 
# the remote services so badly we get no errors, NOT about precisely
# labelling which fields are possible. If the remote service correctly
# determines the password is invalid, then everything's fine.
sub valid_id {
    my ($self, $username) = @_;

    if ($username =~ m{/}) {
        return 0;
    }

    return 1;
}

sub valid_password {
    my ($self, $password) = @_;

    # If the prpl requires a password, _purple_connection_new() will
    # fail when password is NULL or zero-length without returning an
    # error thrasher_login() can detect. Worse, the check in
    # purple_account_connect() is slightly different so it wouldn't
    # even be detectable through purple_account_request_password() and
    # request_fields().
    #
    # Registering with an empty password therefore begins an
    # apparently successful async login that never completes or
    # errors. The user also can't re-register or log out because
    # they're already "logging in". :(
    #
    # If the prpl has OPT_PROTO_PASSWORD_OPTIONAL or OPT_PROTO_NO_PASSWORD
    # the corresponding subclass should override this.
    return !!$password;
}

sub purple_forces_kill { return 0; }

1;