File Coverage

blib/lib/MARC/Record.pm

Criterion	Covered	Total	%
statement	190	200	95.0
branch	56	66	84.8
condition	3	8	37.5
subroutine	35	36	97.2
pod	23	23	100.0
total	307	333	92.1

package MARC::Record;

=head1 NAME

MARC::Record - Perl extension for handling MARC records

=cut

use strict;
use integer;

use vars qw( $ERROR );

use MARC::Field;
use Carp qw(croak);

=head1 VERSION

Version 1.39_02

=cut

use vars qw( $VERSION );
$VERSION = '1.39_02';

use Exporter;
use vars qw( @ISA @EXPORTS @EXPORT_OK );
@ISA = qw( Exporter );
@EXPORTS = qw();
@EXPORT_OK = qw( LEADER_LEN );

use vars qw( $DEBUG ); $DEBUG = 0;

use constant LEADER_LEN => 24;

=head1 DESCRIPTION

Module for handling MARC records as objects.  The file-handling stuff is
in MARC::File::*.

=head1 ERROR HANDLING

Any errors generated are stored in C<$MARC::Record::ERROR>.
Warnings are kept with the record and accessible in the C method.

=head1 CONSTRUCTORS

=head2 new()

Base constructor for the class.  It just returns a completely empty record.
To get real data, you'll need to populate it with fields, or use one of
the MARC::File::* modules to read from a file.

=cut

sub new {
    my $class = shift;
    my $self = {
        _leader => ' ' x 24,
        _fields => [],
        _warnings => [],
    };
    return bless $self, $class;
} # new()

=head2 new_from_usmarc( $marcblob [, \&filter_func($tagno,$tagdata)] )

This is a wrapper around C for compatibility with
older versions of MARC::Record.

The C is optional.  See L::decode for details.

=cut

sub new_from_usmarc {
    my $blob = shift;
    $blob = shift if (ref($blob) || ($blob eq "MARC::Record"));

    require MARC::File::USMARC;

    return MARC::File::USMARC::decode( $blob, @_ );
}

=head1 COMMON FIELD RETRIEVAL METHODS

Following are a number of convenience methods for commonly-retrieved
data fields.  Please note that they each return strings, not MARC::Field
objects.  They return empty strings if the appropriate field or subfield
is not found.  This is as opposed to the C/C methods
which return C if something's not found.  My assumption is that
these methods are used for quick & dirty reports and you don't want to
mess around with noting if something is undef.

Also note that no punctuation cleanup is done.  If the 245a is
"Programming Perl / ", then that's what you'll get back, rather than
"Programming Perl".

=head2 title()

Returns the title from the 245 tag.

=cut

sub title() {
    my $self = shift;

    my $field = $self->field(245);
    return $field ? $field->as_string : "";
}

=head2 title_proper()

Returns the title proper from the 245 tag, subfields a, n and p.

=cut

sub title_proper() {
    my $self = shift;

    my $field = $self->field(245);

    if ( $field ) {
        return $field->as_string('anp');
    } else {
        return "";
    }
}

=head2 author()

Returns the author from the 100, 110 or 111 tag.

=cut

sub author() {
    my $self = shift;

    my $field = $self->field('100|110|111');
    return $field ? $field->as_string : "";
}

=head2 edition()

Returns the edition from the 250 tag, subfield a.

=cut

sub edition() {
    my $self = shift;

    my $str = $self->subfield(250,'a');
    return defined $str ? $str : "";
}

=head2 publication_date()

Returns the publication date from the 260 tag, subfield c.

=cut

sub publication_date() {
    my $self = shift;

    my $str = $self->subfield(260,'c');
    return defined $str ? $str : "";
}

=head1 FIELD & SUBFIELD ACCESS METHODS

=head2 fields()

Returns a list of all the fields in the record. The list contains
a MARC::Field object for each field in the record.

=cut

sub fields() {
    my $self = shift;
    return @{$self->{_fields}};
}

=head2 field( I )

