File Coverage

blib/lib/DJabberd/XMLElement.pm

Criterion	Covered	Total	%
statement	9	124	7.2
branch	0	42	0.0
condition	0	20	0.0
subroutine	3	22	13.6
pod	0	18	0.0
total	12	226	5.3

package DJabberd::XMLElement;
use strict;
use fields (
            'ns',        # namespace name
            'element',   # element name
            'attrs',     # hashref of {namespace}attr => value.  NOTE: used by Stanza.pm directly.
            'children',  # arrayref of child elements of this same type, or scalars for text nodes
            'raw',       # in some cases we have the raw xml and we have to create a fake XMLElement object
                         # business logic is that as_xml returns the raw stuff if it is exists, children has to be empty -- sky
            'prefix',    # namepace prefix in use in this element
            );

use DJabberd::Util;

sub new {
    my $class = shift;
    if (ref $_[0]) {
        # the down-classer that subclasses can inherit
        return bless $_[0], $class;
    }

    # constructing a new XMLElement:
    my DJabberd::XMLElement $self = fields::new($class);
    ($self->{ns},
     $self->{element},
     $self->{attrs},
     $self->{children},
     $self->{raw},
     $self->{prefix}) = @_;
    #my ($ns, $elementname, $attrs, $children) = @_;
    #Carp::confess("children isn't an arrayref, is: $children") unless ref $children eq "ARRAY";

    #DJabberd->track_new_obj($self);
    return $self;
}

#sub DESTROY {
#    my $self = shift;
#    DJabberd->track_destroyed_obj($self);
#}

sub push_child {
    my DJabberd::XMLElement $self = $_[0];
    push @{$self->{children}}, $_[1]; # $node
}

sub set_raw {
    my DJabberd::XMLElement $self = shift;
    $self->{raw} = shift;
    $self->{children} = [];
}

sub children_elements {
    my DJabberd::XMLElement $self = $_[0];
    return grep { ref $_ } @{ $self->{children} };
}

sub remove_child {
    my DJabberd::XMLElement $self = $_[0];
    @{$self->{children}} = grep { $_ != $_[1] } @{$self->{children}};
}

sub children {
    my DJabberd::XMLElement $self = $_[0];
    return @{ $self->{children} };
}

sub first_child {
    my DJabberd::XMLElement $self = $_[0];
    return @{ $self->{children} } ? $self->{children}[0] : undef;
}

sub first_element {
    my DJabberd::XMLElement $self = $_[0];
    foreach my $c (@{ $self->{children} }) {
        return $c if ref $c;
    }
    return undef;
}

sub inner_ns {
    return $_[0]->{attrs}{'{}xmlns'};
}

sub attr {
    return $_[0]->{attrs}{$_[1]};
}

sub set_attr {
    $_[0]->{attrs}{$_[1]} = $_[2];
}

sub attrs {
    return $_[0]->{attrs};
}

sub element {
    my DJabberd::XMLElement $self = $_[0];
    return ($self->{ns}, $self->{element}) if wantarray;
    return "{$self->{ns}}$self->{element}";
}

sub element_name {
    my DJabberd::XMLElement $self = $_[0];
    return $self->{element};
}

sub namespace {
    my DJabberd::XMLElement $self = $_[0];
    return $self->{ns};
}

sub _resolve_prefix {
    my ($self, $nsmap, $def_ns, $uri, $attr) = @_;
    if ($def_ns && $def_ns eq $uri) {
        return '';
    } elsif ($uri eq '') {
        return '';
    } elsif ($nsmap->{$uri}) {
        $nsmap->{$uri} . ':';
    } else {
        $nsmap->{___prefix_count} ||= 0;
        my $count = $nsmap->{___prefix_count}++;
        my $prefix = "nsp$count";
        $nsmap->{$uri} = $prefix;
        $nsmap->{$prefix} = $uri;
        $attr->{'{http://www.w3.org/2000/xmlns}' . $prefix} = $uri;
        return $prefix . ':';
    }
}

