File Coverage

web/cgi-bin/yatt.lib/YATT/LRXML/EntityPath.pm
Criterion Covered Total %
statement 109 116 93.9
branch 69 90 76.6
condition 22 32 68.7
subroutine 12 12 100.0
pod 0 3 0.0
total 212 253 83.7


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;