view release on metacpan or  search on metacpan

lib/Bio/Phylo/NeXML/Writable.pm  view on Meta::CPAN

            return '';
        }
    }

=item 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

=cut

    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 . '="' . encode_entities($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;
    }

=item 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

=cut

    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, $arg ) = @_;
        my $attrs = $flatten_attributes->($self);
	
		# process the 'label' attribute: encode if there's anything there,
		# otherwise delete the attribute
		if ( $attrs->{'label'} ) {
			$attrs->{'label'} = encode_entities($attrs->{'label'});
		}
		else {
			delete $attrs->{'label'};
		}
	
		# process the id attribute: if it's not there, autogenerate it, unless
		# the object is explicitly not identifiable, in which case delete the
		# attribute
        if ( not $attrs->{'id'} ) {
            $attrs->{'id'} = $self->get_xml_id;
        }
        if ( defined $self->is_identifiable and not $self->is_identifiable ) {
            delete $attrs->{'id'};
        }
        
        # process the about attribute
        if ( not @{ $self->get_meta } and $attrs->{'about'} ) {
        	delete $attrs->{'about'};
        }
	
		# set the otus attribute
        if ( $self->can('get_taxa') ) {
            if ( my $taxa = $self->get_taxa ) {
                $attrs->{'otus'} = $taxa->get_xml_id