source: perl/modules/AIM/lib/Net/OSCAR/_BLInternal.pm @ 7a1c90d

barnowl_perlaim
Last change on this file since 7a1c90d was 7a1c90d, checked in by Geoffrey Thomas <geofft@mit.edu>, 16 years ago
Skeleton AIM module, and Net::OSCAR 1.925
  • Property mode set to 100644
File size: 18.0 KB
Line 
1=pod
2
3Net::OSCAR::_BLInternal -- internal buddylist stuff
4
5This handles conversion of Net::OSCAR to "OSCAR buddylist format",
6and the sending of buddylist changes to the OSCAR server.
7
8=cut
9
10package Net::OSCAR::_BLInternal;
11
12use strict;
13use Net::OSCAR::Common qw(:all);
14use Net::OSCAR::Constants;
15use Net::OSCAR::Utility;
16use Net::OSCAR::TLV;
17use Net::OSCAR::XML;
18
19use vars qw($VERSION $REVISION);
20$VERSION = '1.925';
21$REVISION = '$Revision: 1.56 $';
22
23sub 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
35sub 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
43sub 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
56sub 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. ;)
84sub 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.
224sub 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
376sub 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
542sub 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
5571;
Note: See TracBrowser for help on using the repository browser.