File Coverage

blib/lib/Net/OSCAR.pm

Criterion	Covered	Total	%
statement	52	876	5.9
branch	0	394	0.0
condition	0	182	0.0
subroutine	18	186	9.6
pod			n/a
total	70	1638	4.2

package Net::OSCAR;
BEGIN {
  $Net::OSCAR::VERSION = '1.928';
}

$REVISION = '$Revision$';

=pod

=head1 NAME

Net::OSCAR - Implementation of AOL's OSCAR protocol for instant messaging (for interacting with AIM a.k.a. AOL IM a.k.a. AOL Instant Messenger - and ICQ, too!)

=head1 VERSION

version 1.928

=head1 SYNOPSIS

	use Net::OSCAR qw(:standard);

	sub im_in {
		my($oscar, $sender, $message, $is_away) = @_;
		print "[AWAY] " if $is_away;
		print "$sender: $message\n";
	}

	$oscar = Net::OSCAR->new();
	$oscar->set_callback_im_in(\&im_in);
	$oscar->signon($screenname, $password);
	while(1) {
		$oscar->do_one_loop();
		# Do stuff
	}

=head1 INSTALLATION

=head2 HOW TO INSTALL

	perl Build.PL
	perl Build
	perl Build test
	perl Build install

See C for details.
Note that this requires that you have the perl module Module::Build installed.
If you don't, the traditional C
should still work.

=head2 DEPENDENCIES

This modules requires C and C.  C is needed
to run the test suite, and C is needed to generate the XML parse tree
which is shipped with released versions.

=head1 INTRODUCTION

=head2 ABSTRACT

C implements the OSCAR protocol which is used by AOL's AOL Instant
Messenger service.  To use the module, you create a C 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 C<: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.
Source code from the Gaim client, the protocol analysis provided by the Ethereal
network sniffer, and the Alexander Shutko's website
Ehttp://iserverd1.khstu.ru/oscar/E were also used as references.

This module strives to be as compatible with C as possible at the API level, but some
protocol-level differences prevent total compatibility.  The TOC protocol implemented
by C is simpler than OSCAR and has official reference documentation from AOL,
but it only provides a small subset of the full C functionality.
See the section on L for more information.

=head2 EVENT PROCESSING OVERVIEW

Event processing is the implementation of C within the framework of your
program, so that your program can respond to things happening on the OSCAR servers while
still doing everything else that you need it to do, such as accepting user input.  There are three main ways for the module to handle event processing.  The simplest is to
call the L method, which performs a C call on all the object's
sockets and reads incoming commands from the OSCAR server on any connections which
have them.  The C call has a default timeout of 0.01 seconds which can
be adjusted using the L method.  This means that every time you call L,
it will pause for that interval if there are no messages from the OSCAR server.
If you need lower overhead, want better performance, or need to handle many Net::OSCAR objects and/or other files and sockets
at once, see L below.

=head2 FUNCTIONALITY

C pretends to be WinAIM 5.5.3595.  It supports remote buddylists
including permit and deny settings.  It also supports chat, buddy icons,
and extended status messages.  At the present time, setting and retrieving of
directory information is not supported; nor are email privacy settings,
voice chat, stock ticker, file transfer, direct IM, and many other of the
official AOL Instant Messenger client's features.

=head2 TERMINOLOGY

When you sign on with the OSCAR service, you are establishing an OSCAR session.

=head2 CALLBACKS

C uses a callback mechanism to notify you about different events.
A callback is a function provided by you which C will call
when a certain event occurs.  To register a callback, calling the C method
with a code reference as a parameter.  For instance, you might call
C<$oscar-Eset_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 object which generated the callback.  This is useful
when using multiple C objects.

=head1 REFERENCE

=cut

use 5.006_001;
use strict;
use vars qw($REVISION @ISA @EXPORT_OK %EXPORT_TAGS $NODESTROY);
use Carp;
use Scalar::Util qw(weaken);
use Digest::MD5 qw(md5);
use Socket;
use Net::OSCAR::Common qw(:all);
use Net::OSCAR::Constants;
use Net::OSCAR::Utility;
use Net::OSCAR::Connection;
use Net::OSCAR::Callbacks;
use Net::OSCAR::TLV;
use Net::OSCAR::Buddylist;
use Net::OSCAR::Screenname;
use Net::OSCAR::_BLInternal;
use Net::OSCAR::XML;

$NODESTROY = 0;

require Exporter;
@ISA = qw(Exporter);
@EXPORT_OK = @Net::OSCAR::Common::EXPORT_OK;
%EXPORT_TAGS = %Net::OSCAR::Common::EXPORT_TAGS;

Net::OSCAR::XML::load_xml();

=pod

=head2 BASIC FUNCTIONALITY

=head3 METHODS

=over 4

=item new ([capabilities =E CAPABILITIES], [rate_manage =E RATE_MANAGE_MODE])

Creates a new C object.  You may optionally
pass a hash to set some parameters for the object.

=over 4

=item capabilities

A listref of optional features that your client supports.
Valid capabilities are:

=over 4

=item extended_status

iChat-style extended status messages

=item buddy_icons

=item file_transfer

=item file_sharing

=item typing_status

Typing status notification

=item buddy_list_transfer

=back

=item rate_manage

Which mechanism will your application be using to deal with
the sending rates which the server enforces on the client?
See L<"RATE LIMIT OVERVIEW"> for more information on the subject.

=over 4

=item OSCAR_RATE_MANAGE_NONE

=item OSCAR_RATE_MANAGE_AUTO

=item OSCAR_RATE_MANAGE_MANUAL

=back

=back

	$oscar = Net::OSCAR->new(capabilities => [qw(extended_status typing_status)], rate_manage => OSCAR_RATE_MANAGE_AUTO);

=cut

sub new($) {
	my $class = ref($_[0]) || $_[0] || "Net::OSCAR";
	shift;

	my $self = {
		options => {},
		_parameters => [@_]
	};
	bless $self, $class;

	my(%parameters) = @_;
	if(my($badparam) = grep { $_ ne "capabilities" and $_ ne "rate_manage" } keys %parameters) {
		croak "Invalid parameter '$badparam' passed to Net::OSCAR::new.";
	}
	if($parameters{capabilities}) {
		if(my($badcap) = grep { $_ ne "extended_status" and $_ ne "buddy_icons" and $_ ne "file_transfer" and $_ ne "file_sharing" and $_ ne "typing_status" and $_ ne "file_transfer" and $_ ne "buddy_list_transfer" } @{$parameters{capabilities}}) {
			croak "Invalid capability '$badcap' passed to Net::OSCAR::new.";
		}
	}
	if($parameters{rate_manage}) {
		if($parameters{rate_manage} < OSCAR_RATE_MANAGE_NONE or $parameters{rate_manage} > OSCAR_RATE_MANAGE_MANUAL) {
			croak "Invalid rate_manage value '$parameters{rate_manage}' passed to Net::OSCAR::new.";
		} elsif($parameters{rate_manage} == OSCAR_RATE_MANAGE_AUTO) {
			croak "OSCAR_RATE_MANAGE_AUTO hasn't been implemented yet!";
		} else {
			$self->{rate_manage_mode} = $parameters{rate_manage};
			if($self->{rate_manage_mode} != OSCAR_RATE_MANAGE_NONE) {
				require Net::OSCAR::MethodInfo;
			}
		}
	} else {
		$self->{rate_manage_mode} = OSCAR_RATE_MANAGE_NONE;
	}

	$self->{LOGLEVEL} = OSCAR_DBG_WARN;
	$self->{SNDEBUG} = 0;
	$self->{__BLI_locked} = 0;
	$self->{__BLI_commit_later} = 0;

	$self->{description} = "OSCAR session";
	$self->{userinfo} = bltie;
	$self->{services} = tlv;
	$self->{svcqueues} = tlv;
	$self->{listener} = undef;
	$self->{rv_proposals} = {};
	$self->{pass_is_hashed} = 0;
	$self->{stealth} = 0;
	$self->{icq_meta_info_cache} = {};
	$self->{ip} = 0;

	$self->{ft_ip} = undef;
	$self->{rv_neg_mode} = OSCAR_RV_AUTO;
	$self->{bl_limits} = {
		buddies => 0,
		groups => 0,
		permits => 0,
		denies => 0
	};

	$self->{timeout} = 0.01;
	$self->{capabilities} = {};

	if($parameters{capabilities}) {
		$self->{capabilities}->{$_} = 1 foreach @{$parameters{capabilities}};
	}

	# Set default callbacks
	$self->set_callback_snac_unknown(\&Net::OSCAR::Callbacks::default_snac_unknown);

	return $self;
}

=pod

=item signon (HASH)

=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.

The non-hash form of C is obsolete and is only provided for compatibility with C.
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 stealth

Use this to sign on with stealth mode activated.  Using this, as opposed
to signon on without this setting and then calling L<"set_stealth">, will prevent
the user from showing as online for a brief interval after signon.  See L<"set_stealth">
for information about stealth mode.

=item pass_is_hashed

If you want to give Net::OSCAR the MD5 hash of the password instead of the password
itself, use the MD5'd password in the password key and also set this key.  The
benefit of this is that, if your application saves user passwords, you can save
them in hashed form and don't need to store the plaintext.

=item local_ip

If you have more than one IP address with a route to the internet, this
parameter can be used to specify which to use as the source IP for outgoing
connections.

=item local_port

This controls which port Net::OSCAR will listen on for incoming direct connections.
If not specified, a random port will be selected.

=item host

=item port

=item proxy_type

Either "SOCKS4", "SOCKS5", "HTTP", or HTTPS.  This and C must be specified if you wish to use a proxy.
C, C, C are optional.  Note that proxy support
is considered experimental.  You will need to have the C module installed for
SOCKS proxying or the C module installed for HTTP proxying.

=item proxy_host

=item proxy_port

=item proxy_username

=item proxy_password

=back

If the screenname is all-numeric, it will automatically be treated
as an ICQ UIN instead of an AIM screenname.

