| 1 | package DJabberd::XMLElement; |
|---|
| 2 | use strict; |
|---|
| 3 | use fields ( |
|---|
| 4 | 'ns', # namespace name |
|---|
| 5 | 'element', # element name |
|---|
| 6 | 'attrs', # hashref of {namespace}attr => value |
|---|
| 7 | 'children', # arrayref of child elements of this same type, or scalars for text nodes |
|---|
| 8 | ); |
|---|
| 9 | |
|---|
| 10 | use DJabberd::Util; |
|---|
| 11 | |
|---|
| 12 | sub new { |
|---|
| 13 | my $class = shift; |
|---|
| 14 | if (ref $_[0]) { |
|---|
| 15 | # the down-classer that subclasses can inherit |
|---|
| 16 | return bless $_[0], $class; |
|---|
| 17 | } |
|---|
| 18 | |
|---|
| 19 | # constructing a new XMLElement: |
|---|
| 20 | my ($ns, $elementname, $attrs, $children) = @_; |
|---|
| 21 | |
|---|
| 22 | Carp::confess("children isn't an arrayref, is: $children") unless ref $children eq "ARRAY"; |
|---|
| 23 | |
|---|
| 24 | my $self = fields::new($class); |
|---|
| 25 | $self->{ns} = $ns; |
|---|
| 26 | $self->{element} = $elementname; |
|---|
| 27 | $self->{attrs} = $attrs; |
|---|
| 28 | $self->{children} = $children; |
|---|
| 29 | |
|---|
| 30 | return $self; |
|---|
| 31 | } |
|---|
| 32 | |
|---|
| 33 | sub children { |
|---|
| 34 | my DJabberd::XMLElement $self = shift; |
|---|
| 35 | return @{ $self->{children} }; |
|---|
| 36 | } |
|---|
| 37 | |
|---|
| 38 | sub first_child { |
|---|
| 39 | my $self = shift; |
|---|
| 40 | return @{ $self->{children} } ? $self->{children}[0] : undef; |
|---|
| 41 | } |
|---|
| 42 | |
|---|
| 43 | sub first_element { |
|---|
| 44 | my $self = shift; |
|---|
| 45 | foreach my $c (@{ $self->{children} }) { |
|---|
| 46 | return $c if ref $c; |
|---|
| 47 | } |
|---|
| 48 | return undef; |
|---|
| 49 | } |
|---|
| 50 | |
|---|
| 51 | sub attr { |
|---|
| 52 | return $_[0]->{attrs}{$_[1]}; |
|---|
| 53 | } |
|---|
| 54 | |
|---|
| 55 | sub set_attr { |
|---|
| 56 | $_[0]->{attrs}{$_[1]} = $_[2]; |
|---|
| 57 | } |
|---|
| 58 | |
|---|
| 59 | sub attrs { |
|---|
| 60 | return $_[0]->{attrs}; |
|---|
| 61 | } |
|---|
| 62 | |
|---|
| 63 | sub element { |
|---|
| 64 | my $self = shift; |
|---|
| 65 | return ($self->{ns}, $self->{element}) if wantarray; |
|---|
| 66 | return "{$self->{ns}}$self->{element}"; |
|---|
| 67 | } |
|---|
| 68 | |
|---|
| 69 | sub element_name { |
|---|
| 70 | my $self = shift; |
|---|
| 71 | return $self->{element}; |
|---|
| 72 | } |
|---|
| 73 | |
|---|
| 74 | sub namespace { |
|---|
| 75 | my $self = shift; |
|---|
| 76 | return $self->{ns}; |
|---|
| 77 | } |
|---|
| 78 | |
|---|
| 79 | sub as_xml { |
|---|
| 80 | my $self = shift; |
|---|
| 81 | my $nsmap = shift || {}; # localname -> uri, uri -> localname |
|---|
| 82 | my $def_ns = shift; |
|---|
| 83 | |
|---|
| 84 | my ($ns, $el) = $self->element; |
|---|
| 85 | |
|---|
| 86 | # FIXME: escaping |
|---|
| 87 | my $attr_str = ""; |
|---|
| 88 | my $attr = $self->attrs; |
|---|
| 89 | foreach my $k (keys %$attr) { |
|---|
| 90 | my $value = $attr->{$k}; |
|---|
| 91 | $k =~ s!^\{(.+)\}!!; |
|---|
| 92 | my $ns = $1; |
|---|
| 93 | $attr_str .= " $k='" . DJabberd::Util::exml($value) . "'"; |
|---|
| 94 | } |
|---|
| 95 | |
|---|
| 96 | my $xmlns = $ns eq $def_ns ? "" : " xmlns='$ns'"; |
|---|
| 97 | my $innards = $self->innards_as_xml($nsmap, $ns); |
|---|
| 98 | return length $innards ? |
|---|
| 99 | "<$el$xmlns$attr_str>$innards</$el>" : |
|---|
| 100 | "<$el$xmlns$attr_str/>"; |
|---|
| 101 | } |
|---|
| 102 | |
|---|
| 103 | sub innards_as_xml { |
|---|
| 104 | my $self = shift; |
|---|
| 105 | my $nsmap = shift || {}; |
|---|
| 106 | my $def_ns = shift; |
|---|
| 107 | |
|---|
| 108 | my $ret = ""; |
|---|
| 109 | foreach my $c ($self->children) { |
|---|
| 110 | if (ref $c) { |
|---|
| 111 | $ret .= $c->as_xml($nsmap, $def_ns); |
|---|
| 112 | } else { |
|---|
| 113 | $ret .= DJabberd::Util::exml($c); |
|---|
| 114 | } |
|---|
| 115 | } |
|---|
| 116 | return $ret; |
|---|
| 117 | } |
|---|
| 118 | |
|---|
| 119 | 1; |
|---|