cdata results from the CPAN

cdata

Net-OSCAR

view release on metacpan or search on metacpan

=item port

=item proxy_type

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

=item proxy_host

=item proxy_port

=item proxy_username

=item proxy_password

=back

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

=cut

sub signon($@) {
	my($self, $password, $host, %args);
	$self = shift;

	# Determine whether caller is using hash-method or old method of passing parms.
	# Note that this breaks if caller passes in both a host and a port using the old way.
	# But hey, that's why it's deprecated!
	if(@_ < 3) {
		$args{screenname} = shift @_ or return $self->crapout($self->{services}->{0+CONNTYPE_BOS}, "You must specify a username to sign on with!");
		$args{password} = shift @_ or return $self->crapout($self->{services}->{0+CONNTYPE_BOS}, "You must specify a password to sign on with!");;
		$args{host} = shift @_ if @_;
		$args{port} = shift @_ if @_;
	} else {
		%args = @_;
		return $self->crapout($self->{services}->{0+CONNTYPE_BOS}, "You must specify a username and password to sign on with!") unless $args{screenname} and exists($args{password});
	}

	my %defaults = OSCAR_SVC_AIM;
	%defaults = OSCAR_SVC_ICQ if $args{screenname} =~ /^\d+$/;
	foreach my $key(keys %defaults) {
		$args{$key} ||= $defaults{$key};
	}
	return $self->crapout($self->{services}->{0+CONNTYPE_BOS}, "MD5 authentication not available for this service (you must define a password.)") if !defined($args{password}) and $args{hashlogin};
	$self->{screenname} = Net::OSCAR::Screenname->new(\$args{screenname});

	# We set BOS to the login connection so that our error handlers pick up errors on this connection as fatal.
	$args{host} ||= "login.oscar.aol.com";
	$args{port} ||= 5190;


	($self->{screenname}, $password, $host, $self->{port},
		$self->{proxy_type}, $self->{proxy_host}, $self->{proxy_port},
		$self->{proxy_username}, $self->{proxy_password}, $self->{local_ip},
		$self->{local_port}, $self->{pass_is_hashed}, $self->{stealth}) =
			delete @args{qw(screenname password host port proxy_type proxy_host proxy_port proxy_username proxy_password local_ip local_port pass_is_hashed stealth)};

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

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

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

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

=pod

=item signoff

Sign off from the OSCAR service.

=cut

sub signoff($) {
	my $self = shift;
	foreach my $connection(@{$self->{connections}}) {
		$self->delconn($connection);
	}
	my $screenname = $self->{screenname};
	%$self = ();
	$self->{screename} = $screenname; # Useful for post-mortem processing in multiconnection apps
}

=pod

=back

=head3 CALLBACKS

=over 4

=item signon_done (OSCAR)

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

=back

=head2 BUDDIES AND BUDDYLISTS

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

=head3 METHODS

lib/Net/OSCAR.pm view on Meta::CPAN

	}
	return @retval;
}

=pod

=back

=head2 OTHER USERS

See also L<"BUDDIES AND BUDDYLISTS">.

=head3 METHODS

=over 4

=item get_info (WHO)

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

=item get_away (WHO)

Similar to L<get_info>, except requests the user's away message instead of
their profile.

=cut

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

	$self->svcdo(CONNTYPE_BOS, reqdata => $screenname, protobit => "get_info", protodata => {screenname => $screenname});
}
sub get_away($$) {
	my($self, $screenname) = @_;
	return must_be_on($self) unless $self->{is_on};

	$self->svcdo(CONNTYPE_BOS, reqdata => $screenname, protobit => "get_away", protodata => {screenname => $screenname});
}


=pod

=item send_im (WHO, MESSAGE[, AWAY])

Sends someone an instant message.  If the message is an automated reply generated,
perhaps, because you have an away message set, give the AWAY parameter a non-zero
value.  Note that C<Net::OSCAR> will not handle sending away messages to people who
contact you when you are away - you must perform this yourself if you want it done.

Returns a "request ID" that you can use in the C<im_ok> callback to identify the message.
If the message was too long to send, returns zero.

=cut

sub send_im($$$;$) {
	my($self, $to, $msg, $away) = @_;
	return must_be_on($self) unless $self->{is_on};

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

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

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

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

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

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

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

=pod

=item send_typing_status (RECIPIENT, STATUS)

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

=over 4

=item *

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

=item *

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

=item *

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

lib/Net/OSCAR.pm view on Meta::CPAN


=over 4

=item admin_error (OSCAR, REQTYPE, ERROR, ERRURL)

This is called when there is an error performing an administrative function - changing
your password, formatting your screenname, changing your email address, or confirming your
account.  REQTYPE is a string describing the type of request which generated the error.
ERROR is an error message.  ERRURL is an http URL which the user may visit for more
information about the error.

=item admin_ok (OSCAR, REQTYPE)

This is called when an administrative function succeeds.  See L<admin_error> for more info.

=item buddy_icon_uploaded (OSCAR)

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

=item stealth_changed (OSCAR, NEW_STEALTH_STATE)

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

=item extended_status (OSCAR, STATUS)

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

=item evil (OSCAR, NEWEVIL[, FROM])

Called when your evil level changes.  NEWEVIL is your new evil level,
as a percentage (accurate to tenths of a percent.)  ENEMY is undef
if the evil was anonymous (or if the message was triggered because
your evil level naturally decreased), otherwise it is the screenname
of the person who sent us the evil.  See the L<"evil"> method for
more information on evils.

=back

=head2 FILE TRANSFER AND DIRECT CONNECTIONS

=over 4

=item file_send SCREENNAME MESSAGE FILEREFS

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

=cut

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

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

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

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

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

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

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

	return ($req_id, $cookie);
}

=pod

=back

=head2 EVENT PROCESSING

=head3 METHODS

=over 4

=item do_one_loop

Processes incoming data from our connections to the various
OSCAR services.  This method reads one command from any
connections which have data to be read.  See the
L<timeout> method to set the timeout interval used
by this method.

=cut

sub do_one_loop($) {
	my $self = shift;
	my $timeout = $self->{timeout};

	undef $timeout if defined($timeout) and $timeout == -1;

	my($rin, $win, $ein) = ('', '', '');

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

( run in 0.494 second using v1.01-cache-2.11-cpan-13bb782fe5a )