=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->{services}->{0+CONNTYPE_BOS}, "You must specify a username to sign on with!");
		$args{password} = shift @_ or return $self->crapout($self->{services}->{0+CONNTYPE_BOS}, "You must specify a password to sign on with!");;
		$args{host} = shift @_ if @_;
		$args{port} = shift @_ if @_;
	} else {
		%args = @_;
		return $self->crapout($self->{services}->{0+CONNTYPE_BOS}, "You must specify a username and password to sign on with!") unless $args{screenname} and exists($args{password});
	}

	my %defaults = OSCAR_SVC_AIM;
	%defaults = OSCAR_SVC_ICQ if $args{screenname} =~ /^\d+$/;
	foreach my $key(keys %defaults) {
		$args{$key} ||= $defaults{$key};
	}
	return $self->crapout($self->{services}->{0+CONNTYPE_BOS}, "MD5 authentication not available for this service (you must define a password.)") if !defined($args{password}) and $args{hashlogin};
	$self->{screenname} = Net::OSCAR::Screenname->new(\$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},
		$self->{proxy_type}, $self->{proxy_host}, $self->{proxy_port},
		$self->{proxy_username}, $self->{proxy_password}, $self->{local_ip},
		$self->{local_port}, $self->{pass_is_hashed}, $self->{stealth}) =
			delete @args{qw(screenname password host port proxy_type proxy_host proxy_port proxy_username proxy_password local_ip local_port pass_is_hashed stealth)};

	$self->{svcdata} = \%args;

	if(defined($self->{proxy_type})) {
		$self->{proxy_type} = uc($self->{proxy_type});
		die "You must specify proxy_host if proxy_type is specified!\n" unless $self->{proxy_host};
		if($self->{proxy_type} eq "HTTP" or $self->{proxy_type} eq "HTTPS") {
			$self->{http_proxy} = LWP::UserAgent->new(
				agent => "Mozilla/4.08 [en] (WinNT; U ;Nav)",
				keep_alive => 1,
				timeout => 30,
			);
			die "HTTPS not supported by your LWP::UserAgent\n" if $self->{proxy_type} eq "HTTPS" and !$self->{http_proxy}->is_protocol_supported("https");

			my $proxyurl = lc($self->{proxy_type}) . "://$self->{proxy_host}";
			$proxyurl .= ":$self->{proxy_port}" if $self->{proxy_port};
			$proxyurl .= "/";
			$self->{http_proxy}->proxy('http', $proxyurl);
		}
	}

	$self->{services}->{0+CONNTYPE_BOS} = $self->addconn(auth => $password, conntype => CONNTYPE_LOGIN, description => "login", peer => $host);
}

=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

=back

=head3 CALLBACKS

=over 4

=item signon_done (OSCAR)

Called when the user is completely signed on to the service.

=back

=head2 BUDDIES AND BUDDYLISTS

See also L<"OTHER USERS"> for methods which pertain to any other user, regardless of
whether they're on the buddylist or not.

=head3 METHODS

=over 4

=item findbuddy (BUDDY)

In scalar context, 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.

In list context, returns a two-element list consisting of the group
name followed by the group hashref (or the empty list of the buddy
is not found.)

=cut

sub findbuddy($$) {
	my($self, $buddy) = @_;

	while(my($grpname, $group) = each(%{$self->{buddies}})) {
		next if
		  $grpname eq "__BLI_DIRTY" or
		  !$group or
		  not $group->{members}->{$buddy} or
		  $group->{members}->{$buddy}->{__BLI_DELETED};

		hash_iter_reset(\%{$self->{buddies}}); # Reset the iterator
		return wantarray ? ($grpname, $group) : $grpname;
	}
	return;
}

=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.  After calling this method, your program B not call
it again until either the L or L callbacks
are received.

=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.

=cut

sub commit_buddylist($) {
	my($self) = shift;
	return must_be_on($self) unless $self->{is_on};

	if($self->{__BLI_locked}) {
		# If the server is modifying the buddylist,
		# wait until its done to do the commit.
		$self->{__BLI_commit_later} = 1;
		return;
	}

	Net::OSCAR::_BLInternal::NO_to_BLI($self);

	# If user set icon to same as old icon, server won't request an upload.
	# Send a buddy_icon_uploaded callback anyway.
	if($self->{icon_md5sum_old} and $self->{icon_md5sum} eq $self->{icon_md5sum_old}) {
		$self->callback_buddy_icon_uploaded();
	}

	delete $self->{icon_md5sum_old};
}

sub rollback_buddylist($) {
	my($self) = shift;
	return must_be_on($self) unless $self->{is_on};
	Net::OSCAR::_BLInternal::BLI_to_NO($self);
}

sub reorder_groups($@) {
	my $self = shift;
	return must_be_on($self) unless $self->{is_on};
	my @groups = @_;
	tied(%{$self->{buddies}})->setorder(@groups);
	$self->{buddies}->{__BLI_DIRTY} = 1;
}

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);
	$self->{buddies}->{$group}->{__BLI_DIRTY} = 1;
}

=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.  If the group does not exist,
it will be created.  Call L<"commit_buddylist"> for the change to take effect.

=item remove_buddy (GROUP, BUDDIES)

See L.

=item add_group (GROUP)

Creates a new, empty group.  Call L<"commit_buddylist"> for the change to take effect.

=item remove_group (GROUP)

See L.  Any buddies in the group will be removed from the group first.

=cut

sub rename_group($$$) {
	my($self, $oldgroup, $newgroup) = @_;
	return must_be_on($self) unless $self->{is_on};
	return send_error($self, $self->{services}->{0+CONNTYPE_BOS}, 0, "That group does not exist", 0) unless exists $self->{buddies}->{$oldgroup};

	$self->{buddies}->{$newgroup} = $self->{buddies}->{$oldgroup};
	$self->{buddies}->{$newgroup}->{__BLI_DIRTY} = 1;
	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);
}

sub add_group($$) {
	my($self, $group) = @_;
	$self->mod_buddylist(MODBL_ACTION_ADD, MODBL_WHAT_GROUP, $group);
}

sub remove_group($$) {
	my($self, $group) = @_;
	return send_error($self, $self->{services}->{0+CONNTYPE_BOS}, 0, "That group does not exist", 0) unless exists $self->{buddies}->{$group};
	$self->remove_buddy($group, $self->buddies($group)) if $self->buddies($group);
	$self->mod_buddylist(MODBL_ACTION_DEL, MODBL_WHAT_GROUP, $group);
}


=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 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 as per L below.

=cut

sub groups($) { return grep {$_ and $_ ne "__BLI_DIRTY"} keys %{shift->{buddies}}; }
sub buddies($;$) {
	my($self, $group) = @_;

	if($group) {
		my $grp = $self->{buddies}->{$group};

		return grep {
			not $grp->{members}->{$_}->{__BLI_DELETED}
		} keys %{$grp->{members}};
	}

	my @buddies;
	while(my($grpname, $group) = each(%{$self->{buddies}})) {
		next if !$grpname or $grpname eq "__BLI_DIRTY";
		push @buddies, grep { not $group->{members}->{$_}->{__BLI_DELETED} } keys %{$group->{members}};
	}
	return @buddies;
}
sub buddy($$;$) {
	my($self, $buddy, $grpname) = @_;
	my $group;

	if(!$grpname) {
		($grpname, $group) = $self->findbuddy($buddy) or return;
	} else {
		$group = $self->{buddies}->{$grpname} or return;
	}

	my $ret = $group->{members}->{$buddy};
	return $ret->{__BLI_DELETED} ? undef : $ret;

	return $self->{userinfo}->{$buddy} || undef;
}

=pod

=item set_buddy_comment (GROUP, BUDDY[, COMMENT])

Set a brief comment about a buddy.  You must call L<"commit_buddylist"> to save
the comment to the server.  If COMMENT is undefined, the comment is
deleted.

=item set_buddy_alias (GROUP, BUDDY[, ALIAS])

Set an alias for a buddy.  You must call L<"commit_buddylist"> to save
the comment to the server.  If ALIAS is undefined, the alias is
deleted.

=cut

sub set_buddy_comment($$$;$) {
	my($self, $group, $buddy, $comment) = @_;
	return must_be_on($self) unless $self->{is_on};

	my $bud = $self->{buddies}->{$group}->{members}->{$buddy};
	$bud->{comment} = $comment;
	$bud->{__BLI_DIRTY} = 1;
}

sub set_buddy_alias($$$;$) {
	my($self, $group, $buddy, $alias) = @_;
	return must_be_on($self) unless $self->{is_on};

	my $bud = $self->{buddies}->{$group}->{members}->{$buddy};
	$bud->{alias} = $alias;
	$bud->{__BLI_DIRTY} = 1;
}

=pod

=item buddylist_limits

Returns a hash containing the maximum number of buddylist entries
of various types.  The keys in the hash are:

=over 4

=item *

buddies

=item *

groups

=item *

permits

=item *

denies

=back

So, the maximum number of buddies allowed on a buddylist is stored in the C key.
Please note that buddylist storage has some overhead, so the actual number of items you
can have on a buddylist may be slightly less than advertised.

If the OSCAR server did not inform us of the limits, values of 0 will be used.

=cut

sub buddylist_limits($) { return %{shift->{bl_limits}}; }

=pod

=back

=head3 CALLBACKS

=over 4

=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 method.

=item buddy_out (OSCAR, SCREENNAME, GROUP)

Called when a buddy has signed off (or added us to their deny list.)

=item buddylist_error (OSCAR, ERROR, WHAT)

This is called when there is an error commiting changes to the buddylist.
C is the error number.  C is a string describing which buddylist
change failed.  C will revert the failed change to
its state before C was called.  Note that the
buddylist contains information other than the user's buddies - see
any method which says you need to call C to have its
changes take effect.

=item buddylist_ok (OSCAR)

This is called when your changes to the buddylist have been successfully commited.

=item buddylist_changed (OSCAR, CHANGES)

This is called when your buddylist is changed by the server.
The most common reason for this to happen is if the screenname you are signed
on with is also signed on somewhere else, and the buddylist is changed in
the other session.

Currently, only changes to buddies and groups will be listed in C.
Changes to privacy settings and any other portions of the buddylist will
not be included in the list in the current version of C.

C is a list of hash references, one for each change to the buddylist,
with the following keys:

=over 4

=item *

type: Either C or C.  This indicates
if the change was to a buddy or a group.

=item *

action: Either C or C.  This indicates
whether the change was an addition/modification or a deletion.

=item *

group: The name of the group which the modification took place in.  For
C, this will be the name of the group which the
changed buddy was changed in; for C, this will
be the name of the group which was changed.

=item *

buddy: This key is only present for C.  It's the name
of the buddy which was changed.

=back

The C constants come from C, and
are included in the C<:standard> export list.

=back

=head2 PRIVACY

C 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.

=head3 METHODS

=over 4

=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.

=item remove_permit (BUDDIES)

See L.

=item remove_deny (BUDDIES)

See L.

=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.

=item visibility

Returns the user's current visibility setting.  See L.

=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}}; }
sub visibility($) { return shift->{visibility}; }


=pod

=item set_visibility (MODE)

Sets the visibility mode, which determines how the permit and deny lists
are interpreted.  Note that if you're looking for the feature which will prevent
a user from showing up as online on any buddy list while not affecting anything else,
the droids you're looking for are L<"is_stealth">/L<"set_stealth">.

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 package,
and will be imported into your namespace if you import C
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 is_stealth