Returns a list of tags that match the field specifier, or an empty
list if nothing matched.  In scalar context, returns the first
matching tag, or undef if nothing matched.

The field specifier can be a simple number (i.e. "245"), or use the "."
notation of wildcarding (i.e. subject tags are "6..").

=cut

my %field_regex;

sub field {
    my $self = shift;
    my @specs = @_;

    my @list = ();
    for my $tag ( @specs ) {
        my $regex = $field_regex{ $tag };

        # Compile & stash it if necessary
        if ( not defined $regex ) {
            $regex = qr/^$tag$/;
            $field_regex{ $tag } = $regex;
        } # not defined

        for my $maybe ( $self->fields ) {
            if ( $maybe->tag =~ $regex ) {
                return $maybe unless wantarray;

                push( @list, $maybe );
            } # if
        } # for $maybe
    } # for $tag

    return unless wantarray;
    return @list;
}

=head2 subfield( $tag, $subfield )

Shortcut method for getting just a subfield for a tag.  These are equivalent:

  my $title = $marc->field('245')->subfield("a");
  my $title = $marc->subfield('245',"a");

If either the field or subfield can't be found, C is returned.

=cut

sub subfield {
    my $self = shift;
    my $tag = shift;
    my $subfield = shift;

    my $field = $self->field($tag) or return;
    return $field->subfield($subfield);
} # subfield()

=for internal

=cut

sub _all_parms_are_fields {
    for ( @_ ) {
        return 0 unless ref($_) eq 'MARC::Field';
    }
    return 1;
}

=head2 append_fields( @fields )

Appends the field specified by C<$field> to the end of the record.
C<@fields> need to be MARC::Field objects.

    my $field = MARC::Field->new('590','','','a' => 'My local note.');
    $record->append_fields($field);

Returns the number of fields appended.

=cut

sub append_fields {
    my $self = shift;

    _all_parms_are_fields(@_) or croak('Arguments must be MARC::Field objects');

    push(@{ $self->{_fields} }, @_);
    return scalar @_;
}

=head2 insert_fields_before( $before_field, @new_fields )

Inserts the field specified by C<$new_field> before the field C<$before_field>.
Returns the number of fields inserted, or undef on failures.
Both C<$before_field> and all C<@new_fields> need to be MARC::Field objects.
If they are not an exception will be thrown.

    my $before_field = $record->field('260');
    my $new_field = MARC::Field->new('250','','','a' => '2nd ed.');
    $record->insert_fields_before($before_field,$new_field);

=cut

sub insert_fields_before {
    my $self = shift;

    _all_parms_are_fields(@_)
        or croak('All arguments must be MARC::Field objects');

    my ($before,@new) = @_;

    ## find position of $before
    my $fields = $self->{_fields};
    my $pos = 0;
    foreach my $f (@$fields) {
        last if ($f == $before);
        $pos++;
    }

    ## insert before $before
    if ($pos >= @$fields) {
        $self->_warn("Couldn't find field to insert before");
        return;
    }
    splice(@$fields,$pos,0,@new);
    return scalar @new;

}

=head2 insert_fields_after( $after_field, @new_fields )

Identical to C, but fields are added after
C<$after_field>. Remember, C<$after_field> and any new fields must be
valid MARC::Field objects or else an exception will be thrown.

=cut

sub insert_fields_after {
    my $self = shift;

    _all_parms_are_fields(@_) or croak('All arguments must be MARC::Field objects');
    my ($after,@new) = @_;

    ## find position of $after
    my $fields = $self->{_fields};
    my $pos = 0;
    foreach my $f (@$fields) {
        last if ($f == $after);
        $pos++;
    }

    ## insert after $after
    if ($pos+1 >= @$fields) {
        $self->_warn("Couldn't find field to insert after");
        return;
    }
    splice(@$fields,$pos+1,0,@new);
    return scalar @new;
}

=head2 insert_fields_ordered( @new_fields )

Will insert fields in strictly numerical order. So a 008 will be filed
after a 001 field. See C for an additional ordering.

=cut

