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