File Coverage

blib/lib/PICA/Modification.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

package PICA::Modification;
{
  $PICA::Modification::VERSION = '0.16';
}
#ABSTRACT: Idempotent modification of an identified PICA+ record

use strict;
use warnings;
use v5.10;

use parent 'Exporter';

use PICA::Record 0.584;
use Scalar::Util qw(blessed);
use Text::Diff ();

our @ATTRIBUTES = qw(id iln epn del add);


sub new {
	my $class = shift;
	my $attributes = @_ % 2 ? (blessed $_[0] ? $_[0]->attributes : $_[0]) : {@_};

    no strict 'refs';
    my $self = bless {
		map { $_ => $attributes->{$_} } @{ $class.'::ATTRIBUTES' }
	}, $class;

	$self->check;
}


sub attributes {
	my $self = shift;

    no strict 'refs';
	return { map { $_ => $self->{$_} } @{ ref($self).'::ATTRIBUTES' } };
}


sub error {
    my $self = shift;

    return (scalar keys %{$self->{errors}}) unless @_;

    my $attribute = shift;
    return $self->{errors}->{$attribute} unless @_;

    my $message = shift;
    $self->{errors}->{$attribute} = $message;

    return $message;
}


sub check {
	my $self = shift;

	$self->{errors} = { };

	foreach my $attr (@ATTRIBUTES) {
		my $value = $self->{$attr} // '';
	    $value =~ s/^\s+|\s+$//g;
		$self->{$attr} = $value;
	}

	$self->{ppn} = '';
	$self->{dbkey} = '';
    if ($self->{id} =~ /^(([a-z]([a-z0-9-]?[a-z0-9]+))*):ppn:(\d+\d*[Xx]?)$/) {
        $self->{ppn}   = uc($4) if defined $4;
        $self->{dbkey} = lc($1) if defined $1;
    } elsif ($self->{id} eq '') {
        $self->error( id => 'missing record identifier' );
    } else {
        $self->error( id => 'malformed record identifier' );
    }

    $self->error( iln => "malformed ILN" ) unless $self->{iln} =~ /^\d*$/;
    $self->error( epn => "malformed EPN" ) unless $self->{epn} =~ /^\d*$/;

    my %must_delete;

    if ($self->{add}) {
        my $pica = eval { PICA::Record->new( $self->{add} ) };
        if ($pica) {
			$self->error( iln => 'missing ILN for add' )
				if !$self->{iln} and $pica->field(qr/^1/);
			$self->error( epn => 'missing EPN for add' )
				if !$self->{epn} and $pica->field(qr/^2/);
            $pica->sort;
            foreach ($pica->fields) {
                my $tag = $_->tag;
                # TODO: remove occurrence from level 2 tags
                $must_delete{$tag} = 1;
            }
	    	$self->{add} = "$pica";
			chomp $self->{add};
        } else {
            $self->error( add => "malformed fields to add" );
        }
    }

	my @del = grep { $_ !~ /^\s*$/ } split(/\s*,\s*/, $self->{del});

	$self->error( del => 'malformed fields to remove' )
        if grep { $_ !~  qr{^[012]\d\d[A-Z@](/\d\d)?$} } @del;

	$self->error( epn => 'missing EPN for remove' )
		if !$self->{epn} and grep { /^2/ } @del;

	$self->error( iln => 'missing ILN for remove' )
		if !$self->{iln} and grep { /^1/ } @del;

    delete $must_delete{$_} for @del;
    if (%must_delete) {
        $self->error( del => 'fields to add must also be deleted' );
    }

    $self->{del} = join (',', sort @del);

    if (!$self->{add} and !$self->{del} and !$self->error('del')) {
        $self->error( del => 'edit must not be empty' );
    }

    if ( !$self->error('del') ) {
        my @bad = grep { /^(003@|101@|203@)/; } @del;
        if (@bad) {
            $self->error( del => 'must not modify field: '.join(', ',@bad) );
        }
	}

    return $self;
}


sub apply {
    my ($self, $pica, %args) = @_;

    return if $self->error;

	if (!$pica) {
		$self->error( id => 'record not found' );
		return;
	}
	if ( defined $pica->ppn and $pica->ppn ne $self->{ppn} ) {
	    $self->error( id => 'PPN does not match' );
		return;
    }

    my $add = PICA::Record->new( $self->{add} || '' );
    my $del = [ split ',', $self->{del} ];

    my @level0 = grep /^0/, @$del;
    my @level1 = grep /^1/, @$del;
    my @level2 = grep /^2/, @$del;

    my $iln = $self->{iln};
    my $epn = $self->{epn};

    # Level 0
    my $result = $pica->main;
    $result->remove( @level0 ) if @level0;
    $result->append( $add->main );

    # Level 1
	if (@level1 and !$pica->holdings($iln)) {
		$self->error('iln', 'ILN not found');
		return;
    }

    foreach my $h ( $pica->holdings ) {
        if ($iln and $iln eq ($h->iln // '')) {
            @level1 = map { $_ =~ qr{/} ? $_ : ($_,"$_/..") } @level1;
            $h->remove( @level1 );
            $h->append( $add->field(qr/^1/) );
        }
        $result->append( $h->fields );

	    # TODO: Level 2
    }

    $result->sort;

    return $result;
}



sub diff {
    my ($self, $record, $context) = @_;

    my $result = $self->apply( $record ) or return;

    $context //= (scalar $record->fields + scalar $result->fields);

    my $diff = Text::Diff::diff(
        \($record->string),
        \($result->string),
        {CONTEXT => $context}
    );

    $diff =~ s/^@.*$ \n//xgm;

    return $diff;
}

1;




__END__