Commit | Line | Data |
3fea05b9 |
1 | package PPI::Node; |
2 | |
3 | =pod |
4 | |
5 | =head1 NAME |
6 | |
7 | PPI::Node - Abstract PPI Node class, an Element that can contain other Elements |
8 | |
9 | =head1 INHERITANCE |
10 | |
11 | PPI::Node |
12 | isa PPI::Element |
13 | |
14 | =head1 SYNOPSIS |
15 | |
16 | # Create a typical node (a Document in this case) |
17 | my $Node = PPI::Document->new; |
18 | |
19 | # Add an element to the node( in this case, a token ) |
20 | my $Token = PPI::Token::Word->new('my'); |
21 | $Node->add_element( $Token ); |
22 | |
23 | # Get the elements for the Node |
24 | my @elements = $Node->children; |
25 | |
26 | # Find all the barewords within a Node |
27 | my $barewords = $Node->find( 'PPI::Token::Word' ); |
28 | |
29 | # Find by more complex criteria |
30 | my $my_tokens = $Node->find( sub { $_[1]->content eq 'my' } ); |
31 | |
32 | # Remove all the whitespace |
33 | $Node->prune( 'PPI::Token::Whitespace' ); |
34 | |
35 | # Remove by more complex criteria |
36 | $Node->prune( sub { $_[1]->content eq 'my' } ); |
37 | |
38 | =head1 DESCRIPTION |
39 | |
40 | The C<PPI::Node> class provides an abstract base class for the Element |
41 | classes that are able to contain other elements L<PPI::Document>, |
42 | L<PPI::Statement>, and L<PPI::Structure>. |
43 | |
44 | As well as those listed below, all of the methods that apply to |
45 | L<PPI::Element> objects also apply to C<PPI::Node> objects. |
46 | |
47 | =head1 METHODS |
48 | |
49 | =cut |
50 | |
51 | use strict; |
52 | use Carp (); |
53 | use Scalar::Util qw{refaddr}; |
54 | use List::MoreUtils (); |
55 | use Params::Util qw{_INSTANCE _CLASS _CODELIKE}; |
56 | use PPI::Element (); |
57 | |
58 | use vars qw{$VERSION @ISA *_PARENT}; |
59 | BEGIN { |
60 | $VERSION = '1.206'; |
61 | @ISA = 'PPI::Element'; |
62 | *_PARENT = *PPI::Element::_PARENT; |
63 | } |
64 | |
65 | |
66 | |
67 | |
68 | |
69 | ##################################################################### |
70 | # The basic constructor |
71 | |
72 | sub new { |
73 | my $class = ref $_[0] || $_[0]; |
74 | bless { children => [] }, $class; |
75 | } |
76 | |
77 | |
78 | |
79 | |
80 | |
81 | ##################################################################### |
82 | # PDOM Methods |
83 | |
84 | =pod |
85 | |
86 | =head2 scope |
87 | |
88 | The C<scope> method returns true if the node represents a lexical scope |
89 | boundary, or false if it does not. |
90 | |
91 | =cut |
92 | |
93 | ### XS -> PPI/XS.xs:_PPI_Node__scope 0.903+ |
94 | sub scope { '' } |
95 | |
96 | =pod |
97 | |
98 | =head2 add_element $Element |
99 | |
100 | The C<add_element> method adds a L<PPI::Element> object to the end of a |
101 | C<PPI::Node>. Because Elements maintain links to their parent, an |
102 | Element can only be added to a single Node. |
103 | |
104 | Returns true if the L<PPI::Element> was added. Returns C<undef> if the |
105 | Element was already within another Node, or the method is not passed |
106 | a L<PPI::Element> object. |
107 | |
108 | =cut |
109 | |
110 | sub add_element { |
111 | my $self = shift; |
112 | |
113 | # Check the element |
114 | my $Element = _INSTANCE(shift, 'PPI::Element') or return undef; |
115 | $_PARENT{refaddr $Element} and return undef; |
116 | |
117 | # Add the argument to the elements |
118 | push @{$self->{children}}, $Element; |
119 | Scalar::Util::weaken( |
120 | $_PARENT{refaddr $Element} = $self |
121 | ); |
122 | |
123 | 1; |
124 | } |
125 | |
126 | # In a typical run profile, add_element is the number 1 resource drain. |
127 | # This is a highly optimised unsafe version, for internal use only. |
128 | sub __add_element { |
129 | Scalar::Util::weaken( |
130 | $_PARENT{refaddr $_[1]} = $_[0] |
131 | ); |
132 | push @{$_[0]->{children}}, $_[1]; |
133 | } |
134 | |
135 | =pod |
136 | |
137 | =head2 elements |
138 | |
139 | The C<elements> method accesses all child elements B<structurally> within |
140 | the C<PPI::Node> object. Note that in the base of the L<PPI::Structure> |
141 | classes, this C<DOES> include the brace tokens at either end of the |
142 | structure. |
143 | |
144 | Returns a list of zero or more L<PPI::Element> objects. |
145 | |
146 | Alternatively, if called in the scalar context, the C<elements> method |
147 | returns a count of the number of elements. |
148 | |
149 | =cut |
150 | |
151 | sub elements { |
152 | if ( wantarray ) { |
153 | return @{$_[0]->{children}}; |
154 | } else { |
155 | return scalar @{$_[0]->{children}}; |
156 | } |
157 | } |
158 | |
159 | =pod |
160 | |
161 | =head2 first_element |
162 | |
163 | The C<first_element> method accesses the first element structurally within |
164 | the C<PPI::Node> object. As for the C<elements> method, this does include |
165 | the brace tokens for L<PPI::Structure> objects. |
166 | |
167 | Returns a L<PPI::Element> object, or C<undef> if for some reason the |
168 | C<PPI::Node> object does not contain any elements. |
169 | |
170 | =cut |
171 | |
172 | # Normally the first element is also the first child |
173 | sub first_element { |
174 | $_[0]->{children}->[0]; |
175 | } |
176 | |
177 | =pod |
178 | |
179 | =head2 last_element |
180 | |
181 | The C<last_element> method accesses the last element structurally within |
182 | the C<PPI::Node> object. As for the C<elements> method, this does include |
183 | the brace tokens for L<PPI::Structure> objects. |
184 | |
185 | Returns a L<PPI::Element> object, or C<undef> if for some reason the |
186 | C<PPI::Node> object does not contain any elements. |
187 | |
188 | =cut |
189 | |
190 | # Normally the last element is also the last child |
191 | sub last_element { |
192 | $_[0]->{children}->[-1]; |
193 | } |
194 | |
195 | =pod |
196 | |
197 | =head2 children |
198 | |
199 | The C<children> method accesses all child elements lexically within the |
200 | C<PPI::Node> object. Note that in the case of the L<PPI::Structure> |
201 | classes, this does B<NOT> include the brace tokens at either end of the |
202 | structure. |
203 | |
204 | Returns a list of zero of more L<PPI::Element> objects. |
205 | |
206 | Alternatively, if called in the scalar context, the C<children> method |
207 | returns a count of the number of lexical children. |
208 | |
209 | =cut |
210 | |
211 | # In the default case, this is the same as for the elements method |
212 | sub children { |
213 | wantarray ? @{$_[0]->{children}} : scalar @{$_[0]->{children}}; |
214 | } |
215 | |
216 | =pod |
217 | |
218 | =head2 schildren |
219 | |
220 | The C<schildren> method is really just a convenience, the significant-only |
221 | variation of the normal C<children> method. |
222 | |
223 | In list context, returns a list of significant children. In scalar context, |
224 | returns the number of significant children. |
225 | |
226 | =cut |
227 | |
228 | sub schildren { |
229 | return grep { $_->significant } @{$_[0]->{children}} if wantarray; |
230 | my $count = 0; |
231 | foreach ( @{$_[0]->{children}} ) { |
232 | $count++ if $_->significant; |
233 | } |
234 | return $count; |
235 | } |
236 | |
237 | =pod |
238 | |
239 | =head2 child $index |
240 | |
241 | The C<child> method accesses a child L<PPI::Element> object by its |
242 | position within the Node. |
243 | |
244 | Returns a L<PPI::Element> object, or C<undef> if there is no child |
245 | element at that node. |
246 | |
247 | =cut |
248 | |
249 | sub child { |
250 | $_[0]->{children}->[$_[1]]; |
251 | } |
252 | |
253 | =pod |
254 | |
255 | =head2 schild $index |
256 | |
257 | The lexical structure of the Perl language ignores 'insignificant' items, |
258 | such as whitespace and comments, while L<PPI> treats these items as valid |
259 | tokens so that it can reassemble the file at any time. Because of this, |
260 | in many situations there is a need to find an Element within a Node by |
261 | index, only counting lexically significant Elements. |
262 | |
263 | The C<schild> method returns a child Element by index, ignoring |
264 | insignificant Elements. The index of a child Element is specified in the |
265 | same way as for a normal array, with the first Element at index 0, and |
266 | negative indexes used to identify a "from the end" position. |
267 | |
268 | =cut |
269 | |
270 | sub schild { |
271 | my $self = shift; |
272 | my $idx = 0 + shift; |
273 | my $el = $self->{children}; |
274 | if ( $idx < 0 ) { |
275 | my $cursor = 0; |
276 | while ( exists $el->[--$cursor] ) { |
277 | return $el->[$cursor] if $el->[$cursor]->significant and ++$idx >= 0; |
278 | } |
279 | } else { |
280 | my $cursor = -1; |
281 | while ( exists $el->[++$cursor] ) { |
282 | return $el->[$cursor] if $el->[$cursor]->significant and --$idx < 0; |
283 | } |
284 | } |
285 | undef; |
286 | } |
287 | |
288 | =pod |
289 | |
290 | =head2 contains $Element |
291 | |
292 | The C<contains> method is used to determine if another L<PPI::Element> |
293 | object is logically "within" a C<PPI::Node>. For the special case of the |
294 | brace tokens at either side of a L<PPI::Structure> object, they are |
295 | generally considered "within" a L<PPI::Structure> object, even if they are |
296 | not actually in the elements for the L<PPI::Structure>. |
297 | |
298 | Returns true if the L<PPI::Element> is within us, false if not, or C<undef> |
299 | on error. |
300 | |
301 | =cut |
302 | |
303 | sub contains { |
304 | my $self = shift; |
305 | my $Element = _INSTANCE(shift, 'PPI::Element') or return undef; |
306 | |
307 | # Iterate up the Element's parent chain until we either run out |
308 | # of parents, or get to ourself. |
309 | while ( $Element = $Element->parent ) { |
310 | return 1 if refaddr($self) == refaddr($Element); |
311 | } |
312 | |
313 | ''; |
314 | } |
315 | |
316 | =pod |
317 | |
318 | =head2 find $class | \&wanted |
319 | |
320 | The C<find> method is used to search within a code tree for |
321 | L<PPI::Element> objects that meet a particular condition. |
322 | |
323 | To specify the condition, the method can be provided with either a simple |
324 | class name (full or shortened), or a C<CODE>/function reference. |
325 | |
326 | # Find all single quotes in a Document (which is a Node) |
327 | $Document->find('PPI::Quote::Single'); |
328 | |
329 | # The same thing with a shortened class name |
330 | $Document->find('Quote::Single'); |
331 | |
332 | # Anything more elaborate, we so with the sub |
333 | $Document->find( sub { |
334 | # At the top level of the file... |
335 | $_[1]->parent == $_[0] |
336 | and ( |
337 | # ...find all comments and POD |
338 | $_[1]->isa('PPI::Token::Pod') |
339 | or |
340 | $_[1]->isa('PPI::Token::Comment') |
341 | ) |
342 | } ); |
343 | |
344 | The function will be passed two arguments, the top-level C<PPI::Node> |
345 | you are searching in and the current L<PPI::Element> that the condition |
346 | is testing. |
347 | |
348 | The anonymous function should return one of three values. Returning true |
349 | indicates a condition match, defined-false (C<0> or C<''>) indicates |
350 | no-match, and C<undef> indicates no-match and no-descend. |
351 | |
352 | In the last case, the tree walker will skip over anything below the |
353 | C<undef>-returning element and move on to the next element at the same |
354 | level. |
355 | |
356 | To halt the entire search and return C<undef> immediately, a condition |
357 | function should throw an exception (i.e. C<die>). |
358 | |
359 | Note that this same wanted logic is used for all methods documented to |
360 | have a C<\&wanted> parameter, as this one does. |
361 | |
362 | The C<find> method returns a reference to an array of L<PPI::Element> |
363 | objects that match the condition, false (but defined) if no Elements match |
364 | the condition, or C<undef> if you provide a bad condition, or an error |
365 | occurs during the search process. |
366 | |
367 | In the case of a bad condition, a warning will be emitted as well. |
368 | |
369 | =cut |
370 | |
371 | sub find { |
372 | my $self = shift; |
373 | my $wanted = $self->_wanted(shift) or return undef; |
374 | |
375 | # Use a queue based search, rather than a recursive one |
376 | my @found = (); |
377 | my @queue = $self->children; |
378 | eval { |
379 | while ( my $Element = shift @queue ) { |
380 | my $rv = &$wanted( $self, $Element ); |
381 | push @found, $Element if $rv; |
382 | |
383 | # Support "don't descend on undef return" |
384 | next unless defined $rv; |
385 | |
386 | # Skip if the Element doesn't have any children |
387 | next unless $Element->isa('PPI::Node'); |
388 | |
389 | # Depth-first keeps the queue size down and provides a |
390 | # better logical order. |
391 | if ( $Element->isa('PPI::Structure') ) { |
392 | unshift @queue, $Element->finish if $Element->finish; |
393 | unshift @queue, $Element->children; |
394 | unshift @queue, $Element->start if $Element->start; |
395 | } else { |
396 | unshift @queue, $Element->children; |
397 | } |
398 | } |
399 | }; |
400 | if ( $@ ) { |
401 | # Caught exception thrown from the wanted function |
402 | return undef; |
403 | } |
404 | |
405 | @found ? \@found : ''; |
406 | } |
407 | |
408 | =pod |
409 | |
410 | =head2 find_first $class | \&wanted |
411 | |
412 | If the normal C<find> method is like a grep, then C<find_first> is |
413 | equivalent to the L<Scalar::Util> C<first> function. |
414 | |
415 | Given an element class or a wanted function, it will search depth-first |
416 | through a tree until it finds something that matches the condition, |
417 | returning the first Element that it encounters. |
418 | |
419 | See the C<find> method for details on the format of the search condition. |
420 | |
421 | Returns the first L<PPI::Element> object that matches the condition, false |
422 | if nothing matches the condition, or C<undef> if given an invalid condition, |
423 | or an error occurs. |
424 | |
425 | =cut |
426 | |
427 | sub find_first { |
428 | my $self = shift; |
429 | my $wanted = $self->_wanted(shift) or return undef; |
430 | |
431 | # Use the same queue-based search as for ->find |
432 | my @queue = $self->children; |
433 | my $rv = eval { |
434 | # The defined() here prevents a ton of calls to PPI::Util::TRUE |
435 | while ( defined( my $Element = shift @queue ) ) { |
436 | my $rv = &$wanted( $self, $Element ); |
437 | return $Element if $rv; |
438 | |
439 | # Support "don't descend on undef return" |
440 | next unless defined $rv; |
441 | |
442 | # Skip if the Element doesn't have any children |
443 | next unless $Element->isa('PPI::Node'); |
444 | |
445 | # Depth-first keeps the queue size down and provides a |
446 | # better logical order. |
447 | if ( $Element->isa('PPI::Structure') ) { |
448 | unshift @queue, $Element->finish if defined($Element->finish); |
449 | unshift @queue, $Element->children; |
450 | unshift @queue, $Element->start if defined($Element->start); |
451 | } else { |
452 | unshift @queue, $Element->children; |
453 | } |
454 | } |
455 | }; |
456 | if ( $@ ) { |
457 | # Caught exception thrown from the wanted function |
458 | return undef; |
459 | } |
460 | |
461 | $rv or ''; |
462 | } |
463 | |
464 | =pod |
465 | |
466 | =head2 find_any $class | \&wanted |
467 | |
468 | The C<find_any> method is a short-circuiting true/false method that behaves |
469 | like the normal C<find> method, but returns true as soon as it finds any |
470 | Elements that match the search condition. |
471 | |
472 | See the C<find> method for details on the format of the search condition. |
473 | |
474 | Returns true if any Elements that match the condition can be found, false if |
475 | not, or C<undef> if given an invalid condition, or an error occurs. |
476 | |
477 | =cut |
478 | |
479 | sub find_any { |
480 | my $self = shift; |
481 | my $rv = $self->find_first(@_); |
482 | $rv ? 1 : $rv; # false or undef |
483 | } |
484 | |
485 | =pod |
486 | |
487 | =head2 remove_child $Element |
488 | |
489 | If passed a L<PPI::Element> object that is a direct child of the Node, |
490 | the C<remove_element> method will remove the C<Element> intact, along |
491 | with any of its children. As such, this method acts essentially as a |
492 | 'cut' function. |
493 | |
494 | If successful, returns the removed element. Otherwise, returns C<undef>. |
495 | |
496 | =cut |
497 | |
498 | sub remove_child { |
499 | my $self = shift; |
500 | my $child = _INSTANCE(shift, 'PPI::Element') or return undef; |
501 | |
502 | # Find the position of the child |
503 | my $key = refaddr $child; |
504 | my $p = List::MoreUtils::firstidx { |
505 | refaddr $_ == $key |
506 | } @{$self->{children}}; |
507 | return undef unless defined $p; |
508 | |
509 | # Splice it out, and remove the child's parent entry |
510 | splice( @{$self->{children}}, $p, 1 ); |
511 | delete $_PARENT{refaddr $child}; |
512 | |
513 | $child; |
514 | } |
515 | |
516 | =pod |
517 | |
518 | =head2 prune $class | \&wanted |
519 | |
520 | The C<prune> method is used to strip L<PPI::Element> objects out of a code |
521 | tree. The argument is the same as for the C<find> method, either a class |
522 | name, or an anonymous subroutine which returns true/false. Any Element |
523 | that matches the class|wanted will be deleted from the code tree, along |
524 | with any of its children. |
525 | |
526 | The C<prune> method returns the number of C<Element> objects that matched |
527 | and were removed, B<non-recursively>. This might also be zero, so avoid a |
528 | simple true/false test on the return false of the C<prune> method. It |
529 | returns C<undef> on error, which you probably B<should> test for. |
530 | |
531 | =begin testing prune 2 |
532 | |
533 | # Avoids a bug in old Perls relating to the detection of scripts |
534 | # Known to occur in ActivePerl 5.6.1 and at least one 5.6.2 install. |
535 | my $hashbang = reverse 'lrep/nib/rsu/!#'; |
536 | my $document = PPI::Document->new( \<<"END_PERL" ); |
537 | $hashbang |
538 | |
539 | use strict; |
540 | |
541 | sub one { 1 } |
542 | sub two { 2 } |
543 | sub three { 3 } |
544 | |
545 | print one; |
546 | print "\n"; |
547 | print three; |
548 | print "\n"; |
549 | |
550 | exit; |
551 | END_PERL |
552 | |
553 | isa_ok( $document, 'PPI::Document' ); |
554 | ok( defined($document->prune ('PPI::Statement::Sub')), |
555 | 'Pruned multiple subs ok' ); |
556 | |
557 | =end testing |
558 | |
559 | =cut |
560 | |
561 | sub prune { |
562 | my $self = shift; |
563 | my $wanted = $self->_wanted(shift) or return undef; |
564 | |
565 | # Use a depth-first queue search |
566 | my $pruned = 0; |
567 | my @queue = $self->children; |
568 | eval { |
569 | while ( my $element = shift @queue ) { |
570 | my $rv = &$wanted( $self, $element ); |
571 | if ( $rv ) { |
572 | # Delete the child |
573 | $element->delete or return undef; |
574 | $pruned++; |
575 | next; |
576 | } |
577 | |
578 | # Support the undef == "don't descend" |
579 | next unless defined $rv; |
580 | |
581 | if ( _INSTANCE($element, 'PPI::Node') ) { |
582 | # Depth-first keeps the queue size down |
583 | unshift @queue, $element->children; |
584 | } |
585 | } |
586 | }; |
587 | if ( $@ ) { |
588 | # Caught exception thrown from the wanted function |
589 | return undef; |
590 | } |
591 | |
592 | $pruned; |
593 | } |
594 | |
595 | # This method is likely to be very heavily used, to take |
596 | # it slowly and carefuly. |
597 | ### NOTE: Renaming this function or changing either to self will probably |
598 | ### break File::Find::Rule::PPI |
599 | sub _wanted { |
600 | my $either = shift; |
601 | my $it = defined($_[0]) ? shift : do { |
602 | Carp::carp('Undefined value passed as search condition') if $^W; |
603 | return undef; |
604 | }; |
605 | |
606 | # Has the caller provided a wanted function directly |
607 | return $it if _CODELIKE($it); |
608 | if ( ref $it ) { |
609 | # No other ref types are supported |
610 | Carp::carp('Illegal non-CODE reference passed as search condition') if $^W; |
611 | return undef; |
612 | } |
613 | |
614 | # The first argument should be an Element class, possibly in shorthand |
615 | $it = "PPI::$it" unless substr($it, 0, 5) eq 'PPI::'; |
616 | unless ( _CLASS($it) and $it->isa('PPI::Element') ) { |
617 | # We got something, but it isn't an element |
618 | Carp::carp("Cannot create search condition for '$it': Not a PPI::Element") if $^W; |
619 | return undef; |
620 | } |
621 | |
622 | # Create the class part of the wanted function |
623 | my $wanted_class = "\n\treturn '' unless \$_[1]->isa('$it');"; |
624 | |
625 | # Have we been given a second argument to check the content |
626 | my $wanted_content = ''; |
627 | if ( defined $_[0] ) { |
628 | my $content = shift; |
629 | if ( ref $content eq 'Regexp' ) { |
630 | $content = "$content"; |
631 | } elsif ( ref $content ) { |
632 | # No other ref types are supported |
633 | Carp::carp("Cannot create search condition for '$it': Not a PPI::Element") if $^W; |
634 | return undef; |
635 | } else { |
636 | $content = quotemeta $content; |
637 | } |
638 | |
639 | # Complete the content part of the wanted function |
640 | $wanted_content .= "\n\treturn '' unless defined \$_[1]->{content};"; |
641 | $wanted_content .= "\n\treturn '' unless \$_[1]->{content} =~ /$content/;"; |
642 | } |
643 | |
644 | # Create the complete wanted function |
645 | my $code = "sub {" |
646 | . $wanted_class |
647 | . $wanted_content |
648 | . "\n\t1;" |
649 | . "\n}"; |
650 | |
651 | # Compile the wanted function |
652 | $code = eval $code; |
653 | (ref $code eq 'CODE') ? $code : undef; |
654 | } |
655 | |
656 | |
657 | |
658 | |
659 | |
660 | #################################################################### |
661 | # PPI::Element overloaded methods |
662 | |
663 | sub tokens { |
664 | map { $_->tokens } @{$_[0]->{children}}; |
665 | } |
666 | |
667 | ### XS -> PPI/XS.xs:_PPI_Element__content 0.900+ |
668 | sub content { |
669 | join '', map { $_->content } @{$_[0]->{children}}; |
670 | } |
671 | |
672 | # Clone as normal, but then go down and relink all the _PARENT entries |
673 | sub clone { |
674 | my $self = shift; |
675 | my $clone = $self->SUPER::clone; |
676 | $clone->__link_children; |
677 | $clone; |
678 | } |
679 | |
680 | sub location { |
681 | my $self = shift; |
682 | my $first = $self->{children}->[0] or return undef; |
683 | $first->location; |
684 | } |
685 | |
686 | |
687 | |
688 | |
689 | |
690 | ##################################################################### |
691 | # Internal Methods |
692 | |
693 | sub DESTROY { |
694 | local $_; |
695 | if ( $_[0]->{children} ) { |
696 | my @queue = $_[0]; |
697 | while ( defined($_ = shift @queue) ) { |
698 | unshift @queue, @{delete $_->{children}} if $_->{children}; |
699 | |
700 | # Remove all internal/private weird crosslinking so that |
701 | # the cascading DESTROY calls will get called properly. |
702 | %$_ = (); |
703 | } |
704 | } |
705 | |
706 | # Remove us from our parent node as normal |
707 | delete $_PARENT{refaddr $_[0]}; |
708 | } |
709 | |
710 | # Find the position of a child |
711 | sub __position { |
712 | my $key = refaddr $_[1]; |
713 | List::MoreUtils::firstidx { refaddr $_ == $key } @{$_[0]->{children}}; |
714 | } |
715 | |
716 | # Insert one or more elements before a child |
717 | sub __insert_before_child { |
718 | my $self = shift; |
719 | my $key = refaddr shift; |
720 | my $p = List::MoreUtils::firstidx { |
721 | refaddr $_ == $key |
722 | } @{$self->{children}}; |
723 | foreach ( @_ ) { |
724 | Scalar::Util::weaken( |
725 | $_PARENT{refaddr $_} = $self |
726 | ); |
727 | } |
728 | splice( @{$self->{children}}, $p, 0, @_ ); |
729 | 1; |
730 | } |
731 | |
732 | # Insert one or more elements after a child |
733 | sub __insert_after_child { |
734 | my $self = shift; |
735 | my $key = refaddr shift; |
736 | my $p = List::MoreUtils::firstidx { |
737 | refaddr $_ == $key |
738 | } @{$self->{children}}; |
739 | foreach ( @_ ) { |
740 | Scalar::Util::weaken( |
741 | $_PARENT{refaddr $_} = $self |
742 | ); |
743 | } |
744 | splice( @{$self->{children}}, $p + 1, 0, @_ ); |
745 | 1; |
746 | } |
747 | |
748 | # Replace a child |
749 | sub __replace_child { |
750 | my $self = shift; |
751 | my $key = refaddr shift; |
752 | my $p = List::MoreUtils::firstidx { |
753 | refaddr $_ == $key |
754 | } @{$self->{children}}; |
755 | foreach ( @_ ) { |
756 | Scalar::Util::weaken( |
757 | $_PARENT{refaddr $_} = $self |
758 | ); |
759 | } |
760 | splice( @{$self->{children}}, $p, 1, @_ ); |
761 | 1; |
762 | } |
763 | |
764 | # Create PARENT links for an entire tree. |
765 | # Used when cloning or thawing. |
766 | sub __link_children { |
767 | my $self = shift; |
768 | |
769 | # Relink all our children ( depth first ) |
770 | my @queue = ( $self ); |
771 | while ( my $Node = shift @queue ) { |
772 | # Link our immediate children |
773 | foreach my $Element ( @{$Node->{children}} ) { |
774 | Scalar::Util::weaken( |
775 | $_PARENT{refaddr($Element)} = $Node |
776 | ); |
777 | unshift @queue, $Element if $Element->isa('PPI::Node'); |
778 | } |
779 | |
780 | # If it's a structure, relink the open/close braces |
781 | next unless $Node->isa('PPI::Structure'); |
782 | Scalar::Util::weaken( |
783 | $_PARENT{refaddr($Node->start)} = $Node |
784 | ) if $Node->start; |
785 | Scalar::Util::weaken( |
786 | $_PARENT{refaddr($Node->finish)} = $Node |
787 | ) if $Node->finish; |
788 | } |
789 | |
790 | 1; |
791 | } |
792 | |
793 | 1; |
794 | |
795 | =pod |
796 | |
797 | =head1 TO DO |
798 | |
799 | - Move as much as possible to L<PPI::XS> |
800 | |
801 | =head1 SUPPORT |
802 | |
803 | See the L<support section|PPI/SUPPORT> in the main module. |
804 | |
805 | =head1 AUTHOR |
806 | |
807 | Adam Kennedy E<lt>adamk@cpan.orgE<gt> |
808 | |
809 | =head1 COPYRIGHT |
810 | |
811 | Copyright 2001 - 2009 Adam Kennedy. |
812 | |
813 | This program is free software; you can redistribute |
814 | it and/or modify it under the same terms as Perl itself. |
815 | |
816 | The full text of the license can be found in the |
817 | LICENSE file included with this module. |
818 | |
819 | =cut |