1package DJabberd::XMLElement;
2use strict;
3use fields (
4            'ns',        # namespace name
5            'element',   # element name
6            'attrs',     # hashref of {namespace}attr => value.  NOTE: used by Stanza.pm directly.
7            'children',  # arrayref of child elements of this same type, or scalars for text nodes
8            'raw',       # in some cases we have the raw xml and we have to create a fake XMLElement object
9                         # business logic is that as_xml returns the raw stuff if it is exists, children has to be empty -- sky
10            'prefix',    # namepace prefix in use in this element
11            );
12
13use DJabberd::Util;
14
15sub new {
16    my $class = shift;
17    if (ref $_[0]) {
18        # the down-classer that subclasses can inherit
19        return bless $_[0], $class;
20    }
21
22    # constructing a new XMLElement:
23    my DJabberd::XMLElement $self = fields::new($class);
24    ($self->{ns},
25     $self->{element},
26     $self->{attrs},
27     $self->{children},
28     $self->{raw},
29     $self->{prefix}) = @_;
30    #my ($ns, $elementname, $attrs, $children) = @_;
31    #Carp::confess("children isn't an arrayref, is: $children") unless ref $children eq "ARRAY";
32
33    #DJabberd->track_new_obj($self);
34    return $self;
35}
36
37#sub DESTROY {
38#    my $self = shift;
39#    DJabberd->track_destroyed_obj($self);
40#}
41
42sub push_child {
43    my DJabberd::XMLElement $self = $_[0];
44    push @{$self->{children}}, $_[1]; # $node
45}
46
47sub set_raw {
48    my DJabberd::XMLElement $self = shift;
49    $self->{raw} = shift;
50    $self->{children} = [];
51}
52
53sub children_elements {
54    my DJabberd::XMLElement $self = $_[0];
55    return grep { ref $_ } @{ $self->{children} };
56}
57
58sub remove_child {
59    my DJabberd::XMLElement $self = $_[0];
60    @{$self->{children}} = grep { $_ != $_[1] } @{$self->{children}};
61}
62
63sub children {
64    my DJabberd::XMLElement $self = $_[0];
65    return @{ $self->{children} };
66}
67
68sub first_child {
69    my DJabberd::XMLElement $self = $_[0];
70    return @{ $self->{children} } ? $self->{children}[0] : undef;
71}
72
73sub first_element {
74    my DJabberd::XMLElement $self = $_[0];
75    foreach my $c (@{ $self->{children} }) {
76        return $c if ref $c;
77    }
78    return undef;
79}
80
81sub inner_ns {
82    return $_[0]->{attrs}{'{}xmlns'};
83}
84
85sub attr {
86    return $_[0]->{attrs}{$_[1]};
87}
88
89sub set_attr {
90    $_[0]->{attrs}{$_[1]} = $_[2];
91}
92
93sub attrs {
94    return $_[0]->{attrs};
95}
96
97sub element {
98    my DJabberd::XMLElement $self = $_[0];
99    return ($self->{ns}, $self->{element}) if wantarray;
100    return "{$self->{ns}}$self->{element}";
101}
102
103sub element_name {
104    my DJabberd::XMLElement $self = $_[0];
105    return $self->{element};
106}
107
108sub namespace {
109    my DJabberd::XMLElement $self = $_[0];
110    return $self->{ns};
111}
112
113sub _resolve_prefix {
114    my ($self, $nsmap, $def_ns, $uri, $attr) = @_;
115    if ($def_ns && $def_ns eq $uri) {
116        return '';
117    } elsif ($uri eq '') {
118        return '';
119    } elsif ($nsmap->{$uri}) {
120        $nsmap->{$uri} . ':';
121    } else {
122        $nsmap->{___prefix_count} ||= 0;
123        my $count = $nsmap->{___prefix_count}++;
124        my $prefix = "nsp$count";
125        $nsmap->{$uri} = $prefix;
126        $nsmap->{$prefix} = $uri;
127        $attr->{'{http://www.w3.org/2000/xmlns}' . $prefix} = $uri;
128        return $prefix . ':';
129    }
130}
131
132sub as_xml {
133    my DJabberd::XMLElement $self = shift;
134
135    my $nsmap = shift || { }; # localname -> uri, uri -> localname
136
137    # tons of places call as_xml, but nobody seems to care about
138    # the default namespace. It seems, however, that it is a common
139    # usage for "jabber:client" to be this default ns.
140    my $def_ns = shift || 'jabber:client';
141
142    my ($ns, $el) = ($self->{ns}, $self->{element});
143    if ($self->{prefix}) {
144        $nsmap->{ $self->{prefix} } = $ns;
145        $nsmap->{$ns} = $self->{prefix};
146    }
147
148    my $attr_str = "";
149    my $attr = $self->{attrs};
150
151    $nsmap->{xmlns} = 'http://www.w3.org/2000/xmlns';
152    $nsmap->{'http://www.w3.org/2000/xmlns'} = 'xmlns';
153
154    # let's feed the nsmap...
155    foreach my $k (keys %$attr) {
156        if ($k =~ /^\{(.*)\}(.+)$/) {
157            my ($nsuri, $name) = ($1, $2);
158            if ($nsuri eq 'xmlns' ||
159                $nsuri eq 'http://www.w3.org/2000/xmlns/') {
160                $nsmap->{$name} = $attr->{$k};
161                $nsmap->{ $attr->{$k} } = $name;
162            } elsif ($k eq '{}xmlns') {
163                $def_ns = $attr->{$k};
164            }
165        } elsif ($k eq 'xmlns') {
166            $def_ns = $attr->{$k};
167        }
168    }
169
170    my $nsprefix = $self->_resolve_prefix($nsmap, $def_ns, $ns, $attr);
171
172    foreach my $k (keys %$attr) {
173        my $value = $attr->{$k};
174        if ($k =~ /^\{(.*)\}(.+)$/) {
175            my ($nsuri, $name) = ($1, $2);
176            if ($nsuri eq 'xmlns' ||
177                $nsuri eq 'http://www.w3.org/2000/xmlns/') {
178                $attr_str .= " xmlns:$name='" . DJabberd::Util::exml($value)
179                          . "'";
180            } elsif ($k eq '{}xmlns') {
181                $attr_str .= " xmlns='" . DJabberd::Util::exml($value) . "'";
182            } else {
183                my $nsprefix = $self->_resolve_prefix($nsmap, $def_ns, $nsuri);
184                $attr_str .= " $nsprefix$name='" . DJabberd::Util::exml($value)
185                          ."'";
186            }
187        } else {
188            $attr_str .= " $k='" . DJabberd::Util::exml($value) . "'";
189        }
190    }
191
192    my $innards = $self->innards_as_xml($nsmap, $def_ns);
193    $innards = "..." if $DJabberd::ASXML_NO_INNARDS && $innards;
194
195    my $result = length $innards ?
196        "<$nsprefix$el$attr_str>$innards</$nsprefix$el>" :
197        "<$nsprefix$el$attr_str/>";
198
199    return $result;
200
201}
202
203sub innards_as_xml {
204    my DJabberd::XMLElement $self = shift;
205    my $nsmap = shift || {};
206    my $def_ns = shift;
207
208    if ($self->{raw}) {
209        return $self->{raw};
210    }
211
212    my $ret = "";
213    foreach my $c (@{ $self->{children} }) {
214        if (ref $c) {
215            $ret .= $c->as_xml($nsmap, $def_ns);
216        } else {
217            if ($DJabberd::ASXML_NO_TEXT) {
218                $ret .= "...";
219            } else {
220                $ret .= DJabberd::Util::exml($c);
221            }
222        }
223    }
224    return $ret;
225}
226
227sub clone {
228    my $self = shift;
229    my $clone = fields::new(ref($self));
230    $clone->{ns}       = $self->{ns};
231    $clone->{element}  = $self->{element};
232    $clone->{attrs}    = { %{ $self->{attrs} } };
233    $clone->{children} = [ map { ref($_) ? $_->clone : $_ } @{ $self->{children} } ];
234    $clone->{raw}      = $self->{raw};
235    $clone->{prefix}   = $self->{prefix};
236    return $clone;
237}
238
2391;
240