1 | =pod |
---|
2 | |
---|
3 | Net::OSCAR::XML -- XML functions for Net::OSCAR |
---|
4 | |
---|
5 | We're doing the fancy-schmancy Protocol.xml stuff here, so I'll explain it here. |
---|
6 | |
---|
7 | Protocol.xml contains a number of "OSCAR protocol elements". One E<lt>defineE<gt> block |
---|
8 | is one OSCAR protocol elemennt. |
---|
9 | |
---|
10 | When the module is first loaded, Protocol.xml is parsed and two hashes are created, |
---|
11 | one whose keys are the names the the elements and whose values are the contents |
---|
12 | of the XML::Parser tree which represents the contents of those elements; the other |
---|
13 | hash has a family/subtype tuple as a key and element names as a value. |
---|
14 | |
---|
15 | To do something with an element, given its name, Net::OSCAR calls C<protoparse("element name")>. |
---|
16 | This returns a C<Net::OSCAR::XML::Template> object, which has C<pack> and C<unpack> methods. |
---|
17 | C<pack> takes a hash and returns a string of binary characters, and C<unpack> goes the |
---|
18 | other way around. The objects are cached, so C<protoparse> only has to do actual work once |
---|
19 | for every protocol element. |
---|
20 | |
---|
21 | =cut |
---|
22 | |
---|
23 | package Net::OSCAR::XML; |
---|
24 | |
---|
25 | $VERSION = '1.925'; |
---|
26 | $REVISION = '$Revision: 1.24 $'; |
---|
27 | |
---|
28 | use strict; |
---|
29 | use vars qw(@ISA @EXPORT $VERSION); |
---|
30 | use Carp; |
---|
31 | use Data::Dumper; |
---|
32 | |
---|
33 | use Net::OSCAR::TLV; |
---|
34 | use Net::OSCAR::XML::Template; |
---|
35 | our(%xmlmap, %xml_revmap, $PROTOPARSE_DEBUG, $NO_XML_CACHE); |
---|
36 | |
---|
37 | require Exporter; |
---|
38 | @ISA = qw(Exporter); |
---|
39 | @EXPORT = qw( |
---|
40 | protoparse protobit_to_snac snac_to_protobit |
---|
41 | ); |
---|
42 | |
---|
43 | $PROTOPARSE_DEBUG = 0; |
---|
44 | $NO_XML_CACHE = 0; |
---|
45 | |
---|
46 | sub _protopack($$;@); |
---|
47 | sub _xmlnode_to_template($$); |
---|
48 | |
---|
49 | sub load_xml(;$) { |
---|
50 | # Look for parsed-xml file |
---|
51 | if(!$NO_XML_CACHE) { |
---|
52 | foreach (@INC) { |
---|
53 | next unless ref($_) eq 'CODE' || -f "$_/Net/OSCAR/XML/Protocol.parsed-xml"; |
---|
54 | |
---|
55 | if (ref($_) eq 'CODE') { |
---|
56 | *XMLCACHE = $_->($_, 'Net/OSCAR/XML/Protocol.parsed-xml'); |
---|
57 | next if (\*XMLCACHE == undef); |
---|
58 | } else { |
---|
59 | open(XMLCACHE, "$_/Net/OSCAR/XML/Protocol.parsed-xml") or next; |
---|
60 | } |
---|
61 | my $xmlcache = join("", <XMLCACHE>); |
---|
62 | close(XMLCACHE); |
---|
63 | |
---|
64 | my $xmlparse; |
---|
65 | eval $xmlcache or die "Coldn't load xml cache: $@\n"; |
---|
66 | die $@ if $@; |
---|
67 | return parse_xml($xmlparse); |
---|
68 | } |
---|
69 | } |
---|
70 | |
---|
71 | eval { |
---|
72 | require XML::Parser; |
---|
73 | } or die "Couldn't load XML::Parser ($@)\n"; |
---|
74 | die $@ if $@; |
---|
75 | |
---|
76 | my $xmlparser = new XML::Parser(Style => "Tree"); |
---|
77 | |
---|
78 | my $xmlfile = ""; |
---|
79 | if($_[0]) { |
---|
80 | $xmlfile = shift; |
---|
81 | } else { |
---|
82 | foreach (@INC) { |
---|
83 | next unless -f "$_/Net/OSCAR/XML/Protocol.xml"; |
---|
84 | $xmlfile = "$_/Net/OSCAR/XML/Protocol.xml"; |
---|
85 | last; |
---|
86 | } |
---|
87 | croak "Couldn't find Net/OSCAR/XML/Protocol.xml in search path: " . join(" ", @INC) unless $xmlfile; |
---|
88 | } |
---|
89 | |
---|
90 | open(XMLFILE, $xmlfile) or croak "Couldn't open $xmlfile: $!"; |
---|
91 | my $xml = join("", <XMLFILE>); |
---|
92 | close XMLFILE; |
---|
93 | my $xmlparse = $xmlparser->parse($xml) or croak "Couldn't parse XML from $xmlfile: $@"; |
---|
94 | |
---|
95 | parse_xml($xmlparse); |
---|
96 | } |
---|
97 | |
---|
98 | sub add_xml_data($) { |
---|
99 | my $xmlparse = shift; |
---|
100 | |
---|
101 | my @tags = @{$xmlparse->[1]}; # Get contents of <oscar> |
---|
102 | shift @tags; |
---|
103 | while(@tags) { |
---|
104 | my($name, $value); |
---|
105 | (undef, undef, $name, $value) = splice(@tags, 0, 4); |
---|
106 | next unless $name and $name eq "define"; |
---|
107 | |
---|
108 | my %protobit = (xml => $value); |
---|
109 | my %attrs = %{$value->[0]}; |
---|
110 | $protobit{$_} = $attrs{$_} foreach keys %attrs; |
---|
111 | $xml_revmap{$attrs{family}}->{$attrs{subtype}} = $attrs{name} if exists($attrs{family}) and exists($attrs{subtype}); |
---|
112 | $xmlmap{$attrs{name}} = \%protobit; |
---|
113 | } |
---|
114 | } |
---|
115 | |
---|
116 | sub parse_xml($) { |
---|
117 | my $xmlparse = shift; |
---|
118 | |
---|
119 | %xmlmap = (); |
---|
120 | %xml_revmap = (); |
---|
121 | # We set the autovivification so that keys of xml_revmap are Net::OSCAR::TLV hashrefs. |
---|
122 | if(!tied(%xml_revmap)) { |
---|
123 | tie %xml_revmap, "Net::OSCAR::TLV", 'tie %$value, ref($self)'; |
---|
124 | } |
---|
125 | |
---|
126 | add_xml_data($xmlparse); |
---|
127 | |
---|
128 | return 1; |
---|
129 | } |
---|
130 | |
---|
131 | sub _num_to_packlen($$) { |
---|
132 | my($type, $order) = @_; |
---|
133 | $order ||= "network"; |
---|
134 | |
---|
135 | if($type eq "byte") { |
---|
136 | return ("C", 1); |
---|
137 | } elsif($type eq "word") { |
---|
138 | if($order eq "vax") { |
---|
139 | return ("v", 2); |
---|
140 | } else { |
---|
141 | return ("n", 2); |
---|
142 | } |
---|
143 | } elsif($type eq "dword") { |
---|
144 | if($order eq "vax") { |
---|
145 | return ("V", 4); |
---|
146 | } else { |
---|
147 | return ("N", 4); |
---|
148 | } |
---|
149 | } |
---|
150 | |
---|
151 | confess "Invalid num type: $type"; |
---|
152 | } |
---|
153 | |
---|
154 | # Specification for OSCAR protocol template: |
---|
155 | # -Listref whose elements are hashrefs. |
---|
156 | # -Hashrefs have following keys: |
---|
157 | # type: "ref", "num", "data", or "tlvchain" |
---|
158 | # If type = "num": |
---|
159 | # packlet: Pack template letter (C, n, N, v, V) |
---|
160 | # len: Length of datum, in bytes |
---|
161 | # enum_byname: If this is an enum, map of names to values. |
---|
162 | # enum_byval: If this is an enum, map of values to names. |
---|
163 | # If type = "data": |
---|
164 | # Arbitrary data |
---|
165 | # If prefix isn't present, all available data will be gobbled. |
---|
166 | # len (optional): Size of datum, in bytes |
---|
167 | # null_terminated (optional): Data is terminated by a null (0x00) byte |
---|
168 | # If type = "ref": |
---|
169 | # name: Name of protocol bit to punt to |
---|
170 | # If type = "tlvchain": |
---|
171 | # subtyped: If true, this is a 'subtyped' TLV, as per Protocol.dtd. |
---|
172 | # prefix: If present, "count" or "length", and "packlet" and "len" will also be present. |
---|
173 | # items: Listref containing TLVs, hashrefs in format identical to these, with extra key 'num' (and 'subtype', for subtyped TLVs.) |
---|
174 | # value: If present, default value of this datum. |
---|
175 | # name: If present, name in parameter list that this datum gets. |
---|
176 | # count: If present, number of repetitions of this datum. count==-1 represents |
---|
177 | # infinite. If a count is present when unpacking, the data will be encapsulated in a listref. If the user |
---|
178 | # wants to pass in multiple data when packing, they should do so via a listref. Listref-encapsulated data with |
---|
179 | # too many elements for the 'count' will trigger an exception when packing. |
---|
180 | # prefix: If present, either "count" or "length", and indicates that datum has a prefix indicating its length. |
---|
181 | # prefix_packet, prefix_len: As per "num". |
---|
182 | # |
---|
183 | sub _xmlnode_to_template($$) { |
---|
184 | my($tag, $value) = @_; |
---|
185 | |
---|
186 | confess "Invalid value in xmlnode_to_template!" unless ref($value); |
---|
187 | my $attrs = shift @$value; |
---|
188 | |
---|
189 | my $datum = {}; |
---|
190 | $datum->{name} = $attrs->{name} if $attrs->{name}; |
---|
191 | $datum->{value} = "" if $attrs->{default_generate} and $attrs->{default_generate} ne "no"; |
---|
192 | $datum->{value} = $value->[1] if @$value and $value->[1] =~ /\S/; |
---|
193 | |
---|
194 | $datum->{count} = $attrs->{count} if $attrs->{count}; |
---|
195 | if($attrs->{count_prefix} || $attrs->{length_prefix}) { |
---|
196 | my($packlet, $len) = _num_to_packlen($attrs->{count_prefix} || $attrs->{length_prefix}, $attrs->{prefix_order}); |
---|
197 | $datum->{prefix_packlet} = $packlet; |
---|
198 | $datum->{prefix_len} = $len; |
---|
199 | $datum->{prefix} = $attrs->{count_prefix} ? "count" : "length"; |
---|
200 | } |
---|
201 | |
---|
202 | |
---|
203 | if($tag eq "ref") { |
---|
204 | $datum->{type} = "ref"; |
---|
205 | } elsif($tag eq "byte" or $tag eq "word" or $tag eq "dword" or $tag eq "enum") { |
---|
206 | $datum->{type} = "num"; |
---|
207 | |
---|
208 | my $enum = 0; |
---|
209 | if($tag eq "enum") { |
---|
210 | $tag = $attrs->{type}; |
---|
211 | $enum = 1; |
---|
212 | } |
---|
213 | |
---|
214 | my($packlet, $len) = _num_to_packlen($tag, $attrs->{order}); |
---|
215 | $datum->{packlet} = $packlet; |
---|
216 | $datum->{len} = $len; |
---|
217 | |
---|
218 | if($enum) { |
---|
219 | $datum->{enum_byname} = {}; |
---|
220 | $datum->{enum_byval} = {}; |
---|
221 | |
---|
222 | while(@$value) { |
---|
223 | my($subtag, $subval) = splice(@$value, 0, 2); |
---|
224 | next if $subtag eq "0"; |
---|
225 | |
---|
226 | my $attrs = shift @$subval; |
---|
227 | my($name, $value, $default) = ($attrs->{name}, $attrs->{value}, $attrs->{default}); |
---|
228 | $datum->{enum_byname}->{$name} = $value; |
---|
229 | $datum->{enum_byval}->{$value} = $name; |
---|
230 | $datum->{value} = $value if $default; |
---|
231 | } |
---|
232 | } else { |
---|
233 | $datum->{value} = $value->[1] if @$value; |
---|
234 | } |
---|
235 | } elsif($tag eq "data") { |
---|
236 | $datum->{type} = "data"; |
---|
237 | $datum->{len} = $attrs->{length} if $attrs->{length}; |
---|
238 | $datum->{pad} = $attrs->{pad} if exists($attrs->{pad}); |
---|
239 | $datum->{null_terminated} = 1 if $attrs->{null_terminated} and $attrs->{null_terminated} eq "yes"; |
---|
240 | |
---|
241 | while(@$value) { |
---|
242 | my($subtag, $subval) = splice(@$value, 0, 2); |
---|
243 | if($subtag eq "0") { |
---|
244 | $datum->{value} ||= $subval if $subval =~ /\S/; |
---|
245 | next; |
---|
246 | } |
---|
247 | |
---|
248 | my $item = _xmlnode_to_template($subtag, $subval); |
---|
249 | $datum->{items} ||= []; |
---|
250 | push @{$datum->{items}}, $item; |
---|
251 | } |
---|
252 | } elsif($tag eq "tlvchain") { |
---|
253 | $datum->{type} = "tlvchain"; |
---|
254 | $datum->{len} = $attrs->{length} if $attrs->{length}; |
---|
255 | $datum->{subtyped} = 1 if $attrs->{subtyped} and $attrs->{subtyped} eq "yes"; |
---|
256 | |
---|
257 | my($subtag, $subval); |
---|
258 | |
---|
259 | while(@$value) { |
---|
260 | my($tlvtag, $tlvval) = splice(@$value, 0, 2); |
---|
261 | next if $tlvtag ne "tlv"; |
---|
262 | my $tlvattrs = shift @$tlvval; |
---|
263 | |
---|
264 | my $item = {}; |
---|
265 | $item->{type} = "data"; |
---|
266 | $item->{name} = $tlvattrs->{name} if $tlvattrs->{name}; |
---|
267 | $item->{num} = $tlvattrs->{type}; |
---|
268 | $item->{subtype} = $tlvattrs->{subtype} if $tlvattrs->{subtype}; |
---|
269 | $item->{count} = $tlvattrs->{count} if $tlvattrs->{count}; |
---|
270 | $item->{value} = "" if $tlvattrs->{default_generate} and $tlvattrs->{default_generate} ne "no"; |
---|
271 | $item->{items} = []; |
---|
272 | |
---|
273 | while(@$tlvval) { |
---|
274 | my($subtag, $subval) = splice(@$tlvval, 0, 2); |
---|
275 | next if $subtag eq "0"; |
---|
276 | my $tlvitem = _xmlnode_to_template($subtag, $subval); |
---|
277 | |
---|
278 | push @{$item->{items}}, $tlvitem; |
---|
279 | } |
---|
280 | |
---|
281 | |
---|
282 | push @{$datum->{items}}, $item; |
---|
283 | } |
---|
284 | } |
---|
285 | |
---|
286 | return $datum; |
---|
287 | } |
---|
288 | |
---|
289 | |
---|
290 | |
---|
291 | our(%PROTOCACHE); |
---|
292 | sub protoparse($$) { |
---|
293 | my ($oscar, $wanted) = @_; |
---|
294 | return $PROTOCACHE{$wanted}->set_oscar($oscar) if exists($PROTOCACHE{$wanted}); |
---|
295 | |
---|
296 | my $xml = $xmlmap{$wanted}->{xml} or croak "Couldn't find requested protocol element '$wanted'."; |
---|
297 | |
---|
298 | confess "No oscar!" unless $oscar; |
---|
299 | |
---|
300 | my $attrs = shift @$xml; |
---|
301 | |
---|
302 | my @template = (); |
---|
303 | |
---|
304 | while(@$xml) { |
---|
305 | my $tag = shift @$xml; |
---|
306 | my $value = shift @$xml; |
---|
307 | next if $tag eq "0"; |
---|
308 | push @template, _xmlnode_to_template($tag, $value); |
---|
309 | } |
---|
310 | |
---|
311 | return @template if $PROTOPARSE_DEBUG; |
---|
312 | my $obj = Net::OSCAR::XML::Template->new(\@template); |
---|
313 | $PROTOCACHE{$wanted} = $obj; |
---|
314 | return $obj->set_oscar($oscar); |
---|
315 | } |
---|
316 | |
---|
317 | |
---|
318 | |
---|
319 | # Map a "protobit" (XML <define name="foo">) to SNAC (family => foo, subtype => bar) |
---|
320 | sub protobit_to_snac($) { |
---|
321 | my $protobit = shift; |
---|
322 | confess "Unknown protobit $protobit" unless $xmlmap{$protobit}; |
---|
323 | |
---|
324 | my %ret = %{$xmlmap{$protobit}}; |
---|
325 | delete $ret{xml}; |
---|
326 | return %ret; |
---|
327 | } |
---|
328 | |
---|
329 | # Map a SNAC (family => foo, subtype => bar) to "protobit" (XML <define name="foo">) |
---|
330 | sub snac_to_protobit(%) { |
---|
331 | my(%snac) = @_; |
---|
332 | if($xml_revmap{$snac{family}} and $xml_revmap{$snac{family}}->{$snac{subtype}}) { |
---|
333 | return $xml_revmap{$snac{family}}->{$snac{subtype}}; |
---|
334 | } elsif($xml_revmap{'-1'} and $xml_revmap{'-1'}->{$snac{subtype}}) { |
---|
335 | return $xml_revmap{'-1'}->{$snac{subtype}}; |
---|
336 | } else { |
---|
337 | return undef; |
---|
338 | } |
---|
339 | } |
---|
340 | |
---|
341 | 1; |
---|