marc/USMARC.pm

   1 package MARC::File::USMARC;
   2
   3
   4 # Copyright 2000-2002 Katipo Communications
   5 #
   6 # This file is part of Koha.
   7 #
   8 # Koha is free software; you can redistribute it and/or modify it under the
   9 # terms of the GNU General Public License as published by the Free Software
  10 # Foundation; either version 2 of the License, or (at your option) any later
  11 # version.
  12 #
  13 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
  14 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
  15 # A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License along with
  18 # Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
  19 # Suite 330, Boston, MA  02111-1307 USA
  20
  21 # FIXME - Fix the POD to conform to Perl style. In particular,
  22 # functions get an =item, not a =head2.
  23
  24 =head1 NAME
  25
  26 MARC::File::USMARC - USMARC-specific file handling
  27
  28 =cut
  29
  30 use 5.6.0;
  31 use strict;
  32 use integer;
  33 use vars qw( $VERSION $ERROR );
  34
  35 =head1 VERSION
  36
  37 Version 0.93
  38
  39     $Id$
  40
  41 =cut
  42
  43 our $VERSION = '0.93';
  44
  45 use MARC::File;
  46 our @ISA = qw( MARC::File );
  47
  48 use MARC::Record qw( LEADER_LEN );
  49 use constant SUBFIELD_INDICATOR     => "\x1F";
  50 use constant END_OF_FIELD           => "\x1E";
  51 use constant END_OF_RECORD          => "\x1D";
  52 use constant DIRECTORY_ENTRY_LEN    => 12;
  53
  54 =head1 SYNOPSIS
  55
  56     use MARC::File::USMARC;
  57
  58     my $file = MARC::File::USMARC::in( $filename );
  59
  60     while ( my $marc = $file->next() ) {
  61         # Do something
  62     }
  63     $file->close();
  64     undef $file;
  65
  66 =head1 EXPORT
  67
  68 None.
  69
  70 =head1 METHODS
  71
  72 =for internal
  73
  74 Internal function to get the next raw record out of a file.
  75
  76 =cut
  77
  78 sub _next {
  79     my $self = shift;
  80
  81     if ($self->{fh}) {
  82         my $fh = $self->{fh};
  83
  84         my $reclen;
  85
  86         read( $fh, $reclen, 5 )
  87             or return $self->_gripe( "Error reading record length: $!" );
  88
  89         $reclen =~ /^\d{5}$/
  90             or return $self->_gripe( "Invalid record length \"$reclen\"" );
  91         my $usmarc = $reclen;
  92         read( $fh, substr($usmarc,5), $reclen-5 )
  93             or return $self->_gripe( "Error reading $reclen byte record: $!" );
  94
  95         return $usmarc;
  96     } elsif (defined($self->{data})) {
  97         my $data=$self->{data};
  98         my $pointer=$self->{pointer};
  99         my $reclen;
 100         $reclen=substr($data,$pointer,5);
 101         $reclen=~/^\d{5}$/
 102             or return $self->_gripe( "Invalid record length \"$reclen\"" );
 103         my $usmarc=substr($data,$pointer,$reclen);
 104         $self->{pointer}=$pointer+$reclen;
 105         return $usmarc;
 106     }
 107 }
 108
 109 =head2 decode()
 110
 111 Constructor for handling data from a USMARC file.  This function takes care of all
 112 the tag directory parsing & mangling.
 113
 114 Any warnings or coercions can be checked in the C<warnings()> function.
 115
 116 =cut
 117
 118 sub decode {
 119     my $text = shift;
 120     $text = shift if (ref($text)||$text) =~ /^MARC::File/;
 121
 122     my $marc = MARC::Record->new();
 123
 124     # Check for an all-numeric record length
 125     ($text =~ /^(\d{5})/)
 126         or return $marc->_gripe( "Record length \"", substr( $text, 0, 5 ), "\" is not numeric" );
 127
 128     my $reclen = $1;
 129     ($reclen == length($text))
 130         or return $marc->_gripe( "Invalid record length: Leader says $reclen bytes, but it's actually ", length( $text ) );
 131
 132     $marc->leader( substr( $text, 0, LEADER_LEN ) );
 133     my @fields = split( END_OF_FIELD, substr( $text, LEADER_LEN ) );
 134     my $dir = shift @fields or return _gripe( "No directory found" );
 135
 136     (length($dir) % 12 == 0)
 137         or return $marc->_gripe( "Invalid directory length" );
 138     my $nfields = length($dir)/12;
 139
 140     my $finalfield = pop @fields;
 141     # Check for the record terminator, and ignore it
 142     ($finalfield eq END_OF_RECORD)
 143         or $marc->_warn( "Invalid record terminator: \"$finalfield\"" );
 144
 145     # Walk thru the directories, and shift off the fields while we're at it
 146     # Shouldn't be any non-digits anywhere in any directory entry
 147     my @directory = unpack( "A3 A4 A5" x $nfields, $dir );
 148     my @bad = grep /\D/, @directory;
 149     if ( @bad ) {
 150         return $marc->_gripe( "Non-numeric entries in the tag directory: ", join( ", ", map { "\"$_\"" } @bad ) );
 151     }
 152
 153     my $databytesused = 0;
 154     while ( @directory ) {
 155         my $tagno = shift @directory;
 156         my $len = shift @directory;
 157         my $offset = shift @directory;
 158         my $tagdata = shift @fields;
 159
 160         # Check directory validity
 161         ($tagno =~ /^\d\d\d$/)
 162             or return $marc->_gripe( "Invalid field number in directory: \"$tagno\"" );
 163
 164         ($len == length($tagdata) + 1)
 165             or $marc->_warn( "Invalid length in the directory for tag $tagno" );
 166
 167         ($offset == $databytesused)
 168             or $marc->_warn( "Directory offsets are out of whack" );
 169         $databytesused += $len;
 170
 171         if ( $tagno < 10 ) {
 172             $marc->add_fields( $tagno, $tagdata )
 173                 or return undef; # We're relying on add_fields() having set $MARC::Record::ERROR
 174         } else {
 175             my @subfields = split( SUBFIELD_INDICATOR, $tagdata );
 176             my $indicators = shift @subfields
 177                 or return $marc->_gripe( "No subfields found." );
 178             my ($ind1,$ind2);
 179             if ( $indicators =~ /^([0-9 ])([0-9 ])$/ ) {
 180                 ($ind1,$ind2) = ($1,$2);
 181             } else {
 182                 $marc->_warn( "Invalid indicators \"$indicators\" forced to blanks\n" );
 183                 ($ind1,$ind2) = (" "," ");
 184             }
 185
 186             # Split the subfield data into subfield name and data pairs
 187             my @subfield_data = map { (substr($_,0,1),substr($_,1)) } @subfields;
 188             $marc->add_fields( $tagno, $ind1, $ind2, @subfield_data )
 189                 or return undef;
 190         }
 191     } # while
 192
 193     # Once we're done, there shouldn't be any fields left over: They should all have shifted off.
 194     (@fields == 0)
 195         or return $marc->_gripe( "I've got leftover fields that weren't in the directory" );
 196
 197     return $marc;
 198 }
 199
 200 =head2 update_leader()
 201
 202 If any changes get made to the MARC record, the first 5 bytes of the
 203 leader (the length) will be invalid.  This function updates the
 204 leader with the correct length of the record as it would be if
 205 written out to a file.
 206
 207 =cut
 208
 209 sub update_leader() {
 210         my $self = shift;
 211
 212         my (undef,undef,$reclen,$baseaddress) = $self->_build_tag_directory();
 213
 214         $self->_set_leader_lengths( $reclen, $baseaddress );
 215 }
 216
 217 =head2 _build_tag_directory()
 218
 219 Function for internal use only: Builds the tag directory that gets
 220 put in front of the data in a MARC record.
 221
 222 Returns two array references, and two lengths: The tag directory, and the data fields themselves,
 223 the length of all data (including the Leader that we expect will be added),
 224 and the size of the Leader and tag directory.
 225
 226 =cut
 227
 228 sub _build_tag_directory {
 229         my $marc = shift;
 230         $marc = shift if (ref($marc)||$marc) =~ /^MARC::File/;
 231         die "Wanted a MARC::Record but got a ", ref($marc) unless ref($marc) eq "MARC::Record";
 232
 233         my @fields;
 234         my @directory;
 235
 236         my $dataend = 0;
 237         for my $field ( $marc->fields() ) {
 238                 # Dump data into proper format
 239                 my $str = $field->as_usmarc;
 240                 push( @fields, $str );
 241
 242                 # Create directory entry
 243                 my $len = length $str;
 244                 my $direntry = sprintf( "%03d%04d%05d", $field->tag, $len, $dataend );
 245                 push( @directory, $direntry );
 246                 $dataend += $len;
 247         }
 248
 249         my $baseaddress =
 250                 LEADER_LEN +    # better be 24
 251                 ( @directory * DIRECTORY_ENTRY_LEN ) +
 252                                 # all the directory entries
 253                 1;              # end-of-field marker
 254
 255
 256         my $total =
 257                 $baseaddress +  # stuff before first field
 258                 $dataend +      # Length of the fields
 259                 1;              # End-of-record marker
 260
 261
 262
 263         return (\@fields, \@directory, $total, $baseaddress);
 264 }
 265
 266 =head2 encode()
 267
 268 Returns a string of characters suitable for writing out to a USMARC file,
 269 including the leader, directory and all the fields.
 270
 271 =cut
 272
 273 sub encode() {
 274     my $marc = shift;
 275     $marc = shift if (ref($marc)||$marc) =~ /^MARC::File/;
 276
 277     my ($fields,$directory,$reclen,$baseaddress) = _build_tag_directory($marc);
 278     $marc->set_leader_lengths( $reclen, $baseaddress );
 279
 280     # Glomp it all together
 281     return join("",$marc->leader, @$directory, END_OF_FIELD, @$fields, END_OF_RECORD);
 282 }
 283
 284 1;
 285
 286 __END__
 287
 288 =head1 RELATED MODULES
 289
 290 L<MARC::Record>
 291
 292 =head1 TODO
 293
 294 Make some sort of autodispatch so that you don't have to explicitly
 295 specify the MARC::File::X subclass, sort of like how DBI knows to
 296 use DBD::Oracle or DBD::Mysql.
 297
 298 =head1 LICENSE
 299
 300 This code may be distributed under the same terms as Perl itself.
 301
 302 Please note that these modules are not products of or supported by the
 303 employers of the various contributors to the code.
 304
 305 =head1 AUTHOR
 306
 307 Andy Lester, E<lt>marc@petdance.comE<gt> or E<lt>alester@flr.follett.comE<gt>
 308
 309 =cut
 310