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;