source: perl/modules/AIM/lib/Net/OSCAR/Utility.pm @ 3dcccba

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