File Coverage

blib/lib/MARC/Lint.pm

Criterion	Covered	Total	%
statement	284	304	93.4
branch	150	188	79.7
condition	41	64	64.0
subroutine	21	22	95.4
pod	9	9	100.0
total	505	587	86.0

package MARC::Lint;

use strict;
use warnings;
use integer;
use MARC::Record;
use MARC::Field;

use MARC::Lint::CodeData qw(%GeogAreaCodes %ObsoleteGeogAreaCodes %LanguageCodes %ObsoleteLanguageCodes);

our $VERSION = 1.50	;

=head1 NAME

MARC::Lint - Perl extension for checking validity of MARC records

=head1 SYNOPSIS

    use MARC::File::USMARC;
    use MARC::Lint;

    my $lint = new MARC::Lint;
    my $filename = shift;

    my $file = MARC::File::USMARC->in( $filename );
    while ( my $marc = $file->next() ) {
        $lint->check_record( $marc );

        # Print the title tag
        print $marc->title, "\n";

        # Print the errors that were found
        print join( "\n", $lint->warnings ), "\n";
    } # while

Given the following MARC record:

    LDR 00000nam  22002538a 4500
    040    _aMdSSJTT
           _cMdSSJTT
    040    _aMdSSJTT
           _beng
           _cMdSSJTT
    100 14 _aWall, Larry.
    110 1  _aO'Reilly & Associates.
    245 90 _aProgramming Perl /
           _aBig Book of Perl /
           _cLarry Wall, Tom Christiansen & Jon Orwant.
    250    _a3rd ed.
    250    _a3rd ed.
    260    _aCambridge, Mass. :
           _bO'Reilly,
           _r2000.
    590 4  _aPersonally signed by Larry.
    856 43 _uhttp://www.perl.com/

the following errors are generated:

    1XX: Only one 1XX tag is allowed, but I found 2 of them.
    100: Indicator 2 must be blank but it's "4"
    245: Indicator 1 must be 0 or 1 but it's "9"
    245: Subfield _a is not repeatable.
    040: Field is not repeatable.
    260: Subfield _r is not allowed.
    856: Indicator 2 must be blank, 0, 1, 2 or 8 but it's "3"

=head1 DESCRIPTION

Module for checking validity of MARC records.  99% of the users will want to do
something like is shown in the synopsis.  The other intrepid 1% will overload the
C module's methods and provide their own special field-level checking.

What this means is that if you have certain requirements, such as making sure that
all 952 tags have a certain call number in them, you can write a function that
checks for that, and still get all the benefits of the MARC::Lint framework.

=head1 EXPORT

None.  Everything is done through objects.

=head1 METHODS

=head2 new()

No parms needed.  The C object is little more than a list of warnings
and a bunch of rules.

=cut

sub new {
    my $class = shift;

    my $self = {
        _warnings => [],
    };
    bless $self, $class;

    $self->_read_rules();

    return $self;
}

=head2 warnings()

Returns a list of warnings found by C and its brethren.

=cut

sub warnings {
        my $self = shift;

        return wantarray ? @{$self->{_warnings}} : scalar @{$self->{_warnings}};
}

=head2 clear_warnings()

Clear the list of warnings for this linter object.  It's automatically called
when you call C.

=cut

sub clear_warnings {
    my $self = shift;

    $self->{_warnings} = [];
}

=head2 warn( $str [, $str...] )

Create a warning message, built from strings passed, like a C
statement.

Typically, you'll leave this to C, but industrious
programmers may want to do their own checking as well.

=cut

sub warn {
    my $self = shift;

    push( @{$self->{_warnings}}, join( "", @_ ) );

    return;
}

=head2 check_record( $marc )

Does all sorts of lint-like checks on the MARC record I<$marc>,
both on the record as a whole, and on the individual fields &
subfields.

=cut

