File Coverage

blib/lib/MDOM/Element.pm
Criterion Covered Total %
statement 59 155 38.0
branch 12 74 16.2
condition 2 15 13.3
subroutine 22 48 45.8
pod 22 22 100.0
total 117 314 37.2


line stmt bran cond sub pod time code
1             package MDOM::Element;
2              
3             =pod
4              
5             =head1 NAME
6              
7             MDOM::Element - The abstract Element class, a base for all source objects
8              
9             =head1 INHERITANCE
10              
11             MDOM::Element is the root of the PDOM tree
12              
13             =head1 DESCRIPTION
14              
15             The abstract C serves as a base class for all source-related
16             objects, from a single whitespace token to an entire document. It provides
17             a basic set of methods to provide a common interface and basic
18             implementations.
19              
20             =head1 METHODS
21              
22             =cut
23              
24 17     17   113 use strict;
  17         28  
  17         607  
25 17     17   81 use Scalar::Util 'refaddr';
  17         22  
  17         1531  
26 17         1343 use Params::Util '_INSTANCE',
27 17     17   9801 '_ARRAY';
  17         46253  
28 17     17   8642 use MDOM::Node ();
  17         56  
  17         515  
29 17     17   8534 use Clone ();
  17         43229  
  17         535  
30 17     17   119 use List::MoreUtils ();
  17         27  
  17         871  
31             use overload 'bool' => sub () { 1 },
32 17         168 '""' => 'content',
33             '==' => '__equals',
34             '!=' => '__nequals',
35             'eq' => '__eq',
36 17     17   89 'ne' => '__ne';
  17         31  
37              
38 17     17   2202 use vars qw{$VERSION $errstr %_PARENT};
  17         32  
  17         1455  
