File Coverage

blib/lib/PICA/Path.pm

Criterion	Covered	Total	%
statement	79	95	83.1
branch	47	58	81.0
condition	15	29	51.7
subroutine	8	11	72.7
pod	4	6	66.6
total	153	199	76.8

package PICA::Path;
use strict;
use warnings;

our $VERSION = '0.33';

use Carp qw(confess);
use Scalar::Util qw(reftype);

use overload '""' => \&stringify;

sub new {
    my ($class, $path) = @_;

    confess "invalid pica path" if $path !~ /
        ([012*.][0-9*.][0-9*.][A-Z@*.]) # tag
        (\[([0-9*.]{2})\])?             # occurence
        (\$?([_A-Za-z0-9]+))?           # subfields
        (\/(\d+)?(-(\d+)?)?)?           # position
    /x;

    my $field      = $1;
    my $occurrence = $3;
    my $subfield   = defined $5 ? "[$5]" : "[_A-Za-z0-9]";

    my @position;
    if (defined $6) { # from, to
        my ($from, $dash, $to, $length) = ($7, $8, $9, 0);

        if ($dash) {
            confess "invalid pica path" unless defined($from // $to); # /-
        }

        if (defined $to) {
            if (!$from and $dash) { # /-X
                $from = 0;
            }
            $length = $to - $from + 1;
        } else {
            if ($8) {
                $length = undef;
            } else {
                $length = 1;
            }
        }

        if (!defined $length or $length >= 1) {
            unless (!$from and !defined $length) { # /0-
                @position = ($from, $length);
            }
        }
    }

    $field =~ s/\*/./g;
    $field = qr{$field};

    if (defined $occurrence) {
        $occurrence =~ s/\*/./g;
        $occurrence = qr{$occurrence};
    }

    $subfield = qr{$subfield};

    bless [ $field, $occurrence, $subfield, @position ], $class;
}

sub match_field {
    my ($self, $field) = @_;

    if ( $field->[0] =~ $self->[0] &&
        (!$self->[1] || (defined $field->[1] && $field->[1] =~ $self->[1])) ) {
        return $field;
    }

    return
}

sub match_subfields {
    my ($self, $field) = @_;

    my $subfield_regex = $self->[2];
    my $from           = $self->[3];
    my $length         = $self->[4];

    my @values;

    for (my $i = 2; $i < @$field; $i += 2) {
        if ($field->[$i] =~ $subfield_regex) {
            my $value = $field->[$i + 1];
            if (defined $from) {
                $value = $length ? substr($value, $from, $length) :
                                   substr($value, $from);
                next if '' eq ($value // '');
            }
            push @values, $value;
        }
    }

    return @values;
}

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

    $record = $record->{record} if reftype $record eq 'HASH';
    return [ grep { $self->match_field($_) } @$record ];
}

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

    $record = $record->{record} if reftype $record eq 'HASH';

    my @values;

    foreach my $field (grep { $self->match_field($_) } @$record) {
        push @values, $self->match_subfields($field);
    }

    return @values;
}

sub stringify {
    my ($self, $short) = @_;

    my ($field, $occurrence, $subfields) = map {
        defined $_ ? do {
            s/^\(\?[^:]*:(.*)\)$/$1/;
            s/\./*/g;
            $_ } : undef
        } ($self->[0], $self->[1], $self->[2]);

    my $str = $field;

    if (defined $occurrence) {
        $str .= "[$occurrence]";
    }

    if (defined $subfields and $subfields ne '[_A-Za-z0-9]') {
        $subfields =~ s/\[|\]//g;
        unless( $short and $subfields !~  /^\$/ ) {
            $str .= '$';
        }
        $str .= $subfields;
    }

    my ($from, $length, $pos) = ($self->[3], $self->[4]);
    if (defined $from) {
        if ($from) {
            $pos = $from;
        }
        if (!defined $length) {
            if ($from) {
                $pos = "$from-";
            }
        } elsif ($length > 1) {
            $pos .= '-' . ($from + $length - 1);
        } elsif ($length == 1 && !$from) {
            $pos = 0;
        }
    }

    $str .= "/$pos" if defined $pos;

    $str;
}

1;
__END__