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
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
|
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 |