=item set_stealth STEALTH_STATUS

These methods deal with "stealth mode".  When the user is in stealth mode, she won't
show up as online on anyone's buddylist.  However, for all other purposes, she will be online
as usual.  Any restrictions, imposed by the visibility mode (see L<"set_visibility">),
on who can communicate with her will remain in effect.

Stealth state can be changed by another signon of the user's
screenname.  So, if you want your application to be aware of the stealth state,
C won't cut it; there's a L<"stealth_changed"> callback which will serve
nicely.

=cut

sub is_stealth($) { return shift->{stealth}; }
sub set_stealth($$) {
	my($self, $new_state) = @_;
	$self->svcdo(CONNTYPE_BOS, protobit => "set_extended_status", protodata => {
		stealth => {state => $new_state ? 0x100 : 0}
	});
}

=pod

=item set_group_permissions (NEWPERMS)

Set group permissions.  This lets you block any OSCAR users or any AOL users.
C 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

=back

=head2 OTHER USERS

See also L<"BUDDIES AND BUDDYLISTS">.

=head3 METHODS

=over 4

=item get_info (WHO)

Requests a user's information, which includes their profile and idle time.
See the L callback for more information.

=item get_away (WHO)

Similar to L, 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->svcdo(CONNTYPE_BOS, reqdata => $screenname, protobit => "get_info", protodata => {screenname => $screenname});
}
sub get_away($$) {
	my($self, $screenname) = @_;
	return must_be_on($self) unless $self->{is_on};

	$self->svcdo(CONNTYPE_BOS, reqdata => $screenname, protobit => "get_away", protodata => {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 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 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};

	if(!$self->{svcdata}->{hashlogin}) {
		return 0 if length($msg) >= 7987;
	} else {
		return 0 if length($msg) > 2000;
	}

	my %protodata;
	$protodata{message} = $msg;

	if($away) {
		$protodata{is_automatic} = {};
	} else {
		$protodata{request_server_confirmation} = {};
	}

	if($self->{capabilities}->{buddy_icons} and $self->{icon_checksum} and $self->{icon_timestamp} and
		(!exists($self->{userinfo}->{$to}) or
		!exists($self->{userinfo}->{to}->{icon_timestamp_received}) or
		$self->{icon_timestamp} > $self->{userinfo}->{$to}->{icon_timestamp_received})
	) {
		$self->log_print(OSCAR_DBG_DEBUG, "Informing $to about our buddy icon.");
		$self->{userinfo}->{$to} ||= {};
		$self->{userinfo}->{$to}->{icon_timestamp_received} = $self->{icon_timestamp};

		$protodata{icon_data}->{"icon_".$_} = $self->{"icon_".$_} foreach qw(length checksum timestamp);
	}

	my $flags2 = 0;
	if($self->{capabilities}->{typing_status}) {
		$flags2 = 0xB;
	}

	my($req_id) = $self->send_message($to, 1, protoparse($self, "standard_IM_footer")->pack(%protodata), $flags2);
	return $req_id;
}

=pod

=item send_typing_status (RECIPIENT, STATUS)

Send a typing status change to another user.  Send these messages
to implement typing status notification.  Valid values for C are:

=over 4

=item *

TYPINGSTATUS_STARTED: The user has started typing to the recipient.
This indicates that typing is actively taking place.

=item *

TYPINGSTATUS_TYPING: The user is typing to the recipient.  This
indicates that there is text in the message input area, but
typing is not actively taking place at the moment.

=item *

TYPINGSTATUS_FINISHED: The user has finished typing to the recipient.
This should be sent when the user starts to compose a message, but
then erases all of the text in the message input area.

=back

=cut

sub send_typing_status($$$) {
	my($self, $recipient, $status) = @_;

	croak "This client does not support typing status notifications." unless $self->{capabilities}->{typing_status};
	return unless exists $self->{userinfo}->{$recipient} and $self->{userinfo}->{$recipient}->{typing_status};

	$self->svcdo(CONNTYPE_BOS, protobit => "typing_notification", protodata => {
		screenname => $recipient,
		typing_status => $status
	});
}


=pod

=item evil (WHO[, ANONYMOUSLY])

C, or C, 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->svcdo(CONNTYPE_BOS, reqdata => $who, protobit => "outgoing_warning", protodata => {
		is_anonymous => $anon ? 1 : 0,
		screenname => $who
	});
}

=pod

=item get_icon (SCREENNAME, MD5SUM)

Gets a user's buddy icon.  See L for details.  To make
sure this method isn't called excessively, please check the
C and C data, which are available
via the L method (even for people not on the user's buddy
list.)  The MD5 checksum of a user's icon will be in the
C key returned by L.

You should receive a L callback in
response to this method.

=cut

sub get_icon($$$) {
	my($self, $screenname, $md5sum) = @_;

	carp "This client does not support buddy icons!" unless $self->{capabilities}->{buddy_icons};

	$self->svcdo(CONNTYPE_ICON, protobit => "buddy_icon_download", protodata => {
		screenname => $screenname,
		md5sum => $md5sum
	});
}

=pod

=back

=head3 CALLBACKS

=over 4

=item new_buddy_icon (OSCAR, SCREENNAME, BUDDY DATA)

This is called when someone, either someone the user is talking with or someone on
their buddylist, has a potentially new buddy icon.  The buddy data is guaranteed
to have at least C available; C and C
may not be.  Specifically, if C found out about the buddy icon
through a buddy status update (the sort that triggers a L callback),
these data will B be available; if C found out about the
icon via an incoming IM from the person, these data B be available.

Upon receiving this callback, an application should use the C
to search for the icon in its cache, and call L if it can't find it.
If the C, which is what needs to get passed to L, is not present
in the buddy data, use L to request the information for the user,
and then call L from the L callback.

=item buddy_icon_downloaded (OSCAR, SCREENNAME, ICONDATA)

This is called when a user's buddy icon is successfully downloaded from the server.

=item typing_status (OSCAR, SCREENNAME, STATUS)

Called when someone has sent us a typing status notification message.
See L for a description of the different statuses.

=item im_ok (OSCAR, TO, REQID)

Called when an IM to C is successfully sent.
REQID is the request ID of the IM as returned by C.

=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 buddylist_in (OSCAR, FROM, BUDDYLIST)

Called when someone sends you a buddylist.  You must set the L<"buddy_list_transfer">
capability for buddylists to be sent to you.  The buddylist will be a C
hashref whose keys are the groups and whose values are listrefs of C
strings for the buddies in the group.

=item buddy_info (OSCAR, SCREENNAME, BUDDY DATA)

Called in response to a L or L request.
BUDDY DATA is the same as that returned by the L method,
except that one of two additional keys, C and C,
may be present.

=back

=head2 THE SIGNED-ON USER

These methods deal with the user who is currently signed on using a particular
C object.

=head3 METHODS

=over 4

=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 email($) { return shift->{email}; }
sub screenname($) { return shift->{screenname}; }
sub is_on($) { return shift->{is_on}; }

=item profile

Returns your current profile.

=cut

sub profile($) { return shift->{profile}; }

=pod

=item set_away (MESSAGE)

Sets the user's 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.  See also L<"get_away">.

=cut

sub set_away($$) {
	my($self, $awaymsg) = @_;
	return must_be_on($self) unless $self->{is_on};

	# Because we use !defined(awaymsg) to indicate
	# that we just want to set the profile, force
	# it to be defined.
	$awaymsg = "" unless defined($awaymsg);

	shift->set_info(undef, $awaymsg);
}

=pod

=item set_extended_status (MESSAGE)

Sets the user's extended status message.  This requires the
C object to have been created with the C
capability.  Currently, the only clients which support extended
status messages are Net::OSCAR, Gaim, and iChat.  If the message
is undef or the empty string, the user's extended status
message will be cleared.  Use L<"get_info"> to get another
user's extended status.

=cut

sub set_extended_status($$) {
	my($self, $status) = @_;
	croak "This client does not support extended status messages." unless $self->{capabilities}->{extended_status};

	$status ||= "";

	$self->log_print(OSCAR_DBG_NOTICE, "Setting extended status.");
	$self->svcdo(CONNTYPE_BOS, protobit => "set_extended_status", protodata => {
		status_message => {message => $status}
	});
}

=pod

=item set_info (PROFILE)

Sets the user's profile.  Call L<"commit_buddylist"> to have
the new profile saved into the buddylist, so that it will be
set the next time the screenname is signed on.  (This is a
Net::OSCAR-specific feature, so other clients will not pick
up the profile from the buddylist.)

Note that Net::OSCAR stores the user's profile in the server-side buddylist, so
if L<"commit_buddylist"> is called after setting the profile with this method,
the user will automatically get that same profile set whenever they sign on
through Net::OSCAR.  See the file C, included with the C distribution,
for details of how we're storing this data.

Use L<"get_info"> to retrieve another user's profile.

=cut

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

	return must_be_on($self) unless $self->{services}->{0+CONNTYPE_BOS};
	$self->log_print(OSCAR_DBG_NOTICE, "Setting user information.");

	my %protodata;
	$protodata{capabilities} = $self->capabilities();

	if(defined($profile)) {
		$protodata{profile_mimetype} = 'text/aolrtf; charset="us-ascii"';
		$protodata{profile} = $profile;
		$self->{profile} = $profile;
	}

	if(defined($awaymsg)) {
		$protodata{awaymsg_mimetype} = 'text/aolrtf; charset="us-ascii"';
		$protodata{awaymsg} = $awaymsg;
	}

	$self->svcdo(CONNTYPE_BOS, protobit => "set_info", protodata => \%protodata);
}

=pod

=item set_icon (ICONDATA)

Sets the user's buddy icon.  The C object must have been created
with the C capability to use this.  C must be less
than 4kb, should be 48x48 pixels, and should be BMP, GIF, or JPEG image data.
You must call L for this change to take effect.  If
C is the empty string, the user's buddy icon will be removed.

When reading the icon data from a file, make sure to call C
on the file handle.

Note that if the user's buddy icon was previously set with Net::OSCAR,
enough data will be stored in the server-side buddylist that this will
not have to be called every time the user signs on.  However, other clients
do not store the extra data in the buddylist, so if the user previously
set a buddy icon with a non-Net::OSCAR-based client, this method will
need to be called in order for the user's buddy icon to be set properly.

See the file C, included with the C distribution,
for details of how we're storing this data.

You should receive a L callback in response to this
method.

Use L<"get_icon"> to retrieve another user's icon.

=cut

