File Coverage

blib/lib/MARC/Record.pm
Criterion Covered Total %
statement 208 221 94.1
branch 63 78 80.7
condition 3 8 37.5
subroutine 38 39 97.4
pod 25 25 100.0
total 337 371 90.8


line stmt bran cond sub pod time code
1             package MARC::Record;
2              
3             =head1 NAME
4              
5             MARC::Record - Perl extension for handling MARC records
6              
7             =cut
8              
9 34     34   396017 use strict;
  34         82  
  34         1502  
10 34     34   190 use warnings;
  34         64  
  34         985  
11 34     34   12197 use integer;
  34         196  
  34         196  
12              
13 34     34   939 use vars qw( $ERROR );
  34         73  
  34         1716  
14              
15 34     34   22667 use MARC::Field;
  34         7209  
  34         1501  
16 34     34   366 use Carp qw(croak carp);
  34         70  
  34         2859  
17              
18             =head1 VERSION
19              
20             Version 2.0.6
21              
22             =cut
23              
24 34     34   272 use vars qw( $VERSION );
  34         76  
  34         10481  
25             $VERSION = '2.0.6';
26              
27 34     34   205 use Exporter;
  34         64  
  34         1482  
28 34     34   191 use vars qw( @ISA @EXPORTS @EXPORT_OK );
  34         78  
  34         3032  
29             @ISA = qw( Exporter );
30             @EXPORTS = qw();
31             @EXPORT_OK = qw( LEADER_LEN );
32              
33 34     34   403 use vars qw( $DEBUG ); $DEBUG = 0;
  34         63  
  34         1508  
34              
35 34     34   259 use constant LEADER_LEN => 24;
  34         68  
  34         107755  
