Bio::Phylo::NeXML::Writable - Superclass for objects that serialize to NeXML

Bio-Phylo documentation Contained in the Bio-Phylo distribution.

Index

Code Index:

NAME

Top

Bio::Phylo::NeXML::Writable - Superclass for objects that serialize to NeXML

SYNOPSIS

Top

 # no direct usage

DESCRIPTION

Top

This is the superclass for all objects that can be serialized to NeXML (http://www.nexml.org).

METHODS

Top

MUTATORS

set_namespaces()
 Type    : Mutator
 Title   : set_namespaces
 Usage   : $obj->set_namespaces( 'dwc' => 'http://www.namespaceTBD.org/darwin2' );
 Function: Adds one or more prefix/namespace pairs
 Returns : $self
 Args    : One or more prefix/namespace pairs, as even-sized list, 
           or as a hash reference, i.e.:
           $obj->set_namespaces( 'dwc' => 'http://www.namespaceTBD.org/darwin2' );
           or
           $obj->set_namespaces( { 'dwc' => 'http://www.namespaceTBD.org/darwin2' } );
 Notes   : This is a global for the XMLWritable class, so that in a recursive
 		   to_xml call the outermost element contains the namespace definitions.
 		   This method can also be called as a static class method, i.e.
 		   Bio::Phylo::NeXML::Writable->set_namespaces(
 		   'dwc' => 'http://www.namespaceTBD.org/darwin2');
set_suppress_ns()
 Type    : Mutator
 Title   : set_suppress_ns
 Usage   : $obj->set_suppress_ns();
 Function: Tell this object not to write namespace attributes
 Returns : 
 Args    : none
clear_suppress_ns()
 Type    : Mutator
 Title   : clear_suppress_ns
 Usage   : $obj->clear_suppress_ns();
 Function: Tell this object to write namespace attributes
 Returns : 
 Args    : none
add_meta()
 Type    : Mutator
 Title   : add_meta
 Usage   : $obj->add_meta($meta);
 Function: Adds a metadata attachment to the object
 Returns : $self
 Args    : A Bio::Phylo::NeXML::Meta object
remove_meta()
 Type    : Mutator
 Title   : remove_meta
 Usage   : $obj->remove_meta($meta);
 Function: Removes a metadata attachment from the object
 Returns : $self
 Args    : Bio::Phylo::NeXML::Meta
set_identifiable()

By default, all XMLWritable objects are identifiable when serialized, i.e. they have a unique id attribute. However, in some cases a serialized object may not have an id attribute (governed by the nexml schema). For such objects, id generation can be explicitly disabled using this method. Typically, this is done internally - you will probably never use this method.

 Type    : Mutator
 Title   : set_identifiable
 Usage   : $obj->set_identifiable(0);
 Function: Enables/disables id generation
 Returns : $self
 Args    : BOOLEAN
set_tag()

This method is usually only used internally, to define or alter the name of the tag into which the object is serialized. For example, for a Bio::Phylo::Forest::Node object, this method would be called with the 'node' argument, so that the object is serialized into an xml element structure called <node/>

 Type    : Mutator
 Title   : set_tag
 Usage   : $obj->set_tag('node');
 Function: Sets the tag name
 Returns : $self
 Args    : A tag name (must be a valid xml element name)
set_name()

Sets invocant name.

 Type    : Mutator
 Title   : set_name
 Usage   : $obj->set_name($name);
 Function: Assigns an object's name.
 Returns : Modified object.
 Args    : Argument must be a string. Ensure that this string is safe to use for
           whatever output format you want to use (this differs between xml and
           nexus, for example).
set_attributes()

Assigns attributes for the element.

 Type    : Mutator
 Title   : set_attributes
 Usage   : $obj->set_attributes( 'foo' => 'bar' )
 Function: Sets the xml attributes for the object;
 Returns : $self
 Args    : key/value pairs or a hash ref
set_xml_id()

This method is usually only used internally, to store the xml id of an object as it is parsed out of a nexml file - this is for the purpose of round-tripping nexml info sets.

 Type    : Mutator
 Title   : set_xml_id
 Usage   : $obj->set_xml_id('node345');
 Function: Sets the xml id
 Returns : $self
 Args    : An xml id (must be a valid xml NCName)
unset_attribute()

Removes specified attribute

 Type    : Mutator
 Title   : unset_attribute
 Usage   : $obj->unset_attribute( 'foo' )
 Function: Removes the specified xml attribute for the object
 Returns : $self
 Args    : an attribute name

ACCESSORS

get_namespaces()
 Type    : Accessor
 Title   : get_namespaces
 Usage   : my %ns = %{ $obj->get_namespaces };
 Function: Retrieves the known namespaces
 Returns : A hash of prefix/namespace key/value pairs, or
           a single namespace if a single, optional
           prefix was provided as argument
 Args    : Optional - a namespace prefix
get_meta()

Retrieves the metadata for the element.

 Type    : Accessor
 Title   : get_meta
 Usage   : my @meta = @{ $obj->get_meta };
 Function: Retrieves the metadata for the element.
 Returns : An array ref of Bio::Phylo::NeXML::Meta objects
 Args    : Optional: a list of CURIE predicates, in which case
           the returned objects will be those matching these
	   predicates
get_tag()

Retrieves tag name for the element.

 Type    : Accessor
 Title   : get_tag
 Usage   : my $tag = $obj->get_tag;
 Function: Gets the xml tag name for the object;
 Returns : A tag name
 Args    : None.
get_name()

Gets invocant's name.

 Type    : Accessor
 Title   : get_name
 Usage   : my $name = $obj->get_name;
 Function: Returns the object's name.
 Returns : A string
 Args    : None
get_xml_tag()

Retrieves tag string

 Type    : Accessor
 Title   : get_xml_tag
 Usage   : my $str = $obj->get_xml_tag;
 Function: Gets the xml tag for the object;
 Returns : A tag, i.e. pointy brackets
 Args    : Optional: a true value, to close an empty tag
get_attributes()

Retrieves attributes for the element.

 Type    : Accessor
 Title   : get_attributes
 Usage   : my %attrs = %{ $obj->get_attributes };
 Function: Gets the xml attributes for the object;
 Returns : A hash reference
 Args    : None.
 Comments: throws ObjectMismatch if no linked taxa object 
           can be found
get_xml_id()

Retrieves xml id for the element.

 Type    : Accessor
 Title   : get_xml_id
 Usage   : my $id = $obj->get_xml_id;
 Function: Gets the xml id for the object;
 Returns : An xml id
 Args    : None.
get_dom_elt()
 Type    : Serializer
 Title   : get_dom_elt
 Usage   : $obj->get_dom_elt
 Function: Generates a DOM element from the invocant
 Returns : a DOM element object (default XML::Twig)
 Args    : DOM factory object

TESTS

is_identifiable()

By default, all XMLWritable objects are identifiable when serialized, i.e. they have a unique id attribute. However, in some cases a serialized object may not have an id attribute (governed by the nexml schema). This method indicates whether that is the case.

 Type    : Test
 Title   : is_identifiable
 Usage   : if ( $obj->is_identifiable ) { ... }
 Function: Indicates whether IDs are generated
 Returns : BOOLEAN
 Args    : NONE
is_ns_suppressed()
 Type    : Test
 Title   : is_ns_suppressed
 Usage   : if ( $obj->is_ns_suppressed ) { ... }
 Function: Indicates whether namespace attributes should not
           be written on XML serialization
 Returns : BOOLEAN
 Args    : NONE

CLONER

clone()

Clones invocant.

 Type    : Utility method
 Title   : clone
 Usage   : my $clone = $object->clone;
 Function: Creates a copy of the invocant object.
 Returns : A copy of the invocant.
 Args    : NONE.
 Comments: Cloning is currently experimental, use with caution.

SERIALIZERS

to_xml()

Serializes invocant to XML.

 Type    : XML serializer
 Title   : to_xml
 Usage   : my $xml = $obj->to_xml;
 Function: Serializes $obj to xml
 Returns : An xml string
 Args    : None
to_dom()
 Type    : Serializer
 Title   : to_dom
 Usage   : $obj->to_dom
 Function: Generates a DOM subtree from the invocant and
           its contained objects
 Returns : a DOM element object (default: XML::Twig flavor)
 Args    : DOM factory object
 Note    : This is the generic function. It is redefined in the 
           classes below.
to_json()

Serializes object to JSON string

 Type    : Serializer
 Title   : to_json()
 Usage   : print $obj->to_json();
 Function: Serializes object to JSON string
 Returns : String 
 Args    : None
 Comments:

SEE ALSO

Top

Also see the manual: Bio::Phylo::Manual and http://rutgervos.blogspot.com.

CITATION

Top

If you use Bio::Phylo in published research, please cite it:

Rutger A Vos, Jason Caravas, Klaas Hartmann, Mark A Jensen and Chase Miller, 2011. Bio::Phylo - phyloinformatic analysis using Perl. BMC Bioinformatics 12:63. http://dx.doi.org/10.1186/1471-2105-12-63

REVISION

Top

 $Id: Writable.pm 1660 2011-04-02 18:29:40Z rvos $
Bio-Phylo documentation Contained in the Bio-Phylo distribution. 
# $Id: Writable.pm 1660 2011-04-02 18:29:40Z rvos $
package Bio::Phylo::NeXML::Writable;
use strict;
use base 'Bio::Phylo';
use Bio::Phylo::Util::Exceptions 'throw';
use Bio::Phylo::NeXML::DOM;
use Bio::Phylo::Util::CONSTANT qw'/looks_like/ :namespaces :objecttypes';
{
    my $logger              = __PACKAGE__->get_logger;
    my $DICTIONARY_CONSTANT = _DICTIONARY_;
    my $META_CONSTANT       = _META_;
    my %namespaces          = (
        'nex' => _NS_NEXML_,
        'xml' => _NS_XML_,
        'xsi' => _NS_XSI_,
        'rdf' => _NS_RDF_,
        'xsd' => _NS_XSD_,
    );
    my @fields =
      \( my ( %tag, %id, %attributes, %identifiable, %suppress_ns, %meta ) );


    sub set_namespaces {
        my $self = shift;
        if ( scalar(@_) == 1 and ref( $_[0] ) eq 'HASH' ) {
            my $hash = shift;
            for my $key ( keys %{$hash} ) {
                $namespaces{$key} = $hash->{$key};
            }
        }
        elsif ( my %hash = looks_like_hash @_ ) {
            for my $key ( keys %hash ) {
                $namespaces{$key} = $hash{$key};
            }
        }
    }


    sub set_suppress_ns {
        my $self = shift;
        my $id   = $self->get_id;
        $suppress_ns{$id} = 1;
    }


    sub clear_suppress_ns {
        my $self = shift;
        my $id   = $self->get_id;
        $suppress_ns{$id} = 0;
    }


    sub add_meta {
        my ( $self, $meta_obj ) = @_;
        if ( looks_like_object $meta_obj, $META_CONSTANT ) {
            my $id = $self->get_id;
            if ( not $meta{$id} ) {
                $meta{$id} = [];
            }
            push @{ $meta{$id} }, $meta_obj;
            $self->set_attributes( 'about' => '#' . $self->get_xml_id );
        }
        return $self;
    }


    sub remove_meta {
        my ( $self, $meta ) = @_;
        my $id      = $self->get_id;
        my $meta_id = $meta->get_id;
        if ( $meta{$id} ) {
          DICT: for my $i ( 0 .. $#{ $meta{$id} } ) {
                if ( $meta{$id}->[$i]->get_id == $meta_id ) {
                    splice @{ $meta{$id} }, $i, 1;
                    last DICT;
                }
            }
        }
        if ( not $meta{$id} or not @{ $meta{$id} } ) {
            $self->unset_attribute('about');
        }
        return $self;
    }


    sub set_identifiable {
        my $self = shift;
        $identifiable{ $self->get_id } = !!shift;
        return $self;
    }


    sub set_tag {
        my ( $self, $tag ) = @_;

        # _ is ok; see http://www.w3.org/TR/2004/REC-xml-20040204/#NT-NameChar
        if ( $tag =~ qr/^[a-zA-Z]+\:?[a-zA-Z_]*$/ ) {
            $tag{ $self->get_id } = $tag;
            return $self;
        }
        else {
            throw 'BadString' => "'$tag' is not valid for xml";
        }
    }


    sub set_name {
        my ( $self, $name ) = @_;
        if ( defined $name ) {
            return $self->set_attributes( 'label' => $name );
        }
        else {
            return $self;
        }
    }


    sub set_attributes {
        my $self = shift;
        my $id   = $self->get_id;
        my %attrs;
        if ( scalar @_ == 1 and ref $_[0] eq 'HASH' ) {
            %attrs = %{ $_[0] };
        }
        elsif ( scalar @_ % 2 == 0 ) {
            %attrs = @_;
        }
        else {
            throw 'OddHash' => 'Arguments are not even key/value pairs';
        }
        my $hash = $attributes{$id} || {};
        my $fully_qualified_attribute_regex = qr/^(.+?):(.+)/;
        for my $key ( keys %attrs ) {
            if ( $key =~ $fully_qualified_attribute_regex ) {
                my ( $prefix, $attribute ) = ( $1, $2 );
                if ( $prefix ne 'xmlns' and not exists $namespaces{$prefix} ) {
                    $logger->warn(
"Attribute '${prefix}:${attribute}' is not bound to a namespace"
                    );
                }
            }
            $hash->{$key} = $attrs{$key};
        }
        $attributes{$id} = $hash;
        return $self;
    }


    sub set_xml_id {
        my ( $self, $id ) = @_;
        if ( $id =~ qr/^[a-zA-Z][a-zA-Z0-9\-_\.]*$/ ) {
            $id{ $self->get_id } = $id;
            return $self;
        }
        else {
            throw 'BadString' => "'$id' is not a valid xml NCName for $self";
        }
    }


    sub unset_attribute {
        my $self  = shift;
        my $attrs = $attributes{ $self->get_id };
        if ( $attrs and looks_like_instance( $attrs, 'HASH' ) ) {
            delete $attrs->{$_} for @_;
        }
        return $self;
    }


    sub get_namespaces {
        my ( $self, $prefix ) = @_;
        if ($prefix) {
            return $namespaces{$prefix};
        }
        else {
            my %tmp_namespaces = %namespaces;
            return \%tmp_namespaces;
        }
    }


    sub get_meta {
	my $self = shift;
	my $metas = $meta{ $self->get_id } || [];
        if ( @_ ) {
	    my %predicates = map { $_ => 1 } @_;
	    my @matches = grep { $predicates{$_->get_predicate} } @{ $metas };
	    return \@matches;
	}
	return $metas;        
    }


    sub get_tag {
        my $self = shift;
        if ( my $tagstring = $tag{ $self->get_id } ) {
            return $tagstring;
        }
        elsif ( looks_like_implementor $self, '_tag' ) {
            return $self->_tag;
        }
        else {
            return '';
        }
    }


    sub get_name {
        my $self = shift;
        my $id   = $self->get_id;
        if ( !$attributes{$id} ) {
            $attributes{$id} = {};
        }
        if ( defined $attributes{$id}->{'label'} ) {
            return $attributes{$id}->{'label'};
        }
        else {
            return '';
        }
    }


    sub get_xml_tag {
        my ( $self, $closeme ) = @_;
        my %attrs = %{ $self->get_attributes };
        my $tag   = $self->get_tag;
        my $xml   = '<' . $tag;
        for my $key ( keys %attrs ) {
            $xml .= ' ' . $key . '="' . $attrs{$key} . '"';
        }
        my $has_contents = 0;
        my $meta         = $self->get_meta;
        if ( @{$meta} ) {
            $xml .= '>';                       # if not @{ $dictionaries };
            $xml .= $_->to_xml for @{$meta};
            $has_contents++;
        }
        if ($has_contents) {
            $xml .= "</$tag>" if $closeme;
        }
        else {
            $xml .= $closeme ? '/>' : '>';
        }
        return $xml;
    }


    my $SAFE_CHARACTERS_REGEX = qr/(?:[a-zA-Z0-9]|-|_|\.)/;
    my $XMLEntityEncode       = sub {
        my $buf = '';
        for my $c ( split //, shift ) {
            if ( $c =~ $SAFE_CHARACTERS_REGEX ) {
                $buf .= $c;
            }
            else {
                $buf .= '&#' . ord($c) . ';';
            }
        }
        return $buf;
    };
    my $add_namespaces_to_attributes = sub {
        my ( $self, $attrs ) = @_;
        my $i                       = 0;
        my $inside_to_xml_recursion = 0;
      CHECK_RECURSE: while ( my @frame = caller($i) ) {
            if ( $frame[3] =~ m/::to_xml$/ ) {
                $inside_to_xml_recursion++;
                last CHECK_RECURSE if $inside_to_xml_recursion > 1;
            }
            $i++;
        }
        if ( $inside_to_xml_recursion <= 1 ) {
            my $tmp_namespaces = get_namespaces();
            for my $ns ( keys %{$tmp_namespaces} ) {
                $attrs->{ 'xmlns:' . $ns } = $tmp_namespaces->{$ns};
            }
        }
        return $attrs;
    };
    my $flatten_attributes = sub {
        my $self      = shift;
        my $tempattrs = $attributes{ $self->get_id };
        my $attrs;
        if ($tempattrs) {
            my %deref = %{$tempattrs};
            $attrs = \%deref;
        }
        else {
            $attrs = {};
        }
        return $attrs;
    };

    sub get_attributes {
        my $self  = shift;
        my $attrs = $flatten_attributes->($self);
        if ( not exists $attrs->{'label'} and my $label = $self->get_name ) {
            $attrs->{'label'} = $label;
        }
	if ( defined $attrs->{'label'} and $attrs->{'label'} ne '' ) {
	    $attrs->{'label'} = $XMLEntityEncode->($attrs->{'label'});
	}
	else {
	    delete $attrs->{'label'};
	}
        if ( not exists $attrs->{'id'} ) {
            $attrs->{'id'} = $self->get_xml_id;
        }
        if ( defined $self->is_identifiable and not $self->is_identifiable ) {
            delete $attrs->{'id'};
        }
        if ( $self->can('get_taxa') ) {
            if ( my $taxa = $self->get_taxa ) {
                $attrs->{'otus'} = $taxa->get_xml_id
                  if looks_like_instance( $taxa, 'Bio::Phylo' );
            }
            else {
                throw 'ObjectMismatch' =>
                  "$self can link to a taxa element, but doesn't";
            }
        }
        if ( $self->can('get_taxon') ) {
            if ( my $taxon = $self->get_taxon ) {
                $attrs->{'otu'} = $taxon->get_xml_id;
            }
            else {
                $logger->info("No linked taxon found");
            }
        }
        $attrs = $add_namespaces_to_attributes->( $self, $attrs )
          unless $self->is_ns_suppressed;
        my $arg = shift;
        if ($arg) {
            return $attrs->{$arg};
        }
        else {
            return $attrs;
        }
    }


    sub get_xml_id {
        my $self = shift;
        if ( my $id = $id{ $self->get_id } ) {
            return $id;
        }
        else {
            my $xml_id = $self->get_tag;
	    my $obj_id = $self->get_id;
            $xml_id =~ s/^(.).+(.)$/$1$2$obj_id/;
            return $id{$obj_id} = $xml_id;
        }
    }


    sub get_dom_elt {
        my ( $self, $dom ) = @_;
        $dom ||= Bio::Phylo::NeXML::DOM->get_dom;
        unless ( looks_like_object $dom, _DOMCREATOR_ ) {
            throw 'BadArgs' => 'DOM factory object not provided';
        }
        my $elt = $dom->create_element( '-tag' => $self->get_tag );
        my %attrs = %{ $self->get_attributes };
        for my $key ( keys %attrs ) {
            $elt->set_attributes( $key => $attrs{$key} );
        }
        for my $meta ( @{ $self->get_meta } ) {
            $elt->set_child( $meta->to_dom($dom) );
        }

        #my $dictionaries = $self->get_dictionaries;
        #if ( @{ $dictionaries } ) {
        #    $elt->set_child( $_->to_dom($dom) ) for @{ $dictionaries };
        #}
        if ( looks_like_implementor $self, 'get_sets' ) {
            my $sets = $self->get_sets;
            $elt->set_child( $_->to_dom($dom) ) for @{$sets};
        }
        return $elt;
    }


    sub is_identifiable {
        my $self = shift;
        return $identifiable{ $self->get_id };
    }


    sub is_ns_suppressed {
        return $suppress_ns{ shift->get_id };
    }


    sub clone {
        my $self = shift;
        $logger->info("cloning $self");
        my %subs = @_;

        # some extra logic to copy characters from source to target
        if ( not exists $subs{'add_meta'} ) {
            $subs{'add_meta'} = sub {
                my ( $obj, $clone ) = @_;
                for my $meta ( @{ $obj->get_meta } ) {
                    $clone->add_meta($meta);
                }
            };
        }
        return $self->SUPER::clone(%subs);
    }


    sub to_xml {
        my $self = shift;
        my $xml  = '';
        if ( $self->can('get_entities') ) {	    
            for my $ent ( @{ $self->get_entities } ) {
                if ( looks_like_implementor $ent, 'to_xml' ) {
                    $xml .= "\n" . $ent->to_xml;
                }
            }
	    $xml .= $self->sets_to_xml;
        }
        if ($xml) {
            $xml =
              $self->get_xml_tag . $xml . sprintf('</%s>', $self->get_tag);
        }
        else {
            $xml = $self->get_xml_tag(1);
        }
        return $xml;
    }


    sub to_dom {
        my ( $self, $dom ) = @_;
        $dom ||= Bio::Phylo::NeXML::DOM->get_dom;
        if ( looks_like_object $dom, _DOMCREATOR_ ) {
            my $elt = $self->get_dom_elt($dom);
            if ( $self->can('get_entities') ) {
                for my $ent ( @{ $self->get_entities } ) {
                    if ( looks_like_implementor $ent, 'to_dom' ) {
                        $elt->set_child( $ent->to_dom($dom) );
                    }
                }
            }
            return $elt;
        }
        else {
            throw 'BadArgs' => 'DOM factory object not provided';
        }
    }


    sub to_json {
        looks_like_class('XML::XML2JSON')->new->convert( shift->to_xml );
    }

    sub _cleanup {
        my $self = shift;
        my $id   = $self->get_id;
        for my $field (@fields) {
            delete $field->{$id};
        }
    }


    # podinherit_insert_token


}
1;