1=pod
2
3=head1 NAME
4
5Net::OSCAR::Utility -- internal utility functions for Net::OSCAR
6
7=head1 VERSION
8
9version 1.928
10
11=cut
12
13package Net::OSCAR::Utility;
14BEGIN {
15  $Net::OSCAR::Utility::VERSION = '1.928';
16}
17
18$REVISION = '$Revision$';
19
20use strict;
21use vars qw(@ISA @EXPORT);
22use Digest::MD5 qw(md5);
23use Carp;
24
25use Net::OSCAR::TLV;
26use Net::OSCAR::Common qw(:loglevels);
27use Net::OSCAR::Constants;
28
29require Exporter;
30@ISA = qw(Exporter);
31@EXPORT = qw(
32	randchars log_print log_printf log_print_cond log_printf_cond hexdump normalize tlv_decode tlv_encode send_error bltie
33	signon_tlv encode_password send_versions hash_iter_reset millitime
34);
35
36eval {
37	require Time::HiRes;
38};
39our $finetime = $@ ? 0 : 1;
40
41
42sub millitime() {
43	my $time = $finetime ? Time::HiRes::time() : time();
44	return int($time * 1000);
45}
46
47sub randchars($) {
48	my $count = shift;
49	my $retval = "";
50	for(my $i = 0; $i < $count; $i++) { $retval .= chr(int(rand(256))); }
51	return $retval;
52}
53
54
55sub log_print($$@) {
56	my($obj, $level) = (shift, shift);
57	my $session = exists($obj->{session}) ? $obj->{session} : $obj;
58	return unless defined($session->{LOGLEVEL}) and $session->{LOGLEVEL} >= $level;
59
60	my $message = "";
61	$message .= $obj->{description}. ": " if $obj->{description};
62	$message .= join("", @_). "\n";
63
64	if($session->{callbacks}->{log}) {
65		$session->callback_log($level, $message);
66	} else {
67		$message = "(".$session->{screenname}.") $message" if $session->{SNDEBUG};
68		print STDERR $message;
69	}
70}
71
72sub log_printf($$@) {
73	my($obj, $level, $fmtstr) = (shift, shift, shift);
74
75	$obj->log_print($level, sprintf($fmtstr, @_));
76}
77
78sub log_printf_cond($$&) {
79	my($obj, $level, $sub) = @_;
80	my $session = exists($obj->{session}) ? $obj->{session} : $obj;
81	return unless defined($session->{LOGLEVEL}) and $session->{LOGLEVEL} >= $level;
82
83	log_printf($obj, $level, &$sub);
84}
85
86sub log_print_cond($$&) {
87	my($obj, $level, $sub) = @_;
88	my $session = exists($obj->{session}) ? $obj->{session} : $obj;
89	return unless defined($session->{LOGLEVEL}) and $session->{LOGLEVEL} >= $level;
90
91	log_print($obj, $level, &$sub);
92}
93
94sub hexdump($;$) {
95	my $stuff = shift;
96	my $forcehex = shift || 0;
97	my $retbuff = "";
98	my @stuff;
99
100	return "" unless defined($stuff);
101	for(my $i = 0; $i < length($stuff); $i++) {
102		push @stuff, substr($stuff, $i, 1);
103	}
104
105	return $stuff unless $forcehex or grep { $_ lt chr(0x20) or $_ gt chr(0x7E) } @stuff;
106	while(@stuff) {
107		my $i = 0;
108		$retbuff .= "\n\t";
109		my @currstuff = splice(@stuff, 0, 16);
110
111		foreach my $currstuff(@currstuff) {
112			$retbuff .= " " unless $i % 4;
113			$retbuff .= " " unless $i % 8;
114			$retbuff .= sprintf "%02X ", ord($currstuff);
115			$i++;
116		}
117		for(; $i < 16; $i++) {
118			$retbuff .= " " unless $i % 4;
119			$retbuff .= " " unless $i % 8;
120			$retbuff .= "   ";
121		}
122
123		$retbuff .= "  ";
124		$i = 0;
125		foreach my $currstuff(@currstuff) {
126			$retbuff .= " " unless $i % 4;
127			$retbuff .= " " unless $i % 8;
128			if($currstuff ge chr(0x20) and $currstuff le chr(0x7E)) {
129				$retbuff .= $currstuff;
130			} else {
131				$retbuff .= ".";
132			}
133			$i++;
134		}
135	}
136	return $retbuff;
137}
138
139sub normalize($) {
140	my $temp = shift;
141	$temp =~ tr/ //d if $temp;
142	return $temp ? lc($temp) : "";
143}
144
145sub tlv_decode($;$) {
146	my($tlv, $tlvcnt) = @_;
147	my($type, $len, $value, %retval);
148	my $currtlv = 0;
149	my $strpos = 0;
150
151	my $retval = tlv;
152
153	$tlvcnt = 0 unless $tlvcnt;
154	while(length($tlv) >= 4 and (!$tlvcnt or $currtlv < $tlvcnt)) {
155		($type, $len) = unpack("nn", $tlv);
156		$len = 0x2 if $type == 0x13;
157		$strpos += 4;
158		substr($tlv, 0, 4) = "";
159		if($len) {
160			($value) = substr($tlv, 0, $len, "");
161		} else {
162			$value = "";
163		}
164		$strpos += $len;
165		$currtlv++ unless $type == 0;
166		$retval->{$type} = $value;
167	}
168
169	return $tlvcnt ? ($retval, $strpos) : $retval;
170}
171
172sub tlv_encode($) {
173	my $tlv = shift;
174	my($buffer, $type, $value) = ("", 0, "");
175
176	confess "You must use a tied Net::OSCAR::TLV hash!"
177	   unless defined($tlv) and ref($tlv) eq "HASH" and defined(tied(%$tlv)) and tied(%$tlv)->isa("Net::OSCAR::TLV");
178	while (($type, $value) = each %$tlv) {
179		$value ||= "";
180		$buffer .= pack("nna*", $type, length($value), $value);
181
182	}
183	return $buffer;
184}
185
186sub send_error($$$$$;@) {
187	my($oscar, $connection, $error, $desc, $fatal, @reqdata) = @_;
188	$desc = sprintf $desc, @reqdata;
189	$oscar->callback_error($connection, $error, $desc, $fatal);
190}
191
192sub bltie(;$) {
193	my $retval = {};
194	tie %$retval, "Net::OSCAR::Buddylist", @_;
195	return $retval;
196}
197
198sub signon_tlv($;$$) {
199	my($session, $password, $key) = @_;
200
201	my %protodata = (
202		screenname => $session->{screenname},
203		clistr => $session->{svcdata}->{clistr},
204		supermajor => $session->{svcdata}->{supermajor},
205		major => $session->{svcdata}->{major},
206		minor => $session->{svcdata}->{minor},
207		subminor => $session->{svcdata}->{subminor},
208		build => $session->{svcdata}->{build},
209		subbuild => $session->{svcdata}->{subbuild},
210	);
211
212	if($session->{svcdata}->{hashlogin}) {
213		$protodata{password} = encode_password($session, $password);
214	} else {
215		if($session->{auth_response}) {
216			$protodata{auth_response} = delete $session->{auth_response};
217			$protodata{pass_is_hashed} = "" if delete $session->{pass_is_hashed};
218		} else {
219			# As of AIM 5.5, the password can be MD5'd before
220			# going into the things-to-cat-together-and-MD5.
221			# This lets applications that store AIM passwords
222			# store the MD5'd password.  We do it by default
223			# because, well, AIM for Windows does.  We support
224			# the old way to preserve compatibility with
225			# our auth_challenge/auth_response API.
226
227			$protodata{pass_is_hashed} = "";
228			my $hashpass = $session->{pass_is_hashed} ? $password : md5($password);
229
230			$protodata{auth_response} = encode_password($session, $hashpass, $key);
231		}
232	}
233
234	return %protodata;
235}
236
237sub encode_password($$;$) {
238	my($session, $password, $key) = @_;
239
240	if(!$session->{svcdata}->{hashlogin}) { # Use new SNAC-based method
241		my $md5 = Digest::MD5->new;
242
243		$md5->add($key);
244		$md5->add($password);
245		$md5->add("AOL Instant Messenger (SM)");
246		return $md5->digest();
247	} else { # Use old roasting method.  Courtesy of SDiZ Cheng.
248		my $ret = "";
249		my @pass = map {ord($_)} split(//, $password);
250
251		my @encoding_table = map {hex($_)} qw(
252			F3 26 81 C4 39 86 DB 92 71 A3 B9 E6 53 7A 95 7C
253		);
254
255		for(my $i = 0; $i < length($password); $i++) {
256			$ret .= chr($pass[$i] ^ $encoding_table[$i]);
257		}
258
259		return $ret;
260	}
261}
262
263sub send_versions($$;$) {
264	my($connection, $send_tools, $server) = @_;
265	my $conntype = $connection->{conntype};
266	my @services;
267
268	if($conntype != CONNTYPE_BOS and !$server) {
269		@services = (1, $conntype);
270	} else {
271		@services = sort {$b <=> $a} grep {not OSCAR_TOOLDATA()->{$_}->{nobos}} keys %{OSCAR_TOOLDATA()};
272	}
273
274	my %protodata = (service => []);
275	foreach my $service (@services) {
276		my %service = (
277			service_id => $service,
278			service_version => OSCAR_TOOLDATA->{$service}->{version}
279		);
280		if($send_tools) {
281			$service{tool_id} = OSCAR_TOOLDATA->{$service}->{toolid};
282			$service{tool_version} = OSCAR_TOOLDATA->{$service}->{toolversion};
283		}
284
285		push @{$protodata{service}}, \%service;
286	}
287
288	if($send_tools) {
289		$connection->proto_send(protobit => "set_tool_versions", protodata => \%protodata, nopause => 1);
290	} elsif($server) {
291		$connection->proto_send(protobit => "host_versions", protodata => \%protodata, nopause => 1);
292	} else {
293		$connection->proto_send(protobit => "set_service_versions", protodata => \%protodata, nopause => 1);
294	}
295}
296
297# keys(%foo) in void context, the standard way of reseting
298# a hash iterator, appears to leak memory.
299#
300sub hash_iter_reset($) {
301	while((undef, undef) = each(%{$_[0]})) {}
302}
303
3041;