sub set_icon($$) {
	my($self, $icon) = @_;

	carp "This client does not support buddy icons!" unless $self->{capabilities}->{buddy_icons};

	if($icon) {
		$self->{icon} = $icon;
		$self->{icon_md5sum_old} = $self->{icon_md5sum} || "";
		$self->{icon_md5sum} = pack("n", 0x10) . md5($icon);
		$self->{icon_checksum} = $self->icon_checksum($icon);
		$self->{icon_timestamp} = time;
		$self->{icon_length} = length($icon);
	} else {
		delete $self->{icon};
		delete $self->{icon_md5sum};
		delete $self->{icon_checksum};
		delete $self->{icon_timestamp};
		delete $self->{icon_length};
	}
}


=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}->{0+ADMIN_TYPE_PASSWORD_CHANGE}) {
		$self->callback_admin_error(ADMIN_TYPE_PASSWORD_CHANGE, ADMIN_ERROR_REQPENDING);
		return;
	} else {
		$self->{adminreq}->{0+ADMIN_TYPE_PASSWORD_CHANGE}++;
	}

	$self->svcdo(CONNTYPE_ADMIN, protobit => "change_account_info", protodata => {
		newpass => $newpass,
		oldpass => $currpass
	});
}

=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 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}->{0+ADMIN_TYPE_ACCOUNT_CONFIRM}) {
		$self->callback_admin_error(ADMIN_TYPE_ACCOUNT_CONFIRM, ADMIN_ERROR_REQPENDING);
		return;
	} else {
		$self->{adminreq}->{0+ADMIN_TYPE_ACCOUNT_CONFIRM}++;
	}

	$self->svcdo(CONNTYPE_ADMIN, protobit => "confirm_account_request");
}

=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}->{0+ADMIN_TYPE_EMAIL_CHANGE}) {
		$self->callback_admin_error(ADMIN_TYPE_EMAIL_CHANGE, ADMIN_ERROR_REQPENDING);
		return;
	} else {
		$self->{adminreq}->{0+ADMIN_TYPE_EMAIL_CHANGE}++;
	}

	$self->svcdo(CONNTYPE_ADMIN, protobit => "change_account_info", protodata => {
		new_email => $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}->{0+ADMIN_TYPE_SCREENNAME_FORMAT}) {
		$self->callback_admin_error(ADMIN_TYPE_SCREENNAME_FORMAT, ADMIN_ERROR_REQPENDING);
		return;
	} else {
		$self->{adminreq}->{0+ADMIN_TYPE_SCREENNAME_FORMAT}++;
	}

	$self->svcdo(CONNTYPE_ADMIN, protobit => "change_account_info", protodata => {
		new_screenname => $newname
	});
}

=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->svcdo(CONNTYPE_BOS, protobit => "set_idle", protodata => {duration => $time});
}

=pod

=back

=head3 CALLBACKS

=over 4

=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 for more info.

=item buddy_icon_uploaded (OSCAR)

This is called when the user's buddy icon is successfully uploaded to the server.

=item stealth_changed (OSCAR, NEW_STEALTH_STATE)

This is called when the user's stealth state changes.  See L<"is_stealth"> and L<"set_stealth">
for information on stealth.

=item extended_status (OSCAR, STATUS)

Called when the user's extended status changes.  This will normally
be sent in response to a successful L call.

=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.

=back

=head2 FILE TRANSFER AND DIRECT CONNECTIONS

=over 4

=item file_send SCREENNAME MESSAGE FILEREFS

C can be undef to have Net::OSCAR read the file,
a file handle, or the data to send.

=cut

sub file_send($$@) {
	my($self, $screenname, $message, @filerefs) = @_;

	my $connection = $self->addconn(conntype => CONNTYPE_DIRECT_IN);
	my($port) = sockaddr_in(getsockname($connection->{socket}));

	my $size = 0;
	$size += length($_->{data}) foreach @filerefs;

	my %svcdata = (
		file_count_status => (@filerefs > 1 ? 2 : 1),
		file_count => scalar(@filerefs),
		size => $size,
		files => [map {$_->{name}} @filerefs]
	);

	my $cookie = randchars(8);
	my($ip) = unpack("N", inet_aton($self->{services}->{CONNTYPE_BOS()}->local_ip()));
	my %protodata = (
		capability => OSCAR_CAPS()->{filexfer}->{value},
		charset => "us-ascii",
		cookie => $cookie,
		invitation_msg => $message,
		language => 101,
		push_pull => 1,
		status => "propose",
		client_1_ip => $ip,
		client_2_ip => $ip,
		port => $port,
		proxy_ip => unpack("N", inet_aton("63.87.248.248")), # TODO: What's this really supposed to be?
		svcdata_charset => "us-ascii",
		svcdata => protoparse($self, "file_transfer_rendezvous_data")->pack(%svcdata)
	);

	my($req_id) = $self->send_message($screenname, 2, pack("nn", 3, 0) . protoparse($self, "rendezvous_IM")->pack(%protodata), 0, $cookie);

	$self->{rv_proposals}->{$cookie} = $connection->{rv} = {
		cookie => $cookie,
		sender => $self->{screenname},
		recipient => $screenname,
		peer => $screenname,
		type => "filexfer",
		connection => $connection,
		ft_state => "listening",
		direction => "send",
		accepted => 0,
		filenames => [map {$_->{name}} @filerefs],
		data => [map {$_->{data}} @filerefs],
		using_proxy => 0,
		tried_proxy => 0,
		tried_listen => 1,
		tried_connect => 0,
		total_size => $size,
		file_count => scalar(@filerefs)
	};

	return ($req_id, $cookie);
}

=pod

=back

=head2 EVENT PROCESSING

=head3 METHODS

=over 4

=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 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 defined($timeout) and $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;
		} elsif(!$connection->{connected} or $connection->{outbuff}) {
			vec($win, fileno $connection->{socket}, 1) = 1;
		}
	}
	$ein = $rin | $win;

	return unless $ein;
	my $nfound = select($rin, $win, $ein, $timeout);
	$self->process_connections(\$rin, \$win, \$ein) if $nfound and $nfound != -1;
}

=pod

=item process_connections (READERSREF, WRITERSREF, ERRORSREF)

Use this method when you want to implement your own C
statement for event processing instead of using C's
L 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 objects or which are
C objects from a different C
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 objects or
use with a C-based event loop that you are also
using for other purposes.

See the L method for a way to get the necessary
bit vectors to use in your C.

=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;
			$connection->disconnect();
		} else {
			$connection->process_one($read, $write);
		}
	}
}

=pod

=back

=head3 CALLBACKS

=over 4

=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 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 is a C object.

Users of this callback may also be interested in the L<"get_filehandle">
method of C.

=back

=head2 CHATS

=head3 METHODS

=over 4

=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;

	my $reqid = (8<<16) | (unpack("n", randchars(2)))[0];
	$self->{chats}->{pack("N", $reqid)} = $name;
	$self->svcdo(CONNTYPE_CHATNAV, reqid => $reqid, protobit => "chat_navigator_room_create", protodata => {
		exchange => $exchange,
		name => $name
	});
}

=pod

=item chat_accept (CHATURL)

Use this to accept an invitation to join a chatroom.

=item chat_decline (CHATURL)

Use this to decline an invitation to join a chatroom.

=cut

sub chat_accept($$) {
	my($self, $url) = @_;
	return must_be_on($self) unless $self->{is_on};

	$self->log_print(OSCAR_DBG_NOTICE, "Accepting chat invite for $url.");
	my($rv) = grep { $_->{chat_url} eq $url } values %{$self->{rv_proposals}};
	return unless $rv;

	$self->svcdo(CONNTYPE_CHATNAV, protobit => "chat_invitation_accept", protodata => {
		exchange => $rv->{exchange},
		url => $url
	});


	my $reqid = pack("n", 4);
	$reqid .= randchars(2);
	($reqid) = unpack("N", $reqid);

	$self->{chats}->{$reqid} = $rv;
	$self->svcdo(CONNTYPE_BOS, protobit => "service_request", reqid => $reqid, protodata => {
		type => CONNTYPE_CHAT,
		chat => {
			exchange => $rv->{exchange},
			url => $url
		}
	});
}

sub chat_decline($$) {
	my($self, $url) = @_;
	return must_be_on($self) unless $self->{is_on};

	$self->log_print(OSCAR_DBG_NOTICE, "Declining chat invite for $url.");
	my($rv) = grep { $_->{chat_url} eq $url } values %{$self->{rv_proposals}};
	return unless $rv;

	$self->svcdo(CONNTYPE_BOS, protobit => "chat_invitation_decline", protodata => {
		cookie => $rv->{cookie},
		screenname => $rv->{sender},
	});

	delete $self->{rv_proposals}->{$rv->{cookie}};
}

=pod

=back

=head3 CALLBACKS

=over 4

=item chat_buddy_in (OSCAR, SCREENNAME, CHAT, BUDDY DATA)

SCREENNAME has entered CHAT.  BUDDY DATA is the same as that returned by
the L method.

=item chat_buddy_out (OSCAR, SCREENNAME, CHAT)

Called when someone leaves a chatroom.

=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.

=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 object.  CHATURL can
be passed to the L method to accept the invitation.

=item chat_joined (OSCAR, CHATNAME, CHAT)

Called when you enter a chatroom.  CHAT is the C
object for the chatroom.

=item chat_closed (OSCAR, CHAT, ERROR)

Your connection to CHAT (a C object) was severed due to ERROR.

=back

=head2 RATE LIMITS

See L<"RATE LIMIT OVERVIEW"> for more information on rate limits.

=head3 METHODS

=over 4

=item rate_level (OSCAR, METHODNAME[, CHAT])

Returns the rate level (one of C, C, C, C)
which the OSCAR session is currently at for the C (or C) method named
C right now.  This only makes sense for methods which send information to the OSCAR
server, such as C, but if you pass in a method name which doesn't make sense (or isn't
actually a C method, or which isn't rate-limited), we'll gladly an empty list.  B
not available if your application is using L<"OSCAR_RATE_MANAGE_NONE">.>

If C is C, you should also pass the C
object to get rate information on (as the C parameter.)

=cut

sub _rate_level($$$) {
	my($oscar, $level, $levels) = @_;

	if($level <= $levels->{disconnect}) {
		return RATE_DISCONNECT;
	} elsif($level <= $levels->{limit}) {
		return RATE_LIMIT;
	} elsif($level <= $levels->{alert}) {
		return RATE_ALERT;
	} else {
		return RATE_CLEAR;
	}
}

sub _rate_lookup($$;$) {
	my($oscar, $method, $chat) = @_;
	croak "Rate methods not supported when using OSCAR_RATE_MANAGE_NONE!" if $oscar->{rate_manage_mode} == OSCAR_RATE_MANAGE_NONE;

	print "rate_lookup $method\n";
	my $key = $Net::OSCAR::MethodInfo::methods{$method} or return;
	print "\tFound key\n";
	my $conn = $chat || $oscar->connection_for_family(unpack("n", $key));
	print "\tFound connection\n";
	my $class = $conn->{rate_limits}->{classmap}->{$key} or return;
	print "\tFound class\n";
	return $conn->{rate_limits}->{$class};
}

