————————————————————————————————package
Net::OSCAR;
$VERSION
= 0.07;
=head1 NAME
Net::OSCAR - Implementation of AOL's OSCAR protocol for instant messaging
=head1 SYNOPSIS
use Net::OSCAR qw(:standard);
$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 requies 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 two 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.
The other 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 = $my_readers;
my $win = $my_writers;
foreach my $oscar(@oscars) {
my($readers, $writers) = $oscar->selector_filenos();
$rin |= $readers;
$win |= $writers;
}
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.
=head1 FUNCTIONALITY
C<Net::OSCAR> pretends to be WinAIM 4.3.2229. 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
sub
BEGIN {
require
5.006; }
use
strict;
use
Carp;
use
Scalar::Util;
use
Net::OSCAR::TLV;
use
Net::OSCAR::Chat;
use
warnings;
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
->{DEBUG} = 0;
$self
->{SNDEBUG} = 0;
$self
->{description} =
"OSCAR session"
;
$self
->{timeout} = 0.01;
$self
->{permit} =
$self
->bltie();
$self
->{deny} =
$self
->bltie();
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 (SCREENNAME, PASSWORD[, HOST, PORT])
Sign on to the OSCAR service.
You can specify an alternate host/port to connect to.
The default is login.oscar.aol.com port 5190.
=cut
sub
signon($$$;$$) {
my
(
$self
,
$screenname
,
$password
,
$host
,
$port
) =
@_
;
$self
->{screenname} =
$screenname
;
# We set BOS to the login connection so that our error handlers pick up errors on this connection as fatal.
$host
||=
"login.oscar.aol.com"
;
$port
||= 5190;
$self
->{port} =
$port
;
$self
->{bos} =
$self
->addconn(
$password
, CONNTYPE_LOGIN,
"login"
,
$host
);
push
@{
$self
->{connections}},
$self
->{bos};
}
=pod
=item signoff
Sign off from the OSCAR service.
=cut
sub
signoff($) {
my
$self
=
shift
;
foreach
my
$connection
(@{
$self
->{connections}}) {
$self
->delconn(
$connection
);
}
%$self
= ();
}
=pod
=item debug (DEBUGLEVEL[, SCREENNAME DEBUG])
Sets the debugging level. If this is non-zero, lots of information will be printed
to standard error. In theory, higher debugging levels will give you more information,
but right now it's all or nothing. 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. This is useful when you have multiple C<Net::OSCAR> objects.
=cut
sub
debug($$;$) {
my
$self
=
shift
;
$self
->{DEBUG} =
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
;
#print STDERR "After adding connection: ", Data::Dumper::Dumper($self->{connections}), "\n";
return
$connection
;
}
sub
delconn($$) {
my
(
$self
,
$connection
) =
@_
;
return
unless
$self
->{connections};
for
(
my
$i
=
scalar
@{
$self
->{connections}} - 1;
$i
>= 0;
$i
--) {
next
unless
!
$connection
->{
socket
} or (
fileno
$connection
->{
socket
} ==
fileno
$self
->{connections}->[
$i
]->{
socket
});
next
unless
$connection
->{conntype} ==
$self
->{connections}->[
$i
]->{conntype};
# Just in case fileno is undef.
$connection
->debug_print(
"Closing."
);
splice
@{
$self
->{connections}},
$i
, 1;
if
(!
$connection
->{sockerr}) {
eval
{
close
$connection
->{
socket
}
if
$connection
->{
socket
};
};
}
else
{
if
(
$connection
->{conntype} == CONNTYPE_BOS) {
$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;
}
sub
DESTROY {
my
$self
=
shift
;
foreach
my
$connection
(@{
$self
->{connections}}) {
next
unless
$connection
->{
socket
} and not
$connection
->{sockerr};
$connection
->flap_put(
""
, FLAP_CHAN_CLOSE);
$connection
->{
socket
}->
close
;
}
}
=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.
You must include the file numbers of all sockets returned by
the L<connections> method in both the readers, writers, and
errors parameters of your select statement.
See the L<connections> method for a way to get the file
descriptors to add to 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}}) {
next
unless
$connection
->
fileno
;
if
(
$connection
->{connected}) {
next
unless
vec
(
$$readers
|
$$errors
,
$connection
->
fileno
, 1);
vec
(
$$readers
,
$connection
->
fileno
, 1) = 0;
}
else
{
next
unless
vec
(
$$writers
|
$$errors
,
$connection
->
fileno
, 1);
vec
(
$$writers
,
$connection
->
fileno
, 1) = 0;
}
if
(
vec
(
$$errors
,
$connection
->
fileno
, 1)) {
vec
(
$$errors
,
$connection
->
fileno
, 1) = 0;
$connection
->{sockerr} = 1;
$connection
->disconnect();
}
else
{
$connection
->process_one();
}
}
}
=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}}) {
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
->debug_printf(
"findgroup 0x%04X"
,
$groupid
);
while
((
$group
,
$currgroup
) =
each
(%{
$self
->{buddies}})) {
$self
->debug_printf(
"\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->debug_print("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
newid($;$) {
my
(
$self
,
$group
) =
@_
;
my
$id
= 0;
if
(
$group
) {
do
{ ++
$id
; }
while
(
grep
{
$_
->{buddyid} ==
$id
}
values
%$group
);
}
else
{
do
{
$id
= ++
$self
->{nextid}->{__GROUPID__}; }
while
(
$self
->findgroup(
$id
));
}
return
$id
;
}
=pod
=item add_permit (BUDDIES)
Add buddies to your permit list. Note that this is the same as
calling L<add_buddy> with a group of C<permit>.
=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
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 add_buddy (GROUP, BUDDIES)
Adds buddies to the given group on your buddylist.
=item remove_buddy (GROUP, BUDDIES)
See L<add_buddy>.
=cut
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.
=cut
sub
set_visibility($$) {
my
(
$self
,
$vismode
) =
@_
;
$self
->{vismode} =
$vismode
;
if
(!
$self
->{haspd}) {
# Contents of subTLV 0xCB in TLV 0x02 in SNAC 0x0013/0x0006
$self
->{bos}->snac_put(
family
=> 0x13,
subtype
=> 0x08,
data
=>
chr
(0xFF)x4);
$self
->{haspd} =
chr
(0xFF) x 4;
}
$self
->{bos}->snac_put(
family
=> 0x13,
subtype
=> 0x9,
data
=>
pack
(
"nnnn nnn Cnn a*"
, 0, 0, 2, 4,
0xD, 0xCA, 1,
$vismode
, 0xCB,
length
(
$self
->{haspd}),
$self
->{haspd})
);
}
sub
mod_permit($$$@) {
my
(
$self
,
$action
,
$group
,
@buddies
) =
@_
;
my
$groupid
;
my
@ids
;
my
$subtype
;
my
$packet
=
""
;
$subtype
= 0x8
if
$action
== MODBL_ACTION_ADD;
$subtype
= 0xA
if
$action
== MODBL_ACTION_DEL;
if
(
$group
eq
"permit"
) {
$groupid
= GROUP_PERMIT;
}
else
{
$groupid
= GROUP_DENY;
}
if
(
$action
== MODBL_ACTION_ADD) {
foreach
my
$buddy
(
@buddies
) {
$self
->{
$group
}->{
$buddy
}->{buddyid} =
$self
->newid(
$self
->{group});
}
}
else
{
foreach
my
$buddy
(
@buddies
) {
push
@ids
,
$self
->{
$group
}->{
$buddy
}->{buddyid};
delete
$self
->{
$group
}->{
$buddy
};
}
}
foreach
my
$buddy
(
@buddies
) {
my
$id
;
if
(
$action
== MODBL_ACTION_DEL) {
$id
=
shift
@ids
;
}
else
{
$id
=
$self
->{
$group
}->{
$buddy
}->{buddyid};
}
$packet
=
pack
(
"na*"
,
length
(
$buddy
),
$buddy
);
$packet
.=
pack
(
"nnnn"
, 0,
$id
,
$groupid
, 0);
}
$self
->{bos}->snac_put(
family
=> 0x13,
subtype
=>
$subtype
,
data
=>
$packet
);
return
;
}
sub
mod_buddylist($$$$;@) {
my
(
$self
,
$action
,
$what
,
$group
,
@buddies
) =
@_
;
my
$packet
=
""
;
my
$buddy
;
my
$groupid
= 0;
my
$subtype
;
my
@ids
;
$subtype
= 0x8
if
$action
== MODBL_ACTION_ADD;
$subtype
= 0xA
if
$action
== MODBL_ACTION_DEL;
@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} =
$groupid
=
$self
->newid();
$self
->{buddies}->{
$group
}->{members} =
$self
->bltie();
}
elsif
(
$what
== MODBL_WHAT_GROUP and
$action
== MODBL_ACTION_DEL) {
return
unless
exists
$self
->{buddies}->{
$group
};
$groupid
=
$self
->{buddies}->{
$group
}->{groupid};
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
;
$groupid
=
$self
->{buddies}->{
$group
}->{groupid};
foreach
my
$buddy
(
@buddies
) {
$self
->{buddies}->{
$group
}->{members}->{
$buddy
}->{buddyid} =
$self
->newid(
$self
->{buddies}->{
$group
}->{members});
}
}
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
;
$groupid
=
$self
->{buddies}->{
$group
}->{groupid};
foreach
my
$buddy
(
@buddies
) {
push
@ids
,
$self
->{buddies}->{
$group
}->{members}->{
$buddy
}->{buddyid};
delete
$self
->{buddies}->{
$group
}->{members}->{
$buddy
};
}
$self
->mod_buddylist(MODBL_ACTION_DEL, MODBL_WHAT_GROUP,
$group
)
unless
scalar
keys
%{
$self
->{buddies}->{
$group
}->{members}};
}
$self
->{bos}->snac_put(
family
=> 0x13,
subtype
=> 0x11)
unless
$self
->{blmod}++;
foreach
$buddy
(
@buddies
) {
$packet
.=
pack
(
"na*"
,
length
(
$buddy
),
$buddy
);
$packet
.=
pack
(
"n"
,
$groupid
);
if
(
$what
== MODBL_WHAT_BUDDY) {
if
(
$action
== MODBL_ACTION_ADD) {
$packet
.=
pack
(
"n"
,
$self
->{buddies}->{
$group
}->{members}->{
$buddy
}->{buddyid});
}
else
{
$packet
.=
pack
(
"n"
,
shift
@ids
);
}
}
else
{
$packet
.=
pack
(
"n"
, 0);
}
$packet
.=
pack
(
"n"
, (
$what
== MODBL_WHAT_BUDDY) ? 0 : 1);
if
(
$what
== MODBL_WHAT_GROUP and
$action
== MODBL_ACTION_DEL) {
$packet
.=
pack
(
"nnnn"
, 1, 4, 0xC8, 0);
}
else
{
$packet
.=
pack
(
"n"
, 0);
}
}
$self
->{bos}->snac_put(
family
=> 0x13,
subtype
=>
$subtype
,
data
=>
$packet
);
push
@{
$self
->{modgroups}},
$group
;
$self
->{blmod}--;
}
sub
modgroups($) {
my
$self
=
shift
;
return
if
$self
->{blmod};
#{blmod} is a lock on the blist.
if
(
$self
->{bltdone}) {
delete
$self
->{bltdone};
$self
->{bos}->snac_put(
family
=> 0x13,
subtype
=> 0x12);
return
;
}
return
unless
ref
(
$self
->{modgroups}) eq
"ARRAY"
;
my
@groups
= @{
$self
->{modgroups}};
delete
$self
->{modgroups};
if
(!
@groups
) {
delete
$self
->{blmod};
$self
->{bos}->snac_put(
family
=> 0x13,
subtype
=> 0x12);
return
;
}
foreach
my
$group
(
@groups
) {
my
$packet
=
""
;
my
@members
= ();
@members
=
keys
%{
$self
->{buddies}->{
$group
}->{members}}
if
exists
$self
->{buddies}->{
$group
};
if
(
@members
) {
$packet
.=
pack
(
"na*"
,
length
(
$group
),
$group
);
$packet
.=
pack
(
"nn"
,
$self
->{buddies}->{
$group
}->{groupid}, 0);
my
(
%tlv
,
%subtlv
);
tie
%tlv
,
"Net::OSCAR::TLV"
;
tie
%subtlv
,
"Net::OSCAR::TLV"
;
%subtlv
= (
0xC8
=>
pack
(
"n*"
,
map
{
$self
->{buddies}->{
$group
}->{members}->{
$_
}->{buddyid} }
@members
)
);
%tlv
= (
0x01
=>
$self
->{bos}->tlv_encode(\
%subtlv
));
$packet
.=
$self
->{bos}->tlv_encode(\
%tlv
);
}
else
{
$packet
.=
pack
(
"n*"
, 0, 0, 0, 1, 2
*scalar
keys
%{
$self
->{buddies}}, 0xC8, 4,
map
{
$_
->{groupid} }
grep
{
$_
->{groupid} != 0xFFFF }
values
%{
$self
->{buddies}});
}
$self
->{bos}->snac_put(
family
=> 0x13,
subtype
=> 0x09,
data
=>
$packet
);
}
$self
->{bltdone} = 1;
}
sub
extract_userinfo($$) {
my
(
$self
,
$data
) =
@_
;
my
$retval
= {};
my
$tlvcnt
;
(
$retval
->{screenname},
$retval
->{evil},
$tlvcnt
) =
unpack
(
"C/a* n n"
,
$data
);
$retval
->{evil} /= 10;
substr
(
$data
, 0, 5+
length
(
$retval
->{screenname})) =
""
;
$self
->debug_print(
"Decoding userinfo TLV with tlvcnt $tlvcnt."
);
my
(
$tlv
,
$chainlen
) =
$self
->{bos}->tlv_decode(
$data
,
$tlvcnt
);
#$chainlen--;
$self
->debug_print(
"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
->{membersince}) =
unpack
(
"N"
,
$tlv
->{2});
(
$retval
->{onsince}) =
unpack
(
"N"
,
$tlv
->{3});
(
$retval
->{idle}) =
unpack
(
"n"
,
$tlv
->{4})
if
exists
(
$tlv
->{4});
(
$retval
->{capabilities}) =
$tlv
->{0xD};
substr
(
$data
, 0,
$chainlen
) =
""
;
if
(
$data
) {
$tlv
=
$self
->{bos}->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
) =
@_
;
$self
->{bos}->snac_put(
reqdata
=>
$screenname
,
family
=> 0x2,
subtype
=> 0x5,
data
=>
pack
(
"nCa*"
, 1,
length
(
$screenname
),
$screenname
));
}
sub
get_away($$) {
my
(
$self
,
$screenname
) =
@_
;
$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.
=cut
sub
send_im($$$;$) {
my
(
$self
,
$to
,
$msg
,
$away
) =
@_
;
my
$packet
=
""
;
my
$reqid
= 0;
return
0
if
length
(
$msg
) >= 7987;
$packet
= randchars(8);
$packet
.=
pack
(
"n"
, 1);
# channel
$packet
.=
pack
(
"Ca*"
,
length
(
$to
),
$to
);
$packet
.=
pack
(
"n5 C n C n3 a*"
, 2,
length
(
$msg
)+16, 0x501, 4, 0x101, 1,
0x201, 1,
length
(
$msg
)+4, 0, 0,
$msg
);
if
(
$away
) {
$packet
.=
pack
(
"nn"
, 4, 0);
}
else
{
$packet
.=
pack
(
"nn"
, 3, 0);
#request server confirmation
}
$self
->{bos}->snac_put(
reqdata
=>
$to
,
family
=> 0x4,
subtype
=> 0x6,
data
=>
$packet
);
return
1;
}
=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.
=cut
sub
buddyhash($) {
shift
->bltie(); }
sub
bltie($) {
my
$self
=
shift
;
my
%bl
;
tie
%bl
,
"Net::OSCAR::Buddylist"
;
return
\
%bl
;
}
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
->debug_print(
"Incoming ICBM on channel $channel."
);
}
$self
->debug_print(
"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
->debug_print(
"Decoding ICBM secondary TLV."
);
my
$tlv
=
$self
->{bos}->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->debug_print("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
=
$self
->{bos}->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;
}
}
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
) =
@_
;
$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]+/,
"0x74 0x8F 0x24 0x20 0x62 0x87 0x11 0xD1 0x82 0x22 0x44 0x45 0x53 0x54 0x00 0x00"
));
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($$) {
shift
->set_info(
""
,
@_
); }
=pod
=item set_info (PROFILE)
Sets the user's profile.
=cut
sub
set_info($$;$) {
my
(
$self
,
$profile
,
$awaymsg
) =
@_
;
my
%tlv
;
tie
%tlv
,
"Net::OSCAR::TLV"
;
if
(
$profile
) {
$tlv
{0x1} = ENCODING;
$tlv
{0x2} =
$profile
;
}
if
(
defined
(
$awaymsg
)) {
$tlv
{0x3} = ENCODING;
$tlv
{0x4} =
$awaymsg
;
}
$tlv
{0x5} =
$self
->capabilities();
$self
->debug_print(
"Setting user information."
);
$self
->{bos}->snac_put(
family
=> 0x02,
subtype
=> 0x04,
data
=>
$self
->{bos}->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
->debug_print(
"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
) =
@_
;
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
=>
$self
->{bos}->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
;
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
) =
@_
;
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
=>
pack
(
"nna*"
, 0x11,
length
(
$newmail
),
$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
) =
@_
;
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
=>
pack
(
"nn a*"
, 1,
length
(
$newname
),
$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
) =
@_
;
$exchange
||= 4;
$self
->debug_print(
"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
)
);
}
=pod
=item chat_accept (CHAT)
Use this to accept an invitation to join a chatroom.
=cut
sub
chat_accept($$) {
my
(
$self
,
$chat
) =
@_
;
$self
->debug_print(
"Accepting chat invite for $chat."
);
$self
->svcdo(CONNTYPE_CHATNAV,
family
=> 0x0D,
subtype
=> 0x04,
data
=>
pack
(
"nca* Cn"
, 4,
length
(
$chat
),
$chat
, 0, 2)
);
}
sub
crapout($$$) {
my
(
$self
,
$connection
,
$reason
) =
@_
;
$self
->callback_error(
$connection
,
$reason
, 0,
""
,
""
, 0, 0, 1);
$self
->signoff();
}
=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
) =
@_
;
$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,
debug level, 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
->{DEBUG} =
$self
->{DEBUG};
$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}}) {
if
(
$connection
->{connected}) {
vec
(
$rin
,
fileno
$connection
->{
socket
}, 1) = 1;
}
else
{
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.
=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.
=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.
=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}; }
=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
) =
@_
;
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->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, DESCRIPTION, ERRNO, URL, REQDATA, FAMILY, SUBTYPE[, FATAL])
Called when any sort of error occurs (except see L<admin_error> below.) Note that most
of these parameters, except for OSCAR, DESCRIPTION, and FATAL, are optional.
CONNECTION is the particular connection which generated the error - the C<debug_print> method of
C<Net::OSCAR::Connection> may be useful, as may be getting C<$connection->{description}>.
DESCRIPTION is a somewhat nicely formatted error message. It is recommended that you just
use this and ignore all the other parameters (except for FATAL) unless you want to get fancy.
ERRNO is the error number - a list of error descriptions indexed by error number is returned
by C<Net::OSCAR::Common::ERRORS>. URL is an http URL which the user can visit for more information
about the error. REQDATA is some data the was associated with the request which generated the error.
At present, it is a screenname for errors sending IMs or retrieving user information. FAMILY and
SUBTYPE are the SNAC numbers of the request which generated the error and probably aren't too useful
to you. FATAL is non-zero if the error was fatal - something like an invalid password on signon or
the connection to OSCAR being severed.
=item rate_alert (OSCAR, LEVEL, CLEAR, WINDOW)
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.
=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_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 debug_print(OSCAR, MESSAGE)
Use this callback if you don't want the debug_print methods to just print to STDERR.
=back
=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_im_in(@) { do_callback(
"im_in"
,
@_
); }
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_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_debug_print(@) { do_callback(
"debug_print"
,
@_
); }
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_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_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_debug_print($\&) { set_callback(
"debug_print"
,
@_
); }
=pod
=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.
=back
=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
=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.
=head1 HISTORY
=over 4
=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 $] <= 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>
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.
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. AOL Instant Messenger and AIM are registered service marks
of AOL/Time Warner. America OnLine is a registered trademark of AOL/Time Warner.
C<Net::OSCAR> is not affiliated with, endorsed by, or supported by AOL.
=cut
1;