view release on metacpan or  search on metacpan

TOC.pm  view on Meta::CPAN

package AOL::TOC;

use IO;
use Socket;
use AOL::SFLAP;

$VERSION      = "0.34";
$TOC_VERSION  = "1.0";
$ROASTING_KEY = "Tic/Toc";

# Preloaded methods go here.

# Autoload methods go after =cut, and are processed by the autosplit program.

=head1 NAME

AOL::TOC - Perl extension for interfacing with AOL's AIM service

=head1 SYNOPSIS

  use AOL::TOC;
  $toc = AOL::TOC::new($toc_server, $login_server, $port,
         $screenname, $password); 
  $toc->connect();

=head1 DESCRIPTION

This module implements SFLAP, which I presume to be AOL's authenticiation
protocol, and TOC, which is the actual "meat" of the AIM protocol.

=head1 INTERFACE

=head2 connect

connects to the AIM server

=head2 register_callback

This function takes two arguments, the EVENT and the subroutine reference.
Callbacks are similar to the ones found in Net::IRC. The module defines
several AIM "events": ERROR, CLOSED, SIGN_ON, IM_IN, CHAT_IN, UPDATE_BUDDY.
These events can be bound to subroutines.

=head2 dispatch

This flushes all messages to the server, and retreives all current messages.

=head2 add_buddy

Takes one arguement, the nick of the buddy. 
This adds a buddy to your buddy list.

=head2 send_im

Takes two arguments, the name of the buddy and the name of the message, and
sends the IM.

=head2 get_info

Takes one argument, the name of the buddy, and returns the info.

=head2 chat_join

Takes one argument, the name of the chat room to join

=head2 chat_send

Takes two arguments, the name of the chat room, and the message.

=head1 AUTHOR

xjharding@newbedford.k12.ma.us cleaned it up and added DOC
james@foo.org was the original author

=head1 SEE ALSO

Net::AIM, a new module, but it doesn't have the features of this one

=cut

sub roast_password {
  my ($password, $key) = @_;
  my @skey;
  my $rpassword = "0x";
  my $i = 0;

  if (!$key) { $key = $ROASTING_KEY; }

  @skey = split('', $key);

  for $c (split('', $password)) {
    $p = unpack("c", $c);
    $k = unpack("c", @skey[$i % length($key)]);
    $rpassword = sprintf("%s%02x", $rpassword, $p ^ $k);
    $i ++;
  }

  return ($rpassword);
}


sub encode_string {
  my ($self, $str) = @_;
  my ($estr, $i);

  if (!$str) { $str = $self; }

  $estr = "\"";
  for $i (split('', $str)) {
    if (
      ($i eq "\\") || ($i eq "\{") || ($i eq "\}") ||
      ($i eq "\(") || ($i eq "\)") || ($i eq "\[") ||
      ($i eq "\]") || ($i eq "\$") || ($i eq "\""))  
      { 
        $estr .= "\\";
      }
      $estr .= $i;
  }
  $estr .= "\"";

  return ($estr);
}


sub register_callback {
  my ($self, $event, $func, @args) = @_;

  push (@{$self->{callback}{$event}}, $func);
  @{$self->{callback}{$func}} = @args;

  return;
}


sub callback {
  my ($self, $event, @args) = @_;
  my $func;

TOC.pm  view on Meta::CPAN

  }

  $self->send("toc_chat_accept $room_id");                      
  return;
}


sub get_info {
  my ($self, $nickname) = @_;

  $self->send("toc_get_info $nickname");
  return;
}


sub set_info {
  my ($self, $info) = @_;

  $self->send("toc_set_info " . &encode_string($info));
  return;
}


# SFLAP Callbacks

sub sflap_signon {
  my ($self, $data, $password, $language, $version, $toc) = @_;
  my ($buffer, $roasted_password);

  $roasted_password = roast_password($password, $ROASTING_KEY);

  $buffer = pack("Nnna*", 1, 1, length($toc->{sflap}->{nickname}), $toc->{sflap}->{nickname});
  $toc->{sflap}->send($AOL::SFLAP::SFLAP_SIGNON, $buffer);

  $toc->signon($toc->{sflap}->{authorizer}, $toc->{sflap}->{port}, $toc->{sflap}->{nickname}, $roasted_password, $language, $version);
}

sub sflap_data {
  my ($self, $data, $toc) = @_;
  my ($cmd, $args);

  ($cmd, $args) = ($data =~ /^(\w+)\:(.*)$/);

  return unless defined $cmd && defined $args;

  if ($cmd eq "SIGN_ON") {
    ($toc_version) = ($args =~ /^TOC(.*)$/);
    $toc->callback("SIGN_ON", $toc_version);
  }

  if ($cmd eq "CONFIG") {
    $toc->callback("CONFIG", $args);
  }

  if ($cmd eq "NICK") {
    ($beautified_nick) = ($args =~ /^(.*)$/);
    $toc->callback("NICK", $beautified_nick);
  }

  if ($cmd eq "IM_IN") {
    ($nickname, $autoresponse, $message) = ($args =~ /^(.*)\:(.*)\:(.*)$/);
    $toc->callback("IM_IN", $nickname, $autoresponse, $message);
  }

  if ($cmd eq "UPDATE_BUDDY") {
    ($nickname, $online, $evil, $signon_time, $idle_time, $class) = ($args =~ /^(.*)\:(.*)\:(.*)\:(.*)\:(.*)\:(.*)$/);
    $toc->callback("UPDATE_BUDDY", $nickname, $online, $evil, $signon_time, $idle_Time, $class);
  }

  if ($cmd eq "ERROR") {
    ($code, $args) = ($args =~ /^(\d*).?(.*)$/);
    $toc->callback("ERROR", $code, $args);
  }

  if ($cmd eq "EVILED") {
    ($evil_level, $nickname) = ($args =~ /^(.*)\:(.*)$/);
    $toc->callback("EVILED", $evil_level, $nickname);
  }

  if ($cmd eq "CHAT_JOIN") {
    ($room_id, $room_name) = ($args =~ /^(.*)\:(.*)$/);
    $toc->callback("CHAT_JOIN", $room_id, $room_name);
  }

  if ($cmd eq "CHAT_IN") {
    ($room_id, $nickname, $whisper, $message) = ($args =~ /^(.*)\:(.*)\:(.*)\:(.*)$/);
    $toc->callback("CHAT_IN", $room_id, $nickname, $whisper, $message);
  }

  if ($cmd eq "CHAT_UPDATE_BUDDY") {
    ($room_id, $inside, $nicknames) = ($args =~ /^(.*)\:(.*)\:(.*)$/);
    $toc->callback("CHAT_UPDATE_BUDDY", $room_id, $inside, $nicknames);
  }

  if ($cmd eq "CHAT_INVITE") {
    ($room_name, $room_id, $nickname, $message) = ($args =~ /^(.*)\:(.*)\:(.*)\:(.*)$/);
    $toc->callback("CHAT_INVITE", $room_name, $room_id, $nickname, $message);
  }

  if ($cmd eq "CHAT_LEFT") {
    ($room_id) = ($args =~ /^(.*)$/);
    $toc->callback("CHAT_LEFT", $room_id);
  }

  if ($cmd eq "GOTO_URL") {
    ($window_name, $url) = ($args =~ /^(.*)\:(.*)$/);
    $toc->callback("GOTO_URL", $window_name, $url);
  }

  if ($cmd eq "PAUSE") {
    $toc->callback("PAUSE");
  }

}

sub sflap_error {
  my ($self, $data, $toc) = @_;

  return;
}

sub sflap_signoff {