sub rate_level($$;$) {
	my($oscar, $method, $chat) = @_;
	my $rinfo = $oscar->_rate_lookup($method, $chat) or return;

	return $oscar->_rate_level($rinfo->{current_state}, $rinfo->{levels});
}

=pod

=item rate_limits (OSCAR, METHODNAME[, CHAT])

Similar to L<"rate_level">.  This returns the boundaries of the different rate level
categories for the given method name, in the form of a hash with the following keys
(this won't make sense if you don't know how the current level is calculated; see below):

=over 4

=item window_size

=item levels

A hashref with keys for each of the levels.  Each key is the name of a level,
and the value for that key is the threshold for that level.

=over 4

=item clear

=item alert

=item limit

=item disconnect

=back

=item last_time

The time at which the last command to affect this rate level was sent.

=item current_state

The session's current rate level.

=back

Every time a command is sent to the OSCAR server, the level is recalculated according to the formula
(from Alexandr Shutko's OSCAR documentation, L:

	NewLevel = (Window - 1)/Window * OldLevel + 1/Window * CurrentTimeDiff

C is the difference between the current system time and C.

=cut

sub rate_limits($$;$) {
	my($oscar, $method, $chat) = @_;
	return $oscar->_rate_lookup($method, $chat);
}

=pod

=item would_make_rate_level (OSCAR, METHODNAME[, CHAT])

Returns the rate level which your session would be at if C were sent right now.
See L<"rate_level"> for more information.

=cut

sub _compute_rate($$) {
	my($oscar, $rinfo) = @_;

	my $level = $rinfo->{current_state};
	my $window = $rinfo->{window_size};
	my $timediff = (millitime() - $rinfo->{time_offset}) - $rinfo->{last_time};
	return ($window - 1)/$window * $level + 1/$window * $timediff;
}

sub would_make_rate_level($$;$) {
	my($oscar, $method, $chat) = @_;
	my $rinfo = $oscar->_rate_lookup($method, $chat) or return;

	return $oscar->_rate_level($oscar->_compute_rate($rinfo), $rinfo->{levels});
}

=pod

=back

=head3 CALLBACKS

=over 4

=item rate_alert (OSCAR, LEVEL, CLEAR, WINDOW, WORRISOME, VIRTUAL)

This is called when you are sending commands to OSCAR too quickly.

C is one of C, C, C, or C from the C
package (they are imported into your namespace if you import C with the C<:standard>
parameter.)  C means that you're okay.  C means you should slow down.  C
means that the server is ignoring messages from you until you slow down.  C means you're
about to be disconnected.

C and C tell you the maximum speed you can send in order to maintain C standing.
You must send no more than C commands in C milliseconds.  If you just want to keep it
simple, you can just not send any commands for C milliseconds and you'll be fine.

C is nonzero if C 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.

A C rate limit is one which your application would have incurred,
but you're using L, so we
stopped something from being sent out.

=back

=head2 MISCELLANEOUS

=head3 METHODS

=over 4

=item timeout ([NEW TIMEOUT])

Gets or sets the timeout value used by the L method.
The default timeout is 0.01 seconds.

=cut

sub timeout($;$) {
	my($self, $timeout) = @_;
	return $self->{timeout} unless $timeout;
	$self->{timeout} = $timeout;
}

=pod

=item loglevel ([LOGLEVEL[, SCREENNAME DEBUG]])

Gets or sets the level of logging verbosity.  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 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 @_;
}

=pod

=item auth_response (MD5_DIGEST[, PASS_IS_HASHED])

Provide a response to an authentication challenge - see the L<"auth_challenge">
callback for details.

=cut

sub auth_response($$$) {
	my($self, $digest, $pass_is_hashed) = @_;

	if($pass_is_hashed) {
		$self->{pass_is_hashed} = 1;
	} else {
		$self->{pass_is_hashed} = 0;
	}

	$self->log_print(OSCAR_DBG_SIGNON, "Got authentication response - proceeding with signon");
	$self->{auth_response} = $digest;
	my %data = signon_tlv($self);
	$self->svcdo(CONNTYPE_BOS, protobit => "signon", protodata => {%data});
}

=pod

=item clone

Clones the object.  This creates a new C 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 objects in order to allow you to set those parameters once
and then call the L method on the object returned by clone.

=cut

sub clone($) {
	my $self = shift;
	my $clone = $self->new(@{$self->{_parameters}}); 	# 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};

	foreach my $c (@{$clone->{connections}}) {
		$c->{buffer} = \"";
	}

	return $clone;
}

=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 and C functions will be
C objects, so you they will automagically be compared
without regards to case and whitespace.

=cut

sub buddyhash($) { bltie; }

=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
object.

=cut

sub findconn($$) {
	my($self, $target) = @_;
	my($conn) = grep { fileno($_->{socket}) == $target } @{$self->{connections}};
	return $conn;
}

=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 $self = shift;
	my($rin, $win) = ('', '');

	foreach my $connection(@{$self->{connections}}) {
		next unless $connection->{socket};
		if($connection->{connected}) {
			my $n = fileno($connection->{socket});
			vec($rin, $n, 1) = 1;
		}
		if(!$connection->{connected} or $connection->{outbuff}) {
			my $n = fileno($connection->{socket});
			vec($win, $n, 1) = 1;
		}
	}
	return ($rin, $win);
}

=item icon_checksum (ICONDATA)

Returns a checksum of the buddy icon.  Use this in conjunction with the
C buddy info key to cache buddy icons.

=cut

sub icon_checksum($$) {
	my($self, $icon) = @_;

	my $sum = 0;
	my $i = 0;
	for($i = 0; $i+1 < length($icon); $i += 2) {
		$sum += (ord(substr($icon, $i+1, 1)) << 8) + ord(substr($icon, $i, 1));
	}

	$sum += ord(substr($icon, $i, 1)) if $i < length($icon);

	$sum = (($sum & 0xFFFF0000) >> 16) + ($sum & 0x0000FFFF);

	return $sum;
}

=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 list.
If you wish to set application-specific data, you should reserve a high-order
byte for your application by emailing C.
This data is stored in your server-side buddylist and so will be persistent,
even across machines.

If C is present, a hashref for accessing data specific to that group
is returned.

If C 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) = @_;

	# We don't track changes to the contents of these hashes,
	# so mark as dirty and let BLI figure out whether anything really changed.
	if($group and $buddy) {
		my $bud = $self->{buddies}->{$group}->{members}->{$buddy};
		$bud->{__BLI_DIRTY} = 1;
		return $bud->{data};
	} elsif($group) {
		my $grp = $self->{buddies}->{$group};
		$grp->{__BLI_DIRTY} = 1;
		return $grp->{data};
	} else {
		return $self->{appdata};
	}
}

=pod

=item chat_invite (CHAT, MESSAGE, WHO)

Deprecated.  Provided for compatibility with C.
Use the appropriate method of the C 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.
Use the appropriate method of the C object
instead.

=item chat_send (CHAT, MESSAGE)

Deprecated.  Provided for compatibility with C.
Use the appropriate method of the C object
instead.

=cut

sub chat_leave($$) { $_[1]->part(); }
sub chat_send($$$) { $_[1]->chat_send($_[2]); }

=pod

=back

=head3 CALLBACKS

=over 4

=item auth_challenge (OSCAR, CHALLENGE, HASHSTR)

B: AOL Instant Messenger has changed their encryption
mechanisms; instead of using the password in the hash, you B now use
the MD5 hash of the password.  This allows your application to save the user's
password in hashed form instead of plaintext if you're saving passwords.
You must pass an extra parameter to C indicating that you are
using the new encryption scheme.  See below for an example.

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 . MD5(password) . HASHSTR.  For instance, using the
L module:

	my($oscar, $challenge, $hashstr) = @_;
	my $md5 = Digest::MD5->new;
	$md5->add($challenge);
	$md5->add(md5("password"));
	$md5->add($hashstr);
	$oscar->auth_response($md5->digest, 1);

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 of level C is called.  The levels are,
in order of increasing importance:

=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, and precious little else.

=item OSCAR_DBG_SIGNON

Like C, 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.)

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.

=back

=head2 ERROR HANDLING

=head3 CALLBACKS

=over 4

=item error (OSCAR, CONNECTION, ERROR, DESCRIPTION, FATAL)

Called when any sort of error occurs (except see L below and
L in L.)

C is the particular connection which generated the error - the C method of
C may be useful, as may be getting C<$connection-E{description}>.
C is a nicely formatted description of the error.  C is an error number.

If C is non-zero, the error was fatal and the connection to OSCAR has been
closed.

=item snac_unknown (OSCAR, CONNECTION, SNAC, DATA)

Called when Net::OSCAR receives a message from the OSCAR server which
it doesn't known how to handle.  The default handler for this callback
will print out the unknown SNAC.

C is the C object on which the unknkown
message was received.  C is a hashref with keys such as C, C, C, and
C.

