Index: perl/modules/AIM/lib/Net/OSCAR/XML.pm
===================================================================
--- perl/modules/AIM/lib/Net/OSCAR/XML.pm	(revision a1c2f06871a801d9b82caee954afd29c2b65d69c)
+++ perl/modules/AIM/lib/Net/OSCAR/XML.pm	(revision a1c2f06871a801d9b82caee954afd29c2b65d69c)
@@ -0,0 +1,336 @@
+=pod
+
+Net::OSCAR::XML -- XML functions for Net::OSCAR
+
+We're doing the fancy-schmancy Protocol.xml stuff here, so I'll explain it here.
+
+Protocol.xml contains a number of "OSCAR protocol elements".  One E<lt>defineE<gt> block
+is one OSCAR protocol elemennt.
+
+When the module is first loaded, Protocol.xml is parsed and two hashes are created,
+one whose keys are the names the the elements and whose values are the contents
+of the XML::Parser tree which represents the contents of those elements; the other
+hash has a family/subtype tuple as a key and element names as a value.
+
+To do something with an element, given its name, Net::OSCAR calls C<protoparse("element name")>.
+This returns a C<Net::OSCAR::XML::Template> object, which has C<pack> and C<unpack> methods.
+C<pack> takes a hash and returns a string of binary characters, and C<unpack> goes the
+other way around.  The objects are cached, so C<protoparse> only has to do actual work once
+for every protocol element.
+
+=cut
+
+package Net::OSCAR::XML;
+
+$VERSION = '1.925';
+$REVISION = '$Revision: 1.24 $';
+
+use strict;
+use vars qw(@ISA @EXPORT $VERSION);
+use Carp;
+use Data::Dumper;
+
+use Net::OSCAR::TLV;
+use Net::OSCAR::XML::Template;
+our(%xmlmap, %xml_revmap, $PROTOPARSE_DEBUG, $NO_XML_CACHE);
+
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(
+	protoparse protobit_to_snac snac_to_protobit
+);
+
+$PROTOPARSE_DEBUG = 0;
+$NO_XML_CACHE = 0;
+
+sub _protopack($$;@);
+sub _xmlnode_to_template($$);
+
+sub load_xml(;$) {
+	# Look for parsed-xml file
+	if(!$NO_XML_CACHE) {
+		foreach (@INC) {
+			next unless -f "$_/Net/OSCAR/XML/Protocol.parsed-xml";
+
+			open(XMLCACHE, "$_/Net/OSCAR/XML/Protocol.parsed-xml") or next;
+			my $xmlcache = join("", <XMLCACHE>);
+			close(XMLCACHE);
+
+			my $xmlparse;
+			eval $xmlcache or die "Coldn't load xml cache: $@\n";
+			die $@ if $@;
+			return parse_xml($xmlparse);
+		}
+	}
+
+	eval {
+		require XML::Parser;
+	} or die "Couldn't load XML::Parser ($@)\n";
+	die $@ if $@;
+
+	my $xmlparser = new XML::Parser(Style => "Tree");
+
+	my $xmlfile = "";
+	if($_[0]) {
+		$xmlfile = shift;
+	} else {
+		foreach (@INC) {
+			next unless -f "$_/Net/OSCAR/XML/Protocol.xml";
+			$xmlfile = "$_/Net/OSCAR/XML/Protocol.xml";
+			last;
+		}
+		croak "Couldn't find Net/OSCAR/XML/Protocol.xml in search path: " . join(" ", @INC) unless $xmlfile;
+	}
+
+	open(XMLFILE, $xmlfile) or croak "Couldn't open $xmlfile: $!";
+	my $xml = join("", <XMLFILE>);
+	close XMLFILE;
+	my $xmlparse = $xmlparser->parse($xml) or croak "Couldn't parse XML from $xmlfile: $@";
+
+	parse_xml($xmlparse);
+}
+
+sub add_xml_data($) {
+	my $xmlparse = shift;
+
+	my @tags = @{$xmlparse->[1]}; # Get contents of <oscar>
+	shift @tags;
+	while(@tags) {
+		my($name, $value);
+		(undef, undef, $name, $value) = splice(@tags, 0, 4);
+		next unless $name and $name eq "define";
+	
+		my %protobit = (xml => $value);
+		my %attrs = %{$value->[0]};
+		$protobit{$_} = $attrs{$_} foreach keys %attrs;
+		$xml_revmap{$attrs{family}}->{$attrs{subtype}} = $attrs{name} if exists($attrs{family}) and exists($attrs{subtype});
+		$xmlmap{$attrs{name}} = \%protobit;
+	}
+}
+
+sub parse_xml($) {
+	my $xmlparse = shift;
+
+	%xmlmap = ();
+	%xml_revmap = ();
+	# We set the autovivification so that keys of xml_revmap are Net::OSCAR::TLV hashrefs.
+	if(!tied(%xml_revmap)) {
+		tie %xml_revmap, "Net::OSCAR::TLV", 'tie %$value, ref($self)';
+	}
+
+	add_xml_data($xmlparse);
+
+	return 1;
+}
+
+sub _num_to_packlen($$) {
+	my($type, $order) = @_;
+	$order ||= "network";
+
+	if($type eq "byte") {
+		return ("C", 1);
+	} elsif($type eq "word") {
+		if($order eq "vax") {
+			return ("v", 2);
+		} else {
+			return ("n", 2);
+		}
+	} elsif($type eq "dword") {
+		if($order eq "vax") {
+			return ("V", 4);
+		} else {
+			return ("N", 4);
+		}
+	}
+
+	confess "Invalid num type: $type";
+}
+
+# Specification for OSCAR protocol template:
+#	-Listref whose elements are hashrefs.
+#	-Hashrefs have following keys:
+#		type: "ref", "num", "data", or "tlvchain"
+#		If type = "num":
+#			packlet: Pack template letter (C, n, N, v, V)
+#			len: Length of datum, in bytes
+#			enum_byname: If this is an enum, map of names to values.
+#			enum_byval: If this is an enum, map of values to names.
+#		If type = "data":
+#			Arbitrary data
+#			If prefix isn't present, all available data will be gobbled.
+#			len (optional): Size of datum, in bytes
+#			null_terminated (optional): Data is terminated by a null (0x00) byte
+#		If type = "ref":
+#			name: Name of protocol bit to punt to
+#		If type = "tlvchain":
+#			subtyped: If true, this is a 'subtyped' TLV, as per Protocol.dtd.
+#			prefix: If present, "count" or "length", and "packlet" and "len" will also be present.
+#			items: Listref containing TLVs, hashrefs in format identical to these, with extra key 'num' (and 'subtype', for subtyped TLVs.)
+#		value: If present, default value of this datum.
+#		name: If present, name in parameter list that this datum gets.
+#		count: If present, number of repetitions of this datum.  count==-1 represents
+#			infinite.  If a count is present when unpacking, the data will be encapsulated in a listref.  If the user
+#			wants to pass in multiple data when packing, they should do so via a listref.  Listref-encapsulated data with
+#			too many elements for the 'count' will trigger an exception when packing.
+#		prefix: If present, either "count" or "length", and indicates that datum has a prefix indicating its length.
+#			prefix_packet, prefix_len: As per "num".
+#
+sub _xmlnode_to_template($$) {
+	my($tag, $value) = @_;
+
+	confess "Invalid value in xmlnode_to_template!" unless ref($value);
+	my $attrs = shift @$value;
+
+	my $datum = {};
+	$datum->{name} = $attrs->{name} if $attrs->{name};
+	$datum->{value} = "" if $attrs->{default_generate} and $attrs->{default_generate} ne "no";
+	$datum->{value} = $value->[1] if @$value and $value->[1] =~ /\S/;
+
+	$datum->{count} = $attrs->{count} if $attrs->{count};
+	if($attrs->{count_prefix} || $attrs->{length_prefix}) {
+		my($packlet, $len) = _num_to_packlen($attrs->{count_prefix} || $attrs->{length_prefix}, $attrs->{prefix_order});
+		$datum->{prefix_packlet} = $packlet;
+		$datum->{prefix_len} = $len;
+		$datum->{prefix} = $attrs->{count_prefix} ? "count" : "length";
+	}
+
+
+	if($tag eq "ref") {
+		$datum->{type} = "ref";
+	} elsif($tag eq "byte" or $tag eq "word" or $tag eq "dword" or $tag eq "enum") {
+		$datum->{type} = "num";
+
+		my $enum = 0;
+		if($tag eq "enum") {
+			$tag = $attrs->{type};
+			$enum = 1;
+		}
+
+		my($packlet, $len) = _num_to_packlen($tag, $attrs->{order});
+		$datum->{packlet} = $packlet;
+		$datum->{len} = $len;
+
+		if($enum) {
+			$datum->{enum_byname} = {};
+			$datum->{enum_byval} = {};
+
+			while(@$value) {
+				my($subtag, $subval) = splice(@$value, 0, 2);
+				next if $subtag eq "0";
+
+				my $attrs = shift @$subval;
+				my($name, $value, $default) = ($attrs->{name}, $attrs->{value}, $attrs->{default});
+				$datum->{enum_byname}->{$name} = $value;
+				$datum->{enum_byval}->{$value} = $name;
+				$datum->{value} = $value if $default;
+			}
+		} else {
+			$datum->{value} = $value->[1] if @$value;
+		}
+	} elsif($tag eq "data") {
+		$datum->{type} = "data";
+		$datum->{len} = $attrs->{length} if $attrs->{length};
+		$datum->{pad} = $attrs->{pad} if exists($attrs->{pad});
+		$datum->{null_terminated} = 1 if $attrs->{null_terminated} and $attrs->{null_terminated} eq "yes";
+
+		while(@$value) {
+			my($subtag, $subval) = splice(@$value, 0, 2);
+			if($subtag eq "0") {
+				$datum->{value} ||= $subval if $subval =~ /\S/;
+				next;
+			}
+
+			my $item = _xmlnode_to_template($subtag, $subval);
+			$datum->{items} ||= [];
+			push @{$datum->{items}}, $item;
+		}
+	} elsif($tag eq "tlvchain") {
+		$datum->{type} = "tlvchain";
+		$datum->{len} = $attrs->{length} if $attrs->{length};
+		$datum->{subtyped} = 1 if $attrs->{subtyped} and $attrs->{subtyped} eq "yes";
+
+		my($subtag, $subval);
+
+		while(@$value) {
+			my($tlvtag, $tlvval) = splice(@$value, 0, 2);
+			next if $tlvtag ne "tlv";
+			my $tlvattrs = shift @$tlvval;
+
+			my $item = {};
+			$item->{type} = "data";
+			$item->{name} = $tlvattrs->{name} if $tlvattrs->{name};
+			$item->{num} = $tlvattrs->{type};
+			$item->{subtype} = $tlvattrs->{subtype} if $tlvattrs->{subtype};
+			$item->{count} = $tlvattrs->{count} if $tlvattrs->{count};
+			$item->{value} = "" if $tlvattrs->{default_generate} and $tlvattrs->{default_generate} ne "no";
+			$item->{items} = [];
+
+			while(@$tlvval) {
+				my($subtag, $subval) = splice(@$tlvval, 0, 2);
+				next if $subtag eq "0";
+				my $tlvitem = _xmlnode_to_template($subtag, $subval);
+
+				push @{$item->{items}}, $tlvitem;
+			}
+
+
+			push @{$datum->{items}}, $item;
+		}
+	}
+
+	return $datum;
+}
+
+
+
+our(%PROTOCACHE);
+sub protoparse($$) {
+	my ($oscar, $wanted) = @_;
+	return $PROTOCACHE{$wanted}->set_oscar($oscar) if exists($PROTOCACHE{$wanted});
+
+	my $xml = $xmlmap{$wanted}->{xml} or croak "Couldn't find requested protocol element '$wanted'.";
+
+	confess "No oscar!" unless $oscar;
+
+	my $attrs = shift @$xml;
+
+	my @template = ();
+
+	while(@$xml) {
+		my $tag = shift @$xml;
+		my $value = shift @$xml;
+		next if $tag eq "0";
+		push @template, _xmlnode_to_template($tag, $value);
+	}
+
+	return @template if $PROTOPARSE_DEBUG;	
+	my $obj = Net::OSCAR::XML::Template->new(\@template);
+	$PROTOCACHE{$wanted} = $obj;
+	return $obj->set_oscar($oscar);
+}
+
+
+
+# Map a "protobit" (XML <define name="foo">) to SNAC (family => foo, subtype => bar)
+sub protobit_to_snac($) {
+	my $protobit = shift;
+	confess "Unknown protobit $protobit" unless $xmlmap{$protobit};
+
+	my %ret = %{$xmlmap{$protobit}};
+	delete $ret{xml};
+	return %ret;
+}
+
+# Map a SNAC (family => foo, subtype => bar) to "protobit" (XML <define name="foo">)
+sub snac_to_protobit(%) {
+	my(%snac) = @_;
+	if($xml_revmap{$snac{family}} and $xml_revmap{$snac{family}}->{$snac{subtype}}) {
+		return $xml_revmap{$snac{family}}->{$snac{subtype}};
+	} elsif($xml_revmap{'-1'} and $xml_revmap{'-1'}->{$snac{subtype}}) {
+		return $xml_revmap{'-1'}->{$snac{subtype}};
+	} else {
+		return undef;
+	}
+}
+
+1;
