package Net::OSCAR; $VERSION = '1.925'; $REVISION = '$Revision: 1.221 $'; =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 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 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($VERSION $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 =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-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 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.> 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}); } =cut =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-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 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 Ematthewg@zevils.comE. =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 Esam@uhome.netE 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;