=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_buddylist_error(@) { do_callback("buddylist_error", @_); }
sub callback_buddylist_ok(@) { do_callback("buddylist_ok", @_); }
sub callback_buddylist_changed(@) { do_callback("buddylist_changed", @_); }
sub callback_admin_error(@) { do_callback("admin_error", @_); }
sub callback_admin_ok(@) { do_callback("admin_ok", @_); }
sub callback_new_buddy_icon(@) { do_callback("new_buddy_icon", @_); }
sub callback_buddy_icon_uploaded(@) { do_callback("buddy_icon_uploaded", @_); }
sub callback_buddy_icon_downloaded(@) { do_callback("buddy_icon_downloaded", @_); }
sub callback_rate_alert(@) { do_callback("rate_alert", @_); }
sub callback_signon_done(@) { do_callback("signon_done", @_); }
sub callback_log(@) { do_callback("log", @_); }
sub callback_typing_status(@) { do_callback("typing_status", @_); }
sub callback_extended_status(@) { do_callback("extended_status", @_); }
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 callback_stealth_changed(@) { do_callback("stealth_changed", @_); }
sub callback_snac_unknown(@) { do_callback("snac_unknown", @_); }
sub callback_rendezvous_reject(@) { do_callback("rendezvous_reject", @_); }
sub callback_rendezvous_accept(@) { do_callback("rendezvous_accept", @_); }
sub callback_buddylist_in(@) { do_callback("buddylist_in", @_); }

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_buddylist_error($\&) { set_callback("buddylist_error", @_); }
sub set_callback_buddylist_ok($\&) { set_callback("buddylist_ok", @_); }
sub set_callback_buddylist_changed($\&) { set_callback("buddylist_changed", @_); }
sub set_callback_admin_error($\&) { set_callback("admin_error", @_); }
sub set_callback_admin_ok($\&) { set_callback("admin_ok", @_); }
sub set_callback_new_buddy_icon($\&) {
	croak "This client does not support buddy icons." unless $_[0]->{capabilities}->{buddy_icons};
	set_callback("new_buddy_icon", @_);
}
sub set_callback_buddy_icon_uploaded($\&) {
	croak "This client does not support buddy icons." unless $_[0]->{capabilities}->{buddy_icons};
	set_callback("buddy_icon_uploaded", @_);
}
sub set_callback_buddy_icon_downloaded($\&) {
	croak "This client does not support buddy icons." unless $_[0]->{capabilities}->{buddy_icons};
	set_callback("buddy_icon_downloaded", @_);
}
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_typing_status($\&) {
	croak "This client does not support typing status notification." unless $_[0]->{capabilities}->{typing_status};
	set_callback("typing_status", @_);
}
sub set_callback_extended_status($\&) {
	croak "This client does not support extended status messages." unless $_[0]->{capabilities}->{extended_status};
	set_callback("extended_status", @_);
}
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", @_); }
sub set_callback_stealth_changed($\&) { set_callback("stealth_changed", @_); }
sub set_callback_snac_unknown($\&) { set_callback("snac_unknown", @_); }
sub set_callback_rendezvous_reject($\&) { set_callback("snac_rendezvous_reject", @_); }
sub set_callback_rendezvous_accept($\&) { set_callback("snac_rendezvous_accept", @_); }
sub set_callback_buddylist_in($\&) {
	croak "This client does not support buddy list transfer." unless $_[0]->{capabilities}->{buddy_list_transfer};
	set_callback("buddylist_in", @_);
}

=pod

=head1 CHAT CONNECTIONS

Aside from the methods listed here, there are a couple of methods of the
C object that are important for implementing chat
functionality.  C is a descendent of C.

=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 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 RATE LIMIT OVERVIEW

The OSCAR server has the ability to specify restrictions on the rate at which
the client, your application, can send it commands.  These constraints can be independently
set and tracked for different classes of command, so there might be one limit on how
fast you can send IMs and another on how fast you can request away messages.
If your application exceeds these limits, the OSCAR server may start ignoring it or
may even disconnect your session.

See also the reference section on L.

=head2 RATE MANAGEMENT MODES

C supports three different schemes for managing these limits.  Pass the
scheme you want to use as the value of the C key when you invoke the
L<"new"> method.

=head3 OSCAR_RATE_MANAGE_NONE

The default.  C will not keep track of what the limits are,
much less how close you're coming to reaching them.  If the OSCAR server complains
that you are sending too fast, your L<"rate_alert"> callback will be triggered.

=head3 OSCAR_RATE_MANAGE_AUTO

In this mode, C will prevent your application from exceeding the limits.
If you try to send a command which would cause the limits to be exceeded, your
command will be queued.  You will be notified when this happens via the L<"rate_alert">
callback.  B's
L.>

=head3 OSCAR_RATE_MANAGE_MANUAL

In this mode, C will track what the limits are and how close you're
coming to reaching them, but won't do anything about it.  Your application should use the
L<"rate_level">, L<"rate_limits">, and L<"would_make_rate_level"> methods to
control its own rate.

=head1 TIME-DELAYED EVENTS

=head1 CONSTANTS

The following constants are defined when C 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 OSCAR_RATE_MANAGE_NONE

=item OSCAR_RATE_MANAGE_AUTO

=item OSCAR_RATE_MANAGE_MANUAL

=item GROUPPERM_OSCAR

=item GROUPPERM_AOL

=item TYPINGSTATUS_STARTED

=item TYPINGSTATUS_TYPING

=item TYPINGSTATUS_FINISHED

=back

=head1 Net::AIM Compatibility

Here are the major differences between the C interface
and the C 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, but I can't think of any reason
why it would need to be used outside of the module internals.  C
provides the same functionality through the C class.

=item *

Different callbacks with different parameters.

=back

=head1 MISCELLANEOUS INFO

There are two programs included with the C distribution.
C is half a reference implementation of a C client
and half a tool for testing this library.  C is a tool designed
for analyzing the OSCAR protocol from libpcap-format packet captures, but
it isn't particularly well-maintained; the Ethereal sniffer does a good
job at this nowadays.

There is a class C.  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, 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, not C.

=item process_one (CAN_READ, CAN_WRITE, HAS_ERROR)

Call this when a C 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 instead of C.  The C and C 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 to non-zero.

=item session

Returns the C object associated with this C.

=back

=head1 USER INFORMATION

Methods which return information about a user, such as L<"buddy">, will return
the information in the form of a hash.  The keys of the hash are the following --
note that any of these may be absent.

=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 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 alias

A user-defined alias for the buddy.  See L<"set_buddy_alias">.
Note that this key will be present but undefined if there is no alias.

=item extended_status

The user's extended status message, if one is set, will be in this key.
This requires that you set the C capability when
creating the C object.

=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 mobile

The user is using a mobile device.

=item typing_status

The user is known to support typing status notification.  We only find this out if they send us an IM.

=item capabilities

The user's capabilities.  This is a reference to a hash whose keys are the user's capabilities, and
whose values are descriptions of their respective capabilities.

=item icon

The user's buddy icon, if available.

=item icon_checksum

The checksum time of the user's buddy icon, if available.  Use this, in conjunction with
the L method, to cache buddy icons.

=item icon_timestamp

The modification timestamp of the user's buddy icon, if available.

=item icon_length

The length of the user's buddy icon, if available.

=item membersince

Time that the user's account was created, in the same format as the C function.

=item onsince

Time that the user signed on to the service, in the same format as the C function.

=item idle_since

Time, in seconds since Jan 1st 1970, since which the user has been idle.  This will only
be present if the user is idle.  To figure out how long the user has been idle for,
subtract this value from C .

=item evil

Evil (warning) level for the user.

=back

Some keys; namely, C and C, may be available for people
who the user has communicated with but who are not on the user's buddylist.

=cut


=pod

=head1 ICQ-SPECIFIC INFORMATION

ICQ support isn't nearly as well-tested as AIM support, and ICQ-specific
features aren't being particularly actively developed.  Patches for ICQ-isms
are welcome.  The initial patch enabling us to sign on to ICQ was provided by Sam Wong.

=head2 ICQ METHODS

=over 4

=item get_icq_info (UIN)

Requests ICQ-specific information.  See also the L<"buddy_icq_info"> callback.

=cut

sub get_icq_info($$) {
	my($self, $uin) = @_;

	$self->svcdo(CONNTYPE_BOS, protobit => "ICQ_meta_request", protodata => {
		our_uin => $self->{screenname},
		type => 2000,
		seqno => ++$self->{bos}->{icq_seqno},
		typedata => protoparse($self, "ICQ_meta_info_request")->pack(uin => $uin)
	});
}

=pod

=back

=head2 ICQ CALLBACKS

=over 4

=item buddy_icq_info (OSCAR, UIN, ICQ DATA)

The result of a L<"get_icq_info"> call.  Data is a hashref with the following keys, the value
of each key is a either a hashref or undefined:

=over 4

=item basic

=over 4

=item nickname

=item firstname

=item lastname

=item email

=item gmt_offset

=item authorization

=item web_aware

=item direct_connect_permissions

=item publish_primary_email

=back

=item home

=over 4

=item city

=item state

=item phone_num

=item fax_num

=item address

=item cell_phone_num

=item zip_code

=item country_code

=back

=item office

=over 4

=item city

=item state

=item phone_num

=item fax_num

=item address

=item zip_code

=item country_code

=item company

=item department

=item position

=item occupation

=item office_website

=back

=item background

=over 4

=item age

=item gender

=item homepage

=item birth_year

=item birth_month

=item birth_day

=item spoken_languages

This key is a listref containing the langauges the user speaks.

=item origin_city

=item origin_state

=item origin_country

=item marital_status

=back

=item notes

This key is a simple scalar.

=item email_addresses

This key is a listref, each element of which is a hashref with the following keys:

=over 4

=item publish

=item address

=back

=item interests

This key is a listref, each element of which is a hashref with the following keys:

=over 4

=item category

=item interest

=back

=item past_affiliations

This key is a listref, each element of which is a hashref with the following keys:

=over 4

=item category

=item affiliation

=back

=item present_affiliations

As per above.

=item homepage

=over 4

=item category

=item keywords

=back

=back

=back

=cut

sub callback_buddy_icq_info(@) { do_callback("buddy_icq_info", @_); }
sub set_callback_buddy_icq_info($\&) { set_callback("buddy_icq_info", @_); }


=pod

=head1 HIGH-PERFORMANCE EVENT PROCESSING

A second way of doing event processing is designed to make it easy to integrate C into
an existing C-based event loop, especially one where you have many C objects.
Simply call the L<"process_connections"> method with references to the lists of readers, writers,
and errors given to you by C.  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 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 objects:

	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's L<"process_one"> method.
This method, in conjunction with C, probably offers the highest performance
in situations where you have a long-lived application which creates and destroys many
C 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 inside of the L<"connection_changed">
callback.  That part's simple.  The tricky bit is figuring out which
C'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 - the FDs can be retrieved by doing
Cget_filehandle)> inside of the L<"connection_changed"> -
and then calling C<@handles = $poll-Ehandles(POLLIN | POLLOUT | POLLERR | POLLHUP)>
and walking through the handles.

For optimum performance, use the L<"connection_changed"> callback.

=head1 HISTORY

=over 4

=item *

1.925, 2006-02-06

=over 4

=item *

Many buddylist performance enhancements and bug fixes.

=item *

Added support for receiving dynamic buddylist changes from the server
(C.)

=item *

Add support buddylist transfer (C.)

=item *

Miscellaneous performance and scalability enhancements.

=item *

Added experimental migration support.

=item *

Added advanced rate limit management API.

=item *

Added C server for testing.

=item *

Audited screennames exposed to application to verify that they are
C objects everywhere.

=item *

Began work on file transfer.

=item *

Connection status fix for compatibility with POE.

=back

=item *

1.907, 2004-09-22

=over 4

=item *

Fixed assert failure on certain invalid input ("Buddy Trikill" crash)

=back

=item *

1.906, 2004-08-28

=over 4

=item *

Reorganized documentation

=back

=item *

1.904, 2004-08-26

=over 4

=item *

Add $Net::OSCAR::XML::NO_XML_CACHE to prevent use of cached XML parse tree,
and skip tests if we can't load Test::More or XML::Parser.

=back

=item *

1.903, 2004-08-26