39             BEGIN {
40 17     17   43 $VERSION = '0.008';
41 17         26 $errstr = '';
42              
43             # Master Child -> Parent index
44 17         31086 %_PARENT = ();
45             }
46              
47              
48              
49              
50              
51             #####################################################################
52             # General Properties
53              
54             =pod
55              
56             =head2 significant
57              
58             Because we treat whitespace and other non-code items as Tokens (in order to
59             be able to "round trip" the L back to a file) the
60             C method allows us to distinguish between tokens that form a
61             part of the code, and tokens that aren't significant, such as whitespace,
62             POD, or the portion of a file after (and including) the C<__END__> token.
63              
64             Returns true if the Element is significant, or false it not.
65              
66             =cut
67              
68             ### XS -> MDOM/XS.xs:_MDOM_Element__significant 0.845+
69 314     314 1 489 sub significant { 1 }
70              
71             =head2 lineno
72              
73             Accessor for current line number.
74              
75             =cut
76              
77             sub lineno {
78 0     0 1 0 $_[0]->{lineno};
79             }
80              
81             =pod
82              
83             =head2 class
84              
85             The C method is provided as a convenience, and really does nothing
86             more than returning C. However, some people have found that
87             they appreciate the laziness of C<$Foo-Eclass eq 'whatever'>, so I
88             have caved to popular demand and included it.
89              
90             Returns the class of the Element as a string
91              
92             =cut
93              
94 142     142 1 451 sub class { ref($_[0]) }
95              
96             =pod
97              
98             =head2 tokens
99              
100             The C method returns a list of L objects for the
101             Element, essentially getting back that part of the document as if it had
102             not been lexed.
103              
104             This also means there are no Statements and no Structures in the list,
105             just the Token classes.
106              
107             =cut
108              
109 0     0 1 0 sub tokens { $_[0] }
110              
111             =pod
112              
113             =head2 content
114              
115             For B C, the C method will reconstitute the
116             base code for it as a single string. This method is also the method used
117             for overloading stringification. When an Element is used in a double-quoted
118             string for example, this is the method that is called.
119              
120             B
121              
122             You should be aware that because of the way that here-docs are handled, any
123             here-doc content is not included in C, and as such you should
124             B eval or execute the result if it contains any L.
125              
126             The L method C should be used to stringify a PDOM
127             document into something that can be executed as expected.
128              
129             Returns the basic code as a string (excluding here-doc content).
130              
131             =cut
132              
133             ### XS -> MDOM/XS.xs:_MDOM_Element__content 0.900+
134 0     0 1 0 sub content { '' }
135              
136              
137             #####################################################################
138             # Naigation Methods
139              
140             =pod
141              
142             =head2 parent
143              
144             Elements themselves are not intended to contain other Elements, that is
145             left to the L abstract class, a subclass of C.
146             However, all Elements can be contained B a parent Node.
147              
148             If an Element is within a parent Node, the C method returns the
149             Node.
150              
151             =cut
152              
153 27     27 1 132 sub parent { $_PARENT{refaddr $_[0]} }
154              
155             =pod
156              
157             =head2 statement
158              
159             For a C that is contained (at some depth) within a
160             L, the C method will return the first parent
161             Statement object lexically 'above' the Element.
162              
163             Returns a L object, which may be the same Element if the
164             Element is itself a L object.
165              
166             Returns false if the Element is not within a Statement and is not itself
167             a Statement.
168              
169             =cut
170              
171             sub statement {
172 0     0 1 0 my $cursor = shift;
173 0         0 while ( ! _INSTANCE($cursor, 'MDOM::Statement') ) {
174 0 0       0 $cursor = $_PARENT{refaddr $cursor} or return '';
175             }
176 0         0 $cursor;
177             }
178              
179             =pod
180              
181             =head2 top
182              
183             For a C that is contained within a PDOM tree, the C method
184             will return the top-level Node in the tree. Most of the time this should be
185             a L object, however this will not always be so. For example,
186             if a subroutine has been removed from its Document, to be moved to another
187             Document.
188              
189             Returns the top-most PDOM object, which may be the same Element, if it is
190             not within any parent PDOM object.
191              
192             =cut
193              
194             sub top {
195 0     0 1 0 my $cursor = shift;
196 0         0 while ( my $parent = $_PARENT{refaddr $cursor} ) {
197 0         0 $cursor = $parent;
198             }
199 0         0 $cursor;
200             }
201              
202             =pod
203              
204             =head2 document
205              
206             For an Element that is contained within a L object,
207             the C method will return the top-level Document for the Element.
208              
209             Returns the L for this Element, or false if the Element is not
210             contained within a Document.
211              
212             =cut
213              
214             sub document {
215 0     0 1 0 my $top = shift->top;
216 0 0       0 _INSTANCE($top, 'MDOM::Document') and $top;
217             }
218              
219             =pod
220              
221             =head2 next_sibling
222              
223             All L objects (specifically, our parent Node) contain a number of
224             C objects. The C method returns the C
225             immediately after the current one, or false if there is no next sibling.
226              
227             =cut
228              
229             sub next_sibling {
230 4     4 1 6 my $self = shift;
231 4 50       27 my $parent = $_PARENT{refaddr $self} or return '';
232 4         8 my $key = refaddr $self;
233 4         7 my $elements = $parent->{children};
234             my $position = List::MoreUtils::firstidx {
235 8     8   14 refaddr $_ == $key
236 4         25 } @$elements;
237 4 100       39 $elements->[$position + 1] || '';
238             }
239              
240             =pod
241              
242             =head2 snext_sibling
243              
244             As per the other 's' methods, the C method returns the next
245             B sibling of the C object.
246              
247             Returns a C object, or false if there is no 'next' significant
248             sibling.
249              
250             =cut
251              
252             sub snext_sibling {
253 0     0 1 0 my $self = shift;
254 0 0       0 my $parent = $_PARENT{refaddr $self} or return '';
255 0         0 my $key = refaddr $self;
256 0         0 my $elements = $parent->{children};
257             my $position = List::MoreUtils::firstidx {
258 0     0   0 refaddr $_ == $key
259 0         0 } @$elements;
260 0         0 while ( defined(my $it = $elements->[++$position]) ) {
261 0 0       0 return $it if $it->significant;
262             }
263 0         0 '';
264             }
265              
266             =pod
267              
268             =head2 previous_sibling
269              
270             All L objects (specifically, our parent Node) contain a number of
271             C objects. The C method returns the Element
272             immediately before the current one, or false if there is no 'previous'
273             C object.
274              
275             =cut
276              
277             sub previous_sibling {
278 4     4 1 5 my $self = shift;
279 4 50       24 my $parent = $_PARENT{refaddr $self} or return '';
280 4         8 my $key = refaddr $self;
281 4         7 my $elements = $parent->{children};
282             my $position = List::MoreUtils::firstidx {
283 8     8   16 refaddr $_ == $key
284 4         33 } @$elements;
285 4 100 66     40 $position and $elements->[$position - 1] or '';
286             }
287              
288             =pod
289              
290             =head2 sprevious_sibling
291              
292             As per the other 's' methods, the C method returns
293             the previous B sibling of the C object.
294              
295             Returns a C object, or false if there is no 'previous' significant
296             sibling.
297              
298             =cut
299              
300             sub sprevious_sibling {
301 0     0 1 0 my $self = shift;
302 0 0       0 my $parent = $_PARENT{refaddr $self} or return '';
303 0         0 my $key = refaddr $self;
304 0         0 my $elements = $parent->{children};
305             my $position = List::MoreUtils::firstidx {
306 0     0   0 refaddr $_ == $key
307 0         0 } @$elements;
308 0   0     0 while ( $position-- and defined(my $it = $elements->[$position]) ) {
309 0 0       0 return $it if $it->significant;
310             }
311 0         0 '';
312             }
313              
314             =pod
315              
316             =head2 first_token
317              
318             As a support method for higher-order algorithms that deal specifically with
319             tokens and actual Perl content, the C method finds the first
320             MDOM::Token object within or equal to this one.
321              
322             That is, if called on a L subclass, it will descend until it
323             finds a L. If called on a L object, it will return
324             the same object.
325              
326             Returns a L object, or dies on error (which should be extremely
327             rare and only occur if an illegal empty L exists below the
328             current Element somewhere.
329              
330             =cut
331              
332             sub first_token {
333 0     0 1 0 my $cursor = shift;
334 0         0 while ( $cursor->isa('MDOM::Node') ) {
335 0 0       0 $cursor = $cursor->first_element
336             or die "Found empty MDOM::Node while getting first token";
337             }
338 0         0 $cursor;
339             }
340              
341              
342             =pod
343              
344             =head2 last_token
345              
346             As a support method for higher-order algorithms that deal specifically with
347             tokens and actual Perl content, the C method finds the last
348             MDOM::Token object within or equal to this one.
349              
350             That is, if called on a L subclass, it will descend until it
351             finds a L. If called on a L object, it will return
352             the itself.
353              
354             Returns a L object, or dies on error (which should be extremely
355             rare and only occur if an illegal empty L exists below the
356             current Element somewhere.
357              
358             =cut
359              
360             sub last_token {
361 44     44 1 37 my $cursor = shift;
362 44         96 while ( $cursor->isa('MDOM::Node') ) {
363 82 50       132 $cursor = $cursor->last_element
364             or die "Found empty MDOM::Node while getting first token";
365             }
366 44         94 $cursor;
367             }
368              
369             =pod
370              
371             =head2 next_token
372              
373             As a support method for higher-order algorithms that deal specifically with
374             tokens and actual Perl content, the C method finds the
375             L object that is immediately after the current Element, even if
376             it is not within the same parent L as the one for which the
377             method is being called.
378              
379             Note that this is B defined as a L-specific method,
380             because it can be useful to find the next token that is after, say, a
381             L, although obviously it would be useless to want the
382             next token after a L.
383              
384             Returns a L object, or false if there are no more tokens after
385             the Element.
386              
387             =cut
388              
389             sub next_token {
390 0     0 1 0 my $cursor = shift;
391              
392             # Find the next element, going upwards as needed
393 0         0 while ( 1 ) {
394 0         0 my $element = $cursor->next_sibling;
395 0 0       0 if ( $element ) {
396 0 0       0 return $element if $element->isa('MDOM::Token');
397 0         0 return $element->first_token;
398             }
399 0 0       0 $cursor = $cursor->parent or return '';
400 0 0 0     0 if ( $cursor->isa('MDOM::Structure') and $cursor->finish ) {
401 0         0 return $cursor->finish;
402             }
403             }
404             }
405              
406             =pod
407              
408             =head2 previous_token
409              
410             As a support method for higher-order algorithms that deal specifically with
411             tokens and actual Perl content, the C method finds the
412             L object that is immediately before the current Element, even
413             if it is not within the same parent L as this one.
414              
415             Note that this is not defined as a L-only method, because it can
416             be useful to find the token is before, say, a L, although
417             obviously it would be useless to want the next token before a
418             L.
419              
420             Returns a L object, or false if there are no more tokens before
421             the C.
422              
423             =cut
424              
425             sub previous_token {
426 0     0 1 0 my $cursor = shift;
427              
428             # Find the previous element, going upwards as needed
429 0         0 while ( 1 ) {
430 0         0 my $element = $cursor->previous_sibling;
431 0 0       0 if ( $element ) {
432 0 0       0 return $element if $element->isa('MDOM::Token');
433 0         0 return $element->last_token;
434             }
435 0 0       0 $cursor = $cursor->parent or return '';
436 0 0 0     0 if ( $cursor->isa('MDOM::Structure') and $cursor->start ) {
437 0         0 return $cursor->start;
438             }
439             }
440             }
441              
442              
443              
444              
445              
446             #####################################################################
447             # Manipulation
448              
449             =pod
450              
451             =head2 clone
452              
453             As per the L module, the C method makes a perfect copy of
454             an Element object. In the generic case, the implementation is done using
455             the L module's mechanism itself. In higher-order cases, such as for
456             Nodes, there is more work involved to keep the parent-child links intact.
457              
458             =cut
459              
460             sub clone {
461 1     1 1 44 Clone::clone(shift);
462             }
463              
464             =pod
465              
466             =head2 insert_before @Elements
467              
468             The C method allows you to insert lexical perl content, in
469             the form of C objects, before the calling C. You
470             need to be very careful when modifying perl code, as it's easy to break
471             things.
472              
473             In its initial incarnation, this method allows you to insert a single
474             Element, and will perform some basic checking to prevent you inserting
475             something that would be structurally wrong (in PDOM terms).
476              
477             In future, this method may be enhanced to allow the insertion of multiple
478             Elements, inline-parsed code strings or L objects.
479              
480             Returns true if the Element was inserted, false if it can not be inserted,
481             or C if you do not provide a L object as a parameter.
482              
483             =cut
484              
485             sub __insert_before {
486 0     0   0 my $self = shift;
487 0         0 $self->parent->__insert_before_child( $self, @_ );
488             }
489              
490             =pod
491              
492             =head2 insert_after @Elements
493              
494             The C method allows you to insert lexical perl content, in
495             the form of C objects, after the calling C. You need
496             to be very careful when modifying perl code, as it's easy to break things.
497              
498             In its initial incarnation, this method allows you to insert a single
499             Element, and will perform some basic checking to prevent you inserting
500             something that would be structurally wrong (in PDOM terms).
501              
502             In future, this method may be enhanced to allow the insertion of multiple
503             Elements, inline-parsed code strings or L objects.
504              
505             Returns true if the Element was inserted, false if it can not be inserted,
506             or C if you do not provide a L object as a parameter.
507              
508             =cut
509              
510             sub __insert_after {
511 0     0   0 my $self = shift;
512 0         0 $self->parent->__insert_after_child( $self, @_ );
513             }
514              
515             =pod
516              
517             =head2 remove
518              
519             For a given C, the C method will remove it from its
520             parent B, along with all of its children.
521              
522             Returns the C itself as a convenience, or C if an error
523             occurs while trying to remove the C.
524              
525             =cut
526              
527             sub remove {
528 5     5 1 5 my $self = shift;
529 5 50       9 my $parent = $self->parent or return $self;
530 5         12 $parent->remove_child( $self );
531             }
532              
533             =pod
534              
535             =head2 delete
536              
537             For a given C, the C method will remove it from its
538             parent, immediately deleting the C and all of its children (if it
539             has any).
540              
541             Returns true if the C was successfully deleted, or C if
542             an error occurs while trying to remove the C.
543              
544             =cut
545              
546             sub delete {
547 5 50   5 1 16 $_[0]->remove or return undef;
548 5         18 $_[0]->DESTROY;
549 5         12 1;
550             }
551              
552             =pod
553              
554             =head2 replace $Element
555              
556             Although some higher level class support more exotic forms of replace,
557             at the basic level the C method takes a single C as
558             an argument and replaces the current C with it.
559              
560             To prevent accidental damage to code, in this initial implementation the
561             replacement element B be of the same class (or a subclass) as the
562             one being replaced.
563              
564             =cut
565              
566             sub replace {
567 0 0   0 1 0 my $self = ref $_[0] ? shift : return undef;
568 0 0       0 my $Element = _INSTANCE(shift, ref $self) or return undef;
569 0         0 die "The ->replace method has not yet been implemented";
570             }
571              
572             =pod
573              
574             =head2 location
575              
576             If the Element exists within a L that has
577             indexed the Element locations using C, the
578             C method will return the location of the first character of the
579             Element within the Document.
580              
581             Returns the location as a reference to a three-element array in the form
582             C<[ $line, $rowchar, $col ]>. The values are in a human format, with the
583             first character of the file located at C<[ 1, 1, 1 ]>.
584              
585             The second and third numbers are similar, except that the second is the
586             literal horizontal character, and the third is the visual column, taking
587             into account tabbing.
588              
589             Returns C on error, or if the L object has not been indexed.
590              
591             =cut
592              
593             sub location {
594 0     0 1 0 my $self = shift;
595 0 0       0 unless ( exists $self->{_location} ) {
596             # Are we inside a normal document?
597 0 0       0 my $Document = $self->document or return undef;
598 0 0       0 if ( $Document->isa('MDOM::Document::Fragment') ) {
599             # Because they can't be serialized, document fragments
600             # do not support the concept of location.
601 0         0 return undef;
602             }
603              
604             # Generate the locations. If they need one location, then
605             # the chances are they'll want more, and it's better that
606             # everything is already pre-generated.
607 0 0       0 $Document->index_locations or return undef;
608 0 0       0 unless ( exists $self->{_location} ) {
609             # erm... something went very wrong here
610 0         0 return undef;
611             }
612             }
613              
614             # Return a copy, not the original
615 0         0 return [ @{$self->{_location}} ];
  0         0  
616             }
617              
618             # Although flush_locations is only publically a Document-level method,
619             # we are able to implement it at an Element level, allowing us to
620             # selectively flush only the part of the document that occurs after the
621             # element for which the flush is called.
622             sub _flush_locations {
623 0     0   0 my $self = shift;
624 0 0       0 unless ( $self == $self->top ) {
625 0         0 return $self->top->_flush_locations( $self );
626             }
627              
628             # Get the full list of all Tokens
629 0         0 my @Tokens = $self->tokens;
630              
631             # Optionally allow starting from an arbitrary element (or rather,
632             # the first Token equal-to-or-within an arbitrary element)
633 0 0       0 if ( _INSTANCE($_[0], 'MDOM::Element') ) {
634 0         0 my $start = shift->first_token;
635 0         0 while ( my $Token = shift @Tokens ) {
636 0 0       0 return 1 unless $Token->{_location};
637 0 0       0 next unless refaddr($Token) == refaddr($start);
638              
639             # Found the start. Flush it's location
640 0         0 delete $$Token->{_location};
641 0         0 last;
642             }
643             }
644              
645             # Iterate over any remaining Tokens and flush their location
646 0         0 foreach my $Token ( @Tokens ) {
647 0         0 delete $Token->{_location};
648             }
649              
650 0         0 1;
651             }
652              
653              
654              
655              
656              
657             #####################################################################
658             # XML Compatibility Methods
659              
660             sub _xml_name {
661 0   0 0   0 my $class = ref $_[0] || $_[0];
662 0         0 my $name = lc join( '_', split /::/, $class );
663 0         0 substr($name, 4);
664             }
665              
666             sub _xml_attr {
667 0     0   0 return {};
668             }
669              
670             sub _xml_content {
671 0 0   0   0 defined $_[0]->{content} ? $_[0]->{content} : '';
672             }
673              
674              
675              
676              
677              
678             #####################################################################
679             # Internals
680              
681             # Set the error string
682             sub _error {
683 0     0   0 $errstr = $_[1];
684 0         0 undef;
685             }
686              
687             # Clear the error string
688             sub _clear {
689 0     0   0 $errstr = '';
690 0         0 $_[0];
691             }
692              
693             # Being DESTROYed in this manner, rather than by an explicit
694             # ->delete means our reference count has probably fallen to zero.
695             # Therefore we don't need to remove ourselves from our parent,
696             # just the index ( just in case ).
697             ### XS -> MDOM/XS.xs:_MDOM_Element__DESTROY 0.900+
698 866     866   3217 sub DESTROY { delete $_PARENT{refaddr $_[0]} }
699              
700             # Operator overloads
701 0 0   0   0 sub __equals { ref $_[1] and refaddr($_[0]) == refaddr($_[1]) }
702 0     0   0 sub __nequals { !__equals(@_) }
703             sub __eq {
704 1051 50   1051   5111 my $self = _INSTANCE($_[0], 'MDOM::Element') ? $_[0]->content : $_[0];
705 1051 100       1937 my $other = _INSTANCE($_[1], 'MDOM::Element') ? $_[1]->content : $_[1];
706 1051         2993 $self eq $other;
707             }
708 0     0     sub __ne { !__eq(@_) }
709              
710             1;
711              
712             =pod
713              
714             =head1 TO DO
715              
716             It would be nice if C could be used in an ad-hoc manner. That is,
717             if called on an Element within a Document that has not been indexed, it will
718             do a one-off calculation to find the location. It might be very painful if
719             someone started using it a lot, without remembering to index the document,
720             but it would be handy for things that are only likely to use it once, such
721             as error handlers.
722              
723             =head1 SUPPORT
724              
725             See the L in the main module.
726              
727             =head1 AUTHOR
728              
729             Adam Kennedy Eadamk@cpan.orgE
730              
731             =head1 COPYRIGHT
732              
733             Copyright 2001 - 2006 Adam Kennedy.
734              
735             This program is free software; you can redistribute
736             it and/or modify it under the same terms as Perl itself.
737              
738             The full text of the license can be found in the
739             LICENSE file included with this module.
740              
741             =cut