view release on metacpan or  search on metacpan

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

}

sub tlv_decode($;$) {
	my($tlv, $tlvcnt) = @_;
	my($type, $len, $value, %retval);
	my $currtlv = 0;
	my $strpos = 0;

	my $retval = tlv;

	$tlvcnt = 0 unless $tlvcnt;
	while(length($tlv) >= 4 and (!$tlvcnt or $currtlv < $tlvcnt)) {
		($type, $len) = unpack("nn", $tlv);
		$len = 0x2 if $type == 0x13;
		$strpos += 4;
		substr($tlv, 0, 4) = "";
		if($len) {
			($value) = substr($tlv, 0, $len, "");
		} else {
			$value = "";
		}
		$strpos += $len;
		$currtlv++ unless $type == 0;
		$retval->{$type} = $value;
	}

	return $tlvcnt ? ($retval, $strpos) : $retval;
}

sub tlv_encode($) {
	my $tlv = shift;
	my($buffer, $type, $value) = ("", 0, "");

	confess "You must use a tied Net::OSCAR::TLV hash!" 
	   unless defined($tlv) and ref($tlv) eq "HASH" and defined(tied(%$tlv)) and tied(%$tlv)->isa("Net::OSCAR::TLV");
	while (($type, $value) = each %$tlv) {
		$value ||= "";
		$buffer .= pack("nna*", $type, length($value), $value);

	}
	return $buffer;
}

sub send_error($$$$$;@) {
	my($oscar, $connection, $error, $desc, $fatal, @reqdata) = @_;
	$desc = sprintf $desc, @reqdata;
	$oscar->callback_error($connection, $error, $desc, $fatal);
}

sub bltie(;$) {
	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
			# because, well, AIM for Windows does.  We support
			# the old way to preserve compatibility with
			# our auth_challenge/auth_response API.

			$protodata{pass_is_hashed} = "";
			my $hashpass = $session->{pass_is_hashed} ? $password : md5($password);

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

		my @encoding_table = map {hex($_)} qw(
			F3 26 81 C4 39 86 DB 92 71 A3 B9 E6 53 7A 95 7C
		);

		for(my $i = 0; $i < length($password); $i++) {
			$ret .= chr($pass[$i] ^ $encoding_table[$i]);
		}

		return $ret;
	}
}

sub send_versions($$;$) {
	my($connection, $send_tools, $server) = @_;
	my $conntype = $connection->{conntype};
	my @services;

	if($conntype != CONNTYPE_BOS and !$server) {
		@services = (1, $conntype);
	} else {
		@services = sort {$b <=> $a} grep {not OSCAR_TOOLDATA()->{$_}->{nobos}} keys %{OSCAR_TOOLDATA()};
	}

	my %protodata = (service => []);
	foreach my $service (@services) {
		my %service = (
			service_id => $service,
			service_version => OSCAR_TOOLDATA->{$service}->{version}
		);
		if($send_tools) {
			$service{tool_id} = OSCAR_TOOLDATA->{$service}->{toolid};
			$service{tool_version} = OSCAR_TOOLDATA->{$service}->{toolversion};
		}

		push @{$protodata{service}}, \%service;
	}

	if($send_tools) {
		$connection->proto_send(protobit => "set_tool_versions", protodata => \%protodata, nopause => 1);
	} elsif($server) {
		$connection->proto_send(protobit => "host_versions", protodata => \%protodata, nopause => 1);
	} else {
		$connection->proto_send(protobit => "set_service_versions", protodata => \%protodata, nopause => 1);
	}
}

# keys(%foo) in void context, the standard way of reseting
# a hash iterator, appears to leak memory.
#
sub hash_iter_reset($) {