Net-OSCAR

 view release on metacpan or  search on metacpan

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

	$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,
			);

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

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

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

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",

lib/Net/OSCAR/Callbacks/4/incoming_IM.pm  view on Meta::CPAN

		$rv->{type} = $type;
		$rv->{sender} = $sender;
		$rv->{recipient} = $session->{screenname};
		$rv->{cookie} = $data{cookie};
	} elsif($rv->{peer} ne $sender) {
		$connection->log_printf(OSCAR_DBG_WARN, "$sender tried to send a rendezvous which was previously sent by %s; discarding.", $rv->{peer});
		return;
	}

	if($type eq "chat") {
		my %svcdata = protoparse($session, "chat_invite_rendezvous_data")->unpack($data{svcdata});

		# Ignore invites for chats that we're already in
		if(not grep { $_->{url} eq $svcdata{url} }
		   grep { $_->{conntype} == CONNTYPE_CHAT }
		      @{$session->{connections}}
		) {
			# Extract chat ID from char URL
			$rv->{chat_url} = $svcdata{url};
			$svcdata{url} =~ /-.*?-(.*?)(\0*)$/;
			my $chat = $1;
			$chat =~ s/%([0-9A-Z]{1,2})/chr(hex($1))/eig;
			$rv->{name} = $chat;
			$rv->{exchange} = $svcdata{exchange};

			$session->callback_chat_invite($sender, $data{invitation_msg}, $chat, $svcdata{url});
		}
	} elsif($type eq "filexfer") {
		# If proposal is being revised, no svcdata will be present.
		my %svcdata;
		if($data{svcdata}) {
			%svcdata = protoparse($session, "file_transfer_rendezvous_data")->unpack($data{svcdata});

			$rv->{direction} = "receive";
			$rv->{accepted} = 0;
			$rv->{filenames} = $svcdata{files};
			$rv->{total_size} = $svcdata{size};
			$rv->{file_count} = $svcdata{file_count};
			$rv->{using_proxy} = 0;
			$rv->{tried_proxy} = 0;
			$rv->{tried_listen} = 0;
			$rv->{tried_connect} = 0;
		} elsif($rv->{connection}) {
			$session->delconn($rv->{connection});
			delete $rv->{connection};
		}

		$rv->{port} = $data{port};
		$rv->{external_ip} = $data{client_external_ip} ? inet_ntoa(pack("N", $data{client_external_ip})) : "";
		$rv->{ip} = $data{client_1_ip} ? inet_ntoa(pack("N", $data{client_1_ip})) : $rv->{external_ip};
		$rv->{ft_state} = "unconnected";

		$connection->log_printf(OSCAR_DBG_DEBUG, "Got proposal %s for %s:%d (external %s)", hexdump($rv->{cookie}), $rv->{ip}, $rv->{port}, $rv->{external_ip});
	} elsif($type eq "sendlist") {
		my %svcdata = protoparse($session, "buddy_list_transfer_rendezvous_data")->unpack($data{svcdata});
		delete $session->{rv_proposals}->{$data{cookie}};

		my $list = bltie();
		foreach my $group (@{$svcdata{group}}) {
			$list->{$group->{name}} = [];

			my $grouplist = $list->{$group->{name}};
			foreach my $buddy (@{$group->{buddies}}) {
				push @$grouplist, Net::OSCAR::Screenname->new(\$buddy->{name});
			}
		}

		$session->callback_buddylist_in($sender, $list);
	} else {

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

			$self->log_print(OSCAR_DBG_NOTICE, "Couldn't connect.");
			return 0;
		} else {
			$self->log_print(OSCAR_DBG_DEBUG, "Got connack.");
		}

		return $self->{session}->crapout($self, "Got bad connack from server") unless $self->{channel} == FLAP_CHAN_NEWCONN;

		if($self->{conntype} == CONNTYPE_LOGIN) {
			$self->log_print(OSCAR_DBG_DEBUG, "Got connack.  Sending connack.");
			$self->flap_put(pack("N", 1), FLAP_CHAN_NEWCONN) unless $self->{session}->{svcdata}->{hashlogin};
			$self->log_print(OSCAR_DBG_SIGNON, "Connected to login server.");
			$self->{ready} = 1;
			$self->{families} = {23 => 1};

			if(!$self->{session}->{svcdata}->{hashlogin}) {
				$self->proto_send(protobit => "initial_signon_request",
					protodata => {screenname => $self->{session}->{screenname}},
					nopause => 1
				);
			} else {
				$self->proto_send(protobit => "ICQ_signon_request",
					protodata => {signon_tlv($self->{session}, delete($self->{auth}))},
					nopause => 1
				);
			}

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

				reqid => 0x01000000 | (unpack("n", substr($self->{auth}, 0, 2)))[0],
				protodata => {cookie => substr(delete($self->{auth}), 2)},
				nopause => 1
			);
		}
		$self->log_print(OSCAR_DBG_DEBUG, "SNAC time.");
		$self->{ready} = 1;
	} elsif($read) {
		my $no_reread = 0;
		while(1) {
			if(!$self->{session}->{svcdata}->{hashlogin}) {
				$snac = $self->snac_get($no_reread) or return 0;
				Net::OSCAR::Callbacks::process_snac($self, $snac);
			} else {
				my $data = $self->flap_get($no_reread) or return 0;
				$snac = {data => $data, reqid => 0, family => 0x17, subtype => 0x3};
				if($self->{channel} == FLAP_CHAN_CLOSE) {
					$self->{conntype} = CONNTYPE_LOGIN;
					$self->{family} = 0x17;
					$self->{subtype} = 0x3;
					$self->{data} = $data;

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

use Net::OSCAR::Utility;
use Net::OSCAR::XML;
@ISA = qw(Net::OSCAR::Connection);

sub invite($$;$) {
	my($self, $who, $message) = @_;
	$message ||= "Join me in this Buddy Chat";

	$self->log_print(OSCAR_DBG_DEBUG, "Inviting $who to join us.");

	my $svcdata = protoparse($self, "chat_invite_rendezvous_data")->pack(
		exchange => $self->{exchange},
		url => $self->{url}
	);

	my $cookie = randchars(8);
	my %rvdata = (
		capability => OSCAR_CAPS()->{chat}->{value},
		charset => "us-ascii",
		cookie => $cookie,
		invitation_msg => $message,
		push_pull => 1,
		status => "propose",
		svcdata => $svcdata
	);

        return $self->{session}->send_message($who, 2, protoparse($self, "rendezvous_IM")->pack(%rvdata), 0, $cookie);
}

sub chat_send($$;$$) {
	my($self, $msg, $noreflect, $away) = @_;

	my %protodata = (
		cookie => randchars(8),

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

	my $retval = {};
	tie %$retval, "Net::OSCAR::Buddylist", @_;
	return $retval;
}

sub signon_tlv($;$$) {
	my($session, $password, $key) = @_;

	my %protodata = (
		screenname => $session->{screenname},
		clistr => $session->{svcdata}->{clistr},
		supermajor => $session->{svcdata}->{supermajor},
		major => $session->{svcdata}->{major},
		minor => $session->{svcdata}->{minor},
		subminor => $session->{svcdata}->{subminor},
		build => $session->{svcdata}->{build},
		subbuild => $session->{svcdata}->{subbuild},
	);

	if($session->{svcdata}->{hashlogin}) {
		$protodata{password} = encode_password($session, $password);
	} else {
		if($session->{auth_response}) {
			$protodata{auth_response} = delete $session->{auth_response};
			$protodata{pass_is_hashed} = "" if delete $session->{pass_is_hashed};
		} else {
			# As of AIM 5.5, the password can be MD5'd before
			# going into the things-to-cat-together-and-MD5.
			# This lets applications that store AIM passwords
			# store the MD5'd password.  We do it by default

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

			$protodata{auth_response} = encode_password($session, $hashpass, $key);
		}
	}

	return %protodata;
}

sub encode_password($$;$) {
	my($session, $password, $key) = @_;

	if(!$session->{svcdata}->{hashlogin}) { # Use new SNAC-based method
		my $md5 = Digest::MD5->new;

		$md5->add($key);
		$md5->add($password);
		$md5->add("AOL Instant Messenger (SM)");
		return $md5->digest();
	} else { # Use old roasting method.  Courtesy of SDiZ Cheng.
		my $ret = "";
		my @pass = map {ord($_)} split(//, $password);

lib/Net/OSCAR/XML/Protocol.xml  view on Meta::CPAN

					<tlv type="5"><word name="port" /></tlv>
					<tlv type="22"><dword name="proxy_ip" /></tlv>


					<!-- Proposal message -->
					<tlv type="12"><data name="invitation_msg" /></tlv>
					<tlv type="13"><data name="charset">us-ascii</data></tlv>
					<tlv type="14"><byte name="language">48</byte></tlv>

					<!-- See 'rendezvous service-specific data' -->
					<tlv type="10001"><data name="svcdata" /></tlv>
					<tlv type="10002"><data name="svcdata_charset" /></tlv>
				</tlvchain>
			</tlv>
		</tlvchain>
	</define>

	<define name="incoming_IM" family="4" subtype="7">
		<ref name="standard_IM_header" />
		<ref name="userinfo" />
		<data name="message_body" />
	</define>

snacsnatcher  view on Meta::CPAN

		if($protobit =~ /^(incoming|outgoing)_IM$/) {
			my $channel_data;

			if($data{channel} == 1) {
				$channel_data = {protoparse($session, "standard_IM_footer")->unpack($data{message_body})};
			} elsif($data{channel} == 2) {
				$channel_data = {protoparse($session, "rendezvous_IM")->unpack($data{message_body})};
				my $type = OSCAR_CAPS_INVERSE()->{$channel_data->{capability}};

				if($type eq "chat") {
					$channel_data->{svcdata} = {protoparse($session, "chat_invite_rendezvous_data")->unpack($channel_data->{svcdata})};
				} elsif($type eq "filexfer") {
					$channel_data->{svcdata} = {protoparse($session, "file_transfer_rendezvous_data")->unpack($channel_data->{svcdata})};
				} elsif($type eq "sendlist") {
					$channel_data->{svcdata} = {protoparse($session, "buddy_list_transfer_rendezvous_data")->unpack($channel_data->{svcdata})};
				}
			} else {
				$channel_data = $data{message_body};
			}

			$data{message_body} = $channel_data;
		}

		ssdump_hash(\%data, 1);
	}