File Coverage

blib/lib/MARC/Spec/Parser.pm

Criterion	Covered	Total	%
statement	149	162	91.9
branch	57	74	77.0
condition	5	6	83.3
subroutine	18	18	100.0
pod	0	2	0.0
total	229	262	87.4

package MARC::Spec::Parser;

use Carp qw(croak);
use Const::Fast;
use Moo;
use MARC::Spec;
use MARC::Spec::Field;
require MARC::Spec::Subfield;
require MARC::Spec::Comparisonstring;
require MARC::Spec::Subspec;
use namespace::clean;

our $VERSION = '1.0.0';

has spec => (
    is => 'rw',
    required => 1
);

has marcspec => (
    is => 'rwp'
);

const my $FIELDTAG => q{^(?(?:[a-z0-9\.]{3,3}|[A-Z0-9\.]{3,3}|[0-9\.]{3,3}))?};
const my $POSITIONORRANGE => q{(?:(?:(?:[0-9]+|#)\-(?:[0-9]+|#))|(?:[0-9]+|#))};
const my $INDEX => qq{(?:\\[(?$POSITIONORRANGE)\\])?};
const my $CHARPOS => qq{\\/(?$POSITIONORRANGE)};
const my $INDICATORS => q{_(?(?:[_a-z0-9][_a-z0-9]{0,1}))};
const my $SUBSPECS => q{(?(?:\\{.+?(?
const my $SUBFIELDS => q{(?\$.+)?};
const my $FIELD => qr/(?(?:$FIELDTAG$INDEX(?:$CHARPOS|$INDICATORS)?$SUBSPECS$SUBFIELDS))/s;
const my $SUBFIELDRANGE => q{(?(?:[0-9a-z]\-[0-9a-z]))};
const my $SUBFIELDTAG => q{(?[\!-\?\[-\\{\\}-~])};
const my $SUBFIELD => qr/(?\$(?:$SUBFIELDRANGE|$SUBFIELDTAG)$INDEX(?:$CHARPOS)?$SUBSPECS)/s;
const my $LEFTSUBTERM => q{^(?(?:\\\(?:(?<=\\\)[\!\=\~\?]|[^\!\=\~\?])+)|(?:(?<=\$)[\!\=\~\?]|[^\!\=\~\?])+)?};
const my $OPERATOR => q{(?\!\=|\!\~|\=|\~|\!|\?)};
const my $SUBTERMS => qq{(?:$LEFTSUBTERM$OPERATOR)?(?.+)}.q{$};
const my $SUBSPEC => qr/(?:\{(.+?)\})/s;
const my $UNESCAPED => qr/(?

const my $MIN_LENGTH_FIELD => 3;
const my $MIN_LENGTH_SUBFIELD => 2;
const my $NO_LENGTH => -1;

my %cache;

sub BUILDARGS {
    my ($class, @args) = @_;
    if (@args % 2 == 1) { unshift @args, "spec" }
    return { @args };
}

sub BUILD {
    my ($self) = @_;
    my $field = $self->_match_field();
    my $ms = MARC::Spec->new($field);
    if($self->{_parsed}->{subfields}) {
        my $subfields = $self->_match_subfields();
        $ms->add_subfields($subfields);
    }
    $self->_set_marcspec($ms);
}

sub _match_field {
    my ($self) = @_;

    _do_checks($self->spec, $MIN_LENGTH_FIELD);

    $self->spec =~ $FIELD;

    %{$self->{_parsed}} = %+;

    if(!$self->{_parsed}->{tag}) {
        _throw("For fieldtag only '.', digits and lowercase alphabetic or digits and upper case alphabetics characters are allowed.", $self->spec);
    }

    if( length $self->{_parsed}->{field}  != length $self->spec ) {
        _throw('Detected useless data fragment or invalid field spec.', $self->spec);
    }

    # create a new Field
    my $field = MARC::Spec::Field->new($self->{_parsed}->{tag});

    if(defined $self->{_parsed}->{indicators}) {
        my $ind1 = substr $self->{_parsed}->{indicators}, 0, 1;
        if('_' ne $ind1) { $field->indicator1($ind1) }

        if(2 == length($self->{_parsed}->{indicators})) {
            my $ind2 = substr $self->{_parsed}->{indicators}, 1, 1;
            if('_' ne $ind2) { $field->indicator2($ind2) }
        }
    } elsif(defined $self->{_parsed}->{charpos}) {
        $field->set_char_start_end($self->{_parsed}->{charpos});
    }

    if(defined $self->{_parsed}->{index}) {
        $field->set_index_start_end($self->{_parsed}->{index});
    }

    if(defined $field->char_start && defined $self->{_parsed}->{subfields}) {
        _throw("Either characterSpec for field or subfields are allowed.", $self->spec);
    }

    $self->{field_base} = $field->base;

    if($self->{_parsed}->{subspecs}) {
        my $field_subspecs = $self->_match_subspecs($self->{_parsed}->{subspecs});
        $self->_populate_subspecs($field, $field_subspecs, [$self->{field_base}]);
    }
    return $field;
}

sub _populate_subspecs {
    my ($self, $spec, $subspecs, $base) = @_;
    foreach my $subspec (@{$subspecs}) {
        # check if array length is above 1
        if(1 < scalar @{$subspec}) {
            # alternatives to array (OR)
            my @or = ();
            foreach my $or_subspec (@{$subspec}) {
                push @or, $self->_match_subterms($or_subspec, $base);
            }
            $spec->add_subspecs([\@or]);
        }
        else {
            $spec->add_subspec( $self->_match_subterms($subspec->[0], $base ) );
        }
    }
}

sub _match_subfields {
    my ($self) = @_;

    _do_checks($self->{_parsed}->{subfields}, $MIN_LENGTH_SUBFIELD);

    my $subfields = [];
    my $i = 0;
    while($self->{_parsed}->{subfields} =~ /$SUBFIELD/g) {
        if(defined $+{range}) {
            my $from = substr $+{range},0,1;
            my $to = substr $+{range},2,1;
            for my $code ( $from .. $to) {
                push @{$subfields}, $self->_create_subfield($code,%+);
            }
        } else {
            push @{$subfields}, $self->_create_subfield(undef,%+);
        }
        $i++;
    }

    if(0 == $i) {
        _throw("Invalid subfield spec detected.", $self->{_parsed}->{subfields});
    }

    return $subfields;
}

sub _create_subfield {
    my ($self,$code,%args) = @_;
    # create a new Subfield
    my $subfield = MARC::Spec::Subfield->new($code // $args{code});

    if(defined $args{index}) {
        $subfield->set_index_start_end($args{index});
    }

    if(defined $args{charpos}) {
        $subfield->set_char_start_end($args{charpos});
    }

    # handle subspecs
    if(defined $args{subspecs}) {
        my $subfield_subspecs = $self->_match_subspecs($args{subspecs});
        $self->_populate_subspecs($subfield, $subfield_subspecs, [$self->{field_base}, $subfield->base]);
    }
    return $subfield;
}

sub _match_subspecs {
    my ($self, $subspecs) = @_;
    my @subspecs;

    foreach ($subspecs =~ /$SUBSPEC/g) {
        push @subspecs, [split /(?
    }
    return \@subspecs;
}

sub _match_subterms {
    my ($self,$subTerms,$context) = @_;

    if($subTerms =~ $UNESCAPED) {
        _throw("Unescaped character detected.", $subTerms);
    }

    if($subTerms !~ /$SUBTERMS/sg) {
        _throw("Assuming invalid spec.", $subTerms);
    }

    # create a new Subspec
    my $subSpec = MARC::Spec::Subspec->new;

    foreach my $side (('left', 'right')) {
        if(defined $+{$side}) {
            if('\\' ne substr $+{$side},0,1) {
                my $spec = _spec_context($+{$side},$context);

                # this prevents the spec parsed again
                if($cache{$spec}) {
                    $subSpec->$side( $cache{$spec} );
                } else {
                    $subSpec->$side( MARC::Spec::Parser->new($spec)->marcspec );

                    $cache{$spec} = $subSpec->$side;
                }
            } else {
                $subSpec->$side( MARC::Spec::Comparisonstring->new(substr $+{$side},1) );
            }
        } elsif($side eq 'left') {
            my $spec = _spec_context(@{$context}[$#{$context}],$context);
            if($cache{$spec}) {
                $subSpec->left( $cache{$spec} );
            } else {
                $subSpec->left( MARC::Spec::Parser->new($spec)->marcspec );
                $cache{$spec} = $subSpec->left;
            }
        } else {
            _throw("Right hand subTerm is missing.", $subTerms);
        }
    }

    if(defined $+{operator}) { $subSpec->operator( $+{operator} )}

    return $subSpec;
}

sub _spec_context {
    my ($spec, $context) = @_;
    my $fieldContext = @{$context}[0];
    my $fullcontext = join '', @{$context};

    if($spec eq $fullcontext) { return $spec }

    my $firstChar = substr $spec,0,1;
    if($firstChar eq '_') {
        my $refPos = index $fullcontext, $firstChar;

        if(0 <= $refPos) {
            if('$' ne substr $fullcontext,$refPos - 1,1) {
               return substr($fullcontext,0,$refPos).$spec;
            }
        }
        return $fullcontext.$spec;
    }

    if($firstChar eq '$') { return $fieldContext.$spec }

    if($firstChar =~ /\[|\//) {
        my $refPos = rindex $fullcontext, $firstChar;

        if(0 <= $refPos) {
            if('$' ne substr $fullcontext,$refPos - 1,1) {
                return substr($fullcontext,0,$refPos).$spec;
            }
        }
        return $fullcontext.$spec;
    }

    return $spec;
}

sub _do_checks {
    my ($spec, $min_length) = @_;

    if(ref \$spec ne 'SCALAR') {
        _throw("Argument must be of type SCALAR.", ref \$spec);
    }

    if($spec =~ /\s/s) {
        _throw("Whitespaces are not allowed.", $spec);
    }

    if($min_length > length $spec) {
        _throw("Spec must be at least ".$min_length." chracters long.", $spec);
    }

    return;
}

sub _throw {
    my ($message, $hint) = @_;
    croak 'MARCspec Parser exception. '.$message.' Tried to parse: '.$hint;
}

1;
__END__