Context Navigation

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

Visit:

barnowl_perlaim

Last change on this file since a1c2f06 was 7a1c90d, checked in by Geoffrey Thomas <geofft@mit.edu>, 17 years ago
Skeleton AIM module, and Net::OSCAR 1.925
Property mode set to `100644`
File size: 18.0 KB

Rev	Line
[7a1c90d]	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;

Note: See TracBrowser for help on using the repository browser.

Download in other formats: