File Coverage

blib/lib/Bio/Phylo/NeXML/Writable.pm
Criterion Covered Total %
statement 201 322 62.4
branch 54 120 45.0
condition 12 34 35.2
subroutine 42 53 79.2
pod 35 35 100.0
total 344 564 60.9


line stmt bran cond sub pod time code
1             package Bio::Phylo::NeXML::Writable;
2 51     51   324 use strict;
  51         100  
  51         1273  
3 51     51   225 use base 'Bio::Phylo';
  51         110  
  51         8171  
4 51     51   4902 use Bio::Phylo::IO 'unparse';
  51         120  
  51         2313  
5 51     51   4974 use Bio::Phylo::Factory;
  51         110  
  51         294  
6 51     51   13748 use Bio::Phylo::NeXML::DOM;
  51         119  
  51         368  
7 51     51   14008 use Bio::Phylo::NeXML::Entities '/entities/';
  51         197  
  51         7270  
8 51     51   346 use Bio::Phylo::Util::Exceptions 'throw';
  51         97  
  51         2025  
9 51     51   322 use Bio::Phylo::Util::CONSTANT qw'/looks_like/ :namespaces :objecttypes';
  51         94  
  51         24488  
10             {
11             my $logger = __PACKAGE__->get_logger;
12             my $fac = Bio::Phylo::Factory->new;
13             my $DICTIONARY_CONSTANT = _DICTIONARY_;
14             my $META_CONSTANT = _META_;
15             my %namespaces = (
16             'nex' => _NS_NEXML_,
17             'xml' => _NS_XML_,
18             'xsi' => _NS_XSI_,
19             'rdf' => _NS_RDF_,
20             'xsd' => _NS_XSD_,
21             'map' => _NS_PHYLOMAP_,
22             );
23             my @fields =
24             \( my ( %tag, %id, %attributes, %identifiable, %suppress_ns, %meta, %url ) );
25              
26             =head1 NAME
27              
28             Bio::Phylo::NeXML::Writable - Superclass for objects that serialize to NeXML
29              
30             =head1 SYNOPSIS
31              
32             # no direct usage
33              
34             =head1 DESCRIPTION
35              
36             This is the superclass for all objects that can be serialized to NeXML
37             (L<http://www.nexml.org>).
38              
39             =head1 METHODS
40              
41             =head2 MUTATORS
42              
43             =over
44              
45             =item set_namespaces()
46              
47             Type : Mutator
48             Title : set_namespaces
49             Usage : $obj->set_namespaces( 'dwc' => 'http://www.namespaceTBD.org/darwin2' );
50             Function: Adds one or more prefix/namespace pairs
51             Returns : $self
52             Args : One or more prefix/namespace pairs, as even-sized list,
53             or as a hash reference, i.e.:
54             $obj->set_namespaces( 'dwc' => 'http://www.namespaceTBD.org/darwin2' );
55             or
56             $obj->set_namespaces( { 'dwc' => 'http://www.namespaceTBD.org/darwin2' } );
57             Notes : This is a global for the XMLWritable class, so that in a recursive
58             to_xml call the outermost element contains the namespace definitions.
59             This method can also be called as a static class method, i.e.
60             Bio::Phylo::NeXML::Writable->set_namespaces(
61             'dwc' => 'http://www.namespaceTBD.org/darwin2');
62              
63             =cut
64              
65             sub set_namespaces {
66 243     243 1 329 my $self = shift;
67 243 100 66     821 if ( scalar(@_) == 1 and ref( $_[0] ) eq 'HASH' ) {
    50          
68 25         32 my $hash = shift;
69 25         32 for my $key ( keys %{$hash} ) {
  25         66  
70 25         68 $namespaces{$key} = $hash->{$key};
71             }
72             }
73             elsif ( my %hash = looks_like_hash @_ ) {
74 218         550 for my $key ( keys %hash ) {
75 218         716 $namespaces{$key} = $hash{$key};
76             }
77             }
78             }
79              
80             =item set_suppress_ns()
81              
82             Type : Mutator
83             Title : set_suppress_ns
84             Usage : $obj->set_suppress_ns();
85             Function: Tell this object not to write namespace attributes
86             Returns :
87             Args : none
88              
89             =cut
90              
91             sub set_suppress_ns : Clonable {
92 110     110 1 162 my $self = shift;
93 110         214 my $id = $self->get_id;
94 110         300 $suppress_ns{$id} = 1;
95 51     51   350 }
  51         96  
  51         337  
96              
97             =item clear_suppress_ns()
98              
99             Type : Mutator
100             Title : clear_suppress_ns
101             Usage : $obj->clear_suppress_ns();
102             Function: Tell this object to write namespace attributes
103             Returns :
104             Args : none
105              
106             =cut
107              
108             sub clear_suppress_ns {
109 0     0 1 0 my $self = shift;
110 0         0 my $id = $self->get_id;
111 0         0 $suppress_ns{$id} = 0;
112             }
113              
114             =item add_meta()
115              
116             Type : Mutator
117             Title : add_meta
118             Usage : $obj->add_meta($meta);
119             Function: Adds a metadata attachment to the object
120             Returns : $self
121             Args : A Bio::Phylo::NeXML::Meta object
122              
123             =cut
124              
125             sub add_meta {
126 1443     1443 1 2233 my ( $self, $meta_obj ) = @_;
127 1443 50       2958 if ( looks_like_object $meta_obj, $META_CONSTANT ) {
128 1443         2757 my $id = $self->get_id;
129 1443 100       3017 if ( not $meta{$id} ) {
130 321         637 $meta{$id} = [];
131             }
132 1443         2087 push @{ $meta{$id} }, $meta_obj;
  1443         2852  
133 1443 50       2749 if ( $self->is_identifiable ) {
134 0         0 $self->set_attributes( 'about' => '#' . $self->get_xml_id );
135             }
136             }
137 1443         2631 return $self;
138             }
139              
140             =item remove_all_meta()
141              
142             Type : Mutator
143             Title : remove_all_meta
144             Usage : $obj->remove_all_meta();
145             Function: Removes all metadata attachments from the object
146             Returns : $self
147             Args : None
148              
149             =cut
150              
151             sub remove_all_meta {
152 0     0 1 0 my $self = shift;
153 0         0 $meta{$self->get_id} = [];
154 0         0 return $self;
155             }
156              
157             =item remove_meta()
158              
159             Type : Mutator
160             Title : remove_meta
161             Usage : $obj->remove_meta($meta);
162             Function: Removes a metadata attachment from the object
163             Returns : $self
164             Args : Bio::Phylo::NeXML::Meta
165              
166             =cut
167              
168             sub remove_meta {
169 0     0 1 0 my ( $self, $meta ) = @_;
170 0         0 my $id = $self->get_id;
171 0         0 my $meta_id = $meta->get_id;
172 0 0       0 if ( $meta{$id} ) {
173 0         0 DICT: for my $i ( 0 .. $#{ $meta{$id} } ) {
  0         0  
174 0 0       0 if ( $meta{$id}->[$i]->get_id == $meta_id ) {
175 0         0 splice @{ $meta{$id} }, $i, 1;
  0         0  
176 0         0 last DICT;
177             }
178             }
179             }
180 0 0 0     0 if ( not $meta{$id} or not @{ $meta{$id} } ) {
  0         0  
181 0         0 $self->unset_attribute('about');
182             }
183 0         0 return $self;
184             }
185              
186             =item set_meta_object()
187              
188             Type : Mutator
189             Title : set_meta_object
190             Usage : $obj->set_meta_object($predicate => $object);
191             Function: Attaches a $predicate => $object pair to the invocant
192             Returns : $self
193             Args : $predicate => (a valid curie of a known namespace)
194             $object => (an object value)
195              
196             =cut
197              
198             sub set_meta_object {
199 800     800 1 1582 my ( $self, $predicate, $object ) = @_;
200 800 100       997 if ( my ($meta) = @{ $self->get_meta($predicate) } ) {
  800         1501  
201 71         159 $meta->set_triple( $predicate => $object );
202             }
203             else {
204 729         4204 $self->add_meta( $fac->create_meta( '-triple' => { $predicate => $object } ) );
205             }
206 800         2736 return $self;
207             }
208              
209             =item set_meta()
210              
211             Type : Mutator
212             Title : set_meta
213             Usage : $obj->set_meta([ $m1, $m2, $m3 ]);
214             Function: Assigns all metadata objects
215             Returns : $self
216             Args : An array ref of metadata objects
217              
218             =cut
219            
220             sub set_meta : Clonable {
221 109     109 1 184 my ( $self, $meta ) = @_;
222 109 50 33     256 if ( $meta && @{ $meta } ) {
  109         275  
223 0         0 $meta{$self->get_id} = $meta;
224 0         0 $self->set_attributes( 'about' => '#' . $self->get_xml_id );
225             }
226             else {
227 109         379 $meta{$self->get_id} = [];
228 109         319 $self->unset_attribute( 'about' );
229             }
230 109         242 return $self;
231 51     51   28681 }
  51         108  
  51         202  
232            
233             =item set_identifiable()
234              
235             By default, all XMLWritable objects are identifiable when serialized,
236             i.e. they have a unique id attribute. However, in some cases a serialized
237             object may not have an id attribute (governed by the nexml schema). For
238             such objects, id generation can be explicitly disabled using this method.
239             Typically, this is done internally - you will probably never use this method.
240              
241             Type : Mutator
242             Title : set_identifiable
243             Usage : $obj->set_identifiable(0);
244             Function: Enables/disables id generation
245             Returns : $self
246             Args : BOOLEAN
247              
248             =cut
249              
250             sub set_identifiable : Clonable {
251 110     110 1 160 my $self = shift;
252 110         249 $identifiable{ $self->get_id } = shift;
253 110         272 return $self;
254 51     51   8595 }
  51         104  
  51         177  
255              
256             =item set_tag()
257              
258             This method is usually only used internally, to define or alter the
259             name of the tag into which the object is serialized. For example,
260             for a Bio::Phylo::Forest::Node object, this method would be called
261             with the 'node' argument, so that the object is serialized into an
262             xml element structure called <node/>
263              
264             Type : Mutator
265             Title : set_tag
266             Usage : $obj->set_tag('node');
267             Function: Sets the tag name
268             Returns : $self
269             Args : A tag name (must be a valid xml element name)
270              
271             =cut
272              
273             sub set_tag : Clonable {
274 110     110 1 192 my ( $self, $tag ) = @_;
275              
276             # _ is ok; see http://www.w3.org/TR/2004/REC-xml-20040204/#NT-NameChar
277 110 50       857 if ( $tag =~ qr/^[a-zA-Z]+\:?[a-zA-Z_]*$/ ) {
278 110         298 $tag{ $self->get_id } = $tag;
279 110         361 return $self;
280             }
281             else {
282 0         0 throw 'BadString' => "'$tag' is not valid for xml";
283             }
284 51     51   11953 }
  51         121  
  51         191  
285              
286             =item set_name()
287              
288             Sets invocant name.
289              
290             Type : Mutator
291             Title : set_name
292             Usage : $obj->set_name($name);
293             Function: Assigns an object's name.
294             Returns : Modified object.
295             Args : Argument must be a string. Ensure that this string is safe to use for
296             whatever output format you want to use (this differs between xml and
297             nexus, for example).
298              
299             =cut
300              
301             sub set_name : Clonable {
302 11177     11177 1 19602 my ( $self, $name ) = @_;
303 11177 100       19886 if ( defined $name ) {
304 11073         23027 return $self->set_attributes( 'label' => $name );
305             }
306             else {
307 104         206 return $self;
308             }
309 51     51   9101 }
  51         115  
  51         181  
310              
311             =item set_attributes()
312              
313             Assigns attributes for the element.
314              
315             Type : Mutator
316             Title : set_attributes
317             Usage : $obj->set_attributes( 'foo' => 'bar' )
318             Function: Sets the xml attributes for the object;
319             Returns : $self
320             Args : key/value pairs or a hash ref
321              
322             =cut
323              
324             sub set_attributes {
325 15558     15558 1 21520 my $self = shift;
326 15558         28901 my $id = $self->get_id;
327 15558         21346 my %attrs;
328 15558 50 33     45492 if ( scalar @_ == 1 and ref $_[0] eq 'HASH' ) {
    50          
329 0         0 %attrs = %{ $_[0] };
  0         0  
330             }
331             elsif ( scalar @_ % 2 == 0 ) {
332 15558         38096 %attrs = @_;
333             }
334             else {
335 0         0 throw 'OddHash' => 'Arguments are not even key/value pairs';
336             }
337 15558   100     48759 my $hash = $attributes{$id} || {};
338 15558         47890 my $fully_qualified_attribute_regex = qr/^(.+?):(.+)/;
339 15558         35601 for my $key ( keys %attrs ) {
340 17053 100       67616 if ( $key =~ $fully_qualified_attribute_regex ) {
341 1496         3590 my ( $prefix, $attribute ) = ( $1, $2 );
342 1496 50 33     5007 if ( $prefix ne 'xmlns' and not exists $namespaces{$prefix} ) {
343 0         0 $logger->warn("Unbound attribute prefix '${prefix}'");
344             }
345             }
346 17053         40443 $hash->{$key} = $attrs{$key};
347             }
348 15558         28415 $attributes{$id} = $hash;
349 15558         45997 return $self;
350             }
351              
352             =item set_xml_id()
353              
354             This method is usually only used internally, to store the xml id
355             of an object as it is parsed out of a nexml file - this is for
356             the purpose of round-tripping nexml info sets.
357              
358             Type : Mutator
359             Title : set_xml_id
360             Usage : $obj->set_xml_id('node345');
361             Function: Sets the xml id
362             Returns : $self
363             Args : An xml id (must be a valid xml NCName)
364              
365             =cut
366              
367             sub set_xml_id {
368 1     1 1 3 my ( $self, $id ) = @_;
369 1 50       9 if ( $id =~ qr/^[a-zA-Z][a-zA-Z0-9\-_\.]*$/ ) {
370 1         5 $id{ $self->get_id } = $id;
371 1         5 $self->set_attributes( 'id' => $id, 'about' => "#$id" );
372 1         5 return $self;
373             }
374             else {
375 0         0 throw 'BadString' => "'$id' is not a valid xml NCName for $self";
376             }
377             }
378              
379             =item set_base_uri()
380              
381             This utility method can be used to set the xml:base attribute, i.e. to specify
382             a location for the object's XML serialization that potentially differs from
383             the physical location of the containing document.
384              
385             Type : Mutator
386             Title : set_base_uri
387             Usage : $obj->set_base_uri('http://example.org');
388             Function: Sets the xml:base attribute
389             Returns : $self
390             Args : A URI string
391              
392             =cut
393              
394             sub set_base_uri : Clonable {
395 110     110 1 180 my ( $self, $uri ) = @_;
396 110 100       198 if ( $uri ) {
397 2         8 $self->set_attributes( 'xml:base' => $uri );
398             }
399 110         206 return $self;
400 51     51   23693 }
  51         103  
  51         205  
401              
402             =item set_link()
403              
404             This sets a clickable link, i.e. a url, for the object. This has no relation to
405             the xml:base attribute, it is solely intended for serializations that
406             allow clickable links, such as SVG or RSS.
407              
408             Type : Mutator
409             Title : set_link
410             Usage : $node->set_link($url);
411             Function: Sets clickable link
412             Returns : $self
413             Args : url
414              
415             =cut
416              
417             sub set_link : Clonable {
418 117     117 1 211 my ( $self, $url ) = @_;
419 117 100       223 if ( $url ) {
420 9         19 my $id = $self->get_id;
421 9         19 $url{$id} = $url;
422             }
423 117         229 return $self;
424 51     51   8952 }
  51         151  
  51         185  
425              
426             =item unset_attribute()
427              
428             Removes specified attribute
429              
430             Type : Mutator
431             Title : unset_attribute
432             Usage : $obj->unset_attribute( 'foo' )
433             Function: Removes the specified xml attribute for the object
434             Returns : $self
435             Args : an attribute name
436              
437             =cut
438              
439             sub unset_attribute {
440 109     109 1 170 my $self = shift;
441 109         199 my $attrs = $attributes{ $self->get_id };
442 109 50 33     360 if ( $attrs and looks_like_instance( $attrs, 'HASH' ) ) {
443 109         305 delete $attrs->{$_} for @_;
444             }
445 109         194 return $self;
446             }
447              
448             =back
449              
450             =head2 ACCESSORS
451              
452             =over
453              
454             =item get_namespaces()
455              
456             Type : Accessor
457             Title : get_namespaces
458             Usage : my %ns = %{ $obj->get_namespaces };
459             Function: Retrieves the known namespaces
460             Returns : A hash of prefix/namespace key/value pairs, or
461             a single namespace if a single, optional
462             prefix was provided as argument
463             Args : Optional - a namespace prefix
464              
465             =cut
466              
467             sub get_namespaces {
468 17790     17790 1 25681 my ( $self, $prefix ) = @_;
469 17790 100       26896 if ($prefix) {
470 2776         7622 return $namespaces{$prefix};
471             }
472             else {
473 15014         54514 my %tmp_namespaces = %namespaces;
474 15014         32844 return \%tmp_namespaces;
475             }
476             }
477              
478             =item get_prefix_for_namespace()
479              
480             Type : Accessor
481             Title : get_prefix_for_namespace
482             Usage : my $prefix = $obj->get_prefix_for_namespace('http://example.org/')
483             Function: Retrieves the prefix for the argument namespace
484             Returns : A prefix string
485             Args : A namespace URI
486              
487             =cut
488            
489             sub get_prefix_for_namespace {
490 0     0 1 0 my ( $self, $ns_uri ) = @_;
491            
492             # check argument
493 0 0       0 if ( not $ns_uri ) {
494 0         0 throw 'BadArgs' => "Need namespaces URI argument";
495             }
496            
497             # iterate over namespace/prefix pairs
498 0         0 my $namespaces = $self->get_namespaces;
499 0         0 for my $prefix ( keys %{ $namespaces } ) {
  0         0  
500 0 0       0 if ( $namespaces->{$prefix} eq $ns_uri ) {
501 0         0 return $prefix;
502             }
503             }
504            
505             # warn user
506 0         0 $logger->warn("No prefix for namespace $ns_uri");
507 0         0 return undef;
508             }
509              
510             =item get_meta()
511              
512             Retrieves the metadata for the element.
513              
514             Type : Accessor
515             Title : get_meta
516             Usage : my @meta = @{ $obj->get_meta };
517             Function: Retrieves the metadata for the element.
518             Returns : An array ref of Bio::Phylo::NeXML::Meta objects
519             Args : Optional: a list of CURIE predicates, in which case
520             the returned objects will be those matching these
521             predicates
522              
523             =cut
524              
525             sub get_meta {
526 62077     62077 1 72899 my $self = shift;
527 62077   100     102415 my $metas = $meta{ $self->get_id } || [];
528 62077 100       122818 if ( @_ ) {
529 46684         63869 my %predicates = map { $_ => 1 } @_;
  46684         111340  
530 46684         61125 my @matches = grep { $predicates{$_->get_predicate} } @{ $metas };
  12450         28739  
  46684         67938  
531 46684         105431 return \@matches;
532             }
533 15393         44072 return $metas;
534             }
535              
536             =item get_meta_object()
537              
538             Retrieves the metadata annotation object for the provided predicate
539              
540             Type : Accessor
541             Title : get_meta_object
542             Usage : my $title = $obj->get_meta_object('dc:title');
543             Function: Retrieves the metadata annotation value for the object.
544             Returns : An annotation value, i.e. the object of a triple
545             Args : Required: a CURIE predicate for which the annotation
546             value is returned
547             Note : This method returns the object for the first annotation
548             with the provided predicate. Keep this in mind when dealing
549             with an object that has multiple annotations with the same
550             predicate.
551              
552             =cut
553            
554             sub get_meta_object {
555 45884     45884 1 84611 my ( $self, $predicate ) = @_;
556 45884 50       71830 throw 'BadArgs' => "No CURIE provided" unless $predicate;
557 45884         50750 my ( $meta ) = @{ $self->get_meta($predicate) };
  45884         71219  
558 45884 100       73664 if ( $meta ) {
559 432         1002 return $meta->get_object;
560             }
561             else {
562 45452         101228 return undef;
563             }
564             }
565              
566             =item get_tag()
567              
568             Retrieves tag name for the element.
569              
570             Type : Accessor
571             Title : get_tag
572             Usage : my $tag = $obj->get_tag;
573             Function: Gets the xml tag name for the object;
574             Returns : A tag name
575             Args : None.
576              
577             =cut
578              
579             sub get_tag {
580 1535     1535 1 1915 my $self = shift;
581 1535 100       2572 if ( my $tagstring = $tag{ $self->get_id } ) {
    50          
582 4         18 return $tagstring;
583             }
584             elsif ( looks_like_implementor $self, '_tag' ) {
585 1531         2895 return $self->_tag;
586             }
587             else {
588 0         0 return '';
589             }
590             }
591              
592             =item get_name()
593              
594             Gets invocant's name.
595              
596             Type : Accessor
597             Title : get_name
598             Usage : my $name = $obj->get_name;
599             Function: Returns the object's name.
600             Returns : A string
601             Args : None
602              
603             =cut
604              
605             sub get_name {
606 22618     22618 1 101491 my $self = shift;
607 22618         35589 my $id = $self->get_id;
608 22618 100       47323 if ( !$attributes{$id} ) {
609 213         485 $attributes{$id} = {};
610             }
611 22618 100       39090 if ( defined $attributes{$id}->{'label'} ) {
612 22121         61492 return $attributes{$id}->{'label'};
613             }
614             else {
615 497         1353 return '';
616             }
617             }
618              
619             =item get_xml_tag()
620              
621             Retrieves tag string
622              
623             Type : Accessor
624             Title : get_xml_tag
625             Usage : my $str = $obj->get_xml_tag;
626             Function: Gets the xml tag for the object;
627             Returns : A tag, i.e. pointy brackets
628             Args : Optional: a true value, to close an empty tag
629              
630             =cut
631              
632             sub get_xml_tag {
633 0     0 1 0 my ( $self, $closeme ) = @_;
634 0         0 my %attrs = %{ $self->get_attributes };
  0         0  
635 0         0 my $tag = $self->get_tag;
636 0         0 my $xml = '<' . $tag;
637 0         0 for my $key ( keys %attrs ) {
638 0         0 $xml .= ' ' . $key . '="' . encode_entities($attrs{$key}) . '"';
639             }
640 0         0 my $has_contents = 0;
641 0         0 my $meta = $self->get_meta;
642 0 0       0 if ( @{$meta} ) {
  0         0  
643 0         0 $xml .= '>'; # if not @{ $dictionaries };
644 0         0 $xml .= $_->to_xml for @{$meta};
  0         0  
645 0         0 $has_contents++;
646             }
647 0 0       0 if ($has_contents) {
648 0 0       0 $xml .= "</$tag>" if $closeme;
649             }
650             else {
651 0 0       0 $xml .= $closeme ? '/>' : '>';
652             }
653 0         0 return $xml;
654             }
655              
656             =item get_attributes()
657              
658             Retrieves attributes for the element.
659              
660             Type : Accessor
661             Title : get_attributes
662             Usage : my %attrs = %{ $obj->get_attributes };
663             Function: Gets the xml attributes for the object;
664             Returns : A hash reference
665             Args : None.
666             Comments: throws ObjectMismatch if no linked taxa object
667             can be found
668              
669             =cut
670              
671             my $add_namespaces_to_attributes = sub {
672             my ( $self, $attrs ) = @_;
673             my $i = 0;
674             my $inside_to_xml_recursion = 0;
675             CHECK_RECURSE: while ( my @frame = caller($i) ) {
676             if ( $frame[3] =~ m/::to_xml$/ ) {
677             $inside_to_xml_recursion++;
678             last CHECK_RECURSE if $inside_to_xml_recursion > 1;
679             }
680             $i++;
681             }
682             if ( $inside_to_xml_recursion <= 1 ) {
683             my $tmp_namespaces = get_namespaces();
684             for my $ns ( keys %{$tmp_namespaces} ) {
685             $attrs->{ 'xmlns:' . $ns } = $tmp_namespaces->{$ns};
686             }
687             }
688             return $attrs;
689             };
690             my $flatten_attributes = sub {
691             my $self = shift;
692             my $tempattrs = $attributes{ $self->get_id };
693             my $attrs;
694             if ($tempattrs) {
695             my %deref = %{$tempattrs};
696             $attrs = \%deref;
697             }
698             else {
699             $attrs = {};
700             }
701             return $attrs;
702             };
703              
704             sub get_attributes {
705 15014     15014 1 23102 my ( $self, $arg ) = @_;
706 15014         22261 my $attrs = $flatten_attributes->($self);
707            
708             # process the 'label' attribute: encode if there's anything there,
709             # otherwise delete the attribute
710 15014 50       24451 if ( $attrs->{'label'} ) {
711 0         0 $attrs->{'label'} = encode_entities($attrs->{'label'});
712             }
713             else {
714 15014         18374 delete $attrs->{'label'};
715             }
716            
717             # process the id attribute: if it's not there, autogenerate it, unless
718             # the object is explicitly not identifiable, in which case delete the
719             # attribute
720 15014 50       23965 if ( not $attrs->{'id'} ) {
721 15014         23424 $attrs->{'id'} = $self->get_xml_id;
722             }
723 15014 50 33     25302 if ( defined $self->is_identifiable and not $self->is_identifiable ) {
724 0         0 delete $attrs->{'id'};
725             }
726            
727             # process the about attribute
728 15014 50 33     19145 if ( not @{ $self->get_meta } and $attrs->{'about'} ) {
  15014         23665  
729 0         0 delete $attrs->{'about'};
730             }
731            
732             # set the otus attribute
733 15014 50       37782 if ( $self->can('get_taxa') ) {
734 0 0       0 if ( my $taxa = $self->get_taxa ) {
735 0 0       0 $attrs->{'otus'} = $taxa->get_xml_id
736             if looks_like_instance( $taxa, 'Bio::Phylo' );
737             }
738             else {
739 0         0 $logger->error("$self can link to a taxa element, but doesn't");
740             }
741             }
742            
743             # set the otu attribute
744 15014 50       28992 if ( $self->can('get_taxon') ) {
745 0 0       0 if ( my $taxon = $self->get_taxon ) {
746 0         0 $attrs->{'otu'} = $taxon->get_xml_id;
747             }
748             else {
749 0         0 $logger->info("No linked taxon found");
750 0         0 delete $attrs->{'otu'};
751             }
752             }
753            
754             # add the namespace attributes unless explicitly supressed
755 15014 50       23048 if ( not $self->is_ns_suppressed ) {
756 15014         22402 $attrs = $add_namespaces_to_attributes->( $self, $attrs )
757             }
758            
759             # now either return the whole hash or just one value if a
760             # key/attribute name was provided
761 15014 50       57740 return $arg ? $attrs->{$arg} : $attrs;
762             }
763              
764             =item get_xml_id()
765              
766             Retrieves xml id for the element.
767              
768             Type : Accessor
769             Title : get_xml_id
770             Usage : my $id = $obj->get_xml_id;
771             Function: Gets the xml id for the object;
772             Returns : An xml id
773             Args : None.
774              
775             =cut
776              
777             sub get_xml_id {
778 15016     15016 1 18018 my $self = shift;
779 15016 100       24899 if ( my $id = $id{ $self->get_id } ) {
780 13592         28654 return $id;
781             }
782             else {
783 1424         2507 my $xml_id = $self->get_tag;
784 1424         2605 my $obj_id = $self->get_id;
785 1424         9583 $xml_id =~ s/^(.).+(.)$/$1$2$obj_id/;
786 1424         5316 return $id{$obj_id} = $xml_id;
787             }
788             }
789              
790             =item get_base_uri()
791              
792             This utility method can be used to get the xml:base attribute, which specifies
793             a location for the object's XML serialization that potentially differs from
794             the physical location of the containing document.
795              
796             If no xml:base attribute has been defined on the focal object, this method
797             moves on, recursively, to containing objects (e.g. from node to tree to forest)
798             until such time that a base URI has been found.
799              
800             Type : Mutator
801             Title : get_base_uri
802             Usage : my $base = $obj->get_base_uri;
803             Function: Gets the xml:base attribute
804             Returns : A URI string
805             Args : None
806              
807             =cut
808              
809             sub get_base_uri {
810 111     111 1 176 my $self = shift;
811 111         244 while ( $self ) {
812 154         309 my $attrs = $flatten_attributes->($self);
813 154 100       373 if ( my $base = $attrs->{'xml:base'} ) {
814 3         20 $logger->info("Found xml:base attribute on $self: $base");
815 3         19 return $base;
816             }
817            
818 151         687 $logger->info("Traversing up to $self to locate xml:base");
819             # we do this because node objects are contained inside their
820             # parents, recursively, but node nexml elements aren't. it
821             # would be inefficient to traverse all the parent nodes when,
822             # logically, none of them could have an xml:base attribute
823             # that could apply to the original invocant. in fact, doing
824             # so could yield spurious results.
825 151 100       428 if ( $self->_type == _NODE_ ) {
826 2         8 $self = $self->get_tree;
827             }
828             else {
829 149         374 $self = $self->_get_container;
830             }
831             }
832 108         300 $logger->info("No xml:base attribute was found anywhere");
833 108         191 return undef;
834             }
835              
836             =item get_link()
837              
838             This returns a clickable link for the object. This has no relation to
839             the xml:base attribute, it is solely intended for serializations that
840             allow clickable links, such as SVG or RSS.
841              
842             Type : Accessor
843             Title : get_link
844             Usage : my $link = $obj->get_link();
845             Function: Returns a clickable link
846             Returns : url
847             Args : NONE
848              
849             =cut
850              
851 150     150 1 315 sub get_link { $url{ shift->get_id } }
852              
853             =item get_dom_elt()
854              
855             Type : Serializer
856             Title : get_dom_elt
857             Usage : $obj->get_dom_elt
858             Function: Generates a DOM element from the invocant
859             Returns : a DOM element object (default XML::Twig)
860             Args : DOM factory object
861              
862             =cut
863              
864             sub get_dom_elt {
865 0     0 1 0 my ( $self, $dom ) = @_;
866 0   0     0 $dom ||= Bio::Phylo::NeXML::DOM->get_dom;
867 0 0       0 unless ( looks_like_object $dom, _DOMCREATOR_ ) {
868 0         0 throw 'BadArgs' => 'DOM factory object not provided';
869             }
870 0         0 my $elt = $dom->create_element( '-tag' => $self->get_tag );
871 0         0 my %attrs = %{ $self->get_attributes };
  0         0  
872 0         0 for my $key ( keys %attrs ) {
873 0         0 $elt->set_attributes( $key => $attrs{$key} );
874             }
875 0         0 for my $meta ( @{ $self->get_meta } ) {
  0         0  
876 0         0 $elt->set_child( $meta->to_dom($dom) );
877             }
878              
879             #my $dictionaries = $self->get_dictionaries;
880             #if ( @{ $dictionaries } ) {
881             # $elt->set_child( $_->to_dom($dom) ) for @{ $dictionaries };
882             #}
883 0 0       0 if ( looks_like_implementor $self, 'get_sets' ) {
884 0         0 my $sets = $self->get_sets;
885 0         0 $elt->set_child( $_->to_dom($dom) ) for @{$sets};
  0         0  
886             }
887 0         0 return $elt;
888             }
889              
890             =back
891              
892             =head2 TESTS
893              
894             =over
895              
896             =item is_identifiable()
897              
898             By default, all XMLWritable objects are identifiable when serialized,
899             i.e. they have a unique id attribute. However, in some cases a serialized
900             object may not have an id attribute (governed by the nexml schema). This
901             method indicates whether that is the case.
902              
903             Type : Test
904             Title : is_identifiable
905             Usage : if ( $obj->is_identifiable ) { ... }
906             Function: Indicates whether IDs are generated
907             Returns : BOOLEAN
908             Args : NONE
909              
910             =cut
911              
912             sub is_identifiable {
913 16568     16568 1 20441 my $self = shift;
914 16568         26548 return $identifiable{ $self->get_id };
915             }
916             *get_identifiable = \&is_identifiable;
917              
918             =item is_ns_suppressed()
919              
920             Type : Test
921             Title : is_ns_suppressed
922             Usage : if ( $obj->is_ns_suppressed ) { ... }
923             Function: Indicates whether namespace attributes should not
924             be written on XML serialization
925             Returns : BOOLEAN
926             Args : NONE
927              
928             =cut
929              
930             sub is_ns_suppressed {
931 15125     15125 1 25757 return $suppress_ns{ shift->get_id };
932             }
933             *get_suppress_ns = \&is_ns_suppressed;
934            
935             =item is_equal()
936              
937             Tests whether the invocant and the argument are the same. Normally this is done
938             by comparing object identifiers, but if the argument is not an object but a string
939             then the string is taken to be a name with which to compare, e.g.
940             $taxon->is_equal('Homo sapiens')
941              
942             Type : Test
943             Title : is_equal
944             Usage : if ( $obj->is_equal($other) ) { ... }
945             Function: Tests whether the invocant and the argument are the same
946             Returns : BOOLEAN
947             Args : Object to compare with, or a string representing a
948             name to compare with the invocant's name
949              
950             =cut
951            
952             sub is_equal {
953 3489     3489 1 4733 my ($self,$other) = @_;
954 3489 50       5402 return ref $other ? $self->SUPER::is_equal($other) : $self->get_name eq $other;
955             }
956              
957             =back
958              
959             =head2 SERIALIZERS
960              
961             =over
962              
963             =item to_xml()
964              
965             Serializes invocant to XML.
966              
967             Type : XML serializer
968             Title : to_xml
969             Usage : my $xml = $obj->to_xml;
970             Function: Serializes $obj to xml
971             Returns : An xml string
972             Args : None
973              
974             =cut
975              
976             sub to_xml {
977 0     0 1   my $self = shift;
978 0           my $xml = '';
979 0 0         if ( $self->can('get_entities') ) {
980 0           for my $ent ( @{ $self->get_entities } ) {
  0            
981 0 0         if ( looks_like_implementor $ent, 'to_xml' ) {
982 0           $xml .= "\n" . $ent->to_xml;
983             }
984             }
985 0           $xml .= $self->sets_to_xml;
986             }
987 0 0         if ($xml) {
988 0           $xml = $self->get_xml_tag . $xml . sprintf('</%s>', $self->get_tag);
989             }
990             else {
991 0           $xml = $self->get_xml_tag(1);
992             }
993 0           return $xml;
994             }
995              
996             =item to_dom()
997              
998             Type : Serializer
999             Title : to_dom
1000             Usage : $obj->to_dom
1001             Function: Generates a DOM subtree from the invocant and
1002             its contained objects
1003             Returns : a DOM element object (default: XML::Twig flavor)
1004             Args : DOM factory object
1005             Note : This is the generic function. It is redefined in the
1006             classes below.
1007              
1008             =cut
1009              
1010             sub to_dom {
1011 0     0 1   my ( $self, $dom ) = @_;
1012 0   0       $dom ||= Bio::Phylo::NeXML::DOM->get_dom;
1013 0 0         if ( looks_like_object $dom, _DOMCREATOR_ ) {
1014 0           my $elt = $self->get_dom_elt($dom);
1015 0 0         if ( $self->can('get_entities') ) {
1016 0           for my $ent ( @{ $self->get_entities } ) {
  0            
1017 0 0         if ( looks_like_implementor $ent, 'to_dom' ) {
1018 0           $elt->set_child( $ent->to_dom($dom) );
1019             }
1020             }
1021             }
1022 0           return $elt;
1023             }
1024             else {
1025 0           throw 'BadArgs' => 'DOM factory object not provided';
1026             }
1027             }
1028            
1029             =item to_json()
1030              
1031             Serializes object to JSON string
1032              
1033             Type : Serializer
1034             Title : to_json()
1035             Usage : print $obj->to_json();
1036             Function: Serializes object to JSON string
1037             Returns : String
1038             Args : None
1039             Comments:
1040              
1041             =cut
1042              
1043             sub to_json {
1044 0     0 1   looks_like_class('Bio::Phylo::NeXML::XML2JSON')->new->convert( shift->to_xml );
1045             }
1046              
1047             sub _json_data {
1048 0     0     my $self = shift;
1049 0           my %meta = map { $_->get_predicate => $_->get_object } @{ $self->get_meta };
  0            
  0            
1050 0           my %result = %{ $self->SUPER::_json_data };
  0            
1051 0           $result{$_} = $meta{$_} for keys %meta;
1052 0 0         $result{'name'} = $self->get_name if $self->get_name;
1053 0 0         $result{'link'} = $self->get_link if $self->get_link;
1054 0           return \%result;
1055             }
1056              
1057             =item to_cdao()
1058              
1059             Serializes object to CDAO RDF/XML string
1060              
1061             Type : Serializer
1062             Title : to_cdao()
1063             Usage : print $obj->to_cdao();
1064             Function: Serializes object to CDAO RDF/XML string
1065             Returns : String
1066             Args : None
1067             Comments:
1068              
1069             =cut
1070            
1071             sub to_cdao {
1072 0     0 1   return unparse(
1073             '-phylo' => shift,
1074             '-format' => 'cdao',
1075             );
1076             }
1077              
1078             sub _cleanup : Destructor {
1079 28406     28406   34646 my $self = shift;
1080            
1081             # this deserves an explanation. the issue is as follows: for the package
1082             # bio-phylo-megatree we have node objects that are persisted in a database
1083             # and accessed through an object-relational mapping provided by DBIx::Class.
1084             # these node objects are created and destroyed on the fly as a set of node
1085             # records (i.e. a tree) is traversed. this is the whole point of the package,
1086             # because it means large trees don't ever have to be kept in memory. however,
1087             # as a consequence, every time one of those ORM-backed nodes goes out of scope,
1088             # this destructor is called and all the @fields are cleaned up again. this
1089             # precludes computation and caching of node coordinates (or any other semantic
1090             # annotation) on such ORM-backed objects. the terrible, terrible fix for now is
1091             # to just assume that i) these annotations need to stay alive ii) we're not going
1092             # to have ID clashes (!!!!!), so iii) we just don't clean up after ourselves.
1093             # as a note to my future self: it would be a good idea to have a triple store-like
1094             # table to store the annotations, so they are persisted in the same way as the
1095             # node objects, bypassing this malarkey.
1096 28406 50       77793 if ( not $self->isa('DBIx::Class::Core') ) {
1097 28406         47224 my $id = $self->get_id;
1098 28406         42014 for my $field (@fields) {
1099 198842         266612 delete $field->{$id};
1100             }
1101             }
1102 51     51   95855 }
  51         134  
  51         233  
1103              
1104             =back
1105              
1106             =cut
1107              
1108             # podinherit_insert_token
1109              
1110             =head1 SEE ALSO
1111              
1112             There is a mailing list at L<https://groups.google.com/forum/#!forum/bio-phylo>
1113             for any user or developer questions and discussions.
1114              
1115             Also see the manual: L<Bio::Phylo::Manual> and L<http://rutgervos.blogspot.com>.
1116              
1117             =head1 CITATION
1118              
1119             If you use Bio::Phylo in published research, please cite it:
1120              
1121             B<Rutger A Vos>, B<Jason Caravas>, B<Klaas Hartmann>, B<Mark A Jensen>
1122             and B<Chase Miller>, 2011. Bio::Phylo - phyloinformatic analysis using Perl.
1123             I<BMC Bioinformatics> B<12>:63.
1124             L<http://dx.doi.org/10.1186/1471-2105-12-63>
1125              
1126             =cut
1127              
1128             }
1129             1;