36              
37             =head1 DESCRIPTION
38              
39             Module for handling MARC records as objects. The file-handling stuff is
40             in MARC::File::*.
41              
42             =head1 ERROR HANDLING
43              
44             Any errors generated are stored in C<$MARC::Record::ERROR>.
45             Warnings are kept with the record and accessible in the C method.
46              
47             =head1 CONSTRUCTORS
48              
49             =head2 new()
50              
51             Base constructor for the class. It just returns a completely empty record.
52             To get real data, you'll need to populate it with fields, or use one of
53             the MARC::File::* modules to read from a file.
54              
55             =cut
56              
57             sub new {
58 414     414 1 5720 my $class = shift;
59 414         2293 my $self = {
60             _leader => ' ' x 24,
61             _fields => [],
62             _warnings => [],
63             };
64 414         2246 return bless $self, $class;
65             } # new()
66              
67             =head2 new_from_usmarc( $marcblob [, \&filter_func($tagno,$tagdata)] )
68              
69             This is a wrapper around C for compatibility with
70             older versions of MARC::Record.
71              
72             The C is optional. See L::decode for details.
73              
74             =cut
75              
76             sub new_from_usmarc {
77 2     2 1 19 my $blob = shift;
78 2 50 33     22 $blob = shift if (ref($blob) || ($blob eq "MARC::Record"));
79              
80 2         8132 require MARC::File::USMARC;
81              
82 2         15 return MARC::File::USMARC::decode( $blob, @_ );
83             }
84              
85             =head1 COMMON FIELD RETRIEVAL METHODS
86              
87             Following are a number of convenience methods for commonly-retrieved
88             data fields. Please note that they each return strings, not MARC::Field
89             objects. They return empty strings if the appropriate field or subfield
90             is not found. This is as opposed to the C/C methods
91             which return C if something's not found. My assumption is that
92             these methods are used for quick & dirty reports and you don't want to
93             mess around with noting if something is undef.
94              
95             Also note that no punctuation cleanup is done. If the 245a is
96             "Programming Perl / ", then that's what you'll get back, rather than
97             "Programming Perl".
98              
99             =head2 title()
100              
101             Returns the title from the 245 tag.
102              
103             =cut
104              
105             sub title {
106 15     15 1 5926 my $self = shift;
107              
108 15         55 my $field = $self->field(245);
109 15 100       120 return $field ? $field->as_string : "";
110             }
111              
112             =head2 title_proper()
113              
114             Returns the title proper from the 245 tag, subfields a, n and p.
115              
116             =cut
117              
118             sub title_proper {
119 11     11 1 2705 my $self = shift;
120              
121 11         162 my $field = $self->field(245);
122              
123 11 100       54 if ( $field ) {
124 9         40 return $field->as_string('anp');
125             } else {
126 2         11 return "";
127             }
128             }
129              
130             =head2 author()
131              
132             Returns the author from the 100, 110 or 111 tag.
133              
134             =cut
135              
136             sub author {
137 6     6 1 19894 my $self = shift;
138              
139 6         29 my $field = $self->field('100|110|111');
140 6 100       57 return $field ? $field->as_string : "";
141             }
142              
143             =head2 edition()
144              
145             Returns the edition from the 250 tag, subfield a.
146              
147             =cut
148              
149             sub edition {
150 6     6 1 15 my $self = shift;
151              
152 6         27 my $str = $self->subfield(250,'a');
153 6 100       46 return defined $str ? $str : "";
154             }
155              
156             =head2 publication_date()
157              
158             Returns the publication date from the 260 tag, subfield c.
159              
160             =cut
161              
162             sub publication_date {
163 6     6 1 19 my $self = shift;
164              
165 6         24 my $str = $self->subfield(260,'c');
166 6 100       54 return defined $str ? $str : "";
167             }
168              
169             =head1 FIELD & SUBFIELD ACCESS METHODS
170              
171             =head2 fields()
172              
173             Returns a list of all the fields in the record. The list contains
174             a MARC::Field object for each field in the record.
175              
176             =cut
177              
178             sub fields {
179 273     273 1 21769 my $self = shift;
180 273         383 return @{$self->{_fields}};
  273         1348  
181             }
182              
183             =head2 field( I )
184              
185             Returns a list of tags that match the field specifier, or an empty
186             list if nothing matched. In scalar context, returns the first
187             matching tag, or undef if nothing matched.
188              
189             The field specifier can be a simple number (i.e. "245"), or use the "."
190             notation of wildcarding (i.e. subject tags are "6..").
191              
192             =cut
193              
194             my %field_regex;
195              
196             sub field {
197 244     244 1 102206 my $self = shift;
198 244         609 my @specs = @_;
199              
200 244         391 my @list = ();
201 244         486 for my $tag ( @specs ) {
202 244         483 my $regex = $field_regex{ $tag };
203              
204             # Compile & stash it if necessary
205 244 100       762 if ( not defined $regex ) {
206 48         1003 $regex = qr/^$tag$/;
207 48         185 $field_regex{ $tag } = $regex;
208             } # not defined
209              
210 244         737 for my $maybe ( $self->fields ) {
211 1341 100       5135 if ( $maybe->tag =~ $regex ) {
212 234 100       1289 return $maybe unless wantarray;
213              
214 16         47 push( @list, $maybe );
215             } # if
216             } # for $maybe
217             } # for $tag
218              
219 26 100       134 return unless wantarray;
220 9         37 return @list;
221             }
222              
223             =head2 subfield( $tag, $subfield )
224              
225             Shortcut method for getting just a subfield for a tag. These are equivalent:
226              
227             my $title = $marc->field('245')->subfield("a");
228             my $title = $marc->subfield('245',"a");
229              
230             If either the field or subfield can't be found, C is returned.
231              
232             =cut
233              
234             sub subfield {
235 16     16 1 1660 my $self = shift;
236 16         29 my $tag = shift;
237 16         30 my $subfield = shift;
238              
239 16 100       162 my $field = $self->field($tag) or return;
240 9         102 return $field->subfield($subfield);
241             } # subfield()
242              
243             =for internal
244              
245             =cut
246              
247             sub _all_parms_are_fields {
248 2631     2631   4996 for ( @_ ) {
249 2648 100       14352 return 0 unless UNIVERSAL::isa($_, 'MARC::Field');
250             }
251 2627         7822 return 1;
252             }
253              
254             =head2 append_fields( @fields )
255              
256             Appends the field specified by C<$field> to the end of the record.
257             C<@fields> need to be MARC::Field objects.
258              
259             my $field = MARC::Field->new('590','','','a' => 'My local note.');
260             $record->append_fields($field);
261              
262             Returns the number of fields appended.
263              
264             =cut
265              
266             sub append_fields {
267 2610     2610 1 6909 my $self = shift;
268              
269 2610 100       5109 _all_parms_are_fields(@_) or croak('Arguments must be MARC::Field objects');
270              
271 2609         4781 push(@{ $self->{_fields} }, @_);
  2609         7428  
272 2609         22820 return scalar @_;
273             }
274              
275             =head2 insert_fields_before( $before_field, @new_fields )
276              
277             Inserts the field specified by C<$new_field> before the field C<$before_field>.
278             Returns the number of fields inserted, or undef on failures.
279             Both C<$before_field> and all C<@new_fields> need to be MARC::Field objects.
280             If they are not an exception will be thrown.
281              
282             my $before_field = $record->field('260');
283             my $new_field = MARC::Field->new('250','','','a' => '2nd ed.');
284             $record->insert_fields_before($before_field,$new_field);
285              
286             =cut
287              
288             sub insert_fields_before {
289 7     7 1 1069 my $self = shift;
290              
291 7 100       21 _all_parms_are_fields(@_)
292             or croak('All arguments must be MARC::Field objects');
293              
294 6         22 my ($before,@new) = @_;
295              
296             ## find position of $before
297 6         12 my $fields = $self->{_fields};
298 6         11 my $pos = 0;
299 6         13 foreach my $f (@$fields) {
300 68 100       125 last if ($f == $before);
301 63         75 $pos++;
302             }
303              
304             ## insert before $before
305 6 100       21 if ($pos >= @$fields) {
306 1         4 $self->_warn("Couldn't find field to insert before");
307 1         3 return;
308             }
309 5         15 splice(@$fields,$pos,0,@new);
310 5         15 return scalar @new;
311              
312             }
313              
314             =head2 insert_fields_after( $after_field, @new_fields )
315              
316             Identical to C, but fields are added after
317             C<$after_field>. Remember, C<$after_field> and any new fields must be
318             valid MARC::Field objects or else an exception will be thrown.
319              
320             =cut
321              
322             sub insert_fields_after {
323 4     4 1 1882 my $self = shift;
324              
325 4 100       15 _all_parms_are_fields(@_) or croak('All arguments must be MARC::Field objects');
326 3         8 my ($after,@new) = @_;
327              
328             ## find position of $after
329 3         5 my $fields = $self->{_fields};
330 3         16 my $pos = 0;
331 3         6 my $found = 0;
332 3         7 foreach my $f (@$fields) {
333 51 100       87 if ($f == $after) {
334 3         5 $found = 1;
335 3         7 last;
336             }
337 48         55 $pos++;
338             }
339              
340             ## insert after $after
341 3 50       8 unless ($found) {
342 0         0 $self->_warn("Couldn't find field to insert after");
343 0         0 return;
344             }
345 3         13 splice(@$fields,$pos+1,0,@new);
346 3         10 return scalar @new;
347             }
348              
349             =head2 insert_fields_ordered( @new_fields )
350              
351             Will insert fields in strictly numerical order. So a 008 will be filed
352             after a 001 field. See C for an additional ordering.
353              
354             =cut
355              
356             sub insert_fields_ordered {
357 2     2 1 4 my ( $self, @new ) = @_;
358              
359 2 50       9 _all_parms_are_fields(@new)
360             or croak('All arguments must be MARC::Field objects');
361              
362             ## go through each new field
363 2         3 NEW_FIELD: foreach my $newField ( @new ) {
364              
365             ## find location before which it should be inserted
366 4         4 EXISTING_FIELD: foreach my $field ( @{ $self->{_fields} } ) {
  4         12  
367 4 100       9 if ( $field->tag() >= $newField->tag() ) {
368 2         7 $self->insert_fields_before( $field, $newField );
369 2         5 next NEW_FIELD;
370             }
371             }
372              
373             ## if we fell through then this new field is higher than
374             ## all the existing fields, so we append.
375 2         6 $self->append_fields( $newField );
376              
377             }
378 2         4 return( scalar( @new ) );
379             }
380              
381             =head2 insert_grouped_field( $field )
382              
383             Will insert the specified MARC::Field object into the record in grouped
384             order and return true (1) on success, and false (undef) on failure.
385              
386             my $field = MARC::Field->new( '510', 'Indexed by Google.' );
387             $record->insert_grouped_field( $field );
388              
389             For example, if a '650' field is inserted with C
390             it will be inserted at the end of the 6XX group of tags. After discussion
391             most people wanted the ability to add a new field to the end of the
392             hundred group where it belonged. The reason is that according to the MARC
393             format, fields within a record are supposed to be grouped by block
394             (hundred groups). This means that fields may not necessarily be in tag
395             order.
396              
397             =cut
398              
399             sub insert_grouped_field {
400 2     2 1 1108 my ($self,$new) = @_;
401 2 100       16 _all_parms_are_fields($new) or croak('Argument must be MARC::Field object');
402              
403             ## try to find the end of the field group and insert it there
404 1         5 my $limit = int($new->tag() / 100);
405 1         2 my $found = 0;
406 1         6 foreach my $field ($self->fields()) {
407 14 100       40 if ( int($field->tag() / 100) > $limit ) {
408 1         5 $self->insert_fields_before($field,$new);
409 1         2 $found = 1;
410 1         3 last;
411             }
412             }
413              
414             ## if we couldn't find the end of the group, then we must not have
415             ## any tags this high yet, so just append it
416 1 50       6 if (!$found) {
417 0         0 $self->append_fields($new);
418             }
419              
420 1         4 return(1);
421              
422             }
423              
424              
425             =head2 delete_fields( $field )
426              
427             Deletes a given list of MARC::Field objects from the the record.
428              
429             # delete all note fields
430             my @notes = $record->field('5..');
431             $record->delete_fields(@notes);
432              
433             delete_fields() will return the number of fields that were deleted.
434              
435             =cut
436              
437             sub delete_fields {
438 6     6 1 1520 my $self = shift;
439 6 50       16 _all_parms_are_fields(@_) or croak('Arguments must be MARC::Field object');
440 6         10 my @fields = @{$self->{_fields}};
  6         26  
441 6         9 my $original_count = @fields;
442              
443 6         15 foreach my $deleter (@_) {
444 7         11 @fields = grep { $_ != $deleter } @fields;
  102         219  
445             }
446 6         17 $self->{_fields} = \@fields;
447              
448 6         28 return $original_count - @fields;
449             }
450              
451             =head2 delete_field()
452              
453             Same thing as delete_fields() but only expects a single MARC::Field to be passed
454             in. Mainly here for backwards compatibility.
455              
456             =cut
457              
458             sub delete_field {
459 5     5 1 1459 return delete_fields(@_);
460             }
461              
462             =head2 as_usmarc()
463              
464             This is a wrapper around C for compatibility with
465             older versions of MARC::Record.
466              
467             =cut
468              
469             sub as_usmarc {
470 9     9 1 3128 my $self = shift;
471              
472 9         1537 require MARC::File::USMARC;
473              
474 9         47 return MARC::File::USMARC::encode( $self );
475             }
476              
477             =head2 as_formatted()
478              
479             Returns a pretty string for printing in a MARC dump.
480              
481             =cut
482              
483             sub as_formatted {
484 14     14 1 6587 my $self = shift;
485              
486 14   50     119 my @lines = ( "LDR " . ($self->{_leader} || "") );
487 14         86 for my $field ( @{$self->{_fields}} ) {
  14         43  
488 193         544 push( @lines, $field->as_formatted() );
489             }
490              
491 14         196 return join( "\n", @lines );
492             } # as_formatted
493              
494              
495             =head2 leader()
496              
497             Returns the leader for the record. Sets the leader if I is defined.
498             No error checking is done on the validity of the leader.
499              
500             =cut
501              
502             sub leader {
503 3144     3144 1 9868 my $self = shift;
504 3144         5651 my $text = shift;
505              
506 3144 100       8962 if ( defined $text ) {
507 402 100       1535 (length($text) eq 24)
508             or $self->_warn( "Leader must be 24 bytes long" );
509 402         1533 $self->{_leader} = $text;
510             } # set the leader
511              
512 3144         21205 return $self->{_leader};
513             } # leader()
514              
515             =head2 encoding()
516              
517             A method for getting/setting the encoding for a record. The encoding for a
518             record is determined by position 09 in the leader, which is blank for MARC-8
519             encoding, and 'a' for UCS/Unicode. encoding() will return a string, either
520             'MARC-8' or 'UTF-8' appropriately.
521              
522             If you want to set the encoding for a MARC::Record object you can use the
523             string values:
524              
525             $record->encoding( 'UTF-8' );
526              
527             NOTE: MARC::Record objects created from scratch have an a default encoding
528             of MARC-8, which has been the standard for years...but many online catlogs
529             and record vendors are migrating to UTF-8.
530              
531             WARNING: you should be sure your record really does contain valid UTF-8 data
532             when you manually set the encoding.
533              
534             =cut
535              
536             sub encoding {
537 2728     2728 1 5377 my ($self,$arg) = @_;
538             # we basically report from and modify the leader directly
539 2728         6320 my $leader = $self->leader();
540              
541             # when setting
542 2728 100       8011 if ( defined($arg) ) {
543 1 50       6 if ( $arg =~ /UTF-?8/i ) {
    0          
544 1         3 substr($leader,9,1) = 'a';
545             }
546             elsif ( $arg =~ /MARC-?8/i ) {
547 0         0 substr($leader,9,1) = ' ';
548             }
549 1         2 $self->leader($leader);
550             }
551              
552 2728 100       16791 return substr($leader,9,1) eq 'a' ? 'UTF-8' : 'MARC-8';
553             }
554              
555             =head2 set_leader_lengths( $reclen, $baseaddr )
556              
557             Internal function for updating the leader's length and base address.
558              
559             =cut
560              
561             sub set_leader_lengths {
562 10     10 1 16 my $self = shift;
563 10         15 my $reclen = shift;
564 10         27 my $baseaddr = shift;
565 10 50       31 if ($reclen > 99999) {
566 0         0 carp( "Record length of $reclen is larger than the MARC spec allows (99999 bytes)." );
567 0         0 $reclen = 99999;
568             }
569 10         41 substr($self->{_leader},0,5) = sprintf("%05d",$reclen);
570 10         28 substr($self->{_leader},12,5) = sprintf("%05d",$baseaddr);
571             # MARC21 defaults: http://www.loc.gov/marc/bibliographic/ecbdldrd.html
572 10         18 substr($self->{_leader},10,2) = '22';
573 10         47 substr($self->{_leader},20,4) = '4500';
574             }
575              
576             =head2 clone()
577              
578             The C method makes a copy of an existing MARC record and returns
579             the new version. Note that you cannot just say:
580              
581             my $newmarc = $oldmarc;
582              
583             This just makes a copy of the reference, not a new object. You must use
584             the C method like so:
585              
586             my $newmarc = $oldmarc->clone;
587              
588             You can also specify field specs to filter down only a
589             certain subset of fields. For instance, if you only wanted the
590             title and ISBN tags from a record, you could do this:
591              
592             my $small_marc = $marc->clone( 245, '020' );
593              
594             The order of the fields is preserved as it was in the original record.
595              
596             =cut
597              
598             sub clone {
599 1     1 1 7 my $self = shift;
600 1         3 my @keeper_tags = @_;
601              
602             # create a new object of whatever type we happen to be
603 1         3 my $class = ref( $self );
604 1         5 my $clone = $class->new();
605              
606 1         4 $clone->{_leader} = $self->{_leader};
607              
608 1 50       5 my $filtered = @keeper_tags ? [$self->field( @keeper_tags )] : undef;
609              
610 1         6 for my $field ( $self->fields() ) {
611 18 50 33     57 if ( !$filtered || (grep {$field eq $_} @$filtered ) ) {
  0         0  
612 18         44 $clone->append_fields( $field->clone );
613             }
614             }
615              
616             # XXX FIX THIS $clone->update_leader();
617              
618 1         5 return $clone;
619             }
620              
621             =head2 warnings()
622              
623             Returns the warnings (as a list) that were created when the record was read.
624             These are things like "Invalid indicators converted to blanks".
625              
626             my @warnings = $record->warnings();
627              
628             The warnings are items that you might be interested in, or might
629             not. It depends on how stringently you're checking data. If
630             you're doing some grunt data analysis, you probably don't care.
631              
632             A side effect of calling warnings() is that the warning buffer will
633             be cleared.
634              
635             =cut
636              
637             sub warnings {
638 30     30 1 5866 my $self = shift;
639 30         50 my @warnings = @{$self->{_warnings}};
  30         93  
640 30         76 $self->{_warnings} = [];
641 30         130 return @warnings;
642             }
643              
644             =head2 add_fields()
645              
646             C is now deprecated, and users are encouraged to use
647             C, C, and C
648             since they do what you want probably. It is still here though, for backwards
649             compatibility.
650              
651             C adds MARC::Field objects to the end of the list. Returns the
652             number of fields added, or C if there was an error.
653              
654             There are three ways of calling C to add data to the record.
655              
656             =over 4
657              
658             =item 1 Create a MARC::Field object and add it
659              
660             my $author = MARC::Field->new(
661             100, "1", " ", a => "Arnosky, Jim."
662             );
663             $marc->add_fields( $author );
664              
665             =item 2 Add the data fields directly, and let C take care of the objectifying.
666              
667             $marc->add_fields(
668             245, "1", "0",
669             a => "Raccoons and ripe corn /",
670             c => "Jim Arnosky.",
671             );
672              
673             =item 3 Same as #2 above, but pass multiple fields of data in anonymous lists
674              
675             $marc->add_fields(
676             [ 250, " ", " ", a => "1st ed." ],
677             [ 650, "1", " ", a => "Raccoons." ],
678             );
679              
680             =back
681              
682             =cut
683              
684             sub add_fields {
685 2096     2096 1 3019 my $self = shift;
686              
687 2096         2967 my $nfields = 0;
688 2096         3332 my $fields = $self->{_fields};
689              
690 2096         4944 while ( my $parm = shift ) {
691             # User handed us a list of data (most common possibility)
692 2105 100       4124 if ( ref($parm) eq "" ) {
    50          
    50          
693 2095 50       9139 my $field = MARC::Field->new( $parm, @_ )
694             or return _gripe( $MARC::Field::ERROR );
695 2095         4299 push( @$fields, $field );
696 2095         2508 ++$nfields;
697 2095         3743 last; # Bail out, we're done eating parms
698              
699             # User handed us an object.
700             } elsif ( UNIVERSAL::isa($parm, 'MARC::Field') ) {
701 0         0 push( @$fields, $parm );
702 0         0 ++$nfields;
703              
704             # User handed us an anonymous list of parms
705             } elsif ( ref($parm) eq "ARRAY" ) {
706 10 50       36 my $field = MARC::Field->new(@$parm)
707             or return _gripe( $MARC::Field::ERROR );
708 10         17 push( @$fields, $field );
709 10         27 ++$nfields;
710              
711             } else {
712 0         0 croak( "Unknown parm of type", ref($parm), " passed to add_fields()" );
713             } # if
714              
715             } # while
716              
717 2096         10453 return $nfields;
718             }
719              
720             # NOTE: _warn is an object method
721             sub _warn {
722 27     27   38 my $self = shift;
723 27         43 push( @{$self->{_warnings}}, join( "", @_ ) );
  27         115  
724 27         98 return( $self );
725             }
726              
727              
728             # NOTE: _gripe is NOT an object method
729             sub _gripe {
730 0     0     $ERROR = join( "", @_ );
731              
732 0           warn $ERROR;
733              
734 0           return;
735             }
736              
737              
738             1;
739              
740             __END__