sub insert_fields_ordered {
    my ( $self, @new ) = @_;

    _all_parms_are_fields(@new)
        or croak('All arguments must be MARC::Field objects');

    ## go through each new field
    NEW_FIELD: foreach my $newField ( @new ) {

        ## find location before which it should be inserted
        EXISTING_FIELD: foreach my $field ( @{ $self->{_fields} } ) {
            if ( $field->tag() >= $newField->tag() ) {
                $self->insert_fields_before( $field, $newField );
                next NEW_FIELD;
            }
        }

        ## if we fell through then this new field is higher than
        ## all the existing fields, so we append.
        $self->append_fields( $newField );

    }
    return( scalar( @new ) );
}

=head2 insert_grouped_field( $field )

Will insert the specified MARC::Field object into the record in grouped
order and return true (1) on success, and false (undef) on failure.

    my $field = MARC::Field->new( '510', 'Indexed by Google.' );
    $record->insert_grouped_field( $field );

For example, if a '650' field is inserted with C
it will be inserted at the end of the 6XX group of tags. After discussion
most people wanted the ability to add a new field to the end of the
hundred group where it belonged. The reason is that according to the MARC
format, fields within a record are supposed to be grouped by block
(hundred groups). This means that fields may not necessarily be in tag
order.

=cut

sub insert_grouped_field {
    my ($self,$new) = @_;
    _all_parms_are_fields($new) or croak('Argument must be MARC::Field object');

    ## try to find the end of the field group and insert it there
    my $limit = int($new->tag() / 100);
    my $found = 0;
    foreach my $field ($self->fields()) {
        if ( int($field->tag() / 100) > $limit ) {
            $self->insert_fields_before($field,$new);
            $found = 1;
            last;
        }
    }

    ## if we couldn't find the end of the group, then we must not have
    ## any tags this high yet, so just append it
    if (!$found) {
        $self->append_fields($new);
    }

    return(1);

}


=head2 delete_field( $field )

Deletes a field from the record.

The field must have been retrieved from the record using the
C method.  For example, to delete a 526 tag if it exists:

    my $tag526 = $marc->field( "526" );
    if ( $tag526 ) {
        $marc->delete_field( $tag526 );
    }

C returns the number of fields that were deleted.
This shouldn't be 0 unless you didn't get the tag properly.

=cut

sub delete_field {
    my $self = shift;
    my $deleter = shift;
    my $list = $self->{_fields};

    my $old_count = @$list;
    @$list = grep { $_ != $deleter } @$list;
    return $old_count - @$list;
}

=head2 as_usmarc()

This is a wrapper around C for compatibility with
older versions of MARC::Record.

=cut

sub as_usmarc() {
    my $self = shift;

    require MARC::File::USMARC;

    return MARC::File::USMARC::encode( $self );
}

=head2 as_formatted()

Returns a pretty string for printing in a MARC dump.

=cut

sub as_formatted() {
    my $self = shift;

    my @lines = ( "LDR " . ($self->{_leader} || "") );
    for my $field ( @{$self->{_fields}} ) {
            push( @lines, $field->as_formatted() );
    }

    return join( "\n", @lines );
} # as_formatted


=head2 leader()

Returns the leader for the record.  Sets the leader if I is defined.
No error checking is done on the validity of the leader.

=cut

sub leader {
    my $self = shift;
    my $text = shift;

    if ( defined $text ) {
        (length($text) eq 24)
            or $self->_warn( "Leader must be 24 bytes long" );
        $self->{_leader} = $text;
    } # set the leader

    return $self->{_leader};
} # leader()

=head2 set_leader_lengths( $reclen, $baseaddr )

Internal function for updating the leader's length and base address.

=cut

sub set_leader_lengths {
    my $self = shift;
    my $reclen = shift;
    my $baseaddr = shift;
    substr($self->{_leader},0,5)  = sprintf("%05d",$reclen);
    substr($self->{_leader},12,5) = sprintf("%05d",$baseaddr);
    # MARC21 defaults: http://www.loc.gov/marc/bibliographic/ecbdldrd.html
    substr($self->{_leader},10,2) = '22';
    substr($self->{_leader},20,4) = '4500';
}

