package Net::OSCAR; $VERSION = '0.62'; =head1 NAME Net::OSCAR - Implementation of AOL's OSCAR protocol for instant messaging =head1 SYNOPSIS use Net::OSCAR qw(:standard); use Net::OSCAR::OldPerl; # You may need to use this perls older than 5.6. $oscar = Net::OSCAR->new(); $oscar->set_callback_foo(\&foo); $oscar->signon($screenname, $password); while(1) { $oscar->do_one_loop(); # Do stuff } =head1 INSTALLATION perl Makefile.PL make make test make install See C<perlmodinstall> for details. =head1 DEPENDENCIES This modules requires C<Digest::MD5> and C<Scalar::Util>. =head1 ABSTRACT C<Net::OSCAR> implements the OSCAR protocol which is used by AOL's AOL Instant Messenger service. To use the module, you create a C<Net::OSCAR> object, register some functions as handlers for various events by using the module's callback mechanism, and then continually make calls to the module's event processing methods. You probably want to use the :standard parameter when importing this module in order to have a few important constants added to your namespace. See L<"CONSTANTS"> below for a list of the constants exported by the C<:standard> tag. No official documentation exists for the OSCAR protocol, so it had to be figured out by analyzing traffic generated by AOL's official AOL Instant Messenger client. That doesn't really help this module's stability much. This module strives to be as compatible with C<Net::AIM> as possible, but some protocol-level differences prevent total compatibility. The TOC protocol implemented by C<Net::AIM> is simpler and more well-documented but less-powerful protocol then C<OSCAR>. See the section on L<Net::AIM Compatibility> for more information. =head1 EVENT PROCESSING There are three main ways for the module to handle event processing. The first is to call the L<do_one_loop> method, which performs a C<select> call on all the object's sockets and reads incoming commands from the OSCAR server on any connections which have them. The C<select> call has a default timeout of 0.01 seconds which can be adjust using the L<timeout> method. A second way of doing event processing is designed to make it easy to integrate C<Net::OSCAR> into an existing C<select>-based event loop, especially one where you have many C<Net::OSCAR> objects. Simply call the L<"process_connections"> method with references to the lists of readers, writers, and errors given to you by C<select>. Connections that don't belong to the object will be ignored, and connections that do belong to the object will be removed from the C<select> lists so that you can use the lists for your own purposes. Here is an example that demonstrates how to use this method with multiple C<Net::OSCAR> objects: my($rin, $win) = (0, 0); foreach my $oscar(@oscars) { my($thisrin, $thiswin) = $oscar->selector_filenos; $rin |= $thisrin; $win |= $thiswin; } # Add in any other file descriptors you care about using vec(). my $ein = $rin | $win; select($rin, $win, $ein, 0.01); foreach my $oscar(@oscars) { $oscar->process_connections(\$rin, \$win, \$ein); } # Now $rin, $win, and $ein only have the file descriptors not # associated with any of the OSCAR objects in them - we can # process our events. The third way of doing connection processing uses the L<"connection_changed"> callback in conjunction with C<Net::OSCAR::Connection>'s L<"process_one"> method. This method, in conjunction with C<IO::Poll>, probably offers the highest performance in situations where you have a long-lived application which creates and destroys many C<Net::OSCAR> sessions; that is, an application whose list of file descriptors to monitor will likely be sparse. However, this method is the most complicated. What you need to do is call C<IO::Poll::mask> inside of the L<"connection_changed"> callback. That part's simple. The tricky bit is figuring out which C<Net::OSCAR::Connection::process_one>'s to call and how to call them. My recommendation for doing this is to use a hashmap whose keys are the file descriptors of everything you're monitoring in the C<IO::Poll> - the FDs can be retrieved by doing C<fileno($connection-E<gt>get_filehandle)> inside of the L<"connection_changed"> - and then calling C<@handles = $poll-E<gt>handles(POLLIN | POLLOUT | POLLERR | POLLHUP)> and walking through the handles. =head1 FUNCTIONALITY C<Net::OSCAR> pretends to be WinAIM 4.7.2480. It supports remote buddylists including permit and deny settings. It also supports chat. At the present time, setting and retrieving of directory information is not supported; nor are email privacy settings, buddy icons, voice chat, stock ticker, and many other of the official AOL Instant Messenger client's features. =head1 TERMINOLOGY/METHODOLOGY When you sign on with the OSCAR service, you are establishing an OSCAR session. C<Net::OSCAR> connects to the login server and requests a random challenge string. It then sends the MD5 sum of the challenge string, C<AOL Instant Messenger (SM)>, and your password to the server. If the login is successful, the login server gives you an IP address and an authorization cookie to use to connect with the BOS (Basic OSCAR Services) server. C<Net::OSCAR> proceeds to disconnect from the login server and connect to the BOS server. The two go through a handshaking process which includes the server sending us our buddylist. C<Net::OSCAR> supports privacy controls. Our visibility setting, along with the contents of the permit and deny lists, determines who can contact us. Visibility can be set to permit or deny everyone, permit only those on the permit list, deny only those on the deny list, or permit everyone on our buddylist. =head1 METHODS =over 4 =cut use strict; use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS); use Carp; use Scalar::Util; use Net::OSCAR::Common qw(:all); use Net::OSCAR::Connection; use Net::OSCAR::Callbacks; use Net::OSCAR::TLV; use Net::OSCAR::Buddylist; use Net::OSCAR::Screenname; use Net::OSCAR::Chat; use Net::OSCAR::_BLInternal; use Net::OSCAR::OldPerl; require Exporter; @ISA = qw(Exporter); @EXPORT_OK = @Net::OSCAR::Common::EXPORT_OK; %EXPORT_TAGS = %Net::OSCAR::Common::EXPORT_TAGS; =pod =item new Creates a new C<Net::OSCAR> object. =cut sub new($) { my $class = ref($_[0]) || $_[0] || "Net::OSCAR"; shift; my $self = { }; bless $self, $class; $self->{LOGLEVEL} = 0; $self->{SNDEBUG} = 0; $self->{description} = "OSCAR session"; $self->{timeout} = 0.01; return $self; } =pod =item timeout ([NEW TIMEOUT]) Gets or sets the timeout value used by the L<do_one_loop> method. The default timeout is 0.01 seconds. =cut sub timeout($;$) { my($self, $timeout) = @_; return $self->{timeout} unless $timeout; $self->{timeout} = $timeout; } =pod =item signon (HASH) =item signon (SCREENNAME, PASSWORD[, HOST, PORT]) Sign on to the OSCAR service. Using a hash to pass the parameters to this function is preferred - the old method is deprecated. You can specify an alternate host/port to connect to. The default is login.oscar.aol.com port 5190. If you use a hash to pass parameters to this function, here are the valid keys: =over 4 =item screenname =item password Screenname and password are mandatory. The other keys are optional. In the special case of password being present but undefined, the auth_challenge callback will be used - see L<"auth_challenge"> for details. =item host =item port =back There are some other data that can be passed to this method. These data are used to sign on to an OSCAR-using service other than the default of AOL Instant Messenger, such as ICQ. You should not attempt to specify these data directly - instead, use one of the following constants: =over 4 =item OSCAR_SVC_AIM =item OSCAR_SVC_ICQ =back Example of signing on to ICQ: $oscar->signon(screenname => "123456", password => "password", OSCAR_SVC_ICQ); =cut sub signon($@) { my($self, $password, $host, %args); $self = shift; # Determine whether caller is using hash-method or old method of passing parms. # Note that this breaks if caller passes in both a host and a port using the old way. # But hey, that's why it's deprecated! if(@_ < 3) { $args{screenname} = shift @_ or return $self->crapout($self->{bos}, "You must specify a username to sign on with!"); $args{password} = shift @_ or return $self->crapout($self->{bos}, "You must specify a password to sign on with!");; $args{host} = shift @_ if @_; $args{port} = shift @_ if @_; } else { %args = @_; return $self->crapout($self->{bos}, "You must specify a username and password to sign on with!") unless $args{screenname} and exists($args{password}); } my %defaults = OSCAR_SVC_AIM; foreach my $key(keys %defaults) { $args{$key} ||= $defaults{$key}; } return $self->crapout($self->{bos}, "MD5 authentication not available for this service (you must define a password.)") if !defined($args{password}) and $args{hashlogin}; $self->{screenname} = new Net::OSCAR::Screenname $args{screenname}; # We set BOS to the login connection so that our error handlers pick up errors on this connection as fatal. $args{host} ||= "login.oscar.aol.com"; $args{port} ||= 5190; ($self->{screenname}, $password, $host, $self->{port}) = delete @args{qw(screenname password host port)}; $self->{svcdata} = \%args; $self->{bos} = $self->addconn($password, CONNTYPE_LOGIN, "login", $host); } =pod =item auth_response (MD5_DIGEST) Provide a response to an authentication challenge - see the L<"auth_challenge"> callback for details. =cut sub auth_response($$) { my($self, $digest) = @_; $self->log_print(OSCAR_DBG_SIGNON, "Got authentication response - proceeding with signon"); $self->{auth_response} = $digest; $self->{bos}->snac_put(family => 0x17, subtype => 0x2, data => tlv(signon_tlv($self))); } =pod =item signoff Sign off from the OSCAR service. =cut sub signoff($) { my $self = shift; foreach my $connection(@{$self->{connections}}) { $self->delconn($connection); } my $screenname = $self->{screenname}; %$self = (); $self->{screename} = $screenname; # Useful for post-mortem processing in multiconnection apps } =pod =item loglevel ([LOGLEVEL[, SCREENNAME DEBUG]]) Gets or sets the loglevel. If this is non-zero, varing amounts of information will be printed to standard error (unless you have a L<"log"> callback defined). Higher loglevels will give you more information. If the optional screenname debug parameter is non-zero, debug messages will be prepended with the screenname of the OSCAR session which is generating the message (but only if you don't have a L<"log"> callback defined). This is useful when you have multiple C<Net::OSCAR> objects. See the L<"log"> callback for more information. =cut sub loglevel($;$$) { my $self = shift; return $self->{LOGLEVEL} unless @_; $self->{LOGLEVEL} = shift; $self->{SNDEBUG} = shift if @_; } sub addconn($$$$$) { my $self = shift; my $conntype = $_[1]; my $connection = ($conntype == CONNTYPE_CHAT) ? Net::OSCAR::Chat->new($self, @_) : Net::OSCAR::Connection->new($self, @_); if($_[1] == CONNTYPE_BOS) { $self->{bos} = $connection; } elsif($_[1] == CONNTYPE_ADMIN) { $self->{admin} = 1; # We're not quite ready yet - add to queue but don't send svcreq } elsif($_[1] == CONNTYPE_CHATNAV) { $self->{chatnav} = 1; } push @{$self->{connections}}, $connection; $self->callback_connection_changed($connection, "write"); return $connection; } sub delconn($$) { my($self, $connection) = @_; return unless $self->{connections}; $self->callback_connection_changed($connection, "deleted"); for(my $i = scalar @{$self->{connections}} - 1; $i >= 0; $i--) { next unless $self->{connections}->[$i] == $connection; $connection->log_print(OSCAR_DBG_NOTICE, "Closing."); splice @{$self->{connections}}, $i, 1; if(!$connection->{sockerr}) { eval { $connection->flap_put("", FLAP_CHAN_CLOSE) if $connection->{socket}; close $connection->{socket} if $connection->{socket}; }; } else { if($connection->{conntype} == CONNTYPE_BOS or ($connection->{conntype} == CONNTYPE_LOGIN and !$connection->{closing})) { delete $connection->{socket}; print $connection->{sockerr}; return $self->crapout($connection, "Lost connection to BOS"); } elsif($connection->{conntype} == CONNTYPE_CHATNAV) { delete $self->{chatnav}; } elsif($connection->{conntype} == CONNTYPE_ADMIN) { delete $self->{admin}; $self->callback_admin_error("all", ADMIN_ERROR_CONNREF, undef) if scalar(keys(%{$self->{adminreq}})); } elsif($connection->{conntype} == CONNTYPE_CHAT) { $self->callback_chat_closed($connection, "Lost connection to chat"); } } delete $connection->{socket}; return 1; } return 0; } =pod =item findconn (FILENO) Finds the connection that is using the specified file number, or undef if the connection could not be found. Returns a C<Net::OSCAR::Connection> object. =cut sub findconn($$) { my($self, $target) = @_; my($conn) = grep { fileno($_->{socket}) == $target } @{$self->{connections}}; return $conn; } sub DESTROY { my $self = shift; foreach my $connection(@{$self->{connections}}) { next unless $connection->{socket} and not $connection->{sockerr}; $connection->flap_put("", FLAP_CHAN_CLOSE); close $connection->{socket} if $connection->{socket}; } } =pod =item process_connections (READERSREF, WRITERSREF, ERRORSREF) Use this method when you want to implement your own C<select> statement for event processing instead of using C<Net::OSCAR>'s L<do_one_loop> method. The parameters are references to the readers, writers, and errors parameters used by the select statement. The method will ignore all connections which are not C<Net::OSCAR::Connection> objects or which are C<Net::OSCAR::Connection> objects from a different C<Net::OSCAR> object. It modifies its arguments so that its connections are removed from the connection lists. This makes it very convenient for use with multiple C<Net::OSCAR> objects or use with a C<select>-based event loop that you are also using for other purposes. See the L<selector_filenos> method for a way to get the necessary bit vectors to use in your C<select>. =cut sub process_connections($\$\$\$) { my($self, $readers, $writers, $errors) = @_; # Filter out our connections and remove them from the to-do list foreach my $connection(@{$self->{connections}}) { my($read, $write) = (0, 0); next unless $connection->fileno; if($connection->{connected}) { next unless vec($$readers | $$errors, $connection->fileno, 1); vec($$readers, $connection->fileno, 1) = 0; $read = 1; } if(!$connection->{connected} or $connection->{outbuff}) { next unless vec($$writers | $$errors, $connection->fileno, 1); vec($$writers, $connection->fileno, 1) = 0; $write = 1; } if(vec($$errors, $connection->fileno, 1)) { vec($$errors, $connection->fileno, 1) = 0; $connection->{sockerr} = 1; print "socket error is: " . $$errors; $connection->disconnect(); } else { $connection->process_one($read, $write); } } } =pod =item do_one_loop Processes incoming data from our connections to the various OSCAR services. This method reads one command from any connections which have data to be read. See the L<timeout> method to set the timeout interval used by this method. =cut sub do_one_loop($) { my $self = shift; my $timeout = $self->{timeout}; undef $timeout if $timeout == -1; my($rin, $win, $ein) = ('', '', ''); foreach my $connection(@{$self->{connections}}) { next unless exists($connection->{socket}); if($connection->{connected}) { vec($rin, fileno $connection->{socket}, 1) = 1; } else { vec($win, fileno $connection->{socket}, 1) = 1; } } $ein = $rin | $win; my $nfound = select($rin, $win, $ein, $timeout); $self->process_connections(\$rin, \$win, \$ein) if $nfound; } sub findgroup($$) { my($self, $groupid) = @_; my($group, $currgroup, $currid); my $thegroup = undef; $self->log_printf(OSCAR_DBG_DEBUG, "findgroup 0x%04X", $groupid); while(($group, $currgroup) = each(%{$self->{buddies}})) { $self->log_printf(OSCAR_DBG_DEBUG, "\t$group == 0x%04X", $currgroup->{groupid}); next unless exists($currgroup->{groupid}) and $groupid == $currgroup->{groupid}; $thegroup = $group; last; } my $a = keys %{$self->{buddies}}; # reset the iterator return $thegroup; } =pod =item findbuddy (BUDDY) Returns the name of the group that BUDDY is in, or undef if BUDDY could not be found in any group. If BUDDY is in multiple groups, will return the first one we find. =cut sub findbuddy($$) { my($self, $buddy) = @_; #$self->log_print(OSCAR_DBG_DEBUG, "findbuddy $buddy"); foreach my $group(keys %{$self->{buddies}}) { #$self->debug_print("\t$buddy? ", join(",", keys %{$self->{buddies}->{$group}->{members}})); return $group if $self->{buddies}->{$group}->{members}->{$buddy}; } return undef; } sub findbuddy_byid($$$) { my($self, $buddies, $bid) = @_; while(my($buddy, $value) = each(%$buddies)) { return $buddy if $value->{buddyid} == $bid; } return undef; } sub newid($;$) { my($self, $group) = @_; my $id = 0; my %ids = (); if($group) { %ids = map { $_->{buddyid} => 1 } values %$group; do { ++$id; } while($ids{$id}); } else { do { $id = ++$self->{nextid}->{__GROUPID__}; } while($self->findgroup($id)); } return $id; } =pod =item commit_buddylist Sends your modified buddylist to the OSCAR server. Changes to the buddylist won't actually take effect until this method is called. Methods that change the buddylist have a warning about needing to call this method in their documentation. =item rollback_buddylist Revert changes you've made to the buddylist, assuming you haven't called L<"commit_buddylist"> since making them. =item reorder_groups (GROUPS) Changes the ordering of the groups in your buddylist. Call L<"commit_buddylist"> to save the new order on the OSCAR server. =item reorder_buddies (GROUP, BUDDIES) Changes the ordering of the buddies in a group on your buddylist. Call L<"commit_buddylist"> to save the new order on the OSCAR server. =item add_permit (BUDDIES) Add buddies to your permit list. Call L<"commit_buddylist"> for the change to take effect. =item add_deny (BUDDIES) See L<add_permit>. =item remove_permit (BUDDIES) See L<add_permit>. =item remove_deny (BUDDIES) See L<add_permit>. =item get_permitlist Returns a list of all members of the permit list. =item get_denylist Returns a list of all members of the deny list. =cut sub commit_buddylist($) { my($self) = shift; return must_be_on($self) unless $self->{is_on}; Net::OSCAR::_BLInternal::NO_to_BLI($self); } sub reorder_groups($@) { my $self = shift; return must_be_on($self) unless $self->{is_on}; my @groups = @_; tied(%{$self->{buddies}})->setorder(@groups); } sub reorder_buddies($$@) { my $self = shift; return must_be_on($self) unless $self->{is_on}; my $group = shift; my @buddies = @_; tied(%{$self->{buddies}->{$group}->{members}})->setorder(@buddies); } sub add_permit($@) { shift->mod_permit(MODBL_ACTION_ADD, "permit", @_); } sub add_deny($@) { shift->mod_permit(MODBL_ACTION_ADD, "deny", @_); } sub remove_permit($@) { shift->mod_permit(MODBL_ACTION_DEL, "permit", @_); } sub remove_deny($@) { shift->mod_permit(MODBL_ACTION_DEL, "deny", @_); } sub get_permitlist($) { return keys %{shift->{permit}}; } sub get_denylist(@) { return keys %{shift->{deny}}; } =pod =item rename_group (OLDNAME, NEWNAME) Renames a group. Call L<"commit_buddylist"> for the change to take effect. =item add_buddy (GROUP, BUDDIES) Adds buddies to the given group on your buddylist. Call L<"commit_buddylist"> for the change to take effect. =item remove_buddy (GROUP, BUDDIES) See L<add_buddy>. =cut sub rename_group($$$) { my($self, $oldgroup, $newgroup) = @_; return must_be_on($self) unless $self->{is_on}; return send_error($self, $self->{bos}, 0, "That group does not exist", 0) unless exists $self->{buddies}->{$oldgroup}; $self->{buddies}->{$newgroup} = $self->{buddies}->{$oldgroup}; delete $self->{buddies}->{$oldgroup}; } sub add_buddy($$@) { my($self, $group, @buddies) = @_; $self->mod_buddylist(MODBL_ACTION_ADD, MODBL_WHAT_BUDDY, $group, @buddies); } sub remove_buddy($$@) { my($self, $group, @buddies) = @_; $self->mod_buddylist(MODBL_ACTION_DEL, MODBL_WHAT_BUDDY, $group, @buddies); } =pod =item set_visibility (MODE) Sets the visibility mode, which determines how the permit and deny lists are interpreted. The visibility mode may be: =over 4 =item * VISMODE_PERMITALL: Permit everybody. =item * VISMODE_DENYALL: Deny everybody. =item * VISMODE_PERMITSOME: Permit only those on your permit list. =item * VISMODE_DENYSOME: Deny only those on your deny list. =item * VISMODE_PERMITBUDS: Same as VISMODE_PERMITSOME, but your permit list is made to be the same as the buddies from all the various groups in your buddylist (except the deny group!) Adding and removing buddies maintains this relationship. You shouldn't manually alter the permit or deny groups when using this visibility mode. =back These constants are contained in the C<Net::OSCAR::Common> package, and will be imported into your namespace if you import C<Net::OSCAR> with the C<:standard> parameter. When someone is permitted, they can see when you are online and send you messages. When someone is denied, they can't see when you are online or send you messages. You cannot see them or send them messages. You can talk to them if you are in the same chatroom, although neither of you can invite the other one into a chatroom. Call L<"commit_buddylist"> for the change to take effect. =cut sub set_visibility($$) { my($self, $vismode) = @_; return must_be_on($self) unless $self->{is_on}; $self->{visibility} = $vismode; } =pod =item set_group_permissions (NEWPERMS) Set group permissions. This lets you block any OSCAR users or any AOL users. C<NEWPERMS> should be a list of zero or more of the following constants: =over 4 =item GROUPPERM_OSCAR Permit AOL Instant Messenger users to contact you. =item GROUPPERM_AOL Permit AOL subscribers to contact you. =back Call L<"commit_buddylist"> for the change to take effect. =cut sub set_group_permissions($@) { my($self, @perms) = @_; my $perms = 0xFFFFFF00; return must_be_on($self) unless $self->{is_on}; foreach my $perm (@perms) { $perms |= $perm; } $self->{groupperms} = $perms; } =pod =item group_permissions Returns current group permissions. The return value is a list like the one that L<"set_group_permissions"> wants. =cut sub group_permissions($) { my $self = shift; my @retval = (); foreach my $perm (GROUPPERM_OSCAR, GROUPPERM_AOL) { push @retval, $perm if $self->{groupperms} & $perm; } return @retval; } =pod =item profile Returns your current profile. =cut sub profile($) { return shift->{profile}; } =pod =item get_app_data ([GROUP[, BUDDY]]) Gets application-specific data. Returns a hashref whose keys are app-data IDs. IDs with high-order byte 0x0001 are reserved for non-application-specific usage and must be registered with the C<libfaim-aim-protocol@lists.sourceforge.net> list. If you wish to set application-specific data, you should reserve a high-order byte for your application by emailing C<libfaim-aim-protocol@lists.sourceforge.net>. This data is stored in your server-side buddylist and so will be persistent, even across machines. If C<GROUP> is present, a hashref for accessing data specific to that group is returned. If C<BUDDY> is present, a hashref for accessing data specific to that buddy is returned. Call L<"commit_buddylist"> to have the new data saved on the OSCAR server. =cut sub get_app_data($;$$) { my($self, $group, $buddy) = @_; return $self->{appdata} unless $group; return $self->{buddies}->{$group}->{data} unless $buddy; return $self->{buddies}->{$group}->{members}->{$buddy}->{data}; } sub mod_permit($$$@) { my($self, $action, $group, @buddies) = @_; return must_be_on($self) unless $self->{is_on}; if($action == MODBL_ACTION_ADD) { foreach my $buddy(@buddies) { next if exists($self->{$group}->{$buddy}); $self->{$group}->{$buddy}->{buddyid} = $self->newid($self->{group}); } } else { foreach my $buddy(@buddies) { delete $self->{$group}->{$buddy}; } } } sub mod_buddylist($$$$;@) { my($self, $action, $what, $group, @buddies) = @_; return must_be_on($self) unless $self->{is_on}; @buddies = ($group) if $what == MODBL_WHAT_GROUP; if($what == MODBL_WHAT_GROUP and $action == MODBL_ACTION_ADD) { return if exists $self->{buddies}->{$group}; $self->{buddies}->{$group} = { groupid => $self->newid(), members => bltie, data => tlvtie }; } elsif($what == MODBL_WHAT_GROUP and $action == MODBL_ACTION_DEL) { return unless exists $self->{buddies}->{$group}; delete $self->{buddies}->{$group}; } elsif($what == MODBL_WHAT_BUDDY and $action == MODBL_ACTION_ADD) { $self->mod_buddylist(MODBL_ACTION_ADD, MODBL_WHAT_GROUP, $group) unless exists $self->{buddies}->{$group}; @buddies = grep {not exists $self->{buddies}->{$group}->{members}->{$_}} @buddies; return unless @buddies; foreach my $buddy(@buddies) { $self->{buddies}->{$group}->{members}->{$buddy} = { buddyid => $self->newid($self->{buddies}->{$group}->{members}), data => tlvtie, online => 0, comment => undef }; } } elsif($what == MODBL_WHAT_BUDDY and $action == MODBL_ACTION_DEL) { return unless exists $self->{buddies}->{$group}; @buddies = grep {exists $self->{buddies}->{$group}->{members}->{$_}} @buddies; return unless @buddies; foreach my $buddy(@buddies) { delete $self->{buddies}->{$group}->{members}->{$buddy}; } $self->mod_buddylist(MODBL_ACTION_DEL, MODBL_WHAT_GROUP, $group) unless scalar keys %{$self->{buddies}->{$group}->{members}}; } } sub extract_userinfo($$) { my($self, $data) = @_; my $retval = {}; my $tlvcnt; ($retval->{screenname}, $retval->{evil}, $tlvcnt) = unpack("C/a* n n", $data); $retval->{screenname} = new Net::OSCAR::Screenname $retval->{screenname}; $retval->{evil} /= 10; substr($data, 0, 5+length($retval->{screenname})) = ""; $self->log_print(OSCAR_DBG_DEBUG, "Decoding userinfo TLV with tlvcnt $tlvcnt."); my($tlv, $chainlen) = tlv_decode($data, $tlvcnt); #$chainlen--; $self->log_print(OSCAR_DBG_DEBUG, "Done decoding userinfo TLV - chainlen $chainlen."); my($flags) = unpack("n", $tlv->{1}); $retval->{trial} = $flags & 0x1; $retval->{admin} = $flags & 0x2; $retval->{aol} = $flags & 0x4; $retval->{pay} = $flags & 0x8; $retval->{free} = $flags & 0x10; $retval->{away} = $flags & 0x20; $retval->{mobile} = $flags & 0x80; ($retval->{membersince}) = unpack("N", $tlv->{2}) if exists($tlv->{2}); ($retval->{onsince}) = unpack("N", $tlv->{3}) if exists($tlv->{3}); ($retval->{idle}) = unpack("n", $tlv->{4}) if exists($tlv->{4}); ($retval->{capabilities}) = $tlv->{0xD} if exists($tlv->{0xD}); substr($data, 0, $chainlen) = ""; if($data) { $tlv = tlv_decode($data); $retval->{profile} = $tlv->{0x2} if $tlv->{0x2}; $retval->{awaymsg} = $tlv->{0x4} if $tlv->{0x4}; $retval->{chatdata} = $tlv->{0x5} if $tlv->{0x5}; } $chainlen += 5+length($retval->{screenname}); return wantarray ? ($retval, $chainlen) : $retval; } =pod =item get_info (WHO) Requests a user's information, which includes their profile and idle time. See the L<buddy_info> callback for more information. =item get_away (WHO) Similar to L<get_info>, except requests the user's away message instead of their profile. =cut sub get_info($$) { my($self, $screenname) = @_; return must_be_on($self) unless $self->{is_on}; $self->{bos}->snac_put(reqdata => $screenname, family => 0x2, subtype => 0x5, data => pack("nCa*", 1, length($screenname), $screenname)); } sub get_away($$) { my($self, $screenname) = @_; return must_be_on($self) unless $self->{is_on}; $self->{bos}->snac_put(reqdata => $screenname, family => 0x2, subtype => 0x5, data => pack("nCa*", 3, length($screenname), $screenname)); } =pod =item send_im (WHO, MESSAGE[, AWAY]) Sends someone an instant message. If the message is an automated reply generated, perhaps, because you have an away message set, give the AWAY parameter a non-zero value. Note that C<Net::OSCAR> will not handle sending away messages to people who contact you when you are away - you must perform this yourself if you want it done. Returns a "request ID" that you can use in the C<im_ok> callback to identify the message. If the message was too long to send, returns zero. =cut sub send_im($$$;$) { my($self, $to, $msg, $away) = @_; return must_be_on($self) unless $self->{is_on}; my $packet = ""; my $reqid = (8<<16) | (unpack("n", randchars(2)))[0]; if(!$self->{svcdata}->{hashlogin}) { return 0 if length($msg) >= 7987; } else { return 0 if length($msg) > 2000; } $packet = randchars(8); $packet .= pack("n", 1); # channel $packet .= pack("Ca*", length($to), $to); $packet .= tlv(2 => pack("n3 C n C n3 a*", 0x501, 4, 0x101, 1, 0x201, 1, length($msg)+4, 0, 0, $msg)); if($away) { $packet .= tlv(4 => ""); } else { $packet .= tlv(3 => ""); #request server confirmation } $self->{bos}->snac_put(reqid => $reqid, reqdata => $to, family => 0x4, subtype => 0x6, data => $packet, flags2 => 0xb); return $reqid; } =pod =item set_typing (WHO, STATUS) Tells user WHO that your typing status has changed. STATUS can be any of the following values: MTN_TYPING_DONE, MTN_TEXT_TYPED MTN_TYPING_BEGUN. =cut sub set_typing($$$) { my($self, $who, $status) = @_; return must_be_on($self) unless $self->{is_on}; my $packet = ""; $packet .= pack("n*", 0, 0, 0, 0); $packet .= pack("n", 0x01); $packet .= pack("Ca*", length($who), $who); $packet .= pack("n", $status); $self->{bos}->snac_put(family => 0x4, subtype => 0x14, data => $packet); } =pod =item buddyhash Returns a reference to a tied hash which automatically normalizes its keys upon a fetch. Use this for hashes whose keys are AIM screennames since AIM screennames with different capitalization and spacing are considered equivalent. The keys of the hash as returned by the C<keys> and C<each> functions will be C<Net::OSCAR::Screenname> objects, so you they will automagically be compared without regards to case and whitespace. =cut sub buddyhash($) { bltie; } sub im_parse($$) { my($self, $data) = @_; my($from, $msg, $away) = ("", "", 0); my $chat = undef; my $chaturl = undef; my $cookie = substr($data, 0, 8, ""); #OSCAR is so nice, it feeds us BLTs and cookies as SNACs. my($channel) = unpack("n", substr($data, 0, 2, "")); if($channel != 1 and $channel != 2) { carp "Got ICBM on unsupported channel $channel - ignoring."; return; } else { $self->log_print(OSCAR_DBG_DEBUG, "Incoming ICBM on channel $channel."); } $self->log_print(OSCAR_DBG_DEBUG, "Extracting user info."); my ($senderinfo, $tlvlen) = $self->extract_userinfo($data); $from = $senderinfo->{screenname}; # Copying gAIM/libfaim is *so* much easier than understanding stuff. if($channel == 1) { substr($data, 0, $tlvlen) = ""; $self->log_print(OSCAR_DBG_DEBUG, "Decoding ICBM secondary TLV."); my $tlv = tlv_decode($data); $msg = $tlv->{2}; substr($msg, 0, 2) = ""; my($y) = unpack("n", substr($msg, 0, 2, "")); substr($msg, 0, $y+2) = ""; my($msglen, $flags1, $flags2) = unpack("nnn", substr($msg, 0, 6, "")); $msglen -= 4; $away = 1 if exists $tlv->{4}; if($tlv->{3}) { # server ack requested #$self->log_print(OSCAR_DBG_DEBUG, "Sending message ack."); #$self->{bos}->snac_put(family => 0x4, subtype => 0xC, data => # $cookie . pack("nCa*", 1, length($from), $from) #); } } else { $data = $senderinfo->{chatdata}; $away = 0; substr($data, 0, 26) = ""; my $tlv = tlv_decode($data); $msg = $tlv->{0xC}; if($tlv->{0x2711}) { ($chaturl) = unpack("xx C/a*", $tlv->{0x2711}); $chaturl =~ /-.*?-(.*)/; $chat = $1; $chat =~ s/%([0-9A-Z]{1,2})/chr(hex($1))/eig; } $self->{chatinvites}->{$chaturl} = { cookie => $cookie, sender => $from }; } return ($from, $msg, $away, $chat, $chaturl); } =pod =item evil (WHO[, ANONYMOUSLY]) C<Evils>, or C<warns>, a user. Evilling a user increases their evil level, which makes them look bad and decreases the rate at which they can send messages. Evil level gradually decreases over time. If the second parameter is non-zero, the evil will be done anonymously, which does not increase the user's evil level by as much as a standard evil. You can't always evil someone. You can only do it when they do something like send you an instant message. =cut sub evil($$;$) { my($self, $who, $anon) = @_; return must_be_on($self) unless $self->{is_on}; $self->{bos}->snac_put(reqdata => $who, family => 0x04, subtype => 0x08, data => pack("n C a*", ($anon ? 1 : 0), length($who), $who) ); } sub capabilities($) { my $self = shift; my $caps; #AIM_CAPS_CHAT $caps .= pack("C*", map{hex($_)} split(/[ \t\n]+/, "74 8F 24 20 62 87 11 D1 82 22 44 45 53 54 00 00")); return $caps; } =pod =item set_away (MESSAGE) Set's the users away message, also marking them as being away. If the message is undef or the empty string, the user will be marked as no longer being away. =cut sub set_away($$) { my($self, $awaymsg) = @_; return must_be_on($self) unless $self->{is_on}; shift->set_info(undef, $awaymsg); } =pod =item set_info (PROFILE) Sets the user's profile. Call L<"commit_buddylist"> to have the new profile stored on the OSCAR server. =cut sub set_info($$;$) { my($self, $profile, $awaymsg) = @_; my %tlv; tie %tlv, "Net::OSCAR::TLV"; if(defined($profile)) { $tlv{0x1} = ENCODING; $tlv{0x2} = $profile; $self->{profile} = $profile; } if(defined($awaymsg)) { $tlv{0x3} = ENCODING; $tlv{0x4} = $awaymsg; } $tlv{0x5} = $self->capabilities(); $self->log_print(OSCAR_DBG_NOTICE, "Setting user information."); $self->{bos}->snac_put(family => 0x02, subtype => 0x04, data => tlv_encode(\%tlv)); } sub svcdo($$%) { my($self, $service, %snac) = @_; my $svcname = ""; if($service == CONNTYPE_ADMIN) { $svcname = "admin"; } elsif($service == CONNTYPE_CHATNAV) { $svcname = "chatnav"; } if($self->{$svcname} and ref($self->{$svcname})) { $self->{$svcname}->snac_put(%snac); } else { push @{$self->{"${svcname}_queue"}}, \%snac; $self->svcreq($service) unless $self->{$svcname}; } } sub svcreq($$) { my($self, $svctype) = @_; $self->log_print(OSCAR_DBG_INFO, "Sending service request for servicetype $svctype."); $self->{bos}->snac_put(family => 0x1, subtype => 0x4, data => pack("n", $svctype)); } =pod =item change_password (CURRENT PASSWORD, NEW PASSWORD) Changes the user's password. =cut sub change_password($$$) { my($self, $currpass, $newpass) = @_; return must_be_on($self) unless $self->{is_on}; if($self->{adminreq}->{ADMIN_TYPE_PASSWORD_CHANGE}++) { $self->callback_admin_error(ADMIN_TYPE_PASSWORD_CHANGE, ADMIN_ERROR_REQPENDING); return; } my %tlv; tie %tlv, "Net::OSCAR::TLV"; %tlv = ( 0x02 => $newpass, 0x12 => $currpass ); $self->svcdo(CONNTYPE_ADMIN, family => 0x07, subtype => 0x04, data => tlv_encode(\%tlv)); } =pod =item confirm_account Confirms the user's account. This can be used when the user's account is in the trial state, as determined by the presence of the C<trial> key in the information given when the user's information is requested. =cut sub confirm_account($) { my($self) = shift; return must_be_on($self) unless $self->{is_on}; if($self->{adminreq}->{ADMIN_TYPE_ACCOUNT_CONFIRM}++) { $self->callback_admin_error(ADMIN_TYPE_ACCOUNT_CONFIRM, ADMIN_ERROR_REQPENDING); return; } $self->svcdo(CONNTYPE_ADMIN, family => 0x07, subtype => 0x06); } =pod =item change_email (NEW EMAIL) Requests that the email address registered to the user's account be changed. This causes the OSCAR server to send an email to both the new address and the old address. To complete the change, the user must follow instructions contained in the email sent to the new address. The email sent to the old address contains instructions which allow the user to cancel the change within three days of the change request. It is important that the user's current email address be known to the OSCAR server so that it may email the account password if the user forgets it. =cut sub change_email($$) { my($self, $newmail) = @_; return must_be_on($self) unless $self->{is_on}; if($self->{adminreq}->{ADMIN_TYPE_EMAIL_CHANGE}++) { $self->callback_admin_error(ADMIN_TYPE_EMAIL_CHANGE, ADMIN_ERROR_REQPENDING); return; } $self->svcdo(CONNTYPE_ADMIN, family => 0x07, subtype => 0x04, data => tlv(0x11 => $newmail)); } =pod =item format_screenname (NEW FORMAT) Allows the capitalization and spacing of the user's screenname to be changed. The new format must be the same as the user's current screenname, except that case may be changed and spaces may be inserted or deleted. =cut sub format_screenname($$) { my($self, $newname) = @_; return must_be_on($self) unless $self->{is_on}; if($self->{adminreq}->{ADMIN_TYPE_SCREENNAME_FORMAT}++) { $self->callback_admin_error(ADMIN_TYPE_SCREENNAME_FORMAT, ADMIN_ERROR_REQPENDING); return; } $self->svcdo(CONNTYPE_ADMIN, family => 0x07, subtype => 0x04, data => tlv(1 => $newname)); } =pod =item chat_join (NAME[, EXCHANGE]) Creates (or joins?) a chatroom. The exchange parameter should probably not be specified unless you know what you're doing. Do not use this method to accept invitations to join a chatroom - use the L<"chat_accept"> method for that. =cut sub chat_join($$; $) { my($self, $name, $exchange) = @_; return must_be_on($self) unless $self->{is_on}; $exchange ||= 4; $self->log_print(OSCAR_DBG_INFO, "Creating chatroom $name ($exchange)."); my $reqid = (8<<16) | (unpack("n", randchars(2)))[0]; $self->{chats}->{pack("N", $reqid)} = $name; $self->svcdo(CONNTYPE_CHATNAV, family => 0x0D, subtype => 0x08, reqid => $reqid, data => #pack("n Ca*n3C na*", $exchange, # length("create"), "create", 0xFFFF, 0x100, 0x100, 0xD3, # length($name), $name #) pack("n Ca*n2C a*", $exchange, length("create"), "create", 0xFFFF, 0x100, 0x03, tlv( 0xD7 => "en", 0xD6 => "us-ascii", 0xD3 => $name ) ) ); } =pod =item chat_accept (CHAT) Use this to accept an invitation to join a chatroom. =item chat_decline (CHAT) Use this to decline an invitation to join a chatroom. =cut sub chat_accept($$) { my($self, $chat) = @_; return must_be_on($self) unless $self->{is_on}; delete $self->{chatinvites}->{$chat}; $self->log_print(OSCAR_DBG_NOTICE, "Accepting chat invite for $chat."); $self->svcdo(CONNTYPE_CHATNAV, family => 0x0D, subtype => 0x04, data => pack("nca* Cn", 4, length($chat), $chat, 0, 2) ); } sub chat_decline($$) { my($self, $chat) = @_; return must_be_on($self) unless $self->{is_on}; my($invite) = delete $self->{chatinvites}->{$chat} or do { $self->log_print(OSCAR_DBG_WARN, "Chat invite for $chat doesn't exist, so we can't decline it."); return; }; $self->log_print(OSCAR_DBG_NOTICE, "Declining chat invite for $chat."); $self->{bos}->snac_put(family => 0x04, subtype => 0x0B, data => $invite->{cookie} . pack("n", 2) . pack("Ca*", length($invite->{sender}), $invite->{sender}) . pack("nnn", 3, 2, 1) ); } sub crapout($$$;$) { my($self, $connection, $reason, $errno) = @_; send_error($self, $connection, $errno || 0, $reason, 1); $self->signoff(); } sub must_be_on($) { my $self = shift; send_error($self, $self->{bos}, 0, "You have not finished signing on.", 0); } =pod =item set_idle (TIME) Sets the user's idle time in seconds. Set to zero to mark the user as not being idle. Set to non-zero once the user becomes idle. The OSCAR server will automatically increment the user's idle time once you mark the user as being idle. =cut sub set_idle($$) { my($self, $time) = @_; return must_be_on($self) unless $self->{is_on}; $self->{bos}->snac_put(family => 0x1, subtype => 0x11, data => pack("N", $time)); } =pod =item clone Clones the object. This creates a new C<Net::OSCAR> object whose callbacks, loglevel, screenname debugging, and timeout are the same as those of the current object. This is provided as a convenience when using multiple C<Net::OSCAR> objects in order to allow you to set those parameters once and then call the L<signon> method on the object returned by clone. =cut sub clone($) { my $self = shift; my $clone = $self->new(); # Born in a science lab late one night # Without a mother or a father # Just a test tube and womb with a view... # Okay, now we don't want to just copy the reference. # If we did that, changing ourself would change the clone. $clone->{callbacks} = { %{$self->{callbacks}} }; $clone->{LOGLEVEL} = $self->{LOGLEVEL}; $clone->{SNDEBUG} = $self->{SNDEBUG}; $clone->{timeout} = $self->{timeout}; return $clone; } =pod =item selector_filenos Returns a list whose first element is a vec of all filehandles that we care about reading from and whose second element is a vec of all filehandles that we care about writing to. See the L<"process_connections"> method for details. =cut sub selector_filenos($) { my($rin, $win) = ('', ''); foreach my $connection(@{shift->{connections}}) { next unless $connection->{socket}; if($connection->{connected}) { vec($rin, fileno $connection->{socket}, 1) = 1; } if(!$connection->{connected} or $connection->{outbuff}) { vec($win, fileno $connection->{socket}, 1) = 1; } } return ($rin, $win); } =pod =item visibility Returns the user's current visibility setting. See L<set_visibility>. =item groups Returns a list of groups in the user's buddylist. =item buddies (GROUP) Returns the names of the buddies in the specified group in the user's buddylist. The names may not be formatted - that is, they may have spaces and capitalization removed. The names are C<Net::OSCAR::Screenname> objects, so you don't have to worry that they're case and whitespace insensitive when using them for comparison. =item buddy (BUDDY[, GROUP]) Returns information about a buddy on the user's buddylist. This information is a hashref which may have the following keys: =over 4 =item online The user is signed on. If this key is not present, all of the other keys may not be present. =item screenname The formatted version of the user's screenname. This includes all spacing and capitalization. This is a C<Net::OSCAR::Screenname> object, so you don't have to worry about the fact that it's case and whitespace insensitive when comparing it. =item comment A user-defined comment associated with the buddy. See L<"set_buddy_comment">. Note that this key will be present but undefined if there is no comment. =item trial The user's account has trial status. =item aol The user is accessing the AOL Instant Messenger service from America OnLine. =item free Opposite of aol. =item away The user is away. =item admin The user is an administrator. =item membersince Time that the user's account was created, in the same format as the C<time> function. =item onsince Time that the user signed on to the service, in the same format as the C<time> function. =item idle Time that the user has been idle for, in seconds. If this key is present but zero, the user is not idle. If this key is not present, the user is not reporting idle time. =back =item email Returns the email address currently assigned to the user's account. =item screenname Returns the user's current screenname, including all capitalization and spacing. =item is_on Returns true if the user is signed on to the OSCAR service. Otherwise, returns false. =cut sub visibility($) { return shift->{visibility}; } sub groups($) { return keys %{shift->{buddies}}; } sub buddies($;$) { my($self, $group) = @_; return keys %{$self->{buddies}->{$group}->{members}} if $group; return map { keys %{$_->{members}} } values %{$self->{buddies}}; } sub buddy($$;$) { my($self, $buddy, $group) = @_; $group ||= $self->findbuddy($buddy); return undef unless $group; return $self->{buddies}->{$group}->{members}->{$buddy}; } sub email($) { return shift->{email}; } sub screenname($) { return shift->{screenname}; } sub is_on($) { return shift->{is_on}; } =pod =item set_buddy_comment (GROUP, BUDDY[, COMMENT]) Set a brief comment about a buddy. This can be used for things such as the buddy's real name. You must call L<"commit_buddylist"> to save the comment to the server. If COMMENT is undefined, the comment is deleted. =cut sub set_buddy_comment($$$;$) { my($self, $group, $buddy, $comment) = @_; return must_be_on($self) unless $self->{is_on}; $self->{buddies}->{$group}->{members}->{$buddy}->{comment} = $comment; } =pod =item chat_invite (CHAT, MESSAGE, WHO) Deprecated. Provided for compatibility with C<Net::AIM>. Use the appropriate method of the C<Net::OSCAR::Chat> object instead. =cut sub chat_invite($$$@) { my($self, $chat, $msg, @who) = @_; return must_be_on($self) unless $self->{is_on}; foreach my $who(@who) { $chat->{connection}->invite($who, $msg); } } =pod =item chat_leave (CHAT) Deprecated. Provided for compatibility with C<Net::AIM>. Use the appropriate method of the C<Net::OSCAR::Chat> object instead. =item chat_send (CHAT, MESSAGE) Deprecated. Provided for compatibility with C<Net::AIM>. Use the appropriate method of the C<Net::OSCAR::Chat> object instead. =cut sub chat_leave($$) { $_[1]->part(); } sub chat_send($$$) { $_[1]->chat_send($_[2]); } =pod =back =head1 CALLBACKS C<Net::OSCAR> uses a callback mechanism to notify you about different events. A callback is registered by calling the C<set_callback_callbackname> method with a code reference as a parameter. For instance, you might call C<$oscar-E<gt>set_callback_error(\&got_error);>. Your callback function will be passed parameters which are different for each callback type (and are documented below). The first parameter to each callback function will be the C<Net::OSCAR> object which generated the callback. This is useful when using multiple C<Net::OSCAR> objects. =over 4 =item error (OSCAR, CONNECTION, ERROR, DESCRIPTION, FATAL) Called when any sort of error occurs (except see L<admin_error> below.) C<CONNECTION> is the particular connection which generated the error - the C<log_print> method of C<Net::OSCAR::Connection> may be useful, as may be getting C<$connection-E<gt>{description}>. C<DESCRIPTION> is a nicely formatted description of the error. C<ERROR> is an error number. If C<FATAL> is non-zero, the error was fatal and the connection to OSCAR has been closed. =item rate_alert (OSCAR, LEVEL, CLEAR, WINDOW, WORRISOME) This is called when you are sending commands to OSCAR too quickly. LEVEL is one of RATE_CLEAR, RATE_ALERT, RATE_LIMIT, or RATE_DISCONNECT from the C<Net::OSCAR::Common> package (they are imported into your namespace if you import C<Net::OSCAR> with the C<:standard> parameter.) RATE_CLEAR means that you're okay. RATE_ALERT means you should slow down. RATE_LIMIT means that the server is ignoring messages from you until you slow down. RATE_DISCONNECT means you're about to be disconnected. CLEAR and WINDOW tell you the maximum speed you can send in order to maintain RATE_CLEAR standing. You must send no more than WINDOW commands in CLEAR milliseconds. If you just want to keep it simple, you can just not send any commands for CLEAR milliseconds and you'll be fine. WORRISOME is nonzero if C<Net::OSCAR> thinks that the alert is anything worth worrying about. Otherwise it is zero. This is very rough, but it's a good way for the lazy to determine whether or not to bother passing the alert on to their users. =item buddylist_error (OSCAR, ERROR, WHAT) This is called when there is an error commiting changes to the buddylist. C<ERROR> is the error number. C<WHAT> is a string describing which buddylist change failed. C<Net::OSCAR> will revert the failed change to its state before C<commit_buddylist> was called. Note that the buddylist contains information other than the user's buddies - see any method which says you need to call C<commit_buddylist> to have its changes take effect. =item buddylist_ok (OSCAR) This is called when your changes to the buddylist have been successfully commited. =item admin_error (OSCAR, REQTYPE, ERROR, ERRURL) This is called when there is an error performing an administrative function - changing your password, formatting your screenname, changing your email address, or confirming your account. REQTYPE is a string describing the type of request which generated the error. ERROR is an error message. ERRURL is an http URL which the user may visit for more information about the error. =item admin_ok (OSCAR, REQTYPE) This is called when an administrative function succeeds. See L<admin_error> for more info. =item chat_closed (OSCAR, CHAT, ERROR) Your connection to CHAT (a C<Net::OSCAR::Chat> object) was severed due to ERROR. =item buddy_in (OSCAR, SCREENNAME, GROUP, BUDDY DATA) SCREENNAME (in buddy group GROUP) has signed on, or their information has changed. BUDDY DATA is the same as that returned by the L<buddy> method. =item chat_buddy_in (OSCAR, SCREENNAME, CHAT, BUDDY DATA) SCREENNAME has entered CHAT. BUDDY DATA is the same as that returned by the L<buddy> method. =item buddy_out (OSCAR, SCREENNAME, GROUP) Called when a buddy has signed off (or added us to their deny list.) =item chat_buddy_out (OSCAR, SCREENNAME, CHAT) Called when someone leaves a chatroom. =item im_ok (OSCAR, TO, REQID) Called when an IM to C<TO> is successfully sent. REQID is the request ID of the IM as returned by C<send_im>. =item im_in (OSCAR, FROM, MESSAGE[, AWAY]) Called when someone sends you an instant message. If the AWAY parameter is non-zero, the message was generated as an automatic reply, perhaps because you sent that person a message and they had an away message set. =item chat_im_in (OSCAR, FROM, CHAT, MESSAGE) Called when someone says something in a chatroom. Note that you receive your own messages in chatrooms unless you specify the NOREFLECT parameter in L<chat_send>. =item chat_invite (OSCAR, WHO, MESSAGE, CHAT, CHATURL) Called when someone invites us into a chatroom. MESSAGE is the message that they specified on the invitation. CHAT is the name of the chatroom. CHATURL is a chat URL and not a C<Net::OSCAR::Chat> object. CHATURL can be passed to the L<chat_accept> method to accept the invitation. =item chat_joined (OSCAR, CHATNAME, CHAT) Called when you enter a chatroom. CHAT is the C<Net::OSCAR::Chat> object for the chatroom. =item evil (OSCAR, NEWEVIL[, FROM]) Called when your evil level changes. NEWEVIL is your new evil level, as a percentage (accurate to tenths of a percent.) ENEMY is undef if the evil was anonymous (or if the message was triggered because your evil level naturally decreased), otherwise it is the screenname of the person who sent us the evil. See the L<"evil"> method for more information on evils. =item buddy_info (OSCAR, SCREENNAME, BUDDY DATA) Called in response to a L<get_info> or L<get_away> request. BUDDY DATA is the same as that returned by the L<buddy> method, except that one of two additional keys, C<profile> and C<awaymsg>, may be present. =item signon_done (OSCAR) Called when the user is completely signed on to the service. =item auth_challenge (OSCAR, CHALLENGE, HASHSTR) OSCAR uses an MD5-based challenge/response system for authentication so that the password is never sent in plaintext over the network. When a user wishes to sign on, the OSCAR server sends an arbitrary number as a challenge. The client must respond with the MD5 digest of the concatenation of, in this order, the challenge, the password, and an additional hashing string (currently always the string "AOL Instant Messenger (SM)", but it is possible that this might change in the future.) If password is undefined in L<"signon">, this callback will be triggered when the server sends a challenge during the signon process. The client must reply with the MD5 digest of CHALLENGE . password . HASHSTR. For instance, using the L<MD5::Digest> module: my($oscar, $challenge, $hashstr) = @_; my $md5 = Digest::MD5->new; $md5->add($challenge); $md5->add("password"); $md5->add($hashstr); $oscar->auth_response($md5->digest); Note that this functionality is only available for certain services. It is available for AIM but not ICQ. Note also that the MD5 digest must be in binary form, not the more common hex or base64 forms. =item log (OSCAR, LEVEL, MESSAGE) Use this callback if you don't want the log_print methods to just print to STDERR. It is called when even C<MESSAGE> of level C<LEVEL> is called. The levels are, in order of increasing importance: =item typing_status (OSCAR, WHO, LEVEL) Sent when C<WHO>'s typing status changes to C<LEVEL>. C<LEVEL> will be one of the following: MTN_TYPING_DONE, MTN_TEXT_TYPED, MTN_TYPING_BEGUN depending on the status of the other user. =over 4 =item OSCAR_DBG_NONE Really only useful for setting in the L<"loglevel"> method. No information will be logged. The default loglevel. =item OSCAR_DBG_PACKETS Hex dumps of all incoming/outgoing packets. =item OSCAR_DBG_DEBUG Information useful for debugging C<Net::OSCAR>, and precious little else. =item OSCAR_DBG_SIGNON Like C<OSCAR_DBG_NOTICE>, but only for the signon process; this is where problems are most likely to occur, so we provide this for the common case of people who only want a lot of information during signon. This may be deprecated some-day and be replaced by a more flexible facility/level system, ala syslog. =item OSCAR_DBG_NOTICE =item OSCAR_DBG_INFO =item OSCAR_DBG_WARN =back Note that these symbols are imported into your namespace if and only if you use the C<:loglevels> or C<:all> tags when importing the module (e.g. C<use Net::OSCAR qw(:standard :loglevels)>.) Also note that this callback is only triggered for events whose level is greater than or equal to the loglevel for the OSCAR session. The L<"loglevel"> method allows you to get or set the loglevel. =item connection_changed (OSCAR, CONNECTION, STATUS) Called when the status of a connection changes. The status is "read" if we should call L<"process_one"> on the connection when C<select> indicates that the connection is ready for reading, "write" if we should call L<"process_one"> when the connection is ready for writing, "readwrite" if L<"process_one"> should be called in both cases, or "deleted" if the connection has been deleted. C<CONNECTION> is a C<Net::OSCAR::Connection> object. Users of this callback may also be interested in the L<"get_filehandle"> method of C<Net::OSCAR::Connection>. =cut sub do_callback($@) { my $callback = shift; return unless $_[0]->{callbacks}->{$callback}; &{$_[0]->{callbacks}->{$callback}}(@_); } sub set_callback { $_[1]->{callbacks}->{$_[0]} = $_[2]; } sub callback_error(@) { do_callback("error", @_); } sub callback_buddy_in(@) { do_callback("buddy_in", @_); } sub callback_buddy_out(@) { do_callback("buddy_out", @_); } sub callback_typing_status(@) { do_callback("typing_status", @_); } sub callback_im_in(@) { do_callback("im_in", @_); } sub callback_typing_changed(@) { do_callback("typing_changed", @_); } sub callback_chat_joined(@) { do_callback("chat_joined", @_); } sub callback_chat_buddy_in(@) { do_callback("chat_buddy_in", @_); } sub callback_chat_buddy_out(@) { do_callback("chat_buddy_out", @_); } sub callback_chat_im_in(@) { do_callback("chat_im_in", @_); } sub callback_chat_invite(@) { do_callback("chat_invite", @_); } sub callback_buddy_info(@) { do_callback("buddy_info", @_); } sub callback_evil(@) { do_callback("evil", @_); } sub callback_chat_closed(@) { do_callback("chat_closed", @_); } sub callback_buddylist_error(@) { do_callback("buddylist_error", @_); } sub callback_buddylist_ok(@) { do_callback("buddylist_ok", @_); } sub callback_admin_error(@) { do_callback("admin_error", @_); } sub callback_admin_ok(@) { do_callback("admin_ok", @_); } sub callback_rate_alert(@) { do_callback("rate_alert", @_); } sub callback_signon_done(@) { do_callback("signon_done", @_); } sub callback_log(@) { do_callback("log", @_); } sub callback_im_ok(@) { do_callback("im_ok", @_); } sub callback_connection_changed(@) { do_callback("connection_changed", @_); } sub callback_auth_challenge(@) { do_callback("auth_challenge", @_); } sub set_callback_error($\&) { set_callback("error", @_); } sub set_callback_buddy_in($\&) { set_callback("buddy_in", @_); } sub set_callback_buddy_out($\&) { set_callback("buddy_out", @_); } sub set_callback_typing_status($\&) { set_callback("typing_status", @_); } sub set_callback_im_in($\&) { set_callback("im_in", @_); } sub set_callback_chat_joined($\&) { set_callback("chat_joined", @_); } sub set_callback_chat_buddy_in($\&) { set_callback("chat_buddy_in", @_); } sub set_callback_chat_buddy_out($\&) { set_callback("chat_buddy_out", @_); } sub set_callback_chat_im_in($\&) { set_callback("chat_im_in", @_); } sub set_callback_chat_invite($\&) { set_callback("chat_invite", @_); } sub set_callback_buddy_info($\&) { set_callback("buddy_info", @_); } sub set_callback_evil($\&) { set_callback("evil", @_); } sub set_callback_chat_closed($\&) { set_callback("chat_closed", @_); } sub set_callback_buddylist_error($\&) { set_callback("buddylist_error", @_); } sub set_callback_buddylist_ok($\&) { set_callback("buddylist_ok", @_); } sub set_callback_admin_error($\&) { set_callback("admin_error", @_); } sub set_callback_admin_ok($\&) { set_callback("admin_ok", @_); } sub set_callback_rate_alert($\&) { set_callback("rate_alert", @_); } sub set_callback_signon_done($\&) { set_callback("signon_done", @_); } sub set_callback_log($\&) { set_callback("log", @_); } sub set_callback_im_ok($\&) { set_callback("im_ok", @_); } sub set_callback_connection_changed($\&) { set_callback("connection_changed", @_); } sub set_callback_auth_challenge($\&) { set_callback("auth_challenge", @_); } =pod =back =head1 CHATS Aside from the methods listed here, there are a couple of methods of the C<Net::OSCAR::Chat> object that are important for implementing chat functionality. C<Net::OSCAR::Chat> is a descendent of C<Net::OSCAR::Connection>. =over 4 =item invite (WHO, MESSAGE) Invite somebody into the chatroom. =item chat_send (MESSAGE[, NOREFLECT[, AWAY]]) Sends a message to the chatroom. If the NOREFLECT parameter is present, you will not receive the message as an incoming message from the chatroom. If AWAY is present, the message was generated as an automatic reply, perhaps because you have an away message set. =item part Leave the chatroom. =item url Returns the URL for the chatroom. Use this to associate a chat invitation with the chat_joined that C<Net::OSCAR> sends when you've join the chatroom. =item name Returns the name of the chatroom. =item exchange Returns the exchange of the chatroom. This is normally 4 but can be 5 for certain chatrooms. =back =head1 ICQ ICQ support is very preliminary. A patch enabling us to sign on to ICQ was provided by Sam Wong. No further work beyond the ability to sign on has been done on ICQ at this time. See the C<signon> method for details on signing on via ICQ. =head1 CONSTANTS The following constants are defined when C<Net::OSCAR> is imported with the C<:standard> tag. Unless indicated otherwise, the constants are magical scalars - they return different values in string and numeric contexts (for instance, an error message and an error number.) =over 4 =item ADMIN_TYPE_PASSWORD_CHANGE =item ADMIN_TYPE_EMAIL_CHANGE =item ADMIN_TYPE_SCREENNAME_FORMAT =item ADMIN_TYPE_ACCOUNT_CONFIRM =item ADMIN_ERROR_UNKNOWN =item ADMIN_ERROR_BADPASS =item ADMIN_ERROR_BADINPUT =item ADMIN_ERROR_BADLENGTH =item ADMIN_ERROR_TRYLATER =item ADMIN_ERROR_REQPENDING =item ADMIN_ERROR_CONNREF =item VISMODE_PERMITALL =item VISMODE_DENYALL =item VISMODE_PERMITSOME =item VISMODE_DENYSOME =item VISMODE_PERMITBUDS =item RATE_CLEAR =item RATE_ALERT =item RATE_LIMIT =item RATE_DISCONNECT =item GROUPPERM_OSCAR =item GROUPPERM_AOL =back =head1 Net::AIM Compatibility Here are the major differences between the C<Net::OSCAR> interface and the C<Net::AIM> interface: =over 4 =item * No get/set method. =item * No newconn/getconn method. =item * No group parameter for add_permit or add_deny. =item * Many differences in chat handling. =item * No chat_whisper. =item * No encode method - it isn't needed. =item * No send_config method - it isn't needed. =item * No send_buddies method - we don't keep a separate local buddylist. =item * No normalize method - it isn't needed. Okay, there is a normalize function in C<Net::OSCAR::Common>, but I can't think of any reason why it would need to be used outside of the module internals. =item * Different callbacks with different parameters. =back =head1 MISCELLANEOUS There are two programs included with the C<Net::OSCAR> distribution. oscartest is a minimalist implementation of a C<Net::OSCAR> client. snacsnatcher is a tool designed for analyzing the OSCAR protocol from libpcap-format packet captures. There is a class C<Net::OSCAR::Screenname>. OSCAR screennames are case and whitespace insensitive, and if you do something like C<$buddy = new Net::OSCAR::Screenname "Matt Sachs"> instead of C<$buddy = "Matt Sachs">, this will be taken care of for you when you use the string comparison operators (eq, ne, cmp, etc.) C<Net::OSCAR::Connection>, the class used for connection objects, has some methods that may or may not be useful to you. =over 4 =item get_filehandle Returns the filehandle used for the connection. Note that this is a method of C<Net::OSCAR::Connection>, not C<Net::OSCAR>. =item process_one (CAN_READ, CAN_WRITE, HAS_ERROR) Call this when a C<Net::OSCAR::Connection> is ready for reading and/or writing. You might call this yourself instead of using L<"process_connections"> when, for instance, using the L<"connection_changed"> callback in conjunction with C<IO::Poll> instead of C<select>. The C<CAN_READ> and C<CAN_WRITE> parameters should be non-zero if the connection is ready for the respective operations to be performed and zero otherwise. If and only if there was a socket error with the connection, set C<HAS_ERROR> to non-zero. =item session Returns the C<Net::OSCAR> object associated with this C<Net::OSCAR::Connection>. =back =head1 HISTORY =over 4 =item * 0.62, 2002-02-25 =over 4 =item * Error handling slightly improved; error 29 is no longer unknown. =item * A minor internal buddylist enhancement =item * snacsnatcher fixes =back =item * 0.61, 2002-02-17 =over 4 =item * Fixed connection handling =back =item * 0.60, 2002-02-17 =over 4 =item * Various connection_changed fixes, including the new readwrite status. =item * Added Net::OSCAR::Connection::session method =item * Improved Net::OSCAR::Connection::process_one, documented it, and documented using it =back =item * 0.59, 2002-02-15 =over 4 =item * Protocol fixes - solves problem with AOL calling us an unauthorized client =item * Better handling of socket errors, especially when writing =item * Minor POD fixes =back =item * 0.58, 2002-01-20 =over 4 =item * Send buddylist deletions before adds - needed for complex BL mods (loadbuddies) =item * Added hooks to allow client do MD5 digestion for authentication (auth_challenge callback, Net::OSCAR::auth_response method) =back =item * 0.57, 2002-01-16 =over 4 =item * Send callback_chat_joined correctly when joining an existing chat =item * Don't activate OldPerl fixes for perl 5.6.0 =item * Ignore chats that we're already in =back =item * 0.56, 2002-01-16 =over 4 =item * Fixed rate handling =item * Send multiple buddylist modifications per SNAC =item * Detect when someone else signs on with your screenname =item * Corrected attribution of ICQ support =back =item * 0.55, 2001-12-29 =over 4 =item * Preliminary ICQ support, courtesy of SDiZ Chen (actually, Sam Wong). =item * Restored support for pre-5.6 perls - reverted from C<IO::Socket> to C<Socket>. =item * Corrected removal of buddylist entries and other buddylist-handling improvements =item * Improved rate handling - new C<worrisome> parameter to rate_alert callback =item * Removed remaining C<croak> from C<OSCAR::Connection> =item * Added is_on method =back =item * 0.50, 2001-12-23 =over 4 =item * Fixes for the "crap out on 'connection reset by peer'" and "get stuck and slow down in Perl_sv_2bool" bugs! =item * Correct handling of very large (over 100 items) buddylists. =item * We can now join exchange 5 chats. =item * Fixes in modifying permit mode. =item * Updated copyright notice courtesy of AOL's lawyers. =item * Switch to IO::Socket for portability in set_blocking. =back =item * 0.25, 2001-11-26 =over 4 =item * Net::OSCAR is now in beta! =item * We now work with perl 5.005 and even 5.004 =item * Try to prevent weird Net::OSCAR::Screenname bug where perl gets stuck in Perl_sv_2bool =item * Fixed problems with setting visibility mode and adding to deny list (thanks, Philip) =item * Added some methods to allow us to be POE-ified =item * Added guards around a number of methods to prevent the user from trying to do stuff before s/he's finished signing on. =item * Fix *incredibly* stupid error in NO_to_BLI that ate group names =item * Fixed bad bug in log_printf =item * Buddylist error handling changes =item * Added chat_decline command =item * Signon, signoff fixes =item * Allow AOL screennames to sign on =item * flap_get crash fixes =back =item * 0.09, 2001-10-01 =over 4 =item * Crash and undefined value fixes =item * New method: im_ok =item * New method: rename_group, should fix "Couldn't get group name" error. =item * Fix for buddy_in callback and data =item * Better error handling when we can't resolve a host =item * Vastly improved logging infrastructure - debug_print(f) replaced with log_print(f). debug_print callback is now called log and has an extra parameter. =item * Fixed MANIFEST - we don't actually use Changes (and we do use Screenname.pm) =item * blinternal now automagically enforces the proper structure (the right things become Net::OSCAR::TLV tied hashes and the name and data keys are automatically created) upon vivification. So, you can do $bli-E<gt>{0}-E<gt>{1}-E<gt>{2}-E<gt>{data}-E<gt>{0x3} = "foo" without worrying if 0, 1, 2, or data have been tied. Should close bug #47. =back =item * 0.08, 2001-09-07 =over 4 =item * Totally rewritten buddylist handling. It is now much cleaner, bug-resistant, and featureful. =item * Many, many internal changes that I don't feel like enumerating. Hey, there's a reason that I haven't declared the interface stable yet! ;) =item * New convenience object: Net::OSCAR::Screenname =item * Makefile.PL: Fixed perl version test and compatibility with BSD make =back =item * 0.07, 2001-08-13 =over 4 =item * A bunch of Makefile.PL fixes =item * Fixed spurious admin_error callback and prevent user from having multiple pending requests of the same type. (closes #39) =item * Head off some potential problems with set_visibility. (closes #34) =item * Removed connections method, added selector_filenos =item * Added error number 29 (too many recent signons from your site) to Net::OSCAR::Common. =item * We now explicitly perl 5.6.0 or newer. =back =item * 0.06, 2001-08-12 =over 4 =item * Prevent sending duplicate signon_done messages =item * Don't addconn after crapping out! =item * Don't try to delconn unless we have connections. =item * delete returns the correct value now in Net::OSCAR::Buddylist. =item * Don't use warnings if $] E<lt>= 5.005 =item * evil is a method, not a manpage (doc fix) =item * Added buddyhash method. =item * Added a debug_print callback. =item * Clarified process_connections method in documentation =item * You can now specify an alternate host/port in signon =item * Added name method to Chat. =item * permit list and deny list are no longer part of buddylist =item * Rewrote buddylist parsing (again!) =item * No more default profile. =item * Fix bug when storing into an already-existing key in Net::OSCAR::Buddylist. =item * snacsnatcher: Remove spurious include of Net::OSCAR::Common =item * We don't need to handle VISMODE_PERMITBUDS ourself - the server takes care of it. Thanks, VB! =item * Makefile.PL: Lots of way cool enhancements to make dist: =over 4 =item - It modifies the version number for us =item - It does a CVS rtag =item - It updates the HTML documentation on zevils and the README. =back =item * Added HISTORY and INSTALLATION section to POD. =back =item * 0.05, 2001-08-08 =over 4 =item * Don't send signon_done until after we get buddylist. =item * Added signoff method. =item * Fixed typo in documentation =item * Fixed chat_invite parm count =item * Added Scalar::Utils::dualvar variables, especially to Common.pm. dualvar variables return different values in numeric and string context. =item * Added url method for Net::OSCAR::Chat (closes #31) =item * Divide evil by 10 in extract_userinfo (closes #30) =item * chat_invite now exposes chatname (closes #32) =item * Removed unnecessary and warning-generating session length from extract_userinfo =back =item * 0.01, 2001-08-02 =over 4 =item * Initial release. =back =back =head1 SUPPORT See http://www.zevils.com/programs/net-oscar/ for support, including a mailing list and bug-tracking system. =head1 AUTHOR Matthew Sachs E<lt>matthewg@zevils.comE<gt>. =head1 CREDITS John "VBScript" for a lot of technical assistance, including the explanation of rates. Adam Fritzler and the libfaim team for their documentation and an OSCAR implementation that was used to help figure out a lot of the protocol details. E<lt>http://www.zigamorph.net/faim/protocol/E<gt> Mark Doliner for help with remote buddylists. E<lt>http://kingant.net/libfaim/ReadThis.htmlE<gt> Sam Wong E<lt>sam@uhome.netE<gt> for a patch implementing ICQ2000 support. The gaim team - the source to their libfaim client was also very helpful. E<lt>http://gaim.sourceforge.net/E<gt> The users of aimirc for being reasonably patient while this module was developed. E<lt>http://www.zevils.com/programs/aimirc/E<gt> Jayson Baker for some last-minute debugging help. Rocco Caputo for helping to work out the hooks that let use be used with POE. E<lt>http://poe.perl.org/E<gt> AOL, for creating the AOL Instant Messenger service, even though they aren't terribly helpful to developers of third-party clients. =head1 LEGAL Copyright (c) 2001 Matthew Sachs. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. B<AOL> and B<AMERICA ONLINE> are registered trademarks owned by America Online, Inc. The B<INSTANT MESSENGER> mark is owned by America Online, Inc. B<ICQ> is a trademark and/or servicemark of ICQ. C<Net::OSCAR> is not endorsed by, or affiliated with, America Online, Inc or ICQ. =cut 1;