sub check_record {
    my $self = shift;
    my $marc = shift;

    $self->clear_warnings();

    ( (ref $marc) && $marc->isa('MARC::Record') )
        or return $self->warn( "Must pass a MARC::Record object to check_record" );

    my @_1xx = $marc->field( "1.." );
    my $n1xx = scalar @_1xx;
    if ( $n1xx > 1 ) {
        $self->warn( "1XX: Only one 1XX tag is allowed, but I found $n1xx of them." );
    }

    if ( not $marc->field( 245 ) ) {
        $self->warn( "245: No 245 tag." );
    }


    my %field_seen;
    my $rules = $self->{_rules};
    for my $field ( $marc->fields ) {
        my $tagno = $field->tag;

        my $tagrules = '';
        #if 880 field, inherit rules from tagno in subfield _6
        my $is_880 = 0;
        if ($tagno eq '880') {
            $is_880 = 1;
            if ($field->subfield('6')) {
                my $sub6 = $field->subfield('6');
                $tagno = substr($sub6, 0, 3);

                $tagrules = $rules->{$tagno} or next;
                #880 is repeatable, but its linked field may not be
                if ( ($tagrules->{'repeatable'} && ( $tagrules->{'repeatable'} eq 'NR' )) && $field_seen{'880.'.$tagno} ) {
                    $self->warn( "$tagno: Field is not repeatable." );
                } #if repeatability
            } #if subfield 6 present
            else {
                $self->warn( "880: No subfield 6." );
            } #else no subfield 6 in 880 field
        } #if this is 880 field
        else {
            $tagrules = $rules->{$tagno} or next;

            if ( ($tagrules->{'repeatable'} && ( $tagrules->{'repeatable'} eq 'NR' )) && $field_seen{$tagno} ) {
                $self->warn( "$tagno: Field is not repeatable." );
            } #if repeatability
        } #else not 880

        if ( $tagno >= 10 ) {
            for my $ind ( 1..2 ) {
                my $indvalue = $field->indicator($ind);
                if ( not ($indvalue =~ $tagrules->{"ind$ind" . "_regex"}) ) {
                    $self->warn(
                        "$tagno: Indicator $ind must be ",
                        $tagrules->{"ind$ind" . "_desc"},
                        " but it's \"$indvalue\""
                    );
                }
            } # for

            my %sub_seen;
            for my $subfield ( $field->subfields ) {
                my ($code,$data) = @$subfield;

                my $rule = $tagrules->{$code};
                if ( not defined $rule ) {
                    $self->warn( "$tagno: Subfield _$code is not allowed." );
                } elsif ( ($rule eq "NR") && $sub_seen{$code} ) {
                    $self->warn( "$tagno: Subfield _$code is not repeatable." );
                }

                if ( $data =~ /[\t\r\n]/ ) {
                    $self->warn( "$tagno: Subfield _$code has an invalid control character" );
                }

                ++$sub_seen{$code};
            } # for $subfields
        } # if $tagno >= 10

        elsif ($tagno < 10) {
            #check for subfield characters
            if ($field->data() =~ /\x1F/) {
                $self->warn( "$tagno: Subfields are not allowed in fields lower than 010" );
            } #if control field has subfield delimiter
        } #elsif $tagno < 10

        # Check to see if a check_xxx() function exists, and call it on the field if it does
        my $checker = "check_$tagno";
        if ( $self->can( $checker ) ) {
            $self->$checker( $field );
        }

        if ($is_880) {
            ++$field_seen{'880.'.$tagno};
        } #if 880 field
        else {
            ++$field_seen{$tagno};
        }
    } # for my $fields

    return;
}

=head2 check_I( $field )

Various functions to check the different fields.  If the function doesn't exist,
then it doesn't get checked.

=head2 check_020()

Looks at 020$a and reports errors if the check digit is wrong.
Looks at 020$z and validates number if hyphens are present.

Uses Business::ISBN to do validation. Thirteen digit checking is currently done
with the internal sub _isbn13_check_digit(), based on code from Business::ISBN.

TO DO (check_020):

 Fix 13-digit ISBN checking.

=cut