=over 4

=item *

Generate XML parse tree at module build time so that users don't need to have
XML::Parser and expat installed.

=back

=item *

1.902, 2004-08-26

=over 4

=item *

Fixes to buddy icon upload and chat invitation decline

=item *

Increase performance by doing lazy generation of certain debugging info

=back

=item *

1.901, 2004-08-24

=over 4

=item *

Lots of buddylist-handling bug fixes; should fix intermittent buddylist modification errors
and errors only seen when modifying certain screennames; Roy C. rocks.

=item *

We now require Perl 5.6.1.

=item *

Workaround for bug in Perl pre-5.8.4 which manifested as a "'basic OSCAR services' isn't numeric"
warning followed by the program freezing.

=item *

C and C methods added.

=item *

Fixed a potential memory leak which could impact programs which create many transient Net::OSCAR
objects.

=back

=item *

1.900, 2004-08-17

=over 4

=item *

Wrote new XML-based protocol back-end with reasonably comprehensive test-suite.
Numerous protocol changes; we now emulate AOL's version 5.5 client.

=item *

Rewrote snacsnatcher, an OSCAR protocol analysis tool

=item *

Reorganized documentation

=item *

ICQ meta-info support: get_icq_info method, buddy_icq_info callback

=item *

Stealth mode support: is_stealth and set_stealth methods, stealth_changed callback, stealth signon key

=item *

More flexible unknown SNAC handling: snac_unknown callback

=item *

Application can give Net::OSCAR the MD5-hashed password instead of the cleartext password
(pass_is_hashed signon key).  This is useful if your application is storing user passwords.

=item *

Inability to set blocking on Win32 is no longer fatal.  Silly platform.

=item *

Fixed chat functionality.

=back

=item *

1.11, 2004-02-13

=over 4

=item *

Fixed presence-related problems modifying some buddylists

=back

=item *

1.10, 2004-02-10

=over 4

=item *

Fixed idle time handling; user info hashes now have an 'idle_since' key,
which you should use instead of the old 'idle' key.  Subtract C
from C to get the length of time for which the user has been idle.

=item *

Fixed buddylist type 5 handling; this fixes problems modifying the buddylists
of recently-created screennames.

=back

=item *

1.01, 2004-01-06

=over 4

=item *

Fixed buddy ID generation (problems adding buddies)

=back

=item *

1.00, 2004-01-03

=over 4

=item *

Documented requirement to wait for buddylist_foo callback between calls to commit_buddylist

=item *

Fixed handling of idle time (zoyboy22)

=item *

More flexible signon method

=item *

Added buddy alias support

=item *

Buddy icon support

=item *

Typing notification support

=item *

mac.com screenname support

=item *

Support for communicating with ICQ users from AIM

=item *

iChat extended status message support

=item *

We now emulate AOL Instant Messenger for Windows 5.2

=item *

We now parse the capabilities of other users

=item *

Attempts at Win32 (non-cygwin) support

=back

=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 to C.

=item *

Corrected removal of buddylist entries and other buddylist-handling improvements

=item *

Improved rate handling - new C parameter to rate_alert callback

=item *

Removed remaining C from C

=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{0}-E{1}-E{2}-E{data}-E{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= 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-mail].

=head1 CREDITS

AOL, for creating the AOL Instant Messenger service, even though they aren't terribly helpful to
developers of third-party clients.

Apple Computer for help with mac.com support.

The users of IMIRC for being reasonably patient while this module was developed.  Ehttp://www.zevils.com/programs/imirc/E

Bill Atkins for typing status notification and mobile user support.  Ehttp://www.milkbone.org/E

Jayson Baker for some last-minute debugging help.

Roy Camp for loads of bug reports and ideas and helping with user support.

Rocco Caputo for helping to work out the hooks that let use be used with
POE.  Ehttp://poe.perl.org/E

Mark Doliner for help with remote buddylists.  Ehttp://kingant.net/libfaim/ReadThis.htmlE

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.  Ehttp://www.zigamorph.net/faim/protocol/E

The gaim team - the source to their libfaim client was also very helpful.  Ehttp://gaim.sourceforge.net/E

Nick Gray for sponsoring scalability work.

John "VBScript" for a lot of technical assistance, including the explanation of rates.

Jonathon Wodnicki for additional help with typing status notification.

Sam Wong [e-mail] for a patch implementing ICQ2000 support.

=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 and B are registered trademarks
owned by America Online, Inc.  The B mark is owned by America
Online, Inc.  B is a trademark and/or servicemark of ICQ.  C is not
endorsed by, or affiliated with, America Online, Inc or ICQ.  B and B
are registered trademarks of Apple Computer, Inc.  C is not endorsed by,
or affiliated with, Apple Computer, Inc or iChat.

=cut



### Private methods

sub addconn($@) {
	my $self = shift;
	my %data = @_;

	$data{session} = $self;
	weaken($data{session});

	my $connection;
	my $conntype = $data{conntype};
	$data{description} ||= $conntype;

	if($conntype == CONNTYPE_CHAT) {
		require Net::OSCAR::Connection::Chat;
		$connection = Net::OSCAR::Connection::Chat->new(%data);
	} elsif($conntype == CONNTYPE_DIRECT_IN) {
		require Net::OSCAR::Connection::Direct;
		$connection = Net::OSCAR::Connection::Direct->new(%data);
		$connection->listen();
	} elsif($conntype == CONNTYPE_DIRECT_OUT) {
		require Net::OSCAR::Connection::Direct;
		$connection = Net::OSCAR::Connection::Direct->new(%data);
	} elsif($conntype == CONNTYPE_SERVER) {
		require Net::OSCAR::Connection::Server;
		$connection = Net::OSCAR::Connection::Server->new(%data);
	} else {
		$connection = Net::OSCAR::Connection->new(%data);
		# We set the connection to 1 to indicate that it is in progress but not ready for SNAC-sending yet.
		$self->{services}->{$conntype} = 1 unless $conntype == CONNTYPE_CHAT;
	}

	if($conntype == CONNTYPE_BOS) {
		$self->{services}->{$conntype} = $connection;
	}

	push @{$self->{connections}}, $connection;
	$self->callback_connection_changed($connection, $connection->{state});
	return $connection;
}

sub delconn($$) {
	my($self, $connection) = @_;

	return unless $self->{connections};
	$self->callback_connection_changed($connection, "deleted") if $connection->{socket};
	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 {
				if($connection->{socket} and $connection->{conntype} != CONNTYPE_DIRECT_IN and $connection->{conntype} != CONNTYPE_DIRECT_OUT) {
					$connection->flap_put("", FLAP_CHAN_CLOSE);
				}
				close $connection->{socket} if $connection->{socket};
			};
		} else {
			delete $self->{services}->{$connection->{conntype}} unless $connection->{conntype} == CONNTYPE_CHAT;

			if($connection->{conntype} == CONNTYPE_BOS or ($connection->{conntype} == CONNTYPE_LOGIN and !$connection->{closing})) {
				delete $connection->{socket};
				return $self->crapout($connection, "Lost connection to BOS");
			} elsif($connection->{conntype} == CONNTYPE_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");
			} else {
				$self->log_print(OSCAR_DBG_NOTICE, "Closing connection ", $connection->{conntype});
			}
		}
		delete $connection->{socket};
		return 1;
	}
	return 0;
}

sub DESTROY {
	my $self = shift;
	return if $Net::OSCAR::NODESTROY;

	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};
	}
}

sub findgroup($$) {
	my($self, $groupid) = @_;
	my($group, $currgroup, $currid);

	my $thegroup = undef;

	while(($group, $currgroup) = each(%{$self->{buddies}})) {
		next if $group eq "__BLI_DIRTY";
		next unless exists($currgroup->{groupid}) and $groupid == $currgroup->{groupid};
		next if $currgroup->{__BLI_DELETED};
		$thegroup = $group;
		hash_iter_reset(\%{$self->{buddies}}); # Reset the iterator
		last;
	}
	return $thegroup;
}

sub findbuddy_byid($$$) {
	my($self, $buddies, $bid) = @_;

	while(my($buddy, $value) = each(%$buddies)) {
		if($value->{buddyid} == $bid and !$value->{__BLI_DELETED}) {
			hash_iter_reset(\%$buddies); # reset the iterator
			return $buddy;
		}
	}
	return undef;
}

sub newid($;$) {
	my($self, $group) = @_;
	my $id = 4;
	my %ids = ();

	if($group) {
		%ids = map { $_->{buddyid} => 1 } values %$group;
		do { ++$id; } while($ids{$id}) or $id < 4;
	} else {
		do { $id = ++$self->{nextid}->{__GROUPID__}; } while($self->findgroup($id));
	}
	return $id;
}

