The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package Catmandu::Fix::marc_map;

use Catmandu::Sane;
use Carp qw(confess);
use Moo;

has path           => (is => 'ro', required => 1);
has marc_path      => (is => 'ro', required => 1);
has record_key     => (is => 'ro', default => sub { "record" });
has join_char      => (is => 'ro', default => sub { "" });
has value          => (is => 'ro');
has field_regex    => (is => 'ro');
has subfield_regex => (is => 'ro');
has field          => (is => 'ro');
has ind1           => (is => 'ro');
has ind2           => (is => 'ro');
has from           => (is => 'ro');
has to             => (is => 'ro');

around BUILDARGS => sub {
    my ($orig, $class, $marc_path, $path, %opts) = @_;

    my $attrs = {
        marc_path => $marc_path,
        path => $path,
    };
    $attrs->{record_key} = $opts{-record} if defined $opts{-record};
    $attrs->{join_char}  = $opts{-join}   if defined $opts{-join};
    $attrs->{value}      = $opts{-value}  if defined $opts{-value};

    if ($marc_path =~ /(\S{3})(\[(.)?,?(.)?\])?([_a-z0-9^]+)?(\/(\d+)(-(\d+))?)?/) {
        $attrs->{field}          = $1;
        $attrs->{ind1}           = $3;
        $attrs->{ind2}           = $4;
        $attrs->{subfield_regex} = $5 ? "[$5]" : "[a-z0-9_]";
        $attrs->{from}           = $7;
        $attrs->{to}             = $9;
    } else {
        confess "invalid marc path";
    }

    $attrs->{field_regex} = $attrs->{field};
    $attrs->{field_regex} =~ s/\*/./g;

    $orig->($class, $attrs);
};

sub emit {
    my ($self, $fixer) = @_;
    my $path = $fixer->split_path($self->path);
    my $record_key = $fixer->emit_string($self->record_key);
    my $join_char = $fixer->emit_string($self->join_char);
    my $field_regex = $self->field_regex;
    my $subfield_regex = $self->subfield_regex;
    my $var = $fixer->var;

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

    $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}/;";
        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;
                "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 .= "if (${var}->[0] =~ /^LDR|^00/) {";
            $perl .= $add_subfields->(3);
            $perl .= "} else {";
            $perl .= $add_subfields->(5);
            $perl .= "}";
            $perl .= "if (\@{${v}}) {";
            $perl .= "${v} = join(${join_char}, \@{${v}});";
            if (defined(my $off = $self->from)) {
                my $len = defined $self->to ? $self->to - $off + 1 : 1;
                $perl .= "if (eval { ${v} = substr(${v}, ${off}, ${len}); 1 }) {";
            }
            $perl .= $fixer->emit_create_path($fixer->var, $path, sub {
                my $var = shift;
                "if (is_string(${var})) {".
                    "${var} = join(${join_char}, ${var}, ${v});".
                "} else {".
                    "${var} = ${v};".
                "}";
            });
            if (defined($self->from)) {
                $perl .= "}";
            }
            $perl .= "}";
        }
        $perl;
    });

    $perl;
}

1;

=head1 NAME

Catmandu::Fix::marc_map - copy marc values of one field to a new field

=head1 SYNOPSIS

    # Copy all 245 subfields into the my.title hash
    marc_map('245','my.title');

    # Copy the 245-$a$b$c subfields into the my.title hash
    marc_map('245abc','my.title');

    # Copy the 100 subfields into the my.authors array
    marc_map('100','my.authors.$append');

    # Add the 710 subfields into the my.authors array
    marc_map('710','my.authors.$append');

    # Copy the 600-$x subfields into the my.subjects array while packing each into a genre.text hash
    marc_map('600x','my.subjects.$append.genre.text');

    # Copy the 008 characters 35-35 into the my.language hash
    marc_map('008_/35-35','my.language');

    # Copy all the 600 fields into a my.stringy hash joining them by '; '
    marc_map('600','my.stringy', -join => '; ');

    # When 024 field exists create the my.has024 hash with value 'found'
    marc_map('024','my.has024', -value => 'found');

    # Do the same examples now with the marc fields in 'record2'
    marc_map('245','my.title', -record => 'record2');

    # Copy all 100 subfields except the digits to the 'author' field
    marc_map('100^0123456789','author');

=cut