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

barnowl_perlaim
Last change on this file since 3dcccba was 5fcf137, checked in by Geoffrey Thomas <geofft@mit.edu>, 13 years ago
Potential fix to Net::OSCAR to make it deal with coderefs in @INC
  • Property mode set to 100644
File size: 9.8 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 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
98sub 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
116sub 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
131sub _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#
183sub _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
291our(%PROTOCACHE);
292sub 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)
320sub 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">)
330sub 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
3411;
Note: See TracBrowser for help on using the repository browser.