Bio::Phylo::NeXML::DOM::Element::Twig - XML DOM mappings to the

#$Id: Twig.pm 1660 2011-04-02 18:29:40Z rvos $
package Bio::Phylo::NeXML::DOM::Element::Twig;
use strict;
use Bio::Phylo::Util::Exceptions 'throw';
use Bio::Phylo::Util::Dependency 'XML::Twig';
use base qw'Bio::Phylo::NeXML::DOM::Element XML::Twig::Elt';
use Bio::Phylo::Util::CONSTANT '/looks_like/';
use Scalar::Util 'blessed';
our %extant_ids;

sub new {
    my $class = shift;
    my $self  = XML::Twig::Elt->new;
    bless $self, $class;
    if (@_) {
        if ( my %arguments = looks_like_hash @_ ) {
            for my $key ( keys %arguments ) {
                my $method = $key;
                $method =~ s/^-//;
                $method = 'set_' . $method;
                eval { $self->$method( $arguments{$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' => $@;
                    }
                }
            }
            if ( $arguments{'-attributes'} ) {
                my %attributes = %{ $arguments{'-attributes'} };
                $self->_manage_ids( 'ADD', %attributes );
            }
        }
    }
    return $self;
}

sub parse_element {
    my ( $class, $text ) = @_;
    my $twig = XML::Twig->new;
    $twig->parse($text);
    my $root = $twig->root;
    bless $root, __PACKAGE__;
    Bio::Phylo::NeXML::DOM::Element::_recurse_bless($root);
    return $root;
}

sub get_tag {
    return shift->gi;
}

sub set_tag {
    my ( $self, $tagname ) = @_;
    $self->set_gi($tagname);
    return $self;
}

sub get_attributes {
    my ( $self, @att_names ) = @_;
    @att_names = $self->att_names if not @att_names;
    my %ret = map { $_ => $self->att($_) } @att_names;
    return \%ret;
}

sub set_attributes {
    my $self = shift;
    if (@_) {
        my %attr;
        if ( @_ == 1 && looks_like_instance $_[0], 'HASH' ) {
            %attr = %{ $_[0] };
        }
        else {
            %attr = looks_like_hash @_;
        }
        $self->set_att(%attr);
        $self->_manage_ids( 'ADD', %attr );
    }
    return $self;
}

sub clear_attributes {
    my ( $self, @attr_names ) = @_;
    my %ret;
    $ret{$_} = $self->att($_) for @attr_names;
    $self->_manage_ids( 'DEL', @attr_names );  # must come before actual removal
    $self->del_att(@attr_names);
    return %ret;
}

sub set_text {
    my ( $self, $text, @args ) = @_;
    if ($text) {
        my $t = XML::Twig::Elt->new( '#PCDATA', $text );
        $t->paste( last_child => $self );
        return 1;
    }
    else {
        throw 'BadArgs' => "No text specified";
    }
}

sub get_text {
    my ( $self, @args ) = @_;
    return $self->text;
}

sub clear_text {
    my ( $self, @args ) = @_;
    my @res;
    @res = map {
        $_->is_text ? do { $_->delete; 1 } : ()
    } $self->children;
    return 1 if @res;
    return 0;
}

sub get_parent {
    return shift->parent();
}

sub get_children {
    return [ shift->children() ];
}

sub get_first_daughter {
    return shift->first_child();
}

sub get_last_daughter {
    return shift->last_child();
}

sub get_next_sister {
    return shift->next_sibling();
}

sub get_previous_sister {
    return shift->prev_sibling();
}

sub get_elements_by_tagname {
    my ( $self, $tagname, @args ) = @_;
    return $self->descendants_or_self($tagname);
}

sub set_child {
    my ( $self, $child, @args ) = @_;
    if ( looks_like_instance $child, 'XML::Twig::Elt' ) {
        $child->paste( last_child => $self );
        $self->_manage_ids('ADD');
        return $child;
    }
    else {
        throw 'ObjectMismatch' => 'Argument is not an XML::Twig::Elt';
    }
}

sub prune_child {
    my ( $self, $child, @args ) = @_;
    if ( looks_like_instance $child, 'XML::Twig::Elt' ) {
        my $par = $child->parent;
        return unless ( $par && ( $par == $self ) );

        # or delete?
        $child->_manage_ids('DEL');
        $child->cut;
        return $child;
    }
    else {
        throw 'ObjectMismatch' => 'Argument is not an XML::Twig::Elt';
    }
}

sub to_xml {
    return shift->sprint(@_);
}

# note: we do our own updates of the Twig id list (the property
# $twig->{twig_id_list}, since according to the XML::Twig source
# "WARNING: at the moment the id list is not updated reliably" which
# evidently means that it isn't updated at all, unless the special
# add_id method is used. Since we want to create elements independent
# of the twig, I felt more in control doing it by by hand. The kludge
# allows the use of the Twig method elt_id() to "get_element_by_id"
# off a document object.
sub _manage_ids {
    my ( $self, $action, @attrs ) = @_;
    for ($action) {
        $_ eq 'ADD' && do {
            my %attrs = @attrs;
            if (%attrs) {    # changing/adding id attribute
                my $id = $attrs{id};
                if ($id) {
                    $extant_ids{$id} = $self;    # log this id
                    ${ $self->twig->{twig_id_list} }{$id} = $self
                      if $self->twig;
                }
                else {
                    return 0;
                }
            }
            else {    # add this element and its descendants
                      # if all elements were created with new(), they all should
                      # logged in %extant_ids
                if ( $self->twig ) {
                    for ( $self->descendants_or_self ) {
                        ${ $self->twig->{twig_id_list} }{ $_->att('id') } = $_
                          if $_->att('id');
                    }
                }
            }
            last;
        };
        $_ eq 'DEL' && do {
            if (@attrs) {
                if ( grep /^id$/, @attrs ) {
                    my $id = $self->att('id');
                    delete $extant_ids{$id};    # clear this id
                    delete ${ $self->twig->{twig_id_list} }{$id} if $self->twig;
                }
                else {
                    return 0;
                }
            }
            else {
                if ( $self->twig ) {
                    delete $extant_ids{ $_->att('id') }
                      for $self->descendants_or_self;
                    delete ${ $self->twig->{twig_id_list} }{ $_->att('id') }
                      for $self->descendants_or_self;
                }
            }
            last;
        };
        do {
            throw 'BadArgs' => 'Unknown action for _manage_ids()';
        };
    }
    return 1;
}
1;