perl/lib/Thrasher/Protocol/Purple/Yahoo.pm

   1 package Thrasher::Protocol::Purple::Yahoo;
   2 use strict;
   3 use warnings;
   4
   5 =head1 NAME
   6
   7 Thrasher::Protocol::Purple::Yahoo - protocol for connection to Yahoo
   8 Instant Messenger.
   9
  10 =cut
  11
  12 use base "Thrasher::Protocol::Purple";
  13
  14 use Thrasher::Log qw(log debug);
  15 #use CGI qw(escapeHTML);
  16
  17 sub prpl {
  18     return "prpl-yahoo";
  19 }
  20
  21 sub registration {
  22     my ($self, $jid, $registration_info) = @_;
  23
  24     my $username = $registration_info->{'username'} || '';
  25     if ($username =~ /\@yahoo.com$/) {
  26         # FIXME: Some sources suggest this won't work for all IDs with
  27         # @yahoo.com emails, but our users seem to like it this way.
  28         # We should really do this only as a fallback if Yahoo gives
  29         # us a 1013 with the @yahoo.com username.
  30         debug("Suspiciously emailish Yahoo ID $username during registration.");
  31         $registration_info->{'username'} =~ s/\@yahoo.com$//;
  32     }
  33
  34     # If the username has trailing whitespace, the yahoo prpl starts
  35     # an asynchronous connection and never comes back with either
  36     # _connection or _connection_error! (reproducible in pidgin.)
  37     #
  38     # Note: Registering with a usernames with internal whitespace
  39     # already returns an invalid username error.
  40     $registration_info->{'username'} =~ s/^\s+|\s+$//g;
  41
  42     return $self->SUPER::registration($jid, $registration_info);
  43 }
  44
  45 # This receives the message we're about to send out, and adds any
  46 # further processing that may be necessary.
  47 sub process_message {
  48     my $self = shift;
  49     my $message = shift;
  50
  51     return $message;
  52 #    return escapeHTML($message);
  53 }
  54
  55 #sub process_remote_username {
  56 #    my $self = shift;
  57 #    my $s = shift;
  58 #    $s =~ tr/[A-Z]/[a-z]/;
  59 #    $s =~ s/ //g;
  60 #    return $s;
  61 #}
  62
  63 sub name { "Yahoo" }
  64 sub identifier { "yahoo" }
  65 sub gateway_prompt { "Enter Yahoo Username:" }
  66 sub gateway_desc { "Enter Yahoo Username:" }
  67
  68 sub valid_id {
  69     my $self = shift;
  70     my $id = shift;
  71
  72     # Valid id information based on the registration screen's messages.
  73     return $id =~ /^[a-z][a-z_0-9]*(?:\.[a-z_0-9]*)?/i;
  74 }
  75
  76
  77
  78 1;