=head2 clone()

The C method makes a copy of an existing MARC record and returns
the new version.  Note that you cannot just say:

    my $newmarc = $oldmarc;

This just makes a copy of the reference, not a new object.  You must use
the C method like so:

    my $newmarc = $oldmarc->clone;

You can also specify field specs to filter down only a
certain subset of fields.  For instance, if you only wanted the
title and ISBN tags from a record, you could do this:

    my $small_marc = $marc->clone( 245, '020' );

The order of the fields is preserved as it was in the original record.

=cut

sub clone {
    my $self = shift;
    my @keeper_tags = @_;

    # create a new object of whatever type we happen to be
    my $class = ref( $self );
    my $clone = $class->new();

    $clone->{_leader} = $self->{_leader};

    my $filtered = @keeper_tags ? [$self->field( @keeper_tags )] : undef;

    for my $field ( $self->fields() ) {
        if ( !$filtered || (grep {$field eq $_} @$filtered ) ) {
            $clone->append_fields( $field->clone );
        }
    }

    # XXX FIX THIS $clone->update_leader();

    return $clone;
}

=head2 warnings()

Returns the warnings (as a list) that were created when the record was read.
These are things like "Invalid indicators converted to blanks".

    my @warnings = $record->warnings();

The warnings are items that you might be interested in, or might
not.  It depends on how stringently you're checking data.  If
you're doing some grunt data analysis, you probably don't care.

A side effect of calling warnings() is that the warning buffer will
be cleared.

=cut

sub warnings() {
    my $self = shift;
    my @warnings = @{$self->{_warnings}};
    $self->{_warnings} = [];
    return @warnings;
}

=head2 add_fields()

C is now deprecated, and users are encouraged to use
C, C, and C
since they do what you want probably. It is still here though, for backwards
compatability.

C adds MARC::Field objects to the end of the list.  Returns the
number of fields added, or C if there was an error.

There are three ways of calling C to add data to the record.

=over 4

=item 1 Create a MARC::Field object and add it

  my $author = MARC::Field->new(
                100, "1", " ", a => "Arnosky, Jim."
                );
  $marc->add_fields( $author );

=item 2 Add the data fields directly, and let C take care of the objectifying.

  $marc->add_fields(
        245, "1", "0",
                a => "Raccoons and ripe corn /",
                c => "Jim Arnosky.",
                );

=item 3 Same as #2 above, but pass multiple fields of data in anonymous lists

  $marc->add_fields(
        [ 250, " ", " ", a => "1st ed." ],
        [ 650, "1", " ", a => "Raccoons." ],
        );

=back

=cut

sub add_fields {
    my $self = shift;

    my $nfields = 0;
    my $fields = $self->{_fields};

    while ( my $parm = shift ) {
        # User handed us a list of data (most common possibility)
        if ( ref($parm) eq "" ) {
            my $field = MARC::Field->new( $parm, @_ )
                    or return _gripe( $MARC::Field::ERROR );
            push( @$fields, $field );
            ++$nfields;
            last; # Bail out, we're done eating parms

        # User handed us an object.
        } elsif ( ref($parm) eq "MARC::Field" ) {
            push( @$fields, $parm );
            ++$nfields;

        # User handed us an anonymous list of parms
        } elsif ( ref($parm) eq "ARRAY" ) {
            my $field = MARC::Field->new(@$parm)
                or return _gripe( $MARC::Field::ERROR );
            push( @$fields, $field );
            ++$nfields;

        } else {
            croak( "Unknown parm of type", ref($parm), " passed to add_fields()" );
        } # if

    } # while

    return $nfields;
}

# NOTE: _warn is an object method
sub _warn {
    my $self = shift;
    push( @{$self->{_warnings}}, join( "", @_ ) );
    return( $self );
}


# NOTE: _gripe is NOT an object method
sub _gripe {
    $ERROR = join( "", @_ );

    warn $ERROR;

    return;
}


1;

__END__