line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Parse::Path::Role::Path; |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
our $VERSION = '0.92'; # VERSION |
4
|
|
|
|
|
|
|
# ABSTRACT: Role for paths |
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
############################################################################# |
7
|
|
|
|
|
|
|
# Modules |
8
|
|
|
|
|
|
|
|
9
|
6
|
|
|
6
|
|
185907
|
use Moo::Role; |
|
6
|
|
|
|
|
18
|
|
|
6
|
|
|
|
|
51
|
|
10
|
6
|
|
|
6
|
|
8817
|
use Types::Standard qw(Dict Bool Str Int Enum ArrayRef HashRef RegexpRef CodeRef Tuple Maybe Optional); |
|
6
|
|
|
|
|
651123
|
|
|
6
|
|
|
|
|
123
|
|
11
|
|
|
|
|
|
|
|
12
|
6
|
|
|
6
|
|
23200
|
use sanity; |
|
6
|
|
|
|
|
20
|
|
|
6
|
|
|
|
|
65
|
|
13
|
|
|
|
|
|
|
|
14
|
6
|
|
|
6
|
|
2939431
|
use Scalar::Util qw( blessed ); |
|
6
|
|
|
|
|
44
|
|
|
6
|
|
|
|
|
551
|
|
15
|
6
|
|
|
6
|
|
9458
|
use Storable qw( dclone ); |
|
6
|
|
|
|
|
48777
|
|
|
6
|
|
|
|
|
807
|
|
16
|
6
|
|
|
6
|
|
7386
|
use List::AllUtils qw( first all any ); |
|
6
|
|
|
|
|
6752
|
|
|
6
|
|
|
|
|
896
|
|
17
|
6
|
|
|
6
|
|
44
|
use Sub::Name; |
|
6
|
|
|
|
|
13
|
|
|
6
|
|
|
|
|
447
|
|
18
|
|
|
|
|
|
|
|
19
|
6
|
|
|
6
|
|
32
|
use namespace::clean; |
|
6
|
|
|
|
|
13
|
|
|
6
|
|
|
|
|
78
|
|
20
|
6
|
|
|
6
|
|
2895
|
no warnings 'uninitialized'; |
|
6
|
|
|
|
|
13
|
|
|
6
|
|
|
|
|
9324
|
|
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
############################################################################# |
23
|
|
|
|
|
|
|
# Overloading |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
use overload |
26
|
|
|
|
|
|
|
# with_assign (XXX: No idea why it can't use '0+') |
27
|
|
|
|
|
|
|
'+' => subname(_overload_plus => sub { |
28
|
1
|
|
|
1
|
|
833
|
my ($self, $thing, $swap) = @_; |
29
|
1
|
|
|
|
|
6
|
$self->depth + $thing; |
30
|
|
|
|
|
|
|
}), |
31
|
|
|
|
|
|
|
'-' => subname(_overload_minus => sub { |
32
|
2
|
|
|
2
|
|
1423
|
my ($self, $thing, $swap) = @_; |
33
|
2
|
50
|
|
|
|
15
|
$swap ? |
34
|
|
|
|
|
|
|
$thing - $self->depth : |
35
|
|
|
|
|
|
|
$self->depth - $thing |
36
|
|
|
|
|
|
|
; |
37
|
|
|
|
|
|
|
}), |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
# assign |
40
|
|
|
|
|
|
|
'.=' => subname(_overload_concat => sub { |
41
|
2
|
|
|
2
|
|
828
|
my ($self, $thing) = @_; |
42
|
2
|
|
|
|
|
8
|
$self->push($thing); |
43
|
2
|
|
|
|
|
10
|
$self; |
44
|
|
|
|
|
|
|
}), |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
# 3way_comparison |
47
|
|
|
|
|
|
|
'<=>' => subname(_overload_cmp_num => sub { |
48
|
14
|
|
|
14
|
|
4081
|
my ($self, $thing, $swap) = @_; |
49
|
14
|
100
|
|
|
|
49
|
$swap ? |
50
|
|
|
|
|
|
|
$thing <=> $self->depth : |
51
|
|
|
|
|
|
|
$self->depth <=> $thing |
52
|
|
|
|
|
|
|
; |
53
|
|
|
|
|
|
|
}), |
54
|
|
|
|
|
|
|
'cmp' => subname(_overload_cmp => sub { |
55
|
14
|
|
|
14
|
|
18469
|
my ($self, $thing, $swap) = @_; |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
# If both of these are Parse::Path objects, run through the key comparisons |
58
|
14
|
50
|
33
|
|
|
156
|
if (blessed $thing and $thing->does('Parse::Path::Role::Path')) { |
59
|
14
|
50
|
|
|
|
337
|
($self, $thing) = ($thing, $self) if $swap; |
60
|
|
|
|
|
|
|
|
61
|
14
|
|
|
|
|
28
|
my ($cmp, $i) = (0, 0); |
62
|
14
|
|
100
|
|
|
23
|
for (; $i <= $#{$self->_path} and $i <= $#{$thing->_path}; $i++) { |
|
53
|
|
|
|
|
254
|
|
|
49
|
|
|
|
|
213
|
|
63
|
45
|
|
|
|
|
121
|
my ($stepA, $stepB) = ($self->_path->[$i], $thing->_path->[$i]); |
64
|
45
|
50
|
33
|
|
|
659
|
my $cmp = $stepA->{type} eq 'ARRAY' && $stepB->{type} eq 'ARRAY' ? |
65
|
|
|
|
|
|
|
$stepA->{key} <=> $stepB->{key} : |
66
|
|
|
|
|
|
|
$stepA->{key} cmp $stepB->{key} |
67
|
|
|
|
|
|
|
; |
68
|
|
|
|
|
|
|
|
69
|
45
|
100
|
|
|
|
1204
|
return $cmp if $cmp; |
70
|
|
|
|
|
|
|
} |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
# Now it's down to step counts |
73
|
8
|
|
|
|
|
24
|
return $self->step_count <=> $thing->step_count; |
74
|
|
|
|
|
|
|
} |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
# Fallback to string comparison |
77
|
0
|
0
|
|
|
|
0
|
return $swap ? |
78
|
|
|
|
|
|
|
$thing cmp $self->as_string : |
79
|
|
|
|
|
|
|
$self->as_string cmp $thing |
80
|
|
|
|
|
|
|
; |
81
|
|
|
|
|
|
|
}), |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
# conversion |
84
|
1
|
|
|
1
|
|
719
|
'bool' => subname(_overload_bool => sub { !!shift->step_count }), |
85
|
1
|
|
|
1
|
|
1102
|
'""' => subname(_overload_string => sub { shift->as_string }), |
86
|
0
|
|
|
0
|
|
0
|
'0+' => subname(_overload_numify => sub { shift->depth }), |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
# dereferencing |
89
|
1
|
|
|
1
|
|
921
|
'${}' => subname(_overload_scalar => sub { \(shift->as_string) }), |
90
|
1
|
|
|
1
|
|
963
|
'@{}' => subname(_overload_array => sub { shift->as_array }), |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
# special |
93
|
0
|
|
|
0
|
|
0
|
'=' => subname(_overload_clone => sub { shift->clone }) |
94
|
6
|
|
|
6
|
|
49
|
; |
|
6
|
|
|
|
|
13
|
|
|
6
|
|
|
|
|
497
|
|
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
############################################################################# |
97
|
|
|
|
|
|
|
# Requirements |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
requires '_build_blueprint'; |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
# One-time validation for speed |
102
|
|
|
|
|
|
|
my $BLUEPRINT_VALIDATED = 0; |
103
|
|
|
|
|
|
|
my $_blueprint_type = Dict[ |
104
|
|
|
|
|
|
|
hash_step_regexp => RegexpRef, |
105
|
|
|
|
|
|
|
array_step_regexp => RegexpRef, |
106
|
|
|
|
|
|
|
delimiter_regexp => RegexpRef, |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
unescape_translation => ArrayRef[Tuple[RegexpRef, CodeRef]], |
109
|
|
|
|
|
|
|
pos_translation => ArrayRef[Tuple[RegexpRef, Str]], |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
delimiter_placement => HashRef[Str], |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
array_key_sprintf => Str, |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
hash_key_stringification => ArrayRef[Tuple[RegexpRef, Str, Optional[CodeRef]]] |
116
|
|
|
|
|
|
|
]; |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
has _blueprint => ( |
119
|
|
|
|
|
|
|
is => 'ro', |
120
|
|
|
|
|
|
|
builder => '_build_blueprint', |
121
|
|
|
|
|
|
|
lazy => 1, |
122
|
|
|
|
|
|
|
init_arg => undef, |
123
|
|
|
|
|
|
|
isa => sub { |
124
|
|
|
|
|
|
|
return 1 if $BLUEPRINT_VALIDATED; |
125
|
|
|
|
|
|
|
$_blueprint_type->assert_valid($_[0]); |
126
|
|
|
|
|
|
|
$BLUEPRINT_VALIDATED = 1; |
127
|
|
|
|
|
|
|
}, |
128
|
|
|
|
|
|
|
); |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
############################################################################# |
131
|
|
|
|
|
|
|
# Attributes |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
# NOTE: hot attr; bypass isa |
134
|
|
|
|
|
|
|
has _path => ( |
135
|
|
|
|
|
|
|
is => 'rw', |
136
|
|
|
|
|
|
|
#isa => ArrayRef[Dict[ |
137
|
|
|
|
|
|
|
# type => Enum[qw( ARRAY HASH )], |
138
|
|
|
|
|
|
|
# key => Str, |
139
|
|
|
|
|
|
|
# step => Str, |
140
|
|
|
|
|
|
|
# pos => Int, |
141
|
|
|
|
|
|
|
#]], |
142
|
|
|
|
|
|
|
predicate => 1, |
143
|
|
|
|
|
|
|
); |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
has _tmp_path_thing => ( |
146
|
|
|
|
|
|
|
is => 'ro', |
147
|
|
|
|
|
|
|
init_arg => 'path', |
148
|
|
|
|
|
|
|
required => 1, |
149
|
|
|
|
|
|
|
clearer => 1, |
150
|
|
|
|
|
|
|
); |
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
has auto_normalize => ( |
153
|
|
|
|
|
|
|
is => 'rw', |
154
|
|
|
|
|
|
|
isa => Bool, |
155
|
|
|
|
|
|
|
default => sub { 0 }, |
156
|
|
|
|
|
|
|
); |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
has auto_cleanup => ( |
159
|
|
|
|
|
|
|
is => 'rw', |
160
|
|
|
|
|
|
|
isa => Bool, |
161
|
|
|
|
|
|
|
default => sub { 0 }, |
162
|
|
|
|
|
|
|
); |
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
############################################################################# |
165
|
|
|
|
|
|
|
# Pre/post-BUILD |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
sub BUILD { |
168
|
81
|
|
|
81
|
0
|
18529
|
my $self = $_[0]; |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
# Post-build coercion of path |
171
|
81
|
100
|
|
|
|
435
|
unless ($self->_has_path) { |
172
|
80
|
|
|
|
|
343
|
my $path_array = $self->_coerce_step( $self->_tmp_path_thing ); |
173
|
|
|
|
|
|
|
|
174
|
54
|
|
|
|
|
5788
|
$self->_path( $path_array ); |
175
|
54
|
100
|
100
|
|
|
208
|
$self->cleanup if ($self->auto_cleanup and @$path_array); |
176
|
|
|
|
|
|
|
} |
177
|
53
|
|
|
|
|
6300
|
$self->_clear_tmp_path_thing; # ...and may it never return... |
178
|
|
|
|
|
|
|
|
179
|
53
|
|
|
|
|
8230
|
return $self; |
180
|
|
|
|
|
|
|
} |
181
|
|
|
|
|
|
|
|
182
|
|
|
|
|
|
|
############################################################################# |
183
|
|
|
|
|
|
|
# Methods |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
# XXX: The array-based methods makes internal CORE calls ambiguous |
186
|
6
|
|
|
6
|
|
6505
|
no warnings 'ambiguous'; |
|
6
|
|
|
|
|
15
|
|
|
6
|
|
|
|
|
56642
|
|
187
|
|
|
|
|
|
|
|
188
|
276
|
|
|
276
|
0
|
319
|
sub step_count { scalar @{shift->_path}; } |
|
276
|
|
|
|
|
1801
|
|
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
sub depth { |
191
|
17
|
|
|
17
|
0
|
25
|
my $self = shift; |
192
|
|
|
|
|
|
|
|
193
|
17
|
|
|
|
|
20
|
my $depth; |
194
|
17
|
|
|
|
|
26
|
foreach my $step_hash (@{$self->_path}) { |
|
17
|
|
|
|
|
50
|
|
195
|
84
|
|
|
|
|
129
|
my $pos = $step_hash->{pos}; |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
# Process depth |
198
|
84
|
50
|
|
|
|
392
|
if ($pos =~ /^(\d+)$/) { $depth = $1; } # absolute |
|
0
|
50
|
|
|
|
0
|
|
199
|
84
|
|
|
|
|
188
|
elsif ($pos =~ /^X([+\-]\d+)$/) { $depth += $1; } # relative |
200
|
|
|
|
|
|
|
else { # WTF is this? |
201
|
0
|
|
|
|
|
0
|
die sprintf("Found unparsable pos: %s (step: %s)", $pos, $step_hash->{step}); |
202
|
|
|
|
|
|
|
} |
203
|
|
|
|
|
|
|
} |
204
|
|
|
|
|
|
|
|
205
|
17
|
|
|
|
|
99
|
return $depth; |
206
|
|
|
|
|
|
|
} |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
sub is_absolute { |
209
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
210
|
0
|
0
|
|
|
|
0
|
$self->step_count ? $self->_path->[0]{pos} !~ /^X/ : undef; |
211
|
|
|
|
|
|
|
} |
212
|
|
|
|
|
|
|
|
213
|
2
|
|
|
2
|
0
|
196
|
sub as_array { dclone(shift->_path) } |
214
|
0
|
|
|
0
|
0
|
0
|
sub blueprint { dclone(shift->_blueprint) } |
215
|
|
|
|
|
|
|
|
216
|
0
|
|
|
0
|
0
|
0
|
sub shift { {%{ shift @{shift->_path} }} } |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
217
|
0
|
|
|
0
|
0
|
0
|
sub pop { {%{ pop @{shift->_path} }} } |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
218
|
|
|
|
|
|
|
sub unshift { |
219
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
220
|
0
|
|
|
|
|
0
|
my $step_hashs = $self->_coerce_step([@_]); |
221
|
|
|
|
|
|
|
|
222
|
0
|
|
|
|
|
0
|
my $return = unshift @{$self->_path}, @$step_hashs; |
|
0
|
|
|
|
|
0
|
|
223
|
0
|
0
|
0
|
|
|
0
|
$self->cleanup if ($self->auto_cleanup and @$step_hashs); |
224
|
0
|
|
|
|
|
0
|
return $return; |
225
|
|
|
|
|
|
|
} |
226
|
|
|
|
|
|
|
sub push { |
227
|
2
|
|
|
2
|
0
|
5
|
my $self = shift; |
228
|
2
|
|
|
|
|
10
|
my $step_hashs = $self->_coerce_step([@_]); |
229
|
|
|
|
|
|
|
|
230
|
2
|
|
|
|
|
4
|
my $return = push @{$self->_path}, @$step_hashs; |
|
2
|
|
|
|
|
10
|
|
231
|
2
|
50
|
33
|
|
|
9
|
$self->cleanup if ($self->auto_cleanup and @$step_hashs); |
232
|
2
|
|
|
|
|
70
|
return $return; |
233
|
|
|
|
|
|
|
} |
234
|
|
|
|
|
|
|
sub splice { |
235
|
0
|
|
|
0
|
0
|
0
|
my ($self, $offset, $length) = (shift, shift, shift); |
236
|
0
|
|
|
|
|
0
|
my $step_hashs = $self->_coerce_step([@_]); |
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
# Perl syntax getting retardo here... |
239
|
0
|
0
|
|
|
|
0
|
my @params = ( $offset, defined $length ? ($length, @$step_hashs) : () ); |
240
|
0
|
|
|
|
|
0
|
my @return = splice( @{$self->_path}, @params ); |
|
0
|
|
|
|
|
0
|
|
241
|
|
|
|
|
|
|
#my $return = splice( @{$self->_path}, $offset, (defined $length ? ($length, @$step_hashs) : ()) ); |
242
|
|
|
|
|
|
|
|
243
|
0
|
0
|
0
|
|
|
0
|
$self->cleanup if ($self->auto_cleanup and defined $length and @$step_hashs); |
|
|
|
0
|
|
|
|
|
244
|
0
|
0
|
|
|
|
0
|
return (wantarray ? {%{ $return[-1] }} : @{ dclone(\@return) }); |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
245
|
|
|
|
|
|
|
} |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
sub clear { |
248
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
249
|
0
|
|
|
|
|
0
|
$self->_path([]); |
250
|
0
|
|
|
|
|
0
|
return $self; |
251
|
|
|
|
|
|
|
} |
252
|
|
|
|
|
|
|
sub replace { |
253
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
254
|
0
|
|
|
|
|
0
|
$self->clear->push(@_); |
255
|
|
|
|
|
|
|
} |
256
|
|
|
|
|
|
|
|
257
|
|
|
|
|
|
|
sub clone { |
258
|
1
|
|
|
1
|
0
|
1446
|
my $self = shift; |
259
|
|
|
|
|
|
|
|
260
|
|
|
|
|
|
|
# if an argument is passed, assume it's a path |
261
|
1
|
50
|
|
|
|
145
|
my %path_args = @_ ? ( |
262
|
|
|
|
|
|
|
path => shift, |
263
|
|
|
|
|
|
|
) : ( |
264
|
|
|
|
|
|
|
_path => dclone($self->_path), |
265
|
|
|
|
|
|
|
path => '', # ignored |
266
|
|
|
|
|
|
|
); |
267
|
|
|
|
|
|
|
|
268
|
1
|
|
|
|
|
10
|
$self->new( |
269
|
|
|
|
|
|
|
%path_args, |
270
|
|
|
|
|
|
|
auto_normalize => $self->auto_normalize, |
271
|
|
|
|
|
|
|
auto_cleanup => $self->auto_cleanup, |
272
|
|
|
|
|
|
|
); |
273
|
|
|
|
|
|
|
} |
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
sub normalize { |
276
|
0
|
|
|
0
|
0
|
0
|
my $self = $_[0]; |
277
|
0
|
|
|
|
|
0
|
$self->_normalize( $self->_path ); |
278
|
0
|
|
|
|
|
0
|
return $self; |
279
|
|
|
|
|
|
|
} |
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
sub _normalize { |
282
|
29
|
|
|
29
|
|
52
|
my ($self, $path_array) = @_; |
283
|
|
|
|
|
|
|
|
284
|
|
|
|
|
|
|
# For normalization, can't trust the original step, so we make new ones |
285
|
29
|
|
|
|
|
66
|
my $new_array = []; |
286
|
29
|
|
|
|
|
72
|
foreach my $item (@$path_array) { |
287
|
90
|
|
|
|
|
330
|
push @$new_array, $self->key2hash( @$item{qw(key type pos)} ); |
288
|
|
|
|
|
|
|
} |
289
|
|
|
|
|
|
|
|
290
|
29
|
|
|
|
|
186
|
return $new_array; |
291
|
|
|
|
|
|
|
} |
292
|
|
|
|
|
|
|
|
293
|
|
|
|
|
|
|
sub cleanup { |
294
|
24
|
|
|
24
|
0
|
1714
|
my $self = $_[0]; |
295
|
24
|
|
|
|
|
57
|
my $path = $self->_path; |
296
|
24
|
|
|
|
|
42
|
my $new_path = []; |
297
|
|
|
|
|
|
|
|
298
|
24
|
|
|
|
|
34
|
my ($old_pos, $old_type); |
299
|
24
|
|
|
|
|
62
|
foreach my $step_hash (@$path) { |
300
|
73
|
|
|
|
|
116
|
my $full_pos = $step_hash->{pos}; |
301
|
|
|
|
|
|
|
|
302
|
|
|
|
|
|
|
# Process pos |
303
|
73
|
|
|
|
|
81
|
my ($pos, $type); |
304
|
73
|
100
|
|
|
|
454
|
if ($full_pos =~ /^(\d+)$/) { ($pos, $type) = ($1, 'A'); } # absolute |
|
13
|
50
|
|
|
|
40
|
|
305
|
60
|
|
|
|
|
131
|
elsif ($full_pos =~ /^X([+\-]\d+)$/) { ($pos, $type) = ($1, 'R'); } # relative |
306
|
|
|
|
|
|
|
else { # WTF is this? |
307
|
0
|
|
|
|
|
0
|
die sprintf("During path cleanup, found unparsable pos: %s (step: %s)", $full_pos, $step_hash->{step}); |
308
|
|
|
|
|
|
|
} |
309
|
73
|
|
|
|
|
727
|
$pos = int($pos); |
310
|
|
|
|
|
|
|
|
311
|
|
|
|
|
|
|
### XXX: We may not need this level of complexity if we are only using 0, 1, X-1, X-0, X+1 |
312
|
|
|
|
|
|
|
|
313
|
73
|
|
|
|
|
483
|
my $new_step_hash = { %$step_hash }; |
314
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
# The most important pos is the first one |
316
|
73
|
100
|
|
|
|
199
|
unless (defined $old_pos) { |
317
|
24
|
|
|
|
|
33
|
$old_pos = $pos; |
318
|
24
|
|
|
|
|
32
|
$old_type = $type; |
319
|
|
|
|
|
|
|
|
320
|
24
|
|
|
|
|
43
|
push(@$new_path, $new_step_hash); |
321
|
24
|
|
|
|
|
54
|
$new_step_hash->{pos} = $step_hash->{pos}; |
322
|
24
|
|
|
|
|
64
|
next; |
323
|
|
|
|
|
|
|
} |
324
|
|
|
|
|
|
|
|
325
|
|
|
|
|
|
|
# Relative is going to continue the status quo |
326
|
49
|
50
|
|
|
|
159
|
if ($type eq 'R') { |
|
|
0
|
|
|
|
|
|
327
|
49
|
|
|
|
|
61
|
$old_pos += $pos; |
328
|
49
|
100
|
|
|
|
509
|
$new_step_hash->{pos} = $old_type eq 'A' ? $old_pos : sprintf 'X%+d', $pos; |
329
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
# Don't use the pos for placement. Follow the chain of the index, using the array offset. |
331
|
|
|
|
|
|
|
# IOW, if it started out with something like X+3, we won't end up with a bunch of starter blanks. |
332
|
49
|
|
|
|
|
77
|
my $array_index = $#$new_path + $pos; |
333
|
|
|
|
|
|
|
|
334
|
|
|
|
|
|
|
# If the index ends up in the negative, we can't clean it up yet. |
335
|
49
|
100
|
|
|
|
138
|
if ($array_index < 0) { |
|
|
100
|
|
|
|
|
|
336
|
4
|
100
|
|
|
|
16
|
if ($old_type eq 'A') { |
337
|
|
|
|
|
|
|
# An absolute path should never go into the negative index (ie: /..) |
338
|
2
|
|
|
|
|
40
|
die sprintf("During path cleanup, an absolute path dropped into a negative depth (full path: %s)", $self->as_string); |
339
|
|
|
|
|
|
|
} |
340
|
|
|
|
|
|
|
|
341
|
2
|
|
|
|
|
7
|
push(@$new_path, $new_step_hash); |
342
|
|
|
|
|
|
|
} |
343
|
|
|
|
|
|
|
# Backtracking |
344
|
|
|
|
|
|
|
elsif ($pos <= 0) { |
345
|
|
|
|
|
|
|
# If the slicing would carve off past the end, just append and move on... |
346
|
8
|
50
|
|
|
|
21
|
if (@$new_path < abs($pos)) { |
347
|
0
|
|
|
|
|
0
|
push(@$new_path, $new_step_hash); |
348
|
0
|
|
|
|
|
0
|
next; |
349
|
|
|
|
|
|
|
} |
350
|
|
|
|
|
|
|
|
351
|
|
|
|
|
|
|
# Just ignore zero-pos (ie: /./) |
352
|
8
|
100
|
|
|
|
36
|
next unless $pos; |
353
|
|
|
|
|
|
|
|
354
|
|
|
|
|
|
|
# Carve off a slice of the $new_path |
355
|
4
|
|
|
|
|
13
|
my @back_path = splice(@$new_path, $pos); |
356
|
|
|
|
|
|
|
|
357
|
|
|
|
|
|
|
# If any of the steps in the path are a relative negative, we have to keep all of them. |
358
|
4
|
100
|
|
4
|
|
43
|
if (any { $_->{pos} =~ /^X-/ } @back_path) { push(@$new_path, @back_path, $new_step_hash); } |
|
4
|
|
|
|
|
31
|
|
|
2
|
|
|
|
|
12
|
|
359
|
|
|
|
|
|
|
|
360
|
|
|
|
|
|
|
# Otherwise, we won't save this virtual step, and trash the slice. |
361
|
|
|
|
|
|
|
} |
362
|
|
|
|
|
|
|
# Moving ahead |
363
|
|
|
|
|
|
|
else { |
364
|
37
|
|
|
|
|
175
|
$new_path->[$array_index] = $new_step_hash; |
365
|
|
|
|
|
|
|
} |
366
|
|
|
|
|
|
|
} |
367
|
|
|
|
|
|
|
# Absolute is a bit more error prone... |
368
|
|
|
|
|
|
|
elsif ($type eq 'A') { |
369
|
0
|
0
|
|
|
|
0
|
if ($old_type eq 'R') { |
370
|
|
|
|
|
|
|
# What the hell is ..\C:\ ? |
371
|
0
|
|
|
|
|
0
|
die sprintf("During path cleanup, a relative path found an illegal absolute step (full path: %s)", $self->as_string); |
372
|
|
|
|
|
|
|
} |
373
|
|
|
|
|
|
|
|
374
|
|
|
|
|
|
|
# Now this is just A/A, which is rarer, but still legal |
375
|
0
|
|
|
|
|
0
|
$new_step_hash->{pos} = $old_pos = $pos; |
376
|
0
|
|
|
|
|
0
|
$new_path->[$pos] = $new_step_hash; |
377
|
|
|
|
|
|
|
} |
378
|
|
|
|
|
|
|
} |
379
|
|
|
|
|
|
|
|
380
|
|
|
|
|
|
|
# Replace |
381
|
22
|
|
|
|
|
68
|
$self->_path( $new_path ); |
382
|
|
|
|
|
|
|
|
383
|
22
|
|
|
|
|
108
|
return $self; |
384
|
|
|
|
|
|
|
} |
385
|
|
|
|
|
|
|
|
386
|
|
|
|
|
|
|
sub _coerce_step { |
387
|
86
|
|
|
86
|
|
165
|
my ($self, $thing) = @_; |
388
|
|
|
|
|
|
|
|
389
|
|
|
|
|
|
|
# A string step/path to be converted to a HASH step |
390
|
86
|
100
|
33
|
|
|
242
|
unless (ref $thing) { |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
391
|
83
|
|
|
|
|
973
|
my $path_array = $self->path_str2array($thing); |
392
|
57
|
100
|
|
|
|
240
|
return $path_array unless $self->auto_normalize; |
393
|
29
|
|
|
|
|
5522
|
return $self->_normalize($path_array); |
394
|
|
|
|
|
|
|
} |
395
|
|
|
|
|
|
|
|
396
|
|
|
|
|
|
|
# Another DP path object |
397
|
|
|
|
|
|
|
elsif (blessed $thing and $thing->does('Parse::Path::Role::Path')) { |
398
|
|
|
|
|
|
|
# If the class is the same, it's the same type of path and we can do a |
399
|
|
|
|
|
|
|
# direct transfer. And only if the path is normalized, or we don't care |
400
|
|
|
|
|
|
|
# about it. |
401
|
0
|
0
|
0
|
|
|
0
|
return dclone($thing->_path) if ( |
|
|
|
0
|
|
|
|
|
402
|
|
|
|
|
|
|
$thing->isa($self) and |
403
|
|
|
|
|
|
|
$thing->auto_normalize || !$self->auto_normalize |
404
|
|
|
|
|
|
|
); |
405
|
|
|
|
|
|
|
|
406
|
0
|
|
|
|
|
0
|
return $self->_normalize($thing->_path); |
407
|
|
|
|
|
|
|
} |
408
|
|
|
|
|
|
|
|
409
|
|
|
|
|
|
|
# WTF is this? |
410
|
|
|
|
|
|
|
elsif (blessed $thing) { |
411
|
0
|
|
|
|
|
0
|
die sprintf( "Found incoercible %s step (blessed)", blessed $thing ); |
412
|
|
|
|
|
|
|
} |
413
|
|
|
|
|
|
|
|
414
|
|
|
|
|
|
|
# A potential HASH step |
415
|
|
|
|
|
|
|
elsif (ref $thing eq 'HASH') { |
416
|
0
|
|
|
|
|
0
|
die 'Found incoercible HASH step with ref values' |
417
|
0
|
0
|
|
|
|
0
|
if (grep { ref $_ } values %$thing); |
418
|
|
|
|
|
|
|
|
419
|
0
|
0
|
|
0
|
|
0
|
if ( all { exists $thing->{$_} } qw(key type step pos) ) { |
|
0
|
|
|
|
|
0
|
|
420
|
|
|
|
|
|
|
# We have no idea what data is in $thing, so we just soft clone it into |
421
|
|
|
|
|
|
|
# something else. Our own methods will bypass the validation if we |
422
|
|
|
|
|
|
|
# pass the right thing, by accessing _path directly. |
423
|
|
|
|
|
|
|
return [{ |
424
|
0
|
|
|
|
|
0
|
type => $thing->{type}, |
425
|
|
|
|
|
|
|
key => $thing->{key}, |
426
|
|
|
|
|
|
|
step => $thing->{step}, |
427
|
|
|
|
|
|
|
pos => $thing->{pos}, |
428
|
|
|
|
|
|
|
}]; |
429
|
|
|
|
|
|
|
} |
430
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
# It's better to have a key/type pair than a step |
432
|
0
|
0
|
0
|
|
|
0
|
if (exists $thing->{key} and exists $thing->{type}) { |
433
|
0
|
|
|
|
|
0
|
my $step_hash = $self->key2hash( @$thing{qw(key type pos)} ); |
434
|
0
|
|
|
|
|
0
|
return [ $step_hash ]; |
435
|
|
|
|
|
|
|
} |
436
|
|
|
|
|
|
|
|
437
|
0
|
0
|
|
|
|
0
|
return $self->path_str2array( $thing->{step} ) if (exists $thing->{step}); |
438
|
|
|
|
|
|
|
|
439
|
0
|
|
|
|
|
0
|
die 'Found incoercible HASH step with wrong keys/data'; |
440
|
|
|
|
|
|
|
} |
441
|
|
|
|
|
|
|
|
442
|
|
|
|
|
|
|
# A collection of HASH steps? |
443
|
|
|
|
|
|
|
elsif (ref $thing eq 'ARRAY') { |
444
|
3
|
|
|
|
|
4
|
my $path_array = []; |
445
|
3
|
|
|
|
|
9
|
foreach my $item (@$thing) { |
446
|
4
|
|
|
|
|
21
|
my $step_hash = $self->_coerce_step($item); |
447
|
4
|
50
|
|
|
|
122
|
push @$path_array, (ref $step_hash eq 'ARRAY') ? @$step_hash : $step_hash; |
448
|
|
|
|
|
|
|
} |
449
|
|
|
|
|
|
|
|
450
|
3
|
|
|
|
|
7
|
return $path_array; |
451
|
|
|
|
|
|
|
} |
452
|
|
|
|
|
|
|
|
453
|
|
|
|
|
|
|
# WTF is this? |
454
|
|
|
|
|
|
|
else { |
455
|
0
|
|
|
|
|
0
|
die sprintf( "Found incoercible %s step", ref $thing ); |
456
|
|
|
|
|
|
|
} |
457
|
|
|
|
|
|
|
} |
458
|
|
|
|
|
|
|
|
459
|
|
|
|
|
|
|
sub key2hash { |
460
|
90
|
|
|
90
|
0
|
176
|
my ($self, $key, $type, $pos) = @_; |
461
|
|
|
|
|
|
|
|
462
|
|
|
|
|
|
|
# Sanity checks |
463
|
90
|
50
|
|
|
|
300
|
die sprintf( "type not HASH or ARRAY (found %s)", $type ) |
464
|
|
|
|
|
|
|
unless ($type =~ /^HASH$|^ARRAY$/); |
465
|
|
|
|
|
|
|
|
466
|
90
|
|
|
|
|
272
|
my $bp = $self->_blueprint; |
467
|
90
|
|
|
|
|
3510
|
my $hash_bp = $bp->{hash_key_stringification}; |
468
|
90
|
|
|
|
|
136
|
my $hash_re = $bp->{hash_step_regexp}; |
469
|
90
|
|
|
|
|
128
|
my $array_re = $bp->{array_step_regexp}; |
470
|
|
|
|
|
|
|
|
471
|
|
|
|
|
|
|
# Transform the key to a string step |
472
|
90
|
|
|
|
|
128
|
my $step = $key; |
473
|
90
|
100
|
|
|
|
193
|
if ($type eq 'HASH') { |
474
|
87
|
|
|
103
|
|
380
|
my $tuple = first { $step =~ $_->[0] } @$hash_bp; |
|
103
|
|
|
|
|
505
|
|
475
|
87
|
50
|
|
|
|
406
|
die "Cannot match stringification for hash step; hash_step_stringification is not setup right!" unless $tuple; |
476
|
|
|
|
|
|
|
|
477
|
87
|
100
|
|
|
|
214
|
$step = $tuple->[2]->($step) if $tuple->[2]; |
478
|
87
|
|
|
|
|
373
|
$step = sprintf ($tuple->[1], $step); |
479
|
|
|
|
|
|
|
} |
480
|
|
|
|
|
|
|
else { |
481
|
3
|
|
|
|
|
13
|
$step = sprintf ($bp->{array_key_sprintf}, $step); |
482
|
|
|
|
|
|
|
} |
483
|
|
|
|
|
|
|
|
484
|
|
|
|
|
|
|
# Validate the new step |
485
|
90
|
50
|
33
|
|
|
1340
|
if ( |
|
|
|
66
|
|
|
|
|
|
|
|
33
|
|
|
|
|
486
|
|
|
|
|
|
|
$type eq 'HASH' and $step !~ /^$hash_re$/ || |
487
|
|
|
|
|
|
|
$type eq 'ARRAY' and $step !~ /^$array_re$/ |
488
|
|
|
|
|
|
|
) { |
489
|
0
|
|
0
|
|
|
0
|
die sprintf( "Found %s key than didn't validate against regexp: '%s' --> '%s' (pos: %s)", $type, $key, $step, $pos // '???' ); |
490
|
|
|
|
|
|
|
} |
491
|
|
|
|
|
|
|
|
492
|
|
|
|
|
|
|
return { |
493
|
90
|
|
33
|
|
|
719
|
type => $type, |
494
|
|
|
|
|
|
|
key => $key, |
495
|
|
|
|
|
|
|
step => $step, |
496
|
|
|
|
|
|
|
### XXX: No +delimiter in latter case. Not our fault; doing the best we can with the data we've got! ### |
497
|
|
|
|
|
|
|
pos => $pos // $self->_find_pos($step), |
498
|
|
|
|
|
|
|
}; |
499
|
|
|
|
|
|
|
} |
500
|
|
|
|
|
|
|
|
501
|
|
|
|
|
|
|
sub path_str2array { |
502
|
83
|
|
|
83
|
0
|
149
|
my ($self, $path) = @_; |
503
|
83
|
|
|
|
|
154
|
my $path_array = []; |
504
|
|
|
|
|
|
|
|
505
|
83
|
|
|
|
|
244
|
while (length $path) { |
506
|
235
|
|
|
|
|
664
|
my $step_hash = $self->shift_path_str(\$path); |
507
|
|
|
|
|
|
|
|
508
|
209
|
|
|
|
|
393
|
push(@$path_array, $step_hash); |
509
|
209
|
50
|
|
|
|
756
|
die sprintf( "In path '%s', too deep down the rabbit hole, stopped at '%s'", $_[1], $path ) |
510
|
|
|
|
|
|
|
if (@$path_array > 255); |
511
|
|
|
|
|
|
|
}; |
512
|
|
|
|
|
|
|
|
513
|
57
|
|
|
|
|
142
|
return $path_array; |
514
|
|
|
|
|
|
|
} |
515
|
|
|
|
|
|
|
|
516
|
|
|
|
|
|
|
sub _find_pos { |
517
|
217
|
|
|
217
|
|
370
|
my ($self, $step_plus_delimiter) = @_; |
518
|
|
|
|
|
|
|
|
519
|
|
|
|
|
|
|
# Find a matching pos key |
520
|
217
|
|
|
|
|
934
|
my $dt = $self->_blueprint->{pos_translation}; |
521
|
|
|
|
|
|
|
|
522
|
217
|
|
|
423
|
|
7709
|
my $tuple = first { $step_plus_delimiter =~ $_->[0] } @$dt; |
|
423
|
|
|
|
|
1785
|
|
523
|
217
|
50
|
|
|
|
910
|
die "Cannot match a position for step; pos_translation is not setup right!" unless $tuple; |
524
|
|
|
|
|
|
|
|
525
|
217
|
|
|
|
|
693
|
return $tuple->[1]; |
526
|
|
|
|
|
|
|
} |
527
|
|
|
|
|
|
|
|
528
|
|
|
|
|
|
|
sub shift_path_str { |
529
|
235
|
|
|
235
|
0
|
338
|
my ($self, $pathref) = @_; |
530
|
|
|
|
|
|
|
|
531
|
235
|
|
|
|
|
383
|
my $orig_path = $$pathref; |
532
|
|
|
|
|
|
|
|
533
|
235
|
|
|
|
|
729
|
my $bp = $self->_blueprint; |
534
|
235
|
|
|
|
|
34675
|
my $hash_re = $bp->{hash_step_regexp}; |
535
|
235
|
|
|
|
|
441
|
my $array_re = $bp->{array_step_regexp}; |
536
|
235
|
|
|
|
|
331
|
my $delim_re = $bp->{delimiter_regexp}; |
537
|
|
|
|
|
|
|
|
538
|
235
|
|
|
|
|
275
|
my $step_hash; |
539
|
|
|
|
|
|
|
# Array first because hash could have zero-length string |
540
|
235
|
100
|
|
|
|
3004
|
if ($$pathref =~ s/^(?<step>$array_re)//) { |
|
|
100
|
|
|
|
|
|
541
|
24
|
|
|
|
|
294
|
$step_hash = { |
542
|
|
|
|
|
|
|
type => 'ARRAY', |
543
|
|
|
|
|
|
|
key => $+{key}, |
544
|
|
|
|
|
|
|
step => $+{step}, |
545
|
|
|
|
|
|
|
}; |
546
|
|
|
|
|
|
|
} |
547
|
|
|
|
|
|
|
elsif ($$pathref =~ s/^(?<step>$hash_re)//) { |
548
|
193
|
|
|
|
|
4469
|
$step_hash = { |
549
|
|
|
|
|
|
|
type => 'HASH', |
550
|
|
|
|
|
|
|
key => $+{key}, |
551
|
|
|
|
|
|
|
step => $+{step}, |
552
|
|
|
|
|
|
|
}; |
553
|
|
|
|
|
|
|
|
554
|
|
|
|
|
|
|
# Support quote escaping |
555
|
193
|
|
|
|
|
895
|
my $ut = $self->_blueprint->{unescape_translation}; |
556
|
193
|
|
|
91
|
|
7775
|
my $tuple = first { $+{quote} =~ $_->[0] } @$ut; |
|
91
|
|
|
|
|
719
|
|
557
|
193
|
100
|
|
|
|
922
|
$step_hash->{key} = $tuple->[1]->($step_hash->{key}) if defined $tuple; |
558
|
|
|
|
|
|
|
} |
559
|
|
|
|
|
|
|
else { |
560
|
18
|
|
|
|
|
529
|
die sprintf( "Found unparsable step: '%s'", $$pathref ); |
561
|
|
|
|
|
|
|
} |
562
|
|
|
|
|
|
|
|
563
|
217
|
|
|
|
|
1383
|
$$pathref =~ s/^($delim_re)//; |
564
|
|
|
|
|
|
|
|
565
|
|
|
|
|
|
|
# Re-piece the step + delimiter to use with _find_pos |
566
|
217
|
|
|
|
|
1235
|
$step_hash->{pos} = $self->_find_pos( $step_hash->{step}.$1 ); |
567
|
|
|
|
|
|
|
|
568
|
|
|
|
|
|
|
# If the path is not shifting at all, then something is wrong with REs |
569
|
217
|
100
|
|
|
|
681
|
if (length $$pathref == length $orig_path) { |
570
|
8
|
|
|
|
|
277
|
die sprintf( "Found unshiftable step: '%s'", $$pathref ); |
571
|
|
|
|
|
|
|
} |
572
|
|
|
|
|
|
|
|
573
|
209
|
|
|
|
|
586
|
return $step_hash; |
574
|
|
|
|
|
|
|
} |
575
|
|
|
|
|
|
|
|
576
|
|
|
|
|
|
|
sub as_string { |
577
|
59
|
|
|
59
|
0
|
35833
|
my $self = $_[0]; |
578
|
|
|
|
|
|
|
|
579
|
59
|
|
|
|
|
258
|
my $dlp = $self->_blueprint->{delimiter_placement}; |
580
|
|
|
|
|
|
|
|
581
|
59
|
|
|
|
|
6199
|
my $str = ''; |
582
|
59
|
|
|
|
|
219
|
for my $i (0 .. $self->step_count - 1) { |
583
|
200
|
|
|
|
|
420
|
my $step_hash = $self->_path->[$i]; |
584
|
200
|
100
|
|
|
|
445
|
my $next_step = ($i == $self->step_count - 1) ? undef : $self->_path->[$i+1]; |
585
|
|
|
|
|
|
|
|
586
|
200
|
|
|
|
|
370
|
my $d = $step_hash->{pos}; |
587
|
|
|
|
|
|
|
|
588
|
|
|
|
|
|
|
### Left side delimiter placement |
589
|
200
|
50
|
66
|
|
|
1093
|
if ( exists $dlp->{$d.'L'}) { $str .= $dlp->{$d.'L'}; } # pos-specific |
|
0
|
50
|
|
|
|
0
|
|
590
|
0
|
|
|
|
|
0
|
elsif (not $next_step and exists $dlp->{'-1L'} ) { $str .= $dlp->{'-1L'}; } # ending pos |
591
|
|
|
|
|
|
|
|
592
|
|
|
|
|
|
|
# Add the step |
593
|
200
|
|
|
|
|
405
|
$str .= $step_hash->{step}; |
594
|
|
|
|
|
|
|
|
595
|
|
|
|
|
|
|
### Right side delimiter placement |
596
|
200
|
|
|
|
|
416
|
my $L = substr($step_hash->{type}, 0, 1); |
597
|
200
|
100
|
|
|
|
565
|
if (exists $dlp->{$d.'R'}) { # pos-specific (supercedes other right side options) |
|
|
100
|
|
|
|
|
|
598
|
13
|
|
|
|
|
42
|
$str .= $dlp->{$d.'R'}; |
599
|
|
|
|
|
|
|
} |
600
|
|
|
|
|
|
|
elsif ($next_step) { # ref-specific |
601
|
133
|
|
|
|
|
249
|
my $R = substr($next_step->{type}, 0, 1); |
602
|
133
|
100
|
|
|
|
566
|
$str .= $dlp->{$L.$R} if (exists $dlp->{$L.$R}); |
603
|
|
|
|
|
|
|
} |
604
|
|
|
|
|
|
|
else { # ending pos |
605
|
54
|
50
|
|
|
|
373
|
if (exists $dlp->{'-1R'}) { $str .= $dlp->{'-1R'}; } # pos-specific |
|
0
|
50
|
|
|
|
0
|
|
606
|
0
|
|
|
|
|
0
|
elsif (exists $dlp->{$L}) { $str .= $dlp->{$L}; } # ref-specific |
607
|
|
|
|
|
|
|
} |
608
|
|
|
|
|
|
|
} |
609
|
|
|
|
|
|
|
|
610
|
59
|
|
|
|
|
437
|
return $str; |
611
|
|
|
|
|
|
|
} |
612
|
|
|
|
|
|
|
|
613
|
|
|
|
|
|
|
42; |
614
|
|
|
|
|
|
|
|
615
|
|
|
|
|
|
|
__END__ |
616
|
|
|
|
|
|
|
|
617
|
|
|
|
|
|
|
=pod |
618
|
|
|
|
|
|
|
|
619
|
|
|
|
|
|
|
=encoding utf-8 |
620
|
|
|
|
|
|
|
|
621
|
|
|
|
|
|
|
=head1 NAME |
622
|
|
|
|
|
|
|
|
623
|
|
|
|
|
|
|
Parse::Path::Role::Path - Role for paths |
624
|
|
|
|
|
|
|
|
625
|
|
|
|
|
|
|
=head1 SYNOPSIS |
626
|
|
|
|
|
|
|
|
627
|
|
|
|
|
|
|
package Parse::Path::MyNewPath; |
628
|
|
|
|
|
|
|
|
629
|
|
|
|
|
|
|
use Moo; |
630
|
|
|
|
|
|
|
|
631
|
|
|
|
|
|
|
with 'Parse::Path::Role::Path'; |
632
|
|
|
|
|
|
|
|
633
|
|
|
|
|
|
|
sub _build_blueprint { { |
634
|
|
|
|
|
|
|
hash_step_regexp => qr/(?<key>\w+)|(?<quote>")(?<key>[^"]+)(?<quote>")/, |
635
|
|
|
|
|
|
|
array_step_regexp => qr/\[(?<key>\d{1,5})\]/, |
636
|
|
|
|
|
|
|
delimiter_regexp => qr/(?:\.|(?=\[))/, |
637
|
|
|
|
|
|
|
|
638
|
|
|
|
|
|
|
unescape_translation => [], |
639
|
|
|
|
|
|
|
|
640
|
|
|
|
|
|
|
pos_translation => [ |
641
|
|
|
|
|
|
|
[qr/.?/, 'X+1'], |
642
|
|
|
|
|
|
|
], |
643
|
|
|
|
|
|
|
|
644
|
|
|
|
|
|
|
delimiter_placement => { |
645
|
|
|
|
|
|
|
HH => '.', |
646
|
|
|
|
|
|
|
AH => '.', |
647
|
|
|
|
|
|
|
}, |
648
|
|
|
|
|
|
|
|
649
|
|
|
|
|
|
|
array_key_sprintf => '[%u]', |
650
|
|
|
|
|
|
|
hash_key_stringification => [ |
651
|
|
|
|
|
|
|
[qr/.?/, '%s'], |
652
|
|
|
|
|
|
|
], |
653
|
|
|
|
|
|
|
} } |
654
|
|
|
|
|
|
|
|
655
|
|
|
|
|
|
|
=head1 DESCRIPTION |
656
|
|
|
|
|
|
|
|
657
|
|
|
|
|
|
|
This is the base role for L<Parse::Path> and contains 95% of the code. The idea behind the path classes is that they should be able to |
658
|
|
|
|
|
|
|
get by with a single blueprint and little to no changes to the main methods. |
659
|
|
|
|
|
|
|
|
660
|
|
|
|
|
|
|
=head1 BLUEPRINT |
661
|
|
|
|
|
|
|
|
662
|
|
|
|
|
|
|
The blueprint L<class attribute|MooX::ClassAttribute> is a hashref of various properties (built using C<<< _build_blueprint >>>) that detail |
663
|
|
|
|
|
|
|
how the path is parsed and put back together. All properties are required, though some can be turned off. |
664
|
|
|
|
|
|
|
|
665
|
|
|
|
|
|
|
=head2 Path parsing |
666
|
|
|
|
|
|
|
|
667
|
|
|
|
|
|
|
=head3 hash_step_regexp |
668
|
|
|
|
|
|
|
|
669
|
|
|
|
|
|
|
hash_step_regexp => qr/(?<key>\w+)|(?<quote>")(?<key>[^"]+)(?<quote>")/ |
670
|
|
|
|
|
|
|
|
671
|
|
|
|
|
|
|
Regular expression for parsing a hash step. This should be a compiled RE, with a named capture called C<<< key >>>. Optionally, a C<<< quote >>> |
672
|
|
|
|
|
|
|
capture can be added for quoting capabilities. |
673
|
|
|
|
|
|
|
|
674
|
|
|
|
|
|
|
Zero-length strings are acceptable if the RE allows for it. In some cases, ZLS are needed for root paths, ie: a delimiter as the |
675
|
|
|
|
|
|
|
first character of a path. |
676
|
|
|
|
|
|
|
|
677
|
|
|
|
|
|
|
BeginningE<sol>ending markers should not be used, as they will be applied as needed. |
678
|
|
|
|
|
|
|
|
679
|
|
|
|
|
|
|
=head3 array_step_regexp |
680
|
|
|
|
|
|
|
|
681
|
|
|
|
|
|
|
array_step_regexp => qr/\[(?<key>\d{1,5})\]/ |
682
|
|
|
|
|
|
|
array_step_regexp => qr/\Z.\A/ # no-op; turn off array support |
683
|
|
|
|
|
|
|
|
684
|
|
|
|
|
|
|
Regular expression for parsing an array step. This should be a compiled RE, with a named capture called C<<< key >>>. Non-digits are not |
685
|
|
|
|
|
|
|
recommended, and really don't make sense in the scope of an array. Also, the RE should have some sort of digit limit to prevent |
686
|
|
|
|
|
|
|
overly sparse arrays. (See L<Parse::Path/Sparse arrays and memory usage>.) |
687
|
|
|
|
|
|
|
|
688
|
|
|
|
|
|
|
Arrays are checked first, as hashs could have zero-length strings. Arrays should B<not> have zero-length strings, since they should |
689
|
|
|
|
|
|
|
match some sort of digit. |
690
|
|
|
|
|
|
|
|
691
|
|
|
|
|
|
|
Paths that don't use arrays still require a RE, but can use a no-op like the one above. |
692
|
|
|
|
|
|
|
|
693
|
|
|
|
|
|
|
=head3 delimiter_regexp |
694
|
|
|
|
|
|
|
|
695
|
|
|
|
|
|
|
delimiter_regexp => qr/(?:\.|(?=\[))/ |
696
|
|
|
|
|
|
|
|
697
|
|
|
|
|
|
|
Regular expression for parsing path delimiter. This is always parsed after the hashE<sol>array step. |
698
|
|
|
|
|
|
|
|
699
|
|
|
|
|
|
|
=head3 unescape_translation |
700
|
|
|
|
|
|
|
|
701
|
|
|
|
|
|
|
unescape_translation => [ |
702
|
|
|
|
|
|
|
[qr/\"/, \&String::Escape::unbackslash], |
703
|
|
|
|
|
|
|
[qr/\'/, sub { my $str = $_[0]; $str =~ s|\\([\'\\])|$1|g; $str; }], |
704
|
|
|
|
|
|
|
], |
705
|
|
|
|
|
|
|
|
706
|
|
|
|
|
|
|
unescape_translation => [] # turn off unescape support |
707
|
|
|
|
|
|
|
|
708
|
|
|
|
|
|
|
Arrayref-of-arrayrefs used to unescape special characters in a key. Acts like a hashref, but is protected from Regexp |
709
|
|
|
|
|
|
|
stringification. The first value is a regular expression matching the C<<< quote >>> capture (from L</hash_step_regexp>). The value is a |
710
|
|
|
|
|
|
|
coderef of a subroutine that unescapes the string, as a single parameter in and out. |
711
|
|
|
|
|
|
|
|
712
|
|
|
|
|
|
|
As this is a "hashref", multiple subs are supported. This is useful for allowing single quotes in literal strings (with a smaller |
713
|
|
|
|
|
|
|
subset of escape characters) and double quotes in strings that allow full escaping. |
714
|
|
|
|
|
|
|
|
715
|
|
|
|
|
|
|
If quotes and escapes are used, the L</hash_step_regexp> needs to be smart enough to handle all cases of quote escaping. (See the |
716
|
|
|
|
|
|
|
code in L<Parse::Path::DZIL> for an example.) |
717
|
|
|
|
|
|
|
|
718
|
|
|
|
|
|
|
Unescape support can be turned off by using an empty array. (But, the blueprint key still needs to exist.) |
719
|
|
|
|
|
|
|
|
720
|
|
|
|
|
|
|
=head3 pos_translation |
721
|
|
|
|
|
|
|
|
722
|
|
|
|
|
|
|
pos_translation => [ |
723
|
|
|
|
|
|
|
[qr{^/+$}, 0], |
724
|
|
|
|
|
|
|
[qr{^\.\./*$}, 'X-1'], |
725
|
|
|
|
|
|
|
[qr{^\./*$}, 'X-0'], |
726
|
|
|
|
|
|
|
[qr{.?}, 'X+1'], |
727
|
|
|
|
|
|
|
], |
728
|
|
|
|
|
|
|
|
729
|
|
|
|
|
|
|
Arrayref-of-arrayrefs used for pos translation. Acts like a hashref, but is protected from Regexp stringification. These are the |
730
|
|
|
|
|
|
|
absolute and relative identifers of the path. The "key" is a regular expression matching both the path step and right-side delimiter |
731
|
|
|
|
|
|
|
(extracted from L<shift_path_str|Parse::Path/shift_path_str>). |
732
|
|
|
|
|
|
|
|
733
|
|
|
|
|
|
|
The value meanings are as follows: |
734
|
|
|
|
|
|
|
|
735
|
|
|
|
|
|
|
X+# = Forward relative path |
736
|
|
|
|
|
|
|
X-0 = Stationary relative path (like . for file-based paths) |
737
|
|
|
|
|
|
|
X-# = Backward relative path |
738
|
|
|
|
|
|
|
# = Absolute path (# = step position) |
739
|
|
|
|
|
|
|
|
740
|
|
|
|
|
|
|
One of these REs B<must> match, or the parser will die when it finds one it can't parse. Thus, it's advisable to have a "default" |
741
|
|
|
|
|
|
|
RE like C<<< qr/.?/ >>>. |
742
|
|
|
|
|
|
|
|
743
|
|
|
|
|
|
|
Don't assume the RHS delimiter is going to be there. There may be cases where it's missing (like if L<key2hash|Parse::Path/key2hash> |
744
|
|
|
|
|
|
|
was not passed a C<<< pos >>>). |
745
|
|
|
|
|
|
|
|
746
|
|
|
|
|
|
|
If the path doesn't have relativeE<sol>absolute steps, it should be defined with a default of C<<< X+1 >>>. |
747
|
|
|
|
|
|
|
|
748
|
|
|
|
|
|
|
=head2 Path stringification |
749
|
|
|
|
|
|
|
|
750
|
|
|
|
|
|
|
=head3 delimiter_placement |
751
|
|
|
|
|
|
|
|
752
|
|
|
|
|
|
|
delimiter_placement => { |
753
|
|
|
|
|
|
|
'0R' => '/', |
754
|
|
|
|
|
|
|
HH => '.', |
755
|
|
|
|
|
|
|
AH => '.', |
756
|
|
|
|
|
|
|
}, |
757
|
|
|
|
|
|
|
|
758
|
|
|
|
|
|
|
Hashref used for delimiter placement. The keys have the following meanings: |
759
|
|
|
|
|
|
|
|
760
|
|
|
|
|
|
|
##[LR] = Position-specific placement, either on the left or right side of the step. |
761
|
|
|
|
|
|
|
Position can also be '-1' for the end of the path. |
762
|
|
|
|
|
|
|
|
763
|
|
|
|
|
|
|
[AH][AH] = Type-specific placement in-between the two types (ie: AH means an array on the left side |
764
|
|
|
|
|
|
|
and a hash on the right). |
765
|
|
|
|
|
|
|
|
766
|
|
|
|
|
|
|
[AH] = Type-specific placement for the end of the path. |
767
|
|
|
|
|
|
|
|
768
|
|
|
|
|
|
|
The value is the delimiter used in the placement. |
769
|
|
|
|
|
|
|
|
770
|
|
|
|
|
|
|
=head3 array_key_sprintf |
771
|
|
|
|
|
|
|
|
772
|
|
|
|
|
|
|
array_key_sprintf => '[%u]' |
773
|
|
|
|
|
|
|
array_key_sprintf => '' # turn off array support |
774
|
|
|
|
|
|
|
|
775
|
|
|
|
|
|
|
String for L<sprintf|http://perldoc.perl.org/functions/sprintf.html> that stringifies an array key to a step in the path. |
776
|
|
|
|
|
|
|
|
777
|
|
|
|
|
|
|
=head3 hash_key_stringification |
778
|
|
|
|
|
|
|
|
779
|
|
|
|
|
|
|
hash_key_stringification => [ |
780
|
|
|
|
|
|
|
[qr/[^\"]+/, '"%s"' => \&String::Escape::backslash], |
781
|
|
|
|
|
|
|
[qr/\W|^$/, "'%s'" => sub { my $str = $_[0]; $str =~ s|([\'\\])|\\$1|g; $str; }], |
782
|
|
|
|
|
|
|
[qr/.?/, '%s'], |
783
|
|
|
|
|
|
|
], |
784
|
|
|
|
|
|
|
|
785
|
|
|
|
|
|
|
Arrayref-of-arrayrefs used for stringification of a hash key to a step in the path. The internal arrayref is composed of three |
786
|
|
|
|
|
|
|
pieces: |
787
|
|
|
|
|
|
|
|
788
|
|
|
|
|
|
|
1 => RegexpRef = Matched against the hash key |
789
|
|
|
|
|
|
|
2 => Str = String for sprintf used for stringification |
790
|
|
|
|
|
|
|
3 => CodeRef = (Optional) Sub used to transform key prior to sprintf call |
791
|
|
|
|
|
|
|
|
792
|
|
|
|
|
|
|
The third piece is typically used for backslashification. Using multiple REs, you can add in different conditions for different |
793
|
|
|
|
|
|
|
kinds of quoting. |
794
|
|
|
|
|
|
|
|
795
|
|
|
|
|
|
|
=head1 CAVEATS |
796
|
|
|
|
|
|
|
|
797
|
|
|
|
|
|
|
See L<Parse::Path/CAVEATS>. |
798
|
|
|
|
|
|
|
|
799
|
|
|
|
|
|
|
=head1 AVAILABILITY |
800
|
|
|
|
|
|
|
|
801
|
|
|
|
|
|
|
The project homepage is L<https://github.com/SineSwiper/Parse-Path/wiki>. |
802
|
|
|
|
|
|
|
|
803
|
|
|
|
|
|
|
The latest version of this module is available from the Comprehensive Perl |
804
|
|
|
|
|
|
|
Archive Network (CPAN). Visit L<http://www.perl.com/CPAN/> to find a CPAN |
805
|
|
|
|
|
|
|
site near you, or see L<https://metacpan.org/module/Parse::Path/>. |
806
|
|
|
|
|
|
|
|
807
|
|
|
|
|
|
|
=head1 AUTHOR |
808
|
|
|
|
|
|
|
|
809
|
|
|
|
|
|
|
Brendan Byrd <bbyrd@cpan.org> |
810
|
|
|
|
|
|
|
|
811
|
|
|
|
|
|
|
=head1 COPYRIGHT AND LICENSE |
812
|
|
|
|
|
|
|
|
813
|
|
|
|
|
|
|
This software is Copyright (c) 2013 by Brendan Byrd. |
814
|
|
|
|
|
|
|
|
815
|
|
|
|
|
|
|
This is free software, licensed under: |
816
|
|
|
|
|
|
|
|
817
|
|
|
|
|
|
|
The Artistic License 2.0 (GPL Compatible) |
818
|
|
|
|
|
|
|
|
819
|
|
|
|
|
|
|
=cut |