File Coverage

blib/lib/Catmandu/Fix.pm
Criterion Covered Total %
statement 187 367 50.9
branch 45 124 36.2
condition 19 43 44.1
subroutine 34 50 68.0
pod 1 27 3.7
total 286 611 46.8


line stmt bran cond sub pod time code
1              
2             use Catmandu::Sane;
3 147     147   1089663  
  147         273  
  147         783  
4             our $VERSION = '1.2018';
5              
6             use Moo;
7 147     147   1971 use Catmandu::Fix::Parser;
  147         285  
  147         1744  
8 147     147   106241 use Text::Hogan::Compiler;
  147         466  
  147         4380  
9 147     147   70576 use Path::Tiny ();
  147         1275834  
  147         4846  
10 147     147   106640 use File::Spec ();
  147         1487237  
  147         3777  
11 147     147   1113 use File::Temp ();
  147         305  
  147         1879  
12 147     147   90808 use Catmandu::Util qw(
  147         1234193  
  147         4886  
13 147         10121 is_string
14             is_array_ref
15             is_hash_ref
16             is_code_ref
17             is_glob_ref
18             is_instance
19             is_able
20             require_package
21             );
22 147     147   1223 use namespace::clean;
  147         299  
23 147     147   856  
  147         283  
  147         1264  
