| 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 | MARC::Record::BEGIN |
| 0 | 0 | 0 | 0s | 0s | MARC::Record::_all_parms_are_fields |
| 0 | 0 | 0 | 0s | 0s | MARC::Record::_gripe |
| 0 | 0 | 0 | 0s | 0s | MARC::Record::_warn |
| 0 | 0 | 0 | 0s | 0s | MARC::Record::add_fields |
| 0 | 0 | 0 | 0s | 0s | MARC::Record::append_fields |
| 0 | 0 | 0 | 0s | 0s | MARC::Record::as_formatted |
| 0 | 0 | 0 | 0s | 0s | MARC::Record::as_usmarc |
| 0 | 0 | 0 | 0s | 0s | MARC::Record::author |
| 0 | 0 | 0 | 0s | 0s | MARC::Record::clone |
| 0 | 0 | 0 | 0s | 0s | MARC::Record::delete_field |
| 0 | 0 | 0 | 0s | 0s | MARC::Record::edition |
| 0 | 0 | 0 | 0s | 0s | MARC::Record::encoding |
| 0 | 0 | 0 | 0s | 0s | MARC::Record::field |
| 0 | 0 | 0 | 0s | 0s | MARC::Record::fields |
| 0 | 0 | 0 | 0s | 0s | MARC::Record::insert_fields_after |
| 0 | 0 | 0 | 0s | 0s | MARC::Record::insert_fields_before |
| 0 | 0 | 0 | 0s | 0s | MARC::Record::insert_fields_ordered |
| 0 | 0 | 0 | 0s | 0s | MARC::Record::insert_grouped_field |
| 0 | 0 | 0 | 0s | 0s | MARC::Record::leader |
| 0 | 0 | 0 | 0s | 0s | MARC::Record::new |
| 0 | 0 | 0 | 0s | 0s | MARC::Record::new_from_usmarc |
| 0 | 0 | 0 | 0s | 0s | MARC::Record::publication_date |
| 0 | 0 | 0 | 0s | 0s | MARC::Record::set_leader_lengths |
| 0 | 0 | 0 | 0s | 0s | MARC::Record::subfield |
| 0 | 0 | 0 | 0s | 0s | MARC::Record::title |
| 0 | 0 | 0 | 0s | 0s | MARC::Record::title_proper |
| 0 | 0 | 0 | 0s | 0s | MARC::Record::warnings |
| 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 |