Net::AIM - Perl extension for AOL Instant Messenger TOC protocol

  use Net::AIM;

  $aim = new Net::AIM;
  $conn = $aim->newconn(Screenname   => 'Perl AIM',
                        Password     => 'yaddayadda');
  $aim->start;

package Net::AIM;

#
# $Revision: 1.22 $
# $Author: aryeh $
# $Date: 2002/04/23 14:09:15 $
#
#
#

BEGIN { require 5.004; }    # needs IO::* and $coderef->(@args) syntax 

use Net::AIM::Connection;
use IO::Select;
use Carp;
use strict;
use vars qw($VERSION);

$VERSION = '1.22';

sub new {
   my $proto = shift;

   my $self = {
      '_conn'     => undef,  #one connection
      '_debug'    => 0,
      '_queue'    => undef,  # fuck this - a real queue!!
      '_qid'      => 'a',
      '_config'   => { 
          'Buddies' => {
	      'perlaim' => 'b'
	   }
      },
      '_chat_rooms'    => undef,
      '_timeout'  => 1
   };

   bless $self, $proto;

   return $self;
}

sub debug {
    my $self = shift;

    if (@_) {
	$self->{_debug} = $_[0];
    }
    return $self->{_debug};
}

sub set {
   my $self = shift;
   my ($k, $v) = @_;

   $self->{_opts}->{$k} = $v;
   print STDERR "Setting $k to $v\n" if ($self->{_debug});
}

sub get {
   my $self = shift;
   my $key = shift;

   if (exists $self->{_opts}->{$key}) {
        return $self->{_opts}->{$key};
   }

   return 0;
}

sub newconn {
   my $self = shift;

   my $conn = $self->{_conn} = Net::AIM::Connection->new($self, @_);

   return undef if $conn->error;
   return 1;
}

sub getconn {
   my $self = shift;
   return $self->{_conn};
}

sub do_one_loop {
   my $self = shift;
    
   my ($ev, $sock, $time, $nexttimer, $timeout);
   print STDERR "Entered do_one_loop\n" if ($self->{_debug});

   # This cycles through our event queue and exects things that 
   # have an expired time.  It also sets $nexttimer to the closest
   # time of the next event so we wake up for that event while 
   # waiting for data.
#   if (0) { 
#   # Check the queue for scheduled events to run.
#   $time = time();
#   $nexttimer = 0;
#   foreach $ev ($self->queue) {
#      if ($self->{_queue}->{$ev}->[0] <= $time) {
#	 $self->{_queue}->{$ev}->[1]->
#	    (@{$self->{_queue}->{$ev}}[2..$#{$self->{_queue}->{$ev}}]);
#	 delete $self->{_queue}->{$ev};
#      } else {
#	 $nexttimer = $self->{_queue}->{$ev}->[0] 
#	    if ($self->{_queue}->{$ev}->[0] < $nexttimer
#	       or not $nexttimer);
#      }
#   }
#
#   }


   # Block until input arrives, then hand the filehandle over to the
   # user-supplied coderef. Look! It's a freezer full of government cheese!
   #
   # doesn't look like the stuff below is needed... on its way out...
#   if ($nexttimer) {
#      $timeout = $nexttimer - $time < $self->{_timeout}
#	 ? $nexttimer - $time : $self->{_timeout};
#   } else {
#      $timeout = $self->{_timeout};
#   }

   # TODO get return value so we can drop out on disconnect
   # Or maybe just use the even queue and make a connect evt

   my $rv = 1;
   my $sel = $self->{_conn}->select;

   foreach $ev ($sel->can_read($self->{_timeout})) {
      $self->{_conn}->read_and_parse();
   }

   return $rv;
}

sub start {
    my $self = shift;

    while (1) {
	last unless $self->do_one_loop();
    }
}

sub timeout {
    my $self = shift;

    if (@_) { $self->{_timeout} = $_[0] }
    return $self->{_timeout};
}


#################### BEGIN  ######################

sub is_buddy {
   my $self = shift;
   my $group = shift;
   my $buddy = shift;

   return 1 if ($self->{_config}->{$group}->{$self->normalize($buddy)} eq 'b');
   return 0;

}

sub add_buddy {
   my $self = shift;
   my $send = shift;
   my $group = shift;
   my @buddies = @_;
		
   my $budstring = '';
   foreach my $bud (@buddies) {
      $self->{_config}->{$group}->{$self->normalize($bud)} = 'b';
   }

   return unless ($send);
   return $self->{_conn}->add_buddy(@buddies);
}

sub add_permit {
   my $self = shift;
   my $send = shift;
   my $group = shift;
   my @buddies = @_;
		

   my $budstring = '';
   foreach my $bud (@buddies) {
      $self->{_config}->{$group}->{$self->normalize($bud)} = 'p';
   }

   return unless ($send);
   return $self->{_conn}->add_permit(@buddies);
}

sub add_deny {
   my $self = shift;
   my $send = shift;
   my $group = shift;
   my @buddies = @_;
		

   my $budstring = '';
   foreach my $bud (@buddies) {
      $self->{_config}->{$group}->{$self->normalize($bud)} = 'd';
   }

   return unless ($send);
   return $self->{_conn}->add_deny(@buddies);
}

