File Coverage

blib/lib/Catmandu/Path/simple.pm
Criterion Covered Total %
statement 165 193 85.4
branch 47 60 78.3
condition 15 15 100.0
subroutine 17 18 94.4
pod 3 4 75.0
total 247 290 85.1


line stmt bran cond sub pod time code
1              
2             use Catmandu::Sane;
3 94     94   88498  
  94         260  
  94         784  
4             our $VERSION = '1.2019';
5              
6             use Catmandu::Util
7             qw(is_hash_ref is_array_ref is_value is_natural is_code_ref trim);
8 94     94   620 use Moo;
  94         175  
  94         6015  
9 94     94   519 use namespace::clean;
  94         175  
  94         641  
10 94     94   34364  
  94         199  
  94         640  
11             with 'Catmandu::Path', 'Catmandu::Emit';
12              
13             use overload '""' => sub {$_[0]->path};
14 94     94   36457  
  94     0   215  
  94         912  
  0         0  
15             my ($self) = @_;
16             my $path = $self->path;
17 626     626 0 1016 if (is_value($path)) {
18 626         1323 $path = trim($path);
19 626 50       1731 $path =~ s/^\$[\.\/]//;
20 626         1689 $path = [map {s/\\(?=[\.\/])//g; $_} split /(?<!\\)[\.\/]/, $path];
21 626         1079 return $path;
22 626         2003 }
  804         1219  
  804         1927  
23 626         1458 if (is_array_ref($path)) {
24             return $path;
25 0 0       0 }
26 0         0 Catmandu::Error->throw("path should be a string or arrayref of strings");
27             }
28 0         0  
29             my ($self) = @_;
30             my $path = $self->split_path;
31             my $data_var = $self->_generate_var;
32 174     174 1 31307 my $vals_var = $self->_generate_var;
33 174         404  
34 174         521 my $body = $self->_emit_declare_vars($vals_var, '[]') . $self->_emit_get(
35 174         374 $data_var,
36             $path,
37             sub {
38             my ($var, %opts) = @_;
39              
40             # looping goes backwards to keep deletions safe
41 181     181   478 "unshift(\@{${vals_var}}, ${var});";
42             },
43             ) . "return ${vals_var};";
44 181         867  
45             $self->_eval_sub($body, args => [$data_var]);
46 174         503 }
47              
48 174         998 my $self = shift;
49             my %opts = @_ == 1 ? (value => $_[0]) : @_;
50             my $path = $self->split_path;
51             my $key = pop @$path;
52 71     71 1 5100 my $data_var = $self->_generate_var;
53 71 50       237 my $val_var = $self->_generate_var;
54 71         161 my $captures = {};
55 71         130 my $args = [$data_var];
56 71         226  
57 71         146 my $body = $self->_emit_get(
58 71         116 $data_var,
59 71         118 $path,
60             sub {
61             my $var = $_[0];
62             my $val;
63             if (is_code_ref($opts{value})) {
64             $captures->{$val_var} = $opts{value};
65 71     71   116 $val = "${val_var}->(${var}, ${data_var})";
66 71         118 }
67 71 100       257 elsif (exists $opts{value}) {
    50          
68 10         22 $captures->{$val_var} = $opts{value};
69 10         22 $val = $val_var;
70             }
71             else {
72 61         142 push @$args, $val_var;
73 61         102 $val
74             = "is_code_ref(${val_var}) ? ${val_var}->(${var}, ${data_var}) : ${val_var}";
75             }
76 0         0  
77 0         0 $self->_emit_set_key($var, $key, $val);
78             },
79             ) . "return ${data_var};";
80              
81 71         166 $self->_eval_sub($body, args => $args, captures => $captures);
82             }
83 71         398  
84             my ($self, %opts) = @_;
85 71         475 my $path = $self->split_path;
86             my $data_var = $self->_generate_var;
87             my $captures = {};
88             my $args = [$data_var];
89             my $cb;
90              
91             if (my $tests = $opts{if}) {
92             $cb = sub {
93             my ($var, %opts) = @_;
94             my $perl = "";
95             for (my $i = 0; $i < @$tests; $i += 2) {
96             my $test = $tests->[$i];
97             my $val = $tests->[$i + 1];
98             my $test_var = $self->_generate_var;
99             my $val_var = $self->_generate_var;
100             $captures->{$test_var} = $test;
101             $captures->{$val_var} = $val;
102             if ($i) {
103             $perl .= 'els';
104             }
105             $perl
106             .= "if (List::Util::any {\$_->(${var})} \@{${test_var}}) {"
107             . $self->_emit_assign_cb($var, $val_var, %opts) . '}';
108             }
109             $perl;
110             };
111             }
112             else {
113             my $val_var = $self->_generate_var;
114             if (my $val = $opts{value}) {
115             $captures->{$val_var} = $val;
116             }
117             else {
118             push @$args, $val_var;
119             }
120             $cb = sub {
121             my ($var, %opts) = @_;
122             $self->_emit_assign_cb($var, $val_var, %opts);
123             };
124             }
125              
126             my $body
127             = $self->_emit_get($data_var, $path, $cb) . "return ${data_var};";
128              
129             $self->_eval_sub($body, args => $args, captures => $captures);
130             }
131              
132             my ($self, %opts) = @_;
133             my $path = $self->split_path;
134             my $data_var = $self->_generate_var;
135             my $val_var = $self->_generate_var;
136             my $captures = {};
137             my $args = [$data_var];
138             my $cb;
139              
140             if (is_code_ref($opts{value})) {
141             $captures->{$val_var} = $opts{value};
142             $cb = sub {
143             my $var = $_[0];
144             "${var} = ${val_var}->(${var}, ${data_var});";
145             };
146             }
147             elsif (exists $opts{value}) {
148             $captures->{$val_var} = $opts{value};
149             $cb = sub {
150             my $var = $_[0];
151             "${var} = ${val_var};";
152             };
153             }
154             else {
155             push @$args, $val_var;
156             $cb = sub {
157             my $var = $_[0];
158             "if (is_code_ref(${val_var})) {"
159             . "${var} = ${val_var}->(${var}, ${data_var});"
160             . '} else {'
161             . "${var} = ${val_var};" . '}';
162             };
163             }
164              
165             my $body = $self->_emit_create_path($data_var, $path, $cb);
166              
167             $body .= "return ${data_var};";
168              
169             $self->_eval_sub($body, args => $args, captures => $captures);
170             }
171              
172             my ($self) = @_;
173             my $path = $self->split_path;
174             my $key = pop @$path;
175             my $data_var = $self->_generate_var;
176              
177             my $body = $self->_emit_get(
178             $data_var,
179 40     40 1 1085 $path,
180 40         78 sub {
181 40         71 my $var = $_[0];
182 40         101 $self->_emit_delete_key($var, $key);
183             }
184             ) . "return ${data_var};";
185              
186             $self->_eval_sub($body, args => [$data_var]);
187             }
188 40     40   54  
189 40         79 my ($self, $var, $path, $cb, %opts) = @_;
190              
191 40         149 @$path || return $cb->($var, %opts);
192              
193 40         171 $path = [@$path];
194              
195             my $key = shift @$path;
196             my $str_key = $self->_emit_string($key);
197 881     881   2332 my $perl = "";
198              
199 881 100       2412 %opts = (up_var => my $up_var = $var);
200             $var = $self->_generate_var;
201 437         861  
202             if (is_natural($key)) {
203 437         765 $perl
204 437         1153 .= "if (is_hash_ref(${up_var}) && exists(${up_var}->{${str_key}})) {";
205 437         679 $perl .= "my ${var} = ${up_var}->{${str_key}};";
206             $perl .= $self->_emit_get($var, $path, $cb, %opts, key => $str_key);
207 437         1048 $perl
208 437         917 .= "} elsif (is_array_ref(${up_var}) && \@{${up_var}} > ${key}) {";
209             $perl .= "my ${var} = ${up_var}->[${key}];";
210 437 100       1129 $perl .= $self->_emit_get($var, $path, $cb, %opts, index => $key);
    100          
211 8         22 $perl .= "}";
212             }
213 8         18 elsif ($key eq '*') {
214 8         30 $perl .= "if (is_array_ref(${up_var})) {";
215 8         20 $perl .= $self->_emit_iterate_array(
216             $up_var,
217 8         18 sub {
218 8         43 my ($v, %opts) = @_;
219 8         14 "my ${var} = ${v};"
220             . $self->_emit_get($var, $path, $cb, %opts);
221             }
222 37         120 );
223             $perl .= "}";
224             }
225             else {
226 37     37   140 if ($key eq '$first') {
227 37         284 $opts{index} = 0;
228             $perl .= "if (is_array_ref(${up_var}) && \@{${up_var}}) {";
229             $perl .= "my ${var} = ${up_var}->[0];";
230 37         299 }
231 37         172 elsif ($key eq '$last') {
232             $opts{index} = my $i = $self->_generate_var;
233             $perl .= "if (is_array_ref(${up_var}) && \@{${up_var}}) {";
234 392 100       1164 $perl .= $self->_emit_declare_vars($i, "\@{${up_var}} - 1");
    100          
235 1         2 $perl .= "my ${var} = ${up_var}->[${i}];";
236 1         4 }
237 1         3 else {
238             $opts{key} = $str_key;
239             $perl
240 1         2 .= "if (is_hash_ref(${up_var}) && exists(${up_var}->{${str_key}})) {";
241 1         4 $perl .= "my ${var} = ${up_var}->{${str_key}};";
242 1         3 }
243 1         3 $perl .= $self->_emit_get($var, $path, $cb, %opts);
244             $perl .= "}";
245             }
246 390         775  
247 390         1123 $perl;
248             }
249 390         1010  
250             my ($self, $var, $key, $val) = @_;
251 392         2163  
252 392         714 return "${var} = $val;" unless defined $key;
253              
254             my $perl = "";
255 437         1634 my $str_key = $self->_emit_string($key);
256              
257             if (is_natural($key)) {
258             $perl .= "if (is_hash_ref(${var})) {";
259 71     71   142 $perl .= "${var}->{${str_key}} = $val;";
260             $perl .= "} elsif (is_array_ref(${var})) {";
261 71 50       166 $perl .= "${var}->[${key}] = $val;";
262             $perl .= "}";
263 71         131 }
264 71         218 elsif ($key eq '$first') {
265             $perl .= "if (is_array_ref(${var})) {";
266 71 50       197 $perl .= "${var}->[0] = $val;";
    50          
    50          
    50          
    50          
    50          
267 0         0 $perl .= "}";
268 0         0 }
269 0         0 elsif ($key eq '$last') {
270 0         0 $perl .= "if (is_array_ref(${var})) {";
271 0         0 $perl .= "${var}->[\@{${var}} - 1] = $val;";
272             $perl .= "}";
273             }
274 0         0 elsif ($key eq '$prepend') {
275 0         0 $perl .= "if (is_array_ref(${var})) {";
276 0         0 $perl .= "unshift(\@{${var}}, $val);";
277             $perl .= "}";
278             }
279 0         0 elsif ($key eq '$append') {
280 0         0 $perl .= "if (is_array_ref(${var})) {";
281 0         0 $perl .= "push(\@{${var}}, $val);";
282             $perl .= "}";
283             }
284 0         0 elsif ($key eq '*') {
285 0         0 my $i = $self->_generate_var;
286 0         0 $perl .= "if (is_array_ref(${var})) {";
287             $perl .= "for (my ${i} = 0; ${i} < \@{${var}}; ${i}++) {";
288             $perl .= "${var}->[${i}] = $val;";
289 0         0 $perl .= "}}";
290 0         0 }
291 0         0 else {
292             $perl .= "if (is_hash_ref(${var})) {";
293             $perl .= "${var}->{${str_key}} = $val;";
294 0         0 $perl .= "}";
295 0         0 }
296 0         0  
297 0         0 $perl;
298 0         0 }
299              
300             my ($self, $var, $path, $cb) = @_;
301 71         173  
302 71         161 @$path || return $cb->($var);
303 71         102  
304             my $key = shift @$path;
305             my $str_key = $self->_emit_string($key);
306 71         267 my $perl = "";
307              
308             if (is_natural($key)) {
309             my $v1 = $self->_generate_var;
310 463     463   861 my $v2 = $self->_generate_var;
311             $perl .= "if (is_hash_ref(${var})) {";
312 463 100       1003 $perl .= "my ${v1} = ${var};";
313             $perl
314 263         424 .= $self->_emit_create_path("${v1}->{${str_key}}", [@$path], $cb);
315 263         680 $perl .= "} elsif (is_maybe_array_ref(${var})) {";
316 263         422 $perl .= "my ${v2} = ${var} //= [];";
317             $perl .= $self->_emit_create_path("${v2}->[${key}]", [@$path], $cb);
318 263 100       521 $perl .= "}";
    100          
319 9         25 }
320 9         18 elsif ($key eq '*') {
321 9         20 my $v1 = $self->_generate_var;
322 9         22 my $v2 = $self->_generate_var;
323 9         42 $perl .= "if (is_array_ref(${var})) {";
324             $perl .= "my ${v1} = ${var};";
325 9         24  
326 9         21 # loop backwards so that deletions are safe
327 9         28 $perl .= "for (my ${v2} = \@{${v1}} - 1; $v2 >= 0; ${v2}--) {";
328 9         15 $perl .= $self->_emit_create_path("${v1}->[${v2}]", $path, $cb);
329             $perl .= "}";
330             $perl .= "}";
331 1         3 }
332 1         3 else {
333 1         4 my $v = $self->_generate_var;
334 1         4 if ( $key eq '$first'
335             || $key eq '$last'
336             || $key eq '$prepend'
337 1         4 || $key eq '$append')
338 1         4 {
339 1         3 $perl .= "if (is_maybe_array_ref(${var})) {";
340 1         2 $perl .= "my ${v} = ${var} //= [];";
341             if ($key eq '$first') {
342             $perl .= $self->_emit_create_path("${v}->[0]", $path, $cb);
343 253         602 }
344 253 100 100     1527 elsif ($key eq '$last') {
      100        
      100        
345             $perl .= "if (\@${v}) {";
346             $perl .= $self->_emit_create_path("${v}->[\@${v} - 1]",
347             [@$path], $cb);
348             $perl .= "} else {";
349 26         77 $perl .= $self->_emit_create_path("${v}->[0]", [@$path], $cb);
350 26         65 $perl .= "}";
351 26 100       119 }
    100          
    100          
    50          
352 1         5 elsif ($key eq '$prepend') {
353             $perl .= "if (\@${v}) {";
354             $perl .= "unshift(\@${v}, undef);";
355 1         3 $perl .= "}";
356 1         5 $perl .= $self->_emit_create_path("${v}->[0]", $path, $cb);
357             }
358 1         2 elsif ($key eq '$append') {
359 1         4 my $index_var = $self->_generate_var;
360 1         2 $perl
361             .= $self->_emit_declare_vars($index_var, "scalar(\@${v})")
362             . $self->_emit_create_path("${v}->[${index_var}]", $path,
363 2         6 $cb);
364 2         5 }
365 2         3 $perl .= "}";
366 2         6 }
367             else {
368             $perl .= "if (is_maybe_hash_ref(${var})) {";
369 22         53 $perl .= "my ${v} = ${var} //= {};";
370 22         84 $perl
371             .= $self->_emit_create_path("${v}->{${str_key}}", $path, $cb);
372             $perl .= "}";
373             }
374             }
375 26         55  
376             $perl;
377             }
378 227         556  
379 227         499 my ($self, $var, $key) = @_;
380 227         1107  
381             my $str_key = $self->_emit_string($key);
382 227         396 my $perl = "";
383              
384             if (is_natural($key)) {
385             $perl .= "if (is_hash_ref(${var}) && exists(${var}->{${str_key}})) {";
386 263         541 $perl .= "delete(${var}->{${str_key}});";
387             $perl .= "} elsif (is_array_ref(${var}) && \@{${var}} > ${key}) {";
388             $perl .= "splice(\@{${var}}, ${key}, 1)";
389             }
390 40     40   65 elsif ($key eq '$first' || $key eq '$last' || $key eq '*') {
391             $perl .= "if (is_array_ref(${var}) && \@{${var}}) {";
392 40         88 $perl .= "splice(\@{${var}}, 0, 1)" if $key eq '$first';
393 40         75 $perl .= "splice(\@{${var}}, \@{${var}} - 1, 1)" if $key eq '$last';
394             $perl .= "splice(\@{${var}}, 0, \@{${var}})" if $key eq '*';
395 40 100 100     74 }
    100 100        
