source: perl/lib/Net/XMPP/Stanza.pm @ b1f2fb0

barnowl_perlaimdebianrelease-1.10release-1.4release-1.5release-1.6release-1.7release-1.8release-1.9
Last change on this file since b1f2fb0 was 0ff8d110, checked in by Alejandro R. Sedeño <asedeno@mit.edu>, 19 years ago
Adding XML::Stream, Net::XMPP, and Net::Jabber to perl/lib/
  • Property mode set to 100644
File size: 44.2 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#  Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/
19#
20##############################################################################
21
22package Net::XMPP::Stanza;
23
24=head1 NAME
25
26Net::XMPP::Stanza - XMPP Stanza Module
27
28=head1 SYNOPSIS
29
30  Net::XMPP::Stanza is a private package that serves as a basis for all
31  XMPP stanzas generated by Net::XMPP.
32
33=head1 DESCRIPTION
34
35  This module is not meant to be used directly.  You should be using
36  either Net::XMPP::IQ, Net::XMPP::Message, Net::XMPP::Presence, or
37  another package that inherits from Net::XMPP::Stanza.
38
39  That said, this is where all of the namespaced methods are documented.
40
41  The current supported namespaces are:
42
43=cut
44
45# NS_BEGIN
46
47=pod
48
49    jabber:iq:auth
50    jabber:iq:privacy
51    jabber:iq:register
52    jabber:iq:roster
53    urn:ietf:params:xml:ns:xmpp-bind
54    urn:ietf:params:xml:ns:xmpp-session
55
56=cut
57
58# NS_END
59
60=pod
61   
62  For more information on what these namespaces are for, visit
63  http://www.jabber.org and browse the Jabber Programmers Guide.
64
65  The following tables can be read as follows:
66
67  ny:private:ns
68 
69  Name                        Type     Get  Set  Remove  Defined  Add
70  ==========================  =======  ===  ===  ======  =======  ===
71  Foo                         scalar    X    X     X        X
72  Bar                         child                                X
73  Bars                        child     X
74  Test                        master    X    X
75
76  Withing the my:private:ns namespace, there exists the functions:
77
78    GetFoo(), SetFoo(), RemoveFoo(), DefinedFoo()
79   
80    AddBar()
81   
82    GetBars(), DefinedBars()
83   
84    GetTest(), SetMaster()
85
86  Hopefully it should be obvious how this all works.  If not feel free to
87  contact me and I'll work on adding more documentation.
88
89=cut
90
91# DOC_BEGIN
92=head1 jabber:iq:auth
93
94  Name                        Type       Get  Set  Remove  Defined  Add
95  ==========================  =========  ===  ===  ======  =======  ===
96  Digest                      scalar      X    X     X        X       
97  Hash                        scalar      X    X     X        X       
98  Password                    scalar      X    X     X        X       
99  Resource                    scalar      X    X     X        X       
100  Sequence                    scalar      X    X     X        X       
101  Token                       scalar      X    X     X        X       
102  Username                    scalar      X    X     X        X       
103  Auth                        master      X    X                       
104
105=head1 jabber:iq:privacy
106
107  Name                        Type       Get  Set  Remove  Defined  Add
108  ==========================  =========  ===  ===  ======  =======  ===
109  Active                      scalar      X    X     X        X       
110  Default                     scalar      X    X     X        X       
111  List                        child                                  X
112  Lists                       child       X          X        X       
113  Privacy                     master      X    X                       
114
115=head1 jabber:iq:privacy - item objects
116
117  Name                        Type       Get  Set  Remove  Defined  Add
118  ==========================  =========  ===  ===  ======  =======  ===
119  Action                      scalar      X    X     X        X       
120  IQ                          flag        X    X     X        X       
121  Message                     flag        X    X     X        X       
122  Order                       scalar      X    X     X        X       
123  PresenceIn                  flag        X    X     X        X       
124  PresenceOut                 flag        X    X     X        X       
125  Type                        scalar      X    X     X        X       
126  Value                       scalar      X    X     X        X       
127  Item                        master      X    X                       
128
129=head1 jabber:iq:privacy - list objects
130
131  Name                        Type       Get  Set  Remove  Defined  Add
132  ==========================  =========  ===  ===  ======  =======  ===
133  Name                        scalar      X    X     X        X       
134  Item                        child                                  X
135  Items                       child       X          X        X       
136  List                        master      X    X                       
137
138=head1 jabber:iq:register
139
140  Name                        Type       Get  Set  Remove  Defined  Add
141  ==========================  =========  ===  ===  ======  =======  ===
142  Address                     scalar      X    X     X        X       
143  City                        scalar      X    X     X        X       
144  Date                        scalar      X    X     X        X       
145  Email                       scalar      X    X     X        X       
146  First                       scalar      X    X     X        X       
147  Instructions                scalar      X    X     X        X       
148  Key                         scalar      X    X     X        X       
149  Last                        scalar      X    X     X        X       
150  Misc                        scalar      X    X     X        X       
151  Name                        scalar      X    X     X        X       
152  Nick                        scalar      X    X     X        X       
153  Password                    scalar      X    X     X        X       
154  Phone                       scalar      X    X     X        X       
155  Registered                  flag        X    X     X        X       
156  Remove                      flag        X    X     X        X       
157  State                       scalar      X    X     X        X       
158  Text                        scalar      X    X     X        X       
159  URL                         scalar      X    X     X        X       
160  Username                    scalar      X    X     X        X       
161  Zip                         scalar      X    X     X        X       
162  Register                    master      X    X                       
163
164=head1 jabber:iq:roster
165
166  Name                        Type       Get  Set  Remove  Defined  Add
167  ==========================  =========  ===  ===  ======  =======  ===
168  Item                        child                                  X
169  Items                       child       X                           
170  Roster                      master      X    X                       
171
172=head1 jabber:iq:roster - item objects
173
174  Name                        Type       Get  Set  Remove  Defined  Add
175  ==========================  =========  ===  ===  ======  =======  ===
176  Ask                         scalar      X    X     X        X       
177  Group                       array       X    X     X        X       
178  JID                         jid         X    X     X        X       
179  Name                        scalar      X    X     X        X       
180  Subscription                scalar      X    X     X        X       
181  Item                        master      X    X                       
182
183=head1 urn:ietf:params:xml:ns:xmpp-bind
184
185  Name                        Type       Get  Set  Remove  Defined  Add
186  ==========================  =========  ===  ===  ======  =======  ===
187  JID                         jid         X    X     X        X       
188  Resource                    scalar      X    X     X        X       
189  Bind                        master      X    X                       
190
191=head1 urn:ietf:params:xml:ns:xmpp-session
192
193  Name                        Type       Get  Set  Remove  Defined  Add
194  ==========================  =========  ===  ===  ======  =======  ===
195  Session                     master      X    X                       
196
197
198=cut
199
200# DOC_END
201
202=head1 AUTHOR
203
204Ryan Eatmon
205
206=head1 COPYRIGHT
207
208This module is free software; you can redistribute it and/or modify
209it under the same terms as Perl itself.
210
211=cut
212
213use strict;
214use Carp;
215use Net::XMPP::Namespaces;
216use vars qw( $AUTOLOAD %FUNCTIONS $DEBUG );
217
218$DEBUG = new Net::XMPP::Debug(usedefault=>1,
219                              header=>"XMPP");
220
221# XXX need to look at evals and $@
222
223sub new
224{
225    my $proto = shift;
226    my $class = ref($proto) || $proto;
227    my $self = { };
228
229    bless($self, $proto);
230
231    $self->{DEBUGHEADER} = "Stanza";
232    $self->{TAG} = "__netxmpp__:unknown:tag";
233
234    $self->{FUNCS} = \%FUNCTIONS;
235   
236    my $result = $self->_init(@_);
237
238    return $result if defined($result);
239   
240    return $self;
241}
242
243
244sub _init
245{
246    my $self = shift;
247
248    $self->{CHILDREN} = [];
249
250    if ("@_" ne (""))
251    {
252        if ($_[0]->isa("Net::XMPP::Stanza"))
253        {
254            return $_[0];
255        }
256        elsif (ref($_[0]) eq "")
257        {
258            $self->{TAG} = shift;
259            $self->{TREE} = new XML::Stream::Node($self->{TAG});
260        }
261        else
262        {
263            $self->{TREE} = shift;
264            $self->{TAG} = $self->{TREE}->get_tag();
265            $self->_parse_xmlns();
266            $self->_parse_tree();
267        }
268    }
269    else
270    {
271        $self->{TREE} = new XML::Stream::Node($self->{TAG});
272    }
273
274    return;
275}
276
277
278$FUNCTIONS{XMLNS}->{path} = '@xmlns';
279
280$FUNCTIONS{Child}->{type} = 'child';
281$FUNCTIONS{Child}->{path} = '*[@xmlns]';
282$FUNCTIONS{Child}->{child} = {};
283
284##############################################################################
285#
286# debug - prints out the XML::Parser Tree in a readable format for debugging
287#
288##############################################################################
289sub debug
290{
291    my $self = shift;
292
293    print "debug ",$self,":\n";
294    &Net::XMPP::printData("debug: \$self->{CHILDREN}->",$self->{CHILDREN});
295}
296
297
298##############################################################################
299#+----------------------------------------------------------------------------
300#|
301#| Public Methods
302#|
303#+----------------------------------------------------------------------------
304##############################################################################
305
306##############################################################################
307#
308# GetXML - Returns a string that represents the packet.
309#
310##############################################################################
311sub GetXML 
312{
313    my $self = shift;
314    return $self->GetTree()->GetXML();
315}
316
317
318##############################################################################
319#
320# GetTag - Returns the root tag of the object.
321#
322##############################################################################
323sub GetTag
324{
325    my $self = shift;
326   
327    return $self->{TAG};
328}
329
330
331##############################################################################
332#
333# GetTree - Returns an XML::Stream::Node that contains the full tree including
334#           Query, and X children.
335#
336##############################################################################
337sub GetTree
338{
339    my $self = shift;
340    my $keepXMLNS = shift;
341    $keepXMLNS = 0 unless defined($keepXMLNS);
342
343    my $node = $self->{TREE}->copy();
344
345    $node->remove_attrib("xmlns")
346        if (exists($self->{SKIPXMLNS}) && ($keepXMLNS == 0));
347   
348    foreach my $child (@{$self->{CHILDREN}})
349    {
350        my $child_tree = $child->GetTree($keepXMLNS);
351        $node->add_child($child_tree);
352    }
353
354    my $remove_ns = 0;
355    if (defined($node->get_attrib("xmlns")) && ($keepXMLNS == 0))
356    {
357        $remove_ns = 1
358            if ($self->_check_skip_xmlns($node->get_attrib("xmlns")));
359    }
360
361    $node->remove_attrib("xmlns") if ($remove_ns == 1);
362
363    $node->add_raw_xml(@{$self->{RAWXML}})
364        if (exists($self->{RAWXML}) && ($#{$self->{RAWXML}} > -1));
365
366    return $node;
367} 
368
369
370##############################################################################
371#
372# NewChild - calls AddChild to create a new Net::XMPP::Stanza object, sets the
373#            xmlns and returns a pointer to the new object.
374#
375##############################################################################
376sub NewChild
377{
378    my $self = shift;
379    my $xmlns = shift;
380    my $tag = shift;
381   
382    return unless exists($Net::XMPP::Namespaces::NS{$xmlns});
383
384    if (!defined($tag))
385    {
386        $tag = "x";
387        $tag = $Net::XMPP::Namespaces::NS{$xmlns}->{tag}
388            if exists($Net::XMPP::Namespaces::NS{$xmlns});
389    }
390   
391    my $node = new XML::Stream::Node($tag);
392    $node->put_attrib(xmlns=>$xmlns);
393
394    return $self->AddChild($node);
395}
396
397
398##############################################################################
399#
400# AddChild - creates a new Net::XMPP::packet object, pushes it on the child
401#            list, and returns a pointer to the new object.  This is a
402#            private helper function.
403#
404##############################################################################
405sub AddChild
406{
407    my $self = shift;
408    my $node = shift;
409    my $packet = $self->_new_packet($node);
410    push(@{$self->{CHILDREN}},$packet);
411    return $packet;
412}
413
414
415##############################################################################
416#
417# RemoveChild - removes all xtags that have the specified namespace.
418#
419##############################################################################
420sub RemoveChild
421{
422    my $self = shift;
423    my $xmlns = shift;
424
425    foreach my $index (reverse(0..$#{$self->{CHILDREN}}))
426    {
427        splice(@{$self->{CHILDREN}},$index,1)
428            if (!defined($xmlns) ||
429                ($xmlns eq "") ||
430                ($self->{CHILDREN}->[$index]->GetXMLNS() eq $xmlns));
431    }
432}
433
434
435##############################################################################
436#
437# NewFirstChild - calls AddFirstChild to create a new Net::XMPP::Stanza
438#                 object, sets the xmlns and returns a pointer to the new
439#                 object.
440#
441##############################################################################
442sub NewFirstChild
443{
444    my $self = shift;
445    my $xmlns = shift;
446    my $tag = shift;
447   
448    return unless exists($Net::XMPP::Namespaces::NS{$xmlns});
449
450    if (!defined($tag))
451    {
452        $tag = "x";
453        $tag = $Net::XMPP::Namespaces::NS{$xmlns}->{tag}
454            if exists($Net::XMPP::Namespaces::NS{$xmlns});
455    }
456   
457    my $node = new XML::Stream::Node($tag);
458    $node->put_attrib(xmlns=>$xmlns);
459
460    return $self->AddFirstChild($node);
461}
462
463
464##############################################################################
465#
466# AddFirstChild - creates a new Net::XMPP::packet object, puts it on the child
467#                 list in the front, and returns a pointer to the new object.
468#                 This is a private helper function.
469#
470##############################################################################
471sub AddFirstChild
472{
473    my $self = shift;
474    my $node = shift;
475    my $packet = $self->_new_packet($node);
476    unshift(@{$self->{CHILDREN}},$packet);
477    return $packet;
478}
479
480
481##############################################################################
482#
483# RemoveFirstChild - removes all xtags that have the specified namespace.
484#
485##############################################################################
486sub RemoveFirstChild
487{
488    my $self = shift;
489
490    shift(@{$self->{CHILDREN}});
491}
492
493
494##############################################################################
495#
496# InsertRawXML - puts the specified string onto the list for raw XML to be
497#                included in the packet.
498#
499##############################################################################
500sub InsertRawXML
501{
502    my $self = shift;
503    my(@rawxml) = @_;
504    if (!exists($self->{RAWXML}))
505    {
506        $self->{RAWXML} = [];
507    }
508    push(@{$self->{RAWXML}},@rawxml);
509}
510
511
512##############################################################################
513#
514# ClearRawXML - removes all raw XML from the packet.
515#
516##############################################################################
517sub ClearRawXML
518{
519    my $self = shift;
520    $self->{RAWXML} = [];
521}
522
523
524
525
526##############################################################################
527#+----------------------------------------------------------------------------
528#|
529#| AutoLoad methods
530#|
531#+----------------------------------------------------------------------------
532##############################################################################
533
534##############################################################################
535#
536# AutoLoad - This function is a central location for handling all of the
537#            AUTOLOADS for all of the sub modules.
538#
539##############################################################################
540sub AUTOLOAD
541{
542    my $self = shift;
543    return if ($AUTOLOAD =~ /::DESTROY$/);
544    my ($package) = ($AUTOLOAD =~ /^(.*)::/);
545    $AUTOLOAD =~ s/^.*:://;
546    my ($call,$var) = ($AUTOLOAD =~ /^(Add|Get|Set|Remove|Defined)(.*)$/);
547    $call = "" unless defined($call);
548    $var = "" unless defined($var);
549
550    #$self->_debug("AUTOLOAD: self($self) AUTOLOAD($AUTOLOAD) package($package)");
551    #$self->_debug("AUTOLOAD: tag($self->{TAG}) call($call) var($var) args(",join(",",@_),")");
552
553    #-------------------------------------------------------------------------
554    # Pick off calls for top level tags <message/>, <presence/>, and <iq/>
555    #-------------------------------------------------------------------------
556    my @xmlns = $self->{TREE}->XPath('@xmlns');
557    my $XPathArgs = $self->_xpath_AUTOLOAD($package,$call,$var,$xmlns[0]);
558    return $self->_xpath($call,@{$XPathArgs},@_) if defined($XPathArgs);
559
560    #-------------------------------------------------------------------------
561    # We don't know what this function is... Hand it off to Missing Persons...
562    #-------------------------------------------------------------------------
563    $self->_missing_function($AUTOLOAD);
564}
565
566
567##############################################################################
568#
569# _xpath_AUTOLOAD - This function is a helper function for the main AutoLoad
570#                   function to help cut down on repeating code.
571#
572##############################################################################
573sub _xpath_AUTOLOAD
574{
575    my $self = shift;
576    my $package = shift;
577    my $call = shift;
578    my $var = shift;
579    my $xmlns = shift;
580
581    #$self->_debug("_xpath_AUTOLOAD: self($self) package($package) call($call) var($var)");
582    #$self->_debug("_xpath_AUTOLOAD: xmlns($xmlns)") if defined($xmlns);
583
584    #-------------------------------------------------------------------------
585    # First thing, figure out which group of functions we are going to be
586    # working with.  FUNCTIONS, or NS{$xmlns}->{xpath}...
587    #-------------------------------------------------------------------------
588    my $funcs = $self->_xpath_funcs($package,$call,$var,$xmlns);
589    return unless defined($funcs);
590
591    my @setFuncs = grep { $_ ne $var } keys(%{$funcs});
592
593    #$self->_debug("_xpath_AUTOLOAD: setFuncs(",join(",",@setFuncs),")");
594               
595   
596    my $type = (exists($funcs->{$var}->{type}) ?
597                $funcs->{$var}->{type} :
598                "scalar"
599               );
600
601    my $path = (exists($funcs->{$var}->{path}) ?
602                $funcs->{$var}->{path} :
603                ""
604               );
605
606    $path = "*" if ($type eq "raw");
607
608    my $child = "";
609   
610    #-------------------------------------------------------------------------
611    # When this is a master function... change the above variables...
612    #-------------------------------------------------------------------------
613    if(($type eq "master") ||
614       ((ref($type) eq "ARRAY") && ($type->[0] eq "master")))
615    {
616        if ($call eq "Get")
617        {
618            my @newSetFuncs;
619            foreach my $func (@setFuncs)
620            {
621                my $funcType = ( exists($funcs->{$func}->{type}) ?
622                                 $funcs->{$func}->{type} :
623                                 undef
624                               );
625
626                push(@newSetFuncs,$func)
627                    if (!defined($funcType) || ($funcType eq "scalar") ||
628                        ($funcType eq "jid") || ($funcType eq "array") ||
629                        ($funcType eq "flag") || ($funcType eq "timestamp") ||
630                        (ref($funcType) eq "ARRAY"));
631            }
632               
633            $child = \@newSetFuncs;
634        }
635        else
636        {
637            $child = \@setFuncs;
638        }
639    }
640    #-------------------------------------------------------------------------
641    # When this is a child based function... change the above variables...
642    #-------------------------------------------------------------------------
643    elsif (exists($funcs->{$var}->{child}))
644    {
645        $child = $funcs->{$var}->{child};
646               
647        #$self->_debug("_xpath_AUTOLOAD: child($child)");
648               
649        if (exists($child->{ns}))
650        {
651            my $addXMLNS = $child->{ns};
652               
653            my $addFuncs = $Net::XMPP::Namespaces::NS{$addXMLNS}->{xpath};
654            my @calls =
655                grep
656                {
657                    exists($addFuncs->{$_}->{type}) &&
658                    ($addFuncs->{$_}->{type} eq "master")
659                }
660                keys(%{$addFuncs});
661
662            if ($#calls > 0)
663            {
664                print STDERR "Warning: I cannot serve two masters.\n";
665            }
666            $child->{master} = $calls[0];
667        }
668    }
669
670    #-------------------------------------------------------------------------
671    # Return the arguments for the xpath function
672    #-------------------------------------------------------------------------
673    #$self->_debug("_xpath_AUTOLOAD: return($type,$path,$child);");
674    return [$type,$path,$child];
675}
676
677
678##############################################################################
679#
680# _xpath_funcs - Return the list of functions either from the FUNCTIONS hash
681#                or from Net::XMPP::Namespaces::NS.
682#
683##############################################################################
684sub _xpath_funcs
685{
686    my $self = shift;
687    my $package = shift;
688    my $call = shift;
689    my $var = shift;
690    my $xmlns = shift;
691
692    my $funcs;
693   
694    my $coreFuncs = $self->{FUNCS};
695    #eval "\$coreFuncs = \\%".$package."::FUNCTIONS";
696    $coreFuncs = {} unless defined($coreFuncs);
697
698    my $nsFuncs = {};
699    $nsFuncs = $Net::XMPP::Namespaces::NS{$xmlns}->{xpath}
700        if (defined($xmlns) && exists($Net::XMPP::Namespaces::NS{$xmlns}));
701
702    foreach my $set ($coreFuncs,$nsFuncs)
703    {
704        if (exists($set->{$var}))
705        {
706            my $type = (exists($set->{$var}->{type}) ?
707                        $set->{$var}->{type} :
708                        "scalar"
709                       );
710
711            my @calls = ('Get','Set','Defined','Remove');
712            @calls = ('Get','Set') if ($type eq "master");
713            @calls = ('Get','Defined','Remove') if ($type eq "child");
714            @calls = @{$set->{$var}->{calls}}
715                if exists($set->{$var}->{calls});
716
717            foreach my $callName (@calls)
718            {
719                if ($callName eq $call)
720                {
721                    $funcs = $set;
722                    last;
723                }
724            }
725        }
726    }
727
728    #-------------------------------------------------------------------------
729    # If we didn't find any functions to return,  Return failure.
730    #-------------------------------------------------------------------------
731    if (!defined($funcs))
732    {
733        #$self->_debug("_xpath_AUTOLOAD: no funcs found");
734        return;
735    }
736
737    return $funcs;
738}
739
740
741##############################################################################
742#
743# _xpath - given a type it calls the appropriate _xpath_* function below
744#
745##############################################################################
746sub _xpath
747{
748    my $self = shift;
749    my $call = shift;
750
751    #$self->_debug("_xpath: call($call) args(",join(",",@_),")");
752   
753    if ($call eq "Get")        { return $self->_xpath_get(@_)    ; }
754    elsif ($call eq "Set")     { return $self->_xpath_set(@_);     }
755    elsif ($call eq "Defined") { return $self->_xpath_defined(@_); }
756    elsif ($call eq "Add")     { return $self->_xpath_add(@_);     }
757    elsif ($call eq "Remove")  { return $self->_xpath_remove(@_);  }
758}
759
760
761##############################################################################
762#
763# _xpath_get - returns the value stored in the node
764#
765##############################################################################
766sub _xpath_get
767{
768    my $self = shift;
769    my $type = shift;
770    my $xpath = shift;
771    my $childtype = shift;
772    my ($arg0) = shift;
773   
774    #$self->_debug("_xpath_get: self($self) type($type) xpath($xpath) childtype($childtype)");
775    #$self->{TREE}->debug();
776
777    my $subType;
778    ($type,$subType) = $self->_xpath_resolve_types($type);
779   
780
781    #-------------------------------------------------------------------------
782    # type == master
783    #-------------------------------------------------------------------------
784    if ($type eq "master")
785    {
786        my %fields;
787       
788        foreach my $func (sort {$a cmp $b} @{$childtype})
789        {
790            my $defined;
791            eval "\$defined = \$self->Defined$func();";
792            if ($defined)
793            {
794                my @values;
795                eval "\@values = \$self->Get$func();";
796
797                if ($#values > 0)
798                {
799                    $fields{lc($func)} = \@values;
800                }
801                else
802                {
803                    $fields{lc($func)} = $values[0];
804                }
805            }
806        }
807
808        return %fields;
809    }
810   
811    #-------------------------------------------------------------------------
812    # type == node
813    #-------------------------------------------------------------------------
814    # XXX Remove this if there are no problems
815    #if ($type eq "node")
816    #{
817        #$self->_debug("_xpath_get: node: xmlns($arg0)") if defined($arg0);
818
819        #my @results;
820        #foreach my $child (@{$self->{CHILDREN}})
821        #{
822            #$self->_debug("_xpath_get: node: child($child)");
823            #$self->_debug("_xpath_get: node: childXML(",$child->GetXML(),")");
824
825            #push(@results,$child)
826            #     if (!defined($arg0) ||
827            #         ($arg0 eq "") ||
828            #         ($child->GetTree(1)->get_attrib("xmlns") eq $arg0));
829            #}
830
831            #return $results[$childtype->{child_index}] if exists($childtype->{child_index});
832            #return @results if (wantarray);
833            #return $results[0];
834            #}
835
836    #-------------------------------------------------------------------------
837    # The rest actually call the XPath, so call it.
838    #-------------------------------------------------------------------------
839    my @nodes = $self->{TREE}->XPath($xpath);
840
841    #-------------------------------------------------------------------------
842    # type == scalar or timestamp
843    #-------------------------------------------------------------------------
844    if (($type eq "scalar") || ($type eq "timestamp"))
845    {
846        return "" if ($#nodes == -1);
847        return $nodes[0];
848    }
849
850    #-------------------------------------------------------------------------
851    # type == jid
852    #-------------------------------------------------------------------------
853    if ($type eq "jid")
854    {
855        return if ($#nodes == -1);
856        return $self->_new_jid($nodes[0])
857            if (defined($arg0) && ($arg0 eq "jid"));
858        return $nodes[0];
859    }
860
861    #-------------------------------------------------------------------------
862    # type == flag
863    #-------------------------------------------------------------------------
864    if ($type eq "flag")
865    {
866        return $#nodes > -1;
867    }
868   
869    #-------------------------------------------------------------------------
870    # type == array
871    #-------------------------------------------------------------------------
872    if ($type eq "array")
873    {
874        return @nodes if (wantarray);
875        return $nodes[0];
876    }
877   
878    #-------------------------------------------------------------------------
879    # type == raw
880    #-------------------------------------------------------------------------
881    if ($type eq "raw")
882    {
883        my $rawXML = "";
884
885        return join("",@{$self->{RAWXML}}) if ($#{$self->{RAWXML}} > -1);
886       
887        foreach my $node (@nodes)
888        {
889            $rawXML .= $node->GetXML();
890        }
891
892        return $rawXML;
893    }
894
895    #-------------------------------------------------------------------------
896    # type == child
897    #-------------------------------------------------------------------------
898    if (($type eq "child") || ($type eq "children") || ($type eq "node"))
899    {
900        my $xmlns = $arg0;
901        $xmlns = $childtype->{ns} if exists($childtype->{ns});
902
903        #$self->_debug("_xpath_get: children: xmlns($xmlns)");
904
905        my @results;
906        foreach my $child (@{$self->{CHILDREN}})
907        {
908            push(@results, $child)
909                if (!defined($xmlns) ||
910                    ($xmlns eq "") ||
911                    ($child->GetTree(1)->get_attrib("xmlns") eq $xmlns));
912        }
913
914        foreach my $node (@nodes)
915        {
916            $node->put_attrib(xmlns=>$xmlns)
917                unless defined($node->get_attrib("xmlns"));
918            my $result = $self->AddChild($node);
919            $self->{TREE}->remove_child($node);
920            push(@results,$result)
921                if (!defined($xmlns) ||
922                    ($xmlns eq "") ||
923                    ($node->get_attrib("xmlns") eq $xmlns));
924        }
925
926        #$self->_debug("_xpath_get: children: ",join(",",@results));
927        return $results[$childtype->{child_index}] if exists($childtype->{child_index});
928        return @results if (wantarray);
929        return $results[0];
930    }
931}
932
933
934##############################################################################
935#
936# _xpath_set - makes the XML tree such that the value was set.
937#
938##############################################################################
939sub _xpath_set
940{
941    my $self = shift;
942    my $type = shift;
943    my $xpath = shift;
944    my $childtype = shift;
945
946    #$self->_debug("_xpath_set: self($self) type($type) xpath($xpath) childtype($childtype)");
947
948    my $subType;
949    ($type,$subType) = $self->_xpath_resolve_types($type);
950
951    my $node = $self->{TREE};
952
953    #$self->_debug("_xpath_set: node($node)");
954
955    #-------------------------------------------------------------------------
956    # When the type is master, the rest of the args are in hash form
957    #-------------------------------------------------------------------------
958    if ($type eq "master")
959    {
960        #$self->_debug("_xpath_set: master: funcs(",join(",",@{$childtype}),")");
961        my %args;
962        while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); }
963        #$self->_debug("_xpath_set: args(",%args,")");
964        foreach my $func (sort {$a cmp $b} @{$childtype})
965        {
966            #$self->_debug("_xpath_set: func($func)");
967            if (exists($args{lc($func)}))
968            {
969                #$self->_debug("_xpath_set: \$self->Set$func(\$args{lc(\$func)});");
970                eval "\$self->Set$func(\$args{lc(\$func)});";
971            }
972            elsif ($subType eq "all")
973            {
974                #$self->_debug("_xpath_set: \$self->Set$func();");
975                eval "\$self->Set$func();";
976            }
977        }
978        return;
979    }
980
981    #-------------------------------------------------------------------------
982    # When the type is not master, there can be only one argument.
983    #-------------------------------------------------------------------------
984    my $value = shift;
985
986    if ($type eq "raw")
987    {
988        $self->ClearRawXML();
989        $self->InsertRawXML($value);
990        return;
991    }
992
993    #-------------------------------------------------------------------------
994    # Hook to support special cases.  You can register the specials with
995    # the module and they will ba called based on match.
996    #-------------------------------------------------------------------------
997    if (($subType ne "") && exists($self->{CUSTOMSET}->{$subType}))
998    {
999        #$self->_debug("_xpath_set: custom: subType($subType)");
1000        #$self->_debug("_xpath_set: custom: value($value)") if defined($value);
1001        $value = &{$self->{CUSTOMSET}->{$subType}}($self,$value);
1002    }
1003
1004    if ($type eq "timestamp")
1005    {
1006        $value = "" unless defined($value);
1007        if ($value eq "") {
1008            $value = &Net::XMPP::GetTimeStamp("utc","","stamp");
1009        }
1010    }
1011
1012    #$self->_debug("_xpath_set: value($value)") unless !defined($value);
1013
1014    #-------------------------------------------------------------------------
1015    # Now that we have resolved the value, we put it into an array so that we
1016    # can support array refs by referring to the values as an array.
1017    #-------------------------------------------------------------------------
1018    my @values;
1019    push(@values,$value);
1020    if ($type eq "array")
1021    {
1022        if (ref($value) eq "ARRAY")
1023        {
1024            @values = @{$value};
1025        }
1026    }
1027
1028    #$self->_debug("_xpath_set: values(",join(",",@values),")") unless !defined($value);
1029
1030    #-------------------------------------------------------------------------
1031    # And now, for each value...
1032    #-------------------------------------------------------------------------
1033    foreach my $val (@values)
1034    {
1035        #$self->_debug("_xpath_set: val($val)") unless !defined($val);
1036        #$self->_debug("_xpath_set: type($type)");
1037
1038        next unless (defined($val) || ($type eq "flag"));
1039
1040        if ((ref($val) ne "") && ($val->isa("Net::XMPP::JID")))
1041        {
1042            $val = $val->GetJID("full");
1043        }
1044
1045        my $path = $xpath;
1046
1047        #$self->_debug("_xpath_set: val($val)") unless !defined($val);
1048        #$self->_debug("_xpath_set: path($path)");
1049   
1050        my $childPath = "";
1051        while(($path !~ /^\/?\@/) && ($path !~ /^\/?text\(\)/))
1052        {
1053            #$self->_debug("_xpath_set: Multi-level!!!!");
1054            my ($child) = ($path =~ /^\/?([^\/]+)/);
1055            $path =~ s/^\/?[^\/]+//;
1056            #$self->_debug("_xpath_set: path($path)");
1057            #$self->_debug("_xpath_set: childPath($childPath)");
1058           
1059            if (($type eq "scalar") || ($type eq "jid") || ($type eq "timestamp"))
1060            {
1061                my $tmpPath = $child;
1062                $tmpPath = "$childPath/$child" if ($childPath ne "");
1063               
1064                my @nodes = $self->{TREE}->XPath("$tmpPath");
1065                #$self->_debug("_xpath_set: \$#nodes($#nodes)");
1066                if ($#nodes == -1)
1067                {
1068                    if ($childPath eq "")
1069                    {
1070                        $node = $self->{TREE}->add_child($child);
1071                    }
1072                    else
1073                    {
1074                        my $tree = $self->{TREE}->XPath("$childPath");
1075                        $node = $tree->add_child($child);
1076                    }
1077                }
1078                else
1079                {
1080                    $node = $nodes[0];
1081                }
1082            }
1083
1084            if ($type eq "array")
1085            {
1086                $node = $self->{TREE}->add_child($child);
1087            }
1088
1089            if ($type eq "flag")
1090            {
1091                $node = $self->{TREE}->add_child($child);
1092                return;
1093            }
1094           
1095            $childPath .= "/" unless ($childPath eq "");
1096            $childPath .= $child;
1097        }
1098
1099        my ($piece) = ($path =~ /^\/?([^\/]+)/);
1100   
1101        #$self->_debug("_xpath_set: piece($piece)");
1102
1103        if ($piece =~ /^\@(.+)$/)
1104        {
1105            $node->put_attrib($1=>$val);
1106        }
1107        elsif ($piece eq "text()")
1108        {
1109            $node->remove_cdata();
1110            $node->add_cdata($val);
1111        }
1112    }
1113}
1114
1115
1116##############################################################################
1117#
1118# _xpath_defined - returns true if there is data for the requested item, false
1119#                otherwise.
1120#
1121##############################################################################
1122sub _xpath_defined
1123{
1124    my $self = shift;
1125    my $type = shift;
1126    my $xpath = shift;
1127    my $childtype = shift;
1128    my $ns = shift;
1129
1130    #$self->_debug("_xpath_defined: self($self) type($type) xpath($xpath) childtype($childtype)");
1131    #$self->_debug("_xpath_defined: ns($ns)") if defined($ns);
1132    #$self->_debug("_xpath_defined: xml(",$self->{TREE}->GetXML(),")");
1133
1134    my $subType;
1135    ($type,$subType) = $self->_xpath_resolve_types($type);
1136
1137    if ($type eq "raw")
1138    {
1139        if ($#{$self->{RAWXML}} > -1)
1140        {
1141            return 1;
1142        }
1143    }
1144
1145    my @nodes = $self->{TREE}->XPath($xpath);
1146    my $defined = ($#nodes > -1);
1147   
1148    #$self->_debug("_xpath_defined: nodes(",join(",",@nodes),")");
1149    #$self->_debug("_xpath_defined: ",$#nodes);
1150   
1151    if (!$defined && (($type eq "child") || ($type eq "children") || ($type eq "node")))
1152    {
1153        if ((ref($childtype) eq "HASH") && exists($childtype->{ns}))
1154        {
1155            $ns = $childtype->{ns};
1156        }
1157   
1158        foreach my $packet (@{$self->{CHILDREN}})
1159        {
1160            if (!defined($ns) || ($packet->GetXMLNS() eq $ns))
1161            {
1162                $defined = 1;
1163                last;
1164            }
1165        }
1166    }
1167
1168    #$self->_debug("_xpath_defined: defined($defined)");
1169
1170    return $defined;
1171}
1172
1173
1174##############################################################################
1175#
1176# _xpath_add - returns the value stored in the node
1177#
1178##############################################################################
1179sub _xpath_add
1180{
1181    my $self = shift;
1182    my $type = shift;
1183    my $xpath = shift;
1184    my $childtype = shift;
1185
1186    my $xmlns = $childtype->{ns};
1187    my $master = $childtype->{master};
1188
1189    #$self->_debug("_xpath_add: self($self) type($type) xpath($xpath) childtype($childtype)");
1190    #$self->_debug("_xpath_add: xmlns($xmlns) master($master)");
1191
1192    my $tag = $xpath;
1193    if (exists($childtype->{specify_name}))
1194    {
1195        if (($#_ > -1) && (($#_/2) =~ /^\d+$/))
1196        {
1197            $tag = shift;
1198        }
1199        else
1200        {
1201            $tag = $childtype->{tag};
1202        }
1203    }
1204
1205    my $node = new XML::Stream::Node($tag);
1206    $node->put_attrib(xmlns=>$xmlns);
1207
1208    my $obj = $self->AddChild($node);
1209    eval "\$obj->Set${master}(\@_);" if defined($master);
1210
1211    $obj->_skip_xmlns() if exists($childtype->{skip_xmlns});
1212
1213    return $obj;
1214}
1215
1216
1217##############################################################################
1218#
1219# _xpath_remove - remove the specified thing from the data (I know it's vague.)
1220#
1221##############################################################################
1222sub _xpath_remove
1223{
1224    my $self = shift;
1225    my $type = shift;
1226    my $xpath = shift;
1227    my $childtype = shift;
1228
1229    #$self->_debug("_xpath_remove: self($self) type($type) xpath($xpath) childtype($childtype)");
1230
1231    my $subType;
1232    ($type,$subType) = $self->_xpath_resolve_types($type);
1233
1234    my $nodePath = $xpath;
1235    $nodePath =~ s/\/?\@\S+$//;
1236    $nodePath =~ s/\/text\(\)$//;
1237
1238    #$self->_debug("_xpath_remove: xpath($xpath) nodePath($nodePath)");
1239
1240    my @nodes;
1241    @nodes = $self->{TREE}->XPath($nodePath) if ($nodePath ne "");
1242
1243    #$self->_debug("_xpath_remove: nodes($#nodes)");
1244   
1245    if ($xpath =~ /\@(\S+)/)
1246    {
1247        my $attrib = $1;
1248        #$self->_debug("_xpath_remove: attrib($attrib)");
1249       
1250        if ($nodePath eq "")
1251        {
1252            $self->{TREE}->remove_attrib($attrib);
1253        }
1254        else
1255        {
1256            foreach my $node (@nodes)
1257            {
1258                $node->remove_attrib($attrib);
1259            }
1260        }
1261        return;
1262    }
1263   
1264    foreach my $node (@nodes)
1265    {
1266        #$self->_debug("_xpath_remove: node GetXML(".$node->GetXML().")");
1267        $self->{TREE}->remove_child($node);
1268    }
1269
1270    if ($type eq "child")
1271    {
1272        my @keep;
1273        foreach my $child (@{$self->{CHILDREN}})
1274        {
1275            #$self->_debug("_xpath_remove: check(".$child->GetXML().")");
1276            next if ($child->GetXMLNS() eq $childtype->{ns});
1277            #$self->_debug("_xpath_remove: keep(".$child->GetXML().")");
1278            push(@keep,$child);
1279        }
1280        $self->{CHILDREN} = \@keep;
1281    }
1282}
1283
1284
1285##############################################################################
1286#
1287# _xpath_resolve_types - Resolve the type and subType into the correct values.
1288#
1289##############################################################################
1290sub _xpath_resolve_types
1291{
1292    my $self = shift;
1293    my $type = shift;
1294   
1295    my $subType = "";
1296    if (ref($type) eq "ARRAY")
1297    {
1298        if ($type->[0] eq "special")
1299        {
1300            $subType = $type->[1];
1301            $type = "scalar";
1302        }
1303        elsif ($type->[0] eq "master")
1304        {
1305            $subType = $type->[1];
1306            $type = "master";
1307        }
1308    }
1309   
1310    #$self->_debug("_xpath_resolve_types: type($type) subtype($subType)");
1311
1312    return ($type,$subType);
1313}
1314
1315
1316##############################################################################
1317#
1318# _parse_xmlns - anything that uses the namespace method must first kow what
1319#                the xmlns of this thing is... So here's a function to do
1320#                just that.
1321#
1322##############################################################################
1323sub _parse_xmlns
1324{
1325    my $self = shift;
1326
1327    $self->SetXMLNS($self->{TREE}->get_attrib("xmlns"))
1328        if defined($self->{TREE}->get_attrib("xmlns"));
1329}
1330
1331
1332##############################################################################
1333#
1334# _parse_tree - run through the XML::Stream::Node and pull any child nodes
1335#               out that we recognize and create objects for them.
1336#
1337##############################################################################
1338sub _parse_tree
1339{
1340    my $self = shift;
1341
1342    my @xTrees = $self->{TREE}->XPath('*[@xmlns]');
1343
1344    if ($#xTrees > -1)
1345    {
1346        foreach my $xTree (@xTrees)
1347        {
1348            if( exists($Net::XMPP::Namespaces::NS{$xTrees[0]->get_attrib("xmlns")}))
1349            {
1350                $self->AddChild($xTree);
1351                $self->{TREE}->remove_child($xTree);
1352            }
1353        }
1354    }
1355}
1356
1357
1358
1359
1360##############################################################################
1361#+----------------------------------------------------------------------------
1362#|
1363#| Private Methods
1364#|
1365#+----------------------------------------------------------------------------
1366##############################################################################
1367
1368sub _check_skip_xmlns
1369{
1370    my $self = shift;
1371    my $xmlns = shift;
1372
1373    foreach my $skipns (keys(%Net::XMPP::Namespaces::SKIPNS))
1374    {
1375        return 1 if ($xmlns =~ /^$skipns/);
1376    }
1377
1378    return 0;
1379}
1380
1381
1382##############################################################################
1383#
1384# _debug - helper function for printing debug messages using Net::XMPP::Debug
1385#
1386##############################################################################
1387sub _debug
1388{
1389    my $self = shift;
1390    return $DEBUG->Log99($self->{DEBUGHEADER},": ",@_);
1391}
1392
1393
1394##############################################################################
1395#
1396# _missing_function - send an error if the function is missing.
1397#
1398##############################################################################
1399sub _missing_function
1400{
1401    my ($parent,$function) = @_;
1402    croak("Undefined function $function in package ".ref($parent));
1403}
1404
1405
1406##############################################################################
1407#
1408# _new_jid - create a new JID object.
1409#
1410##############################################################################
1411sub _new_jid
1412{
1413    my $self = shift;
1414    return new Net::XMPP::JID(@_);
1415}
1416
1417
1418##############################################################################
1419#
1420# _new_packet - create a new Stanza object.
1421#
1422##############################################################################
1423sub _new_packet
1424{
1425    my $self = shift;
1426    return new Net::XMPP::Stanza(@_);
1427}
1428
1429
1430##############################################################################
1431#
1432# _skip_xmlns - in the GetTree function, cause the xmlns attribute to be
1433#               removed for a node that has this set.
1434#
1435##############################################################################
1436sub _skip_xmlns
1437{
1438    my $self = shift;
1439
1440    $self->{SKIPXMLNS} = 1;
1441}
1442
1443
14441;
Note: See TracBrowser for help on using the repository browser.