1 | =pod |
---|
2 | |
---|
3 | Net::OSCAR::_BLInternal -- internal buddylist stuff |
---|
4 | |
---|
5 | This handles conversion of Net::OSCAR to "OSCAR buddylist format", |
---|
6 | and the sending of buddylist changes to the OSCAR server. |
---|
7 | |
---|
8 | =cut |
---|
9 | |
---|
10 | package Net::OSCAR::_BLInternal; |
---|
11 | |
---|
12 | use strict; |
---|
13 | use Net::OSCAR::Common qw(:all); |
---|
14 | use Net::OSCAR::Constants; |
---|
15 | use Net::OSCAR::Utility; |
---|
16 | use Net::OSCAR::TLV; |
---|
17 | use Net::OSCAR::XML; |
---|
18 | |
---|
19 | use vars qw($VERSION $REVISION); |
---|
20 | $VERSION = '1.925'; |
---|
21 | $REVISION = '$Revision: 1.56 $'; |
---|
22 | |
---|
23 | sub init_entry($$$$) { |
---|
24 | my($blinternal, $type, $gid, $bid) = @_; |
---|
25 | |
---|
26 | $blinternal->{$type} ||= tlv(); |
---|
27 | $blinternal->{$type}->{$gid} ||= tlv(); |
---|
28 | $blinternal->{$type}->{$gid}->{$bid} ||= {}; |
---|
29 | $blinternal->{$type}->{$gid}->{$bid}->{name} ||= ""; |
---|
30 | $blinternal->{$type}->{$gid}->{$bid}->{data} ||= tlv(); |
---|
31 | $blinternal->{$type}->{$gid}->{$bid}->{__BLI_DIRTY} = 1; |
---|
32 | $blinternal->{$type}->{$gid}->{$bid}->{__BLI_DELETED} = 0; |
---|
33 | } |
---|
34 | |
---|
35 | sub blentry_clear($%) { |
---|
36 | my($session, %data) = @_; |
---|
37 | |
---|
38 | if(chain_exists($session->{blinternal}, $data{entry_type}, $data{group_id}, $data{buddy_id})) { |
---|
39 | $session->{blinternal}->{$data{entry_type}}->{$data{group_id}}->{$data{buddy_id}}->{__BLI_DELETED} = 1; |
---|
40 | } |
---|
41 | } |
---|
42 | |
---|
43 | sub blentry_set($%) { |
---|
44 | my($session, %data) = @_; |
---|
45 | |
---|
46 | init_entry($session->{blinternal}, $data{entry_type}, $data{group_id}, $data{buddy_id}); |
---|
47 | my $typedata = tlv_decode($data{entry_data}); |
---|
48 | |
---|
49 | $session->{blinternal}->{$data{entry_type}}->{$data{group_id}}->{$data{buddy_id}}->{name} = $data{entry_name} if $data{entry_name}; |
---|
50 | while(my($key, $value) = each %$typedata) { |
---|
51 | $session->{blinternal}->{$data{entry_type}}->{$data{group_id}}->{$data{buddy_id}}->{data}->{$key} = $value; |
---|
52 | } |
---|
53 | $session->log_printf_cond(OSCAR_DBG_DEBUG, sub { "Got BLI entry %s 0x%04X/0x%04X/0x%04X with %d bytes of data:%s", $data{entry_name}, $data{entry_type}, $data{group_id}, $data{buddy_id}, length($typedata), hexdump($data{entry_data}) }); |
---|
54 | } |
---|
55 | |
---|
56 | sub blparse($$) { |
---|
57 | my($session, $data) = @_; |
---|
58 | |
---|
59 | $session->{visibility} = VISMODE_PERMITALL; # If we don't have p/d data, this is default. |
---|
60 | |
---|
61 | delete $session->{blinternal}; |
---|
62 | $session->{blinternal} = tlv(); |
---|
63 | |
---|
64 | while(length($data) > 4) { |
---|
65 | my($name) = unpack("n/a*", $data); |
---|
66 | substr($data, 0, 2+length($name)) = ""; |
---|
67 | my($gid, $bid, $type, $sublen) = unpack("n4", substr($data, 0, 8, "")); |
---|
68 | my $typedata = substr($data, 0, $sublen, ""); |
---|
69 | blentry_set($session, |
---|
70 | entry_type => $type, |
---|
71 | group_id => $gid, |
---|
72 | buddy_id => $bid, |
---|
73 | entry_name => $name, |
---|
74 | entry_data => $typedata |
---|
75 | ); |
---|
76 | } |
---|
77 | |
---|
78 | BLI_to_NO($session); |
---|
79 | } |
---|
80 | |
---|
81 | # Buddylist-Internal -> Net::OSCAR |
---|
82 | # Sets various $session hashkeys from blinternal. |
---|
83 | # That's what Brian Bli-to-no'd do. ;) |
---|
84 | sub BLI_to_NO($) { |
---|
85 | my($session) = @_; |
---|
86 | my $bli = $session->{blinternal}; |
---|
87 | |
---|
88 | delete $session->{blinternal_visbid}; |
---|
89 | delete $session->{blinternal_iconbid}; |
---|
90 | |
---|
91 | $session->{buddies} ||= bltie(1); |
---|
92 | $session->{buddies}->{__BLI_DIRTY} = 0; |
---|
93 | |
---|
94 | $session->{permit} ||= bltie; |
---|
95 | $session->{deny} ||= bltie; |
---|
96 | |
---|
97 | |
---|
98 | foreach my $type ([2, "permit"], [3, "deny"]) { |
---|
99 | my($num, $name) = @$type; |
---|
100 | |
---|
101 | if(exists $bli->{$num}) { |
---|
102 | foreach my $bid(keys(%{$bli->{$num}->{0}})) { |
---|
103 | my $item = $bli->{$num}->{0}->{$bid}; |
---|
104 | |
---|
105 | if($item->{__BLI_DELETED}) { |
---|
106 | delete $session->{$name}->{$item->{name}}; |
---|
107 | delete $bli->{$num}->{0}->{$bid}; |
---|
108 | } elsif($item->{__BLI_DIRTY}) { |
---|
109 | $session->{$name}->{$item->{name}} = {buddyid => $bid}; |
---|
110 | $item->{__BLI_DIRTY} = 0; |
---|
111 | } |
---|
112 | } |
---|
113 | } |
---|
114 | } |
---|
115 | |
---|
116 | |
---|
117 | foreach my $type (4, 5, 0x14) { |
---|
118 | delete $bli->{$type}->{0}->{$_} foreach grep { $bli->{$type}->{0}->{$_}->{__BLI_DELETED} } keys %{$bli->{$type}->{0}}; |
---|
119 | } |
---|
120 | |
---|
121 | if(exists $bli->{4} and exists $bli->{4}->{0} and (my($visbid) = grep {exists($bli->{4}->{0}->{$_}->{data}->{0xCB})} keys %{$bli->{4}->{0}})) { |
---|
122 | $session->{blinternal_visbid} = $visbid; |
---|
123 | my $typedata = $bli->{4}->{0}->{$visbid}->{data}; |
---|
124 | if($bli->{4}->{0}->{$visbid}->{__BLI_DIRTY}) { |
---|
125 | ($session->{visibility}) = unpack("C", $typedata->{0xCA}) if $typedata->{0xCA}; |
---|
126 | |
---|
127 | my $groupperms = $typedata->{0xCB}; |
---|
128 | ($session->{groupperms}) = unpack("N", $groupperms) if $groupperms; |
---|
129 | $session->{profile} = $typedata->{0x0100} if exists($typedata->{0x0100}); |
---|
130 | ($session->{icon_checksum}) = unpack("n", $typedata->{0x0101}) if exists($typedata->{0x0101}); |
---|
131 | ($session->{icon_timestamp}) = unpack("N", $typedata->{0x0102}) if exists($typedata->{0x0102}); |
---|
132 | ($session->{icon_length}) = unpack("N", $typedata->{0x0103}) if exists($typedata->{0x0103}); |
---|
133 | |
---|
134 | $session->{appdata} = $typedata; |
---|
135 | |
---|
136 | $session->set_info($session->{profile}) if exists($session->{profile}); |
---|
137 | |
---|
138 | $bli->{4}->{0}->{$visbid}->{__BLI_DIRTY} = 0; |
---|
139 | } |
---|
140 | } else { |
---|
141 | # No permit info - we permit everyone |
---|
142 | $session->{visibility} = VISMODE_PERMITALL; |
---|
143 | $session->{groupperms} = 0xFFFFFFFF; |
---|
144 | } |
---|
145 | |
---|
146 | if(exists $bli->{0x14} and exists $bli->{0x14}->{0} and (my($iconbid) = grep {exists($bli->{0x14}->{0}->{$_}->{data}->{0xD5})} keys %{$bli->{0x14}->{0}})) { |
---|
147 | $session->{blinternal_iconbid} = $iconbid; |
---|
148 | my $typedata = $bli->{0x14}->{0}->{$iconbid}->{data}; |
---|
149 | $session->{icon_md5sum} = $typedata->{0xD5}; |
---|
150 | } |
---|
151 | |
---|
152 | |
---|
153 | my @ret; |
---|
154 | |
---|
155 | foreach my $gid (keys %{$bli->{1}}) { |
---|
156 | next unless exists $bli->{1}->{$gid}->{0}; |
---|
157 | my $item = $bli->{1}->{$gid}->{0}; |
---|
158 | |
---|
159 | if($item->{__BLI_DELETED}) { |
---|
160 | delete $bli->{1}->{$gid}->{0}; |
---|
161 | next if $gid == 0 or !$item->{name}; |
---|
162 | |
---|
163 | delete $session->{buddies}->{$item->{name}}; |
---|
164 | push @ret, {type => MODBL_WHAT_GROUP, action => MODBL_ACTION_DEL, group => $item->{name}}; |
---|
165 | } elsif($item->{__BLI_DIRTY}) { |
---|
166 | $item->{__BLI_DIRTY} = 0; |
---|
167 | next if $gid == 0 or !$item->{name}; |
---|
168 | |
---|
169 | $session->{buddies}->{$item->{name}} ||= {}; |
---|
170 | my $entry = $session->{buddies}->{$item->{name}}; |
---|
171 | |
---|
172 | $entry->{__BLI_DIRTY} = 0; |
---|
173 | $entry->{__BLI_DELETED} = 0; |
---|
174 | $entry->{groupid} = $gid; |
---|
175 | $entry->{members} = bltie unless $entry->{members}; |
---|
176 | $entry->{data} = $item->{data}; |
---|
177 | |
---|
178 | push @ret, {type => MODBL_WHAT_GROUP, action => MODBL_ACTION_ADD, group => $item->{name}}; |
---|
179 | } |
---|
180 | } |
---|
181 | |
---|
182 | foreach my $gid (keys %{$bli->{0}}) { |
---|
183 | foreach my $bid (keys %{$bli->{0}->{$gid}}) { |
---|
184 | my $item = $bli->{0}->{$gid}->{$bid}; |
---|
185 | my $group = ""; |
---|
186 | $group = $bli->{1}->{$gid}->{0}->{name} if chain_exists($bli, 1, $gid, 0); |
---|
187 | |
---|
188 | if($item->{__BLI_DELETED}) { |
---|
189 | delete $bli->{0}->{$gid}->{$bid}; |
---|
190 | next if $gid == 0 or !$group; |
---|
191 | |
---|
192 | delete $session->{buddies}->{$group}->{members}->{$item->{name}} if $group; |
---|
193 | push @ret, {type => MODBL_WHAT_BUDDY, action => MODBL_ACTION_DEL, group => $group, buddy => $item->{name}}; |
---|
194 | } elsif($item->{__BLI_DIRTY}) { |
---|
195 | $item->{__BLI_DIRTY} = 0; |
---|
196 | next if $gid == 0 or !$group; |
---|
197 | |
---|
198 | my $comment = undef; |
---|
199 | $comment = $item->{data}->{0x13C} if exists($item->{data}->{0x13C}); |
---|
200 | |
---|
201 | my $alias = undef; |
---|
202 | $alias = $item->{data}->{0x131} if exists($item->{data}->{0x131}); |
---|
203 | |
---|
204 | $session->{buddies}->{$group}->{members}->{$item->{name}} ||= {}; |
---|
205 | my $entry = $session->{buddies}->{$group}->{members}->{$item->{name}}; |
---|
206 | $entry->{__BLI_DIRTY} = 0; |
---|
207 | $entry->{__BLI_DELETED} = 0; |
---|
208 | $entry->{buddyid} = $bid; |
---|
209 | $entry->{online} = 0 unless exists($entry->{online}); |
---|
210 | $entry->{comment} = $comment; |
---|
211 | $entry->{alias} = $alias; |
---|
212 | $entry->{data} = $item->{data}; |
---|
213 | $entry->{screenname} = Net::OSCAR::Screenname->new($item->{name}); |
---|
214 | |
---|
215 | push @ret, {type => MODBL_WHAT_BUDDY, action => MODBL_ACTION_ADD, group => $group, buddy => $item->{name}}; |
---|
216 | } |
---|
217 | } |
---|
218 | } |
---|
219 | |
---|
220 | return @ret; |
---|
221 | } |
---|
222 | |
---|
223 | # Gee, guess what this does? Hint: see sub BLI_to_NO. |
---|
224 | sub NO_to_BLI($) { |
---|
225 | my $session = shift; |
---|
226 | |
---|
227 | my $bli = tlv(); |
---|
228 | my $oldbli = $session->{blinternal}; |
---|
229 | |
---|
230 | # Copy old data |
---|
231 | my $visbid = $session->{blinternal_visbid} || int(rand(30000)) + 1; |
---|
232 | my $iconbid = $session->{blinternal_iconbid} || 0x51F4; |
---|
233 | foreach my $type (keys %$oldbli) { |
---|
234 | next if $type == 2 or $type == 3; |
---|
235 | foreach my $gid (keys %{$oldbli->{$type}}) { |
---|
236 | foreach my $bid (keys %{$oldbli->{$type}->{$gid}}) { |
---|
237 | next if $type == 4 and $bid == $visbid; |
---|
238 | next if $type == 0x14 and $bid == $iconbid; |
---|
239 | |
---|
240 | init_entry($bli, $type, $gid, $bid); |
---|
241 | $bli->{$type}->{$gid}->{$bid}->{name} = $oldbli->{$type}->{$gid}->{$bid}->{name}; |
---|
242 | foreach my $data (keys %{$oldbli->{$type}->{$gid}->{$bid}->{data}}) { |
---|
243 | $bli->{$type}->{$gid}->{$bid}->{data}->{$data} = $oldbli->{$type}->{$gid}->{$bid}->{data}->{$data}; |
---|
244 | } |
---|
245 | } |
---|
246 | } |
---|
247 | } |
---|
248 | |
---|
249 | |
---|
250 | foreach my $permit (keys %{$session->{permit}}) { |
---|
251 | init_entry($bli, 2, 0, $session->{permit}->{$permit}->{buddyid}); |
---|
252 | $bli->{2}->{0}->{$session->{permit}->{$permit}->{buddyid}}->{name} = $permit; |
---|
253 | } |
---|
254 | |
---|
255 | foreach my $deny (keys %{$session->{deny}}) { |
---|
256 | init_entry($bli, 3, 0, $session->{deny}->{$deny}->{buddyid}); |
---|
257 | $bli->{3}->{0}->{$session->{deny}->{$deny}->{buddyid}}->{name} = $deny; |
---|
258 | } |
---|
259 | |
---|
260 | init_entry($bli, 4, 0, $visbid); |
---|
261 | $bli->{4}->{0}->{$visbid}->{data}->{0xCA} = pack("C", $session->{visibility} || VISMODE_PERMITALL); |
---|
262 | $bli->{4}->{0}->{$visbid}->{data}->{0xCB} = pack("N", $session->{groupperms} || 0xFFFFFFFF); |
---|
263 | |
---|
264 | #Net::OSCAR protocol extensions |
---|
265 | $bli->{4}->{0}->{$visbid}->{data}->{0x0100} = $session->{profile} if $session->{profile}; |
---|
266 | $bli->{4}->{0}->{$visbid}->{data}->{0x0101} = pack("n", $session->{icon_checksum}) if $session->{icon_checksum}; |
---|
267 | $bli->{4}->{0}->{$visbid}->{data}->{0x0102} = pack("N", $session->{icon_timestamp}) if $session->{icon_timestamp}; |
---|
268 | $bli->{4}->{0}->{$visbid}->{data}->{0x0103} = pack("N", $session->{icon_length}) if $session->{icon_length}; |
---|
269 | |
---|
270 | foreach my $appdata(keys %{$session->{appdata}}) { |
---|
271 | $bli->{4}->{0}->{$visbid}->{data}->{$appdata} = $session->{appdata}->{$appdata}; |
---|
272 | } |
---|
273 | |
---|
274 | if(exists($session->{icon_md5sum}) || chain_exists($oldbli, 0x14, 0, $iconbid)) { |
---|
275 | init_entry($bli, 0x14, 0, $iconbid); |
---|
276 | |
---|
277 | if(chain_exists($oldbli, 0x14, 0, $iconbid)) { |
---|
278 | $bli->{0x14}->{0}->{$iconbid}->{name} = $oldbli->{0x14}->{0}->{$iconbid}->{name}; |
---|
279 | |
---|
280 | $bli->{0x14}->{0}->{$iconbid}->{data}->{$_} = $oldbli->{0x14}->{0}->{$iconbid}->{data}->{$_} |
---|
281 | foreach grep { $_ != 0xD5 } keys %{$oldbli->{0x14}->{0}->{$iconbid}->{data}}; |
---|
282 | } else { |
---|
283 | $bli->{0x14}->{0}->{$iconbid}->{name} = "1"; |
---|
284 | } |
---|
285 | |
---|
286 | if(exists($session->{icon_md5sum})) { |
---|
287 | $bli->{0x14}->{0}->{$iconbid}->{data}->{0xD5} = $session->{icon_md5sum}; |
---|
288 | } |
---|
289 | } |
---|
290 | |
---|
291 | init_entry($bli, 1, 0, 0); |
---|
292 | if($session->{buddies}->{__BLI_DIRTY}) { |
---|
293 | $bli->{1}->{0}->{0}->{data}->{0xC8} = pack("n*", map { $_->{groupid} } grep { ref($_) } values %{$session->{buddies}}); |
---|
294 | $session->{buddies}->{__BLI_DIRTY} = 0; |
---|
295 | } else { |
---|
296 | $bli->{1}->{0}->{0}->{__BLI_SKIP} = 1; |
---|
297 | $oldbli->{1}->{0}->{0}->{__BLI_SKIP} = 1; |
---|
298 | } |
---|
299 | |
---|
300 | while(my($grpname, $grp) = each(%{$session->{buddies}})) { |
---|
301 | next if $grpname eq "__BLI_DIRTY"; |
---|
302 | |
---|
303 | my $gid = $grp->{groupid}; |
---|
304 | |
---|
305 | if($grp->{__BLI_DELETED}) { |
---|
306 | delete $session->{buddies}->{$grpname}; |
---|
307 | delete $bli->{1}->{$gid}->{0}; |
---|
308 | next; |
---|
309 | } |
---|
310 | |
---|
311 | if(not $grp->{__BLI_DIRTY}) { |
---|
312 | $bli->{1}->{$gid}->{0}->{__BLI_SKIP} = 1; |
---|
313 | $oldbli->{1}->{$gid}->{0}->{__BLI_SKIP} = 1; |
---|
314 | next; |
---|
315 | } else { |
---|
316 | $grp->{__BLI_DIRTY} = 0; |
---|
317 | } |
---|
318 | |
---|
319 | init_entry($bli, 1, $gid, 0); |
---|
320 | my $bligrp = $bli->{1}->{$gid}->{0}; |
---|
321 | $bligrp->{name} = $grpname; |
---|
322 | |
---|
323 | |
---|
324 | # Clear out data, since the user may have deleted keys. |
---|
325 | $bli->{1}->{$gid}->{0}->{data} = tlv(); |
---|
326 | |
---|
327 | # It seems that WinAIM can now have groups without 0xC8 data, and gets pissed if we create such data where it doesn't exist. |
---|
328 | if(!exists($oldbli->{1}->{$gid}) or chain_exists($oldbli, 1, $gid, 0, "data", 0xC8)) { |
---|
329 | $bligrp->{data}->{0xC8} = pack("n*", |
---|
330 | map { $_->{buddyid} } |
---|
331 | grep { not $_->{__BLI_DELETED} } |
---|
332 | values %{$grp->{members}}); |
---|
333 | } |
---|
334 | |
---|
335 | if(chain_exists($oldbli, 1, $gid, 0)) { |
---|
336 | $bli->{1}->{$gid}->{0}->{data}->{$_} = $oldbli->{1}->{$gid}->{0}->{data}->{$_} |
---|
337 | foreach grep { $_ != 0xC8 } keys %{$oldbli->{1}->{$gid}->{0}->{data}}; |
---|
338 | } |
---|
339 | |
---|
340 | |
---|
341 | while(my($buddy, $bud) = each(%{$grp->{members}})) { |
---|
342 | my $bid = $bud->{buddyid}; |
---|
343 | |
---|
344 | if($bud->{__BLI_DELETED}) { |
---|
345 | delete $grp->{members}->{$buddy}; |
---|
346 | delete $bli->{0}->{$gid}->{$bid}; |
---|
347 | next; |
---|
348 | } |
---|
349 | |
---|
350 | if(not $bud->{__BLI_DIRTY}) { |
---|
351 | $bli->{0}->{$gid}->{$bid}->{__BLI_SKIP} = 1; |
---|
352 | $oldbli->{0}->{$gid}->{$bid}->{__BLI_SKIP} = 1; |
---|
353 | next; |
---|
354 | } else { |
---|
355 | $bud->{__BLI_DIRTY} = 0; |
---|
356 | } |
---|
357 | |
---|
358 | next unless $bid; |
---|
359 | init_entry($bli, 0, $gid, $bid); |
---|
360 | my $blibud = $bli->{0}->{$gid}->{$bid}; |
---|
361 | $blibud->{name} = "$buddy"; # Make sure to get strinfied version of Screenname |
---|
362 | |
---|
363 | $blibud->{data} = tlv(); |
---|
364 | while(my ($key, $value) = each(%{$bud->{data}})) { |
---|
365 | $blibud->{data}->{$key} = $value; |
---|
366 | } |
---|
367 | $blibud->{data}->{0x13C} = $bud->{comment} if defined $bud->{comment}; |
---|
368 | $blibud->{data}->{0x131} = $bud->{alias} if defined $bud->{alias}; |
---|
369 | } |
---|
370 | } |
---|
371 | |
---|
372 | BLI_to_OSCAR($session, $bli); |
---|
373 | } |
---|
374 | |
---|
375 | # Send changes to BLI over to OSCAR |
---|
376 | sub BLI_to_OSCAR($$) { |
---|
377 | my($session, $newbli) = @_; |
---|
378 | my $oldbli = $session->{blinternal}; |
---|
379 | my (@adds, @modifies, @deletes); |
---|
380 | $session->crapout($session->{services}->{0+CONNTYPE_BOS}, "You must wait for a buddylist_ok or buddylist_error callback before calling commit_buddylist again.") if $session->{budmods}; |
---|
381 | $session->{budmods} = []; |
---|
382 | |
---|
383 | my %budmods; |
---|
384 | $budmods{add} = []; |
---|
385 | $budmods{modify} = []; |
---|
386 | $budmods{delete} = []; |
---|
387 | |
---|
388 | # First, delete stuff that we no longer use and modify everything else |
---|
389 | foreach my $type(keys %$oldbli) { |
---|
390 | |
---|
391 | my $budtype = (BUDTYPES)[$type] || "unknown type $type"; |
---|
392 | |
---|
393 | foreach my $gid(keys %{$oldbli->{$type}}) { |
---|
394 | foreach my $bid(keys %{$oldbli->{$type}->{$gid}}) { |
---|
395 | my $oldentry = $oldbli->{$type}->{$gid}->{$bid}; |
---|
396 | if($oldentry->{__BLI_SKIP}) { |
---|
397 | delete $oldentry->{__BLI_SKIP}; |
---|
398 | next; |
---|
399 | } |
---|
400 | |
---|
401 | my $olddata = tlv_encode($oldentry->{data}); |
---|
402 | $session->log_printf_cond(OSCAR_DBG_DEBUG, sub { "Old BLI entry %s 0x%04X/0x%04X/0x%04X with %d bytes of data:%s", $oldentry->{name}, $type, $gid, $bid, length($olddata), hexdump($olddata) }); |
---|
403 | my $delete = 0; |
---|
404 | if(exists($newbli->{$type}) and exists($newbli->{$type}->{$gid}) and exists($newbli->{$type}->{$gid}->{$bid})) { |
---|
405 | my $newentry = $newbli->{$type}->{$gid}->{$bid}; |
---|
406 | my $newdata = tlv_encode($newentry->{data}); |
---|
407 | $session->log_printf_cond(OSCAR_DBG_DEBUG, sub { "New BLI entry %s 0x%04X/0x%04X/0x%04X with %d bytes of data:%s", $newentry->{name}, $type, $gid, $bid, length($newdata), hexdump($newdata) }); |
---|
408 | |
---|
409 | next if |
---|
410 | $newentry->{name} eq $oldentry->{name} |
---|
411 | and $newdata eq $olddata; |
---|
412 | |
---|
413 | # Apparently, we can't modify the name of a buddylist entry? |
---|
414 | if($newentry->{name} ne $oldentry->{name}) { |
---|
415 | $delete = 1; |
---|
416 | } else { |
---|
417 | $session->log_print(OSCAR_DBG_DEBUG, "Modifying."); |
---|
418 | |
---|
419 | push @{$budmods{modify}}, { |
---|
420 | reqdata => {desc => "modifying $budtype $newentry->{name}", type => $type, gid => $gid, bid => $bid}, |
---|
421 | protodata => { |
---|
422 | entry_name => $newentry->{name}, |
---|
423 | group_id => $gid, |
---|
424 | buddy_id => $bid, |
---|
425 | entry_type => $type, |
---|
426 | entry_data => $newdata |
---|
427 | } |
---|
428 | }; |
---|
429 | } |
---|
430 | } else { |
---|
431 | $delete = 1; |
---|
432 | } |
---|
433 | |
---|
434 | if($delete) { |
---|
435 | $session->log_print(OSCAR_DBG_DEBUG, "Deleting."); |
---|
436 | |
---|
437 | push @{$budmods{delete}}, { |
---|
438 | reqdata => {desc => "deleting $budtype $oldentry->{name}", type => $type, gid => $gid, bid => $bid}, |
---|
439 | protodata => { |
---|
440 | entry_name => $oldentry->{name}, |
---|
441 | group_id => $gid, |
---|
442 | buddy_id => $bid, |
---|
443 | entry_type => $type, |
---|
444 | entry_data => $olddata |
---|
445 | } |
---|
446 | }; |
---|
447 | } |
---|
448 | } |
---|
449 | } |
---|
450 | } |
---|
451 | |
---|
452 | # Now, add the new stuff |
---|
453 | foreach my $type(keys %$newbli) { |
---|
454 | |
---|
455 | my $budtype = (BUDTYPES)[$type] || "unknown type $type"; |
---|
456 | |
---|
457 | foreach my $gid(keys %{$newbli->{$type}}) { |
---|
458 | foreach my $bid(keys %{$newbli->{$type}->{$gid}}) { |
---|
459 | my $entry = $newbli->{$type}->{$gid}->{$bid}; |
---|
460 | if($entry->{__BLI_SKIP}) { |
---|
461 | delete $entry->{__BLI_SKIP}; |
---|
462 | next; |
---|
463 | } |
---|
464 | |
---|
465 | next if exists($oldbli->{$type}) and exists($oldbli->{$type}->{$gid}) and exists($oldbli->{$type}->{$gid}->{$bid}) and $oldbli->{$type}->{$gid}->{$bid}->{name} eq $newbli->{$type}->{$gid}->{$bid}->{name}; |
---|
466 | |
---|
467 | my $data = tlv_encode($entry->{data}); |
---|
468 | |
---|
469 | $session->log_printf_cond(OSCAR_DBG_DEBUG, sub { "New BLI entry %s 0x%04X/0x%04X/0x%04X with %d bytes of data:%s", $entry->{name}, $type, $gid, $bid, length($data), hexdump($data) }); |
---|
470 | |
---|
471 | push @{$budmods{add}}, { |
---|
472 | reqdata => {desc => "adding $budtype $entry->{name}", type => $type, gid => $gid, bid => $bid}, |
---|
473 | protodata => { |
---|
474 | entry_name => $entry->{name}, |
---|
475 | group_id => $gid, |
---|
476 | buddy_id => $bid, |
---|
477 | entry_type => $type, |
---|
478 | entry_data => $data |
---|
479 | } |
---|
480 | }; |
---|
481 | } |
---|
482 | } |
---|
483 | } |
---|
484 | |
---|
485 | # Actually send the changes. Don't send more than 7K in a single SNAC. |
---|
486 | # FLAP size limit is 8K, but that includes headers - good to have a safety margin |
---|
487 | foreach my $type (qw(add modify delete)) { |
---|
488 | my $changelist = $budmods{$type}; |
---|
489 | |
---|
490 | my(@reqdata, @packets); |
---|
491 | my $packet = ""; |
---|
492 | foreach my $change(@$changelist) { |
---|
493 | $packet .= protoparse($session, "buddylist_modification")->pack(%{$change->{protodata}}); |
---|
494 | push @reqdata, $change->{reqdata}; |
---|
495 | |
---|
496 | if(length($packet) > 7*1024) { |
---|
497 | #$session->log_print(OSCAR_DBG_INFO, "Adding to blmod queue (max packet size reached): type $type, payload size ", scalar(@reqdata)); |
---|
498 | push @packets, { |
---|
499 | type => $type, |
---|
500 | data => $packet, |
---|
501 | reqdata => [@reqdata], |
---|
502 | }; |
---|
503 | $packet = ""; |
---|
504 | @reqdata = (); |
---|
505 | } |
---|
506 | } |
---|
507 | if($packet) { |
---|
508 | #$session->log_print(OSCAR_DBG_INFO, "Adding to blmod queue (no more changes): type $type, payload size ", scalar(@reqdata)); |
---|
509 | push @packets, { |
---|
510 | type => $type, |
---|
511 | data => $packet, |
---|
512 | reqdata => [@reqdata], |
---|
513 | }; |
---|
514 | } |
---|
515 | |
---|
516 | push @{$session->{budmods}}, map { |
---|
517 | { |
---|
518 | protobit => "buddylist_" . $_->{type}, |
---|
519 | reqdata => $_->{reqdata}, |
---|
520 | protodata => {mods => $_->{data}} |
---|
521 | }; |
---|
522 | } @packets; |
---|
523 | } |
---|
524 | |
---|
525 | push @{$session->{budmods}}, {protobit => "end_buddylist_modifications"}; # End BL mods |
---|
526 | #$session->log_print(OSCAR_DBG_INFO, "Adding terminator to blmod queue."); |
---|
527 | |
---|
528 | $session->{blold} = $oldbli; |
---|
529 | $session->{blinternal} = $newbli; |
---|
530 | |
---|
531 | if(@{$session->{budmods}} <= 1) { # We only have the start/end modification packets, no actual changes |
---|
532 | #$session->log_print(OSCAR_DBG_INFO, "Empty blmod queue - calling buddylist_ok."); |
---|
533 | delete $session->{budmods}; |
---|
534 | $session->callback_buddylist_ok(); |
---|
535 | } else { |
---|
536 | #$session->log_print(OSCAR_DBG_INFO, "Non-empty blmod queue - sending initiator and first change packet."); |
---|
537 | $session->svcdo(CONNTYPE_BOS, protobit => "start_buddylist_modifications"); |
---|
538 | $session->svcdo(CONNTYPE_BOS, %{shift @{$session->{budmods}}}); # Send the first modification |
---|
539 | } |
---|
540 | } |
---|
541 | |
---|
542 | sub chain_exists($@) { |
---|
543 | my($tlv, @refs) = @_; |
---|
544 | |
---|
545 | while(@refs) { |
---|
546 | my $ref = shift @refs; |
---|
547 | if(exists($tlv->{$ref})) { |
---|
548 | $tlv = $tlv->{$ref}; |
---|
549 | } else { |
---|
550 | return 0; |
---|
551 | } |
---|
552 | } |
---|
553 | |
---|
554 | return defined($tlv) ? 1 : 0; |
---|
555 | } |
---|
556 | |
---|
557 | 1; |
---|