source: perl/modules/AIM/lib/Net/OSCAR.pm @ 3dcccba

barnowl_perlaim
Last change on this file since 3dcccba was 7a1c90d, checked in by Geoffrey Thomas <geofft@mit.edu>, 13 years ago
Skeleton AIM module, and Net::OSCAR 1.925
  • Property mode set to 100644
File size: 116.0 KB
Line 
1package Net::OSCAR;
2
3$VERSION = '1.925';
4$REVISION = '$Revision: 1.221 $';
5
6=pod
7
8=head1 NAME
9
10Net::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!)
11
12=head1 SYNOPSIS
13
14        use Net::OSCAR qw(:standard);
15
16        sub im_in {
17                my($oscar, $sender, $message, $is_away) = @_;
18                print "[AWAY] " if $is_away;
19                print "$sender: $message\n";
20        }
21
22        $oscar = Net::OSCAR->new();
23        $oscar->set_callback_im_in(\&im_in);
24        $oscar->signon($screenname, $password);
25        while(1) {
26                $oscar->do_one_loop();
27                # Do stuff
28        }
29
30=head1 INSTALLATION
31
32=head2 HOW TO INSTALL
33
34        perl Build.PL
35        perl Build
36        perl Build test
37        perl Build install
38
39See C<perldoc Module::Build> for details.
40Note that this requires that you have the perl module Module::Build installed.
41If you don't, the traditional C<perl Makefile.PL ; make ; make test ; make install>
42should still work.
43
44=head2 DEPENDENCIES
45
46This modules requires C<Digest::MD5> and C<Scalar::Util>.  C<Test::More> is needed
47to run the test suite, and C<XML::Parser> is needed to generate the XML parse tree
48which is shipped with released versions.
49
50=head1 INTRODUCTION
51
52=head2 ABSTRACT
53
54C<Net::OSCAR> implements the OSCAR protocol which is used by AOL's AOL Instant
55Messenger service.  To use the module, you create a C<Net::OSCAR> object,
56register some functions as handlers for various events by using the module's
57callback mechanism, and then continually make calls to the module's event
58processing methods.
59
60You probably want to use the C<:standard> parameter when importing this module
61in order to have a few important constants added to your namespace.  See
62L<"CONSTANTS"> below for a list of the constants exported by the C<:standard> tag.
63
64No official documentation exists for the OSCAR protocol, so it had to be figured
65out by analyzing traffic generated by AOL's official AOL Instant Messenger client.
66Source code from the Gaim client, the protocol analysis provided by the Ethereal
67network sniffer, and the Alexander Shutko's website
68E<lt>http://iserverd1.khstu.ru/oscar/E<gt> were also used as references.
69
70This module strives to be as compatible with C<Net::AIM> as possible at the API level, but some
71protocol-level differences prevent total compatibility.  The TOC protocol implemented
72by C<Net::AIM> is simpler than OSCAR and has official reference documentation from AOL,
73but it only provides a small subset of the full C<OSCAR> functionality.
74See the section on L<Net::AIM Compatibility> for more information.
75
76=head2 EVENT PROCESSING OVERVIEW
77
78Event processing is the implementation of C<Net::OSCAR> within the framework of your
79program, so that your program can respond to things happening on the OSCAR servers while
80still 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
81call the L<do_one_loop> method, which performs a C<select> call on all the object's
82sockets and reads incoming commands from the OSCAR server on any connections which
83have them.  The C<select> call has a default timeout of 0.01 seconds which can
84be adjusted using the L<timeout> method.  This means that every time you call L<do_one_loop>,
85it will pause for that interval if there are no messages from the OSCAR server.
86If you need lower overhead, want better performance, or need to handle many Net::OSCAR objects and/or other files and sockets
87at once, see L<HIGH-PERFORMANCE EVENT PROCESSING> below.
88
89=head2 FUNCTIONALITY
90
91C<Net::OSCAR> pretends to be WinAIM 5.5.3595.  It supports remote buddylists
92including permit and deny settings.  It also supports chat, buddy icons,
93and extended status messages.  At the present time, setting and retrieving of
94directory information is not supported; nor are email privacy settings,
95voice chat, stock ticker, file transfer, direct IM, and many other of the
96official AOL Instant Messenger client's features.
97
98=head2 TERMINOLOGY
99
100When you sign on with the OSCAR service, you are establishing an OSCAR session.
101
102=head2 CALLBACKS
103
104C<Net::OSCAR> uses a callback mechanism to notify you about different events.
105A callback is a function provided by you which C<Net::OSCAR> will call
106when a certain event occurs.  To register a callback, calling the C<set_callback_callbackname> method
107with a code reference as a parameter.  For instance, you might call
108C<$oscar-E<gt>set_callback_error(\&got_error);>.  Your callback function will
109be passed parameters which are different for each callback type (and are
110documented below).  The first parameter to each callback function will be
111the C<Net::OSCAR> object which generated the callback.  This is useful
112when using multiple C<Net::OSCAR> objects.
113
114=head1 REFERENCE
115
116=cut
117
118use 5.006_001;
119use strict;
120use vars qw($VERSION $REVISION @ISA @EXPORT_OK %EXPORT_TAGS $NODESTROY);
121use Carp;
122use Scalar::Util qw(weaken);
123use Digest::MD5 qw(md5);
124use Socket;
125use Net::OSCAR::Common qw(:all);
126use Net::OSCAR::Constants;
127use Net::OSCAR::Utility;
128use Net::OSCAR::Connection;
129use Net::OSCAR::Callbacks;
130use Net::OSCAR::TLV;
131use Net::OSCAR::Buddylist;
132use Net::OSCAR::Screenname;
133use Net::OSCAR::_BLInternal;
134use Net::OSCAR::XML;
135
136$NODESTROY = 0;
137
138require Exporter;
139@ISA = qw(Exporter);
140@EXPORT_OK = @Net::OSCAR::Common::EXPORT_OK;
141%EXPORT_TAGS = %Net::OSCAR::Common::EXPORT_TAGS;
142
143Net::OSCAR::XML::load_xml();
144
145=pod
146
147=head2 BASIC FUNCTIONALITY
148
149=head3 METHODS
150
151=over 4
152
153=item new ([capabilities =E<gt> CAPABILITIES], [rate_manage =E<gt> RATE_MANAGE_MODE])
154
155Creates a new C<Net::OSCAR> object.  You may optionally
156pass a hash to set some parameters for the object.
157
158=over 4
159
160=item capabilities
161
162A listref of optional features that your client supports.
163Valid capabilities are:
164
165=over 4
166
167=item extended_status
168
169iChat-style extended status messages
170
171=item buddy_icons
172
173=item file_transfer
174
175=item file_sharing
176
177=item typing_status
178
179Typing status notification
180
181=item buddy_list_transfer
182
183=back
184
185=item rate_manage
186
187Which mechanism will your application be using to deal with
188the sending rates which the server enforces on the client?
189See L<"RATE LIMIT OVERVIEW"> for more information on the subject.
190
191=over 4
192
193=item OSCAR_RATE_MANAGE_NONE
194
195=item OSCAR_RATE_MANAGE_AUTO
196
197=item OSCAR_RATE_MANAGE_MANUAL
198
199=back
200
201=back
202
203        $oscar = Net::OSCAR->new(capabilities => [qw(extended_status typing_status)], rate_manage => OSCAR_RATE_MANAGE_AUTO);
204
205=cut
206
207sub new($) {
208        my $class = ref($_[0]) || $_[0] || "Net::OSCAR";
209        shift;
210
211        my $self = {
212                options => {},
213                _parameters => [@_]
214        };
215        bless $self, $class;
216
217        my(%parameters) = @_;
218        if(my($badparam) = grep { $_ ne "capabilities" and $_ ne "rate_manage" } keys %parameters) {
219                croak "Invalid parameter '$badparam' passed to Net::OSCAR::new.";
220        }
221        if($parameters{capabilities}) {
222                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}}) {
223                        croak "Invalid capability '$badcap' passed to Net::OSCAR::new.";
224                }
225        }
226        if($parameters{rate_manage}) {
227                if($parameters{rate_manage} < OSCAR_RATE_MANAGE_NONE or $parameters{rate_manage} > OSCAR_RATE_MANAGE_MANUAL) {
228                        croak "Invalid rate_manage value '$parameters{rate_manage}' passed to Net::OSCAR::new.";
229                } elsif($parameters{rate_manage} == OSCAR_RATE_MANAGE_AUTO) {
230                        croak "OSCAR_RATE_MANAGE_AUTO hasn't been implemented yet!";
231                } else {
232                        $self->{rate_manage_mode} = $parameters{rate_manage};
233                        if($self->{rate_manage_mode} != OSCAR_RATE_MANAGE_NONE) {
234                                require Net::OSCAR::MethodInfo;
235                        }
236                }
237        } else {
238                $self->{rate_manage_mode} = OSCAR_RATE_MANAGE_NONE;
239        }
240
241        $self->{LOGLEVEL} = OSCAR_DBG_WARN;
242        $self->{SNDEBUG} = 0;
243        $self->{__BLI_locked} = 0;
244        $self->{__BLI_commit_later} = 0;
245
246        $self->{description} = "OSCAR session";
247        $self->{userinfo} = bltie;
248        $self->{services} = tlv;
249        $self->{svcqueues} = tlv;
250        $self->{listener} = undef;
251        $self->{rv_proposals} = {};
252        $self->{pass_is_hashed} = 0;
253        $self->{stealth} = 0;
254        $self->{icq_meta_info_cache} = {};
255        $self->{ip} = 0;
256
257        $self->{ft_ip} = undef;
258        $self->{rv_neg_mode} = OSCAR_RV_AUTO;
259        $self->{bl_limits} = {
260                buddies => 0,
261                groups => 0,
262                permits => 0,
263                denies => 0
264        };
265
266        $self->{timeout} = 0.01;
267        $self->{capabilities} = {};
268
269        if($parameters{capabilities}) {
270                $self->{capabilities}->{$_} = 1 foreach @{$parameters{capabilities}};
271        }
272
273        # Set default callbacks
274        $self->set_callback_snac_unknown(\&Net::OSCAR::Callbacks::default_snac_unknown);
275
276        return $self;
277}
278
279=pod
280
281=item signon (HASH)
282
283=item signon (SCREENNAME, PASSWORD[, HOST, PORT]
284
285Sign on to the OSCAR service.  You can specify an
286alternate host/port to connect to.  The default is
287login.oscar.aol.com port 5190. 
288
289The non-hash form of C<signon> is obsolete and is only provided for compatibility with C<Net::AIM>.
290If you use a hash to pass parameters to this function, here are the valid keys:
291
292=over 4
293
294=item screenname
295
296=item password
297
298Screenname and password are mandatory.  The other keys are optional.
299In the special case of password being present but undefined, the
300auth_challenge callback will be used - see L<"auth_challenge"> for details.
301
302=item stealth
303
304Use this to sign on with stealth mode activated.  Using this, as opposed
305to signon on without this setting and then calling L<"set_stealth">, will prevent
306the user from showing as online for a brief interval after signon.  See L<"set_stealth">
307for information about stealth mode.
308
309=item pass_is_hashed
310
311If you want to give Net::OSCAR the MD5 hash of the password instead of the password
312itself, use the MD5'd password in the password key and also set this key.  The
313benefit of this is that, if your application saves user passwords, you can save
314them in hashed form and don't need to store the plaintext.
315
316=item local_ip
317
318If you have more than one IP address with a route to the internet, this
319parameter can be used to specify which to use as the source IP for outgoing
320connections.
321
322=item local_port
323
324This controls which port Net::OSCAR will listen on for incoming direct connections.
325If not specified, a random port will be selected.
326
327=item host
328
329=item port
330
331=item proxy_type
332
333Either "SOCKS4", "SOCKS5", "HTTP", or HTTPS.  This and C<proxy_host> must be specified if you wish to use a proxy.
334C<proxy_port>, C<proxy_username>, C<proxy_password> are optional.  Note that proxy support
335is considered experimental.  You will need to have the C<Net::SOCKS> module installed for
336SOCKS proxying or the C<LWP::UserAgent> module installed for HTTP proxying.
337
338=item proxy_host
339
340=item proxy_port
341
342=item proxy_username
343
344=item proxy_password
345
346=back
347
348If the screenname is all-numeric, it will automatically be treated
349as an ICQ UIN instead of an AIM screenname.
350
351=cut
352
353sub signon($@) {
354        my($self, $password, $host, %args);
355        $self = shift;
356
357        # Determine whether caller is using hash-method or old method of passing parms.
358        # Note that this breaks if caller passes in both a host and a port using the old way.
359        # But hey, that's why it's deprecated!
360        if(@_ < 3) {
361                $args{screenname} = shift @_ or return $self->crapout($self->{services}->{0+CONNTYPE_BOS}, "You must specify a username to sign on with!");
362                $args{password} = shift @_ or return $self->crapout($self->{services}->{0+CONNTYPE_BOS}, "You must specify a password to sign on with!");;
363                $args{host} = shift @_ if @_;
364                $args{port} = shift @_ if @_;
365        } else {
366                %args = @_;
367                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});
368        }
369
370        my %defaults = OSCAR_SVC_AIM;
371        %defaults = OSCAR_SVC_ICQ if $args{screenname} =~ /^\d+$/;
372        foreach my $key(keys %defaults) {
373                $args{$key} ||= $defaults{$key};
374        }
375        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};
376        $self->{screenname} = Net::OSCAR::Screenname->new(\$args{screenname});
377
378        # We set BOS to the login connection so that our error handlers pick up errors on this connection as fatal.
379        $args{host} ||= "login.oscar.aol.com";
380        $args{port} ||= 5190;
381
382
383        ($self->{screenname}, $password, $host, $self->{port},
384                $self->{proxy_type}, $self->{proxy_host}, $self->{proxy_port},
385                $self->{proxy_username}, $self->{proxy_password}, $self->{local_ip},
386                $self->{local_port}, $self->{pass_is_hashed}, $self->{stealth}) =
387                        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)};
388
389        $self->{svcdata} = \%args;
390
391        if(defined($self->{proxy_type})) {
392                $self->{proxy_type} = uc($self->{proxy_type});
393                die "You must specify proxy_host if proxy_type is specified!\n" unless $self->{proxy_host};
394                if($self->{proxy_type} eq "HTTP" or $self->{proxy_type} eq "HTTPS") {
395                        $self->{http_proxy} = LWP::UserAgent->new(
396                                agent => "Mozilla/4.08 [en] (WinNT; U ;Nav)",
397                                keep_alive => 1,
398                                timeout => 30,
399                        );
400                        die "HTTPS not supported by your LWP::UserAgent\n" if $self->{proxy_type} eq "HTTPS" and !$self->{http_proxy}->is_protocol_supported("https");
401
402                        my $proxyurl = lc($self->{proxy_type}) . "://$self->{proxy_host}";
403                        $proxyurl .= ":$self->{proxy_port}" if $self->{proxy_port};
404                        $proxyurl .= "/";
405                        $self->{http_proxy}->proxy('http', $proxyurl);
406                }
407        }
408
409        $self->{services}->{0+CONNTYPE_BOS} = $self->addconn(auth => $password, conntype => CONNTYPE_LOGIN, description => "login", peer => $host);
410}
411
412=pod
413
414=item signoff
415
416Sign off from the OSCAR service.
417
418=cut
419
420sub signoff($) {
421        my $self = shift;
422        foreach my $connection(@{$self->{connections}}) {
423                $self->delconn($connection);
424        }
425        my $screenname = $self->{screenname};
426        %$self = ();
427        $self->{screename} = $screenname; # Useful for post-mortem processing in multiconnection apps
428}
429
430=pod
431
432=back
433
434=head3 CALLBACKS
435
436=over 4
437
438=item signon_done (OSCAR)
439
440Called when the user is completely signed on to the service.
441
442=back
443
444=head2 BUDDIES AND BUDDYLISTS
445
446See also L<"OTHER USERS"> for methods which pertain to any other user, regardless of
447whether they're on the buddylist or not.
448
449=head3 METHODS
450
451=over 4
452
453=item findbuddy (BUDDY)
454
455In scalar context, returns the name of the group that BUDDY is in, or undef if
456BUDDY could not be found in any group.  If BUDDY is in multiple
457groups, will return the first one we find.
458
459In list context, returns a two-element list consisting of the group
460name followed by the group hashref (or the empty list of the buddy
461is not found.)
462
463=cut
464
465sub findbuddy($$) {
466        my($self, $buddy) = @_;
467
468        while(my($grpname, $group) = each(%{$self->{buddies}})) {
469                next if
470                  $grpname eq "__BLI_DIRTY" or
471                  !$group or
472                  not $group->{members}->{$buddy} or
473                  $group->{members}->{$buddy}->{__BLI_DELETED};
474
475                hash_iter_reset(\%{$self->{buddies}}); # Reset the iterator
476                return wantarray ? ($grpname, $group) : $grpname;
477        }
478        return;
479}
480
481=pod
482
483=item commit_buddylist
484
485Sends your modified buddylist to the OSCAR server.  Changes to the buddylist
486won't actually take effect until this method is called.  Methods that change
487the buddylist have a warning about needing to call this method in their
488documentation.  After calling this method, your program B<MUST> not call
489it again until either the L<buddylist_ok> or L<buddylist_error> callbacks
490are received.
491
492=item rollback_buddylist
493
494Revert changes you've made to the buddylist, assuming you haven't called
495L<"commit_buddylist"> since making them.
496
497=item reorder_groups (GROUPS)
498
499Changes the ordering of the groups in your buddylist.  Call L<"commit_buddylist"> to
500save the
501new order on the OSCAR server.
502
503=item reorder_buddies (GROUP, BUDDIES)
504
505Changes the ordering of the buddies in a group on your buddylist.
506Call L<"commit_buddylist"> to save the new order on the OSCAR server.
507
508=cut
509
510sub commit_buddylist($) {
511        my($self) = shift;
512        return must_be_on($self) unless $self->{is_on};
513
514        if($self->{__BLI_locked}) {
515                # If the server is modifying the buddylist,
516                # wait until its done to do the commit.
517                $self->{__BLI_commit_later} = 1;
518                return;
519        }
520
521        Net::OSCAR::_BLInternal::NO_to_BLI($self);
522
523        # If user set icon to same as old icon, server won't request an upload.
524        # Send a buddy_icon_uploaded callback anyway.
525        if($self->{icon_md5sum_old} and $self->{icon_md5sum} eq $self->{icon_md5sum_old}) {
526                $self->callback_buddy_icon_uploaded();
527        }
528
529        delete $self->{icon_md5sum_old};
530}
531
532sub rollback_buddylist($) {
533        my($self) = shift;
534        return must_be_on($self) unless $self->{is_on};
535        Net::OSCAR::_BLInternal::BLI_to_NO($self);
536}
537
538sub reorder_groups($@) {
539        my $self = shift;
540        return must_be_on($self) unless $self->{is_on};
541        my @groups = @_;
542        tied(%{$self->{buddies}})->setorder(@groups);
543        $self->{buddies}->{__BLI_DIRTY} = 1;
544}
545
546sub reorder_buddies($$@) {
547        my $self = shift;
548        return must_be_on($self) unless $self->{is_on};
549        my $group = shift;
550        my @buddies = @_;
551        tied(%{$self->{buddies}->{$group}->{members}})->setorder(@buddies);
552        $self->{buddies}->{$group}->{__BLI_DIRTY} = 1;
553}
554
555=pod
556
557=item rename_group (OLDNAME, NEWNAME)
558
559Renames a group.  Call L<"commit_buddylist"> for the change to take effect.
560
561=item add_buddy (GROUP, BUDDIES)
562
563Adds buddies to the given group on your buddylist.  If the group does not exist,
564it will be created.  Call L<"commit_buddylist"> for the change to take effect.
565
566=item remove_buddy (GROUP, BUDDIES)
567
568See L<add_buddy>.
569
570=item add_group (GROUP)
571
572Creates a new, empty group.  Call L<"commit_buddylist"> for the change to take effect.
573
574=item remove_group (GROUP)
575
576See L<add_group>.  Any buddies in the group will be removed from the group first.
577
578=cut
579
580sub rename_group($$$) {
581        my($self, $oldgroup, $newgroup) = @_;
582        return must_be_on($self) unless $self->{is_on};
583        return send_error($self, $self->{services}->{0+CONNTYPE_BOS}, 0, "That group does not exist", 0) unless exists $self->{buddies}->{$oldgroup};
584
585        $self->{buddies}->{$newgroup} = $self->{buddies}->{$oldgroup};
586        $self->{buddies}->{$newgroup}->{__BLI_DIRTY} = 1;
587        delete $self->{buddies}->{$oldgroup};
588}
589
590sub add_buddy($$@) {
591        my($self, $group, @buddies) = @_;
592        $self->mod_buddylist(MODBL_ACTION_ADD, MODBL_WHAT_BUDDY, $group, @buddies);
593}
594
595sub remove_buddy($$@) {
596        my($self, $group, @buddies) = @_;
597        $self->mod_buddylist(MODBL_ACTION_DEL, MODBL_WHAT_BUDDY, $group, @buddies);
598}
599
600sub add_group($$) {
601        my($self, $group) = @_;
602        $self->mod_buddylist(MODBL_ACTION_ADD, MODBL_WHAT_GROUP, $group);
603}
604
605sub remove_group($$) {
606        my($self, $group) = @_;
607        return send_error($self, $self->{services}->{0+CONNTYPE_BOS}, 0, "That group does not exist", 0) unless exists $self->{buddies}->{$group};
608        $self->remove_buddy($group, $self->buddies($group)) if $self->buddies($group);
609        $self->mod_buddylist(MODBL_ACTION_DEL, MODBL_WHAT_GROUP, $group);
610}
611
612
613=item groups
614
615Returns a list of groups in the user's buddylist.
616
617=item buddies (GROUP)
618
619Returns the names of the buddies in the specified group in the user's buddylist.
620The names may not be formatted - that is, they may have spaces and capitalization
621removed.  The names are C<Net::OSCAR::Screenname> objects, so you don't have to
622worry that they're case and whitespace insensitive when using them for comparison.
623
624=item buddy (BUDDY[, GROUP])
625
626Returns information about a buddy on the user's buddylist.  This information is
627a hashref as per L<USER INFORMATION> below.
628
629=cut
630
631sub groups($) { return grep {$_ and $_ ne "__BLI_DIRTY"} keys %{shift->{buddies}}; }
632sub buddies($;$) {
633        my($self, $group) = @_;
634
635        if($group) {
636                my $grp = $self->{buddies}->{$group};
637
638                return grep {
639                        not $grp->{members}->{$_}->{__BLI_DELETED}
640                } keys %{$grp->{members}};
641        }
642
643        my @buddies;
644        while(my($grpname, $group) = each(%{$self->{buddies}})) {
645                next if !$grpname or $grpname eq "__BLI_DIRTY";
646                push @buddies, grep { not $group->{members}->{$_}->{__BLI_DELETED} } keys %{$group->{members}};
647        }
648        return @buddies;
649}
650sub buddy($$;$) {
651        my($self, $buddy, $grpname) = @_;
652        my $group;
653
654        if(!$grpname) {
655                ($grpname, $group) = $self->findbuddy($buddy) or return;
656        } else {
657                $group = $self->{buddies}->{$grpname} or return;
658        }
659
660        my $ret = $group->{members}->{$buddy};
661        return $ret->{__BLI_DELETED} ? undef : $ret;
662
663        return $self->{userinfo}->{$buddy} || undef;
664}
665
666=pod
667
668=item set_buddy_comment (GROUP, BUDDY[, COMMENT])
669
670Set a brief comment about a buddy.  You must call L<"commit_buddylist"> to save
671the comment to the server.  If COMMENT is undefined, the comment is
672deleted.
673
674=item set_buddy_alias (GROUP, BUDDY[, ALIAS])
675
676Set an alias for a buddy.  You must call L<"commit_buddylist"> to save
677the comment to the server.  If ALIAS is undefined, the alias is
678deleted.
679
680=cut
681
682sub set_buddy_comment($$$;$) {
683        my($self, $group, $buddy, $comment) = @_;
684        return must_be_on($self) unless $self->{is_on};
685
686        my $bud = $self->{buddies}->{$group}->{members}->{$buddy};
687        $bud->{comment} = $comment;
688        $bud->{__BLI_DIRTY} = 1;
689}
690
691sub set_buddy_alias($$$;$) {
692        my($self, $group, $buddy, $alias) = @_;
693        return must_be_on($self) unless $self->{is_on};
694
695        my $bud = $self->{buddies}->{$group}->{members}->{$buddy};
696        $bud->{alias} = $alias;
697        $bud->{__BLI_DIRTY} = 1;
698}
699
700=pod
701
702=item buddylist_limits
703
704Returns a hash containing the maximum number of buddylist entries
705of various types.  The keys in the hash are:
706
707=over 4
708
709=item *
710
711buddies
712
713=item *
714
715groups
716
717=item *
718
719permits
720
721=item *
722
723denies
724
725=back
726
727So, the maximum number of buddies allowed on a buddylist is stored in the C<buddies> key.
728Please note that buddylist storage has some overhead, so the actual number of items you
729can have on a buddylist may be slightly less than advertised.
730
731If the OSCAR server did not inform us of the limits, values of 0 will be used.
732
733=cut
734
735sub buddylist_limits($) { return %{shift->{bl_limits}}; }
736
737=pod
738
739=back
740
741=head3 CALLBACKS
742
743=over 4
744
745=item buddy_in (OSCAR, SCREENNAME, GROUP, BUDDY DATA)
746
747SCREENNAME (in buddy group GROUP) has signed on, or their information has
748changed.  BUDDY DATA is the same as that returned by the L<buddy> method.
749
750=item buddy_out (OSCAR, SCREENNAME, GROUP)
751
752Called when a buddy has signed off (or added us to their deny list.)
753
754=item buddylist_error (OSCAR, ERROR, WHAT)
755
756This is called when there is an error commiting changes to the buddylist.
757C<ERROR> is the error number.  C<WHAT> is a string describing which buddylist
758change failed.  C<Net::OSCAR> will revert the failed change to
759its state before C<commit_buddylist> was called.  Note that the
760buddylist contains information other than the user's buddies - see
761any method which says you need to call C<commit_buddylist> to have its
762changes take effect.
763
764=item buddylist_ok (OSCAR)
765
766This is called when your changes to the buddylist have been successfully commited.
767
768=item buddylist_changed (OSCAR, CHANGES)
769
770This is called when your buddylist is changed by the server.
771The most common reason for this to happen is if the screenname you are signed
772on with is also signed on somewhere else, and the buddylist is changed in
773the other session.
774
775Currently, only changes to buddies and groups will be listed in C<CHANGES>.
776Changes to privacy settings and any other portions of the buddylist will
777not be included in the list in the current version of C<Net::OSCAR>.
778
779C<CHANGES> is a list of hash references, one for each change to the buddylist,
780with the following keys:
781
782=over 4
783
784=item *
785
786type: Either C<MODBL_WHAT_BUDDY> or C<MODBL_WHAT_GROUP>.  This indicates
787if the change was to a buddy or a group.
788
789=item *
790
791action: Either C<MODBL_ACTION_DEL> or C<MODBL_ACTION_ADD>.  This indicates
792whether the change was an addition/modification or a deletion.
793
794=item *
795
796group: The name of the group which the modification took place in.  For
797C<MODBL_WHAT_BUDDY>, this will be the name of the group which the
798changed buddy was changed in; for C<MODBL_WHAT_GROUP>, this will
799be the name of the group which was changed.
800
801=item *
802
803buddy: This key is only present for C<MODBL_WHAT_BUDDY>.  It's the name
804of the buddy which was changed.
805
806=back
807
808The C<MODBL_*> constants come from C<Net::OSCAR::Common>, and
809are included in the C<:standard> export list.
810
811=back
812
813=head2 PRIVACY
814
815C<Net::OSCAR> supports privacy controls.  Our visibility setting, along
816with the contents of the permit and deny lists, determines who can
817contact us.  Visibility can be set to permit or deny everyone, permit only
818those on the permit list, deny only those on the deny list, or permit
819everyone on our buddylist.
820
821=head3 METHODS
822
823=over 4
824
825=item add_permit (BUDDIES)
826
827Add buddies to your permit list.  Call L<"commit_buddylist"> for the
828change to take effect.
829
830=item add_deny (BUDDIES)
831
832See L<add_permit>.
833
834=item remove_permit (BUDDIES)
835
836See L<add_permit>.
837
838=item remove_deny (BUDDIES)
839
840See L<add_permit>.
841
842=item get_permitlist
843
844Returns a list of all members of the permit list.
845
846=item get_denylist
847
848Returns a list of all members of the deny list.
849
850=item visibility
851
852Returns the user's current visibility setting.  See L<set_visibility>.
853
854=cut
855
856sub add_permit($@) { shift->mod_permit(MODBL_ACTION_ADD, "permit", @_); }
857sub add_deny($@) { shift->mod_permit(MODBL_ACTION_ADD, "deny", @_); }
858sub remove_permit($@) { shift->mod_permit(MODBL_ACTION_DEL, "permit", @_); }
859sub remove_deny($@) { shift->mod_permit(MODBL_ACTION_DEL, "deny", @_); }
860sub get_permitlist($) { return keys %{shift->{permit}}; }
861sub get_denylist(@) { return keys %{shift->{deny}}; }
862sub visibility($) { return shift->{visibility}; }
863
864
865=pod
866
867=item set_visibility (MODE)
868
869Sets the visibility mode, which determines how the permit and deny lists
870are interpreted.  Note that if you're looking for the feature which will prevent
871a user from showing up as online on any buddy list while not affecting anything else,
872the droids you're looking for are L<"is_stealth">/L<"set_stealth">.
873
874The visibility mode may be:
875
876=over 4
877
878=item *
879
880VISMODE_PERMITALL: Permit everybody.
881
882=item *
883
884VISMODE_DENYALL: Deny everybody.
885
886=item *
887
888VISMODE_PERMITSOME: Permit only those on your permit list.
889
890=item *
891
892VISMODE_DENYSOME: Deny only those on your deny list.
893
894=item *
895
896VISMODE_PERMITBUDS: Same as VISMODE_PERMITSOME, but your permit list is made to be
897the same as the buddies from all the various groups in your
898buddylist (except the deny group!)  Adding and removing buddies
899maintains this relationship.  You shouldn't manually alter the
900permit or deny groups when using this visibility mode.
901
902=back
903
904These constants are contained in the C<Net::OSCAR::Common> package,
905and will be imported into your namespace if you import C<Net::OSCAR>
906with the C<:standard> parameter.
907
908When someone is permitted, they can see when you are online and
909send you messages.  When someone is denied, they can't see when
910you are online or send you messages.  You cannot see them or
911send them messages.  You can talk to them if you are in the same
912chatroom, although neither of you can invite the other one into
913a chatroom.
914
915Call L<"commit_buddylist"> for the change to take effect.
916
917=cut
918
919sub set_visibility($$) {
920        my($self, $vismode) = @_;
921
922        return must_be_on($self) unless $self->{is_on};
923        $self->{visibility} = $vismode;
924}
925
926=pod
927
928=item is_stealth
929
930=item set_stealth STEALTH_STATUS
931
932These methods deal with "stealth mode".  When the user is in stealth mode, she won't
933show up as online on anyone's buddylist.  However, for all other purposes, she will be online
934as usual.  Any restrictions, imposed by the visibility mode (see L<"set_visibility">),
935on who can communicate with her will remain in effect.
936
937Stealth state can be changed by another signon of the user's
938screenname.  So, if you want your application to be aware of the stealth state,
939C<is_stealth> won't cut it; there's a L<"stealth_changed"> callback which will serve
940nicely.
941
942=cut
943
944sub is_stealth($) { return shift->{stealth}; }
945sub set_stealth($$) {
946        my($self, $new_state) = @_;
947        $self->svcdo(CONNTYPE_BOS, protobit => "set_extended_status", protodata => {
948                stealth => {state => $new_state ? 0x100 : 0}
949        });
950}
951
952=pod
953
954=item set_group_permissions (NEWPERMS)
955
956Set group permissions.  This lets you block any OSCAR users or any AOL users.
957C<NEWPERMS> should be a list of zero or more of the following constants:
958
959=over 4
960
961=item GROUPPERM_OSCAR
962
963Permit AOL Instant Messenger users to contact you.
964
965=item GROUPPERM_AOL
966
967Permit AOL subscribers to contact you.
968
969=back
970
971Call L<"commit_buddylist"> for the change to take effect.
972
973=cut
974
975sub set_group_permissions($@) {
976        my($self, @perms) = @_;
977        my $perms = 0xFFFFFF00;
978
979        return must_be_on($self) unless $self->{is_on};
980        foreach my $perm (@perms) { $perms |= $perm; }
981        $self->{groupperms} = $perms;
982}
983
984=pod
985
986=item group_permissions
987
988Returns current group permissions.  The return value is a list like the one
989that L<"set_group_permissions"> wants.
990
991=cut
992
993sub group_permissions($) {
994        my $self = shift;
995        my @retval = ();
996
997        foreach my $perm (GROUPPERM_OSCAR, GROUPPERM_AOL) {
998                push @retval, $perm if $self->{groupperms} & $perm;
999        }
1000        return @retval;
1001}
1002
1003=pod
1004
1005=back
1006
1007=head2 OTHER USERS
1008
1009See also L<"BUDDIES AND BUDDYLISTS">.
1010
1011=head3 METHODS
1012
1013=over 4
1014
1015=item get_info (WHO)
1016
1017Requests a user's information, which includes their profile and idle time.
1018See the L<buddy_info> callback for more information.
1019
1020=item get_away (WHO)
1021
1022Similar to L<get_info>, except requests the user's away message instead of
1023their profile.
1024
1025=cut
1026
1027sub get_info($$) {
1028        my($self, $screenname) = @_;
1029        return must_be_on($self) unless $self->{is_on};
1030
1031        $self->svcdo(CONNTYPE_BOS, reqdata => $screenname, protobit => "get_info", protodata => {screenname => $screenname});
1032}
1033sub get_away($$) {
1034        my($self, $screenname) = @_;
1035        return must_be_on($self) unless $self->{is_on};
1036
1037        $self->svcdo(CONNTYPE_BOS, reqdata => $screenname, protobit => "get_away", protodata => {screenname => $screenname});
1038}
1039
1040
1041=pod
1042
1043=item send_im (WHO, MESSAGE[, AWAY])
1044
1045Sends someone an instant message.  If the message is an automated reply generated,
1046perhaps, because you have an away message set, give the AWAY parameter a non-zero
1047value.  Note that C<Net::OSCAR> will not handle sending away messages to people who
1048contact you when you are away - you must perform this yourself if you want it done.
1049
1050Returns a "request ID" that you can use in the C<im_ok> callback to identify the message.
1051If the message was too long to send, returns zero.
1052
1053=cut
1054
1055sub send_im($$$;$) {
1056        my($self, $to, $msg, $away) = @_;
1057        return must_be_on($self) unless $self->{is_on};
1058
1059        if(!$self->{svcdata}->{hashlogin}) {
1060                return 0 if length($msg) >= 7987;
1061        } else {
1062                return 0 if length($msg) > 2000;
1063        }
1064
1065        my %protodata;
1066        $protodata{message} = $msg;
1067
1068        if($away) {
1069                $protodata{is_automatic} = {};
1070        } else {
1071                $protodata{request_server_confirmation} = {};
1072        }
1073
1074        if($self->{capabilities}->{buddy_icons} and $self->{icon_checksum} and $self->{icon_timestamp} and
1075                (!exists($self->{userinfo}->{$to}) or
1076                !exists($self->{userinfo}->{to}->{icon_timestamp_received}) or
1077                $self->{icon_timestamp} > $self->{userinfo}->{$to}->{icon_timestamp_received})
1078        ) {
1079                $self->log_print(OSCAR_DBG_DEBUG, "Informing $to about our buddy icon.");
1080                $self->{userinfo}->{$to} ||= {};
1081                $self->{userinfo}->{$to}->{icon_timestamp_received} = $self->{icon_timestamp};
1082
1083                $protodata{icon_data}->{"icon_".$_} = $self->{"icon_".$_} foreach qw(length checksum timestamp);
1084        }
1085
1086        my $flags2 = 0;
1087        if($self->{capabilities}->{typing_status}) {
1088                $flags2 = 0xB;
1089        }
1090
1091        my($req_id) = $self->send_message($to, 1, protoparse($self, "standard_IM_footer")->pack(%protodata), $flags2);
1092        return $req_id;
1093}
1094
1095=pod
1096
1097=item send_typing_status (RECIPIENT, STATUS)
1098
1099Send a typing status change to another user.  Send these messages
1100to implement typing status notification.  Valid values for C<STATUS> are:
1101
1102=over 4
1103
1104=item *
1105
1106TYPINGSTATUS_STARTED: The user has started typing to the recipient.
1107This indicates that typing is actively taking place.
1108
1109=item *
1110
1111TYPINGSTATUS_TYPING: The user is typing to the recipient.  This
1112indicates that there is text in the message input area, but
1113typing is not actively taking place at the moment.
1114
1115=item *
1116
1117TYPINGSTATUS_FINISHED: The user has finished typing to the recipient.
1118This should be sent when the user starts to compose a message, but
1119then erases all of the text in the message input area.
1120
1121=back
1122
1123=cut
1124
1125sub send_typing_status($$$) {
1126        my($self, $recipient, $status) = @_;
1127
1128        croak "This client does not support typing status notifications." unless $self->{capabilities}->{typing_status};
1129        return unless exists $self->{userinfo}->{$recipient} and $self->{userinfo}->{$recipient}->{typing_status};
1130
1131        $self->svcdo(CONNTYPE_BOS, protobit => "typing_notification", protodata => {
1132                screenname => $recipient,
1133                typing_status => $status
1134        });
1135}
1136
1137
1138=pod
1139
1140=item evil (WHO[, ANONYMOUSLY])
1141
1142C<Evils>, or C<warns>, a user.  Evilling a user increases their evil level,
1143which makes them look bad and decreases the rate at which they can send
1144messages.  Evil level gradually decreases over time.  If the second
1145parameter is non-zero, the evil will be done anonymously, which does
1146not increase the user's evil level by as much as a standard evil.
1147
1148You can't always evil someone.  You can only do it when they do something
1149like send you an instant message.
1150
1151=cut
1152
1153sub evil($$;$) {
1154        my($self, $who, $anon) = @_;
1155        return must_be_on($self) unless $self->{is_on};
1156
1157        $self->svcdo(CONNTYPE_BOS, reqdata => $who, protobit => "outgoing_warning", protodata => {
1158                is_anonymous => $anon ? 1 : 0,
1159                screenname => $who
1160        });
1161}
1162
1163=pod
1164
1165=item get_icon (SCREENNAME, MD5SUM)
1166
1167Gets a user's buddy icon.  See L<set_icon> for details.  To make
1168sure this method isn't called excessively, please check the
1169C<icon_checksum> and C<icon_timestamp> data, which are available
1170via the L<buddy> method (even for people not on the user's buddy
1171list.)  The MD5 checksum of a user's icon will be in the
1172C<icon_md5sum> key returned by L<buddy>.
1173
1174You should receive a L<buddy_icon_downloaded> callback in
1175response to this method.
1176
1177=cut
1178
1179sub get_icon($$$) {
1180        my($self, $screenname, $md5sum) = @_;
1181
1182        carp "This client does not support buddy icons!" unless $self->{capabilities}->{buddy_icons};
1183
1184        $self->svcdo(CONNTYPE_ICON, protobit => "buddy_icon_download", protodata => {
1185                screenname => $screenname,
1186                md5sum => $md5sum
1187        });
1188}       
1189
1190=pod
1191
1192=back
1193
1194=head3 CALLBACKS
1195
1196=over 4
1197
1198=item new_buddy_icon (OSCAR, SCREENNAME, BUDDY DATA)
1199
1200This is called when someone, either someone the user is talking with or someone on
1201their buddylist, has a potentially new buddy icon.  The buddy data is guaranteed
1202to have at least C<icon_checksum> available; C<icon_timestamp> and C<icon_length>
1203may not be.  Specifically, if C<Net::OSCAR> found out about the buddy icon
1204through a buddy status update (the sort that triggers a L<buddy_in> callback),
1205these data will B<not> be available; if C<Net::OSCAR> found out about the
1206icon via an incoming IM from the person, these data B<will> be available.
1207
1208Upon receiving this callback, an application should use the C<icon_checksum>
1209to search for the icon in its cache, and call L<get_icon> if it can't find it.
1210If the C<icon_md5sum>, which is what needs to get passed to L<get_icon>, is not present
1211in the buddy data, use L<get_info> to request the information for the user,
1212and then call L<get_icon> from the L<buddy_info> callback.
1213
1214=item buddy_icon_downloaded (OSCAR, SCREENNAME, ICONDATA)
1215
1216This is called when a user's buddy icon is successfully downloaded from the server.
1217
1218=item typing_status (OSCAR, SCREENNAME, STATUS)
1219
1220Called when someone has sent us a typing status notification message.
1221See L<send_typing_status> for a description of the different statuses.
1222
1223=item im_ok (OSCAR, TO, REQID)
1224
1225Called when an IM to C<TO> is successfully sent.
1226REQID is the request ID of the IM as returned by C<send_im>.
1227
1228=item im_in (OSCAR, FROM, MESSAGE[, AWAY])
1229
1230Called when someone sends you an instant message.  If the AWAY parameter
1231is non-zero, the message was generated as an automatic reply, perhaps because
1232you sent that person a message and they had an away message set.
1233
1234=item buddylist_in (OSCAR, FROM, BUDDYLIST)
1235
1236Called when someone sends you a buddylist.  You must set the L<"buddy_list_transfer">
1237capability for buddylists to be sent to you.  The buddylist will be a C<Net::OSCAR::Buddylist>
1238hashref whose keys are the groups and whose values are listrefs of C<Net::OSCAR::Screenname>
1239strings for the buddies in the group.
1240
1241=item buddy_info (OSCAR, SCREENNAME, BUDDY DATA)
1242
1243Called in response to a L<get_info> or L<get_away> request.
1244BUDDY DATA is the same as that returned by the L<buddy> method,
1245except that one of two additional keys, C<profile> and C<awaymsg>,
1246may be present.
1247
1248=back
1249
1250=head2 THE SIGNED-ON USER
1251
1252These methods deal with the user who is currently signed on using a particular
1253C<Net::OSCAR> object.
1254
1255=head3 METHODS
1256
1257=over 4
1258
1259=item email
1260
1261Returns the email address currently assigned to the user's account.
1262
1263=item screenname
1264
1265Returns the user's current screenname, including all capitalization and spacing.
1266
1267=item is_on
1268
1269Returns true if the user is signed on to the OSCAR service.  Otherwise,
1270returns false.
1271
1272=cut
1273
1274sub email($) { return shift->{email}; }
1275sub screenname($) { return shift->{screenname}; }
1276sub is_on($) { return shift->{is_on}; }
1277
1278=item profile
1279
1280Returns your current profile.
1281
1282=cut
1283
1284sub profile($) { return shift->{profile}; }
1285
1286=pod
1287
1288=item set_away (MESSAGE)
1289
1290Sets the user's away message, also marking them as being away.
1291If the message is undef or the empty string, the user will be
1292marked as no longer being away.  See also L<"get_away">.
1293
1294=cut
1295
1296sub set_away($$) {
1297        my($self, $awaymsg) = @_;
1298        return must_be_on($self) unless $self->{is_on};
1299
1300        # Because we use !defined(awaymsg) to indicate
1301        # that we just want to set the profile, force
1302        # it to be defined.
1303        $awaymsg = "" unless defined($awaymsg);
1304
1305        shift->set_info(undef, $awaymsg);
1306}
1307
1308=pod
1309
1310=item set_extended_status (MESSAGE)
1311
1312Sets the user's extended status message.  This requires the
1313C<Net::OSCAR> object to have been created with the C<extended_status>
1314capability.  Currently, the only clients which support extended
1315status messages are Net::OSCAR, Gaim, and iChat.  If the message
1316is undef or the empty string, the user's extended status
1317message will be cleared.  Use L<"get_info"> to get another
1318user's extended status.
1319
1320=cut
1321
1322sub set_extended_status($$) {
1323        my($self, $status) = @_;
1324        croak "This client does not support extended status messages." unless $self->{capabilities}->{extended_status};
1325
1326        $status ||= "";
1327
1328        $self->log_print(OSCAR_DBG_NOTICE, "Setting extended status.");
1329        $self->svcdo(CONNTYPE_BOS, protobit => "set_extended_status", protodata => {
1330                status_message => {message => $status}
1331        });
1332}
1333
1334=pod
1335
1336=item set_info (PROFILE)
1337
1338Sets the user's profile.  Call L<"commit_buddylist"> to have
1339the new profile saved into the buddylist, so that it will be
1340set the next time the screenname is signed on.  (This is a
1341Net::OSCAR-specific feature, so other clients will not pick
1342up the profile from the buddylist.)
1343
1344Note that Net::OSCAR stores the user's profile in the server-side buddylist, so
1345if L<"commit_buddylist"> is called after setting the profile with this method,
1346the user will automatically get that same profile set whenever they sign on
1347through Net::OSCAR.  See the file C<PROTOCOL>, included with the C<Net::OSCAR> distribution,
1348for details of how we're storing this data.
1349
1350Use L<"get_info"> to retrieve another user's profile.
1351
1352=cut
1353
1354sub set_info($$;$) {
1355        my($self, $profile, $awaymsg) = @_;
1356
1357        return must_be_on($self) unless $self->{services}->{0+CONNTYPE_BOS};
1358        $self->log_print(OSCAR_DBG_NOTICE, "Setting user information.");
1359
1360        my %protodata;
1361        $protodata{capabilities} = $self->capabilities();
1362
1363        if(defined($profile)) {
1364                $protodata{profile_mimetype} = 'text/aolrtf; charset="us-ascii"';
1365                $protodata{profile} = $profile;
1366                $self->{profile} = $profile;
1367        }
1368
1369        if(defined($awaymsg)) {
1370                $protodata{awaymsg_mimetype} = 'text/aolrtf; charset="us-ascii"';
1371                $protodata{awaymsg} = $awaymsg;
1372        }
1373
1374        $self->svcdo(CONNTYPE_BOS, protobit => "set_info", protodata => \%protodata);
1375}
1376
1377=pod
1378
1379=item set_icon (ICONDATA)
1380
1381Sets the user's buddy icon.  The C<Net::OSCAR> object must have been created
1382with the C<buddy_icons> capability to use this.  C<ICONDATA> must be less
1383than 4kb, should be 48x48 pixels, and should be BMP, GIF, or JPEG image data.
1384You must call L<commit_buddylist> for this change to take effect.  If
1385C<ICONDATA> is the empty string, the user's buddy icon will be removed.
1386
1387When reading the icon data from a file, make sure to call C<binmode>
1388on the file handle.
1389
1390Note that if the user's buddy icon was previously set with Net::OSCAR,
1391enough data will be stored in the server-side buddylist that this will
1392not have to be called every time the user signs on.  However, other clients
1393do not store the extra data in the buddylist, so if the user previously
1394set a buddy icon with a non-Net::OSCAR-based client, this method will
1395need to be called in order for the user's buddy icon to be set properly.
1396
1397See the file C<PROTOCOL>, included with the C<Net::OSCAR> distribution,
1398for details of how we're storing this data.
1399
1400You should receive a L<buddy_icon_uploaded> callback in response to this
1401method.
1402
1403Use L<"get_icon"> to retrieve another user's icon.
1404
1405=cut
1406
1407sub set_icon($$) {
1408        my($self, $icon) = @_;
1409
1410        carp "This client does not support buddy icons!" unless $self->{capabilities}->{buddy_icons};
1411
1412        if($icon) {
1413                $self->{icon} = $icon;
1414                $self->{icon_md5sum_old} = $self->{icon_md5sum} || "";
1415                $self->{icon_md5sum} = pack("n", 0x10) . md5($icon);
1416                $self->{icon_checksum} = $self->icon_checksum($icon);
1417                $self->{icon_timestamp} = time;
1418                $self->{icon_length} = length($icon);
1419        } else {
1420                delete $self->{icon};
1421                delete $self->{icon_md5sum};
1422                delete $self->{icon_checksum};
1423                delete $self->{icon_timestamp};
1424                delete $self->{icon_length};
1425        }
1426}
1427
1428
1429=pod
1430
1431=pod
1432
1433=item change_password (CURRENT PASSWORD, NEW PASSWORD)
1434
1435Changes the user's password.
1436
1437=cut
1438
1439sub change_password($$$) {
1440        my($self, $currpass, $newpass) = @_;
1441        return must_be_on($self) unless $self->{is_on};
1442
1443        if($self->{adminreq}->{0+ADMIN_TYPE_PASSWORD_CHANGE}) {
1444                $self->callback_admin_error(ADMIN_TYPE_PASSWORD_CHANGE, ADMIN_ERROR_REQPENDING);
1445                return;
1446        } else {
1447                $self->{adminreq}->{0+ADMIN_TYPE_PASSWORD_CHANGE}++;
1448        }
1449
1450        $self->svcdo(CONNTYPE_ADMIN, protobit => "change_account_info", protodata => {
1451                newpass => $newpass,
1452                oldpass => $currpass
1453        });
1454}
1455
1456=pod
1457
1458=item confirm_account
1459
1460Confirms the user's account.  This can be used when the user's account is in the trial state,
1461as determined by the presence of the C<trial> key in the information given when the user's
1462information is requested.
1463
1464=cut
1465
1466sub confirm_account($) {
1467        my($self) = shift;
1468        return must_be_on($self) unless $self->{is_on};
1469
1470        if($self->{adminreq}->{0+ADMIN_TYPE_ACCOUNT_CONFIRM}) {
1471                $self->callback_admin_error(ADMIN_TYPE_ACCOUNT_CONFIRM, ADMIN_ERROR_REQPENDING);
1472                return;
1473        } else {
1474                $self->{adminreq}->{0+ADMIN_TYPE_ACCOUNT_CONFIRM}++;
1475        }
1476
1477        $self->svcdo(CONNTYPE_ADMIN, protobit => "confirm_account_request");
1478}
1479
1480=pod
1481
1482=item change_email (NEW EMAIL)
1483
1484Requests that the email address registered to the user's account be changed.
1485This causes the OSCAR server to send an email to both the new address and the
1486old address.  To complete the change, the user must follow instructions contained
1487in the email sent to the new address.  The email sent to the old address contains
1488instructions which allow the user to cancel the change within three days of the
1489change request.  It is important that the user's current email address be
1490known to the OSCAR server so that it may email the account password if the
1491user forgets it.
1492
1493=cut
1494
1495sub change_email($$) {
1496        my($self, $newmail) = @_;
1497        return must_be_on($self) unless $self->{is_on};
1498
1499        if($self->{adminreq}->{0+ADMIN_TYPE_EMAIL_CHANGE}) {
1500                $self->callback_admin_error(ADMIN_TYPE_EMAIL_CHANGE, ADMIN_ERROR_REQPENDING);
1501                return;
1502        } else {
1503                $self->{adminreq}->{0+ADMIN_TYPE_EMAIL_CHANGE}++;
1504        }
1505
1506        $self->svcdo(CONNTYPE_ADMIN, protobit => "change_account_info", protodata => {
1507                new_email => $newmail
1508        });
1509}
1510
1511=pod
1512
1513=item format_screenname (NEW FORMAT)
1514
1515Allows the capitalization and spacing of the user's screenname to be changed.
1516The new format must be the same as the user's current screenname, except that
1517case may be changed and spaces may be inserted or deleted.
1518
1519=cut
1520
1521sub format_screenname($$) {
1522        my($self, $newname) = @_;
1523        return must_be_on($self) unless $self->{is_on};
1524
1525        if($self->{adminreq}->{0+ADMIN_TYPE_SCREENNAME_FORMAT}) {
1526                $self->callback_admin_error(ADMIN_TYPE_SCREENNAME_FORMAT, ADMIN_ERROR_REQPENDING);
1527                return;
1528        } else {
1529                $self->{adminreq}->{0+ADMIN_TYPE_SCREENNAME_FORMAT}++;
1530        }
1531
1532        $self->svcdo(CONNTYPE_ADMIN, protobit => "change_account_info", protodata => {
1533                new_screenname => $newname
1534        });
1535}
1536
1537=pod
1538
1539=item set_idle (TIME)
1540
1541Sets the user's idle time in seconds.  Set to zero to mark the user as
1542not being idle.  Set to non-zero once the user becomes idle.  The OSCAR
1543server will automatically increment the user's idle time once you mark
1544the user as being idle.
1545
1546=cut
1547
1548sub set_idle($$) {
1549        my($self, $time) = @_;
1550        return must_be_on($self) unless $self->{is_on};
1551        $self->svcdo(CONNTYPE_BOS, protobit => "set_idle", protodata => {duration => $time});
1552}
1553
1554=pod
1555
1556=back
1557
1558=head3 CALLBACKS
1559
1560=over 4
1561
1562=item admin_error (OSCAR, REQTYPE, ERROR, ERRURL)
1563
1564This is called when there is an error performing an administrative function - changing
1565your password, formatting your screenname, changing your email address, or confirming your
1566account.  REQTYPE is a string describing the type of request which generated the error.
1567ERROR is an error message.  ERRURL is an http URL which the user may visit for more
1568information about the error.
1569
1570=item admin_ok (OSCAR, REQTYPE)
1571
1572This is called when an administrative function succeeds.  See L<admin_error> for more info.
1573
1574=item buddy_icon_uploaded (OSCAR)
1575
1576This is called when the user's buddy icon is successfully uploaded to the server.
1577
1578=item stealth_changed (OSCAR, NEW_STEALTH_STATE)
1579
1580This is called when the user's stealth state changes.  See L<"is_stealth"> and L<"set_stealth">
1581for information on stealth.
1582
1583=item extended_status (OSCAR, STATUS)
1584
1585Called when the user's extended status changes.  This will normally
1586be sent in response to a successful L<set_extended_status> call.
1587
1588=item evil (OSCAR, NEWEVIL[, FROM])
1589
1590Called when your evil level changes.  NEWEVIL is your new evil level,
1591as a percentage (accurate to tenths of a percent.)  ENEMY is undef
1592if the evil was anonymous (or if the message was triggered because
1593your evil level naturally decreased), otherwise it is the screenname
1594of the person who sent us the evil.  See the L<"evil"> method for
1595more information on evils.
1596
1597=back
1598
1599=head2 FILE TRANSFER AND DIRECT CONNECTIONS
1600
1601=over 4
1602
1603=item file_send SCREENNAME MESSAGE FILEREFS
1604
1605C<FILEDATA> can be undef to have Net::OSCAR read the file,
1606a file handle, or the data to send.
1607
1608=cut
1609
1610sub file_send($$@) {
1611        my($self, $screenname, $message, @filerefs) = @_;
1612
1613        my $connection = $self->addconn(conntype => CONNTYPE_DIRECT_IN);
1614        my($port) = sockaddr_in(getsockname($connection->{socket}));
1615
1616        my $size = 0;
1617        $size += length($_->{data}) foreach @filerefs;
1618
1619        my %svcdata = (
1620                file_count_status => (@filerefs > 1 ? 2 : 1),
1621                file_count => scalar(@filerefs),
1622                size => $size,
1623                files => [map {$_->{name}} @filerefs]
1624        );
1625
1626        my $cookie = randchars(8);
1627        my($ip) = unpack("N", inet_aton($self->{services}->{CONNTYPE_BOS()}->local_ip()));
1628        my %protodata = (
1629                capability => OSCAR_CAPS()->{filexfer}->{value},
1630                charset => "us-ascii",
1631                cookie => $cookie,
1632                invitation_msg => $message,
1633                language => 101,
1634                push_pull => 1,
1635                status => "propose",
1636                client_1_ip => $ip,
1637                client_2_ip => $ip,
1638                port => $port,
1639                proxy_ip => unpack("N", inet_aton("63.87.248.248")), # TODO: What's this really supposed to be?
1640                svcdata_charset => "us-ascii",
1641                svcdata => protoparse($self, "file_transfer_rendezvous_data")->pack(%svcdata)
1642        );
1643
1644        my($req_id) = $self->send_message($screenname, 2, pack("nn", 3, 0) . protoparse($self, "rendezvous_IM")->pack(%protodata), 0, $cookie);
1645
1646        $self->{rv_proposals}->{$cookie} = $connection->{rv} = {
1647                cookie => $cookie,
1648                sender => $self->{screenname},
1649                recipient => $screenname,
1650                peer => $screenname,
1651                type => "filexfer",
1652                connection => $connection,
1653                ft_state => "listening",
1654                direction => "send",
1655                accepted => 0,
1656                filenames => [map {$_->{name}} @filerefs],
1657                data => [map {$_->{data}} @filerefs],
1658                using_proxy => 0,
1659                tried_proxy => 0,
1660                tried_listen => 1,
1661                tried_connect => 0,
1662                total_size => $size,
1663                file_count => scalar(@filerefs)
1664        };
1665
1666        return ($req_id, $cookie);
1667}
1668
1669=pod
1670
1671=back
1672
1673=head2 EVENT PROCESSING
1674
1675=head3 METHODS
1676
1677=over 4
1678
1679=item do_one_loop
1680
1681Processes incoming data from our connections to the various
1682OSCAR services.  This method reads one command from any
1683connections which have data to be read.  See the
1684L<timeout> method to set the timeout interval used
1685by this method.
1686
1687=cut
1688
1689sub do_one_loop($) {
1690        my $self = shift;
1691        my $timeout = $self->{timeout};
1692
1693        undef $timeout if defined($timeout) and $timeout == -1;
1694
1695        my($rin, $win, $ein) = ('', '', '');
1696
1697        foreach my $connection(@{$self->{connections}}) {
1698                next unless exists($connection->{socket});
1699                if($connection->{connected}) {
1700                        vec($rin, fileno $connection->{socket}, 1) = 1;
1701                } elsif(!$connection->{connected} or $connection->{outbuff}) {
1702                        vec($win, fileno $connection->{socket}, 1) = 1;
1703                }
1704        }
1705        $ein = $rin | $win;
1706
1707        return unless $ein;
1708        my $nfound = select($rin, $win, $ein, $timeout);
1709        $self->process_connections(\$rin, \$win, \$ein) if $nfound and $nfound != -1;
1710}
1711
1712=pod
1713
1714=item process_connections (READERSREF, WRITERSREF, ERRORSREF)
1715
1716Use this method when you want to implement your own C<select>
1717statement for event processing instead of using C<Net::OSCAR>'s
1718L<do_one_loop> method.  The parameters are references to the
1719readers, writers, and errors parameters used by the select
1720statement.  The method will ignore all connections which
1721are not C<Net::OSCAR::Connection> objects or which are
1722C<Net::OSCAR::Connection> objects from a different C<Net::OSCAR>
1723object.  It modifies its arguments so that its connections
1724are removed from the connection lists.  This makes it very
1725convenient for use with multiple C<Net::OSCAR> objects or
1726use with a C<select>-based event loop that you are also
1727using for other purposes.
1728
1729See the L<selector_filenos> method for a way to get the necessary
1730bit vectors to use in your C<select>.
1731
1732=cut
1733
1734sub process_connections($\$\$\$) {
1735        my($self, $readers, $writers, $errors) = @_;
1736
1737        # Filter out our connections and remove them from the to-do list
1738        foreach my $connection(@{$self->{connections}}) {
1739                my($read, $write) = (0, 0);
1740                next unless $connection->fileno;
1741                if($connection->{connected}) {
1742                        next unless vec($$readers | $$errors, $connection->fileno, 1);
1743                        vec($$readers, $connection->fileno, 1) = 0;
1744                        $read = 1;
1745                }
1746                if(!$connection->{connected} or $connection->{outbuff}) {
1747                        next unless vec($$writers | $$errors, $connection->fileno, 1);
1748                        vec($$writers, $connection->fileno, 1) = 0;
1749                        $write = 1;
1750                }
1751                if(vec($$errors, $connection->fileno, 1)) {
1752                        vec($$errors, $connection->fileno, 1) = 0;
1753                        $connection->{sockerr} = 1;
1754                        $connection->disconnect();
1755                } else {
1756                        $connection->process_one($read, $write);
1757                }
1758        }
1759}
1760
1761=pod
1762
1763=back
1764
1765=head3 CALLBACKS
1766
1767=over 4
1768
1769=item connection_changed (OSCAR, CONNECTION, STATUS)
1770
1771Called when the status of a connection changes.  The status is "read" if we
1772should call L<"process_one"> on the connection when C<select> indicates that
1773the connection is ready for reading, "write" if we should call
1774L<"process_one"> when the connection is ready for writing, "readwrite" if L<"process_one">
1775should be called in both cases, or "deleted" if the connection has been deleted.
1776
1777C<CONNECTION> is a C<Net::OSCAR::Connection> object.
1778
1779Users of this callback may also be interested in the L<"get_filehandle">
1780method of C<Net::OSCAR::Connection>.
1781
1782=back
1783
1784=head2 CHATS
1785
1786=head3 METHODS
1787
1788=over 4
1789
1790=item chat_join (NAME[, EXCHANGE])
1791
1792Creates (or joins?) a chatroom.  The exchange parameter should probably not be
1793specified unless you know what you're doing.  Do not use this method
1794to accept invitations to join a chatroom - use the L<"chat_accept"> method
1795for that.
1796
1797=cut
1798
1799sub chat_join($$;$) {
1800        my($self, $name, $exchange) = @_;
1801        return must_be_on($self) unless $self->{is_on};
1802        $exchange ||= 4;
1803
1804        my $reqid = (8<<16) | (unpack("n", randchars(2)))[0];
1805        $self->{chats}->{pack("N", $reqid)} = $name;
1806        $self->svcdo(CONNTYPE_CHATNAV, reqid => $reqid, protobit => "chat_navigator_room_create", protodata => {
1807                exchange => $exchange,
1808                name => $name
1809        });
1810}
1811
1812=pod
1813
1814=item chat_accept (CHATURL)
1815
1816Use this to accept an invitation to join a chatroom.
1817
1818=item chat_decline (CHATURL)
1819
1820Use this to decline an invitation to join a chatroom.
1821
1822=cut
1823
1824sub chat_accept($$) {
1825        my($self, $url) = @_;
1826        return must_be_on($self) unless $self->{is_on};
1827
1828        $self->log_print(OSCAR_DBG_NOTICE, "Accepting chat invite for $url.");
1829        my($rv) = grep { $_->{chat_url} eq $url } values %{$self->{rv_proposals}};
1830        return unless $rv;
1831
1832        $self->svcdo(CONNTYPE_CHATNAV, protobit => "chat_invitation_accept", protodata => {
1833                exchange => $rv->{exchange},
1834                url => $url
1835        });
1836
1837
1838        my $reqid = pack("n", 4);
1839        $reqid .= randchars(2);
1840        ($reqid) = unpack("N", $reqid);
1841
1842        $self->{chats}->{$reqid} = $rv;
1843        $self->svcdo(CONNTYPE_BOS, protobit => "service_request", reqid => $reqid, protodata => {
1844                type => CONNTYPE_CHAT,
1845                chat => {
1846                        exchange => $rv->{exchange},
1847                        url => $url
1848                }
1849        });
1850}
1851
1852sub chat_decline($$) {
1853        my($self, $url) = @_;
1854        return must_be_on($self) unless $self->{is_on};
1855
1856        $self->log_print(OSCAR_DBG_NOTICE, "Declining chat invite for $url.");
1857        my($rv) = grep { $_->{chat_url} eq $url } values %{$self->{rv_proposals}};
1858        return unless $rv;
1859
1860        $self->svcdo(CONNTYPE_BOS, protobit => "chat_invitation_decline", protodata => {
1861                cookie => $rv->{cookie},
1862                screenname => $rv->{sender},
1863        });
1864
1865        delete $self->{rv_proposals}->{$rv->{cookie}};
1866}
1867
1868=pod
1869
1870=back
1871
1872=head3 CALLBACKS
1873
1874=over 4
1875
1876=item chat_buddy_in (OSCAR, SCREENNAME, CHAT, BUDDY DATA)
1877
1878SCREENNAME has entered CHAT.  BUDDY DATA is the same as that returned by
1879the L<buddy> method.
1880
1881=item chat_buddy_out (OSCAR, SCREENNAME, CHAT)
1882
1883Called when someone leaves a chatroom.
1884
1885=item chat_im_in (OSCAR, FROM, CHAT, MESSAGE)
1886
1887Called when someone says something in a chatroom.  Note that you
1888receive your own messages in chatrooms unless you specify the
1889NOREFLECT parameter in L<chat_send>.
1890
1891=item chat_invite (OSCAR, WHO, MESSAGE, CHAT, CHATURL)
1892
1893Called when someone invites us into a chatroom.  MESSAGE is the message
1894that they specified on the invitation.  CHAT is the name of the chatroom.
1895CHATURL is a chat URL and not a C<Net::OSCAR::Connection::Chat> object.  CHATURL can
1896be passed to the L<chat_accept> method to accept the invitation.
1897
1898=item chat_joined (OSCAR, CHATNAME, CHAT)
1899
1900Called when you enter a chatroom.  CHAT is the C<Net::OSCAR::Connection::Chat>
1901object for the chatroom.
1902
1903=item chat_closed (OSCAR, CHAT, ERROR)
1904
1905Your connection to CHAT (a C<Net::OSCAR::Connection::Chat> object) was severed due to ERROR.
1906
1907=back
1908
1909=head2 RATE LIMITS
1910
1911See L<"RATE LIMIT OVERVIEW"> for more information on rate limits.
1912
1913=head3 METHODS
1914
1915=over 4
1916
1917=item rate_level (OSCAR, METHODNAME[, CHAT])
1918
1919Returns the rate level (one of C<RATE_CLEAR>, C<RATE_ALERT>, C<RATE_LIMIT>, C<RATE_DISCONNECT>)
1920which the OSCAR session is currently at for the C<Net::OSCAR> (or C<Net::OSCAR::Connection::Chat>) method named
1921C<METHODNAME> right now.  This only makes sense for methods which send information to the OSCAR
1922server, such as C<send_im>, but if you pass in a method name which doesn't make sense (or isn't
1923actually a C<Net::OSCAR> method, or which isn't rate-limited), we'll gladly an empty list.  B<This method is
1924not available if your application is using L<"OSCAR_RATE_MANAGE_NONE">.>
1925
1926If C<METHODNAME> is C<chat_send>, you should also pass the C<Net::OSCAR::Connection::Chat>
1927object to get rate information on (as the C<CHAT> parameter.)
1928
1929=cut
1930
1931sub _rate_level($$$) {
1932        my($oscar, $level, $levels) = @_;
1933
1934        if($level <= $levels->{disconnect}) {
1935                return RATE_DISCONNECT;
1936        } elsif($level <= $levels->{limit}) {
1937                return RATE_LIMIT;
1938        } elsif($level <= $levels->{alert}) {
1939                return RATE_ALERT;
1940        } else {
1941                return RATE_CLEAR;
1942        }
1943}
1944
1945sub _rate_lookup($$;$) {
1946        my($oscar, $method, $chat) = @_;
1947        croak "Rate methods not supported when using OSCAR_RATE_MANAGE_NONE!" if $oscar->{rate_manage_mode} == OSCAR_RATE_MANAGE_NONE;
1948
1949        print "rate_lookup $method\n";
1950        my $key = $Net::OSCAR::MethodInfo::methods{$method} or return;
1951        print "\tFound key\n";
1952        my $conn = $chat || $oscar->connection_for_family(unpack("n", $key));
1953        print "\tFound connection\n";
1954        my $class = $conn->{rate_limits}->{classmap}->{$key} or return;
1955        print "\tFound class\n";
1956        return $conn->{rate_limits}->{$class};
1957}
1958
1959sub rate_level($$;$) {
1960        my($oscar, $method, $chat) = @_;
1961        my $rinfo = $oscar->_rate_lookup($method, $chat) or return;
1962
1963        return $oscar->_rate_level($rinfo->{current_state}, $rinfo->{levels});
1964}
1965
1966=pod
1967
1968=item rate_limits (OSCAR, METHODNAME[, CHAT])
1969
1970Similar to L<"rate_level">.  This returns the boundaries of the different rate level
1971categories for the given method name, in the form of a hash with the following keys
1972(this won't make sense if you don't know how the current level is calculated; see below):
1973
1974=over 4
1975
1976=item window_size
1977
1978=item levels
1979
1980A hashref with keys for each of the levels.  Each key is the name of a level,
1981and the value for that key is the threshold for that level.
1982
1983=over 4
1984
1985=item clear
1986
1987=item alert
1988
1989=item limit
1990
1991=item disconnect
1992
1993=back
1994
1995=item last_time
1996
1997The time at which the last command to affect this rate level was sent.
1998
1999=item current_state
2000
2001The session's current rate level.
2002
2003=back
2004
2005Every time a command is sent to the OSCAR server, the level is recalculated according to the formula
2006(from Alexandr Shutko's OSCAR documentation, L<http://iserverd.khstu.ru/oscar/>:
2007
2008        NewLevel = (Window - 1)/Window * OldLevel + 1/Window * CurrentTimeDiff
2009
2010C<CurrentTimeDiff> is the difference between the current system time and C<last_time>.
2011
2012=cut
2013
2014sub rate_limits($$;$) {
2015        my($oscar, $method, $chat) = @_;
2016        return $oscar->_rate_lookup($method, $chat);
2017}
2018
2019=pod
2020
2021=item would_make_rate_level (OSCAR, METHODNAME[, CHAT])
2022
2023Returns the rate level which your session would be at if C<METHODNAME> were sent right now.
2024See L<"rate_level"> for more information.
2025
2026=cut
2027
2028sub _compute_rate($$) {
2029        my($oscar, $rinfo) = @_;
2030
2031        my $level = $rinfo->{current_state};
2032        my $window = $rinfo->{window_size};
2033        my $timediff = (millitime() - $rinfo->{time_offset}) - $rinfo->{last_time};
2034        return ($window - 1)/$window * $level + 1/$window * $timediff;
2035}
2036
2037sub would_make_rate_level($$;$) {
2038        my($oscar, $method, $chat) = @_;
2039        my $rinfo = $oscar->_rate_lookup($method, $chat) or return;
2040
2041        return $oscar->_rate_level($oscar->_compute_rate($rinfo), $rinfo->{levels});
2042}
2043
2044=cut
2045
2046=back
2047
2048=head3 CALLBACKS
2049
2050=over 4
2051
2052=item rate_alert (OSCAR, LEVEL, CLEAR, WINDOW, WORRISOME, VIRTUAL)
2053
2054This is called when you are sending commands to OSCAR too quickly.
2055
2056C<LEVEL> is one of C<RATE_CLEAR>, C<RATE_ALERT>, C<RATE_LIMIT>, or C<RATE_DISCONNECT> from the C<Net::OSCAR::Common>
2057package (they are imported into your namespace if you import C<Net::OSCAR> with the C<:standard>
2058parameter.)  C<RATE_CLEAR> means that you're okay.  C<RATE_ALERT> means you should slow down.  C<RATE_LIMIT>
2059means that the server is ignoring messages from you until you slow down.  C<RATE_DISCONNECT> means you're
2060about to be disconnected.
2061
2062C<CLEAR> and C<WINDOW> tell you the maximum speed you can send in order to maintain C<RATE_CLEAR> standing.
2063You must send no more than C<WINDOW> commands in C<CLEAR> milliseconds.  If you just want to keep it
2064simple, you can just not send any commands for C<CLEAR> milliseconds and you'll be fine.
2065
2066C<WORRISOME> is nonzero if C<Net::OSCAR> thinks that the alert is anything worth
2067worrying about.  Otherwise it is zero.  This is very rough, but it's a good way
2068for the lazy to determine whether or not to bother passing the alert on to
2069their users.
2070
2071A C<VIRTUAL> rate limit is one which your application would have incurred,
2072but you're using L<automatic rate management|"OSCAR_RATE_MANAGE_AUTO">, so we
2073stopped something from being sent out.
2074
2075=back
2076
2077=head2 MISCELLANEOUS
2078
2079=head3 METHODS
2080
2081=over 4
2082
2083=item timeout ([NEW TIMEOUT])
2084
2085Gets or sets the timeout value used by the L<do_one_loop> method.
2086The default timeout is 0.01 seconds.
2087
2088=cut
2089
2090sub timeout($;$) {
2091        my($self, $timeout) = @_;
2092        return $self->{timeout} unless $timeout;
2093        $self->{timeout} = $timeout;
2094}
2095
2096=pod
2097
2098=item loglevel ([LOGLEVEL[, SCREENNAME DEBUG]])
2099
2100Gets or sets the level of logging verbosity.  If this is non-zero, varing amounts of information will be printed
2101to standard error (unless you have a L<"log"> callback defined).  Higher loglevels will give you more information.
2102If the optional screenname debug parameter is non-zero,
2103debug messages will be prepended with the screenname of the OSCAR session which is generating
2104the message (but only if you don't have a L<"log"> callback defined).  This is useful when you have multiple C<Net::OSCAR> objects.
2105
2106See the L<"log"> callback for more information.
2107
2108=cut
2109
2110sub loglevel($;$$) {
2111        my $self = shift;
2112        return $self->{LOGLEVEL} unless @_;
2113        $self->{LOGLEVEL} = shift;
2114        $self->{SNDEBUG} = shift if @_;
2115}
2116
2117=pod
2118
2119=item auth_response (MD5_DIGEST[, PASS_IS_HASHED])
2120
2121Provide a response to an authentication challenge - see the L<"auth_challenge">
2122callback for details.
2123
2124=cut
2125
2126sub auth_response($$$) {
2127        my($self, $digest, $pass_is_hashed) = @_;
2128
2129        if($pass_is_hashed) {
2130                $self->{pass_is_hashed} = 1;
2131        } else {
2132                $self->{pass_is_hashed} = 0;
2133        }
2134
2135        $self->log_print(OSCAR_DBG_SIGNON, "Got authentication response - proceeding with signon");
2136        $self->{auth_response} = $digest;
2137        my %data = signon_tlv($self);
2138        $self->svcdo(CONNTYPE_BOS, protobit => "signon", protodata => {%data});
2139}
2140
2141=pod
2142
2143=item clone
2144
2145Clones the object.  This creates a new C<Net::OSCAR> object whose callbacks,
2146loglevel, screenname debugging, and timeout are the same as those of the
2147current object.  This is provided as a convenience when using multiple
2148C<Net::OSCAR> objects in order to allow you to set those parameters once
2149and then call the L<signon> method on the object returned by clone.
2150
2151=cut
2152
2153sub clone($) {
2154        my $self = shift;
2155        my $clone = $self->new(@{$self->{_parameters}});        # Born in a science lab late one night
2156                                                                # Without a mother or a father
2157                                                                # Just a test tube and womb with a view...
2158
2159        # Okay, now we don't want to just copy the reference.
2160        # If we did that, changing ourself would change the clone.
2161        $clone->{callbacks} = { %{$self->{callbacks}} };
2162
2163        $clone->{LOGLEVEL} = $self->{LOGLEVEL};
2164        $clone->{SNDEBUG} = $self->{SNDEBUG};
2165        $clone->{timeout} = $self->{timeout};
2166
2167        foreach my $c (@{$clone->{connections}}) {
2168                $c->{buffer} = \"";
2169        }
2170
2171        return $clone;
2172}
2173
2174=pod
2175
2176=item buddyhash
2177
2178Returns a reference to a tied hash which automatically normalizes its keys upon a fetch.
2179Use this for hashes whose keys are AIM screennames since AIM screennames with different
2180capitalization and spacing are considered equivalent.
2181
2182The keys of the hash as returned by the C<keys> and C<each> functions will be
2183C<Net::OSCAR::Screenname> objects, so you they will automagically be compared
2184without regards to case and whitespace.
2185
2186=cut
2187
2188sub buddyhash($) { bltie; }
2189
2190=pod
2191
2192=item findconn (FILENO)
2193
2194Finds the connection that is using the specified file number, or undef
2195if the connection could not be found.  Returns a C<Net::OSCAR::Connection>
2196object.
2197
2198=cut
2199
2200sub findconn($$) {
2201        my($self, $target) = @_;
2202        my($conn) = grep { fileno($_->{socket}) == $target } @{$self->{connections}};
2203        return $conn;
2204}
2205
2206=pod
2207
2208=item selector_filenos
2209
2210Returns a list whose first element is a vec of all filehandles that we care
2211about reading from and whose second element is a vec of all filehandles that
2212we care about writing to.  See the L<"process_connections"> method for details.
2213
2214=cut
2215
2216sub selector_filenos($) {
2217        my $self = shift;
2218        my($rin, $win) = ('', '');
2219
2220        foreach my $connection(@{$self->{connections}}) {
2221                next unless $connection->{socket};
2222                if($connection->{connected}) {
2223                        my $n = fileno($connection->{socket});
2224                        vec($rin, $n, 1) = 1;
2225                }
2226                if(!$connection->{connected} or $connection->{outbuff}) {
2227                        my $n = fileno($connection->{socket});
2228                        vec($win, $n, 1) = 1;
2229                }
2230        }
2231        return ($rin, $win);
2232}
2233
2234=item icon_checksum (ICONDATA)
2235
2236Returns a checksum of the buddy icon.  Use this in conjunction with the
2237C<icon_checksum> buddy info key to cache buddy icons.
2238
2239=cut
2240
2241sub icon_checksum($$) {
2242        my($self, $icon) = @_;
2243
2244        my $sum = 0;
2245        my $i = 0;
2246        for($i = 0; $i+1 < length($icon); $i += 2) {
2247                $sum += (ord(substr($icon, $i+1, 1)) << 8) + ord(substr($icon, $i, 1));
2248        }
2249
2250        $sum += ord(substr($icon, $i, 1)) if $i < length($icon);
2251
2252        $sum = (($sum & 0xFFFF0000) >> 16) + ($sum & 0x0000FFFF);
2253
2254        return $sum;
2255}
2256
2257=pod
2258
2259=item get_app_data ([GROUP[, BUDDY]])
2260
2261Gets application-specific data.  Returns a hashref whose keys are app-data IDs.
2262IDs with high-order byte 0x0001 are reserved for non-application-specific usage
2263and must be registered with the C<libfaim-aim-protocol@lists.sourceforge.net> list.
2264If you wish to set application-specific data, you should reserve a high-order
2265byte for your application by emailing C<libfaim-aim-protocol@lists.sourceforge.net>.
2266This data is stored in your server-side buddylist and so will be persistent,
2267even across machines.
2268
2269If C<GROUP> is present, a hashref for accessing data specific to that group
2270is returned.
2271
2272If C<BUDDY> is present, a hashref for accessing data specific to that buddy
2273is returned.
2274
2275Call L<"commit_buddylist"> to have the new data saved on the OSCAR server.
2276
2277=cut
2278
2279sub get_app_data($;$$) {
2280        my($self, $group, $buddy) = @_;
2281
2282        # We don't track changes to the contents of these hashes,
2283        # so mark as dirty and let BLI figure out whether anything really changed.
2284        if($group and $buddy) {
2285                my $bud = $self->{buddies}->{$group}->{members}->{$buddy};
2286                $bud->{__BLI_DIRTY} = 1;
2287                return $bud->{data};
2288        } elsif($group) {
2289                my $grp = $self->{buddies}->{$group};
2290                $grp->{__BLI_DIRTY} = 1;
2291                return $grp->{data};
2292        } else {
2293                return $self->{appdata};
2294        }
2295}
2296
2297=pod
2298
2299=item chat_invite (CHAT, MESSAGE, WHO)
2300
2301Deprecated.  Provided for compatibility with C<Net::AIM>.
2302Use the appropriate method of the C<Net::OSCAR::Connection::Chat> object
2303instead.
2304
2305=cut
2306
2307sub chat_invite($$$@) {
2308        my($self, $chat, $msg, @who) = @_;
2309        return must_be_on($self) unless $self->{is_on};
2310        foreach my $who(@who) { $chat->{connection}->invite($who, $msg); }
2311}
2312
2313=pod
2314
2315=item chat_leave (CHAT)
2316
2317Deprecated.  Provided for compatibility with C<Net::AIM>.
2318Use the appropriate method of the C<Net::OSCAR::Connection::Chat> object
2319instead.
2320
2321=item chat_send (CHAT, MESSAGE)
2322
2323Deprecated.  Provided for compatibility with C<Net::AIM>.
2324Use the appropriate method of the C<Net::OSCAR::Connection::Chat> object
2325instead.
2326
2327=cut
2328
2329sub chat_leave($$) { $_[1]->part(); }
2330sub chat_send($$$) { $_[1]->chat_send($_[2]); }
2331
2332=pod
2333
2334=back
2335
2336=head3 CALLBACKS
2337
2338=over 4
2339
2340=item auth_challenge (OSCAR, CHALLENGE, HASHSTR)
2341
2342B<New for Net::OSCAR 2.0>: AOL Instant Messenger has changed their encryption
2343mechanisms; instead of using the password in the hash, you B<may> now use
2344the MD5 hash of the password.  This allows your application to save the user's
2345password in hashed form instead of plaintext if you're saving passwords.
2346You must pass an extra parameter to C<auth_response> indicating that you are
2347using the new encryption scheme.  See below for an example.
2348
2349OSCAR uses an MD5-based challenge/response system for authentication so that the
2350password is never sent in plaintext over the network.  When a user wishes to sign on,
2351the OSCAR server sends an arbitrary number as a challenge.  The client must respond
2352with the MD5 digest of the concatenation of, in this order, the challenge, the password,
2353and an additional hashing string (currently always the string
2354"AOL Instant Messenger (SM)", but it is possible that this might change in the future.)
2355
2356If password is undefined in L<"signon">, this callback will be triggered when the
2357server sends a challenge during the signon process.  The client must reply with
2358the MD5 digest of CHALLENGE . MD5(password) . HASHSTR.  For instance, using the
2359L<MD5::Digest> module:
2360
2361        my($oscar, $challenge, $hashstr) = @_;
2362        my $md5 = Digest::MD5->new;
2363        $md5->add($challenge);
2364        $md5->add(md5("password"));
2365        $md5->add($hashstr);
2366        $oscar->auth_response($md5->digest, 1);
2367
2368Note that this functionality is only available for certain services.  It is
2369available for AIM but not ICQ.  Note also that the MD5 digest must be in binary
2370form, not the more common hex or base64 forms.
2371
2372=item log (OSCAR, LEVEL, MESSAGE)
2373
2374Use this callback if you don't want the log_print methods to just print to STDERR.
2375It is called when even C<MESSAGE> of level C<LEVEL> is called.  The levels are,
2376in order of increasing importance:
2377
2378=over 4
2379
2380=item OSCAR_DBG_NONE
2381
2382Really only useful for setting in the L<"loglevel"> method.  No information will
2383be logged.  The default loglevel.
2384
2385=item OSCAR_DBG_PACKETS
2386
2387Hex dumps of all incoming/outgoing packets.
2388
2389=item OSCAR_DBG_DEBUG
2390
2391Information useful for debugging C<Net::OSCAR>, and precious little else.
2392
2393=item OSCAR_DBG_SIGNON
2394
2395Like C<OSCAR_DBG_NOTICE>, but only for the signon process; this is where
2396problems are most likely to occur, so we provide this for the common case of
2397people who only want a lot of information during signon.  This may be deprecated
2398some-day and be replaced by a more flexible facility/level system, ala syslog.
2399
2400=item OSCAR_DBG_NOTICE
2401
2402=item OSCAR_DBG_INFO
2403
2404=item OSCAR_DBG_WARN
2405
2406=back
2407
2408Note that these symbols are imported into your namespace if and only if you use
2409the C<:loglevels> or C<:all> tags when importing the module (e.g. C<use Net::OSCAR qw(:standard :loglevels)>.)
2410
2411Also note that this callback is only triggered for events whose level is greater
2412than or equal to the loglevel for the OSCAR session.  The L<"loglevel"> method
2413allows you to get or set the loglevel.
2414
2415=back
2416
2417=head2 ERROR HANDLING
2418
2419=head3 CALLBACKS
2420
2421=over 4
2422
2423=item error (OSCAR, CONNECTION, ERROR, DESCRIPTION, FATAL)
2424
2425Called when any sort of error occurs (except see L<admin_error> below and
2426L<buddylist_error> in L<BUDDIES AND BUDDYLISTS>.)
2427
2428C<CONNECTION> is the particular connection which generated the error - the C<log_print> method of
2429C<Net::OSCAR::Connection> may be useful, as may be getting C<$connection-E<gt>{description}>.
2430C<DESCRIPTION> is a nicely formatted description of the error.  C<ERROR> is an error number.
2431
2432If C<FATAL> is non-zero, the error was fatal and the connection to OSCAR has been
2433closed.
2434
2435=item snac_unknown (OSCAR, CONNECTION, SNAC, DATA)
2436
2437Called when Net::OSCAR receives a message from the OSCAR server which
2438it doesn't known how to handle.  The default handler for this callback
2439will print out the unknown SNAC.
2440
2441C<CONNECTION> is the C<Net::OSCAR::Connection> object on which the unknkown
2442message was received.  C<SNAC> is a hashref with keys such as C<family>, C<subtype>, C<flags1>, and
2443C<flags2>.
2444
2445=back
2446
2447=cut
2448
2449sub do_callback($@) {
2450        my $callback = shift;
2451        return unless $_[0]->{callbacks}->{$callback};
2452        &{$_[0]->{callbacks}->{$callback}}(@_);
2453}
2454sub set_callback { $_[1]->{callbacks}->{$_[0]} = $_[2]; }
2455
2456sub callback_error(@) { do_callback("error", @_); }
2457sub callback_buddy_in(@) { do_callback("buddy_in", @_); }
2458sub callback_buddy_out(@) { do_callback("buddy_out", @_); }
2459sub callback_im_in(@) { do_callback("im_in", @_); }
2460sub callback_chat_joined(@) { do_callback("chat_joined", @_); }
2461sub callback_chat_buddy_in(@) { do_callback("chat_buddy_in", @_); }
2462sub callback_chat_buddy_out(@) { do_callback("chat_buddy_out", @_); }
2463sub callback_chat_im_in(@) { do_callback("chat_im_in", @_); }
2464sub callback_chat_invite(@) { do_callback("chat_invite", @_); }
2465sub callback_buddy_info(@) { do_callback("buddy_info", @_); }
2466sub callback_evil(@) { do_callback("evil", @_); }
2467sub callback_chat_closed(@) { do_callback("chat_closed", @_); }
2468sub callback_buddylist_error(@) { do_callback("buddylist_error", @_); }
2469sub callback_buddylist_ok(@) { do_callback("buddylist_ok", @_); }
2470sub callback_buddylist_changed(@) { do_callback("buddylist_changed", @_); }
2471sub callback_admin_error(@) { do_callback("admin_error", @_); }
2472sub callback_admin_ok(@) { do_callback("admin_ok", @_); }
2473sub callback_new_buddy_icon(@) { do_callback("new_buddy_icon", @_); }
2474sub callback_buddy_icon_uploaded(@) { do_callback("buddy_icon_uploaded", @_); }
2475sub callback_buddy_icon_downloaded(@) { do_callback("buddy_icon_downloaded", @_); }
2476sub callback_rate_alert(@) { do_callback("rate_alert", @_); }
2477sub callback_signon_done(@) { do_callback("signon_done", @_); }
2478sub callback_log(@) { do_callback("log", @_); }
2479sub callback_typing_status(@) { do_callback("typing_status", @_); }
2480sub callback_extended_status(@) { do_callback("extended_status", @_); }
2481sub callback_im_ok(@) { do_callback("im_ok", @_); }
2482sub callback_connection_changed(@) { do_callback("connection_changed", @_); }
2483sub callback_auth_challenge(@) { do_callback("auth_challenge", @_); }
2484sub callback_stealth_changed(@) { do_callback("stealth_changed", @_); }
2485sub callback_snac_unknown(@) { do_callback("snac_unknown", @_); }
2486sub callback_rendezvous_reject(@) { do_callback("rendezvous_reject", @_); }
2487sub callback_rendezvous_accept(@) { do_callback("rendezvous_accept", @_); }
2488sub callback_buddylist_in(@) { do_callback("buddylist_in", @_); }
2489
2490sub set_callback_error($\&) { set_callback("error", @_); }
2491sub set_callback_buddy_in($\&) { set_callback("buddy_in", @_); }
2492sub set_callback_buddy_out($\&) { set_callback("buddy_out", @_); }
2493sub set_callback_im_in($\&) { set_callback("im_in", @_); }
2494sub set_callback_chat_joined($\&) { set_callback("chat_joined", @_); }
2495sub set_callback_chat_buddy_in($\&) { set_callback("chat_buddy_in", @_); }
2496sub set_callback_chat_buddy_out($\&) { set_callback("chat_buddy_out", @_); }
2497sub set_callback_chat_im_in($\&) { set_callback("chat_im_in", @_); }
2498sub set_callback_chat_invite($\&) { set_callback("chat_invite", @_); }
2499sub set_callback_buddy_info($\&) { set_callback("buddy_info", @_); }
2500sub set_callback_evil($\&) { set_callback("evil", @_); }
2501sub set_callback_chat_closed($\&) { set_callback("chat_closed", @_); }
2502sub set_callback_buddylist_error($\&) { set_callback("buddylist_error", @_); }
2503sub set_callback_buddylist_ok($\&) { set_callback("buddylist_ok", @_); }
2504sub set_callback_buddylist_changed($\&) { set_callback("buddylist_changed", @_); }
2505sub set_callback_admin_error($\&) { set_callback("admin_error", @_); }
2506sub set_callback_admin_ok($\&) { set_callback("admin_ok", @_); }
2507sub set_callback_new_buddy_icon($\&) {
2508        croak "This client does not support buddy icons." unless $_[0]->{capabilities}->{buddy_icons};
2509        set_callback("new_buddy_icon", @_);
2510}
2511sub set_callback_buddy_icon_uploaded($\&) {
2512        croak "This client does not support buddy icons." unless $_[0]->{capabilities}->{buddy_icons};
2513        set_callback("buddy_icon_uploaded", @_);
2514}
2515sub set_callback_buddy_icon_downloaded($\&) {
2516        croak "This client does not support buddy icons." unless $_[0]->{capabilities}->{buddy_icons};
2517        set_callback("buddy_icon_downloaded", @_);
2518}
2519sub set_callback_rate_alert($\&) { set_callback("rate_alert", @_); }
2520sub set_callback_signon_done($\&) { set_callback("signon_done", @_); }
2521sub set_callback_log($\&) { set_callback("log", @_); }
2522sub set_callback_typing_status($\&) {
2523        croak "This client does not support typing status notification." unless $_[0]->{capabilities}->{typing_status};
2524        set_callback("typing_status", @_);
2525}
2526sub set_callback_extended_status($\&) {
2527        croak "This client does not support extended status messages." unless $_[0]->{capabilities}->{extended_status};
2528        set_callback("extended_status", @_);
2529}
2530sub set_callback_im_ok($\&) { set_callback("im_ok", @_); }
2531sub set_callback_connection_changed($\&) { set_callback("connection_changed", @_); }
2532sub set_callback_auth_challenge($\&) { set_callback("auth_challenge", @_); }
2533sub set_callback_stealth_changed($\&) { set_callback("stealth_changed", @_); }
2534sub set_callback_snac_unknown($\&) { set_callback("snac_unknown", @_); }
2535sub set_callback_rendezvous_reject($\&) { set_callback("snac_rendezvous_reject", @_); }
2536sub set_callback_rendezvous_accept($\&) { set_callback("snac_rendezvous_accept", @_); }
2537sub set_callback_buddylist_in($\&) {
2538        croak "This client does not support buddy list transfer." unless $_[0]->{capabilities}->{buddy_list_transfer};
2539        set_callback("buddylist_in", @_);
2540}
2541
2542=pod
2543
2544=head1 CHAT CONNECTIONS
2545
2546Aside from the methods listed here, there are a couple of methods of the
2547C<Net::OSCAR::Connection::Chat> object that are important for implementing chat
2548functionality.  C<Net::OSCAR::Connection::Chat> is a descendent of C<Net::OSCAR::Connection>.
2549
2550=over 4
2551
2552=item invite (WHO, MESSAGE)
2553
2554Invite somebody into the chatroom.
2555
2556=item chat_send (MESSAGE[, NOREFLECT[, AWAY]])
2557
2558Sends a message to the chatroom.  If the NOREFLECT parameter is
2559present, you will not receive the message as an incoming message
2560from the chatroom.  If AWAY is present, the message was generated
2561as an automatic reply, perhaps because you have an away message set.
2562
2563=item part
2564
2565Leave the chatroom.
2566
2567=item url
2568
2569Returns the URL for the chatroom.  Use this to associate a chat invitation
2570with the chat_joined that C<Net::OSCAR> sends when you've join the chatroom.
2571
2572=item name
2573
2574Returns the name of the chatroom.
2575
2576=item exchange
2577
2578Returns the exchange of the chatroom.
2579This is normally 4 but can be 5 for certain chatrooms.
2580
2581=back
2582
2583=head1 RATE LIMIT OVERVIEW
2584
2585The OSCAR server has the ability to specify restrictions on the rate at which
2586the client, your application, can send it commands.  These constraints can be independently
2587set and tracked for different classes of command, so there might be one limit on how
2588fast you can send IMs and another on how fast you can request away messages.
2589If your application exceeds these limits, the OSCAR server may start ignoring it or
2590may even disconnect your session.
2591
2592See also the reference section on L<rate limits|"RATE LIMITS">.
2593
2594=head2 RATE MANAGEMENT MODES
2595
2596C<Net::OSCAR> supports three different schemes for managing these limits.  Pass the
2597scheme you want to use as the value of the C<rate_manage> key when you invoke the
2598L<"new"> method.
2599
2600=head3 OSCAR_RATE_MANAGE_NONE
2601
2602The default.  C<Net::OSCAR> will not keep track of what the limits are,
2603much less how close you're coming to reaching them.  If the OSCAR server complains
2604that you are sending too fast, your L<"rate_alert"> callback will be triggered.
2605
2606=head3 OSCAR_RATE_MANAGE_AUTO
2607
2608In this mode, C<Net::OSCAR> will prevent your application from exceeding the limits.
2609If you try to send a command which would cause the limits to be exceeded, your
2610command will be queued.  You will be notified when this happens via the L<"rate_alert">
2611callback.  B<This mode is only available if your application implements C<Net::OSCAR>'s
2612L<time-delayed event system|"TIME-DELAYED EVENTS">.>
2613
2614=head3 OSCAR_RATE_MANAGE_MANUAL
2615
2616In this mode, C<Net::OSCAR> will track what the limits are and how close you're
2617coming to reaching them, but won't do anything about it.  Your application should use the
2618L<"rate_level">, L<"rate_limits">, and L<"would_make_rate_level"> methods to
2619control its own rate.
2620
2621=head1 TIME-DELAYED EVENTS
2622
2623=head1 CONSTANTS
2624
2625The following constants are defined when C<Net::OSCAR> is imported with the
2626C<:standard> tag.  Unless indicated otherwise, the constants are magical
2627scalars - they return different values in string and numeric contexts (for
2628instance, an error message and an error number.)
2629
2630=over 4
2631
2632=item ADMIN_TYPE_PASSWORD_CHANGE
2633
2634=item ADMIN_TYPE_EMAIL_CHANGE
2635
2636=item ADMIN_TYPE_SCREENNAME_FORMAT
2637
2638=item ADMIN_TYPE_ACCOUNT_CONFIRM
2639
2640=item ADMIN_ERROR_UNKNOWN
2641
2642=item ADMIN_ERROR_BADPASS
2643
2644=item ADMIN_ERROR_BADINPUT
2645
2646=item ADMIN_ERROR_BADLENGTH
2647
2648=item ADMIN_ERROR_TRYLATER
2649
2650=item ADMIN_ERROR_REQPENDING
2651
2652=item ADMIN_ERROR_CONNREF
2653
2654=item VISMODE_PERMITALL
2655
2656=item VISMODE_DENYALL
2657
2658=item VISMODE_PERMITSOME
2659
2660=item VISMODE_DENYSOME
2661
2662=item VISMODE_PERMITBUDS
2663
2664=item RATE_CLEAR
2665
2666=item RATE_ALERT
2667
2668=item RATE_LIMIT
2669
2670=item RATE_DISCONNECT
2671
2672=item OSCAR_RATE_MANAGE_NONE
2673
2674=item OSCAR_RATE_MANAGE_AUTO
2675
2676=item OSCAR_RATE_MANAGE_MANUAL
2677
2678=item GROUPPERM_OSCAR
2679
2680=item GROUPPERM_AOL
2681
2682=item TYPINGSTATUS_STARTED
2683
2684=item TYPINGSTATUS_TYPING
2685
2686=item TYPINGSTATUS_FINISHED
2687
2688=back
2689
2690=head1 Net::AIM Compatibility
2691
2692Here are the major differences between the C<Net::OSCAR> interface
2693and the C<Net::AIM> interface:
2694
2695=over 4
2696
2697=item *
2698
2699No get/set method.
2700
2701=item *
2702
2703No newconn/getconn method.
2704
2705=item *
2706
2707No group parameter for add_permit or add_deny.
2708
2709=item *
2710
2711Many differences in chat handling.
2712
2713=item *
2714
2715No chat_whisper.
2716
2717=item *
2718
2719No encode method - it isn't needed.
2720
2721=item *
2722
2723No send_config method - it isn't needed.
2724
2725=item *
2726
2727No send_buddies method - we don't keep a separate local buddylist.
2728
2729=item *
2730
2731No normalize method - it isn't needed.  Okay, there is a normalize
2732function in C<Net::OSCAR::Utility>, but I can't think of any reason
2733why it would need to be used outside of the module internals.  C<Net::OSCAR>
2734provides the same functionality through the C<Net::OSCAR::Screenname> class.
2735
2736=item *
2737
2738Different callbacks with different parameters.
2739
2740=back
2741
2742=head1 MISCELLANEOUS INFO
2743
2744There are two programs included with the C<Net::OSCAR> distribution.
2745C<oscartest> is half a reference implementation of a C<Net::OSCAR> client
2746and half a tool for testing this library.  C<snacsnatcher> is a tool designed
2747for analyzing the OSCAR protocol from libpcap-format packet captures, but
2748it isn't particularly well-maintained; the Ethereal sniffer does a good
2749job at this nowadays.
2750
2751There is a class C<Net::OSCAR::Screenname>.  OSCAR screennames
2752are case and whitespace insensitive, and if you do something like
2753C<$buddy = new Net::OSCAR::Screenname "Matt Sachs"> instead of
2754C<$buddy = "Matt Sachs">, this will be taken care of for you when
2755you use the string comparison operators (eq, ne, cmp, etc.)
2756
2757C<Net::OSCAR::Connection>, the class used for connection objects,
2758has some methods that may or may not be useful to you.
2759
2760=over 4
2761
2762=item get_filehandle
2763
2764Returns the filehandle used for the connection.  Note that this is a method
2765of C<Net::OSCAR::Connection>, not C<Net::OSCAR>.
2766
2767=item process_one (CAN_READ, CAN_WRITE, HAS_ERROR)
2768
2769Call this when a C<Net::OSCAR::Connection> is ready for reading and/or
2770writing.  You might call this yourself instead of using L<"process_connections">
2771when, for instance, using the L<"connection_changed"> callback in conjunction with
2772C<IO::Poll> instead of C<select>.  The C<CAN_READ> and C<CAN_WRITE> parameters
2773should be non-zero if the connection is ready for the respective operations to be
2774performed and zero otherwise.  If and only if there was a socket error with the
2775connection, set C<HAS_ERROR> to non-zero.
2776
2777=item session
2778
2779Returns the C<Net::OSCAR> object associated with this C<Net::OSCAR::Connection>.
2780
2781=back
2782
2783=head1 USER INFORMATION
2784
2785Methods which return information about a user, such as L<"buddy">, will return
2786the information in the form of a hash.  The keys of the hash are the following --
2787note that any of these may be absent.
2788
2789=over 4
2790
2791=item online
2792
2793The user is signed on.  If this key is not present, all of the other keys may not
2794be present.
2795
2796=item screenname
2797
2798The formatted version of the user's screenname.  This includes all spacing and
2799capitalization.  This is a C<Net::OSCAR::Screenname> object, so you don't have to
2800worry about the fact that it's case and whitespace insensitive when comparing it.
2801
2802=item comment
2803
2804A user-defined comment associated with the buddy.  See L<"set_buddy_comment">.
2805Note that this key will be present but undefined if there is no comment.
2806
2807=item alias
2808
2809A user-defined alias for the buddy.  See L<"set_buddy_alias">.
2810Note that this key will be present but undefined if there is no alias.
2811
2812=item extended_status
2813
2814The user's extended status message, if one is set, will be in this key.
2815This requires that you set the C<extended_status> capability when
2816creating the C<Net::OSCAR> object.
2817
2818=item trial
2819
2820The user's account has trial status.
2821
2822=item aol
2823
2824The user is accessing the AOL Instant Messenger service from America OnLine.
2825
2826=item free
2827
2828Opposite of aol.
2829
2830=item away
2831
2832The user is away.
2833
2834=item admin
2835
2836The user is an administrator.
2837
2838=item mobile
2839
2840The user is using a mobile device.
2841
2842=item typing_status
2843
2844The user is known to support typing status notification.  We only find this out if they send us an IM.
2845
2846=item capabilities
2847
2848The user's capabilities.  This is a reference to a hash whose keys are the user's capabilities, and
2849whose values are descriptions of their respective capabilities.
2850
2851=item icon
2852
2853The user's buddy icon, if available.
2854
2855=item icon_checksum
2856
2857The checksum time of the user's buddy icon, if available.  Use this, in conjunction with
2858the L<icon_checksum> method, to cache buddy icons.
2859
2860=item icon_timestamp
2861
2862The modification timestamp of the user's buddy icon, if available.
2863
2864=item icon_length
2865
2866The length of the user's buddy icon, if available.
2867
2868=item membersince
2869
2870Time that the user's account was created, in the same format as the C<time> function.
2871
2872=item onsince
2873
2874Time that the user signed on to the service, in the same format as the C<time> function.
2875
2876=item idle_since
2877
2878Time, in seconds since Jan 1st 1970, since which the user has been idle.  This will only
2879be present if the user is idle.  To figure out how long the user has been idle for,
2880subtract this value from C<time()> .
2881
2882=item evil
2883
2884Evil (warning) level for the user.
2885
2886=back
2887
2888Some keys; namely, C<typing_status> and C<icon_checksum>, may be available for people
2889who the user has communicated with but who are not on the user's buddylist.
2890
2891=cut
2892
2893
2894=pod
2895
2896=head1 ICQ-SPECIFIC INFORMATION
2897
2898ICQ support isn't nearly as well-tested as AIM support, and ICQ-specific
2899features aren't being particularly actively developed.  Patches for ICQ-isms
2900are welcome.  The initial patch enabling us to sign on to ICQ was provided by Sam Wong.
2901
2902=head2 ICQ METHODS
2903
2904=over 4
2905
2906=item get_icq_info (UIN)
2907
2908Requests ICQ-specific information.  See also the L<"buddy_icq_info"> callback.
2909
2910=cut
2911
2912sub get_icq_info($$) {
2913        my($self, $uin) = @_;
2914
2915        $self->svcdo(CONNTYPE_BOS, protobit => "ICQ_meta_request", protodata => {
2916                our_uin => $self->{screenname},
2917                type => 2000,
2918                seqno => ++$self->{bos}->{icq_seqno},
2919                typedata => protoparse($self, "ICQ_meta_info_request")->pack(uin => $uin)
2920        });
2921}
2922
2923=pod
2924
2925=back
2926
2927=head2 ICQ CALLBACKS
2928
2929=over 4
2930
2931=item buddy_icq_info (OSCAR, UIN, ICQ DATA)
2932
2933The result of a L<"get_icq_info"> call.  Data is a hashref with the following keys, the value
2934of each key is a either a hashref or undefined:
2935
2936=over 4
2937
2938=item basic
2939
2940=over 4
2941
2942=item nickname
2943
2944=item firstname
2945
2946=item lastname
2947
2948=item email
2949
2950=item gmt_offset
2951
2952=item authorization
2953
2954=item web_aware
2955
2956=item direct_connect_permissions
2957
2958=item publish_primary_email
2959
2960=back
2961
2962=item home
2963
2964=over 4
2965
2966=item city
2967
2968=item state
2969
2970=item phone_num
2971
2972=item fax_num
2973
2974=item address
2975
2976=item cell_phone_num
2977
2978=item zip_code
2979
2980=item country_code
2981
2982=back
2983
2984=item office
2985
2986=over 4
2987
2988=item city
2989
2990=item state
2991
2992=item phone_num
2993
2994=item fax_num
2995
2996=item address
2997
2998=item zip_code
2999
3000=item country_code
3001
3002=item company
3003
3004=item department
3005
3006=item position
3007
3008=item occupation
3009
3010=item office_website
3011
3012=back
3013
3014=item background
3015
3016=over 4
3017
3018=item age
3019
3020=item gender
3021
3022=item homepage
3023
3024=item birth_year
3025
3026=item birth_month
3027
3028=item birth_day
3029
3030=item spoken_languages
3031
3032This key is a listref containing the langauges the user speaks.
3033
3034=item origin_city
3035
3036=item origin_state
3037
3038=item origin_country
3039
3040=item marital_status
3041
3042=back
3043
3044=item notes
3045
3046This key is a simple scalar.
3047
3048=item email_addresses
3049
3050This key is a listref, each element of which is a hashref with the following keys:
3051
3052=over 4
3053
3054=item publish
3055
3056=item address
3057
3058=back
3059
3060=item interests
3061
3062This key is a listref, each element of which is a hashref with the following keys:
3063
3064=over 4
3065
3066=item category
3067
3068=item interest
3069
3070=back
3071
3072=item past_affiliations
3073
3074This key is a listref, each element of which is a hashref with the following keys:
3075
3076=over 4
3077
3078=item category
3079
3080=item affiliation
3081
3082=back
3083
3084=item present_affiliations
3085
3086As per above.
3087
3088=item homepage
3089
3090=over 4
3091
3092=item category
3093
3094=item keywords
3095
3096=back
3097
3098=back
3099
3100=back
3101
3102=cut
3103
3104sub callback_buddy_icq_info(@) { do_callback("buddy_icq_info", @_); }
3105sub set_callback_buddy_icq_info($\&) { set_callback("buddy_icq_info", @_); }
3106
3107
3108=pod
3109
3110=head1 HIGH-PERFORMANCE EVENT PROCESSING
3111
3112A second way of doing event processing is designed to make it easy to integrate C<Net::OSCAR> into
3113an existing C<select>-based event loop, especially one where you have many C<Net::OSCAR> objects.
3114Simply call the L<"process_connections"> method with references to the lists of readers, writers,
3115and errors given to you by C<select>.  Connections that don't belong to the object will be ignored,
3116and connections that do belong to the object will be removed from the C<select> lists so that you
3117can use the lists for your own purposes.
3118Here is an example that demonstrates how to use this method with multiple C<Net::OSCAR> objects:
3119
3120        my $ein = $rin | $win;
3121        select($rin, $win, $ein, 0.01);
3122        foreach my $oscar(@oscars) {
3123                $oscar->process_connections(\$rin, \$win, \$ein);
3124        }
3125
3126        # Now $rin, $win, and $ein only have the file descriptors not
3127        # associated with any of the OSCAR objects in them - we can
3128        # process our events.
3129
3130The third way of doing connection processing uses the L<"connection_changed">
3131callback in conjunction with C<Net::OSCAR::Connection>'s L<"process_one"> method.
3132This method, in conjunction with C<IO::Poll>, probably offers the highest performance
3133in situations where you have a long-lived application which creates and destroys many
3134C<Net::OSCAR> sessions; that is, an application whose list of file descriptors to
3135monitor will likely be sparse.  However, this method is the most complicated.
3136What you need to do is call C<IO::Poll::mask> inside of the L<"connection_changed">
3137callback.  That part's simple.  The tricky bit is figuring out which
3138C<Net::OSCAR::Connection::process_one>'s to call and how to call them.  My recommendation
3139for doing this is to use a hashmap whose keys are the file descriptors of everything
3140you're monitoring in the C<IO::Poll> - the FDs can be retrieved by doing
3141C<fileno($connection-E<gt>get_filehandle)> inside of the L<"connection_changed"> -
3142and then calling C<@handles = $poll-E<gt>handles(POLLIN | POLLOUT | POLLERR | POLLHUP)>
3143and walking through the handles.
3144
3145For optimum performance, use the L<"connection_changed"> callback.
3146
3147=head1 HISTORY
3148
3149=over 4
3150
3151=item *
3152
31531.925, 2006-02-06
3154
3155=over 4
3156
3157=item *
3158
3159Many buddylist performance enhancements and bug fixes.
3160
3161=item *
3162
3163Added support for receiving dynamic buddylist changes from the server
3164(C<callback_buddylist_changed>.)
3165
3166=item *
3167
3168Add support buddylist transfer (C<set_callback_buddylist_in>.)
3169
3170=item *
3171
3172Miscellaneous performance and scalability enhancements.
3173
3174=item *
3175
3176Added experimental migration support.
3177
3178=item *
3179
3180Added advanced rate limit management API.
3181
3182=item *
3183
3184Added C<oscarserv> server for testing.
3185
3186=item *
3187
3188Audited screennames exposed to application to verify that they are
3189C<Net::OSCAR::Screenname> objects everywhere.
3190
3191=item *
3192
3193Began work on file transfer.
3194
3195=item *
3196
3197Connection status fix for compatibility with POE.
3198
3199=back
3200
3201=item *
3202
32031.907, 2004-09-22
3204
3205=over 4
3206
3207=item *
3208
3209Fixed assert failure on certain invalid input ("Buddy Trikill" crash)
3210
3211=back
3212
3213=item *
3214
32151.906, 2004-08-28
3216
3217=over 4
3218
3219=item *
3220
3221Reorganized documentation
3222
3223=back
3224
3225=item *
3226
32271.904, 2004-08-26
3228
3229=over 4
3230
3231=item *
3232
3233Add $Net::OSCAR::XML::NO_XML_CACHE to prevent use of cached XML parse tree,
3234and skip tests if we can't load Test::More or XML::Parser.
3235
3236=back
3237
3238=item *
3239
32401.903, 2004-08-26
3241
3242=over 4
3243
3244=item *
3245
3246Generate XML parse tree at module build time so that users don't need to have
3247XML::Parser and expat installed.
3248
3249=back
3250
3251=item *
3252
32531.902, 2004-08-26
3254
3255=over 4
3256
3257=item *
3258
3259Fixes to buddy icon upload and chat invitation decline
3260
3261=item *
3262
3263Increase performance by doing lazy generation of certain debugging info
3264
3265=back
3266
3267=item *
3268
32691.901, 2004-08-24
3270
3271=over 4
3272
3273=item *
3274
3275Lots of buddylist-handling bug fixes; should fix intermittent buddylist modification errors
3276and errors only seen when modifying certain screennames; Roy C. rocks.
3277
3278=item *
3279
3280We now require Perl 5.6.1.
3281
3282=item *
3283
3284Workaround for bug in Perl pre-5.8.4 which manifested as a "'basic OSCAR services' isn't numeric"
3285warning followed by the program freezing.
3286
3287=item *
3288
3289C<add_group> and C<remove_group> methods added.
3290
3291=item *
3292
3293Fixed a potential memory leak which could impact programs which create many transient Net::OSCAR
3294objects.
3295
3296=back
3297
3298=item *
3299
33001.900, 2004-08-17
3301
3302=over 4
3303
3304=item *
3305
3306Wrote new XML-based protocol back-end with reasonably comprehensive test-suite.
3307Numerous protocol changes; we now emulate AOL's version 5.5 client.
3308
3309=item *
3310
3311Rewrote snacsnatcher, an OSCAR protocol analysis tool
3312
3313=item *
3314
3315Reorganized documentation
3316
3317=item *
3318
3319ICQ meta-info support: get_icq_info method, buddy_icq_info callback
3320
3321=item *
3322
3323Stealth mode support: is_stealth and set_stealth methods, stealth_changed callback, stealth signon key
3324
3325=item *
3326
3327More flexible unknown SNAC handling: snac_unknown callback
3328
3329=item *
3330
3331Application can give Net::OSCAR the MD5-hashed password instead of the cleartext password
3332(pass_is_hashed signon key).  This is useful if your application is storing user passwords.
3333
3334=item *
3335
3336Inability to set blocking on Win32 is no longer fatal.  Silly platform.
3337
3338=item *
3339
3340Fixed chat functionality.
3341
3342=back
3343
3344=item *
3345
33461.11, 2004-02-13
3347
3348=over 4
3349
3350=item *
3351
3352Fixed presence-related problems modifying some buddylists
3353
3354=back
3355
3356=item *
3357
33581.10, 2004-02-10
3359
3360=over 4
3361
3362=item *
3363
3364Fixed idle time handling; user info hashes now have an 'idle_since' key,
3365which you should use instead of the old 'idle' key.  Subtract C<idle_since>
3366from C<time()> to get the length of time for which the user has been idle.
3367
3368=item *
3369
3370Fixed buddylist type 5 handling; this fixes problems modifying the buddylists
3371of recently-created screennames.
3372
3373=back
3374
3375=item *
3376
33771.01, 2004-01-06
3378
3379=over 4
3380
3381=item *
3382
3383Fixed buddy ID generation (problems adding buddies)
3384
3385=back
3386
3387=item *
3388
33891.00, 2004-01-03
3390
3391=over 4
3392
3393=item *
3394
3395Documented requirement to wait for buddylist_foo callback between calls to commit_buddylist
3396
3397=item *
3398
3399Fixed handling of idle time (zoyboy22)
3400
3401=item *
3402
3403More flexible signon method
3404
3405=item *
3406
3407Added buddy alias support
3408
3409=item *
3410
3411Buddy icon support
3412
3413=item *
3414
3415Typing notification support
3416
3417=item *
3418
3419mac.com screenname support
3420
3421=item *
3422
3423Support for communicating with ICQ users from AIM
3424
3425=item *
3426
3427iChat extended status message support
3428
3429=item *
3430
3431We now emulate AOL Instant Messenger for Windows 5.2
3432
3433=item *
3434
3435We now parse the capabilities of other users
3436
3437=item *
3438
3439Attempts at Win32 (non-cygwin) support
3440
3441=back
3442
3443=item *
3444
34450.62, 2002-02-25
3446
3447=over 4
3448
3449=item *
3450
3451Error handling slightly improved; error 29 is no longer unknown.
3452
3453=item *
3454
3455A minor internal buddylist enhancement
3456
3457=item *
3458
3459snacsnatcher fixes
3460
3461=back
3462
3463=item *
3464
34650.61, 2002-02-17
3466
3467=over 4
3468
3469=item *
3470
3471Fixed connection handling
3472
3473=back
3474
3475=item *
3476
34770.60, 2002-02-17
3478
3479=over 4
3480
3481=item *
3482
3483Various connection_changed fixes, including the new readwrite status.
3484
3485=item *
3486
3487Added Net::OSCAR::Connection::session method
3488
3489=item *
3490
3491Improved Net::OSCAR::Connection::process_one, documented it, and documented using it
3492
3493=back
3494
3495=item *
3496
34970.59, 2002-02-15
3498
3499=over 4
3500
3501=item *
3502
3503Protocol fixes - solves problem with AOL calling us an unauthorized client
3504
3505=item *
3506
3507Better handling of socket errors, especially when writing
3508
3509=item *
3510
3511Minor POD fixes
3512
3513=back
3514
3515=item *
3516
35170.58, 2002-01-20
3518
3519=over 4
3520
3521=item *
3522
3523Send buddylist deletions before adds - needed for complex BL mods (loadbuddies)
3524
3525=item *
3526
3527Added hooks to allow client do MD5 digestion for authentication (auth_challenge
3528callback, Net::OSCAR::auth_response method)
3529
3530=back
3531
3532=item *
3533
35340.57, 2002-01-16
3535
3536=over 4
3537
3538=item *
3539
3540Send callback_chat_joined correctly when joining an existing chat
3541
3542=item *
3543
3544Don't activate OldPerl fixes for perl 5.6.0
3545
3546=item *
3547
3548Ignore chats that we're already in
3549
3550=back
3551
3552=item *
3553
35540.56, 2002-01-16
3555
3556=over 4
3557
3558=item *
3559
3560Fixed rate handling
3561
3562=item *
3563
3564Send multiple buddylist modifications per SNAC
3565
3566=item *
3567
3568Detect when someone else signs on with your screenname
3569
3570=item *
3571
3572Corrected attribution of ICQ support
3573
3574=back
3575
3576=item *
3577
35780.55, 2001-12-29
3579
3580=over 4
3581
3582=item *
3583
3584Preliminary ICQ support, courtesy of SDiZ Chen (actually, Sam Wong).
3585
3586=item *
3587
3588Restored support for pre-5.6 perls - reverted from C<IO::Socket> to C<Socket>.
3589
3590=item *
3591
3592Corrected removal of buddylist entries and other buddylist-handling improvements
3593
3594=item *
3595
3596Improved rate handling - new C<worrisome> parameter to rate_alert callback
3597
3598=item *
3599
3600Removed remaining C<croak> from C<OSCAR::Connection>
3601
3602=item *
3603
3604Added is_on method
3605
3606=back
3607
3608=item *
3609
36100.50, 2001-12-23
3611
3612=over 4
3613
3614=item *
3615
3616Fixes for the "crap out on 'connection reset by peer'" and "get stuck and slow down in Perl_sv_2bool" bugs!
3617
3618=item *
3619
3620Correct handling of very large (over 100 items) buddylists.
3621
3622=item *
3623
3624We can now join exchange 5 chats.
3625
3626=item *
3627
3628Fixes in modifying permit mode.
3629
3630=item *
3631
3632Updated copyright notice courtesy of AOL's lawyers.
3633
3634=item *
3635
3636Switch to IO::Socket for portability in set_blocking.
3637
3638=back
3639
3640=item *
3641
36420.25, 2001-11-26
3643
3644=over 4
3645
3646=item *
3647
3648Net::OSCAR is now in beta!
3649
3650=item *
3651
3652We now work with perl 5.005 and even 5.004
3653
3654=item *
3655
3656Try to prevent weird Net::OSCAR::Screenname bug where perl gets stuck in Perl_sv_2bool
3657
3658=item *
3659
3660Fixed problems with setting visibility mode and adding to deny list (thanks, Philip)
3661
3662=item *
3663
3664Added some methods to allow us to be POE-ified
3665
3666=item *
3667
3668Added guards around a number of methods to prevent the user from trying to do stuff before s/he's finished signing on.
3669
3670=item *
3671
3672Fix *incredibly* stupid error in NO_to_BLI that ate group names
3673
3674=item *
3675
3676Fixed bad bug in log_printf
3677
3678=item *
3679
3680Buddylist error handling changes
3681
3682=item *
3683
3684Added chat_decline command
3685
3686=item *
3687
3688Signon, signoff fixes
3689
3690=item *
3691
3692Allow AOL screennames to sign on
3693
3694=item *
3695
3696flap_get crash fixes
3697
3698=back
3699
3700=item *
3701
37020.09, 2001-10-01
3703
3704=over 4
3705
3706=item *
3707
3708Crash and undefined value fixes
3709
3710=item *
3711
3712New method: im_ok
3713
3714=item *
3715
3716New method: rename_group, should fix "Couldn't get group name" error.
3717
3718=item *
3719
3720Fix for buddy_in callback and data
3721
3722=item *
3723
3724Better error handling when we can't resolve a host
3725
3726=item *
3727
3728Vastly improved logging infrastructure - debug_print(f) replaced with log_print(f). debug_print callback is now called log and has an extra parameter.
3729
3730=item *
3731
3732Fixed MANIFEST - we don't actually use Changes (and we do use Screenname.pm)
3733
3734=item *
3735
3736blinternal now automagically enforces the proper structure (the right things become Net::OSCAR::TLV tied hashes and the name and data keys are automatically created) upon vivification.  So, you can do $bli-E<gt>{0}-E<gt>{1}-E<gt>{2}-E<gt>{data}-E<gt>{0x3} = "foo" without worrying if 0, 1, 2, or data have been tied.  Should close bug #47.
3737
3738=back
3739
3740=item *
3741
37420.08, 2001-09-07
3743
3744=over 4
3745
3746=item *
3747
3748Totally rewritten buddylist handling.  It is now much cleaner, bug-resistant,
3749and featureful.
3750
3751=item *
3752
3753Many, many internal changes that I don't feel like enumerating.
3754Hey, there's a reason that I haven't declared the interface stable yet! ;)
3755
3756=item *
3757
3758New convenience object: Net::OSCAR::Screenname
3759
3760=item *
3761
3762Makefile.PL: Fixed perl version test and compatibility with BSD make
3763
3764=back
3765
3766=item *
3767
37680.07, 2001-08-13
3769
3770=over 4
3771
3772=item *
3773
3774A bunch of Makefile.PL fixes
3775
3776=item *
3777
3778Fixed spurious admin_error callback and prevent user from having multiple
3779pending requests of the same type.  (closes #39)
3780
3781=item *
3782
3783Head off some potential problems with set_visibility.  (closes #34)
3784
3785=item *
3786
3787Removed connections method, added selector_filenos
3788
3789=item *
3790
3791Added error number 29 (too many recent signons from your site) to Net::OSCAR::Common.
3792
3793=item *
3794
3795We now explicitly perl 5.6.0 or newer.
3796
3797=back
3798
3799=item *
3800
38010.06, 2001-08-12
3802
3803=over 4
3804
3805=item *
3806
3807Prevent sending duplicate signon_done messages
3808
3809=item *
3810
3811Don't addconn after crapping out!
3812
3813=item *
3814
3815Don't try to delconn unless we have connections.
3816
3817=item *
3818
3819delete returns the correct value now in Net::OSCAR::Buddylist.
3820
3821=item *
3822
3823Don't use warnings if $] E<lt>= 5.005
3824
3825=item *
3826
3827evil is a method, not a manpage (doc fix)
3828
3829=item *
3830
3831Added buddyhash method.
3832
3833=item *
3834
3835Added a debug_print callback.
3836
3837=item *
3838
3839Clarified process_connections method in documentation
3840
3841=item *
3842
3843You can now specify an alternate host/port in signon
3844
3845=item *
3846
3847Added name method to Chat.
3848
3849=item *
3850
3851permit list and deny list are no longer part of buddylist
3852
3853=item *
3854
3855Rewrote buddylist parsing (again!)
3856
3857=item *
3858
3859No more default profile.
3860
3861=item *
3862
3863Fix bug when storing into an already-existing key in Net::OSCAR::Buddylist.
3864
3865=item *
3866
3867snacsnatcher: Remove spurious include of Net::OSCAR::Common
3868
3869=item *
3870
3871We don't need to handle VISMODE_PERMITBUDS ourself - the server takes care of it.
3872Thanks, VB!
3873
3874=item *
3875
3876Makefile.PL: Lots of way cool enhancements to make dist:
3877
3878=over 4
3879
3880=item -
3881
3882It modifies the version number for us
3883
3884=item -
3885
3886It does a CVS rtag
3887
3888=item -
3889
3890It updates the HTML documentation on zevils and the README.
3891
3892=back
3893
3894=item *
3895
3896Added HISTORY and INSTALLATION section to POD.
3897
3898=back
3899
3900=item *
3901
39020.05, 2001-08-08
3903
3904=over 4
3905
3906=item *
3907
3908Don't send signon_done until after we get buddylist.
3909
3910=item *
3911
3912Added signoff method.
3913
3914=item *
3915
3916Fixed typo in documentation
3917
3918=item *
3919
3920Fixed chat_invite parm count
3921
3922=item *
3923
3924Added Scalar::Utils::dualvar variables, especially to Common.pm.
3925dualvar variables return different values in numeric and string context.
3926
3927=item *
3928
3929Added url method for Net::OSCAR::Chat (closes #31)
3930
3931=item *
3932
3933Divide evil by 10 in extract_userinfo (closes #30)
3934
3935=item *
3936
3937chat_invite now exposes chatname (closes #32)
3938
3939=item *
3940
3941Removed unnecessary and warning-generating session length from extract_userinfo
3942
3943=back
3944
3945=item *
3946
39470.01, 2001-08-02
3948
3949=over 4
3950
3951=item *
3952
3953Initial release.
3954
3955=back
3956
3957=back
3958
3959=head1 SUPPORT
3960
3961See http://www.zevils.com/programs/net-oscar/ for support, including
3962a mailing list and bug-tracking system.
3963
3964=head1 AUTHOR
3965
3966Matthew Sachs E<lt>matthewg@zevils.comE<gt>.
3967
3968=head1 CREDITS
3969
3970AOL, for creating the AOL Instant Messenger service, even though they aren't terribly helpful to
3971developers of third-party clients.
3972
3973Apple Computer for help with mac.com support.
3974
3975The users of IMIRC for being reasonably patient while this module was developed.  E<lt>http://www.zevils.com/programs/imirc/E<gt>
3976
3977Bill Atkins for typing status notification and mobile user support.  E<lt>http://www.milkbone.org/E<gt>
3978
3979Jayson Baker for some last-minute debugging help.
3980
3981Roy Camp for loads of bug reports and ideas and helping with user support.
3982
3983Rocco Caputo for helping to work out the hooks that let use be used with
3984POE.  E<lt>http://poe.perl.org/E<gt>
3985
3986Mark Doliner for help with remote buddylists.  E<lt>http://kingant.net/libfaim/ReadThis.htmlE<gt>
3987
3988Adam Fritzler and the libfaim team for their documentation and an OSCAR implementation that
3989was used to help figure out a lot of the protocol details.  E<lt>http://www.zigamorph.net/faim/protocol/E<gt>
3990
3991The gaim team - the source to their libfaim client was also very helpful.  E<lt>http://gaim.sourceforge.net/E<gt>
3992
3993Nick Gray for sponsoring scalability work.
3994
3995John "VBScript" for a lot of technical assistance, including the explanation of rates.
3996
3997Jonathon Wodnicki for additional help with typing status notification.
3998
3999Sam Wong E<lt>sam@uhome.netE<gt> for a patch implementing ICQ2000 support.
4000
4001=head1 LEGAL
4002
4003Copyright (c) 2001 Matthew Sachs.  All rights reserved.
4004This program is free software; you can redistribute it and/or modify it under the
4005same terms as Perl itself.  B<AOL> and B<AMERICA ONLINE> are registered trademarks
4006owned by America Online, Inc.  The B<INSTANT MESSENGER> mark is owned by America
4007Online, Inc.  B<ICQ> is a trademark and/or servicemark of ICQ.  C<Net::OSCAR> is not
4008endorsed by, or affiliated with, America Online, Inc or ICQ.  B<iChat> and B<Apple Computer>
4009are registered trademarks of Apple Computer, Inc.  C<Net::OSCAR> is not endorsed by,
4010or affiliated with, Apple Computer, Inc or iChat.
4011
4012=cut
4013
4014
4015
4016### Private methods
4017
4018sub addconn($@) {
4019        my $self = shift;
4020        my %data = @_;
4021
4022        $data{session} = $self;
4023        weaken($data{session});
4024       
4025        my $connection;
4026        my $conntype = $data{conntype};
4027        $data{description} ||= $conntype;
4028
4029        if($conntype == CONNTYPE_CHAT) {
4030                require Net::OSCAR::Connection::Chat;
4031                $connection = Net::OSCAR::Connection::Chat->new(%data);
4032        } elsif($conntype == CONNTYPE_DIRECT_IN) {
4033                require Net::OSCAR::Connection::Direct;
4034                $connection = Net::OSCAR::Connection::Direct->new(%data);
4035                $connection->listen();
4036        } elsif($conntype == CONNTYPE_DIRECT_OUT) {
4037                require Net::OSCAR::Connection::Direct;
4038                $connection = Net::OSCAR::Connection::Direct->new(%data);
4039        } elsif($conntype == CONNTYPE_SERVER) {
4040                require Net::OSCAR::Connection::Server;
4041                $connection = Net::OSCAR::Connection::Server->new(%data);
4042        } else {
4043                $connection = Net::OSCAR::Connection->new(%data);
4044                # We set the connection to 1 to indicate that it is in progress but not ready for SNAC-sending yet.
4045                $self->{services}->{$conntype} = 1 unless $conntype == CONNTYPE_CHAT;
4046        }
4047
4048        if($conntype == CONNTYPE_BOS) {
4049                $self->{services}->{$conntype} = $connection;
4050        }
4051
4052        push @{$self->{connections}}, $connection;
4053        $self->callback_connection_changed($connection, $connection->{state});
4054        return $connection;
4055}
4056
4057sub delconn($$) {
4058        my($self, $connection) = @_;
4059
4060        return unless $self->{connections};
4061        $self->callback_connection_changed($connection, "deleted") if $connection->{socket};
4062        for(my $i = scalar @{$self->{connections}} - 1; $i >= 0; $i--) {
4063                next unless $self->{connections}->[$i] == $connection;
4064                $connection->log_print(OSCAR_DBG_NOTICE, "Closing.");
4065                splice @{$self->{connections}}, $i, 1;
4066                if(!$connection->{sockerr}) {
4067                        eval {
4068                                if($connection->{socket} and $connection->{conntype} != CONNTYPE_DIRECT_IN and $connection->{conntype} != CONNTYPE_DIRECT_OUT) {
4069                                        $connection->flap_put("", FLAP_CHAN_CLOSE);
4070                                }
4071                                close $connection->{socket} if $connection->{socket};
4072                        };
4073                } else {
4074                        delete $self->{services}->{$connection->{conntype}} unless $connection->{conntype} == CONNTYPE_CHAT;
4075
4076                        if($connection->{conntype} == CONNTYPE_BOS or ($connection->{conntype} == CONNTYPE_LOGIN and !$connection->{closing})) {
4077                                delete $connection->{socket};
4078                                return $self->crapout($connection, "Lost connection to BOS");
4079                        } elsif($connection->{conntype} == CONNTYPE_ADMIN) {
4080                                $self->callback_admin_error("all", ADMIN_ERROR_CONNREF, undef) if scalar(keys(%{$self->{adminreq}}));
4081                        } elsif($connection->{conntype} == CONNTYPE_CHAT) {
4082                                $self->callback_chat_closed($connection, "Lost connection to chat");
4083                        } else {
4084                                $self->log_print(OSCAR_DBG_NOTICE, "Closing connection ", $connection->{conntype});
4085                        }
4086                }
4087                delete $connection->{socket};
4088                return 1;
4089        }
4090        return 0;
4091}
4092
4093sub DESTROY {
4094        my $self = shift;
4095        return if $Net::OSCAR::NODESTROY;
4096
4097        foreach my $connection(@{$self->{connections}}) {
4098                next unless $connection->{socket} and not $connection->{sockerr};
4099                $connection->flap_put("", FLAP_CHAN_CLOSE);
4100                close $connection->{socket} if $connection->{socket};
4101        }
4102}
4103
4104sub findgroup($$) {
4105        my($self, $groupid) = @_;
4106        my($group, $currgroup, $currid);
4107
4108        my $thegroup = undef;
4109
4110        while(($group, $currgroup) = each(%{$self->{buddies}})) {
4111                next if $group eq "__BLI_DIRTY";
4112                next unless exists($currgroup->{groupid}) and $groupid == $currgroup->{groupid};
4113                next if $currgroup->{__BLI_DELETED};
4114                $thegroup = $group;
4115                hash_iter_reset(\%{$self->{buddies}}); # Reset the iterator
4116                last;
4117        }
4118        return $thegroup;
4119}
4120
4121sub findbuddy_byid($$$) {
4122        my($self, $buddies, $bid) = @_;
4123
4124        while(my($buddy, $value) = each(%$buddies)) {
4125                if($value->{buddyid} == $bid and !$value->{__BLI_DELETED}) {
4126                        hash_iter_reset(\%$buddies); # reset the iterator
4127                        return $buddy;
4128                }
4129        }
4130        return undef;
4131}
4132
4133sub newid($;$) {
4134        my($self, $group) = @_;
4135        my $id = 4;
4136        my %ids = ();
4137
4138        if($group) {
4139                %ids = map { $_->{buddyid} => 1 } values %$group;
4140                do { ++$id; } while($ids{$id}) or $id < 4;
4141        } else {
4142                do { $id = ++$self->{nextid}->{__GROUPID__}; } while($self->findgroup($id));
4143        }
4144        return $id;
4145}
4146
4147sub capabilities($) {
4148        my $self = shift;
4149
4150        my @caps;
4151
4152        push @caps, OSCAR_CAPS()->{chat}->{value}, OSCAR_CAPS()->{interoperate}->{value};
4153        push @caps, OSCAR_CAPS()->{extstatus}->{value} if $self->{capabilities}->{extended_status};
4154        push @caps, OSCAR_CAPS()->{buddyicon}->{value} if $self->{capabilities}->{buddy_icons};
4155        push @caps, OSCAR_CAPS()->{filexfer}->{value} if $self->{capabilities}->{file_transfer};
4156        push @caps, OSCAR_CAPS()->{fileshare}->{value} if $self->{capabilities}->{file_sharing};
4157        push @caps, OSCAR_CAPS()->{sendlist}->{value} if $self->{capabilities}->{buddy_list_transfer};
4158
4159        return \@caps;
4160}
4161
4162sub mod_permit($$$@) {
4163        my($self, $action, $group, @buddies) = @_;
4164
4165        return must_be_on($self) unless $self->{is_on};
4166        if($action == MODBL_ACTION_ADD) {
4167                foreach my $buddy(@buddies) {
4168                        next if exists($self->{$group}->{$buddy});
4169                        $self->{$group}->{$buddy}->{buddyid} = $self->newid($self->{$group});
4170                }
4171        } else {
4172                foreach my $buddy(@buddies) {
4173                        delete $self->{$group}->{$buddy};
4174                }
4175        }
4176}
4177
4178sub mod_buddylist($$$$;@) {
4179        my($self, $action, $what, $group, @buddies) = @_;
4180        return must_be_on($self) unless $self->{is_on};
4181
4182        if($group eq "__BLI_DIRTY") {
4183                send_error($self, $self->{bos}, "Invalid group name", "__BLI_DIRTY is a reserved group name.", 0);
4184                return;
4185        }
4186
4187        @buddies = ($group) if $what == MODBL_WHAT_GROUP;
4188
4189        if($what == MODBL_WHAT_GROUP and $action == MODBL_ACTION_ADD) {
4190                return if exists $self->{buddies}->{$group} and !$self->{buddies}->{$group}->{__BLI_DELETED};
4191
4192                $self->{buddies}->{__BLI_DIRTY} = 1;
4193
4194                # Maybe group was deleted and then recreated
4195                if(exists $self->{buddies}->{$group}) {
4196                        my $grp = $self->{buddies}->{$group};
4197                        $grp->{__BLI_DIRTY} = 1;
4198                        $grp->{__BLI_DELETED} = 0;
4199                        $grp->{data} = tlv();
4200                        $_->{__BLI_DELETED} = 1 foreach values %{$grp->{members}};
4201                } else {
4202                        $self->{buddies}->{$group} = {
4203                                groupid => $self->newid(),
4204                                members => bltie(),
4205                                data => tlv(),
4206                                __BLI_DIRTY => 1,
4207                                __BLI_DELETED => 0,
4208                        };
4209                }
4210        } elsif($what == MODBL_WHAT_GROUP and $action == MODBL_ACTION_DEL) {
4211                return unless exists $self->{buddies}->{$group};
4212                $self->{buddies}->{__BLI_DIRTY} = 1;
4213                $self->{buddies}->{$group}->{__BLI_DELETED} = 1;
4214        } elsif($what == MODBL_WHAT_BUDDY and $action == MODBL_ACTION_ADD) {
4215
4216                $self->mod_buddylist(MODBL_ACTION_ADD, MODBL_WHAT_GROUP, $group) unless
4217                        exists $self->{buddies}->{$group} and
4218                        not $self->{buddies}->{$group}->{__BLI_DELETED};
4219
4220                my $grp = $self->{buddies}->{$group};
4221                @buddies = grep {
4222                        not (
4223                                exists $grp->{members}->{$_} and
4224                                not $grp->{members}->{$_}->{__BLI_DELETED}
4225                        )
4226                } @buddies;
4227                return unless @buddies;
4228
4229                $grp->{__BLI_DIRTY} = 1;
4230
4231                foreach my $buddy(@buddies) {
4232                        # Buddy may have been deleted and recreated
4233                        if(exists($grp->{members}->{$buddy})) {
4234                                my $bud = $grp->{members}->{$buddy};
4235                                $bud->{__BLI_DIRTY} = 1;
4236                                $bud->{__BLI_DELETED} = 0;
4237                                $bud->{data} = tlv();
4238                                $bud->{comment} = undef;
4239                                $bud->{alias} = undef;
4240                        } else {
4241                                $grp->{members}->{$buddy} = {
4242                                        buddyid => $self->newid($grp->{members}),
4243                                        screenname => Net::OSCAR::Screenname->new($buddy),
4244                                        data => tlv(),
4245                                        online => 0,
4246                                        comment => undef,
4247                                        alias => undef,
4248                                        __BLI_DIRTY => 1,
4249                                        __BLI_DELETED => 0,
4250                                };
4251                        }
4252                }
4253        } elsif($what == MODBL_WHAT_BUDDY and $action == MODBL_ACTION_DEL) {
4254                return unless exists $self->{buddies}->{$group};
4255
4256                my $grp = $self->{buddies}->{$group};
4257                @buddies = grep {
4258                        exists $grp->{members}->{$_} and
4259                        not $grp->{members}->{$_}->{__BLI_DELETED}
4260                } @buddies;
4261                return unless @buddies;
4262
4263                $grp->{__BLI_DIRTY} = 1;
4264
4265                foreach my $buddy(@buddies) {
4266                        $grp->{members}->{$buddy}->{__BLI_DELETED} = 1;
4267                }
4268                $self->mod_buddylist(MODBL_ACTION_DEL, MODBL_WHAT_GROUP, $group) unless scalar
4269                        grep { not $grp->{members}->{$_}->{__BLI_DELETED} }
4270                        keys %{$grp->{members}};
4271        }
4272}
4273
4274sub postprocess_userinfo($$) {
4275        my($self, $userinfo) = @_;
4276
4277        Net::OSCAR::Screenname->new(\$userinfo->{screenname});
4278
4279        if($userinfo->{idle}) {
4280                $userinfo->{idle} *= 60;
4281                $userinfo->{idle_since} = time() - $userinfo->{idle};
4282        }
4283        $userinfo->{evil} /= 10 if exists($userinfo->{evil});
4284        if(exists($userinfo->{flags})) {
4285                my $flags = $userinfo->{flags};
4286                $userinfo->{trial} = $flags & 0x1;
4287                $userinfo->{admin} = $flags & 0x2;
4288                $userinfo->{aol} = $flags & 0x4;
4289                $userinfo->{pay} = $flags & 0x8;
4290                $userinfo->{free} = $flags & 0x10;
4291                $userinfo->{away} = $flags & 0x20;
4292                $userinfo->{mobile} = $flags & 0x80;
4293        }
4294
4295        if(exists($userinfo->{capabilities})) {
4296                my $capabilities = delete $userinfo->{capabilities};
4297                foreach my $capability (@$capabilities) {
4298                        $self->log_print(OSCAR_DBG_DEBUG, "Got a capability.");
4299                        if(OSCAR_CAPS_INVERSE()->{$capability}) {
4300                                my $capname = OSCAR_CAPS_INVERSE()->{$capability};
4301                                $self->log_print(OSCAR_DBG_DEBUG, "Got capability $capname.");
4302                                $userinfo->{capabilities}->{$capname} = OSCAR_CAPS()->{$capname}->{description};
4303                        } else {
4304                                $self->log_print_cond(OSCAR_DBG_INFO, sub { "Unknown capability: ", hexdump($capability) });
4305                        }
4306                }
4307        }
4308               
4309        if(exists($userinfo->{icon_md5sum})) {
4310                if(!exists($self->{userinfo}->{$userinfo->{screenname}})
4311                   or !exists($self->{userinfo}->{$userinfo->{screenname}}->{icon_md5sum})
4312                   or $self->{userinfo}->{$userinfo->{screenname}}->{icon_md5sum} ne $userinfo->{icon_md5sum}) {
4313                        $self->callback_new_buddy_icon($userinfo->{screenname}, $userinfo);
4314                }
4315        }
4316}
4317
4318sub send_message($$$$;$$) {
4319        my($self, $recipient, $channel, $body, $flags2, $cookie) = @_;
4320        $flags2 ||= 0;
4321
4322        my $reqid = (8<<16) | (unpack("n", randchars(2)))[0];
4323        my %protodata = (
4324                cookie => $cookie ? $cookie : randchars(8),
4325                channel => $channel,
4326                screenname => $recipient,
4327                message_body => $body,
4328        );
4329        $self->svcdo(CONNTYPE_BOS, reqdata => $recipient, reqid => $reqid, protobit => "outgoing_IM", protodata => \%protodata, flags2 => $flags2);
4330
4331        return ($reqid, $protodata{cookie});
4332}
4333
4334sub rendezvous_revise($$;$) {
4335        my($self, $cookie, $ip) = @_;
4336        return unless exists($self->{rv_proposals}->{$cookie});
4337        my $proposal = $self->{rv_proposals}->{$cookie};
4338
4339        if($proposal->{connection}) {
4340                $self->delconn($proposal->{connection});
4341                delete $proposal->{connection};
4342        }
4343
4344        if(!$ip) {
4345                croak "OSCAR server FT proxy not yet supported!";
4346        }
4347
4348        my $connection = $self->addconn(conntype => CONNTYPE_DIRECT_IN);
4349        my($port) = sockaddr_in(getsockname($connection->{socket}));
4350
4351        my %protodata = (
4352                capability => OSCAR_CAPS()->{filexfer}->{value},
4353                cookie => $proposal->{cookie},
4354                status => "propose",
4355                client_1_ip => $self->{ip},
4356                client_2_ip => $self->{ip},
4357                port => $port,
4358        );
4359        $proposal->{connection} = $connection;
4360        $proposal->{ft_state} = "listening";
4361        $proposal->{accepted} = 0;
4362        $proposal->{tried_listen} = 1;
4363
4364        my($req_id) = $self->send_message($proposal->{peer}, 2, protoparse($self, "rendezvous_IM")->pack(%protodata), 0, $cookie);
4365}
4366
4367sub rendezvous_proxy_host($) {
4368        return "ars.oscar.aol.com";
4369}
4370
4371sub rendezvous_negotiate($$) {
4372        my($self, $cookie) = @_;
4373        return unless exists($self->{rv_proposals}->{$cookie});
4374        my $proposal = $self->{rv_proposals}->{$cookie};
4375
4376        if($proposal->{tried_connect} or !$proposal->{ip} or $proposal->{ip} eq "0.0.0.0" or $proposal->{ip} eq "255.255.255.255") {
4377                $self->log_print(OSCAR_DBG_DEBUG, "Negotiating rendezvous.");
4378
4379                # If we haven't tried hosting the connection and it
4380                # doesn't look like we're behind NAT, or we have
4381                # a designated file transfer IP, try hosting.
4382                # Otherwise, use the proxy.
4383                #
4384                if(!$proposal->{tried_listen} and
4385                  $self->{ft_ip} or ($self->{ip} and $self->{bos}->local_ip eq $self->{ip})
4386                ) {
4387                        $self->log_print(OSCAR_DBG_DEBUG, "Hosting.");
4388                        $self->rendezvous_revise($cookie, $self->{ft_ip} || $self->{ip});
4389                        $proposal->{using_proxy} = 0;
4390                        $proposal->{tried_listen} = 1;
4391                        $proposal->{ft_state} = "listening";
4392                        return;
4393                } elsif(!$proposal->{tried_proxy}) {
4394                        $self->log_print(OSCAR_DBG_DEBUG, "Using proxy.");
4395                        $proposal->{using_proxy} = 1;
4396                        $proposal->{tried_proxy} = 1;
4397                        $proposal->{ft_state} = "proxy_connect";
4398                        $proposal->{ip} = $self->rendezvous_proxy_host();
4399                } else {
4400                        $self->rendezvous_reject($cookie);
4401                        $self->log_printf(OSCAR_DBG_WARN, "Couldn't figure out how to connect for file transfer (%s, %s).", $proposal->{ip}, $proposal->{proxy});
4402                        return;
4403                }
4404        } else {
4405                $proposal->{using_proxy} = 0;
4406                $proposal->{tried_connect} = 1;
4407                $proposal->{ft_state} = "connecting";
4408        }
4409
4410        return 1;
4411}
4412
4413sub rendezvous_accept($$) {
4414        my($self, $cookie) = @_;
4415        return unless exists($self->{rv_proposals}->{$cookie});
4416        my $proposal = $self->{rv_proposals}->{$cookie};
4417
4418        return unless $self->rendezvous_negotiate($cookie);
4419
4420        $self->log_printf(OSCAR_DBG_INFO, "Establishing rendezvous connection to %s:%d", $proposal->{ip}, $proposal->{port});
4421        $proposal->{ip} .= ":" . $proposal->{port} if $proposal->{port};
4422        my $newconn = $self->addconn(
4423                conntype => CONNTYPE_DIRECT_OUT,
4424                peer => $proposal->{ip},
4425                description => "transfer of files: " . join(", ", @{$proposal->{filenames}}),
4426                rv => $proposal,
4427        );
4428        $proposal->{connection} = $newconn;
4429}
4430
4431sub rendezvous_reject($$) {
4432        my($self, $cookie) = @_;
4433
4434        return unless exists($self->{rv_proposals}->{$cookie});
4435        my $proposal = delete $self->{rv_proposals}->{$cookie};
4436
4437        my %protodata;
4438        $protodata{status} = "cancel";
4439        $protodata{cookie} = $cookie;
4440        $protodata{capability} = OSCAR_CAPS()->{$proposal->{type}} ? OSCAR_CAPS()->{$proposal->{type}}->{value} : $proposal->{type};
4441
4442        return $self->send_message($proposal->{sender}, 2, protoparse($self, "rendezvous_IM")->pack(%protodata));
4443}
4444
4445sub svcdo($$%) {
4446        my($self, $service, %data) = @_;
4447
4448        if($self->{services}->{$service} and ref($self->{services}->{$service})) {
4449                $self->{services}->{$service}->proto_send(%data);
4450        } else {
4451                push @{$self->{svcqueues}->{$service}}, \%data;
4452                $self->svcreq($service) unless $self->{services}->{$service};
4453        }
4454}
4455
4456sub svcreq($$;@) {
4457        my($self, $svctype, @extradata) = @_;
4458
4459        $self->log_print(OSCAR_DBG_INFO, "Sending service request for servicetype $svctype.");
4460        $self->svcdo(CONNTYPE_BOS, protobit => "service_request", protodata => {type => $svctype, @extradata});
4461}
4462
4463sub crapout($$$;$) {
4464        my($self, $connection, $reason, $errno) = @_;
4465        send_error($self, $connection, $errno || 0, $reason, 1);
4466        $self->signoff();
4467}
4468
4469sub must_be_on($) {
4470        my $self = shift;
4471        send_error($self, $self->{services}->{0+CONNTYPE_BOS}, 0, "You have not finished signing on.", 0);
4472}
4473
4474
4475sub server($%) {
4476        my $self = shift;
4477        my %data = @_;
4478        $self->{$_} = $data{$_} foreach keys %data;
4479        $self->addconn(conntype => CONNTYPE_SERVER);
4480}
4481
4482sub connection_for_family($$) {
4483        my($self, $family) = @_;
4484
4485        my $bos = $self->{services}->{0+CONNTYPE_BOS};
4486        if($bos->{families}->{$family}) {
4487                return $bos;
4488        }
4489
4490        foreach my $connection (@{$self->{session}->{connections}}) {
4491                next unless $connection->{families}->{$family};
4492                $connection->log_print(OSCAR_DBG_WARN, "Found connection for unsupported SNAC.");
4493                return $connection;
4494        }
4495
4496        return;
4497}
4498
44991;
4500
Note: See TracBrowser for help on using the repository browser.