sub as_xml {
    my DJabberd::XMLElement $self = shift;

    my $nsmap = shift || { }; # localname -> uri, uri -> localname

    # tons of places call as_xml, but nobody seems to care about
    # the default namespace. It seems, however, that it is a common
    # usage for "jabber:client" to be this default ns.
    my $def_ns = shift || 'jabber:client';

    my ($ns, $el) = ($self->{ns}, $self->{element});
    if ($self->{prefix}) {
        $nsmap->{ $self->{prefix} } = $ns;
        $nsmap->{$ns} = $self->{prefix};
    }

    my $attr_str = "";
    my $attr = $self->{attrs};

    $nsmap->{xmlns} = 'http://www.w3.org/2000/xmlns';
    $nsmap->{'http://www.w3.org/2000/xmlns'} = 'xmlns';

    # let's feed the nsmap...
    foreach my $k (keys %$attr) {
        if ($k =~ /^\{(.*)\}(.+)$/) {
            my ($nsuri, $name) = ($1, $2);
            if ($nsuri eq 'xmlns' ||
                $nsuri eq 'http://www.w3.org/2000/xmlns/') {
                $nsmap->{$name} = $attr->{$k};
                $nsmap->{ $attr->{$k} } = $name;
            } elsif ($k eq '{}xmlns') {
                $def_ns = $attr->{$k};
            }
        } elsif ($k eq 'xmlns') {
            $def_ns = $attr->{$k};
        }
    }

    my $nsprefix = $self->_resolve_prefix($nsmap, $def_ns, $ns, $attr);

    foreach my $k (keys %$attr) {
        my $value = $attr->{$k};
        if ($k =~ /^\{(.*)\}(.+)$/) {
            my ($nsuri, $name) = ($1, $2);
            if ($nsuri eq 'xmlns' ||
                $nsuri eq 'http://www.w3.org/2000/xmlns/') {
                $attr_str .= " xmlns:$name='" . DJabberd::Util::exml($value)
                          . "'";
            } elsif ($k eq '{}xmlns') {
                $attr_str .= " xmlns='" . DJabberd::Util::exml($value) . "'";
            } else {
                my $nsprefix = $self->_resolve_prefix($nsmap, $def_ns, $nsuri);
                $attr_str .= " $nsprefix$name='" . DJabberd::Util::exml($value)
                          ."'";
            }
        } else {
            $attr_str .= " $k='" . DJabberd::Util::exml($value) . "'";
        }
    }

    my $innards = $self->innards_as_xml($nsmap, $def_ns);
    $innards = "..." if $DJabberd::ASXML_NO_INNARDS && $innards;

    my $result = length $innards ?
        "<$nsprefix$el$attr_str>$innards" :
        "<$nsprefix$el$attr_str/>";

    return $result;

}

sub innards_as_xml {
    my DJabberd::XMLElement $self = shift;
    my $nsmap = shift || {};
    my $def_ns = shift;

    if ($self->{raw}) {
        return $self->{raw};
    }

    my $ret = "";
    foreach my $c (@{ $self->{children} }) {
        if (ref $c) {
            $ret .= $c->as_xml($nsmap, $def_ns);
        } else {
            if ($DJabberd::ASXML_NO_TEXT) {
                $ret .= "...";
            } else {
                $ret .= DJabberd::Util::exml($c);
            }
        }
    }
    return $ret;
}

sub clone {
    my $self = shift;
    my $clone = fields::new(ref($self));
    $clone->{ns}       = $self->{ns};
    $clone->{element}  = $self->{element};
    $clone->{attrs}    = { %{ $self->{attrs} } };
    $clone->{children} = [ map { ref($_) ? $_->clone : $_ } @{ $self->{children} } ];
    $clone->{raw}      = $self->{raw};
    $clone->{prefix}   = $self->{prefix};
    return $clone;
}

1;