line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# -*- mode: perl; coding: utf-8 -*- |
2
|
|
|
|
|
|
|
package YATT::LRXML::EntityPath; |
3
|
4
|
|
|
4
|
|
884
|
use strict; |
|
4
|
|
|
|
|
8
|
|
|
4
|
|
|
|
|
134
|
|
4
|
4
|
|
|
4
|
|
20
|
use warnings qw(FATAL all NONFATAL misc); |
|
4
|
|
|
|
|
8
|
|
|
4
|
|
|
|
|
255
|
|
5
|
4
|
|
|
4
|
|
20
|
BEGIN {require Exporter; *import = \&Exporter::import} |
|
4
|
|
|
|
|
11482
|
|
6
|
|
|
|
|
|
|
our @EXPORT_OK = qw(parse_entpath is_nested_entpath); |
7
|
|
|
|
|
|
|
our @EXPORT = @EXPORT_OK; |
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
=pod |
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
term ::= ( text | expr | pipeline ) ','? ; |
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
pipeline ::= container? trail+ ; |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
trail ::= var | '[' term ']' ; |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
container::= '[' term* ']' |
18
|
|
|
|
|
|
|
| '{' ( dot_name (':' text | '=' term ) |
19
|
|
|
|
|
|
|
| other+ ','? |
20
|
|
|
|
|
|
|
)* '}' ; |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
var ::= (':'+ | '.'+) name ( '(' term* ')' )? ; |
23
|
|
|
|
|
|
|
name ::= \w+ ; |
24
|
|
|
|
|
|
|
dot_name ::= [\w\.]+ ; |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
expr ::= '=' text ; |
27
|
|
|
|
|
|
|
text ::= word ( group word? )* ; -- group で始まるのは、container. |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
group ::= [\(\[\{] ( text | ',' )* [\}\]\)] |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
word ::= [\w\$\-\+\*/%<>] other* ; |
32
|
|
|
|
|
|
|
other ::= [\w\$\-\+\*/%<>:\.!=] ; |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
=cut |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
# is_nested_entpath($entpath, ?head?) |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
sub is_nested_entpath { |
39
|
50
|
50
|
33
|
50
|
0
|
337
|
return unless defined $_[0] and ref $_[0] eq 'ARRAY'; |
40
|
50
|
|
|
|
|
83
|
my $item = shift; |
41
|
50
|
100
|
66
|
|
|
441
|
return unless defined $item->[0] and ref $item->[0] eq 'ARRAY'; |
42
|
2
|
50
|
|
|
|
17
|
return 1 unless defined $_[0]; |
43
|
0
|
0
|
|
|
|
0
|
defined $item->[0][0] and $item->[0][0] eq $_[0]; |
44
|
|
|
|
|
|
|
} |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
our ($TRANS, $NODE, $ORIG); |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
sub mydie (@) { |
49
|
2
|
|
|
2
|
0
|
5
|
my $fmt = shift; |
50
|
2
|
|
|
|
|
6
|
my $diag = do { |
51
|
2
|
50
|
33
|
|
|
14
|
if ($TRANS and $NODE) { |
52
|
2
|
|
|
|
|
14
|
$TRANS->node_error($NODE, $fmt, @_); |
53
|
|
|
|
|
|
|
} else { |
54
|
0
|
|
|
|
|
0
|
sprintf $fmt, @_; |
55
|
|
|
|
|
|
|
}; |
56
|
|
|
|
|
|
|
}; |
57
|
2
|
|
|
|
|
44
|
die $diag; |
58
|
|
|
|
|
|
|
} |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
sub parse_entpath { |
61
|
272
|
|
|
272
|
0
|
38239
|
my ($pack, $orig, $trans, $node) = @_; |
62
|
272
|
100
|
|
|
|
727
|
return undef unless defined $orig; |
63
|
271
|
|
|
|
|
487
|
local $_ = $orig; |
64
|
271
|
|
|
|
|
492
|
local $ORIG = $orig; |
65
|
271
|
|
|
|
|
439
|
local $TRANS = $trans; |
66
|
271
|
|
|
|
|
396
|
local $NODE = $node; |
67
|
271
|
|
|
|
|
401
|
my @result; |
68
|
271
|
50
|
|
|
|
610
|
if (wantarray) { |
69
|
271
|
|
|
|
|
620
|
@result = &_parse_pipeline; |
70
|
|
|
|
|
|
|
} else { |
71
|
0
|
|
|
|
|
0
|
$result[0] = &_parse_pipeline; |
72
|
|
|
|
|
|
|
} |
73
|
270
|
100
|
|
|
|
633
|
if ($_ ne '') { |
74
|
1
|
|
|
|
|
8
|
mydie "Unexpected token '$_' in entpath '$orig'"; |
75
|
|
|
|
|
|
|
} |
76
|
269
|
50
|
|
|
|
1362
|
wantarray ? @result : $result[0]; |
77
|
|
|
|
|
|
|
} |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
my %open_head = qw| ( call [ array { hash |; |
80
|
|
|
|
|
|
|
my %open_rest = qw| ( call [ aref |; |
81
|
|
|
|
|
|
|
my %close_ch = qw( ( ) [ ] { } ); |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
my $re_var = qr{[:]+ (\w+) (\()?}x; |
84
|
|
|
|
|
|
|
my $re_other= qr{[\w\$\-\+\*/%<>\.=\@\|!:]}x; |
85
|
|
|
|
|
|
|
my $re_word = qr{[\w\$\-\+\*/%<>\.=\@\|!] $re_other*}x; |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
sub _parse_pipeline { |
88
|
316
|
|
|
316
|
|
404
|
my @pipe; |
89
|
316
|
100
|
|
|
|
1336
|
if (s/^ \[ //x) { |
|
|
100
|
|
|
|
|
|
90
|
|
|
|
|
|
|
# container |
91
|
6
|
|
|
|
|
27
|
push @pipe, _parse_group(['array'], ']', \&_parse_term); |
92
|
|
|
|
|
|
|
} elsif (s/^ \{ //x) { |
93
|
17
|
|
|
|
|
37
|
push @pipe, &_parse_hash; |
94
|
|
|
|
|
|
|
} |
95
|
316
|
|
|
|
|
2802
|
while (s/^$re_var | ^(\[) | ^(\{)//x) { |
96
|
361
|
100
|
|
|
|
1451
|
if ($2) { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
97
|
|
|
|
|
|
|
# '(' |
98
|
96
|
|
|
|
|
513
|
push @pipe, _parse_group([call => $1], ')', \&_parse_term); |
99
|
|
|
|
|
|
|
} elsif (defined $1) { |
100
|
|
|
|
|
|
|
# \w+ |
101
|
239
|
|
|
|
|
1771
|
push @pipe, [var => $1]; |
102
|
|
|
|
|
|
|
} elsif (defined $3) { # '[' |
103
|
24
|
|
|
|
|
97
|
push @pipe, _parse_group(['aref'], ']', \&_parse_term, 'expr'); |
104
|
|
|
|
|
|
|
} elsif (defined $4) { |
105
|
2
|
|
|
|
|
9
|
push @pipe, _parse_group(['var'], '}', \&_parse_term); |
106
|
|
|
|
|
|
|
} else { |
107
|
0
|
|
|
|
|
0
|
mydie "?? $_"; |
108
|
|
|
|
|
|
|
} |
109
|
|
|
|
|
|
|
} |
110
|
315
|
50
|
|
|
|
1148
|
wantarray ? @pipe : \@pipe; |
111
|
|
|
|
|
|
|
} |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
my $re_grend = qr{ (?=[\)\]\}]) | $ }x; |
114
|
|
|
|
|
|
|
my $re_text = qr{($re_word) # 1 |
115
|
|
|
|
|
|
|
(?: ([\(\[\{]) # 2 |
116
|
|
|
|
|
|
|
| $re_grend)? |
117
|
|
|
|
|
|
|
| $re_grend |
118
|
|
|
|
|
|
|
}x; |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
sub _parse_term { |
121
|
169
|
|
|
169
|
|
274
|
my ($literal_type) = @_; |
122
|
169
|
|
100
|
|
|
815
|
$literal_type ||= 'text'; |
123
|
|
|
|
|
|
|
# :foo() [call => foo] |
124
|
|
|
|
|
|
|
# :foo(,) [call => foo => [text => '']] |
125
|
|
|
|
|
|
|
# :foo(bar) [call => foo => [text => 'bar']] |
126
|
|
|
|
|
|
|
# :foo(,,) [call => foo => [text => ''], [text => '']] |
127
|
|
|
|
|
|
|
# :foo(bar,) [call => foo => [text => 'bar'], [text => '']] |
128
|
|
|
|
|
|
|
# :foo(bar,,)[call => foo => [text => 'bar'], [text => '']] |
129
|
169
|
100
|
|
|
|
434
|
if (s{^,}{}x) { |
130
|
8
|
|
|
|
|
28
|
return [$literal_type => '']; |
131
|
|
|
|
|
|
|
} |
132
|
161
|
100
|
|
|
|
448
|
if (my $is_expr = s{^=}{}) { |
133
|
12
|
|
|
|
|
41
|
return &_parse_expr; |
134
|
|
|
|
|
|
|
} |
135
|
149
|
|
|
|
|
187
|
my @result; |
136
|
149
|
100
|
|
|
|
2512
|
unless (s{^$re_text}{}) { |
137
|
45
|
|
|
|
|
124
|
@result = &_parse_pipeline; |
138
|
|
|
|
|
|
|
} else { |
139
|
104
|
|
|
|
|
175
|
my $result = ''; |
140
|
|
|
|
|
|
|
TEXT: { |
141
|
104
|
|
|
|
|
162
|
do { |
|
104
|
|
|
|
|
144
|
|
142
|
165
|
100
|
|
|
|
521
|
$result .= $1 if defined $1; |
143
|
165
|
50
|
|
|
|
445
|
$result .= $4 if defined $4; |
144
|
165
|
100
|
66
|
|
|
3869
|
if (my $opn = $2 || $3) { |
|
|
100
|
66
|
|
|
|
|
145
|
|
|
|
|
|
|
# open group |
146
|
4
|
|
|
|
|
11
|
$result .= $opn; |
147
|
4
|
|
|
|
|
19
|
$result .= &_parse_group_string($close_ch{$opn}); |
148
|
|
|
|
|
|
|
} elsif (not defined $1 and not defined $4) { |
149
|
59
|
|
|
|
|
238
|
last TEXT; |
150
|
|
|
|
|
|
|
} |
151
|
|
|
|
|
|
|
} while s{^(?: $re_text | ([\(\[\{]) | ([:\.]) ) }{}x; |
152
|
|
|
|
|
|
|
} |
153
|
103
|
|
|
|
|
1025
|
@result = [$literal_type => $result]; |
154
|
|
|
|
|
|
|
} |
155
|
148
|
|
|
|
|
378
|
s/^,//; |
156
|
148
|
|
|
|
|
443
|
@result; |
157
|
|
|
|
|
|
|
} |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
sub _parse_expr { |
160
|
12
|
|
|
12
|
|
34
|
my $literal_type = 'expr'; |
161
|
12
|
50
|
|
|
|
47
|
if (s{^,}{}x) { |
162
|
0
|
|
|
|
|
0
|
return [$literal_type => '']; |
163
|
|
|
|
|
|
|
} |
164
|
12
|
|
|
|
|
27
|
my $result = ''; |
165
|
|
|
|
|
|
|
TEXT: |
166
|
12
|
|
|
|
|
1441
|
while (s{^(?: $re_text | ([\(\[\{]) | ([:\.]) ) }{}x) { |
167
|
27
|
100
|
|
|
|
435
|
$result .= $1 if defined $1; |
168
|
27
|
100
|
|
|
|
92
|
$result .= $4 if defined $4; |
169
|
27
|
100
|
66
|
|
|
303
|
if (my $opn = $2 || $3) { |
|
|
100
|
100
|
|
|
|
|
170
|
|
|
|
|
|
|
# open group |
171
|
12
|
|
|
|
|
28
|
$result .= $opn; |
172
|
12
|
|
|
|
|
44
|
$result .= &_parse_group_string($close_ch{$opn}); |
173
|
|
|
|
|
|
|
} elsif (not defined $1 and not defined $4) { |
174
|
4
|
|
|
|
|
16
|
last TEXT; |
175
|
|
|
|
|
|
|
} |
176
|
|
|
|
|
|
|
} |
177
|
12
|
|
|
|
|
38
|
s/^,//; |
178
|
12
|
|
|
|
|
63
|
[$literal_type => $result]; |
179
|
|
|
|
|
|
|
} |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
sub _parse_group { |
182
|
128
|
|
|
128
|
|
365
|
my ($group, $close, $sub, @rest) = @_; |
183
|
128
|
|
|
|
|
547
|
for (my ($len, $cnt) = length($_); $_ ne ''; $len = length($_), $cnt++) { |
184
|
271
|
100
|
|
|
|
1035
|
if (s/^ ([\)\]\}])//x) { |
185
|
127
|
50
|
|
|
|
421
|
mydie "Paren mismatch: expect $close got $1 " if $1 ne $close; |
186
|
127
|
|
|
|
|
287
|
last; |
187
|
|
|
|
|
|
|
} |
188
|
144
|
|
|
|
|
359
|
my @pipe = $sub->(@rest); |
189
|
143
|
50
|
66
|
|
|
599
|
if ($cnt && $len == length($_)) { |
190
|
0
|
0
|
|
|
|
0
|
mydie "Can't match: $_" . (defined $close ? " for $close" : ""); |
191
|
|
|
|
|
|
|
} |
192
|
143
|
100
|
|
|
|
749
|
push @$group, @pipe <= 1 ? @pipe : \@pipe; |
193
|
|
|
|
|
|
|
} |
194
|
127
|
|
|
|
|
893
|
$group; |
195
|
|
|
|
|
|
|
} |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
sub _parse_group_string { |
198
|
20
|
|
|
20
|
|
46
|
my ($close) = @_; |
199
|
20
|
|
|
|
|
38
|
my $result = ''; |
200
|
20
|
|
|
|
|
83
|
for (my ($len, $prev) = length($_); $_ ne '' |
201
|
|
|
|
|
|
|
; $prev = $len, $len = length($_)) { |
202
|
47
|
100
|
|
|
|
193
|
if (s/^ ([\)\]\}])//x) { |
203
|
19
|
50
|
|
|
|
69
|
mydie "Paren mismatch: expect $close got $1 " if $1 ne $close; |
204
|
19
|
|
|
|
|
43
|
$result .= $1; |
205
|
19
|
|
|
|
|
36
|
last; |
206
|
|
|
|
|
|
|
} |
207
|
28
|
100
|
|
|
|
1613
|
if (s/^($re_word | , )//x) { |
|
|
100
|
|
|
|
|
|
208
|
22
|
|
|
|
|
63
|
$result .= $1; |
209
|
|
|
|
|
|
|
} elsif (s/^([\(\[\{])//) { |
210
|
4
|
|
|
|
|
9
|
$result .= $1; |
211
|
4
|
|
|
|
|
32
|
$result .= &_parse_group_string($close_ch{$1}); |
212
|
|
|
|
|
|
|
} |
213
|
28
|
100
|
100
|
|
|
544
|
if (defined $prev and $prev == length($_)) { |
214
|
1
|
|
|
|
|
7
|
mydie "Can't parse entity_path group $ORIG (near $_)\n" |
215
|
|
|
|
|
|
|
} |
216
|
|
|
|
|
|
|
} |
217
|
19
|
|
|
|
|
188
|
$result; |
218
|
|
|
|
|
|
|
} |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
sub _parse_hash { |
221
|
17
|
|
|
17
|
|
36
|
my @hash = ('hash'); |
222
|
17
|
|
|
|
|
59
|
for (my ($len, $cnt) = length($_); $_ ne ''; $len = length($_), $cnt++) { |
223
|
42
|
100
|
|
|
|
136
|
if (s/^ ([\)\]\}])//x) { |
224
|
17
|
50
|
|
|
|
45
|
mydie "Paren mismatch: expect \} got $1 " if $1 ne '}'; |
225
|
17
|
|
|
|
|
24
|
last; |
226
|
|
|
|
|
|
|
} |
227
|
|
|
|
|
|
|
# {!=,:var} を許すには… |
228
|
25
|
50
|
66
|
|
|
429
|
if (s/^([\w\.\-]+) [:=] //x || s/^($re_other+) ,?//x) { |
229
|
|
|
|
|
|
|
# ↑ array でも許すべきか? |
230
|
25
|
|
|
|
|
48
|
my $str = $1; |
231
|
25
|
50
|
|
|
|
89
|
push @hash, [$str =~ s/^:// ? 'var' : 'text', $str]; |
232
|
|
|
|
|
|
|
} |
233
|
25
|
|
|
|
|
61
|
my @value = &_parse_term; |
234
|
25
|
100
|
|
|
|
60
|
push @hash, @value > 1 ? \@value : $value[0]; |
235
|
25
|
50
|
|
|
|
106
|
unless (length($_) < $len) { |
236
|
0
|
|
|
|
|
0
|
mydie "Infinite loop on parse_hash: $_"; |
237
|
|
|
|
|
|
|
} |
238
|
|
|
|
|
|
|
} |
239
|
|
|
|
|
|
|
# XXX: Give more detailed diag! |
240
|
17
|
50
|
|
|
|
51
|
mydie "Odd number of hash elements" if (@hash - 1) % 2; |
241
|
17
|
|
|
|
|
41
|
\@hash; |
242
|
|
|
|
|
|
|
} |
243
|
|
|
|
|
|
|
|
244
|
|
|
|
|
|
|
1; |