source: perl/modules/Jabber/lib/XML/Stream/Tree.pm @ 0dbb7d2

barnowl_perlaimdebianrelease-1.10release-1.4release-1.5release-1.6release-1.7release-1.8release-1.9
Last change on this file since 0dbb7d2 was c2bed55, checked in by Nelson Elhage <nelhage@mit.edu>, 19 years ago
Moving Net::Jabber into Jabber.par
  • Property mode set to 100644
File size: 24.9 KB
Line 
1##############################################################################
2#
3#  This library is free software; you can redistribute it and/or
4#  modify it under the terms of the GNU Library General Public
5#  License as published by the Free Software Foundation; either
6#  version 2 of the License, or (at your option) any later version.
7#
8#  This library is distributed in the hope that it will be useful,
9#  but WITHOUT ANY WARRANTY; without even the implied warranty of
10#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
11#  Library General Public License for more details.
12#
13#  You should have received a copy of the GNU Library General Public
14#  License along with this library; if not, write to the
15#  Free Software Foundation, Inc., 59 Temple Place - Suite 330,
16#  Boston, MA  02111-1307, USA.
17#
18#  Jabber
19#  Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/
20#
21##############################################################################
22
23package XML::Stream::Tree;
24
25=head1 NAME
26
27XML::Stream::Tree - Functions to make building and parsing the tree easier
28to work with.
29
30=head1 SYNOPSIS
31
32  Just a collection of functions that do not need to be in memory if you
33choose one of the other methods of data storage.
34
35=head1 FORMAT
36
37The result of parsing:
38
39  <foo><head id="a">Hello <em>there</em></head><bar>Howdy<ref/></bar>do</foo>
40
41would be:
42         Tag   Content
43  ==================================================================
44  [foo, [{},
45         head, [{id => "a"},
46                0, "Hello ",
47                em, [{},
48                     0, "there"
49                    ]
50               ],
51         bar, [{},
52               0, "Howdy",
53               ref, [{}]
54              ],
55         0, "do"
56        ]
57  ]
58
59The above was copied from the XML::Parser man page.  Many thanks to
60Larry and Clark.
61
62=head1 AUTHOR
63
64By Ryan Eatmon in March 2001 for http://jabber.org/
65
66=head1 COPYRIGHT
67
68This module is free software; you can redistribute it and/or modify
69it under the same terms as Perl itself.
70
71=cut
72
73use vars qw( $VERSION $LOADED );
74
75$VERSION = "1.22";
76$LOADED = 1;
77
78##############################################################################
79#
80# _handle_element - handles the main tag elements sent from the server.
81#                   On an open tag it creates a new XML::Parser::Tree so
82#                   that _handle_cdata and _handle_element can add data
83#                   and tags to it later.
84#
85##############################################################################
86sub _handle_element
87{
88    my $self;
89    $self = $_[0] if (ref($_[0]) eq "XML::Stream::Parser");
90    $self = shift unless (ref($_[0]) eq "XML::Stream::Parser");
91    my ($sax, $tag, %att) = @_;
92    my $sid = $sax->getSID();
93
94    $self->debug(2,"_handle_element: sid($sid) sax($sax) tag($tag) att(",%att,")");
95
96    my @NEW;
97    if($#{$self->{SIDS}->{$sid}->{tree}} < 0)
98    {
99        push @{$self->{SIDS}->{$sid}->{tree}}, $tag;
100    }
101    else
102    {
103        push @{ $self->{SIDS}->{$sid}->{tree}[ $#{$self->{SIDS}->{$sid}->{tree}}]}, $tag;
104    }
105    push @NEW, \%att;
106    push @{$self->{SIDS}->{$sid}->{tree}}, \@NEW;
107}
108
109
110##############################################################################
111#
112# _handle_cdata - handles the CDATA that is encountered.  Also, in the
113#                      spirit of XML::Parser::Tree it combines any sequential
114#                      CDATA into one tag.
115#
116##############################################################################
117sub _handle_cdata
118{
119    my $self;
120    $self = $_[0] if (ref($_[0]) eq "XML::Stream::Parser");
121    $self = shift unless (ref($_[0]) eq "XML::Stream::Parser");
122    my ($sax, $cdata) = @_;
123    my $sid = $sax->getSID();
124
125    $self->debug(2,"_handle_cdata: sid($sid) sax($sax) cdata($cdata)");
126
127    return if ($#{$self->{SIDS}->{$sid}->{tree}} == -1);
128
129    $self->debug(2,"_handle_cdata: sax($sax) cdata($cdata)");
130
131    my $pos = $#{$self->{SIDS}->{$sid}->{tree}};
132    $self->debug(2,"_handle_cdata: pos($pos)");
133
134    if ($pos > 0 && $self->{SIDS}->{$sid}->{tree}[$pos - 1] eq "0")
135    {
136        $self->debug(2,"_handle_cdata: append cdata");
137        $self->{SIDS}->{$sid}->{tree}[$pos - 1] .= $cdata;
138    }
139    else
140    {
141        $self->debug(2,"_handle_cdata: new cdata");
142        push @{$self->{SIDS}->{$sid}->{tree}[$#{$self->{SIDS}->{$sid}->{tree}}]}, 0;
143        push @{$self->{SIDS}->{$sid}->{tree}[$#{$self->{SIDS}->{$sid}->{tree}}]}, $cdata;
144    } 
145}
146
147
148##############################################################################
149#
150# _handle_close - when we see a close tag we need to pop the last element
151#                      from the list and push it onto the end of the previous
152#                      element.  This is how we build our hierarchy.
153#
154##############################################################################
155sub _handle_close
156{
157    my $self;
158    $self = $_[0] if (ref($_[0]) eq "XML::Stream::Parser");
159    $self = shift unless (ref($_[0]) eq "XML::Stream::Parser");
160    my ($sax, $tag) = @_;
161    my $sid = $sax->getSID();
162
163    $self->debug(2,"_handle_close: sid($sid) sax($sax) tag($tag)");
164
165    my $CLOSED = pop @{$self->{SIDS}->{$sid}->{tree}};
166
167    $self->debug(2,"_handle_close: check(",$#{$self->{SIDS}->{$sid}->{tree}},")");
168
169    if ($#{$self->{SIDS}->{$sid}->{tree}} == -1)
170    {
171        if ($self->{SIDS}->{$sid}->{rootTag} ne $tag)
172        {
173            $self->{SIDS}->{$sid}->{streamerror} = "Root tag mis-match: <$self->{SIDS}->{$sid}->{rootTag}> ... </$tag>\n";
174        }
175        return;
176    }
177
178    if($#{$self->{SIDS}->{$sid}->{tree}} < 1)
179    {
180
181        push @{$self->{SIDS}->{$sid}->{tree}}, $CLOSED;
182
183        if (ref($self) ne "XML::Stream::Parser")
184        {
185            my $stream_prefix = $self->StreamPrefix($sid);
186
187            if(defined($self->{SIDS}->{$sid}->{tree}->[0]) &&
188               ($self->{SIDS}->{$sid}->{tree}->[0] =~ /^${stream_prefix}\:/))
189            { 
190                my @tree = @{$self->{SIDS}->{$sid}->{tree}};
191                $self->{SIDS}->{$sid}->{tree} = [];
192                $self->ProcessStreamPacket($sid,\@tree);
193            }
194            else
195            {
196                my @tree = @{$self->{SIDS}->{$sid}->{tree}};
197                $self->{SIDS}->{$sid}->{tree} = [];
198               
199                my @special =
200                    &XML::Stream::XPath(
201                        \@tree,
202                        '[@xmlns="'.&XML::Stream::ConstXMLNS("xmpp-sasl").'" or @xmlns="'.&XML::Stream::ConstXMLNS("xmpp-tls").'"]'
203                    );
204                if ($#special > -1)
205                {
206                    my $xmlns = &GetXMLData("value",\@tree,"","xmlns");
207
208                    $self->ProcessSASLPacket($sid,\@tree)
209                        if ($xmlns eq &XML::Stream::ConstXMLNS("xmpp-sasl"));
210                    $self->ProcessTLSPacket($sid,\@tree)
211                        if ($xmlns eq &XML::Stream::ConstXMLNS("xmpp-tls"));
212                }
213                else
214                {
215                    &{$self->{CB}->{node}}($sid,\@tree);
216                }
217            }
218        }
219    }
220    else
221    {
222        push @{$self->{SIDS}->{$sid}->{tree}[$#{$self->{SIDS}->{$sid}->{tree}}]}, $CLOSED;
223    }
224}
225
226
227##############################################################################
228#
229# SetXMLData - takes a host of arguments and sets a portion of the specified
230#              XML::Parser::Tree object with that data.  The function works
231#              in two modes "single" or "multiple".  "single" denotes that
232#              the function should locate the current tag that matches this
233#              data and overwrite it's contents with data passed in.
234#              "multiple" denotes that a new tag should be created even if
235#              others exist.
236#
237#              type    - single or multiple
238#              XMLTree - pointer to XML::Stream Tree object
239#              tag     - name of tag to create/modify (if blank assumes
240#                        working with top level tag)
241#              data    - CDATA to set for tag
242#              attribs - attributes to ADD to tag
243#
244##############################################################################
245sub SetXMLData
246{
247    my ($type,$XMLTree,$tag,$data,$attribs) = @_;
248    my ($key);
249
250    if ($tag ne "")
251    {
252        if ($type eq "single")
253        {
254            my ($child);
255            foreach $child (1..$#{$$XMLTree[1]})
256            {
257                if ($$XMLTree[1]->[$child] eq $tag)
258                {
259                    if ($data ne "")
260                    {
261                        #todo: add code to handle writing the cdata again and appending it.
262                        $$XMLTree[1]->[$child+1]->[1] = 0;
263                        $$XMLTree[1]->[$child+1]->[2] = $data;
264                    }
265                    foreach $key (keys(%{$attribs}))
266                    {
267                        $$XMLTree[1]->[$child+1]->[0]->{$key} = $$attribs{$key};
268                    }
269                    return;
270                }
271            }
272        }
273        $$XMLTree[1]->[($#{$$XMLTree[1]}+1)] = $tag;
274        $$XMLTree[1]->[($#{$$XMLTree[1]}+1)]->[0] = {};
275        foreach $key (keys(%{$attribs}))
276        {
277            $$XMLTree[1]->[$#{$$XMLTree[1]}]->[0]->{$key} = $$attribs{$key};
278        }
279        if ($data ne "")
280        {
281            $$XMLTree[1]->[$#{$$XMLTree[1]}]->[1] = 0;
282            $$XMLTree[1]->[$#{$$XMLTree[1]}]->[2] = $data;
283        }
284    }
285    else
286    {
287        foreach $key (keys(%{$attribs}))
288        {
289            $$XMLTree[1]->[0]->{$key} = $$attribs{$key};
290        }
291        if ($data ne "")
292        {
293            if (($#{$$XMLTree[1]} > 0) &&
294                ($$XMLTree[1]->[($#{$$XMLTree[1]}-1)] eq "0"))
295            {
296                $$XMLTree[1]->[$#{$$XMLTree[1]}] .= $data;
297            }
298            else
299            {
300                $$XMLTree[1]->[($#{$$XMLTree[1]}+1)] = 0;
301                $$XMLTree[1]->[($#{$$XMLTree[1]}+1)] = $data;
302            }
303        }
304    }
305}
306
307
308##############################################################################
309#
310# GetXMLData - takes a host of arguments and returns various data structures
311#              that match them.
312#
313#              type - "existence" - returns 1 or 0 if the tag exists in the
314#                                   top level.
315#                     "value" - returns either the CDATA of the tag, or the
316#                               value of the attribute depending on which is
317#                               sought.  This ignores any mark ups to the data
318#                               and just returns the raw CDATA.
319#                     "value array" - returns an array of strings representing
320#                                     all of the CDATA in the specified tag.
321#                                     This ignores any mark ups to the data
322#                                     and just returns the raw CDATA.
323#                     "tree" - returns an XML::Parser::Tree object with the
324#                              specified tag as the root tag.
325#                     "tree array" - returns an array of XML::Parser::Tree
326#                                    objects each with the specified tag as
327#                                    the root tag.
328#                     "child array" - returns a list of all children nodes
329#                                     not including CDATA nodes.
330#                     "attribs" - returns a hash with the attributes, and
331#                                 their values, for the things that match
332#                                 the parameters
333#                     "count" - returns the number of things that match
334#                               the arguments
335#                     "tag" - returns the root tag of this tree
336#              XMLTree - pointer to XML::Parser::Tree object
337#              tag     - tag to pull data from.  If blank then the top level
338#                        tag is accessed.
339#              attrib  - attribute value to retrieve.  Ignored for types
340#                        "value array", "tree", "tree array".  If paired
341#                        with value can be used to filter tags based on
342#                        attributes and values.
343#              value   - only valid if an attribute is supplied.  Used to
344#                        filter for tags that only contain this attribute.
345#                        Useful to search through multiple tags that all
346#                        reference different name spaces.
347#
348##############################################################################
349sub GetXMLData
350{
351    my ($type,$XMLTree,$tag,$attrib,$value) = @_;
352
353    $tag = "" if !defined($tag);
354    $attrib = "" if !defined($attrib);
355    $value = "" if !defined($value);
356
357    my $skipthis = 0;
358
359    #---------------------------------------------------------------------------
360    # Check if a child tag in the root tag is being requested.
361    #---------------------------------------------------------------------------
362    if ($tag ne "")
363    {
364        my $count = 0;
365        my @array;
366        foreach my $child (1..$#{$$XMLTree[1]})
367        {
368            next if (($child/2) !~ /\./);
369            if (($$XMLTree[1]->[$child] eq $tag) || ($tag eq "*"))
370            {
371                next if (ref($$XMLTree[1]->[$child]) eq "ARRAY");
372
373                #---------------------------------------------------------------------
374                # Filter out tags that do not contain the attribute and value.
375                #---------------------------------------------------------------------
376                next if (($value ne "") && ($attrib ne "") && exists($$XMLTree[1]->[$child+1]->[0]->{$attrib}) && ($$XMLTree[1]->[$child+1]->[0]->{$attrib} ne $value));
377                next if (($attrib ne "") && ((ref($$XMLTree[1]->[$child+1]) ne "ARRAY") || !exists($$XMLTree[1]->[$child+1]->[0]->{$attrib})));
378
379                #---------------------------------------------------------------------
380                # Check for existence
381                #---------------------------------------------------------------------
382                if ($type eq "existence")
383                {
384                    return 1;
385                }
386               
387                #---------------------------------------------------------------------
388                # Return the raw CDATA value without mark ups, or the value of the
389                # requested attribute.
390                #---------------------------------------------------------------------
391                if ($type eq "value")
392                {
393                    if ($attrib eq "")
394                    {
395                        my $str = "";
396                        my $next = 0;
397                        my $index;
398                        foreach $index (1..$#{$$XMLTree[1]->[$child+1]}) {
399                            if ($next == 1) { $next = 0; next; }
400                            if ($$XMLTree[1]->[$child+1]->[$index] eq "0") {
401                                $str .= $$XMLTree[1]->[$child+1]->[$index+1];
402                                $next = 1;
403                            }
404                        }
405                        return $str;
406                    }
407                    return $$XMLTree[1]->[$child+1]->[0]->{$attrib}
408                        if (exists $$XMLTree[1]->[$child+1]->[0]->{$attrib});
409                }
410                #---------------------------------------------------------------------
411                # Return an array of values that represent the raw CDATA without
412                # mark up tags for the requested tags.
413                #---------------------------------------------------------------------
414                if ($type eq "value array")
415                {
416                    if ($attrib eq "")
417                    {
418                        my $str = "";
419                        my $next = 0;
420                        my $index;
421                        foreach $index (1..$#{$$XMLTree[1]->[$child+1]})
422                        {
423                            if ($next == 1) { $next = 0;  next; }
424                            if ($$XMLTree[1]->[$child+1]->[$index] eq "0")
425                            {
426                                $str .= $$XMLTree[1]->[$child+1]->[$index+1];
427                                $next = 1;
428                            }
429                        }
430                        push(@array,$str);
431                    }
432                    else
433                    {
434                        push(@array,$$XMLTree[1]->[$child+1]->[0]->{$attrib})
435                            if (exists $$XMLTree[1]->[$child+1]->[0]->{$attrib});
436                    }
437                }
438                #---------------------------------------------------------------------
439                # Return a pointer to a new XML::Parser::Tree object that has the
440                # requested tag as the root tag.
441                #---------------------------------------------------------------------
442                if ($type eq "tree")
443                {
444                    my @tree = ( $$XMLTree[1]->[$child] , $$XMLTree[1]->[$child+1] );
445                    return @tree;
446                }
447                #---------------------------------------------------------------------
448                # Return an array of pointers to XML::Parser::Tree objects that have
449                # the requested tag as the root tags.
450                #---------------------------------------------------------------------
451                if ($type eq "tree array")
452                {
453                    my @tree = ( $$XMLTree[1]->[$child] , $$XMLTree[1]->[$child+1] );
454                    push(@array,\@tree);
455                }
456                #---------------------------------------------------------------------
457                # Return a count of the number of tags that match
458                #---------------------------------------------------------------------
459                if ($type eq "count")
460                {
461                    if ($$XMLTree[1]->[$child] eq "0")
462                    {
463                        $skipthis = 1;
464                        next;
465                    }
466                    if ($skipthis == 1)
467                    {
468                        $skipthis = 0;
469                        next;
470                    }
471                    $count++;
472                }
473                #---------------------------------------------------------------------
474                # Return a count of the number of tags that match
475                #---------------------------------------------------------------------
476                if ($type eq "child array")
477                {
478                    my @tree = ( $$XMLTree[1]->[$child] , $$XMLTree[1]->[$child+1] );
479                    push(@array,\@tree) if ($tree[0] ne "0");
480                }
481                #---------------------------------------------------------------------
482                # Return the attribute hash that matches this tag
483                #---------------------------------------------------------------------
484                if ($type eq "attribs")
485                {
486                    return (%{$$XMLTree[1]->[$child+1]->[0]});
487                }
488            }
489        }
490        #-------------------------------------------------------------------------
491        # If we are returning arrays then return array.
492        #-------------------------------------------------------------------------
493        if (($type eq "tree array") || ($type eq "value array") ||
494            ($type eq "child array"))
495        {
496            return @array;
497        }
498
499        #-------------------------------------------------------------------------
500        # If we are returning then count, then do so
501        #-------------------------------------------------------------------------
502        if ($type eq "count")
503        {
504            return $count;
505        }
506    }
507    else
508    {
509        #-------------------------------------------------------------------------
510        # This is the root tag, so handle things a level up.
511        #-------------------------------------------------------------------------
512
513        #-------------------------------------------------------------------------
514        # Return the raw CDATA value without mark ups, or the value of the
515        # requested attribute.
516        #-------------------------------------------------------------------------
517        if ($type eq "value")
518        {
519            if ($attrib eq "")
520            {
521                my $str = "";
522                my $next = 0;
523                my $index;
524                foreach $index (1..$#{$$XMLTree[1]})
525                {
526                    if ($next == 1) { $next = 0; next; }
527                    if ($$XMLTree[1]->[$index] eq "0")
528                    {
529                        $str .= $$XMLTree[1]->[$index+1];
530                        $next = 1;
531                    }
532                }
533                return $str;
534            }
535            return $$XMLTree[1]->[0]->{$attrib}
536                if (exists $$XMLTree[1]->[0]->{$attrib});
537        }
538        #-------------------------------------------------------------------------
539        # Return a pointer to a new XML::Parser::Tree object that has the
540        # requested tag as the root tag.
541        #-------------------------------------------------------------------------
542        if ($type eq "tree")
543        {
544            my @tree =  @{$$XMLTree};
545            return @tree;
546        }
547
548        #-------------------------------------------------------------------------
549        # Return the 1 if the specified attribute exists in the root tag.
550        #-------------------------------------------------------------------------
551        if ($type eq "existence")
552        {
553            return 1 if (($attrib ne "") && (exists($$XMLTree[1]->[0]->{$attrib})));
554        }
555
556        #-------------------------------------------------------------------------
557        # Return the attribute hash that matches this tag
558        #-------------------------------------------------------------------------
559        if ($type eq "attribs")
560        {
561            return %{$$XMLTree[1]->[0]};
562        }
563        #-------------------------------------------------------------------------
564        # Return the tag of this node
565        #-------------------------------------------------------------------------
566        if ($type eq "tag")
567        {
568            return $$XMLTree[0];
569        }
570    }
571    #---------------------------------------------------------------------------
572    # Return 0 if this was a request for existence, or "" if a request for
573    # a "value", or [] for "tree", "value array", and "tree array".
574    #---------------------------------------------------------------------------
575    return 0 if ($type eq "existence");
576    return "" if ($type eq "value");
577    return [];
578}
579
580
581##############################################################################
582#
583# BuildXML - takes an XML::Parser::Tree object and builds the XML string
584#                 that it represents.
585#
586##############################################################################
587sub BuildXML
588{
589    my ($parseTree,$rawXML) = @_;
590
591    return "" if $#{$parseTree} == -1;
592
593    my $str = "";
594    if (ref($parseTree->[0]) eq "") 
595    {
596        if ($parseTree->[0] eq "0")
597        {
598            return &XML::Stream::EscapeXML($parseTree->[1]);
599        }
600
601        $str = "<".$parseTree->[0];
602        foreach my $att (sort {$a cmp $b} keys(%{$parseTree->[1]->[0]}))
603        {
604            $str .= " ".$att."='".&XML::Stream::EscapeXML($parseTree->[1]->[0]->{$att})."'";
605        }
606
607        if (($#{$parseTree->[1]} > 0) || (defined($rawXML) && ($rawXML ne "")))
608        {
609            $str .= ">";
610           
611            my $index = 1;
612            while($index <= $#{$parseTree->[1]})
613            {
614                my @newTree = ( $parseTree->[1]->[$index], $parseTree->[1]->[$index+1] );
615                $str .= &XML::Stream::Tree::BuildXML(\@newTree);
616                $index += 2;
617            }
618           
619            $str .= $rawXML if defined($rawXML);
620            $str .= "</".$parseTree->[0].">";
621        }
622        else
623        {
624            $str .= "/>";
625        }
626
627    }
628
629    return $str;
630}
631
632
633##############################################################################
634#
635# XML2Config - takes an XML data tree and turns it into a hash of hashes.
636#              This only works for certain kinds of XML trees like this:
637#
638#                <foo>
639#                  <bar>1</bar>
640#                  <x>
641#                    <y>foo</y>
642#                  </x>
643#                  <z>5</z>
644#                </foo>
645#
646#              The resulting hash would be:
647#
648#                $hash{bar} = 1;
649#                $hash{x}->{y} = "foo";
650#                $hash{z} = 5;
651#
652#              Good for config files.
653#
654##############################################################################
655sub XML2Config
656{
657    my ($XMLTree) = @_;
658
659    my %hash;
660    foreach my $tree (&XML::Stream::GetXMLData("tree array",$XMLTree,"*"))
661    {
662        if ($tree->[0] eq "0")
663        {
664            return $tree->[1] unless ($tree->[1] =~ /^\s*$/);
665        }
666        else
667        {
668            if (&XML::Stream::GetXMLData("count",$XMLTree,$tree->[0]) > 1)
669            {
670                push(@{$hash{$tree->[0]}},&XML::Stream::XML2Config($tree));
671            }
672            else
673            {
674                $hash{$tree->[0]} = &XML::Stream::XML2Config($tree);
675            }
676        }
677    }
678    return \%hash;
679}
680
681
6821;
Note: See TracBrowser for help on using the repository browser.