File Coverage

blib/lib/Struct/Path/PerlStyle.pm
Criterion Covered Total %
statement 148 148 100.0
branch 74 74 100.0
condition 25 25 100.0
subroutine 15 15 100.0
pod 2 2 100.0
total 264 264 100.0


line stmt bran cond sub pod time code
1             package Struct::Path::PerlStyle;
2              
3 8     8   278977 use 5.010;
  8         83  
4 8     8   47 use strict;
  8         17  
  8         262  
5 8     8   54 use warnings FATAL => 'all';
  8         17  
  8         359  
6 8     8   3639 use parent 'Exporter';
  8         2348  
  8         43  
7 8     8   4356 use utf8;
  8         105  
  8         44  
8              
9 8     8   261 use Carp 'croak';
  8         16  
  8         393  
10 8     8   4136 use Safe;
  8         298755  
  8         567  
11 8     8   5416 use Text::Balanced qw(extract_bracketed extract_quotelike);
  8         140767  
  8         836  
12 8     8   73 use re qw(is_regexp regexp_pattern);
  8         18  
  8         3547  
13              
14             require Struct::Path::PerlStyle::Functions;
15              
16             our @EXPORT_OK = qw(
17             path2str
18             str2path
19             );
20              
21             =encoding utf8
22              
23             =head1 NAME
24              
25             Struct::Path::PerlStyle - Perl-style syntax frontend for L.
26              
27             =begin html
28              
29             Travis CI
30             Coverage Status
31             CPAN version
32              
33             =end html
34              
35             =head1 VERSION
36              
37             Version 0.92
38              
39             =cut
40              
41             our $VERSION = '0.92';
42              
43             =head1 SYNOPSIS
44              
45             use Struct::Path qw(path);
46             use Struct::Path::PerlStyle qw(path2str str2path);
47              
48             my $nested = {
49             a => {
50             b => ["B0", "B1", "B2"],
51             c => ["C0", "C1"],
52             d => {},
53             },
54             };
55              
56             my @found = path($nested, str2path('{a}{}[0,2]'), deref => 1, paths => 1);
57              
58             while (@found) {
59             my $path = shift @found;
60             my $data = shift @found;
61              
62             print "path '" . path2str($path) . "' refer to '$data'\n";
63             }
64              
65             # path '{a}{b}[0]' refer to 'B0'
66             # path '{a}{b}[2]' refer to 'B2'
67             # path '{a}{c}[0]' refer to 'C0'
68              
69             =head1 EXPORT
70              
71             Nothing is exported by default.
72              
73             =head1 PATH SYNTAX
74              
75             Path is a sequence of 'steps', each represents nested level in the structure.
76              
77             =head2 Hashes
78              
79             Like in perl hash keys should be specified using curly brackets
80              
81             {} # all values from a's subhash
82             {foo} # value for 'foo' key
83             {foo,bar} # slicing: 'foo' and 'bar' values
84             {"space inside"} # key must be quoted unless it is a simple word
85             {"multi\nline"} # special characters interpolated when double quoted
86             {/pattern/mods} # keys regexp match
87              
88             =head2 Arrays
89              
90             Square brackets used for array indexes specification
91              
92             [] # all array items
93             [9] # 9-th element
94             [0,1,2,5] # slicing: 0, 1, 2 and 5 array items
95             [0..2,5] # same, but using ranges
96             [9..0] # descending ranges allowed
97              
98             =head2 Hooks
99              
100             Expressions enclosed in parenthesis treated as hooks and evaluated using
101             L compartment. Almost all perl operators and core functions available,
102             see L for more info. Some path related functions provided by
103             L.
104              
105             [](/pattern/mods) # match array values by regular expression
106             []{foo}(eq "bar" && BACK) # select hashes which have pair 'foo' => 'bar'
107              
108             There are two global variables available whithin safe compartment: C<$_> which
109             refers to value and C<%_> which provides current path via key C (in
110             L notation) and structure levels refs stack via key C.
111              
112             =head2 Aliases
113              
114             String in angle brackets is an alias - shortcut mapped into sequence of
115             steps. Aliases resolved iteratively, so alias may also refer into path with
116             another aliases.
117              
118             Aliases may be defined via global variable
119              
120             $Struct::Path::PerlStyle::ALIASES = {
121             foo => '{some}{long}{path}',
122             bar => '{and}{few}{steps}{more}'
123             };
124              
125             and then
126              
127             # expands to '{some}{long}{path}{and}{few}{steps}{more}'
128              
129             or as option for C:
130              
131             str2path('', {aliases => {foo => '{long}{path}'}});
132              
133             =head1 SUBROUTINES
134              
135             =cut
136              
137             our $ALIASES;
138              
139             my %ESCP = (
140             '"' => '\"',
141             "\a" => '\a',
142             "\b" => '\b',
143             "\t" => '\t',
144             "\n" => '\n',
145             "\f" => '\f',
146             "\r" => '\r',
147             "\e" => '\e',
148             );
149             my $ESCP = join('', sort keys %ESCP);
150              
151             my %INTP = map { $ESCP{$_} => $_ } keys %ESCP; # swap keys <-> values
152             my $INTP = join('|', map { "\Q$_\E" } sort keys %INTP);
153              
154             # $_ will be substituted (if omitted) as first arg if placed on start of
155             # hook expression
156             my $COMPL_OPS = join('|', map { "\Q$_\E" }
157             qw(< > <= => lt gt le ge == != eq ne ~~ =~));
158              
159             my $HASH_KEY_CHARS = qr/[\p{Alnum}_\.\-\+]/;
160              
161             our $HOOK_STRICT = 1;
162              
163             my $SAFE = Safe->new;
164             $SAFE->share_from(
165             'Struct::Path::PerlStyle::Functions',
166             \@Struct::Path::PerlStyle::Functions::EXPORT_OK
167             );
168             $SAFE->deny('warn');
169              
170             my $QR_MAP = {
171             '' => sub { qr/$_[0]/ },
172             i => sub { qr/$_[0]/i },
173             m => sub { qr/$_[0]/m },
174             s => sub { qr/$_[0]/s },
175             x => sub { qr/$_[0]/x },
176             im => sub { qr/$_[0]/im },
177             is => sub { qr/$_[0]/is },
178             ix => sub { qr/$_[0]/ix },
179             ms => sub { qr/$_[0]/ms },
180             mx => sub { qr/$_[0]/mx },
181             sx => sub { qr/$_[0]/sx },
182             ims => sub { qr/$_[0]/ims },
183             imx => sub { qr/$_[0]/imx },
184             isx => sub { qr/$_[0]/isx },
185             msx => sub { qr/$_[0]/msx },
186             imsx => sub { qr/$_[0]/imsx },
187             };
188              
189             =head2 str2path
190              
191             Convert perl-style string to L path structure
192              
193             $struct = str2path($string);
194              
195             =cut
196              
197             sub _push_hash {
198 74     74   158 my ($steps, $text) = @_;
199 74         135 my ($body, $delim, $mods, %step, $token, $type);
200              
201 74         162 while ($text) {
202 142         358 ($token, $text, $type, $delim, $body, $mods) =
203             (extract_quotelike($text))[0,1,3,4,5,10];
204              
205 142 100 100     10901 if (not defined $delim) { # bareword
    100 100        
    100 100        
    100 100        
206 57 100       449 push @{$step{K}}, $token = $1
  55         738  
207             if ($text =~ s/^\s*($HASH_KEY_CHARS+)//);
208             } elsif (!$type and $delim eq '"') {
209 39         222 $body =~ s/($INTP)/$INTP{$1}/gs; # interpolate
210 39         70 push @{$step{K}}, $body;
  39         112  
211             } elsif (!$type and $delim eq "'") {
212 11         19 push @{$step{K}}, $body;
  11         31  
213             } elsif ($delim eq '/' and !$type or $type eq 'm') {
214 33         113 $mods = join('', sort(split('', $mods)));
215 33         54 eval { push @{$step{K}}, $QR_MAP->{$mods}->($body) };
  33         49  
  33         132  
216 33 100       92 if ($@) {
217 3         19 (my $err = $@) =~ s/ at .+//s;
218 3         7 croak "Step #" . scalar @{$steps} . " $err";
  3         330  
219             }
220             } else { # things like qr, qw and so on
221 2         6 substr($text, 0, 0, $token);
222 2         5 undef $token;
223             }
224              
225 139 100       724 croak "Unsupported key '$text', step #" . @{$steps}
  4         577  
226             if (!defined $token);
227              
228 135         289 $text =~ s/^\s+//; # discard trailing spaces
229              
230 135 100       331 if ($text ne '') {
231 78 100       283 if ($text =~ s/^,//) {
232 71 100       195 croak "Trailing delimiter at step #" . @{$steps}
  2         218  
233             if ($text eq '');
234             } else {
235 7         19 croak "Delimiter expected before '$text', step #" . @{$steps};
  7         776  
236             }
237             }
238             }
239              
240 58         95 push @{$steps}, \%step;
  58         218  
241             }
242              
243             sub _push_hook {
244 30     30   63 my ($steps, $text) = @_;
245              
246             # substitute default value if omitted
247 30 100       357 $text =~ s/^\s*/\$_ /
248             if ($text =~ /^\s*(!\s*|not\s+)*($COMPL_OPS)/);
249              
250 30         124 my $hook = 'sub {' .
251             '$^W = 0; ' .
252             'local %_ = ("path", $_[0], "refs", $_[1]); ' .
253             'local $_ = (ref $_[1] eq "ARRAY" and @{$_[1]}) ? ${$_[1]->[-1]} : undef; ' .
254             $text .
255             '}';
256              
257 30     2   426 open (local *STDERR,'>', \(my $stderr)); # catch compilation errors
  2         16  
  2         4  
  2         13  
258              
259 30 100       1805 unless ($hook = $SAFE->reval($hook, $HOOK_STRICT)) {
260 9 100       5764 if ($stderr) {
261 1         6 $stderr =~ s/ at \(eval \d+\) .+//s;
262 1         3 $stderr = " ($stderr)";
263             } else {
264 8         18 $stderr = "";
265             }
266              
267 9         27 (my $err = $@) =~ s/ at \(eval \d+\) .+//s;
268 9         25 croak "Failed to eval hook '$text': $err, step #" . @{$steps} . $stderr;
  9         1273  
269             }
270              
271 21         14402 push @{$steps}, $hook;
  21         194  
272             }
273              
274             sub _push_list {
275 57     57   119 my ($steps, $text) = @_;
276 57         92 my (@range, @step);
277              
278 57         211 for my $i (split /\s*,\s*/, $text, -1) {
279             @range = grep {
280 69 100       211 croak "Incorrect array index '$i', step #" . @{$steps}
  7         842  
281 80 100       132 unless (eval { $_ == int($_) });
  80         431  
282             } ($i =~ /^\s*(-?\d+)\s*\.\.\s*(-?\d+)\s*$/) ? ($1, $2) : $i;
283              
284 62 100       228 push @step, $range[0] < $range[-1]
285             ? $range[0] .. $range[-1]
286             : reverse $range[-1] .. $range[0];
287             }
288              
289 50         91 push @{$steps}, \@step;
  50         169  
290             }
291              
292             sub str2path($;$) {
293 115     115 1 66425 my ($path, $opts) = @_;
294              
295 115 100       529 croak "Undefined path passed" unless (defined $path);
296              
297 114 100       307 local $ALIASES = $opts->{aliases} if (exists $opts->{aliases});
298              
299 114         197 my (@steps, $step, $type);
300              
301 114         255 while ($path) {
302             # separated match: to be able to have another brackets inside;
303             # currently mostly for hooks, for example: '( $x > $y )'
304 180         353 for ('{"}', '["]', '(")', '<">') {
305 354         936 ($step, $path) = extract_bracketed($path, $_, '');
306 354 100       38884 last if ($step);
307             }
308              
309 180 100       1361 croak "Unsupported thing in the path, step #" . @steps . ": '$path'"
310             unless ($step);
311              
312 171         420 $type = substr $step, 0, 1, ''; # remove leading bracket
313 171         298 substr $step, -1, 1, ''; # remove trailing bracket
314              
315 171 100       457 if ($type eq '{') {
    100          
    100          
316 74         199 _push_hash(\@steps, $step);
317             } elsif ($type eq '[') {
318 57         150 _push_list(\@steps, $step);
319             } elsif ($type eq '(') {
320 30         74 _push_hook(\@steps, $step);
321             } else { # <>
322 10 100       360 croak "Unknown alias '$step'" unless (exists $ALIASES->{$step});
323              
324 8         18 substr $path, 0, 0, $ALIASES->{$step};
325 8         15 redo;
326             }
327             }
328              
329 71         418 return \@steps;
330             }
331              
332             =head2 path2str
333              
334             Convert L path structure to perl-style string
335              
336             $string = path2str($struct);
337              
338             =cut
339              
340             sub path2str($) {
341 47     47 1 36745 my $path = shift;
342              
343 47 100       278 croak "Arrayref expected for path" unless (ref $path eq 'ARRAY');
344 46         89 my $out = '';
345 46         86 my $sc = 0; # step counter
346              
347 46         78 for my $step (@{$path}) {
  46         115  
348 66         113 my @items;
349              
350 66 100       197 if (ref $step eq 'ARRAY') {
    100          
351 27         39 for my $i (@{$step}) {
  27         47  
352             croak "Incorrect array index '" . ($i // 'undef') . "', step #$sc"
353 65 100 100     119 unless (eval { int($i) == $i });
  65         504  
354 62 100 100     294 if (@items and (
      100        
355             $items[-1][0] < $i and $items[-1][-1] == $i - 1 or # ascending
356             $items[-1][0] > $i and $items[-1][-1] == $i + 1 # descending
357             )) {
358 30         66 $items[-1][1] = $i; # update range
359             } else {
360 32         72 push @items, [$i]; # new range
361             }
362             }
363              
364 24         45 for (@{items}) {
365             $_ = abs($_->[0] - $_->[-1]) < 2
366 32 100       100 ? join(',', @{$_})
  21         62  
367             : "$_->[0]..$_->[-1]"
368             }
369              
370 24         65 $out .= "[" . join(",", @{items}) . "]";
371             } elsif (ref $step eq 'HASH') {
372 38         65 my $keys;
373              
374 38 100       90 if (exists $step->{K}) {
    100          
375             croak "Unsupported hash keys definition, step #$sc"
376 35 100       201 unless (ref $step->{K} eq 'ARRAY');
377             croak "Unsupported hash definition (extra keys), step #$sc"
378 34 100       52 if (keys %{$step} > 1);
  34         193  
379 33         80 $keys = $step->{K};
380 3         14 } elsif (keys %{$step}) {
381 1         226 croak "Unsupported hash definition (unknown keys), step #$sc";
382             } else {
383 2         6 $keys = [];
384             }
385              
386 35         56 for my $k (@{$keys}) {
  35         66  
387 83 100 100     774 if (is_regexp($k)) {
    100          
388 15         54 my ($patt, $mods) = regexp_pattern($k);
389 15         37 $mods =~ s/[dlu]//g; # for Perl's internal use (c) perlre
390 15         48 push @items, "/$patt/$mods";
391              
392             } elsif (defined $k and ref $k eq '') {
393 66         125 push @items, $k;
394              
395 66 100       400 unless ($k =~ /^$HASH_KEY_CHARS+$/) {
396 33         165 $items[-1] =~ s/([\Q$ESCP\E])/$ESCP{$1}/gs; # escape
397 33         107 $items[-1] = qq("$items[-1]"); # quote
398             }
399             } else {
400 2   100     214 croak "Unsupported hash key type '" .
401             (ref($k) || 'undef') . "', step #$sc"
402             }
403             }
404              
405 33         132 $out .= "{" . join(",", @items) . "}";
406             } else {
407 1         105 croak "Unsupported thing in the path, step #$sc";
408             }
409 57         131 $sc++;
410             }
411              
412 37         128 return $out;
413             }
414              
415             =head1 AUTHOR
416              
417             Michael Samoglyadov, C<< >>
418              
419             =head1 BUGS
420              
421             Please report any bugs or feature requests to
422             C, or through the web interface at
423             L. I
424             will be notified, and then you'll automatically be notified of progress on
425             your bug as I make changes.
426              
427             =head1 SUPPORT
428              
429             You can find documentation for this module with the perldoc command.
430              
431             perldoc Struct::Path::PerlStyle
432              
433             You can also look for information at:
434              
435             =over 4
436              
437             =item * RT: CPAN's request tracker (report bugs here)
438              
439             L
440              
441             =item * AnnoCPAN: Annotated CPAN documentation
442              
443             L
444              
445             =item * CPAN Ratings
446              
447             L
448              
449             =item * Search CPAN
450              
451             L
452              
453             =back
454              
455             =head1 SEE ALSO
456              
457             L, L, L
458             L, L, L
459              
460             =head1 LICENSE AND COPYRIGHT
461              
462             Copyright 2016-2019 Michael Samoglyadov.
463              
464             This program is free software; you can redistribute it and/or modify it
465             under the terms of either: the GNU General Public License as published
466             by the Free Software Foundation; or the Artistic License.
467              
468             See L for more information.
469              
470             =cut
471              
472             1; # End of Struct::Path::PerlStyle