24             with 'Catmandu::Logger';
25             with 'Catmandu::Emit';
26              
27             has parser => (is => 'lazy');
28             has fixer => (is => 'lazy', init_arg => undef);
29             has _captures =>
30             (is => 'ro', lazy => 1, init_arg => undef, default => sub {+{}});
31             has var =>
32             (is => 'ro', lazy => 1, init_arg => undef, builder => '_generate_var');
33             has _fixes => (is => 'ro', init_arg => 'fixes', default => sub {[]});
34             has fixes =>
35             (is => 'ro', lazy => 1, init_arg => undef, builder => '_build_fixes');
36             has _reject_var => (
37             is => 'ro',
38             lazy => 1,
39             init_arg => undef,
40             builder => '_build_reject_var'
41             );
42             has _fixes_var =>
43             (is => 'ro', lazy => 1, init_arg => undef, builder => '_build_fixes_var');
44             has preprocess => (is => 'ro');
45             has _hogan =>
46             (is => 'ro', lazy => 1, init_arg => undef, builder => '_build_hogan');
47             has _hogan_vars => (is => 'ro', init_arg => 'variables');
48              
49             Catmandu::Fix::Parser->new;
50             }
51 149     149   3419  
52             my ($self) = @_;
53             my $fixes_arg = $self->_fixes;
54             my $fixes = [];
55 478     478   3705  
56 478         1512 for my $fix (@$fixes_arg) {
57 478         876  
58             if (is_code_ref($fix)) {
59 478         1120 push @$fixes, require_package('Catmandu::Fix::code')->new($fix);
60             }
61 480 100 100     5011 elsif (ref $fix && ref($fix) =~ /^IO::/) {
    100          
    100          
    100          
    50          
62 1         5 my $txt = Catmandu::Util::read_io($fix);
63             $txt = $self->_preprocess($txt);
64             push @$fixes, @{$self->parser->parse($txt)};
65 1         4 }
66 1         5 elsif (is_glob_ref($fix)) {
67 1         3 my $fh = Catmandu::Util::io($fix, binmode => ':encoding(UTF-8)');
  1         20  
68             my $txt = Catmandu::Util::read_io($fh);
69             $txt = $self->_preprocess($txt);
70 1         5 push @$fixes, @{$self->parser->parse($txt)};
71 1         3 }
72 1         4 elsif (ref $fix) {
73 1         2 push @$fixes, $fix;
  1         21  
74             }
75             elsif (is_string($fix)) {
76 327         905 if ($fix =~ /[^\s]/ && $fix !~ /\(/) {
77             $fix = Path::Tiny::path($fix)->slurp_utf8;
78             }
79 150 100 66     1158 $fix = $self->_preprocess($fix);
80 10         55 push @$fixes, @{$self->parser->parse($fix)};
81             }
82 150         11618 }
83 150         5974  
  150         2518  
84             $fixes;
85             }
86              
87 475         4339 my ($self) = @_;
88              
89             my $reject = $self->_reject;
90             my $sub = $self->_eval_sub(
91 477     477   4378 $self->emit,
92             args => [$self->var],
93 477         1768 captures => $self->_captures
94 477         1418 );
95              
96             sub {
97             my $data = $_[0];
98              
99             if (is_hash_ref($data)) {
100             my $d = $sub->($data);
101 492     492   1022 return if ref $d && $d == $reject;
102             return $d;
103 492 100       1706 }
104 470         7991  
105 466 100 66     2554 if (is_array_ref($data)) {
106 457         4671 return [grep {!(ref $_ && $_ == $reject)}
107             map {$sub->($_)} @$data];
108             }
109 22 100       71  
110 16   66     106 if (is_code_ref($data)) {
111 9         28 return sub {
  16         309  
112             while (1) {
113             my $d = $sub->($data->() // return);
114 13 100       39 return if ref $d && $d == $reject;
115             return $d;
116 6         486 }
117 6   100     14 };
118 5 50 33     37 }
119 5         34  
120             if ( is_instance($data)
121 3         16 && is_able($data, 'does')
122             && $data->does('Catmandu::Iterable'))
123             {
124 10 100 66     51 return $data->map(sub {$sub->($_[0])})
      66        
125             ->reject(sub {ref $_[0] && $_[0] == $reject});
126             }
127              
128 24         428 Catmandu::BadArg->throw(
129 9 50       574 "must be hashref, arrayref, coderef or iterable object");
  23         167  
130             };
131             }
132              
133 1         12 my ($self) = @_;
134 474         4060 $self->capture($self->_reject);
135             }
136              
137             my ($self) = @_;
138 478     478   3736 $self->capture($self->fixes);
139 478         1139 }
140              
141             Text::Hogan::Compiler->new;
142             }
143 0     0   0  
144 0         0 my ($self, $text) = @_;
145             return $text unless $self->preprocess || $self->_hogan_vars;
146             my $vars = $self->_hogan_vars || {};
147             $self->_hogan->compile($text, {numeric_string_as_string => 1})
148 1     1   18 ->render($vars);
149             }
150              
151             my ($self, $data) = @_;
152 152     152   359 $self->fixer->($data);
153 152 100 66     1049 }
154 1   50     5  
155 1         27 $_[0]->_generate_var;
156             }
157              
158             $_[0]->_generate_label;
159             }
160 495     495 1 186481  
161 495         8420 my ($self, $capture) = @_;
162             my $var = $self->_generate_var;
163             $self->_captures->{$var} = $capture;
164             $var;
165 116     116 0 286 }
166              
167             my ($self) = @_;
168             my $var = $self->var;
169 0     0 0 0 my $err = $self->_generate_var;
170             my $reject_var = $self->_reject_var;
171             my $perl = "";
172              
173 1418     1418 0 4119 $perl .= "eval {";
174 1418         3039  
175 1418         20687 # Loop over all the fixes and emit their code
176 1418         9134 $perl .= $self->emit_fixes($self->fixes);
177              
178             $perl .= "return ${var};";
179             $perl .= $self->_reject_label . ": return ${reject_var};";
180 478     478 0 905 $perl .= "} or do {";
181 478         6862 $perl .= $self->_emit_declare_vars($err, '$@');
182 478         1160 $perl .= "${err}->throw if is_instance(${err},'Throwable::Error');";
183 478         6980 $perl .= "Catmandu::FixError->throw(message => ${err}, data => ${var});";
184 478         847 $perl .= "};";
185              
186 478         920 $self->log->debug($perl);
187              
188             $perl;
189 478         6786 }
190              
191 475         1134 # Emit an array of fixes
192 475         1343 my ($self, $fixes) = @_;
193 475         867 my $perl = '';
194 475         1251  
195 475         1242 for (my $i = 0; $i < @{$fixes}; $i++) {
196 475         1255 my $fix = $fixes->[$i];
197 475         722 $perl .= $self->emit_fix($fix);
198             }
199 475         8329  
200             $perl;
201 475         179697 }
202              
203             $_[0]->_emit_reject;
204             }
205              
206 741     741 0 1445 my ($self, $fix) = @_;
207 741         1149 my $perl;
208              
209 741         1280 if ($fix->can('emit')) {
  1486         3543  
210 745         1257 $perl = $self->emit_block(
211 745         1731 sub {
212             my ($label) = @_;
213             $fix->emit($self, $label);
214 741         1917 }
215             );
216             }
217             elsif ($fix->can('fix')) {
218 26     26 0 99 my $var = $self->var;
219             my $ref = $self->_generate_var;
220             $self->_captures->{$ref} = $fix;
221             $perl = "${var} = ${ref}->fix(${var});";
222 870     870 0 1472 }
223 870         1113 else {
224             Catmandu::Error->throw('not a fix');
225 870 100       3207 }
    50          