sub remove_buddy {
   my $self = shift;
   my $send = shift;
   my $group = shift;
   my @buddies = @_;
		
   my $budstring = '';
   foreach my $bud (@buddies) {
      delete $self->{_config}->{$group}->{$self->normalize($bud)};
   }

   return unless ($send);
   return $self->{_conn}->remove_buddy(@buddies);
}

# We should AUTOLOAD all of these ....

sub set_away {
   my $self = shift;
   return $self->{_conn}->set_away(@_);
}

sub get_info {
   my $self = shift;
   return $self->{_conn}->get_info(@_);
}

sub set_info {
   my $self = shift;
   return $self->{_conn}->set_info(@_);
}

sub evil {
   my $self = shift;
   return $self->{_conn}->evil(@_);
}

sub send {
   my $self = shift;
   return $self->{_conn}->send(@_);
}

sub chat_invite {
   my $self = shift;
   return $self->{_conn}->chat_invite(@_);
}

sub chat_accept {
   my $self = shift;
   return $self->{_conn}->chat_accept(@_);
}

sub chat_leave {
   my $self = shift;
   return $self->{_conn}->chat_leave(@_);
}

sub chat_whisper {
   my $self = shift;
   return $self->{_conn}->chat_whisper(@_);
}

sub chat_send {
   my $self = shift;
   return $self->{_conn}->chat_send(@_);
}

sub chat_join {
   my $self = shift;
   return $self->{_conn}->chat_join(@_);
}

sub send_im {
   my $self = shift;
   return $self->{_conn}->send_im(@_);
}

sub list_rooms {
   my $self = shift;

   my @data;
   while (my ($k, $v) = each(%{ $self->{_chat_rooms}} )) {
      push @data, "$k:$v";
   }
   return (@data);
}

sub get_roomname {
   my $self = shift;
   my $id = shift;

   return ($self->{_chat_rooms}->{$id});
}

sub set_roomname {
   my $self = shift;
   my $id = shift;
   my $roomname = shift;

   $self->{_chat_rooms}->{$id} = $roomname;
   return;
}

sub del_roomname {
   my $self = shift;
   my $id = shift;

   delete $self->{_chat_rooms}->{$id};
}

#sub chat_joined {
#   my $self = shift;
#   my $id = shift;
#   my $room = shift;
#
#   $self->{_chat_rooms}->{$id} = $room;
#}

sub encode {
   my $self = shift;
   my $str = shift;

   $str =~ s/([\\\}\{\(\)\[\]\$\"])/\\$1/g;
   return ('"' . $str . '"');
}

sub send_config {
   my $self = shift;
   my $configstr = 'm ';

   if ( defined $self->{_config} &&
      exists $self->{_config}->{mode} &&
      $self->{_config}->{mode} =~ /^\d$/ ) {
	 $configstr .= $self->{_config}->{mode};
   } else {
      $configstr .= '1';
   }

   $configstr .= "\n";
   foreach my $group ( keys %{ $self->{_config} } ) {
      next if ($group eq 'mode');  # we did this already
      $configstr .= "g $group\n";
      while (my ($sn, $type) = each %{ $self->{_config}->{$group} } ) {
	 $configstr .= "$type $sn\n";
      }
   }

   $self->{_conn}->send_config($configstr);
#	print "toc_set_config $configstr\n-----\n" ;

}

sub send_buddies {
   my $self = shift;

   my @buddies;

   foreach my $group ( keys %{ $self->{_config} } ) {
      next if ($group eq 'mode');  # we did this already

      while (my ($sn, $type) = each %{ $self->{_config}->{$group} } ) {
	 next unless ($type eq 'b');
	 push @buddies, $sn;	
      }
   }

   # we seem to croak if we have no buddies.... on signup
   push @buddies, $self->{_conn}->screenname() if (@buddies == 0);

   $self->{_conn}->add_buddy(@buddies);
}

sub set_config_str {
   my $self = shift;
   my $str = shift;
   my $add = shift;
   my $group = 'unknown';

   $self->{_config} = {} unless($add);

   foreach (split(/\n/, $str))  {
      my ($char, $item);

      ($char, $item) = split(/\s/, $_, 2);
      next unless (defined $char && defined $item);

#      print STDERR " .. save config [$char, $item]\n";
      if ($char eq 'm') {
	 $self->{_config}->{mode} = $item; 
      } elsif ($char eq 'g') {
	 $group = $item;
      } elsif ($char =~/^[pdb]$/) {
         $self->{_config}->{$group}->{$self->normalize($item)} = $char;
      }
   }

}

# this is here for backwards compatibility
sub set_config {
   my $self = shift;
   my $str = shift;
   return $self->set_config_str($str, 1);
}

sub normalize {
   my $self = shift;
   my $data = shift;

   $data =~ s/[^A-Za-z0-9]//g;
   $data =~ tr/A-Z/a-z/;
   return $data;
}

#sub quit {
#    my $self = shift;
#
#    # Do any user-defined stuff before leaving
#    $self->handler("leaving");
#
#    unless ( $self->connected ) {  return (1)  }
#    return 1;
#}

"Aryeh Goldsmith <perlaim\@aryeh.net>";
__END__