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

barnowl_perlaim
Last change on this file since 3dcccba was 7a1c90d, checked in by Geoffrey Thomas <geofft@mit.edu>, 16 years ago
Skeleton AIM module, and Net::OSCAR 1.925
  • Property mode set to 100644
File size: 14.3 KB
Line 
1# These objects, initialized with an "OSCAR protocol template" from Net::OSCAR::XML::protoparse,
2# pack and unpack data according to the specification of that template.
3
4package Net::OSCAR::XML::Template;
5
6use strict;
7use warnings;
8
9use Net::OSCAR::XML;
10use Net::OSCAR::Common qw(:loglevels);
11use Net::OSCAR::Utility qw(hexdump);
12use Net::OSCAR::TLV;
13use Data::Dumper;
14use Carp;
15
16sub new($@) {
17        my $class = shift;
18        my $package = ref($class) || $class || "Net::OSCAR::XML::Template";
19        my $self = {template => $_[0]};
20        $self->{oscar} = $class->{oscar} if ref($class) and $class->{oscar};
21        bless $self, $package;
22        return $self;
23}
24
25# Net::OSCAR::XML caches Template objects that don't have an associated OSCAR,
26# so that the same Template can be reused with multiple OSCAR objects.
27# Before returning a Template to the user, it calls set_oscar, so here we clone
28# ourself with the new OSCAR.
29#
30sub set_oscar($$) {
31        my($self, $oscar) = @_;
32        my $clone = $self->new($self->{template});
33        $clone->{oscar} = $oscar;
34        return $clone;
35}
36
37
38# If given a scalar ref instead of a scalar as the second argument,
39# we will modify the packet in-place.
40sub unpack($$) {
41        my ($self, $x_packet) = @_;
42        my $oscar = $self->{oscar};
43        my $template = $self->{template};
44        my $packet = ref($x_packet) ? $$x_packet : $x_packet;
45
46        my %data = ();
47
48        $oscar->log_print_cond(OSCAR_DBG_XML, sub { "Decoding:\n", hexdump($packet), "\n according to: ", Data::Dumper::Dumper($template) });
49
50        assert(ref($template) eq "ARRAY");
51        foreach my $datum (@$template) {
52                # In TLV chains, count refers to number of TLVs, not number of repetitions of the datum, so it defaults to infinite.
53                my $count = $datum->{count} || ($datum->{type} eq "tlvchain" ? -1 : 1);
54                my @results;
55
56
57                ## Figure out how much input data this datum is dealing with
58
59                if($datum->{prefix} and $datum->{prefix} eq "count") {
60                        ($count) = unpack($datum->{prefix_packlet}, substr($packet, 0, $datum->{prefix_len}, "")) || 0;
61                }
62
63                my $size = undef;
64                if($datum->{type} eq "num") {
65                        if($count != -1) {
66                                $size = $datum->{len} * $count;
67                        } else {
68                                $size = length($packet);
69                        }
70                } else {
71                        if($datum->{prefix} and $datum->{prefix} eq "length") {
72                                ($size) = unpack($datum->{prefix_packlet}, substr($packet, 0, $datum->{prefix_len}, ""));
73                        } elsif(exists($datum->{len})) {
74                                # In TLV chains, count is the number of TLVs, not a repeat
75                                # count for the datum.
76                                if($datum->{type} eq "tlvchain") {
77                                        $size = $datum->{len};
78                                } else {
79                                        if($count == -1) {
80                                                $size = length($packet);
81                                        } else {
82                                                $size = $datum->{len} * $count;
83                                        }
84                                }
85                        }
86                }
87
88                my $input;
89                if(defined($size)) {
90                        $input = substr($packet, 0, $size, "");
91                } else {
92                        $input = $packet;
93                }
94
95
96                ## Okay, we have our input data -- act on it
97
98                if($datum->{type} eq "num") {
99                        for(my $i = 0; ($input ne "") and ($count == -1 or $i < $count); $i++) {
100                                push @results, unpack($datum->{packlet}, substr($input, 0, $datum->{len}, ""));
101
102                                if(exists($datum->{enum_byval}) and exists($datum->{enum_byval}->{$results[-1]})) {
103                                        $results[-1] = $datum->{enum_byval}->{$results[-1]};
104                                }
105                        }
106                } elsif($datum->{type} eq "data" or $datum->{type} eq "ref") {
107                        # If we just have simple, no preset length, no subitems, raw data, it can't have a repeat count, since the first repetition will gobble up everything
108                        assert($datum->{type} ne "data" or ($datum->{items} and @{$datum->{items}}) or defined($size) or $count == 1 or $datum->{null_terminated});
109
110                        # We want:
111                        #       <data length_prefix="num" />
112                        # to be empty string, not undefined, when length==0.
113                        if(!$input and $count == 1 and defined($size)) {
114                                push @results, "";
115                        }
116
117                        for(my $i = 0; $input and ($count == -1 or $i < $count); $i++) {
118                                # So, consider the structure:
119                                #       <data name="foo">
120                                #               <word />
121                                #               <word />
122                                #       </data>
123                                # We don't know the size of 'foo' in advance.
124                                # Thus, we pass a reference to the actual packet into protopack.
125                                # subpacket will be modified to be the packet minus the bits that the contents of the data consumed.
126
127                                my %tmp;
128                                if($datum->{type} eq "data") {
129                                        my $subinput;
130                                        if($datum->{len}) {
131                                                $subinput = substr($input, 0, $datum->{len}, "");
132                                        } elsif($datum->{null_terminated}) {
133                                                $input =~ s/^(.*?)\0//;
134                                                $subinput = $1;
135                                        } else {
136                                                $subinput = $input;
137                                                $input = "";
138                                        }
139
140                                        if(exists($datum->{pad})) {
141                                                my $pad = chr($datum->{pad});
142                                                $subinput =~ s/$pad*$//;
143                                        }
144
145                                        if($datum->{items} and @{$datum->{items}}) {
146                                                assert(!$datum->{null_terminated});
147                                                (%tmp) = $self->new($datum->{items})->unpack(\$subinput);
148                                                $input = $subinput unless $datum->{len};
149                                        } else {
150                                                $subinput =~ s/\0$// if $datum->{null_terminated};
151
152                                                # The simple case -- raw <data />
153                                                push @results, $subinput if $datum->{name};
154                                        }
155                                } elsif($datum->{type} eq "ref") {
156                                        (%tmp) = protoparse($oscar, $datum->{name})->unpack(\$input);
157                                }
158
159                                push @results, \%tmp if %tmp;
160                        }
161                } elsif($datum->{type} eq "tlvchain") {
162                        my @unknown;
163
164                        ## First set up a hash to store the data for each TLV, grouped by (sub)type
165                        ##
166                        my $tlvmap = tlv();
167                        if($datum->{subtyped}) {
168                                foreach (@{$datum->{items}}) {
169                                        $tlvmap->{$_->{num}} ||= tlv();
170                                        $tlvmap->{$_->{num}}->{$_->{subtype} || -1} = {%$_};
171                                }
172                        } else {
173                                $tlvmap->{$_->{num}} = {%$_} foreach (@{$datum->{items}});
174                        }
175
176                        ## Now, go through the chain and split the data into TLVs.
177                        ##
178                        for(my $i = 0; $input and ($count == -1 or $i < $count); $i++) {
179                                my %tlv;
180                                if($datum->{subtyped}) {
181                                        (%tlv) = protoparse($oscar, "subtyped_TLV")->unpack(\$input);
182                                } else {
183                                        (%tlv) = protoparse($oscar, "TLV")->unpack(\$input);
184                                }
185
186                                my $unknown = 0;
187                                if(!exists($tlvmap->{$tlv{type}})) {
188                                        $tlvmap->{$tlv{type}} = $datum->{subtyped} ? tlv() : {};
189                                        $unknown = 1;
190                                }                               
191
192                                assert(!exists($tlv{name})) if exists($tlv{count});
193                                if($datum->{subtyped}) {
194                                        assert(exists($tlv{subtype}));
195
196                                        if(!exists($tlvmap->{$tlv{type}}->{$tlv{subtype}})) {
197                                                if(exists($tlvmap->{$tlv{type}}->{-1})) {
198                                                        $tlv{subtype} = -1;
199                                                } else {
200                                                        $tlvmap->{$tlv{type}}->{$tlv{subtype}} = {};
201                                                        $unknown = 1;
202                                                }
203                                        }
204
205                                        if(!$unknown) {
206                                                my $type = $tlv{type};
207                                                my $subtype = $tlv{subtype};
208                                                $tlvmap->{$type}->{$subtype}->{data} ||= [];
209                                                $tlvmap->{$type}->{$subtype}->{outdata} ||= [];
210
211                                                $tlv{data} = "" if !defined($tlv{data});
212                                                push @{$tlvmap->{$type}->{$subtype}->{data}}, $tlv{data};
213                                        } else {
214                                                push @unknown, {
215                                                        type => $tlv{type},
216                                                        subtype => $tlv{subtype},
217                                                        data => $tlv{data}
218                                                };
219                                        }
220                                } else {
221                                        if(!$unknown) {
222                                                my $type = $tlv{type};
223                                                $tlvmap->{$type}->{data} ||= [];
224                                                $tlvmap->{$type}->{outdata} ||= [];
225
226                                                $tlv{data} = "" if !defined($tlv{data});
227                                                push @{$tlvmap->{$tlv{type}}->{data}}, $tlv{data};
228                                        } else {
229                                                push @unknown, {
230                                                        type => $tlv{type},
231                                                        data => $tlv{data}
232                                                };
233                                        }
234                                }
235                        }
236
237                        ## Almost done!  Go back through the hash we made earlier, which now has the
238                        ## data in it, and figure out which TLVs we want to emit.
239                        ##
240                        my @outvals;
241                        while(my($num, $val) = each %$tlvmap) {
242                                if($datum->{subtyped}) {
243                                        while(my($subtype, $subval) = each %$val) {
244                                                push @outvals, $subval if exists($subval->{data});
245                                        }
246                                } else {
247                                        push @outvals, $val if exists($val->{data});
248                                }
249                        }
250
251
252                        ## Okay, now take the TLVs to emit, and structure the output correctly
253                        ## for each thing-to-emit.  We'll need to do one last phase of postprocessing
254                        ## so that we can group counted TLVs correctly.
255                        ##
256                        foreach my $val (@outvals) {
257                                foreach (@{$val->{data}}) {
258                                        next unless exists($val->{items});
259                                        my(%tmp) = $self->new($val->{items})->unpack($_);
260                                        # We want:
261                                        #   <tlv type="1"><data name="x" /></tlv>
262                                        # to give x => "" when TLV 1 is present but empty,
263                                        # not x => undef.
264                                        if(@{$val->{items}} == 1 and $val->{items}->[0]->{name}) {
265                                                my $name = $val->{items}->[0]->{name};
266                                                $tmp{$name} = "" if !defined($tmp{$name});
267                                        }
268
269                                        if(@{$val->{items}}) {
270                                                push @{$val->{outdata}}, \%tmp;
271                                        } else {
272                                                push @{$val->{outdata}}, "";
273                                        }
274                                }
275                        }
276
277
278                        ## Okay, we've stashed the output (formatted data structures) for each TLV.
279                        ## Now we need to merge these into results.
280                        ## This is normally just pushing everything out to results, as a hashref
281                        ## under the TLVs name for named TLVs, but counted TLVs also need to
282                        ## be layered into an array.
283                        ##
284                        foreach my $val (@outvals) {
285                                if(exists($val->{count})) {
286                                        if(exists($val->{name})) {
287                                                push @results, {
288                                                        $val->{name} => $val->{outdata}
289                                                };
290                                        } else {
291                                                push @results, $val->{outdata}->[0];
292                                        }
293                                } else {
294                                        if(exists($val->{name})) {
295                                                push @results, {
296                                                        $val->{name} => $val->{outdata}->[0]
297                                                };
298                                        } else {
299                                                push @results, $val->{outdata}->[0];
300                                        }
301                                }
302                        }
303
304                        push @results, {__UNKNOWN => [@unknown]} if @unknown;
305                }
306
307
308                # If we didn't know the length of the datum in advance,
309                # we've been modifying the entire packet in-place.
310                $packet = $input if !defined($size);
311
312
313                ## Okay, we have the results from this datum, store them away.
314
315                if($datum->{name}) {
316                        if($datum->{count} or ($datum->{prefix} and $datum->{prefix} eq "count")) {
317                                $data{$datum->{name}} = \@results;
318                        } elsif(
319                          $datum->{type} eq "ref" or
320                          (ref($datum->{items}) and @{$datum->{items}})
321                        ) {
322                                $data{$_} = $results[0]->{$_} foreach keys %{$results[0]};
323                        } else {
324                                $data{$datum->{name}} = $results[0];
325                        }
326                } elsif(@results) {
327                        foreach my $result(@results) {
328                                next unless ref($result);
329                                $data{$_} = $result->{$_} foreach keys %$result;
330                        }
331                }
332        }
333
334        $oscar->log_print_cond(OSCAR_DBG_XML, sub { "Decoded:\n", join("\n", map { "\t$_ => ".(defined($data{$_}) ? hexdump($data{$_}) : 'undef') } keys %data) });
335
336        # Remember, passing in a ref to packet in place of actual packet data == in-place editing...
337        $$x_packet = $packet if ref($x_packet);
338
339        return %data;
340}
341
342
343sub pack($%) {
344        my($self, %data) = @_;
345        my $packet = "";
346        my $oscar = $self->{oscar};
347        my $template = $self->{template};
348
349        $oscar->log_print_cond(OSCAR_DBG_XML, sub { "Encoding:\n", join("\n", map { "\t$_ => ".(defined($data{$_}) ? hexdump($data{$_}) : 'undef') } keys %data), "\n according to: ", Data::Dumper::Dumper($template) });
350
351        assert(ref($template) eq "ARRAY");
352        foreach my $datum (@$template) {
353                my $output = undef;
354
355                ## Figure out what we're packing
356                my $value = undef;
357                $value = $data{$datum->{name}} if $datum->{name};
358                $value = $datum->{value} if !defined($value);
359                my @valarray = ref($value) eq "ARRAY" ? @$value : ($value); # Don't modify $value in-place!
360
361                $datum->{count} = @valarray if $datum->{prefix} and $datum->{prefix} eq "count";
362                my $max_count = exists($datum->{count}) ? $datum->{count} : 1;
363                my $count = 0;
364
365                assert($max_count == -1 or @valarray <= $max_count);
366
367
368                ## Pack it
369                if($datum->{type} eq "num") {
370                        next unless defined($value);
371
372                        for($count = 0; ($max_count == -1 or $count < $max_count) and @valarray; $count++) {
373                                my $val = shift @valarray;
374                                if(exists($datum->{enum_byname}) and exists($datum->{enum_byname}->{$val})) {
375                                        $val = $datum->{enum_byname}->{$val};
376                                }
377
378                                $output .= pack($datum->{packlet}, $val);
379                        }
380                } elsif($datum->{type} eq "data" or $datum->{type} eq "ref") {
381                        for($count = 0; ($max_count == -1 or $count < $max_count) and @valarray; $count++) {
382                                my $val = shift @valarray;
383
384                                if($datum->{items} and @{$datum->{items}}) {
385                                        $output .= $self->new($datum->{items})->pack(ref($val) ? %$val : %data);
386                                } elsif($datum->{type} eq "ref") {
387                                        assert($max_count == 1 or (ref($val) and ref($val) eq "HASH"));
388                                        $output .= protoparse($oscar, $datum->{name})->pack(ref($val) ? %$val : %data);
389                                } else {
390                                        $output .= $val if defined($val);
391                                }
392
393                                $output .= chr(0) if $datum->{null_terminated};
394                                if(exists($datum->{pad})) {
395                                        assert(exists($datum->{len}) and exists($datum->{pad}));
396
397                                        my $outlen = defined($output) ? length($output) : 0;
398                                        my $pad_needed = $datum->{len} - $outlen;
399                                        $output .= chr($datum->{pad}) x $pad_needed if $pad_needed;
400                                }
401                        }
402                } elsif($datum->{type} eq "tlvchain") {
403                        foreach my $tlv (@{$datum->{items}}) {
404                                my $tlvdata = undef;
405
406                                if(exists($tlv->{name})) {
407                                        if(exists($data{$tlv->{name}})) {
408                                                if(@{$tlv->{items}}) {
409                                                        assert(ref($data{$tlv->{name}}) eq "HASH" or ref($data{$tlv->{name}}) eq "ARRAY");
410                                                        if(ref($data{$tlv->{name}}) eq "ARRAY") {
411                                                                $tlvdata = [];
412                                                                push @$tlvdata, $self->new($tlv->{items})->pack(%$_) foreach @{$data{$tlv->{name}}};
413                                                        } else {
414                                                                $tlvdata = [$self->new($tlv->{items})->pack(%{$data{$tlv->{name}}})];
415                                                        }
416                                                } else {
417                                                        $tlvdata = [""] if defined($data{$tlv->{name}});
418                                                }
419                                        } elsif(exists($tlv->{value}) and !@{$tlv->{items}}) {
420                                                $tlvdata = [$tlv->{value}];
421                                        }
422                                } else {
423                                        my $tmp = $self->new($tlv->{items})->pack(%data);
424
425                                        # If TLV has no name and only one element, do special handling for "present but empty" value.
426                                        if($tmp ne "") {
427                                                $tlvdata = [$tmp];
428                                        } elsif(@{$tlv->{items}} == 1 and $tlv->{items}->[0]->{name} and exists($data{$tlv->{items}->[0]->{name}})) {
429                                                $tlvdata = [""];
430                                        } elsif(!@{$tlv->{items}} and exists($tlv->{value})) {
431                                                $tlvdata = [$tlv->{value}];
432                                        }
433                                }
434       
435                                assert($tlv->{num});
436                                next unless defined($tlvdata);
437
438                                $count++;
439                                if($datum->{subtyped}) {
440                                        my $subtype = 0;
441                                        assert(exists($tlv->{subtype}));
442                                        $subtype = $tlv->{subtype} if $tlv->{subtype} != -1;
443
444                                        $output .= protoparse($oscar, "subtyped_TLV")->pack(
445                                                type => $tlv->{num},
446                                                subtype => $subtype,
447                                                data => $_
448                                        ) foreach @$tlvdata;
449                                } else {
450                                        $output .= protoparse($oscar, "TLV")->pack(
451                                                type => $tlv->{num},
452                                                data => $_
453                                        ) foreach @$tlvdata;
454                                }
455                        }
456                }
457
458
459                ## Handle any prefixes
460                if($datum->{prefix} and defined($output)) {
461                        if($datum->{prefix} eq "count") {
462                                $packet .= pack($datum->{prefix_packlet}, $count);
463                        } else {
464                                $packet .= pack($datum->{prefix_packlet}, length($output));
465                        }
466                }
467
468                $packet .= $output if defined($output);
469        }
470
471        $oscar->log_print_cond(OSCAR_DBG_XML, sub { "Encoded:\n", hexdump($packet) });
472        return $packet;
473}
474
475
476sub assert($) {
477        my $test = shift;
478        return if $test;
479        confess("Net::OSCAR internal error");
480}
481
482# Why isn't this imported properly??
483sub protoparse { Net::OSCAR::XML::protoparse(@_); }
484
4851;
Note: See TracBrowser for help on using the repository browser.