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

package Catmandu::Fix::pica_map;

our $VERSION = '0.16';

use Catmandu::Sane;
use Moo;

use Catmandu::Fix::Has;
use PICA::Path;

has pica_path => ( fix_arg => 1 );
has path      => ( fix_arg => 1 );
has record    => ( fix_opt => 1 );
has split     => ( fix_opt => 1 );
has join      => ( fix_opt => 1 );
has value     => ( fix_opt => 1 );
has pluck     => ( fix_opt => 1 );

sub emit {
    my ( $self, $fixer ) = @_;
    my $path       = $fixer->split_path( $self->path );
    my $record_key = $fixer->emit_string( $self->record // 'record' );
    my $join_char  = $fixer->emit_string( $self->join // '' );
    my $pica_path  = PICA::Path->new($self->pica_path);

    my ($field_regex, $occurrence_regex, $subfield_regex, $from, $length) = @$pica_path;

    my $var  = $fixer->var;
    my $vals = $fixer->generate_var;
    my $perl = $fixer->emit_declare_vars( $vals, '[]' );

    my $field_regex_var = $fixer->generate_var;
    $perl .= $fixer->emit_declare_vars( $field_regex_var, "qr{$field_regex}" );

    my $subfield_regex_var = $fixer->generate_var;
    $perl .= $fixer->emit_declare_vars( $subfield_regex_var, "qr{$subfield_regex}" );

    my $occurrence_regex_var;
    if (defined $occurrence_regex) {
        $occurrence_regex_var = $fixer->generate_var;
        $perl .= $fixer->emit_declare_vars( $occurrence_regex_var, "qr{$occurrence_regex}" );
    }

    $perl .= $fixer->emit_foreach(
        "${var}->{${record_key}}",
        sub {
            my $var  = shift;
            my $v    = $fixer->generate_var;
            my $perl = "";

            $perl .= "next if ${var}->[0] !~ ${field_regex_var};";

            if (defined $occurrence_regex) {
                $perl .= "next if (!defined ${var}->[1] || ${var}->[1] !~ ${occurrence_regex_var});";
            }

            if ( $self->value ) {
                $perl .= $fixer->emit_declare_vars( $v,
                    $fixer->emit_string( $self->value ) );
            }
            else {
                my $i = $fixer->generate_var;
                my $add_subfields = sub {
                    my $start = shift;
                    if ($self->pluck) {
                        # Treat the subfield_regex as a hash index
                        my $pluck = $fixer->generate_var;
                        return
                        "my ${pluck}  = {};" .
                        "for (my ${i} = ${start}; ${i} < \@{${var}}; ${i} += 2) {".
                            "push(\@{ ${pluck}->{ ${var}->[${i}] } }, ${var}->[${i} + 1]);" .
                        "}" .
                        "for my ${i} (split('','${subfield_regex}')) { " .
                            "push(\@{${v}}, \@{ ${pluck}->{${i}} }) if exists ${pluck}->{${i}};" .
                        "}";
                    }
                    else {
                        # Treat the subfield_regex as regex that needs to match the subfields
                        return
                        "for (my ${i} = ${start}; ${i} < \@{${var}}; ${i} += 2) {".
                            "if (${var}->[${i}] =~ /${subfield_regex}/) {".
                                "push(\@{${v}}, ${var}->[${i} + 1]);".
                            "}".
                        "}";
                    }
                };
                $perl .= $fixer->emit_declare_vars( $v, "[]" );
                $perl .= $add_subfields->(2);
                $perl .= "if (\@{${v}}) {";
                if ( !$self->split ) {
                    $perl .= "${v} = join(${join_char}, \@{${v}});";
                    if ( defined( my $off = $from ) ) {
                        $perl .= "if (eval { ${v} = substr(${v}, ${off}, ${length}); 1 }) {";
                    }
                }
                $perl .= $fixer->emit_create_path(
                    $fixer->var,
                    $path,
                    sub {
                        my $var = shift;
                        if ( $self->split ) {
                            "if (is_array_ref(${var})) {"
                                . "push \@{${var}}, ${v};"
                                . "} else {"
                                . "${var} = [${v}];" . "}";
                        }
                        else {
                            "if (is_string(${var})) {"
                                . "${var} = join(${join_char}, ${var}, ${v});"
                                . "} else {"
                                . "${var} = ${v};" . "}";
                        }
                    }
                );
                if ( defined($from) ) {
                    $perl .= "}";
                }
                $perl .= "}";
            }
            $perl;
        }
    );

    $perl;
}

1;
__END__