226              
227             $perl;
228 859     859   1427 }
229 859         2743  
230             my ($self, $cb) = @_;
231 859         4012 my $label = $self->_generate_label;
232             my $perl = "${label}: {";
233             $perl .= $cb->($label);
234 11         195 $perl .= "};";
235 11         117 $perl;
236 11         171 }
237 11         108  
238             my ($self, $var) = @_;
239             "undef %{${var}} if is_hash_ref(${var});";
240 0         0 }
241              
242             shift->_emit_value(@_);
243 870         3598 }
244              
245             shift->_emit_string(@_);
246             }
247 859     859 0 1485  
248 859         2426 my ($self, $pattern) = @_;
249 859         1612 $pattern =~ s/\//\\\//g;
250 859         1547 $pattern =~ s/\\$/\\\\/; # pattern can't end with an escape in m/.../
251 859         1381 "m/$pattern/";
252 859         1594 }
253              
254             my ($self, $pattern, $replace) = @_;
255             $pattern =~ s/\//\\\//g;
256 0     0 0 0 $pattern =~ s/\\$/\\\\/; # pattern can't end with an escape in m/.../
257 0         0 $replace =~ s/\//\\\//g;
258             $replace =~ s/\\$/\\\\/; # pattern can't end with an escape in m/.../
259             "s/$pattern/$replace/";
260             }
261 0     0 0 0  
262             shift->_emit_declare_vars(@_);
263             }
264              
265 8     8 0 26 "{";
266             }
267              
268             "};";
269 0     0 0 0 }
270 0         0  
271 0         0 my ($self, $var, $cb) = @_;
272 0         0 my $perl = "";
273             my $v = $self->_generate_var;
274             $perl .= "foreach (\@{${var}}) {";
275             $perl .= $self->emit_declare_vars($v, '$_');
276 0     0 0 0 $perl .= $cb->($v);
277 0         0 $perl .= "}";
278 0         0 $perl;
279 0         0 }
280 0         0  
281 0         0 my ($self, $var, $cb) = @_;
282             my $perl = "";
283             my $v = $self->_generate_var;
284             $perl .= "foreach (keys(\%{${var}})) {";
285 4     4 0 20 $perl .= $self->emit_declare_vars($v, '$_');
286             $perl .= $cb->($v);
287             $perl .= "}";
288             $perl;
289 0     0 0 0 }
290              
291             my ($self, $var, $keys, $cb) = @_;
292              
293 0     0 0 0 $keys = [@$keys]; # protect keys
294              
295             if (@$keys) { # protect $var
296             my $v = $self->_generate_var;
297 0     0 0 0 $self->_emit_declare_vars($v, $var)
298 0         0 . $self->_emit_walk_path($v, $keys, $cb);
299 0         0 }
300 0         0 else {
301 0         0 $cb->($var);
302 0         0 }
303 0         0 }
304 0         0  
305             my ($self, $var, $keys, $cb) = @_;
306              
307             @$keys || return $cb->($var);
308 4     4 0 9  
309 4         7 my $key = shift @$keys;
310 4         8 my $str_key = $self->emit_string($key);
311 4         11 my $perl = "";
312 4         10  
313 4         21 if ($key =~ /^[0-9]+$/) {
314 4         8 $perl .= "if (is_hash_ref(${var})) {";
315 4         7 $perl .= "${var} = ${var}->{${str_key}};";
316             $perl .= $self->_emit_walk_path($var, [@$keys], $cb);
317             $perl .= "} elsif (is_array_ref(${var}) && \@{${var}} > ${key}) {";
318             $perl .= "${var} = ${var}->[${key}];";
319 8     8 0 85 $perl .= $self->_emit_walk_path($var, [@$keys], $cb);
320             $perl .= "}";
321 8         14 }
322             elsif ($key eq '*') {
323 8 100       18 my $v = $self->_generate_var;
324 6         14 $perl .= "if (is_array_ref(${var})) {";
325 6         13 $perl .= $self->emit_foreach(
326             $var,
327             sub {
328             return $self->_emit_walk_path(shift, $keys, $cb);
329 2         5 }
330             );
331             $perl .= "}";
332             }
333             else {
334 12     12   23 if ($key eq '$first') {
335             $perl .= "if (is_array_ref(${var}) && \@{${var}}) {";
336 12 100       22 $perl .= "${var} = ${var}->[0];";
337             }
338 6         12 elsif ($key eq '$last') {
339 6         11 $perl .= "if (is_array_ref(${var}) && \@{${var}}) {";
340 6         7 $perl .= "${var} = ${var}->[\@{${var}} - 1];";
341             }
342 6 50       21 else {
    50          
343 0         0 $perl .= "if (is_hash_ref(${var})) {";
344 0         0 $perl .= "${var} = ${var}->{${str_key}};";
345 0         0 }
346 0         0 $perl .= $self->_emit_walk_path($var, $keys, $cb);
347 0         0 $perl .= "}";
348 0         0 }
349 0         0  
350             $perl;
351             }
352 0         0  
353 0         0 my ($self, $var, $keys, $cb) = @_;
354             $self->_emit_create_path($var, [@$keys], $cb);
355             }
356              
357 0     0   0 my ($self, $var, $keys, $cb) = @_;
358              
359 0         0 @$keys || return $cb->($var);
360 0         0  
361             my $key = shift @$keys;
362             my $str_key = $self->emit_string($key);
363 6 50       14 my $perl = "";
    50          
