File | /usr/share/perl5/MARC/Record.pm |
Statements Executed | 37 |
Total Time | 0.002563 seconds |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
0 | 0 | 0 | 0s | 0s | BEGIN | MARC::Record::
0 | 0 | 0 | 0s | 0s | _all_parms_are_fields | MARC::Record::
0 | 0 | 0 | 0s | 0s | _gripe | MARC::Record::
0 | 0 | 0 | 0s | 0s | _warn | MARC::Record::
0 | 0 | 0 | 0s | 0s | add_fields | MARC::Record::
0 | 0 | 0 | 0s | 0s | append_fields | MARC::Record::
0 | 0 | 0 | 0s | 0s | as_formatted | MARC::Record::
0 | 0 | 0 | 0s | 0s | as_usmarc | MARC::Record::
0 | 0 | 0 | 0s | 0s | author | MARC::Record::
0 | 0 | 0 | 0s | 0s | clone | MARC::Record::
0 | 0 | 0 | 0s | 0s | delete_field | MARC::Record::
0 | 0 | 0 | 0s | 0s | edition | MARC::Record::
0 | 0 | 0 | 0s | 0s | encoding | MARC::Record::
0 | 0 | 0 | 0s | 0s | field | MARC::Record::
0 | 0 | 0 | 0s | 0s | fields | MARC::Record::
0 | 0 | 0 | 0s | 0s | insert_fields_after | MARC::Record::
0 | 0 | 0 | 0s | 0s | insert_fields_before | MARC::Record::
0 | 0 | 0 | 0s | 0s | insert_fields_ordered | MARC::Record::
0 | 0 | 0 | 0s | 0s | insert_grouped_field | MARC::Record::
0 | 0 | 0 | 0s | 0s | leader | MARC::Record::
0 | 0 | 0 | 0s | 0s | new | MARC::Record::
0 | 0 | 0 | 0s | 0s | new_from_usmarc | MARC::Record::
0 | 0 | 0 | 0s | 0s | publication_date | MARC::Record::
0 | 0 | 0 | 0s | 0s | set_leader_lengths | MARC::Record::
0 | 0 | 0 | 0s | 0s | subfield | MARC::Record::
0 | 0 | 0 | 0s | 0s | title | MARC::Record::
0 | 0 | 0 | 0s | 0s | title_proper | MARC::Record::
0 | 0 | 0 | 0s | 0s | warnings | MARC::Record::
Line | Stmts. | Exclusive Time | Avg. | Code |
---|---|---|---|---|
1 | package MARC::Record; | |||
2 | ||||
3 | =head1 NAME | |||
4 | ||||
5 | MARC::Record - Perl extension for handling MARC records | |||
6 | ||||
7 | =cut | |||
8 | ||||
9 | 3 | 29µs | 10µs | use strict; # spent 8µs making 1 call to strict::import |
10 | 3 | 25µs | 8µs | use integer; # spent 5µs making 1 call to integer::import |
11 | ||||
12 | 3 | 26µs | 9µs | use vars qw( $ERROR ); # spent 24µs making 1 call to vars::import |
13 | ||||
14 | 3 | 129µs | 43µs | use MARC::Field; # spent 5µs making 1 call to import |
15 | 3 | 28µs | 9µs | use Carp qw(croak); # spent 44µs making 1 call to Exporter::import |
16 | ||||
17 | =head1 VERSION | |||
18 | ||||
19 | Version 2.0.0 | |||
20 | ||||
21 | =cut | |||
22 | ||||
23 | 3 | 34µs | 11µs | use vars qw( $VERSION ); # spent 28µs making 1 call to vars::import |
24 | 1 | 900ns | 900ns | $VERSION = '2.0.0'; |
25 | ||||
26 | 3 | 33µs | 11µs | use Exporter; # spent 34µs making 1 call to Exporter::import |
27 | 3 | 49µs | 16µs | use vars qw( @ISA @EXPORTS @EXPORT_OK ); # spent 57µs making 1 call to vars::import |
28 | 1 | 9µs | 9µs | @ISA = qw( Exporter ); |
29 | 1 | 400ns | 400ns | @EXPORTS = qw(); |
30 | 1 | 1µs | 1µs | @EXPORT_OK = qw( LEADER_LEN ); |
31 | ||||
32 | 4 | 36µs | 9µs | use vars qw( $DEBUG ); $DEBUG = 0; # spent 26µs making 1 call to vars::import |
33 | ||||
34 | 3 | 2.15ms | 717µs | use constant LEADER_LEN => 24; # spent 47µs making 1 call to constant::import |
35 | ||||
36 | =head1 DESCRIPTION | |||
37 | ||||
38 | Module for handling MARC records as objects. The file-handling stuff is | |||
39 | in MARC::File::*. | |||
40 | ||||
41 | =head1 ERROR HANDLING | |||
42 | ||||
43 | Any errors generated are stored in C<$MARC::Record::ERROR>. | |||
44 | Warnings are kept with the record and accessible in the C<warnings()> method. | |||
45 | ||||
46 | =head1 CONSTRUCTORS | |||
47 | ||||
48 | =head2 new() | |||
49 | ||||
50 | Base constructor for the class. It just returns a completely empty record. | |||
51 | To get real data, you'll need to populate it with fields, or use one of | |||
52 | the MARC::File::* modules to read from a file. | |||
53 | ||||
54 | =cut | |||
55 | ||||
56 | sub new { | |||
57 | my $class = shift; | |||
58 | my $self = { | |||
59 | _leader => ' ' x 24, | |||
60 | _fields => [], | |||
61 | _warnings => [], | |||
62 | }; | |||
63 | return bless $self, $class; | |||
64 | } # new() | |||
65 | ||||
66 | =head2 new_from_usmarc( $marcblob [, \&filter_func($tagno,$tagdata)] ) | |||
67 | ||||
68 | This is a wrapper around C<MARC::File::USMARC::decode()> for compatibility with | |||
69 | older versions of MARC::Record. | |||
70 | ||||
71 | The C<wanted_func()> is optional. See L<MARC::File::USMARC>::decode for details. | |||
72 | ||||
73 | =cut | |||
74 | ||||
75 | sub new_from_usmarc { | |||
76 | my $blob = shift; | |||
77 | $blob = shift if (ref($blob) || ($blob eq "MARC::Record")); | |||
78 | ||||
79 | require MARC::File::USMARC; | |||
80 | ||||
81 | return MARC::File::USMARC::decode( $blob, @_ ); | |||
82 | } | |||
83 | ||||
84 | =head1 COMMON FIELD RETRIEVAL METHODS | |||
85 | ||||
86 | Following are a number of convenience methods for commonly-retrieved | |||
87 | data fields. Please note that they each return strings, not MARC::Field | |||
88 | objects. They return empty strings if the appropriate field or subfield | |||
89 | is not found. This is as opposed to the C<field()>/C<subfield()> methods | |||
90 | which return C<undef> if something's not found. My assumption is that | |||
91 | these methods are used for quick & dirty reports and you don't want to | |||
92 | mess around with noting if something is undef. | |||
93 | ||||
94 | Also note that no punctuation cleanup is done. If the 245a is | |||
95 | "Programming Perl / ", then that's what you'll get back, rather than | |||
96 | "Programming Perl". | |||
97 | ||||
98 | =head2 title() | |||
99 | ||||
100 | Returns the title from the 245 tag. | |||
101 | ||||
102 | =cut | |||
103 | ||||
104 | sub title() { | |||
105 | my $self = shift; | |||
106 | ||||
107 | my $field = $self->field(245); | |||
108 | return $field ? $field->as_string : ""; | |||
109 | } | |||
110 | ||||
111 | =head2 title_proper() | |||
112 | ||||
113 | Returns the title proper from the 245 tag, subfields a, n and p. | |||
114 | ||||
115 | =cut | |||
116 | ||||
117 | sub title_proper() { | |||
118 | my $self = shift; | |||
119 | ||||
120 | my $field = $self->field(245); | |||
121 | ||||
122 | if ( $field ) { | |||
123 | return $field->as_string('anp'); | |||
124 | } else { | |||
125 | return ""; | |||
126 | } | |||
127 | } | |||
128 | ||||
129 | =head2 author() | |||
130 | ||||
131 | Returns the author from the 100, 110 or 111 tag. | |||
132 | ||||
133 | =cut | |||
134 | ||||
135 | sub author() { | |||
136 | my $self = shift; | |||
137 | ||||
138 | my $field = $self->field('100|110|111'); | |||
139 | return $field ? $field->as_string : ""; | |||
140 | } | |||
141 | ||||
142 | =head2 edition() | |||
143 | ||||
144 | Returns the edition from the 250 tag, subfield a. | |||
145 | ||||
146 | =cut | |||
147 | ||||
148 | sub edition() { | |||
149 | my $self = shift; | |||
150 | ||||
151 | my $str = $self->subfield(250,'a'); | |||
152 | return defined $str ? $str : ""; | |||
153 | } | |||
154 | ||||
155 | =head2 publication_date() | |||
156 | ||||
157 | Returns the publication date from the 260 tag, subfield c. | |||
158 | ||||
159 | =cut | |||
160 | ||||
161 | sub publication_date() { | |||
162 | my $self = shift; | |||
163 | ||||
164 | my $str = $self->subfield(260,'c'); | |||
165 | return defined $str ? $str : ""; | |||
166 | } | |||
167 | ||||
168 | =head1 FIELD & SUBFIELD ACCESS METHODS | |||
169 | ||||
170 | =head2 fields() | |||
171 | ||||
172 | Returns a list of all the fields in the record. The list contains | |||
173 | a MARC::Field object for each field in the record. | |||
174 | ||||
175 | =cut | |||
176 | ||||
177 | sub fields() { | |||
178 | my $self = shift; | |||
179 | return @{$self->{_fields}}; | |||
180 | } | |||
181 | ||||
182 | =head2 field( I<tagspec(s)> ) | |||
183 | ||||
184 | Returns a list of tags that match the field specifier, or an empty | |||
185 | list if nothing matched. In scalar context, returns the first | |||
186 | matching tag, or undef if nothing matched. | |||
187 | ||||
188 | The field specifier can be a simple number (i.e. "245"), or use the "." | |||
189 | notation of wildcarding (i.e. subject tags are "6.."). | |||
190 | ||||
191 | =cut | |||
192 | ||||
193 | 1 | 300ns | 300ns | my %field_regex; |
194 | ||||
195 | sub field { | |||
196 | my $self = shift; | |||
197 | my @specs = @_; | |||
198 | ||||
199 | my @list = (); | |||
200 | for my $tag ( @specs ) { | |||
201 | my $regex = $field_regex{ $tag }; | |||
202 | ||||
203 | # Compile & stash it if necessary | |||
204 | if ( not defined $regex ) { | |||
205 | $regex = qr/^$tag$/; | |||
206 | $field_regex{ $tag } = $regex; | |||
207 | } # not defined | |||
208 | ||||
209 | for my $maybe ( $self->fields ) { | |||
210 | if ( $maybe->tag =~ $regex ) { | |||
211 | return $maybe unless wantarray; | |||
212 | ||||
213 | push( @list, $maybe ); | |||
214 | } # if | |||
215 | } # for $maybe | |||
216 | } # for $tag | |||
217 | ||||
218 | return unless wantarray; | |||
219 | return @list; | |||
220 | } | |||
221 | ||||
222 | =head2 subfield( $tag, $subfield ) | |||
223 | ||||
224 | Shortcut method for getting just a subfield for a tag. These are equivalent: | |||
225 | ||||
226 | my $title = $marc->field('245')->subfield("a"); | |||
227 | my $title = $marc->subfield('245',"a"); | |||
228 | ||||
229 | If either the field or subfield can't be found, C<undef> is returned. | |||
230 | ||||
231 | =cut | |||
232 | ||||
233 | sub subfield { | |||
234 | my $self = shift; | |||
235 | my $tag = shift; | |||
236 | my $subfield = shift; | |||
237 | ||||
238 | my $field = $self->field($tag) or return; | |||
239 | return $field->subfield($subfield); | |||
240 | } # subfield() | |||
241 | ||||
242 | =for internal | |||
243 | ||||
244 | =cut | |||
245 | ||||
246 | sub _all_parms_are_fields { | |||
247 | for ( @_ ) { | |||
248 | return 0 unless ref($_) eq 'MARC::Field'; | |||
249 | } | |||
250 | return 1; | |||
251 | } | |||
252 | ||||
253 | =head2 append_fields( @fields ) | |||
254 | ||||
255 | Appends the field specified by C<$field> to the end of the record. | |||
256 | C<@fields> need to be MARC::Field objects. | |||
257 | ||||
258 | my $field = MARC::Field->new('590','','','a' => 'My local note.'); | |||
259 | $record->append_fields($field); | |||
260 | ||||
261 | Returns the number of fields appended. | |||
262 | ||||
263 | =cut | |||
264 | ||||
265 | sub append_fields { | |||
266 | my $self = shift; | |||
267 | ||||
268 | _all_parms_are_fields(@_) or croak('Arguments must be MARC::Field objects'); | |||
269 | ||||
270 | push(@{ $self->{_fields} }, @_); | |||
271 | return scalar @_; | |||
272 | } | |||
273 | ||||
274 | =head2 insert_fields_before( $before_field, @new_fields ) | |||
275 | ||||
276 | Inserts the field specified by C<$new_field> before the field C<$before_field>. | |||
277 | Returns the number of fields inserted, or undef on failures. | |||
278 | Both C<$before_field> and all C<@new_fields> need to be MARC::Field objects. | |||
279 | If they are not an exception will be thrown. | |||
280 | ||||
281 | my $before_field = $record->field('260'); | |||
282 | my $new_field = MARC::Field->new('250','','','a' => '2nd ed.'); | |||
283 | $record->insert_fields_before($before_field,$new_field); | |||
284 | ||||
285 | =cut | |||
286 | ||||
287 | sub insert_fields_before { | |||
288 | my $self = shift; | |||
289 | ||||
290 | _all_parms_are_fields(@_) | |||
291 | or croak('All arguments must be MARC::Field objects'); | |||
292 | ||||
293 | my ($before,@new) = @_; | |||
294 | ||||
295 | ## find position of $before | |||
296 | my $fields = $self->{_fields}; | |||
297 | my $pos = 0; | |||
298 | foreach my $f (@$fields) { | |||
299 | last if ($f == $before); | |||
300 | $pos++; | |||
301 | } | |||
302 | ||||
303 | ## insert before $before | |||
304 | if ($pos >= @$fields) { | |||
305 | $self->_warn("Couldn't find field to insert before"); | |||
306 | return; | |||
307 | } | |||
308 | splice(@$fields,$pos,0,@new); | |||
309 | return scalar @new; | |||
310 | ||||
311 | } | |||
312 | ||||
313 | =head2 insert_fields_after( $after_field, @new_fields ) | |||
314 | ||||
315 | Identical to C<insert_fields_before()>, but fields are added after | |||
316 | C<$after_field>. Remember, C<$after_field> and any new fields must be | |||
317 | valid MARC::Field objects or else an exception will be thrown. | |||
318 | ||||
319 | =cut | |||
320 | ||||
321 | sub insert_fields_after { | |||
322 | my $self = shift; | |||
323 | ||||
324 | _all_parms_are_fields(@_) or croak('All arguments must be MARC::Field objects'); | |||
325 | my ($after,@new) = @_; | |||
326 | ||||
327 | ## find position of $after | |||
328 | my $fields = $self->{_fields}; | |||
329 | my $pos = 0; | |||
330 | foreach my $f (@$fields) { | |||
331 | last if ($f == $after); | |||
332 | $pos++; | |||
333 | } | |||
334 | ||||
335 | ## insert after $after | |||
336 | if ($pos+1 >= @$fields) { | |||
337 | $self->_warn("Couldn't find field to insert after"); | |||
338 | return; | |||
339 | } | |||
340 | splice(@$fields,$pos+1,0,@new); | |||
341 | return scalar @new; | |||
342 | } | |||
343 | ||||
344 | =head2 insert_fields_ordered( @new_fields ) | |||
345 | ||||
346 | Will insert fields in strictly numerical order. So a 008 will be filed | |||
347 | after a 001 field. See C<insert_grouped_field()> for an additional ordering. | |||
348 | ||||
349 | =cut | |||
350 | ||||
351 | sub insert_fields_ordered { | |||
352 | my ( $self, @new ) = @_; | |||
353 | ||||
354 | _all_parms_are_fields(@new) | |||
355 | or croak('All arguments must be MARC::Field objects'); | |||
356 | ||||
357 | ## go through each new field | |||
358 | NEW_FIELD: foreach my $newField ( @new ) { | |||
359 | ||||
360 | ## find location before which it should be inserted | |||
361 | EXISTING_FIELD: foreach my $field ( @{ $self->{_fields} } ) { | |||
362 | if ( $field->tag() >= $newField->tag() ) { | |||
363 | $self->insert_fields_before( $field, $newField ); | |||
364 | next NEW_FIELD; | |||
365 | } | |||
366 | } | |||
367 | ||||
368 | ## if we fell through then this new field is higher than | |||
369 | ## all the existing fields, so we append. | |||
370 | $self->append_fields( $newField ); | |||
371 | ||||
372 | } | |||
373 | return( scalar( @new ) ); | |||
374 | } | |||
375 | ||||
376 | =head2 insert_grouped_field( $field ) | |||
377 | ||||
378 | Will insert the specified MARC::Field object into the record in grouped | |||
379 | order and return true (1) on success, and false (undef) on failure. | |||
380 | ||||
381 | my $field = MARC::Field->new( '510', 'Indexed by Google.' ); | |||
382 | $record->insert_grouped_field( $field ); | |||
383 | ||||
384 | For example, if a '650' field is inserted with C<insert_grouped_field()> | |||
385 | it will be inserted at the end of the 6XX group of tags. After discussion | |||
386 | most people wanted the ability to add a new field to the end of the | |||
387 | hundred group where it belonged. The reason is that according to the MARC | |||
388 | format, fields within a record are supposed to be grouped by block | |||
389 | (hundred groups). This means that fields may not necessarily be in tag | |||
390 | order. | |||
391 | ||||
392 | =cut | |||
393 | ||||
394 | sub insert_grouped_field { | |||
395 | my ($self,$new) = @_; | |||
396 | _all_parms_are_fields($new) or croak('Argument must be MARC::Field object'); | |||
397 | ||||
398 | ## try to find the end of the field group and insert it there | |||
399 | my $limit = int($new->tag() / 100); | |||
400 | my $found = 0; | |||
401 | foreach my $field ($self->fields()) { | |||
402 | if ( int($field->tag() / 100) > $limit ) { | |||
403 | $self->insert_fields_before($field,$new); | |||
404 | $found = 1; | |||
405 | last; | |||
406 | } | |||
407 | } | |||
408 | ||||
409 | ## if we couldn't find the end of the group, then we must not have | |||
410 | ## any tags this high yet, so just append it | |||
411 | if (!$found) { | |||
412 | $self->append_fields($new); | |||
413 | } | |||
414 | ||||
415 | return(1); | |||
416 | ||||
417 | } | |||
418 | ||||
419 | ||||
420 | =head2 delete_field( $field ) | |||
421 | ||||
422 | Deletes a field from the record. | |||
423 | ||||
424 | The field must have been retrieved from the record using the | |||
425 | C<field()> method. For example, to delete a 526 tag if it exists: | |||
426 | ||||
427 | my $tag526 = $marc->field( "526" ); | |||
428 | if ( $tag526 ) { | |||
429 | $marc->delete_field( $tag526 ); | |||
430 | } | |||
431 | ||||
432 | C<delete_field()> returns the number of fields that were deleted. | |||
433 | This shouldn't be 0 unless you didn't get the tag properly. | |||
434 | ||||
435 | =cut | |||
436 | ||||
437 | sub delete_field { | |||
438 | my $self = shift; | |||
439 | my $deleter = shift; | |||
440 | my $list = $self->{_fields}; | |||
441 | ||||
442 | my $old_count = @$list; | |||
443 | @$list = grep { $_ != $deleter } @$list; | |||
444 | return $old_count - @$list; | |||
445 | } | |||
446 | ||||
447 | =head2 as_usmarc() | |||
448 | ||||
449 | This is a wrapper around C<MARC::File::USMARC::encode()> for compatibility with | |||
450 | older versions of MARC::Record. | |||
451 | ||||
452 | =cut | |||
453 | ||||
454 | sub as_usmarc() { | |||
455 | my $self = shift; | |||
456 | ||||
457 | require MARC::File::USMARC; | |||
458 | ||||
459 | return MARC::File::USMARC::encode( $self ); | |||
460 | } | |||
461 | ||||
462 | =head2 as_formatted() | |||
463 | ||||
464 | Returns a pretty string for printing in a MARC dump. | |||
465 | ||||
466 | =cut | |||
467 | ||||
468 | sub as_formatted() { | |||
469 | my $self = shift; | |||
470 | ||||
471 | my @lines = ( "LDR " . ($self->{_leader} || "") ); | |||
472 | for my $field ( @{$self->{_fields}} ) { | |||
473 | push( @lines, $field->as_formatted() ); | |||
474 | } | |||
475 | ||||
476 | return join( "\n", @lines ); | |||
477 | } # as_formatted | |||
478 | ||||
479 | ||||
480 | =head2 leader() | |||
481 | ||||
482 | Returns the leader for the record. Sets the leader if I<text> is defined. | |||
483 | No error checking is done on the validity of the leader. | |||
484 | ||||
485 | =cut | |||
486 | ||||
487 | sub leader { | |||
488 | my $self = shift; | |||
489 | my $text = shift; | |||
490 | ||||
491 | if ( defined $text ) { | |||
492 | (length($text) eq 24) | |||
493 | or $self->_warn( "Leader must be 24 bytes long" ); | |||
494 | $self->{_leader} = $text; | |||
495 | } # set the leader | |||
496 | ||||
497 | return $self->{_leader}; | |||
498 | } # leader() | |||
499 | ||||
500 | =head2 encoding() | |||
501 | ||||
502 | A method for getting/setting the encoding for a record. The encoding for a | |||
503 | record is determined by position 09 in the leader, which is blank for MARC-8 | |||
504 | encoding, and 'a' for UCS/Unicode. encoding() will return a string, either | |||
505 | 'MARC-8' or 'UTF-8' appropriately. | |||
506 | ||||
507 | If you want to set the encoding for a MARC::Record object you can use the | |||
508 | string values: | |||
509 | ||||
510 | $record->encoding( 'UTF-8' ); | |||
511 | ||||
512 | NOTE: MARC::Record objects created from scratch have an a default encoding | |||
513 | of MARC-8, which has been the standard for years...but many online catlogs | |||
514 | and record vendors are migrating to UTF-8. | |||
515 | ||||
516 | WARNING: you should be sure your record really does contain valid UTF-8 data | |||
517 | when you manually set the encoding. | |||
518 | ||||
519 | =cut | |||
520 | ||||
521 | sub encoding { | |||
522 | my ($self,$arg) = @_; | |||
523 | # we basically report from and modify the leader directly | |||
524 | my $leader = $self->leader(); | |||
525 | ||||
526 | # when setting | |||
527 | if ( defined($arg) ) { | |||
528 | if ( $arg =~ /UTF-8/i ) { | |||
529 | substr($leader,9,1) = 'a'; | |||
530 | } | |||
531 | elsif ( $arg =~ /MARC-8/i ) { | |||
532 | substr($leader,9,1) = ' '; | |||
533 | } | |||
534 | $self->leader($leader); | |||
535 | } | |||
536 | ||||
537 | return substr($leader,9,1) eq 'a' ? 'UTF-8' : 'MARC-8'; | |||
538 | } | |||
539 | ||||
540 | =head2 set_leader_lengths( $reclen, $baseaddr ) | |||
541 | ||||
542 | Internal function for updating the leader's length and base address. | |||
543 | ||||
544 | =cut | |||
545 | ||||
546 | sub set_leader_lengths { | |||
547 | my $self = shift; | |||
548 | my $reclen = shift; | |||
549 | my $baseaddr = shift; | |||
550 | substr($self->{_leader},0,5) = sprintf("%05d",$reclen); | |||
551 | substr($self->{_leader},12,5) = sprintf("%05d",$baseaddr); | |||
552 | # MARC21 defaults: http://www.loc.gov/marc/bibliographic/ecbdldrd.html | |||
553 | substr($self->{_leader},10,2) = '22'; | |||
554 | substr($self->{_leader},20,4) = '4500'; | |||
555 | } | |||
556 | ||||
557 | =head2 clone() | |||
558 | ||||
559 | The C<clone()> method makes a copy of an existing MARC record and returns | |||
560 | the new version. Note that you cannot just say: | |||
561 | ||||
562 | my $newmarc = $oldmarc; | |||
563 | ||||
564 | This just makes a copy of the reference, not a new object. You must use | |||
565 | the C<clone()> method like so: | |||
566 | ||||
567 | my $newmarc = $oldmarc->clone; | |||
568 | ||||
569 | You can also specify field specs to filter down only a | |||
570 | certain subset of fields. For instance, if you only wanted the | |||
571 | title and ISBN tags from a record, you could do this: | |||
572 | ||||
573 | my $small_marc = $marc->clone( 245, '020' ); | |||
574 | ||||
575 | The order of the fields is preserved as it was in the original record. | |||
576 | ||||
577 | =cut | |||
578 | ||||
579 | sub clone { | |||
580 | my $self = shift; | |||
581 | my @keeper_tags = @_; | |||
582 | ||||
583 | # create a new object of whatever type we happen to be | |||
584 | my $class = ref( $self ); | |||
585 | my $clone = $class->new(); | |||
586 | ||||
587 | $clone->{_leader} = $self->{_leader}; | |||
588 | ||||
589 | my $filtered = @keeper_tags ? [$self->field( @keeper_tags )] : undef; | |||
590 | ||||
591 | for my $field ( $self->fields() ) { | |||
592 | if ( !$filtered || (grep {$field eq $_} @$filtered ) ) { | |||
593 | $clone->append_fields( $field->clone ); | |||
594 | } | |||
595 | } | |||
596 | ||||
597 | # XXX FIX THIS $clone->update_leader(); | |||
598 | ||||
599 | return $clone; | |||
600 | } | |||
601 | ||||
602 | =head2 warnings() | |||
603 | ||||
604 | Returns the warnings (as a list) that were created when the record was read. | |||
605 | These are things like "Invalid indicators converted to blanks". | |||
606 | ||||
607 | my @warnings = $record->warnings(); | |||
608 | ||||
609 | The warnings are items that you might be interested in, or might | |||
610 | not. It depends on how stringently you're checking data. If | |||
611 | you're doing some grunt data analysis, you probably don't care. | |||
612 | ||||
613 | A side effect of calling warnings() is that the warning buffer will | |||
614 | be cleared. | |||
615 | ||||
616 | =cut | |||
617 | ||||
618 | sub warnings() { | |||
619 | my $self = shift; | |||
620 | my @warnings = @{$self->{_warnings}}; | |||
621 | $self->{_warnings} = []; | |||
622 | return @warnings; | |||
623 | } | |||
624 | ||||
625 | =head2 add_fields() | |||
626 | ||||
627 | C<add_fields()> is now deprecated, and users are encouraged to use | |||
628 | C<append_fields()>, C<insert_fields_after()>, and C<insert_fields_before()> | |||
629 | since they do what you want probably. It is still here though, for backwards | |||
630 | compatability. | |||
631 | ||||
632 | C<add_fields()> adds MARC::Field objects to the end of the list. Returns the | |||
633 | number of fields added, or C<undef> if there was an error. | |||
634 | ||||
635 | There are three ways of calling C<add_fields()> to add data to the record. | |||
636 | ||||
637 | =over 4 | |||
638 | ||||
639 | =item 1 Create a MARC::Field object and add it | |||
640 | ||||
641 | my $author = MARC::Field->new( | |||
642 | 100, "1", " ", a => "Arnosky, Jim." | |||
643 | ); | |||
644 | $marc->add_fields( $author ); | |||
645 | ||||
646 | =item 2 Add the data fields directly, and let C<add_fields()> take care of the objectifying. | |||
647 | ||||
648 | $marc->add_fields( | |||
649 | 245, "1", "0", | |||
650 | a => "Raccoons and ripe corn /", | |||
651 | c => "Jim Arnosky.", | |||
652 | ); | |||
653 | ||||
654 | =item 3 Same as #2 above, but pass multiple fields of data in anonymous lists | |||
655 | ||||
656 | $marc->add_fields( | |||
657 | [ 250, " ", " ", a => "1st ed." ], | |||
658 | [ 650, "1", " ", a => "Raccoons." ], | |||
659 | ); | |||
660 | ||||
661 | =back | |||
662 | ||||
663 | =cut | |||
664 | ||||
665 | sub add_fields { | |||
666 | my $self = shift; | |||
667 | ||||
668 | my $nfields = 0; | |||
669 | my $fields = $self->{_fields}; | |||
670 | ||||
671 | while ( my $parm = shift ) { | |||
672 | # User handed us a list of data (most common possibility) | |||
673 | if ( ref($parm) eq "" ) { | |||
674 | my $field = MARC::Field->new( $parm, @_ ) | |||
675 | or return _gripe( $MARC::Field::ERROR ); | |||
676 | push( @$fields, $field ); | |||
677 | ++$nfields; | |||
678 | last; # Bail out, we're done eating parms | |||
679 | ||||
680 | # User handed us an object. | |||
681 | } elsif ( ref($parm) eq "MARC::Field" ) { | |||
682 | push( @$fields, $parm ); | |||
683 | ++$nfields; | |||
684 | ||||
685 | # User handed us an anonymous list of parms | |||
686 | } elsif ( ref($parm) eq "ARRAY" ) { | |||
687 | my $field = MARC::Field->new(@$parm) | |||
688 | or return _gripe( $MARC::Field::ERROR ); | |||
689 | push( @$fields, $field ); | |||
690 | ++$nfields; | |||
691 | ||||
692 | } else { | |||
693 | croak( "Unknown parm of type", ref($parm), " passed to add_fields()" ); | |||
694 | } # if | |||
695 | ||||
696 | } # while | |||
697 | ||||
698 | return $nfields; | |||
699 | } | |||
700 | ||||
701 | # NOTE: _warn is an object method | |||
702 | sub _warn { | |||
703 | my $self = shift; | |||
704 | push( @{$self->{_warnings}}, join( "", @_ ) ); | |||
705 | return( $self ); | |||
706 | } | |||
707 | ||||
708 | ||||
709 | # NOTE: _gripe is NOT an object method | |||
710 | sub _gripe { | |||
711 | $ERROR = join( "", @_ ); | |||
712 | ||||
713 | warn $ERROR; | |||
714 | ||||
715 | return; | |||
716 | } | |||
717 | ||||
718 | ||||
719 | 1 | 11µs | 11µs | 1; |
720 | ||||
721 | __END__ | |||
722 | ||||
723 | =head1 DESIGN NOTES | |||
724 | ||||
725 | A brief discussion of why MARC::Record is done the way it is: | |||
726 | ||||
727 | =over 4 | |||
728 | ||||
729 | =item * It's built for quick prototyping | |||
730 | ||||
731 | One of the areas Perl excels is in allowing the programmer to | |||
732 | create easy solutions quickly. MARC::Record is designed along | |||
733 | those same lines. You want a program to dump all the 6XX | |||
734 | tags in a file? MARC::Record is your friend. | |||
735 | ||||
736 | =item * It's built for extensibility | |||
737 | ||||
738 | Currently, I'm using MARC::Record for analyzing bibliographic | |||
739 | data, but who knows what might happen in the future? MARC::Record | |||
740 | needs to be just as adept at authority data, too. | |||
741 | ||||
742 | =item * It's designed around accessor methods | |||
743 | ||||
744 | I use method calls everywhere, and I expect calling programs to do | |||
745 | the same, rather than accessing internal data directly. If you | |||
746 | access an object's hash fields on your own, future releases may | |||
747 | break your code. | |||
748 | ||||
749 | =item * It's not built for speed | |||
750 | ||||
751 | One of the tradeoffs in using accessor methods is some overhead | |||
752 | in the method calls. Is this slow? I don't know, I haven't measured. | |||
753 | I would suggest that if you're a cycle junkie that you use | |||
754 | Benchmark.pm to check to see where your bottlenecks are, and then | |||
755 | decide if MARC::Record is for you. | |||
756 | ||||
757 | =back | |||
758 | ||||
759 | =head1 RELATED MODULES | |||
760 | ||||
761 | L<MARC::Field>, L<MARC::Batch>, L<MARC::File::XML>, L<MARC::Charset>, | |||
762 | L<MARC::Lint> | |||
763 | ||||
764 | =head1 SEE ALSO | |||
765 | ||||
766 | =over 4 | |||
767 | ||||
768 | =item * perl4lib (L<http://www.rice.edu/perl4lib/>) | |||
769 | ||||
770 | A mailing list devoted to the use of Perl in libraries. | |||
771 | ||||
772 | =item * Library Of Congress MARC pages (L<http://www.loc.gov/marc/>) | |||
773 | ||||
774 | The definitive source for all things MARC. | |||
775 | ||||
776 | ||||
777 | =item * I<Understanding MARC Bibliographic> (L<http://lcweb.loc.gov/marc/umb/>) | |||
778 | ||||
779 | Online version of the free booklet. An excellent overview of the MARC format. Essential. | |||
780 | ||||
781 | ||||
782 | =item * Tag Of The Month (L<http://www.tagofthemonth.com/>) | |||
783 | ||||
784 | Follett Software Company's | |||
785 | (L<http://www.fsc.follett.com/>) monthly discussion of various MARC tags. | |||
786 | ||||
787 | =back | |||
788 | ||||
789 | =head1 TODO | |||
790 | ||||
791 | =over 4 | |||
792 | ||||
793 | =item * Incorporate MARC.pm in the distribution. | |||
794 | ||||
795 | Combine MARC.pm and MARC::* into one distribution. | |||
796 | ||||
797 | =item * Podify MARC.pm | |||
798 | ||||
799 | =item * Allow regexes across the entire tag | |||
800 | ||||
801 | Imagine something like this: | |||
802 | ||||
803 | my @sears_headings = $marc->tag_grep( qr/Sears/ ); | |||
804 | ||||
805 | (from Mike O'Regan) | |||
806 | ||||
807 | =item * Insert a field in an arbitrary place in the record | |||
808 | ||||
809 | =item * Modifying an existing field | |||
810 | ||||
811 | =back | |||
812 | ||||
813 | =head1 BUGS, WISHES AND CORRESPONDENCE | |||
814 | ||||
815 | Please feel free to email me at C<< <mrylander@gmail.com> >>. I'm glad | |||
816 | to help as best I can, and I'm always interested in bugs, suggestions | |||
817 | and patches. | |||
818 | ||||
819 | An excellent place to look for information, and get quick help, is from | |||
820 | the perl4lib mailing list. See L<http://perl4lib.perl.org> for more | |||
821 | information about this list, and other helpful MARC information. | |||
822 | ||||
823 | The MARC::Record development team uses the RT bug tracking system at | |||
824 | L<http://rt.cpan.org>. If your email is about a bug or suggestion, | |||
825 | please report it through the RT system. This is a huge help for the | |||
826 | team, and you'll be notified of progress as things get fixed or updated. | |||
827 | If you prefer not to use the website, you can send your bug to C<< | |||
828 | <bug-MARC-Record@rt.cpan.org> >> | |||
829 | ||||
830 | =head1 IDEAS | |||
831 | ||||
832 | Ideas are things that have been considered, but nobody's actually asked for. | |||
833 | ||||
834 | =over 4 | |||
835 | ||||
836 | =item * Create multiple output formats. | |||
837 | ||||
838 | These could be ASCII or MarcMaker. | |||
839 | ||||
840 | =back | |||
841 | ||||
842 | =head1 LICENSE | |||
843 | ||||
844 | This code may be distributed under the same terms as Perl itself. | |||
845 | ||||
846 | Please note that these modules are not products of or supported by the | |||
847 | employers of the various contributors to the code. | |||
848 | ||||
849 | =head1 AUTHOR | |||
850 | ||||
851 | Andy Lester, C<< <andy@petdance.com> >> | |||
852 | ||||
853 | =cut | |||
854 |