396 7         20 else {
397 7         22 $perl .= "if (is_hash_ref(${var})) {";
398 7         16 $perl .= "delete(${var}->{${str_key}})";
399 7         16 }
400             $perl .= ";";
401             $perl .= "}";
402 3         9  
403 3 100       9 $perl;
404 3 100       8 }
405 3 100       6  
406             1;
407              
408 30         71  
409 30         57 =pod
410              
411 40         56 =head1 NAME
412 40         46  
413             Catmandu::Path::simple - The default Catmandu path syntax
414 40         124  
415             =head1 SYNOPSIS
416              
417             my $data = {foo => {bar => ['first_bar', 'second_bar']}};
418              
419             my $path = Catmandu::Path::simple->new("foo.bar.0");
420              
421             my $getter = $path->getter;
422             my $first_bar = $getter->($data);
423              
424             my $updater = $path->updater(sub { my $str = $_[0]; uc $str });
425             $updater->($data);
426             # => {foo => {bar => ['FIRST_BAR', 'second_bar']}}
427              
428             # safer version with a type check
429             my $updater = $path->updater(if_string => sub { my $str = $_[0]; uc $str });
430              
431             =head1 CONFIGURATION
432              
433             =over 4
434              
435             =item path
436              
437             The string version of the path. Required.
438              
439             =back
440              
441             =head1 METHODS
442              
443             =head2 getter
444              
445             Returns a coderef that can get the values for the path.
446             The coderef takes the data as argument and returns the matching values as an
447             arrayref.
448              
449             my $path = Catmandu::Path::Simple->new(path => '$.foo');
450             my $data = {foo => 'foo', bar => 'bar'};
451             $path->getter->($data);
452             # => ['foo']
453              
454             =head2 setter
455              
456             Returns a coderef that can create the final part of the path and set it's
457             value. In contrast to C<creator> this will only set the value if the
458             intermediate path exists. The coderef takes the data as argument and also
459             returns the data.
460              
461             my $path = Catmandu::Path::Simple->new(path => '$.foo.$append');
462             $path->creator(value => 'foo')->({});
463             # => {foo => ['foo']}
464             $path->creator(value => sub { my ($val, $data) = @_; $val // 'foo' })->({});
465             # => {foo => ['foo']}
466              
467             # calling creator with no value creates a sub that takes the value as an
468             # extra argument
469             $path->creator->({}, 'foo');
470             $path->creator->({}, sub { my ($val, $data) = @_; $val // 'foo' });
471             # => {foo => ['foo']}
472              
473             =head2 setter(\&callback|$value)
474              
475             This is a shortcut for C<setter(value => \&callback|$value)>.
476              
477             =head2 updater(value => \&callback)
478              
479             Returns a coderef that can update the value of an existing path.
480              
481             =head2 updater(if_* => [\&callback])
482              
483             TODO
484              
485             =head2 updater(if => [\&callback])
486              
487             TODO
488              
489             =head2 updater(if_* => \&callback)
490              
491             TODO
492              
493             =head2 updater(if => \&callback)
494              
495             TODO
496              
497             =head2 updater(\&callback)
498              
499             This is a shortcut for C<updater(value => \&callback|$value)>.
500              
501             =head2 creator(value => \&callback|$value)
502              
503             Returns a coderef that can create the path and set it's value. In contrast to
504             C<setter> this also creates the intermediate path if necessary.
505             The coderef takes the data as argument and also returns the data.
506              
507             my $path = Catmandu::Path::Simple->new(path => '$.foo.$append');
508             $path->creator(value => 'foo')->({});
509             # => {foo => ['foo']}
510             $path->creator(value => sub { my ($val, $data) = @_; $val // 'foo' })->({});
511             # => {foo => ['foo']}
512              
513             # calling creator with no value creates a sub that takes the value as an
514             # extra argument
515             $path->creator->({}, 'foo');
516             $path->creator->({}, sub { my ($val, $data) = @_; $val // 'foo' });
517             # => {foo => ['foo']}
518              
519             =head2 creator(\&callback|$value)
520              
521             This is a shortcut for C<creator(value => \&callback|$value)>.
522              
523             =head2 deleter
524              
525             Returns a coderef that can delete the path.
526             The coderef takes the data as argument and also returns the data.
527              
528             my $path = Catmandu::Path::Simple->new(path => '$.foo');
529             $path->deleter->({foo => 'foo', bar => 'bar'});
530             # => {bar => 'bar'}
531              
532             =head1 SEE ALSO
533              
534             L<Catmandu::Path>.
535              
536             =cut