364 0         0  
365 0         0 if ($key =~ /^[0-9]+$/) {
366             my $v1 = $self->_generate_var;
367             my $v2 = $self->_generate_var;
368 0         0 $perl .= "if (is_hash_ref(${var})) {";
369 0         0 $perl .= "my ${v1} = ${var};";
370             $perl
371             .= $self->_emit_create_path("${v1}->{${str_key}}", [@$keys], $cb);
372 6         14 $perl .= "} elsif (is_maybe_array_ref(${var})) {";
373 6         10 $perl .= "my ${v2} = ${var} //= [];";
374             $perl .= $self->_emit_create_path("${v2}->[${key}]", [@$keys], $cb);
375 6         14 $perl .= "}";
376 6         7 }
377             elsif ($key eq '*') {
378             my $v1 = $self->_generate_var;
379 6         32 my $v2 = $self->_generate_var;
380             $perl .= "if (is_array_ref(${var})) {";
381             $perl .= "my ${v1} = ${var};";
382             $perl .= "for (my ${v2} = 0; ${v2} < \@{${v1}}; ${v2}++) {";
383 0     0 0 0 $perl .= $self->_emit_create_path("${v1}->[${v2}]", $keys, $cb);
384 0         0 $perl .= "}";
385             $perl .= "}";
386             }
387             else {
388 0     0   0 my $v = $self->_generate_var;
389             if ( $key eq '$first'
390 0 0       0 || $key eq '$last'
391             || $key eq '$prepend'
392 0         0 || $key eq '$append')
393 0         0 {
394 0         0 $perl .= "if (is_maybe_array_ref(${var})) {";
395             $perl .= "my ${v} = ${var} //= [];";
396 0 0       0 if ($key eq '$first') {
    0          
397 0         0 $perl .= $self->_emit_create_path("${v}->[0]", $keys, $cb);
398 0         0 }
399 0         0 elsif ($key eq '$last') {
400 0         0 $perl .= "if (\@${v}) {";
401 0         0 $perl .= $self->_emit_create_path("${v}->[\@${v} - 1]",
402             [@$keys], $cb);
403 0         0 $perl .= "} else {";
404 0         0 $perl .= $self->_emit_create_path("${v}->[0]", [@$keys], $cb);
405 0         0 $perl .= "}";
406 0         0 }
407             elsif ($key eq '$prepend') {
408             $perl .= "if (\@${v}) {";
409 0         0 $perl .= "unshift(\@${v}, undef);";
410 0         0 $perl .= "}";
411 0         0 $perl .= $self->_emit_create_path("${v}->[0]", $keys, $cb);
412 0         0 }
413 0         0 elsif ($key eq '$append') {
414 0         0 $perl
415 0         0 .= $self->_emit_create_path("${v}->[\@${v}]", $keys, $cb);
416 0         0 }
417             $perl .= "}";
418             }
419 0         0 else {
420 0 0 0     0 $perl .= "if (is_maybe_hash_ref(${var})) {";
      0        
      0        
421             $perl .= "my ${v} = ${var} //= {};";
422             $perl
423             .= $self->_emit_create_path("${v}->{${str_key}}", $keys, $cb);
424             $perl .= "}";
425 0         0 }
426 0         0 }
427 0 0       0  
    0          
    0          
    0          
428 0         0 $perl;
429             }
430              
431 0         0 my ($self, $var, $key, $cb) = @_;
432 0         0  
433             return $cb->($var) unless defined $key;
434 0         0  
435 0         0 my $str_key = $self->emit_string($key);
436 0         0 my $perl = "";
437              
438             if ($key =~ /^[0-9]+$/) {
439 0         0 $perl .= "if (is_hash_ref(${var}) && exists(${var}->{${str_key}})) {";
440 0         0 $perl .= $cb->("${var}->{${str_key}}");
441 0         0 $perl .= "} elsif (is_array_ref(${var}) && \@{${var}} > ${key}) {";
442 0         0 $perl .= $cb->("${var}->[${key}]");
443             $perl .= "}";
444             }
445 0         0 elsif ($key eq '$first') {
446             $perl .= "if (is_array_ref(${var}) && \@{${var}}) {";
447             $perl .= $cb->("${var}->[0]");
448 0         0 $perl .= "}";
449             }
450             elsif ($key eq '$last') {
451 0         0 $perl .= "if (is_array_ref(${var}) && \@{${var}}) {";
452 0         0 $perl .= $cb->("${var}->[\@{${var}} - 1]");
453 0         0 $perl .= "}";
454             }
455 0         0 elsif ($key eq '*') {
456             my $i = $self->_generate_var;
457             $perl .= "if (is_array_ref(${var})) {";
458             $perl .= "for (my ${i} = 0; ${i} < \@{${var}}; ${i}++) {";
459 0         0 $perl .= $cb->("${var}->[${i}]", $i);
460             $perl .= "}}";
461             }
462             else {
463 0     0 0 0 $perl .= "if (is_hash_ref(${var}) && exists(${var}->{${str_key}})) {";
464             $perl .= $cb->("${var}->{${str_key}}");
465 0 0       0 $perl .= "}";
466             }
467 0         0  
468 0         0 $perl;
469             }
470 0 0       0  
    0          
    0          
    0          
