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     return $self->SUPER::registration($jid, $registration_info);
  35 }
  36
  37 # This receives the message we're about to send out, and adds any
  38 # further processing that may be necessary.
  39 sub process_message {
  40     my $self = shift;
  41     my $message = shift;
  42
  43     return $message;
  44 #    return escapeHTML($message);
  45 }
  46
  47 #sub process_remote_username {
  48 #    my $self = shift;
  49 #    my $s = shift;
  50 #    $s =~ tr/[A-Z]/[a-z]/;
  51 #    $s =~ s/ //g;
  52 #    return $s;
  53 #}
  54
  55 sub name { "Yahoo" }
  56 sub identifier { "yahoo" }
  57 sub gateway_prompt { "Enter Yahoo Username:" }
  58 sub gateway_desc { "Enter Yahoo Username:" }
  59
  60 sub valid_id {
  61     my $self = shift;
  62     my $id = shift;
  63
  64     # Valid id information based on the registration screen's messages.
  65     return $id =~ /^[a-z][a-z_0-9]*(?:\.[a-z_0-9]*)?/i;
  66 }
  67
  68
  69
  70 1;