File Coverage

blib/lib/Parse/Path/Role/Path.pm
Criterion Covered Total %
statement 199 264 75.3
branch 73 124 58.8
condition 17 53 32.0
subroutine 38 50 76.0
pod 0 20 0.0
total 327 511 63.9


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