471 0         0 my ($self, $var, $key, $val) = @_;
472 0         0  
473 0         0 return "${var} = $val;" unless defined $key;
474 0         0  
475 0         0 my $perl = "";
476             my $str_key = $self->emit_string($key);
477              
478 0         0 if ($key =~ /^[0-9]+$/) {
479 0         0 $perl .= "if (is_hash_ref(${var})) {";
480 0         0 $perl .= "${var}->{${str_key}} = $val;";
481             $perl .= "} elsif (is_array_ref(${var})) {";
482             $perl .= "${var}->[${key}] = $val;";
483 0         0 $perl .= "}";
484 0         0 }
485 0         0 elsif ($key eq '$first') {
486             $perl .= "if (is_array_ref(${var})) {";
487             $perl .= "${var}->[0] = $val;";
488 0         0 $perl .= "}";
489 0         0 }
490 0         0 elsif ($key eq '$last') {
491 0         0 $perl .= "if (is_array_ref(${var})) {";
492 0         0 $perl .= "${var}->[\@{${var}} - 1] = $val;";
493             $perl .= "}";
494             }
495 0         0 elsif ($key eq '$prepend') {
496 0         0 $perl .= "if (is_array_ref(${var})) {";
497 0         0 $perl .= "unshift(\@{${var}}, $val);";
498             $perl .= "}";
499             }
500 0         0 elsif ($key eq '$append') {
501             $perl .= "if (is_array_ref(${var})) {";
502             $perl .= "push(\@{${var}}, $val);";
503             $perl .= "}";
504 0     0 0 0 }
505             elsif ($key eq '*') {
506 0 0       0 my $i = $self->_generate_var;
507             $perl .= "if (is_array_ref(${var})) {";
508 0         0 $perl .= "for (my ${i} = 0; ${i} < \@{${var}}; ${i}++) {";
509 0         0 $perl .= "${var}->[${i}] = $val;";
510             $perl .= "}}";
511 0 0       0 }
    0          
    0          
    0          
    0          
    0          
512 0         0 else {
513 0         0 $perl .= "if (is_hash_ref(${var})) {";
514 0         0 $perl .= "${var}->{${str_key}} = $val;";
515 0         0 $perl .= "}";
516 0         0 }
517              
518             $perl;
519 0         0 }
520 0         0  
521 0         0 my ($self, $var, $key, $cb) = @_;
522              
523             my $str_key = $self->emit_string($key);
524 0         0 my $perl = "";
525 0         0 my $vals;
526 0         0 if ($cb) {
527             $vals = $self->_generate_var;
528             $perl = $self->emit_declare_vars($vals, '[]');
529 0         0 }
530 0         0  
531 0         0 if ($key =~ /^[0-9]+$/) {
532             $perl .= "if (is_hash_ref(${var}) && exists(${var}->{${str_key}})) {";
533             $perl .= "push(\@{${vals}}, " if $cb;
534 0         0 $perl .= "delete(${var}->{${str_key}})";
535 0         0 $perl .= ")" if $cb;
536 0         0 $perl .= ";";
537             $perl .= "} elsif (is_array_ref(${var}) && \@{${var}} > ${key}) {";
538             $perl .= "push(\@{${vals}}, " if $cb;
539 0         0 $perl .= "splice(\@{${var}}, ${key}, 1)";
540 0         0 $perl .= ")" if $cb;
541 0         0 }
542 0         0 elsif ($key eq '$first' || $key eq '$last' || $key eq '*') {
543 0         0 $perl .= "if (is_array_ref(${var}) && \@{${var}}) {";
544             $perl .= "push(\@{${vals}}, " if $cb;
545             $perl .= "splice(\@{${var}}, 0, 1)" if $key eq '$first';
546 0         0 $perl .= "splice(\@{${var}}, \@{${var}} - 1, 1)" if $key eq '$last';
547 0         0 $perl .= "splice(\@{${var}}, 0, \@{${var}})" if $key eq '*';
548 0         0 $perl .= ")" if $cb;
549             }
550             else {
551 0         0 $perl .= "if (is_hash_ref(${var}) && exists(${var}->{${str_key}})) {";
552             $perl .= "push(\@{${vals}}, " if $cb;
553             $perl .= "delete(${var}->{${str_key}})";
554             $perl .= ")" if $cb;
555 0     0 0 0 }
556             $perl .= ";";
557 0         0 $perl .= "}";
558 0         0 if ($cb) {
559 0         0 $perl .= $cb->($vals);
560 0 0       0 }
561 0         0  
562 0         0 $perl;
563             }
564              
565 0 0 0     0 my ($self, $var, $key) = @_;
    0 0        
