← Index
Performance Profile   « block view • line view • sub view »
For t/test-parsing
  Run on Sun Nov 14 09:49:57 2010
Reported on Sun Nov 14 09:50:11 2010

File /usr/share/perl5/MARC/Field.pm
Statements Executed 19
Total Time 0.0021888 seconds
Subroutines — ordered by exclusive time
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sMARC::Field::::BEGINMARC::Field::BEGIN
0000s0sMARC::Field::::_gripeMARC::Field::_gripe
0000s0sMARC::Field::::_normalize_arrayrefMARC::Field::_normalize_arrayref
0000s0sMARC::Field::::_warnMARC::Field::_warn
0000s0sMARC::Field::::add_subfieldsMARC::Field::add_subfields
0000s0sMARC::Field::::as_formattedMARC::Field::as_formatted
0000s0sMARC::Field::::as_stringMARC::Field::as_string
0000s0sMARC::Field::::as_usmarcMARC::Field::as_usmarc
0000s0sMARC::Field::::cloneMARC::Field::clone
0000s0sMARC::Field::::dataMARC::Field::data
0000s0sMARC::Field::::delete_subfieldMARC::Field::delete_subfield
0000s0sMARC::Field::::delete_subfieldsMARC::Field::delete_subfields
0000s0sMARC::Field::::indicatorMARC::Field::indicator
0000s0sMARC::Field::::is_control_fieldMARC::Field::is_control_field
0000s0sMARC::Field::::newMARC::Field::new
0000s0sMARC::Field::::replace_withMARC::Field::replace_with
0000s0sMARC::Field::::subfieldMARC::Field::subfield
0000s0sMARC::Field::::subfieldsMARC::Field::subfields
0000s0sMARC::Field::::tagMARC::Field::tag
0000s0sMARC::Field::::updateMARC::Field::update
0000s0sMARC::Field::::warningsMARC::Field::warnings
LineStmts.Exclusive
Time
Avg.Code
1package MARC::Field;
2
3324µs8µsuse strict;
# spent 9µs making 1 call to strict::import
4324µs8µsuse integer;
# spent 9µs making 1 call to integer::import
5344µs15µsuse Carp;
# spent 67µs making 1 call to Exporter::import
6
7345µs15µsuse constant SUBFIELD_INDICATOR => "\x1F";
# spent 53µs making 1 call to constant::import
8328µs9µsuse constant END_OF_FIELD => "\x1E";
# spent 41µs making 1 call to constant::import
9
1032.02ms674µsuse vars qw( $ERROR );
# spent 25µs making 1 call to vars::import
11
12=head1 NAME
13
14MARC::Field - Perl extension for handling MARC fields
15
16=head1 SYNOPSIS
17
18 use MARC::Field;
19
20 my $field = MARC::Field->new( 245, '1', '0',
21 'a' => 'Raccoons and ripe corn / ',
22 'c' => 'Jim Arnosky.'
23 );
24 $field->add_subfields( "a", "1st ed." );
25
26=head1 DESCRIPTION
27
28Defines MARC fields for use in the MARC::Record module. I suppose
29you could use them on their own, but that wouldn't be very interesting.
30
31=head1 EXPORT
32
33None by default. Any errors are stored in C<$MARC::Field::ERROR>, which
34C<$MARC::Record> usually bubbles up to C<$MARC::Record::ERROR>.
35
36=head1 METHODS
37
38=head2 new()
39
40The constructor, which will return a MARC::Field object. Typically you will
41pass in the tag number, indicator 1, indicator 2, and then a list of any
42subfield/data pairs. For example:
43
44 my $field = MARC::Field->new(
45 245, '1', '0',
46 'a' => 'Raccoons and ripe corn / ',
47 'c' => 'Jim Arnosky.'
48 );
49
50Or if you want to add a field < 010 that does not have indicators.
51
52 my $field = MARC::Field->new( '001', ' 14919759' );
53
54=cut
55
56sub new {
57 my $class = shift;
58 $class = $class;
59
60 ## MARC spec indicates that tags can have alphabetical
61 ## characters in them! If they do appear we assume that
62 ## they have indicators like tags > 010
63 my $tagno = shift;
64 ($tagno =~ /^[0-9A-Za-z]{3}$/)
65 or croak( "Tag \"$tagno\" is not a valid tag." );
66 my $is_control = (($tagno =~ /^\d+$/) && ($tagno < 10));
67
68 my $self = bless {
69 _tag => $tagno,
70 _warnings => [],
71 _is_control_field => $is_control,
72 }, $class;
73
74 if ( $is_control ) {
75 $self->{_data} = shift;
76 } else {
77 for my $indcode ( qw( _ind1 _ind2 ) ) {
78 my $indicator = shift;
79 if ( $indicator !~ /^[0-9A-Za-z ]$/ ) {
80 $self->_warn( "Invalid indicator \"$indicator\" forced to blank" ) unless ($indicator eq "");
81 $indicator = " ";
82 }
83 $self->{$indcode} = $indicator;
84 } # for
85
86 (@_ >= 2)
87 or croak( "Field $tagno must have at least one subfield" );
88
89 # Normally, we go thru add_subfields(), but internally we can cheat
90 $self->{_subfields} = [@_];
91 }
92
93 return $self;
94} # new()
95
96
97=head2 tag()
98
99Returns the three digit tag for the field.
100
101=cut
102
103sub tag {
104 my $self = shift;
105 return $self->{_tag};
106}
107
108=head2 indicator(indno)
109
110Returns the specified indicator. Returns C<undef> and sets
111C<$MARC::Field::ERROR> if the I<indno> is not 1 or 2, or if
112the tag doesn't have indicators.
113
114=cut
115
116sub indicator($) {
117 my $self = shift;
118 my $indno = shift;
119
120 $self->_warn( "Fields below 010 do not have indicators" )
121 if $self->is_control_field;
122
123 if ( $indno == 1 ) {
124 return $self->{_ind1};
125 } elsif ( $indno == 2 ) {
126 return $self->{_ind2};
127 } else {
128 croak( "Indicator number must be 1 or 2" );
129 }
130}
131
132=head2 is_control_field()
133
134Tells whether this field is one of the control tags from 001-009.
135
136=cut
137
138sub is_control_field {
139 my $self = shift;
140 return $self->{_is_control_field};
141}
142
143=head2 subfield(code)
144
145When called in a scalar context returns the text from the first subfield
146matching the subfield code.
147
148 my $subfield = $field->subfield( 'a' );
149
150Or if you think there might be more than one you can get all of them by
151calling in a list context:
152
153 my @subfields = $field->subfield( 'a' );
154
155If no matching subfields are found, C<undef> is returned in a scalar context
156and an empty list in a list context.
157
158If the tag is less than an 010, C<undef> is returned and
159C<$MARC::Field::ERROR> is set.
160
161=cut
162
163sub subfield {
164 my $self = shift;
165 my $code_wanted = shift;
166
167 croak( "Fields below 010 do not have subfields, use data()" )
168 if $self->is_control_field;
169
170 my @data = @{$self->{_subfields}};
171 my @found;
172 while ( defined( my $code = shift @data ) ) {
173 if ( $code eq $code_wanted ) {
174 push( @found, shift @data );
175 } else {
176 shift @data;
177 }
178 }
179 if ( wantarray() ) { return @found; }
180 return( $found[0] );
181}
182
183=head2 subfields()
184
185Returns all the subfields in the field. What's returned is a list of
186list refs, where the inner list is a subfield code and the subfield data.
187
188For example, this might be the subfields from a 245 field:
189
190 (
191 [ 'a', 'Perl in a nutshell :' ],
192 [ 'b', 'A desktop quick reference.' ],
193 )
194
195=cut
196
197sub subfields {
198 my $self = shift;
199
200 $self->_warn( "Fields below 010 do not have subfields" )
201 if $self->is_control_field;
202
203 my @list;
204 my @data = @{$self->{_subfields}};
205 while ( defined( my $code = shift @data ) ) {
206 push( @list, [$code, shift @data] );
207 }
208 return @list;
209}
210
211=head2 data()
212
213Returns the data part of the field, if the tag number is less than 10.
214
215=cut
216
217sub data {
218 my $self = shift;
219
220 croak( "data() is only for tags less than 010, use subfield()" )
221 unless $self->is_control_field;
222
223 $self->{_data} = $_[0] if @_;
224
225 return $self->{_data};
226}
227
228=head2 add_subfields(code,text[,code,text ...])
229
230Adds subfields to the end of the subfield list.
231
232 $field->add_subfields( 'c' => '1985' );
233
234Returns the number of subfields added, or C<undef> if there was an error.
235
236=cut
237
238sub add_subfields {
239 my $self = shift;
240
241 croak( "Subfields are only for tags >= 10" )
242 if $self->is_control_field;
243
244 push( @{$self->{_subfields}}, @_ );
245 return @_/2;
246}
247
248=head2 delete_subfield()
249
250delete_subfield() allows you to remove subfields from a field:
251
252 # delete any subfield a in the field
253 $field->delete_subfield(code => 'a');
254
255 # delete any subfield a or u in the field
256 $field->delete_subfield(code => ['a', 'u']);
257
258If you want to only delete subfields at a particular position you can
259use the pos parameter:
260
261 # delete subfield u at the first position
262 $field->delete_subfield(code => 'u', pos => 0);
263
264 # delete subfield u at first or second position
265 $field->delete_subfield(code => 'u', pos => [0,1]);
266
267You can specify a regex to for only deleting subfields that match:
268
269 # delete any subfield u that matches zombo.com
270 $field->delete_subfield(code => 'u', match => qr/zombo.com/);
271
272=cut
273
274sub delete_subfield {
275 my ($self, %options) = @_;
276 my $codes = _normalize_arrayref($options{code});
277 my $positions = _normalize_arrayref($options{'pos'});
278 my $match = $options{match};
279
280 croak 'match must be a compiled regex'
281 if $match and ref($match) ne 'Regexp';
282
283 my @current_subfields = @{$self->{_subfields}};
284 my @new_subfields = ();
285 my $removed = 0;
286 my $subfield_num = $[ - 1; # users $[ preferences control indexing
287
288 while (@current_subfields > 0) {
289 $subfield_num += 1;
290 my $subfield_code = shift @current_subfields;
291 my $subfield_value = shift @current_subfields;
292 if ((@$codes==0 or grep {$_ eq $subfield_code} @$codes)
293 and (!$match or $subfield_value =~ $match)
294 and (@$positions==0 or grep {$_ == $subfield_num} @$positions)) {
295 $removed += 1;
296 next;
297 }
298 push( @new_subfields, $subfield_code, $subfield_value);
299 }
300 $self->{_subfields} = \@new_subfields;
301 return $removed;
302}
303
304=head2 delete_subfields()
305
306Delete all subfields with a given subfield code. This is here for backwards
307compatability, you should use the more flexible delete_subfield().
308
309=cut
310
311sub delete_subfields {
312 my ($self, $code) = @_;
313 return $self->delete_subfield(code => $code);
314}
315
316=head2 update()
317
318Allows you to change the values of the field. You can update indicators
319and subfields like this:
320
321 $field->update( ind2 => '4', a => 'The ballad of Abe Lincoln');
322
323If you attempt to update a subfield which does not currently exist in the field,
324then a new subfield will be appended to the field. If you don't like this
325auto-vivification you must check for the existence of the subfield prior to
326update.
327
328 if ( $field->subfield( 'a' ) ) {
329 $field->update( 'a' => 'Cryptonomicon' );
330 }
331
332If you want to update a field that has no indicators or subfields (000-009)
333just call update() with one argument, the string that you would like to
334set the field to.
335
336 $field = $record->field( '003' );
337 $field->update('IMchF');
338
339Note: when doing subfield updates be aware that C<update()> will only
340update the first occurrence. If you need to do anything more complicated
341you will probably need to create a new field and use C<replace_with()>.
342
343Returns the number of items modified.
344
345=cut
346
347sub update {
348 my $self = shift;
349
350 ## tags 000 - 009 don't have indicators or subfields
351 if ( $self->is_control_field ) {
352 $self->{_data} = shift;
353 return(1);
354 }
355
356 ## otherwise we need to update subfields and indicators
357 my @data = @{$self->{_subfields}};
358 my $changes = 0;
359
360 while ( @_ ) {
361
362 my $arg = shift;
363 my $val = shift;
364
365 ## indicator update
366 if ($arg =~ /^ind[12]$/) {
367 $self->{"_$arg"} = $val;
368 $changes++;
369 }
370
371 ## subfield update
372 else {
373 my $found = 0;
374 ## update existing subfield
375 for ( my $i=0; $i<@data; $i+=2 ) {
376 if ($data[$i] eq $arg) {
377 $data[$i+1] = $val;
378 $found = 1;
379 $changes++;
380 last;
381 }
382 } # for
383
384 ## append new subfield
385 if ( !$found ) {
386 push( @data, $arg, $val );
387 $changes++;
388 }
389 }
390
391 } # while
392
393 ## synchronize our subfields
394 $self->{_subfields} = \@data;
395 return($changes);
396
397}
398
399=head2 replace_with()
400
401Allows you to replace an existing field with a new one. You need to pass
402C<replace()> a MARC::Field object to replace the existing field with. For
403example:
404
405 $field = $record->field('245');
406 my $new_field = new MARC::Field('245','0','4','The ballad of Abe Lincoln.');
407 $field->replace_with($new_field);
408
409Doesn't return a meaningful or reliable value.
410
411=cut
412
413sub replace_with {
414
415 my ($self,$new) = @_;
416 ref($new) =~ /^MARC::Field$/
417 or croak("Must pass a MARC::Field object");
418
419 %$self = %$new;
420
421}
422
423
424=head2 as_string( [$subfields] )
425
426Returns a string of all subfields run together. A space is added to
427the result between each subfield. The tag number and subfield
428character are not included.
429
430Subfields appear in the output string in the order in which they
431occur in the field.
432
433If C<$subfields> is specified, then only those subfields will be included.
434
435 my $field = MARC::Field->new(
436 245, '1', '0',
437 'a' => 'Abraham Lincoln',
438 'h' => '[videorecording] :',
439 'b' => 'preserving the union /',
440 'c' => 'A&E Home Video.'
441 );
442 print $field->as_string( 'abh' ); # Only those three subfields
443 # prints 'Abraham Lincoln [videorecording] : preserving the union /'.
444
445Note that subfield h comes before subfield b in the output.
446
447=cut
448
449sub as_string() {
450 my $self = shift;
451 my $subfields = shift;
452
453 if ( $self->is_control_field ) {
454 return $self->{_data};
455 }
456
457 my @subs;
458
459 my $subs = $self->{_subfields};
460 my $nfields = @$subs / 2;
461 for my $i ( 1..$nfields ) {
462 my $offset = ($i-1)*2;
463 my $code = $subs->[$offset];
464 my $text = $subs->[$offset+1];
465 push( @subs, $text ) if !$subfields || $code =~ /^[$subfields]$/;
466 } # for
467
468 return join( " ", @subs );
469}
470
471
472=head2 as_formatted()
473
474Returns a pretty string for printing in a MARC dump.
475
476=cut
477
478sub as_formatted() {
479 my $self = shift;
480
481 my @lines;
482
483 if ( $self->is_control_field ) {
484 push( @lines, sprintf( "%03s %s", $self->{_tag}, $self->{_data} ) );
485 } else {
486 my $hanger = sprintf( "%03s %1.1s%1.1s", $self->{_tag}, $self->{_ind1}, $self->{_ind2} );
487
488 my $subs = $self->{_subfields};
489 my $nfields = @$subs / 2;
490 my $offset = 0;
491 for my $i ( 1..$nfields ) {
492 push( @lines, sprintf( "%-6.6s _%1.1s%s", $hanger, $subs->[$offset++], $subs->[$offset++] ) );
493 $hanger = "";
494 } # for
495 }
496
497 return join( "\n", @lines );
498}
499
500
501=head2 as_usmarc()
502
503Returns a string for putting into a USMARC file. It's really only
504useful by C<MARC::Record::as_usmarc()>.
505
506=cut
507
508sub as_usmarc() {
509 my $self = shift;
510
511 # Tags < 010 are pretty easy
512 if ( $self->is_control_field ) {
513 return $self->data . END_OF_FIELD;
514 } else {
515 my @subs;
516 my @subdata = @{$self->{_subfields}};
517 while ( @subdata ) {
518 push( @subs, join( "", SUBFIELD_INDICATOR, shift @subdata, shift @subdata ) );
519 } # while
520
521 return
522 join( "",
523 $self->indicator(1),
524 $self->indicator(2),
525 @subs,
526 END_OF_FIELD, );
527 }
528}
529
530=head2 clone()
531
532Makes a copy of the field. Note that this is not just the same as saying
533
534 my $newfield = $field;
535
536since that just makes a copy of the reference. To get a new object, you must
537
538 my $newfield = $field->clone;
539
540Returns a MARC::Field record.
541
542=cut
543
544sub clone {
545 my $self = shift;
546
547 my $tagno = $self->{_tag};
548 my $is_control = (($tagno =~ /^\d+$/) && ($tagno < 10));
549
550 my $clone =
551 bless {
552 _tag => $tagno,
553 _warnings => [],
554 _is_control_field => $is_control,
555 }, ref($self);
556
557 if ( $is_control ) {
558 $clone->{_data} = $self->{_data};
559 } else {
560 $clone->{_ind1} = $self->{_ind1};
561 $clone->{_ind2} = $self->{_ind2};
562 $clone->{_subfields} = [@{$self->{_subfields}}];
563 }
564
565 return $clone;
566}
567
568=head2 warnings()
569
570Returns the warnings that were created when the record was read.
571These are things like "Invalid indicators converted to blanks".
572
573The warnings are items that you might be interested in, or might
574not. It depends on how stringently you're checking data. If
575you're doing some grunt data analysis, you probably don't care.
576
577=cut
578
579sub warnings() {
580 my $self = shift;
581
582 return @{$self->{_warnings}};
583}
584
585# NOTE: _warn is an object method
586sub _warn($) {
587 my $self = shift;
588
589 push( @{$self->{_warnings}}, join( "", @_ ) );
590}
591
592sub _gripe(@) {
593 $ERROR = join( "", @_ );
594
595 warn $ERROR;
596
597 return;
598}
599
600sub _normalize_arrayref {
601 my $ref = shift;
602 if (ref($ref) eq 'ARRAY') { return $ref }
603 elsif (defined $ref) { return [$ref] }
604 return [];
605}
606
607
60813µs3µs1;
609
610__END__
611
612=head1 SEE ALSO
613
614See the "SEE ALSO" section for L<MARC::Record>.
615
616=head1 TODO
617
618See the "TODO" section for L<MARC::Record>.
619
620=cut
621
622=head1 LICENSE
623
624This code may be distributed under the same terms as Perl itself.
625
626Please note that these modules are not products of or supported by the
627employers of the various contributors to the code.
628
629=head1 AUTHOR
630
631Andy Lester, C<< <andy@petdance.com> >>
632
633=cut