sub capabilities($) {
	my $self = shift;

	my @caps;

	push @caps, OSCAR_CAPS()->{chat}->{value}, OSCAR_CAPS()->{interoperate}->{value};
	push @caps, OSCAR_CAPS()->{extstatus}->{value} if $self->{capabilities}->{extended_status};
	push @caps, OSCAR_CAPS()->{buddyicon}->{value} if $self->{capabilities}->{buddy_icons};
	push @caps, OSCAR_CAPS()->{filexfer}->{value} if $self->{capabilities}->{file_transfer};
	push @caps, OSCAR_CAPS()->{fileshare}->{value} if $self->{capabilities}->{file_sharing};
	push @caps, OSCAR_CAPS()->{sendlist}->{value} if $self->{capabilities}->{buddy_list_transfer};

	return \@caps;
}

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};

	if($group eq "__BLI_DIRTY") {
		send_error($self, $self->{bos}, "Invalid group name", "__BLI_DIRTY is a reserved group name.", 0);
		return;
	}

	@buddies = ($group) if $what == MODBL_WHAT_GROUP;

	if($what == MODBL_WHAT_GROUP and $action == MODBL_ACTION_ADD) {
		return if exists $self->{buddies}->{$group} and !$self->{buddies}->{$group}->{__BLI_DELETED};

		$self->{buddies}->{__BLI_DIRTY} = 1;

		# Maybe group was deleted and then recreated
		if(exists $self->{buddies}->{$group}) {
			my $grp = $self->{buddies}->{$group};
			$grp->{__BLI_DIRTY} = 1;
			$grp->{__BLI_DELETED} = 0;
			$grp->{data} = tlv();
			$_->{__BLI_DELETED} = 1 foreach values %{$grp->{members}};
		} else {
			$self->{buddies}->{$group} = {
				groupid => $self->newid(),
				members => bltie(),
				data => tlv(),
				__BLI_DIRTY => 1,
				__BLI_DELETED => 0,
			};
		}
	} elsif($what == MODBL_WHAT_GROUP and $action == MODBL_ACTION_DEL) {
		return unless exists $self->{buddies}->{$group};
		$self->{buddies}->{__BLI_DIRTY} = 1;
		$self->{buddies}->{$group}->{__BLI_DELETED} = 1;
	} 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} and
			not $self->{buddies}->{$group}->{__BLI_DELETED};

		my $grp = $self->{buddies}->{$group};
		@buddies = grep {
			not (
				exists $grp->{members}->{$_} and
				not $grp->{members}->{$_}->{__BLI_DELETED}
			)
		} @buddies;
		return unless @buddies;

		$grp->{__BLI_DIRTY} = 1;

		foreach my $buddy(@buddies) {
			# Buddy may have been deleted and recreated
			if(exists($grp->{members}->{$buddy})) {
				my $bud = $grp->{members}->{$buddy};
				$bud->{__BLI_DIRTY} = 1;
				$bud->{__BLI_DELETED} = 0;
				$bud->{data} = tlv();
				$bud->{comment} = undef;
				$bud->{alias} = undef;
			} else {
				$grp->{members}->{$buddy} = {
					buddyid => $self->newid($grp->{members}),
					screenname => Net::OSCAR::Screenname->new($buddy),
					data => tlv(),
					online => 0,
					comment => undef,
					alias => undef,
					__BLI_DIRTY => 1,
					__BLI_DELETED => 0,
				};
			}
		}
	} elsif($what == MODBL_WHAT_BUDDY and $action == MODBL_ACTION_DEL) {
		return unless exists $self->{buddies}->{$group};

		my $grp = $self->{buddies}->{$group};
		@buddies = grep {
			exists $grp->{members}->{$_} and
			not $grp->{members}->{$_}->{__BLI_DELETED}
		} @buddies;
		return unless @buddies;

		$grp->{__BLI_DIRTY} = 1;

		foreach my $buddy(@buddies) {
			$grp->{members}->{$buddy}->{__BLI_DELETED} = 1;
		}
		$self->mod_buddylist(MODBL_ACTION_DEL, MODBL_WHAT_GROUP, $group) unless scalar
			grep { not $grp->{members}->{$_}->{__BLI_DELETED} }
			keys %{$grp->{members}};
	}
}

sub postprocess_userinfo($$) {
	my($self, $userinfo) = @_;

	Net::OSCAR::Screenname->new(\$userinfo->{screenname});

	if($userinfo->{idle}) {
		$userinfo->{idle} *= 60;
		$userinfo->{idle_since} = time() - $userinfo->{idle};
	}
	$userinfo->{evil} /= 10 if exists($userinfo->{evil});
	if(exists($userinfo->{flags})) {
		my $flags = $userinfo->{flags};
		$userinfo->{trial} = $flags & 0x1;
		$userinfo->{admin} = $flags & 0x2;
		$userinfo->{aol} = $flags & 0x4;
		$userinfo->{pay} = $flags & 0x8;
		$userinfo->{free} = $flags & 0x10;
		$userinfo->{away} = $flags & 0x20;
		$userinfo->{mobile} = $flags & 0x80;
	}

	if(exists($userinfo->{capabilities})) {
		my $capabilities = delete $userinfo->{capabilities};
		foreach my $capability (@$capabilities) {
			$self->log_print(OSCAR_DBG_DEBUG, "Got a capability.");
			if(OSCAR_CAPS_INVERSE()->{$capability}) {
				my $capname = OSCAR_CAPS_INVERSE()->{$capability};
				$self->log_print(OSCAR_DBG_DEBUG, "Got capability $capname.");
				$userinfo->{capabilities}->{$capname} = OSCAR_CAPS()->{$capname}->{description};
			} else {
				$self->log_print_cond(OSCAR_DBG_INFO, sub { "Unknown capability: ", hexdump($capability) });
			}
		}
	}

	if(exists($userinfo->{icon_md5sum})) {
		if(!exists($self->{userinfo}->{$userinfo->{screenname}})
		   or !exists($self->{userinfo}->{$userinfo->{screenname}}->{icon_md5sum})
		   or $self->{userinfo}->{$userinfo->{screenname}}->{icon_md5sum} ne $userinfo->{icon_md5sum}) {
			$self->callback_new_buddy_icon($userinfo->{screenname}, $userinfo);
		}
	}
}

sub send_message($$$$;$$) {
	my($self, $recipient, $channel, $body, $flags2, $cookie) = @_;
	$flags2 ||= 0;

	my $reqid = (8<<16) | (unpack("n", randchars(2)))[0];
	my %protodata = (
		cookie => $cookie ? $cookie : randchars(8),
		channel => $channel,
		screenname => $recipient,
		message_body => $body,
	);
	$self->svcdo(CONNTYPE_BOS, reqdata => $recipient, reqid => $reqid, protobit => "outgoing_IM", protodata => \%protodata, flags2 => $flags2);

	return ($reqid, $protodata{cookie});
}

sub rendezvous_revise($$;$) {
	my($self, $cookie, $ip) = @_;
	return unless exists($self->{rv_proposals}->{$cookie});
	my $proposal = $self->{rv_proposals}->{$cookie};

	if($proposal->{connection}) {
		$self->delconn($proposal->{connection});
		delete $proposal->{connection};
	}

	if(!$ip) {
		croak "OSCAR server FT proxy not yet supported!";
	}

	my $connection = $self->addconn(conntype => CONNTYPE_DIRECT_IN);
	my($port) = sockaddr_in(getsockname($connection->{socket}));

	my %protodata = (
		capability => OSCAR_CAPS()->{filexfer}->{value},
		cookie => $proposal->{cookie},
		status => "propose",
		client_1_ip => $self->{ip},
		client_2_ip => $self->{ip},
		port => $port,
	);
	$proposal->{connection} = $connection;
	$proposal->{ft_state} = "listening";
	$proposal->{accepted} = 0;
	$proposal->{tried_listen} = 1;

	my($req_id) = $self->send_message($proposal->{peer}, 2, protoparse($self, "rendezvous_IM")->pack(%protodata), 0, $cookie);
}

sub rendezvous_proxy_host($) {
	return "ars.oscar.aol.com";
}

sub rendezvous_negotiate($$) {
	my($self, $cookie) = @_;
	return unless exists($self->{rv_proposals}->{$cookie});
	my $proposal = $self->{rv_proposals}->{$cookie};

	if($proposal->{tried_connect} or !$proposal->{ip} or $proposal->{ip} eq "0.0.0.0" or $proposal->{ip} eq "255.255.255.255") {
		$self->log_print(OSCAR_DBG_DEBUG, "Negotiating rendezvous.");

		# If we haven't tried hosting the connection and it
		# doesn't look like we're behind NAT, or we have
		# a designated file transfer IP, try hosting.
		# Otherwise, use the proxy.
		#
		if(!$proposal->{tried_listen} and
		  $self->{ft_ip} or ($self->{ip} and $self->{bos}->local_ip eq $self->{ip})
		) {
			$self->log_print(OSCAR_DBG_DEBUG, "Hosting.");
			$self->rendezvous_revise($cookie, $self->{ft_ip} || $self->{ip});
			$proposal->{using_proxy} = 0;
			$proposal->{tried_listen} = 1;
			$proposal->{ft_state} = "listening";
			return;
		} elsif(!$proposal->{tried_proxy}) {
			$self->log_print(OSCAR_DBG_DEBUG, "Using proxy.");
			$proposal->{using_proxy} = 1;
			$proposal->{tried_proxy} = 1;
			$proposal->{ft_state} = "proxy_connect";
			$proposal->{ip} = $self->rendezvous_proxy_host();
		} else {
			$self->rendezvous_reject($cookie);
			$self->log_printf(OSCAR_DBG_WARN, "Couldn't figure out how to connect for file transfer (%s, %s).", $proposal->{ip}, $proposal->{proxy});
			return;
		}
	} else {
		$proposal->{using_proxy} = 0;
		$proposal->{tried_connect} = 1;
		$proposal->{ft_state} = "connecting";
	}

	return 1;
}

sub rendezvous_accept($$) {
	my($self, $cookie) = @_;
	return unless exists($self->{rv_proposals}->{$cookie});
	my $proposal = $self->{rv_proposals}->{$cookie};

	return unless $self->rendezvous_negotiate($cookie);

	$self->log_printf(OSCAR_DBG_INFO, "Establishing rendezvous connection to %s:%d", $proposal->{ip}, $proposal->{port});
	$proposal->{ip} .= ":" . $proposal->{port} if $proposal->{port};
	my $newconn = $self->addconn(
		conntype => CONNTYPE_DIRECT_OUT,
		peer => $proposal->{ip},
		description => "transfer of files: " . join(", ", @{$proposal->{filenames}}),
		rv => $proposal,
	);
	$proposal->{connection} = $newconn;
}

sub rendezvous_reject($$) {
	my($self, $cookie) = @_;

	return unless exists($self->{rv_proposals}->{$cookie});
	my $proposal = delete $self->{rv_proposals}->{$cookie};

	my %protodata;
	$protodata{status} = "cancel";
	$protodata{cookie} = $cookie;
	$protodata{capability} = OSCAR_CAPS()->{$proposal->{type}} ? OSCAR_CAPS()->{$proposal->{type}}->{value} : $proposal->{type};

	return $self->send_message($proposal->{sender}, 2, protoparse($self, "rendezvous_IM")->pack(%protodata));
}

sub svcdo($$%) {
	my($self, $service, %data) = @_;

	if($self->{services}->{$service} and ref($self->{services}->{$service})) {
		$self->{services}->{$service}->proto_send(%data);
	} else {
		push @{$self->{svcqueues}->{$service}}, \%data;
		$self->svcreq($service) unless $self->{services}->{$service};
	}
}

sub svcreq($$;@) {
        my($self, $svctype, @extradata) = @_;

        $self->log_print(OSCAR_DBG_INFO, "Sending service request for servicetype $svctype.");
        $self->svcdo(CONNTYPE_BOS, protobit => "service_request", protodata => {type => $svctype, @extradata});
}

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->{services}->{0+CONNTYPE_BOS}, 0, "You have not finished signing on.", 0);
}


sub server($%) {
	my $self = shift;
	my %data = @_;
	$self->{$_} = $data{$_} foreach keys %data;
	$self->addconn(conntype => CONNTYPE_SERVER);
}

sub connection_for_family($$) {
	my($self, $family) = @_;

	my $bos = $self->{services}->{0+CONNTYPE_BOS};
	if($bos->{families}->{$family}) {
		return $bos;
	}

	foreach my $connection (@{$self->{session}->{connections}}) {
		next unless $connection->{families}->{$family};
		$connection->log_print(OSCAR_DBG_WARN, "Found connection for unsupported SNAC.");
		return $connection;
	}

	return;
}

1;