File Coverage

blib/lib/Catmandu/Fix/pica_map.pm
Criterion Covered Total %
statement 12 62 19.3
branch 0 16 0.0
condition 0 4 0.0
subroutine 4 6 66.6
pod 0 1 0.0
total 16 89 17.9


line stmt bran cond sub pod time code
1             package Catmandu::Fix::pica_map;
2              
3             our $VERSION = '0.17';
4              
5 1     1   1144 use Catmandu::Sane;
  1         2  
  1         8  
6 1     1   205 use Moo;
  1         2  
  1         9  
7              
8 1     1   1068 use Catmandu::Fix::Has;
  1         914  
  1         6  
9 1     1   1277 use PICA::Path;
  1         1161  
  1         1038  
10              
11             has pica_path => ( fix_arg => 1 );
12             has path => ( fix_arg => 1 );
13             has record => ( fix_opt => 1 );
14             has split => ( fix_opt => 1 );
15             has join => ( fix_opt => 1 );
16             has value => ( fix_opt => 1 );
17             has pluck => ( fix_opt => 1 );
18              
19             sub emit {
20 0     0 0   my ( $self, $fixer ) = @_;
21 0           my $path = $fixer->split_path( $self->path );
22 0   0       my $record_key = $fixer->emit_string( $self->record // 'record' );
23 0   0       my $join_char = $fixer->emit_string( $self->join // '' );
24 0           my $pica_path = PICA::Path->new($self->pica_path);
25              
26 0           my ($field_regex, $occurrence_regex, $subfield_regex, $from, $length) = @$pica_path;
27              
28 0           my $var = $fixer->var;
29 0           my $vals = $fixer->generate_var;
30 0           my $perl = $fixer->emit_declare_vars( $vals, '[]' );
31              
32 0           my $field_regex_var = $fixer->generate_var;
33 0           $perl .= $fixer->emit_declare_vars( $field_regex_var, "qr{$field_regex}" );
34              
35 0           my $subfield_regex_var = $fixer->generate_var;
36 0           $perl .= $fixer->emit_declare_vars( $subfield_regex_var, "qr{$subfield_regex}" );
37              
38 0           my $occurrence_regex_var;
39 0 0         if (defined $occurrence_regex) {
40 0           $occurrence_regex_var = $fixer->generate_var;
41 0           $perl .= $fixer->emit_declare_vars( $occurrence_regex_var, "qr{$occurrence_regex}" );
42             }
43              
44             $perl .= $fixer->emit_foreach(
45             "${var}->{${record_key}}",
46             sub {
47 0     0     my $var = shift;
48 0           my $v = $fixer->generate_var;
49 0           my $perl = "";
50              
51 0           $perl .= "next if ${var}->[0] !~ ${field_regex_var};";
52              
53 0 0         if (defined $occurrence_regex) {
54 0           $perl .= "next if (!defined ${var}->[1] || ${var}->[1] !~ ${occurrence_regex_var});";
55             }
56              
57 0 0         if ( $self->value ) {
58 0           $perl .= $fixer->emit_declare_vars( $v,
59             $fixer->emit_string( $self->value ) );
60             }
61             else {
62 0           my $i = $fixer->generate_var;
63             my $add_subfields = sub {
64 0           my $start = shift;
65 0 0         if ($self->pluck) {
66             # Treat the subfield_regex as a hash index
67 0           my $pluck = $fixer->generate_var;
68             return
69 0           "my ${pluck} = {};" .
70             "for (my ${i} = ${start}; ${i} < \@{${var}}; ${i} += 2) {".
71             "push(\@{ ${pluck}->{ ${var}->[${i}] } }, ${var}->[${i} + 1]);" .
72             "}" .
73             "for my ${i} (split('','${subfield_regex}')) { " .
74             "push(\@{${v}}, \@{ ${pluck}->{${i}} }) if exists ${pluck}->{${i}};" .
75             "}";
76             }
77             else {
78             # Treat the subfield_regex as regex that needs to match the subfields
79             return
80 0           "for (my ${i} = ${start}; ${i} < \@{${var}}; ${i} += 2) {".
81             "if (${var}->[${i}] =~ /${subfield_regex}/) {".
82             "push(\@{${v}}, ${var}->[${i} + 1]);".
83             "}".
84             "}";
85             }
86 0           };
87 0           $perl .= $fixer->emit_declare_vars( $v, "[]" );
88 0           $perl .= $add_subfields->(2);
89 0           $perl .= "if (\@{${v}}) {";
90 0 0         if ( !$self->split ) {
91 0           $perl .= "${v} = join(${join_char}, \@{${v}});";
92 0 0         if ( defined( my $off = $from ) ) {
93 0           $perl .= "if (eval { ${v} = substr(${v}, ${off}, ${length}); 1 }) {";
94             }
95             }
96             $perl .= $fixer->emit_create_path(
97             $fixer->var,
98             $path,
99             sub {
100 0           my $var = shift;
101 0 0         if ( $self->split ) {
102 0           "if (is_array_ref(${var})) {"
103             . "push \@{${var}}, ${v};"
104             . "} else {"
105             . "${var} = [${v}];" . "}";
106             }
107             else {
108 0           "if (is_string(${var})) {"
109             . "${var} = join(${join_char}, ${var}, ${v});"
110             . "} else {"
111             . "${var} = ${v};" . "}";
112             }
113             }
114 0           );
115 0 0         if ( defined($from) ) {
116 0           $perl .= "}";
117             }
118 0           $perl .= "}";
119             }
120 0           $perl;
121             }
122 0           );
123              
124 0           $perl;
125             }
126              
127             1;
128             __END__