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

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