=head1 NAME
Bio::Phylo::NeXML::DOM::Element::Libxml - XML DOM element mappings to the
C<XML::LibXML> package
=head1 SYNOPSIS
Don't use directly; use Bio::Phylo::NeXML::DOM->new( -format => 'libxml' ) instead.
=head1 DESCRIPTION
This module provides mappings the methods specified in the
L<Bio::Phylo::NeXML::DOM::Element> abstract class to the
C<XML::LibXML::Element> package.
=head1 AUTHOR
Mark A. Jensen ( maj -at- fortinbras -dot- us )
=cut
package Bio::Phylo::NeXML::DOM::Element::Libxml;
use strict;
use Bio::Phylo::Util::Exceptions 'throw';
use Bio::Phylo::Util::CONSTANT '/looks_like/';
use Bio::Phylo::Util::Dependency 'XML::LibXML';
use base qw'Bio::Phylo::NeXML::DOM::Element XML::LibXML::Element';
XML::LibXML->import(':libxml');
=head2 Constructor
=over
=item new()
Type : Constructor
Title : new
Usage : $elt = Bio::Phylo::NeXML::DOM::Element->new($tag, $attr)
Function: Create a new XML DOM element
Returns : DOM element object
Args : Optional:
'-tag' => $tag - tag name as string
'-attributes' => $attr - hashref of attributes/values
=cut
sub new {
my $class = shift;
if ( my %args = looks_like_hash @_ ) {
if ( $args{'-tag'} ) {
my $self = XML::LibXML::Element->new( $args{'-tag'} );
bless $self, $class;
delete $args{'-tag'};
for my $key ( keys %args ) {
my $method = $key;
$method =~ s/^-//;
$method = 'set_' . $method;
eval { $self->$method( $args{$key} ); };
if ($@) {
if ( blessed $@ and $@->can('rethrow') ) {
$@->rethrow;
}
elsif ( not ref($@)
and $@ =~ /^Can't locate object method / )
{
throw 'BadArgs' =>
"The named argument '${key}' cannot be passed to the constructor";
}
else {
throw 'Generic' => $@;
}
}
}
return $self;
}
else {
throw 'BadArgs' => "Tag name required for XML::LibXML::Element";
}
}
else {
throw 'BadArgs' => "Tag name required for XML::LibXML::Element";
}
}
=item parse_element()
Type : Factory method
Title : parse_element
Usage : $elt = $dom->parse_element($text)
Function: Create a new XML DOM element from XML text
Returns : DOM element
Args : An XML String
=cut
sub parse_element {
my ( $class, $text ) = @_;
my $dom = XML::LibXML->load_xml($text);
my $root = $dom->documentElement();
bless $root, __PACKAGE__;
Bio::Phylo::NeXML::DOM::Element::_recurse_bless($root);
return $root;
}
=back
=head2 Tagname mutators/accessors
=over
=item get_tag()
Type : Accessor
Title : get_tag
Usage : $elt->get_tag()
Function: Get tag name
Returns : Tag name as scalar string
Args : none
=cut
sub get_tag {
return shift->tagName;
}
=item set_tag()
Type : Mutator
Title : set_tag
Usage : $elt->set_tag( $tagname )
Function: Set tagname
Returns : True on success
Args : Tag name as scalar string
=cut
sub set_tag {
my ( $self, $tagname, @args ) = @_;
$self->setNodeName($tagname);
return $self;
}
=back
=head2 Attribute mutators/accessors
=over
=item get_attributes()
Type : Accessor
Title : get_attributes
Usage : $elt->get_attributes( @attribute_names )
Function: Get attribute values
Returns : Array of attribute values
Args : [an array of] attribute name[s] as string[s]
=cut
sub get_attributes {
my ( $self, @attr_names ) = @_;
my %ret = map { $_ => $self->getAttribute($_) } @attr_names;
return \%ret;
}
=item set_attributes()
Type : Mutator
Title : set_attributes
Usage : $elt->set_attributes( @attribute_assoc_array )
Function: Set attribute values
Returns : True on success
Args : An associative array of form ( $name => $value, ... )
=cut
sub set_attributes {
my $self = shift;
if (@_) {
my %attr;
if ( @_ == 1 && looks_like_instance $_[0], 'HASH' ) {
%attr = %{ $_[0] };
}
else {
%attr = looks_like_hash @_;
}
$self->setAttribute( $_, $attr{$_} ) for keys %attr;
}
return $self;
}
=item clear_attributes()
Type : Mutator
Title : clear_attributes
Usage : $elt->clear_attributes( @attribute_names )
Function: Remove attributes from element
Returns : Hash of removed attributes/values
Args : Array of attribute names
=cut
sub clear_attributes {
my ( $self, @attr_names ) = @_;
return 0 if not @attr_names;
my %ret;
$ret{$_} = $self->getAttribute($_) for @attr_names;
$self->removeAttribute($_) for @attr_names;
return %ret;
}
=back
=head2 Content mutators/accessors
=over
=item set_text()
Type : Mutator
Title : set_text
Usage : $elt->set_text($text_content)
Function: Add a #TEXT node to the element
Returns : True on success
Args : scalar string
=cut
sub set_text {
my ( $self, $text, @args ) = @_;
if ($text) {
$self->appendTextNode($text);
return $self;
}
else {
throw 'BadArgs' => "No text specified";
}
}
=item get_text()
Type : Accessor
Title : get_text
Usage : $elt->get_text()
Function: Retrieve direct #TEXT descendants as (concatenated) string
Returns : scalar string (the text content) or undef if no text nodes
Args : none
=cut
#no strict;
sub get_text {
my ( $self, @args ) = @_;
my $text;
for ( $self->childNodes ) {
$text .= $_->nodeValue if $_->nodeType == XML::LibXML::XML_TEXT_NODE;
}
return $text;
}
#use strict;
=item clear_text()
Type : Mutator
Title : clear_text
Usage : $elt->clear_text()
Function: Remove direct #TEXT descendant nodes from element
Returns : True on success; false if no #TEXT nodes removed
Args : none
=cut
#no strict;
sub clear_text {
my ( $self, @args ) = @_;
my @res = map {
$_->nodeType == XML::LibXML::XML_TEXT_NODE
? $self->removeChild($_)
: ()
} $self->childNodes;
return !!scalar(@res);
}
#use strict;
=back
=head2 Traversal methods
=over
=item get_parent()
Type : Accessor
Title : get_parent
Usage : $elt->get_parent()
Function: Get parent DOM node of invocant
Returns : Element object or undef if invocant is root
Args : none
=cut
sub get_parent {
my $e = shift->parentNode;
return bless $e, __PACKAGE__;
}
=item get_children()
Type : Accessor
Title : get_children
Usage : $elt->get_children()
Function: Get child nodes of invocant
Returns : Array of Elements
Args : none
=cut
sub get_children {
my @ret = shift->childNodes;
bless( $_, __PACKAGE__ ) for (@ret);
return \@ret;
}
=item get_first_daughter()
Type : Accessor
Title : get_first_daughter
Usage : $elt->get_first_daughter()
Function: Get first child (as defined by underlying package) of invocant
Returns : Element object or undef if invocant is childless
Args : none
=cut
sub get_first_daughter {
my $e = shift->firstChild;
return bless $e, __PACKAGE__;
}
=item get_last_daughter()
Type : Accessor
Title : get_last_daughter
Usage : $elt->get_last_daughter()
Function: Get last child (as defined by underlying package) of invocant
Returns : Element object or undef if invocant is childless
Args : none
=cut
sub get_last_daughter {
my $e = shift->lastChild;
return bless $e, __PACKAGE__;
}
=item get_next_sister()
Type : Accessor
Title : get_next_sister
Usage : $elt->get_next_sister()
Function: Gets next sibling (as defined by underlying package) of invocant
Returns : Element object or undef if invocant is the rightmost element
Args : none
=cut
sub get_next_sister {
my $e = shift->nextSibling;
return bless $e, __PACKAGE__;
}
=item get_previous_sister()
Type : Accessor
Title : get_previous_sister
Usage : $elt->get_previous_sister()
Function: Get previous sibling (as defined by underlying package) of invocant
Returns : Element object or undef if invocant is leftmost element
Args : none
=cut
sub get_previous_sister {
my $e = shift->previousSibling;
return bless $e, __PACKAGE__;
}
=item get_elements_by_tagname()
Type : Accessor
Title : get_elements_by_tagname
Usage : $elt->get_elements_by_tagname($tagname)
Function: Get array of elements having given tag name from invocant's
descendants
Returns : Array of elements or undef if no match
Args : tag name as string
=cut
sub get_elements_by_tagname {
my ( $self, $tagname, @args ) = @_;
my @a = $self->getElementsByTagName($tagname);
bless( $_, __PACKAGE__ ) for (@a);
return @a;
}
=back
=head2 Prune and graft methods
=over
=item set_child()
Type : Mutator
Title : set_child
Usage : $elt->set_child($child)
Function: Add child element object to invocant's descendants
Returns : the element object added
Args : Element object
Note : See caution at
L<http://search.cpan.org/~pajas/XML-LibXML-1.69/lib/XML/LibXML/Node.pod#addChild>
=cut
sub set_child {
my ( $self, $child, @args ) = @_;
if ( looks_like_instance $child, 'XML::LibXML::Node' ) {
return $self->addChild($child);
}
else {
throw 'ObjectMismatch' => "Argument is not an XML::LibXML::Node";
}
}
=item prune_child()
Type : Mutator
Title : prune_child
Usage : $elt->prune_child($child)
Function: Remove the subtree rooted by $child from among the invocant's
descendants
Returns : $child or undef if $child is not among the children of invocant
Args : Element object
=cut
sub prune_child {
my ( $self, $child, @args ) = @_;
if ( looks_like_instance $child, 'XML::LibXML::Node' ) {
return $self->removeChild($child);
}
else {
throw 'ObjectMismatch' => "Argument is not an XML::LibXML::Node";
}
}
=back
=head2 Output methods
=over
=item to_xml()
Type : Serializer
Title : to_xml
Usage : $elt->to_xml
Function: Create XML string from subtree rooted by invocant
Returns : XML string
Args : Formatting arguments as allowed by underlying package
=cut
sub to_xml {
my ( $self, @args ) = @_;
return $self->toString(@args);
}
=back
=head1 CITATION
If you use Bio::Phylo in published research, please cite it:
B<Rutger A Vos>, B<Jason Caravas>, B<Klaas Hartmann>, B<Mark A Jensen>
and B<Chase Miller>, 2011. Bio::Phylo - phyloinformatic analysis using Perl.
I<BMC Bioinformatics> B<12>:63.
L<http://dx.doi.org/10.1186/1471-2105-12-63>
=cut
1;