566 0         0  
567 0 0       0 my $perl = "";
568 0         0  
569 0 0       0 if ($key =~ /^[0-9]+$/) {
570 0         0 $perl .= "if (is_hash_ref(${var})) {";
571 0         0 $perl .= $self->emit_foreach_key(
572 0 0       0 $var,
573 0         0 sub {
574 0 0       0 my $v = shift;
575             "delete(${var}->{${v}}) if ${v} ne ${key};";
576             }
577 0         0 );
578 0 0       0 $perl .= "} elsif (is_array_ref(${var})) {";
579 0 0       0 $perl .= "if (\@{${var}} > ${key}) {";
580 0 0       0 $perl .= "splice(\@{${var}}, 0, ${key});" if $key > 0;
581 0 0       0 $perl .= "splice(\@{${var}}, 1, \@{${var}} - 1);";
582 0 0       0 $perl .= "} else {";
583             $perl .= "splice(\@{${var}}, 0, \@{${var}});";
584             $perl .= "}";
585 0         0 $perl .= "}";
586 0 0       0 }
587 0         0 elsif ($key eq '$first') {
588 0 0       0 $perl .= "if (is_array_ref(${var}) && \@{${var}} > 1) {";
589             $perl .= "splice(\@{${var}}, 1, \@{${var}} - 1);";
590 0         0 $perl .= "}";
591 0         0 }
592 0 0       0 elsif ($key eq '$last') {
593 0         0 $perl .= "if (is_array_ref(${var}) && \@{${var}} > 1) {";
594             $perl .= "splice(\@{${var}}, 0, \@{${var}} - 1);";
595             $perl .= "}";
596 0         0 }
597             elsif ($key eq '*') {
598              
599             # retain everything
600 8     8 0 15 }
601             else {
602 8         21 $key = $self->emit_string($key);
603             $perl .= "if (is_hash_ref(${var})) {";
604 8 100       40 $perl .= $self->emit_foreach_key(
    100          
    100          
    100          
605 2         4 $var,
606             sub {
607             my $v = shift;
608             "if ($v ne ${key}) {" . "delete(${var}->{${v}});" . "}";
609 2     2   3 }
610 2         7 );
611             $perl .= "}";
612 2         10 }
613 2         9  
614 2         5 $perl;
615 2 50       8 }
616 2         5  
617 2         4 my ($self, $var) = @_;
618 2         4 "$var = clone($var);";
619 2         3 }
620 2         3  
621             # Split a path on '.' or '/', but not on '\.' or '\/'.
622             my ($self, $path) = @_;
623 1         4 Catmandu::Util::split_path($path);
624 1         3 }
625 1         1  
626             1;
627              
628 1         4  
629 1         4 =pod
630 1         1  
631             =head1 NAME
632              
633             Catmandu::Fix - a Catmandu class used for data transformations
634              
635             =head1 SYNOPSIS
636              
637 2         6 # From the command line
638 2         6  
639             $ catmandu convert JSON --fix 'add(foo,bar)' < data.json
640             $ catmandu convert YAML --fix 'upcase(job) remove(test)' < data.yml
641             $ catmandu convert CSV --fix 'sort(tags)' < data.csv
642 2     2   4 $ catmandu run /tmp/myfixes.txt
643 2         8 $ catmandu convert OAI --url http://biblio.ugent.be/oai --fix /tmp/myfixes.txt
644              
645 2         10 # With preprocessing
646 2         9 $ catmandu convert JSON --var field=foo --fix 'add({{field}},bar)' < data.json
647              
648             # From Perl
649 8         25  
650             use Catmandu;
651              
652             my $fixer = Catmandu->fixer('upcase(job)','removed(test)');
653 0     0 0 0 my $fixer = Catmandu->fixer('/tmp/myfixes.txt');
654 0         0  
655             # Convert data
656             my $arr = $fixer->fix([ ... ]);
657             my $hash = $fixer->fix({ ... });
658             my $importer = Catmandu->importer('YAML', file => 'data.yml');
659 8     8 0 11 my $fixed_importer = $fixer->fix($importer);
660 8         22  
661             # With preprocessing
662             my $fixer = Catmandu::Fix->new(
663             variables => {x => 'foo', y => 'bar'},
664             fixes => ['add({{x}},{{y}})'],
665             );
666              
667             # Inline fixes
668             use Catmandu::Fix::upcase as => 'my_upcase';
669             use Catmandu::Fix::remove as => 'my_remove';
670              
671             my $hash = { 'job' => 'librarian' , deep => { nested => '1'} };
672              
673             my_upcase($hash,'job');
674             my_remove($hash,'deep.nested');
675              
676             =head1 DESCRIPTION
677              
678             A Catmandu::Fix is a Perl package that can transform data. These packages are used
679             for easy data manipulation by non programmers. The main intention is to use fixes
680             on the command line or in Fix scripts. A small DSL language is available to execute
681             many Fix command on a stream of data.
682              
683             When a C<fix> argument is given to a L<Catmandu::Importer>, L<Catmandu::Exporter> or
684             L<Catmandu::Store> then the transformations are executed on every item in the stream.
685              
686             =head1 FIX LANGUAGE
687              
688             A Fix script is a collection of one or more Fix commands. The fixes are executed
689             on every record in the dataset. If this command is executed on the command line:
690              
691             $ catmandu convert JSON --fix 'upcase(title); add(deep.nested.field,1)' < data.json
692              
693             then all the title fields will be upcased and a new deeply nested field will be added:
694              
695             { "title":"foo" }
696             { "title":"bar" }
697              
698             becomes:
699              
700             { "title":"FOO" , "deep":{"nested":{"field":1}} }
701             { "title":"BAR" , "deep":{"nested":{"field":1}} }
702              
703             Using the command line, Fix commands need a semicolon (;) as separator. All these commands can
704             also be written into a Fix script where semicolons are not required:
705              
706             $ catmandu convert JSON --fix script.fix < data.json
707              
708             where C<script.fix> contains:
709              
710             upcase(title)
711             add(deep.nested.field,1)
712              
713             Conditionals can be used to provide the logic when to execute fixes:
714              
715             if exists(error)
716             set(valid, 0)
717             end
718              
719             if exists(error)
720             set(is_valid, 0)
721             elsif exists(warning)
722             set(is_valid, 1)
723             log(...)
724             else
725             set(is_valid, 1)
726             end
727              
728             unless all_match(title, "PERL")
729             add(is_perl, "noooo")
730             end
731              
732             exists(error) and set(is_valid, 0)
733             exists(error) && set(is_valid, 0)
734              
735             exists(title) or log('title missing')
736             exists(title) || log('title missing')
737              
738             Binds are used to manipulate the context in which Fixes are executed. E.g.
739             execute a fix on every item in a list:
740              
741             # 'demo' is an array of hashes
742             bind list(path:demo)
743             add_field(foo,bar)
744             end
745             # do is an alias for bind
746             do list(path:demo)
747             add_field(foo,bar)
748             end
749              
750             To delete records from a stream of data the C<reject> Fix can be used:
751              
752             reject() # Reject all in the stream
753              
754             if exists(foo)
755             reject() # Reject records that contain a 'foo' field
756             end
757              
758             reject exists(foo) # Reject records that contain a 'foo' field
759              
760             The opposite of C<reject> is C<select>:
761              
762             select() # Keep all records in the stream
763              
764             select exists(foo) # Keep only the records that contain a 'foo' field
765              
766             Comments in Fix scripts are all lines (or parts of a line) that start with a hash (#):
767              
768             # This is ignored
769             add(test,123) # This is also a comment
770              
771             You can load fixes from another namespace with the C<use> statement:
772              
773             # this will look for fixes in the Foo::Bar namespace and make them
774             # available prefixed by fb
775             use(foo.bar, as: fb)
776             fb.baz()
777              
778             # this will look for Foo::Bar::Condition::is_baz
779             if fb.is_baz()
780             ...
781             fix()
782             ...
783             end
784              
785             =head1 FIX COMMANDS, ARGUMENTS AND OPTIONS
786              
787             Fix commands manipulate data or in some cases execute side effects. Fix
788             commands have zero or more arguments and zero or more options. Fix command
789             arguments are separated by commas ",". Fix options are name/value pairs
790             separated by a colon ":".
791              
792             # A command with zero arguments
793             my_command()
794              
795             # A command with multiple arguments
796             my_other_command(foo,bar,test)
797              
798             # A command with optional arguments
799             my_special_command(foo,bar,color:blue,size:12)
800              
801             All command arguments are treated as strings. These strings can be FIX PATHs
802             pointing to values or string literals. When command line arguments don't contain
803             special characters comma "," , equal "=" , great than ">" or colon ":", then
804             they can be written as-is. Otherwise, the arguments need to be quoted with single
805             or double quotes:
806              
807             # Both commands below have the same effect
808             my_other_command(foo,bar,test)
809             my_other_command("foo","bar","test")
810              
811             # Illegal syntax
812             my_special_command(foo,http://test.org,color:blue,size:12) # <- syntax error
813              
814             # Correct syntax
815             my_special_command(foo,"http://test.org",color:blue,size:12)
816            
817             # Or, alternative
818             my_special_command("foo","http://test.org",color:"blue",size:12)
819              
820             =head1 FIX PATHS
821              
822             Most of the Fix commands use paths to point to values
823             in a data record. E.g. 'foo.2.bar' is a key 'bar' which is the 3-rd value of the
824             key 'foo'.
825              
826             A special case is when you want to point to all items in an array. In this case
827             the wildcard '*' can be used. E.g. 'foo.*' points to all the items in the 'foo'
828             array.
829              
830             For array values there are special wildcards available:
831              
832             * $append - Add a new item at the end of an array
833             * $prepend - Add a new item at the start of an array
834             * $first - Syntactic sugar for index '0' (the head of the array)
835             * $last - Syntactic sugar for index '-1' (the tail of the array)
836              
837             E.g.
838              
839             # Create { mods => { titleInfo => [ { 'title' => 'a title' }] } };
840             add('mods.titleInfo.$append.title', 'a title');
841              
842             # Create { mods => { titleInfo => [ { 'title' => 'a title' } , { 'title' => 'another title' }] } };
843             add('mods.titleInfo.$append.title', 'another title');
844              
845             # Create { mods => { titleInfo => [ { 'title' => 'foo' } , { 'title' => 'another title' }] } };
846             add('mods.titleInfo.$first.title', 'foo');
847              
848             # Create { mods => { titleInfo => [ { 'title' => 'foo' } , { 'title' => 'bar' }] } };
849             add('mods.titleInfo.$last.title', 'bar');
850              
851             Some Fix commands can implement an alternatice path syntax to point to values.
852             See for example L<Catmandu::MARC>, L<Catmandu:PICA>:
853              
854             # Copy the MARC 245a field to the my.title field
855             marc_map(245a,my.title)
856              
857             =head1 OPTIONS
858              
859             =head2 fixes
860              
861             An array of fixes. L<Catmandu::Fix> which will execute every fix in consecutive
862             order. A fix can be the name of a Catmandu::Fix::* routine, or the path to a
863             plain text file containing all the fixes to be executed. Required.
864              
865             =head2 preprocess
866              
867             If set to C<1>, fix files or inline fixes will first be preprocessed as a
868             moustache template. See C<variables> below for an example. Default is C<0>, no
869             preprocessing.
870              
871             =head2 variables
872              
873             An optional hashref of variables that are used to preprocess the fix files or
874             inline fixes as a moustache template. Setting the C<variables> option also sets
875             C<preprocess> to 1.
876              
877             my $fixer = Catmandu::Fix->new(
878             variables => {x => 'foo', y => 'bar'},
879             fixes => ['add({{x}},{{y}})'],
880             );
881             my $data = {};
882             $fixer->fix($data);
883             # $data is now {foo => 'bar'}
884              
885             =head1 METHODS
886              
887             =head2 fix(HASH)
888              
889             Execute all the fixes on a HASH. Returns the fixed HASH.
890              
891             =head2 fix(ARRAY)
892              
893             Execute all the fixes on every element in the ARRAY. Returns an ARRAY of fixes.
894              
895             =head2 fix(Catmandu::Iterator)
896              
897             Execute all the fixes on every item in an L<Catmandu::Iterator>. Returns a
898             (lazy) iterator on all the fixes.
899              
900             =head2 fix(sub {})
901              
902             Executes all the fixes on a generator function. Returns a new generator with fixed data.
903              
904             =head2 log
905              
906             Return the current logger. See L<Catmandu> for activating the logger in your main code.
907              
908             =head1 CODING
909              
910             One can extend the Fix language by creating own custom-made fixes. Three methods are
911             available to create an new fix function:
912              
913             * Simplest: create a class that implements a C<fix> method.
914             * For most use cases: create a class that consumes the C<Catmandu::Fix::Builder> role and use C<Catmandu::Path> to build your fixer.
915             * Hardest: create a class that emits Perl code that will be evaled by the Fix module.
916              
917             Both methods will be explained shortly.
918              
919             =head2 Quick and easy
920              
921             A Fix function is a Perl class in the C<Catmandu::Fix> namespace that implements a C<fix> method.
922             The C<fix> methods accepts a Perl hash as input and returns a (fixed) Perl hash as output. As
923             an example, the code belows implements the C<meow> Fix which inserts a 'meow' field with value 'purrrrr'.
924              
925             package Catmandu::Fix::meow;
926              
927             use Moo;
928              
929             sub fix {
930             my ($self,$data) = @_;
931             $data->{meow} = 'purrrrr';
932             $data;
933             }
934              
935             1;
936              
937             Given this Perl class, the following fix statement can be used in your application:
938              
939             # Will add 'meow' = 'purrrrr' to the data
940             meow()
941              
942             Use the quick and easy method when your fixes are not dependent on reading or writing data
943             from/to a JSON path. Your Perl classes need to implement their own logic to read or write data
944             into the given Perl hash.
945              
946             Fix arguments are passed as arguments to the C<new> function of the Perl class. As in
947              
948             # In the fix file...
949             meow('test123', count: 4)
950              
951             # ...will be translated into this pseudo code
952             my $fix = Catmandu::Fix::meow->new('test123', count: 4);
953              
954             Using L<Moo> these arguments can be catched with L<Catmandu::Fix::Has> package:
955              
956             package Catmandu::Fix::meow;
957              
958             use Catmandu::Sane;
959             use Moo;
960             use Catmandu::Fix::Has;
961              
962             has msg => (fix_arg => 1); # required parameter 1
963             has count => (fix_opt => 1, default => sub { 4 }); # optional parameter 'count' with default value 4
964              
965             sub fix {
966             my ($self,$data) = @_;
967             $data->{meow} = $self->msg x $self->count;
968             $data;
969             }
970              
971             1;
972              
973             Using this code the fix statement can be used like:
974              
975             # Will add 'meow' = 'purrpurrpurrpurr'
976             meow('purr', count: 4)
977              
978             =head1 SEE ALSO
979              
980             L<Catmandu::Fixable>,
981             L<Catmandu::Importer>,
982             L<Catmandu::Exporter>,
983             L<Catmandu::Store>,
984             L<Catmandu::Bag>
985              
986             =cut