sub check_020 {


    use Business::ISBN;

    my $self = shift;
    my $field = shift;

###################################################

# break subfields into code-data array and validate data

    my @subfields = $field->subfields();

    while (my $subfield = pop(@subfields)) {
        my ($code, $data) = @$subfield;
        my $isbnno = $data;
        #remove any hyphens
        $isbnno =~ s/\-//g;
        #remove nondigits
        $isbnno =~ s/^\D*(\d{9,12}[X\d])\b.*$/$1/;

        #report error if this is subfield 'a'
        #and the first 10 or 13 characters are not a match for $isbnno
        if ($code eq 'a') {
            if ((substr($data,0,length($isbnno)) ne $isbnno)) {
                $self->warn( "020: Subfield a may have invalid characters.");
            } #if first characters don't match

            #report error if no space precedes a qualifier in subfield a
            if ($data =~ /\(/) {
                $self->warn( "020: Subfield a qualifier must be preceded by space, $data.") unless ($data =~ /[X0-9] \(/);
            } #if data has parenthetical qualifier

            #report error if unable to find 10-13 digit string of digits in subfield 'a'
            if (($isbnno !~ /(?:^\d{10}$)|(?:^\d{13}$)|(?:^\d{9}X$)/)) {
                $self->warn( "020: Subfield a has the wrong number of digits, $data.");
            } # if subfield 'a' but not 10 or 13 digit isbn
            #otherwise, check 10 and 13 digit checksums for validity
            else {
                if ((length ($isbnno) == 10)) {

                    if (($Business::ISBN::VERSION gt '2.02_01') || ($Business::ISBN::VERSION gt '2.009')) {
                        $self->warn( "020: Subfield a has bad checksum, $data." ) if (Business::ISBN::valid_isbn_checksum($isbnno) != 1);
                    } #if Business::ISBN version higher than 2.02_01 or 2.009
                    elsif ($Business::ISBN::VERSION lt '2') {
                        $self->warn( "020: Subfield a has bad checksum, $data." ) if (Business::ISBN::is_valid_checksum($isbnno) != 1);
                    } #elsif Business::ISBN version lower than 2
                    else {
                        $self->warn( "Business::ISBN version must be below 2 or above 2.02_02 or 2.009." );
                    } #else Business::ISBN version between 2 and 2.02_02
                } #if 10 digit ISBN has invalid check digit
                # do validation check for 13 digit isbn
#########################################
### Not yet fully implemented ###########
#########################################
                elsif (length($isbnno) == 13){
                    #change line below once Business::ISBN handles 13-digit ISBNs
                    my $is_valid_13 = _isbn13_check_digit($isbnno);
                    $self->warn( "020: Subfield a has bad checksum (13 digit), $data.") unless ($is_valid_13 == 1);
                } #elsif 13 digit ISBN has invalid check digit
###################################################
            } #else subfield 'a' has 10 or 13 digits
        } #if subfield 'a'
        #look for valid isbn in 020$z
        elsif ($code eq 'z') {
            if (($data =~ /^ISBN/) || ($data =~ /^\d*\-\d+/)){
##################################################
## Turned on for now--Comment to unimplement ####
##################################################
                $self->warn( "020:  Subfield z is numerically valid.") if ((length ($isbnno) == 10) && (Business::ISBN::is_valid_checksum($isbnno) == 1));
            } #if 10 digit ISBN has invalid check digit
        } #elsif subfield 'z'

    } # while @subfields

} #check_020

=head2 _isbn13_check_digit($ean)

Internal sub to determine if 13-digit ISBN has a valid checksum. The code is
taken from Business::ISBN::as_ean. It is expected to be temporary until
Business::ISBN is updated to check 13-digit ISBNs itself.

=cut

sub _isbn13_check_digit {

    my $ean = shift;
    #remove and store current check digit
    my $check_digit = chop($ean);

    #calculate valid checksum
    my $sum = 0;
    foreach my $index ( 0, 2, 4, 6, 8, 10 )
        {
        $sum +=     substr($ean, $index, 1);
        $sum += 3 * substr($ean, $index + 1, 1);
        }

    #take the next higher multiple of 10 and subtract the sum.
    #if $sum is 37, the next highest multiple of ten is 40. the
    #check digit would be 40 - 37 => 3.
    my $valid_check_digit = ( 10 * ( int( $sum / 10 ) + 1 ) - $sum ) % 10;

    return $check_digit == $valid_check_digit ? 1 : 0;

} # _isbn13_check_digit

#########################################

=head2 check_041( $field )

Warns if subfields are not evenly divisible by 3 unless second indicator is 7
(future implementation would ensure that each subfield is exactly 3 characters
unless ind2 is 7--since subfields are now repeatable. This is not implemented
here due to the large number of records needing to be corrected.). Validates
against the MARC Code List for Languages (L) using the
MARC::Lint::CodeData data pack to MARC::Lint (%LanguageCodes,
%ObsoleteLanguageCodes).

=cut

sub check_041 {


    my $self = shift;
    my $field = shift;

    # break subfields into code-data array (so the entire field is in one array)

    my @subfields = $field->subfields();
    my @newsubfields = ();

    while (my $subfield = pop(@subfields)) {
        my ($code, $data) = @$subfield;
        unshift (@newsubfields, $code, $data);
    } # while

    #warn if length of each subfield is not divisible by 3 unless ind2 is 7
    unless ($field->indicator(2) eq '7') {
        for (my $index = 0; $index <=$#newsubfields; $index+=2) {
            if (length ($newsubfields[$index+1]) %3 != 0) {
                $self->warn( "041: Subfield _$newsubfields[$index] must be evenly divisible by 3 or exactly three characters if ind2 is not 7, ($newsubfields[$index+1])." );
            } #if field length not divisible evenly by 3
##############################################
# validation against code list data
## each subfield has a multiple of 3 chars
# need to look at each group of 3 characters
            else {

                #break each character of the subfield into an array position
                my @codechars = split '', $newsubfields[$index+1];

                my $pos = 0;
                #store each 3 char code in a slot of @codes041
                my @codes041 = ();
                while ($pos <= $#codechars) {
                    push @codes041, (join '', @codechars[$pos..$pos+2]);
                    $pos += 3;
                }


                foreach my $code041 (@codes041) {
                    #see if language code matches valid code
                    my $validlang = $LanguageCodes{$code041} ? 1 : 0;
                    #look for invalid code match if valid code was not matched
                    my $obsoletelang = $ObsoleteLanguageCodes{$code041} ? 1 : 0;

                    # skip valid subfields
                    unless ($validlang) {
#report invalid matches as possible obsolete codes
                        if ($obsoletelang) {
                            $self->warn( "041: Subfield _$newsubfields[$index], $newsubfields[$index+1], may be obsolete.");
                        }
                        else {
                            $self->warn( "041: Subfield _$newsubfields[$index], $newsubfields[$index+1] ($code041), is not valid.");
                        } #else code not found
                    } # unless found valid code
                } #foreach code in 041
            } # else subfield has multiple of 3 chars
##############################################
        } # foreach subfield
    } #unless ind2 is 7
} #check_041

=head2 check_043( $field )

Warns if each subfield a is not exactly 7 characters. Validates each code
against the MARC code list for Geographic Areas (L)
using the MARC::Lint::CodeData data pack to MARC::Lint (%GeogAreaCodes,
%ObsoleteGeogAreaCodes).

=cut

sub check_043 {

    my $self = shift;
    my $field = shift;

    # break subfields into code-data array (so the entire field is in one array)

    my @subfields = $field->subfields();
    my @newsubfields = ();

    while (my $subfield = pop(@subfields)) {
        my ($code, $data) = @$subfield;
        unshift (@newsubfields, $code, $data);
    } # while

    #warn if length of subfield a is not exactly 7
    for (my $index = 0; $index <=$#newsubfields; $index+=2) {
        if (($newsubfields[$index] eq 'a') && (length ($newsubfields[$index+1]) != 7)) {
            $self->warn( "043: Subfield _a must be exactly 7 characters, $newsubfields[$index+1]" );
        } # if suba and length is not 7
        #check against code list for geographic areas.
        elsif ($newsubfields[$index] eq 'a') {

            #see if geog area code matches valid code
            my $validgac = $GeogAreaCodes{$newsubfields[$index+1]} ? 1 : 0;
            #look for obsolete code match if valid code was not matched
            my $obsoletegac = $ObsoleteGeogAreaCodes{$newsubfields[$index+1]} ? 1 : 0;

            # skip valid subfields
            unless ($validgac) {
                #report invalid matches as possible obsolete codes
                if ($obsoletegac) {
                    $self->warn( "043: Subfield _a, $newsubfields[$index+1], may be obsolete.");
                }
                else {
                    $self->warn( "043: Subfield _a, $newsubfields[$index+1], is not valid.");
                } #else code not found
            } # unless found valid code

        } #elsif suba
    } #foreach subfield
} #check_043

=head2 check_245( $field )

 -Makes sure $a exists (and is first subfield).
 -Warns if last character of field is not a period
 --Follows LCRI 1.0C, Nov. 2003 rather than MARC21 rule
 -Verifies that $c is preceded by / (space-/)
 -Verifies that initials in $c are not spaced
 -Verifies that $b is preceded by :;= (space-colon, space-semicolon, space-equals)
 -Verifies that $h is not preceded by space unless it is dash-space
 -Verifies that data of $h is enclosed in square brackets
 -Verifies that $n is preceded by . (period)
  --As part of that, looks for no-space period, or dash-space-period (for replaced elipses)
 -Verifies that $p is preceded by , (no-space-comma) when following $n and . (period) when following other subfields.
 -Performs rudimentary article check of 245 2nd indicator vs. 1st word of 245$a (for manual verification).

 Article checking is done by internal _check_article method, which should work for 130, 240, 245, 440, 630, 730, and 830.

=cut

sub check_245 {

    my $self = shift;
    my $field = shift;

    #set tagno for reporting
    my $tagno = '245';

    if ( not $field->subfield( "a" ) ) {
        $self->warn( "245: Must have a subfield _a." );
    }

    # break subfields into code-data array (so the entire field is in one array)

    my @subfields = $field->subfields();
    my @newsubfields = ();
    my $has_sub_6 = 0;

    while (my $subfield = pop(@subfields)) {
        my ($code, $data) = @$subfield;
        #check for subfield 6 being present
        $has_sub_6 = 1 if ($code eq '6');
        unshift (@newsubfields, $code, $data);
    } # while

    # 245 must end in period (may want to make this less restrictive by allowing trailing spaces)
    #do 2 checks--for final punctuation (MARC21 rule), and for period (LCRI 1.0C, Nov. 2003; LCPS 1.7.1)
    if ($newsubfields[$#newsubfields] !~ /[.?!]$/) {
        $self->warn ( "245: Must end with . (period).");
    }
    elsif($newsubfields[$#newsubfields] =~ /[?!]$/) {
        $self->warn ( "245: MARC21 allows ? or ! as final punctuation but LCRI 1.0C, Nov. 2003 (LCPS 1.7.1 for RDA records), requires period.");
    }

    ##Check for first subfield
    #subfield a should be first subfield (or 2nd if subfield '6' is present)
    if ($has_sub_6) {
        #make sure there are at least 2 subfields
        if ($#newsubfields < 3) {
            $self->warn ("$tagno: May have too few subfields.");
        } #if fewer than 2 subfields
        else {
            if ($newsubfields[0] ne '6') {
                $self->warn ( "$tagno: First subfield must be _6, but it is $newsubfields[0]");
            } #if 1st subfield not '6'
            if ($newsubfields[2] ne 'a') {
                $self->warn ( "$tagno: First subfield after subfield _6 must be _a, but it is _$newsubfields[2]");
            } #if 2nd subfield not 'a'
        } #else at least 2 subfields
    } #if has subfield 6
    else {
        #1st subfield must be 'a'
        if ($newsubfields[0] ne 'a') {
            $self->warn ( "$tagno: First subfield must be _a, but it is _$newsubfields[0]");
        } #if 2nd subfield not 'a'
    } #else no subfield _6
    ##End check for first subfield

    #subfield c, if present, must be preceded by /
    #also look for space between initials
    if ($field->subfield("c")) {

        for (my $index = 2; $index <=$#newsubfields; $index+=2) {
# 245 subfield c must be preceded by / (space-/)
            if ($newsubfields[$index] eq 'c') {
                $self->warn ( "245: Subfield _c must be preceded by /") if ($newsubfields[$index-1] !~ /\s\/$/);
                # 245 subfield c initials should not have space
                $self->warn ( "245: Subfield _c initials should not have a space.") if (($newsubfields[$index+1] =~ /\b\w\. \b\w\./) && ($newsubfields[$index+1] !~ /\[\bi\.e\. \b\w\..*\]/));
                last;
            } #if
        } #for
    } # subfield c exists

    #each subfield b, if present, should be preceded by :;= (colon, semicolon, or equals sign)
    ### Are there others? ###
    if ($field->subfield("b")) {

        # 245 subfield b should be preceded by space-:;= (colon, semicolon, or equals sign)
        for (my $index = 2; $index <=$#newsubfields; $index+=2) {
#report error if subfield 'b' is not preceded by space-:;= (colon, semicolon, or equals sign)
            if (($newsubfields[$index] eq 'b') && ($newsubfields[$index-1] !~ / [:;=]$/)) {
                $self->warn ( "245: Subfield _b should be preceded by space-colon, space-semicolon, or space-equals sign.");
            } #if
        } #for
    } # subfield b exists


    #each subfield h, if present, should be preceded by non-space
    if ($field->subfield("h")) {

        # 245 subfield h should not be preceded by space
        for (my $index = 2; $index <=$#newsubfields; $index+=2) {
            #report error if subfield 'h' is preceded by space (unless dash-space)
            if (($newsubfields[$index] eq 'h') && ($newsubfields[$index-1] !~ /(\S$)|(\-\- $)/)) {
                $self->warn ( "245: Subfield _h should not be preceded by space.");
            } #if h and not preceded by no-space (unless dash)
            #report error if subfield 'h' does not start with open square bracket with a matching close bracket
            ##could have check against list of valid values here
            if (($newsubfields[$index] eq 'h') && ($newsubfields[$index+1] !~ /^\[\w*\s*\w*\]/)) {
                $self->warn ( "245: Subfield _h must have matching square brackets, $newsubfields[$index].");
            }
        } #for
    } # subfield h exists

    #each subfield n, if present, must be preceded by . (period)
    if ($field->subfield("n")) {

        # 245 subfield n must be preceded by . (period)
        for (my $index = 2; $index <=$#newsubfields; $index+=2) {
            #report error if subfield 'n' is not preceded by non-space-period or dash-space-period
            if (($newsubfields[$index] eq 'n') && ($newsubfields[$index-1] !~ /(\S\.$)|(\-\- \.$)/)) {
                $self->warn ( "245: Subfield _n must be preceded by . (period).");
            } #if
        } #for
    } # subfield n exists

    #each subfield p, if present, must be preceded by a , (no-space-comma) if it follows subfield n, or by . (no-space-period or dash-space-period) following other subfields
    if ($field->subfield("p")) {

        # 245 subfield p must be preceded by . (period) or , (comma)
        for (my $index = 2; $index <=$#newsubfields; $index+=2) {
#only looking for subfield p
            if ($newsubfields[$index] eq 'p') {
# case for subfield 'n' being field before this one (allows dash-space-comma)
                if (($newsubfields[$index-2] eq 'n') && ($newsubfields[$index-1] !~ /(\S,$)|(\-\- ,$)/)) {
                    $self->warn ( "245: Subfield _p must be preceded by , (comma) when it follows subfield _n.");
                } #if subfield n precedes this one
                # elsif case for subfield before this one is not n
                elsif (($newsubfields[$index-2] ne 'n') && ($newsubfields[$index-1] !~ /(\S\.$)|(\-\- \.$)/)) {
                    $self->warn ( "245: Subfield _p must be preceded by . (period) when it follows a subfield other than _n.");
                } #elsif subfield p preceded by non-period when following a non-subfield 'n'
            } #if index is looking at subfield p
        } #for
    } # subfield p exists

######################################
#check for invalid 2nd indicator
$self->_check_article($field);

} # check_245




############
# Internal #
############

=head2 _check_article

Check of articles is based on code from Ian Hamilton. This version is more
limited in that it focuses on English, Spanish, French, Italian and German
articles. Certain possible articles have been removed if they are valid English
non-articles. This version also disregards 008_language/041 codes and just uses
the list of articles to provide warnings/suggestions.

source for articles = L

Should work with fields 130, 240, 245, 440, 630, 730, and 830. Reports error if
another field is passed in.

=cut

sub _check_article {

    my $self = shift;
    my $field = shift;

#add articles here as needed
##Some omitted due to similarity with valid words (e.g. the German 'die').
    my %article = (
        'a' => 'eng glg hun por',
        'an' => 'eng',
        'das' => 'ger',
        'dem' => 'ger',
        'der' => 'ger',
        'ein' => 'ger',
        'eine' => 'ger',
        'einem' => 'ger',
        'einen' => 'ger',
        'einer' => 'ger',
        'eines' => 'ger',
        'el' => 'spa',
        'en' => 'cat dan nor swe',
        'gl' => 'ita',
        'gli' => 'ita',
        'il' => 'ita mlt',
        'l' => 'cat fre ita mlt',
        'la' => 'cat fre ita spa',
        'las' => 'spa',
        'le' => 'fre ita',
        'les' => 'cat fre',
        'lo' => 'ita spa',
        'los' => 'spa',
        'os' => 'por',
        'the' => 'eng',
        'um' => 'por',
        'uma' => 'por',
        'un' => 'cat spa fre ita',
        'una' => 'cat spa ita',
        'une' => 'fre',
        'uno' => 'ita',
    );

#add exceptions here as needed
# may want to make keys lowercase
    my %exceptions = (
        'A & E' => 1,
        'A & ' => 1,
        'A-' => 1,
        'A+' => 1,
        'A is ' => 1,
        'A isn\'t ' => 1,
        'A l\'' => 1,
        'A la ' => 1,
        'A posteriori' => 1,
        'A priori' => 1,
        'A to ' => 1,
        'El Nino' => 1,
        'El Salvador' => 1,
        'L is ' => 1,
        'L-' => 1,
        'La Salle' => 1,
        'Las Vegas' => 1,
        'Lo cual' => 1,
        'Lo mein' => 1,
        'Lo que' => 1,
        'Los Alamos' => 1,
        'Los Angeles' => 1,
    );

    #get tagno to determine which indicator to check and for reporting
    my $tagno = $field->tag();
    #retrieve tagno from subfield 6 if 880 field
    if ($tagno eq '880') {
        if ($field->subfield('6')) {
            my $sub6 = $field->subfield('6');
            $tagno = substr($sub6, 0, 3);
        } #if subfield 6
    } #if 880 field

    #$ind holds nonfiling character indicator value
    my $ind = '';
    #$first_or_second holds which indicator is for nonfiling char value
    my $first_or_second = '';
    if ($tagno !~ /^(?:130|240|245|440|630|730|830)$/) {
        print $tagno, " is not a valid field for article checking\n";
        return;
    } #if field is not one of those checked for articles
    #130, 630, 730 => ind1
    elsif ($tagno =~ /^(?:130|630|730)$/) {
        $ind = $field->indicator(1);
        $first_or_second = '1st';
    } #if field is 130, 630, or 730
    #240, 245, 440, 830 => ind2
    elsif ($tagno =~ /^(?:240|245|440|830)$/) {
        $ind = $field->indicator(2);
        $first_or_second = '2nd';
    } #if field is 240, 245, 440, or 830


    #report non-numeric non-filing indicators as invalid
    $self->warn ( $tagno, ": Non-filing indicator is non-numeric" ) unless ($ind =~ /^[0-9]$/);
    #get subfield 'a' of the title field
    my $title = $field->subfield('a') || '';


    my $char1_notalphanum = 0;
    #check for apostrophe, quote, bracket,  or parenthesis, before first word
    #remove if found and add to non-word counter
    while ($title =~ /^["'\[\(*]/){
        $char1_notalphanum++;
        $title =~ s/^["'\[\(*]//;
    }
    # split title into first word + rest on space, parens, bracket, apostrophe, quote, or hyphen
    my ($firstword, $separator, $etc) = $title =~ /^([^ \(\)\[\]'"\-]+)([ \(\)\[\]'"\-])?(.*)/i;
        $firstword = '' if ! defined( $firstword );
        $separator = '' if ! defined( $separator );
        $etc = '' if ! defined( $etc );

    #get length of first word plus the number of chars removed above plus one for the separator
    my $nonfilingchars = length($firstword) + $char1_notalphanum + 1;

    #check to see if first word is an exception
    my $isan_exception = 0;
    $isan_exception = grep {$title =~ /^\Q$_\E/i} (keys %exceptions);

    #lowercase chars of $firstword for comparison with article list
    $firstword = lc($firstword);

    my $isan_article = 0;

    #see if first word is in the list of articles and not an exception
    $isan_article = 1 if (($article{$firstword}) && !($isan_exception));

    #if article then $nonfilingchars should match $ind
    if ($isan_article) {
        #account for quotes, apostrophes, parens, or brackets before 2nd word
#        if (($separator eq ' ') && ($etc =~ /^['"]/)) {
        if (($separator) && ($etc =~ /^[ \(\)\[\]'"\-]+/)) {
            while ($etc =~ /^[ "'\[\]\(\)*]/){
                $nonfilingchars++;
                $etc =~ s/^[ "'\[\]\(\)*]//;
            } #while etc starts with nonfiling chars
        } #if separator defined and etc starts with nonfiling chars
        #special case for 'en' (unsure why)
        if ($firstword eq 'en') {
            $self->warn ( $tagno, ": First word, , $firstword, may be an article, check $first_or_second indicator ($ind)." ) unless (($ind eq '3') || ($ind eq '0'));
        }
        elsif ($nonfilingchars ne $ind) {
            $self->warn ( $tagno, ": First word, $firstword, may be an article, check $first_or_second indicator ($ind)." );
        } #unless ind is same as length of first word and nonfiling characters
    } #if first word is in article list
    #not an article so warn if $ind is not 0
    else {
        unless ($ind eq '0') {
            $self->warn ( $tagno, ": First word, $firstword, does not appear to be an article, check $first_or_second indicator ($ind)." );
        } #unless ind is 0
    } #else not in article list

#######################################

} #_check_article


############

=head1 SEE ALSO

Check the docs for L.  All software links are there.

=head1 TODO

=over 4

=item * Subfield 6

For subfield 6, it should always be the 1st subfield according to MARC 21 specifications. Perhaps a generic check should be added that warns if subfield 6 is not the 1st subfield.

=item * Subfield 8.

This subfield could be the 1st or 2nd subfield, so the code that checks for the 1st few subfields (check_245, check_250) should take that into account.

=item * Subfield 9

This subfield is not officially allowed in MARC, since it is locally defined. Some way needs to be made to allow messages/warnings about this subfield to be turned off (or otherwise deal with records using/allowing locally defined subfield 9).

=item * 008 length and presence check

Currently, 008 validation is not implemented in MARC::Lint, but is left to MARC::Errorchecks. It might be useful if MARC::Lint's basic validation checks included a verification that the 008 exists and is exactly 40 characters long. Additional 008-related checking and byte validation would remain in MARC::Errorchecks.

=item * ISBN and ISSN checking

020 and 022 fields are validated with the C and
C modules, respectively. Business::ISBN versions between 2 and
2.02_01 are incompatible with MARC::Lint.

=item * check_041 cleanup

Splitting subfield code strings every 3 chars could probably be written more efficiently.

=item * check_245 cleanup

The article checking in particular.

=item * Method for turning off checks

Provide a way for users to skip checks more easily when using check_record, or a
specific check_xxx method (e.g. skip article checking).

=back

=head1 LICENSE

This code may be distributed under the same terms as Perl itself.

Please note that these modules are not products of or supported by the
employers of the various contributors to the code.

=cut

# Used only to read the stuff from __DATA__
sub _read_rules {
    my $self = shift;

    my $tell = tell(DATA);  # Stash the position so we can reset it for next time

    local $/ = "";
    while ( my $tagblock =  ) {
        my @lines = split( /\n/, $tagblock );
        s/\s+$// for @lines;

        next unless @lines >= 4; # Some of our entries are tag-only

        my $tagline = shift @lines;
        my @keyvals = split( /\s+/, $tagline, 3 );
        my $tagno = shift @keyvals;
        my $repeatable = shift @keyvals;

        $self->_parse_tag_rules( $tagno, $repeatable, @lines );
    } # while

    # Set the pointer back to where it was, in case we do this again
    seek( DATA, $tell, 0 );
}

sub _parse_tag_rules {
    my $self = shift;
    my $tagno = shift;
    my $repeatable = shift;
    my @lines = @_;

    my $rules = ($self->{_rules}->{$tagno} ||= {});
    $rules->{'repeatable'} = $repeatable;

    for my $line ( @lines ) {
        my @keyvals = split( /\s+/, $line, 3 );
        my $key = shift @keyvals;
        my $val = shift @keyvals;

        # Do magic for indicators
        if ( $key =~ /^ind/ ) {
            $rules->{$key} = $val;

            my $desc;
            my $regex;

            if ( $val eq "blank" ) {
                $desc = "blank";
                $regex = qr/^ $/;
            } else {
                $desc = _nice_list($val);
                $val =~ s/^b/ /;
                $regex = qr/^[$val]$/;
            }

            $rules->{$key."_desc"} = $desc;
            $rules->{$key."_regex"} = $regex;
        } # if indicator
        else {
            if ( $key =~ /(.)-(.)/ ) {
                my ($min,$max) = ($1,$2);
                $rules->{$_} = $val for ($min..$max);
            } else {
                $rules->{$key} = $val;
            }
        } # not an indicator
    } # for $line
}


sub _nice_list {
    my $str = shift;

    if ( $str =~ s/(\d)-(\d)/$1 thru $2/ ) {
        return $str;
    }

    my @digits = split( //, $str );
    $digits[0] = "blank" if $digits[0] eq "b";
    my $last = pop @digits;
    return join( ", ", @digits ) . " or $last";
}

sub _ind_regex {
    my $str = shift;

    return qr/^ $/ if $str eq "blank";

    return qr/^[$str]$/;
}


1;

__DATA__