#$Id$
package Bio::Phylo::NeXML::DOM::Element::Twig;
use strict;
use Bio::Phylo::Util::CONSTANT qw(looks_like_instance looks_like_hash);
use Bio::Phylo::NeXML::DOM::Element ();
use Bio::Phylo::Util::Exceptions qw(throw);
use vars qw(@ISA %extant_ids);
use Scalar::Util 'blessed';

BEGIN {
    eval { require XML::Twig };
    if ($@) {
	throw 'ExtensionError' => "Failed to load XML::Twig: $@";
    }
    @ISA = qw( Bio::Phylo::NeXML::DOM::Element XML::Twig::Elt );
}

=head1 NAME

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

=head1 SYNOPSIS

Don't use directly; use Bio::Phylo::NeXML::DOM->new( -format => 'twig' ) instead.

=head1 DESCRIPTION

This module provides mappings the methods specified in the 
L<Bio::Phylo::NeXML::DOM::Element> abstract class.

=head1 AUTHOR

Mark A. Jensen ( maj -at- fortinbras -dot- us )

=cut

=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;
    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;
}

=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 $twig = XML::Twig->new;
    $twig->parse($text);
    my $root = $twig->root;
    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->gi;
}

=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 ) = @_;
    $self->set_gi($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, @att_names) = @_;    
    @att_names = $self->att_names if not @att_names;
    my %ret = map { $_ => $self->att($_) } @att_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->set_att(%attr);
	$self->_manage_ids( 'ADD', %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) = @_;
    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;
}

=back

=head2 Namespace accessors/mutators

=over

=item

 Type    : 
 Title   :
 Usage   :
 Function:
 Returns :
 Args    :

=cut

=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 ) {
	my $t = XML::Twig::Elt->new('#PCDATA', $text);
	$t->paste( last_child => $self );
	return 1;
    }
    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)
 Args    : none

=cut

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

=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

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

=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 {
    return shift->parent();
}

=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 {
    return [ shift->children() ];
}

=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 {
    return shift->first_child();
}

=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 {
    return shift->last_child();
}

=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 {
    return shift->next_sibling();
}

=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 {
    return shift->prev_sibling();
}

=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) = @_;
    return $self->descendants_or_self( $tagname );
}

=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

=cut

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';
    }
}

=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::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';
    }
}

=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 {
    return shift->sprint(@_);
}

=back

=cut

# 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;
