package Catmandu::Fix::marc_remove;
use Catmandu::Sane;
use Carp qw(confess);
use Moo;
use Catmandu::Fix::Has;
has marc_path => (fix_arg => 1);
has record => (fix_opt => 1);
sub emit {
my ($self,$fixer) = @_;
my $record_key = $fixer->emit_string($self->record // 'record');
my $marc_path = $self->marc_path;
my $field_regex;
my ($field,$ind1,$ind2,$subfield_regex,$from,$to,$len);
if ($marc_path =~ /(\S{3})(\[(.)?,?(.)?\])?([_a-z0-9^]+)?(\/(\d+)(-(\d+))?)?/) {
$field = $1;
$ind1 = $3;
$ind2 = $4;
$subfield_regex = defined $5 ? "[$5]" : undef;
$from = $7;
$to = $9;
}
else {
confess "invalid marc path";
}
$field_regex = $field;
$field_regex =~ s/\*/./g;
my $var = $fixer->var;
my $new_record = $fixer->generate_var;
my $perl = $fixer->emit_declare_vars($new_record,[]);
$perl .= $fixer->emit_foreach("${var}->{${record_key}}", sub {
my $var = shift;
my $perl = "";
$perl .= "if (${var}->[0] =~ /${field_regex}/) { ";
if (defined $ind1) {
$perl .= "next if (defined ${var}->[1] && ${var}->[1] eq '${ind1}');";
}
if (defined $ind2) {
$perl .= "next if (defined ${var}->[2] && ${var}->[2] eq '${ind2}');";
}
unless (defined $ind1 || defined $ind2 || defined $subfield_regex) {
$perl .= "next;";
}
$perl .= "}";
my $i = $fixer->generate_var;
my $new_subf = $fixer->generate_var;
$perl .= $fixer->emit_declare_vars($new_subf,'[]');
my $del_subfields = sub {
my $start = shift;
my $perl =<<EOF;
${new_subf} = [];
for (my ${i} = ${start}; ${i} < \@{${var}}; ${i} += 2) {
unless (${var}->[${i}] =~ /${subfield_regex}/) {
push \@{${new_subf}} , ${var}->[${i}];
push \@{${new_subf}} , ${var}->[${i}+1];
}
}
splice \@{${var}} , ${start} , int(\@{${var}}), \@{${new_subf}};
EOF
$perl;
};
if (defined $subfield_regex) {
$perl .= "if ( ${var}->[0] =~ /${field_regex}/) {";
$perl .= "if (${var}->[0] =~ /^LDR|^00/) {";
$perl .= $del_subfields->(3);
# Old Catmandu::MARC contained a bug/feature to allow
# for '_' subfields in non-control elements ..for backwards
# compatibility we ignore them
$perl .= "} elsif (defined ${var}->[5] && ${var}->[5] eq '_') {";
$perl .= $del_subfields->(5);
$perl .= "} else {";
$perl .= $del_subfields->(3);
$perl .= "}";
$perl .= "}";
}
$perl .= "push \@${new_record} , ${var} ";
$perl;
});
$perl .= "${var}->{${record_key}} = ${new_record};";
$perl;
}
=head1 NAME
Catmandu::Fix::marc_remove - remove marc (sub)fields
=head1 SYNOPSIS
# remove all marc 600 fields
marc_remove('600')
# remove the 245-a subfield
marc_remove('245a')
# the same with the marc fields in 'record2'
marc_remove('600', '-record', 'record2')
=head1 DESCRIPTION
Read our Wiki pages at L<https://github.com/LibreCat/Catmandu/wiki/Fixes> for a complete
overview of the Fix language.
=head1 SEE ALSO
L<Catmandu::Fix>
=cut
1;