Open-ILS/src/perlmods/MARC/File/XML.pm

   1 package MARC::File::XML;
   2
   3 use warnings;
   4 use strict;
   5 use base qw( MARC::File );
   6 use MARC::Record;
   7 use MARC::Field;
   8 use MARC::File::SAX;
   9 use MARC::Charset;
  10 use IO::File;
  11 use Carp qw( croak );
  12 use Encode ();
  13
  14 our $VERSION = '0.66';
  15
  16 my $handler = MARC::File::SAX->new();
  17 my $parser = XML::SAX::ParserFactory->parser( Handler => $handler );
  18 my $charset = MARC::Charset->new();
  19
  20
  21 =head1 NAME
  22
  23 MARC::File::XML - Work with MARC data encoded as XML
  24
  25 =head1 SYNOPSIS
  26
  27     ## reading with MARC::Batch
  28     my $batch = MARC::Batch->new( 'XML', $filename );
  29     my $record = $batch->next();
  30
  31     ## or reading with MARC::File::XML explicitly
  32     my $file = MARC::File::XML->in( $filename );
  33     my $record = $file->next();
  34
  35     ## serialize a single MARC::Record object as XML
  36     print $record->as_xml();
  37
  38     ## write a bunch of records to a file
  39     my $file = MARC::File::XML->out( 'myfile.xml' );
  40     $file->write( $record1 );
  41     $file->write( $record2 );
  42     $file->write( $record3 );
  43     $file->close();
  44
  45     ## instead of writing to disk, get the xml directly
  46     my $xml = join( "\n",
  47         MARC::File::XML::header(),
  48         MARC::File::XML::record( $record1 ),
  49         MARC::File::XML::record( $record2 ),
  50         MARC::File::XML::footer()
  51     );
  52
  53 =head1 DESCRIPTION
  54
  55 The MARC-XML distribution is an extension to the MARC-Record distribution for
  56 working with MARC21 data that is encoded as XML. The XML encoding used is the
  57 MARC21slim schema supplied by the Library of Congress. More information may
  58 be obtained here: http://www.loc.gov/standards/marcxml/
  59
  60 You must have MARC::Record installed to use MARC::File::XML. In fact
  61 once you install the MARC-XML distribution you will most likely not use it
  62 directly, but will have an additional file format available to you when you
  63 use MARC::Batch.
  64
  65 This version of MARC-XML supersedes an the versions ending with 0.25 which
  66 were used with the MARC.pm framework. MARC-XML now uses MARC::Record
  67 exclusively.
  68
  69 If you have any questions or would like to contribute to this module please
  70 sign on to the perl4lib list. More information about perl4lib is available
  71 at L<http://perl4lib.perl.org>.
  72
  73 =head1 METHODS
  74
  75 When you use MARC::File::XML your MARC::Record objects will have two new
  76 additional methods available to them:
  77
  78 =head2 as_xml()
  79
  80 Returns a MARC::Record object serialized in XML.
  81
  82     print $record->as_xml();
  83
  84 =cut
  85
  86 sub MARC::Record::as_xml {
  87     my $record = shift;
  88     my $enc = shift;
  89     return(  MARC::File::XML::encode( $record, $enc ) );
  90 }
  91
  92 =head2 new_from_xml()
  93
  94 If you have a chunk of XML and you want a record object for it you can use
  95 this method to generate a MARC::Record object.
  96
  97     my $record = MARC::Record->new_from_xml( $xml );
  98
  99 Note: only works for single record XML chunks.
 100
 101 =cut
 102
 103 sub MARC::Record::new_from_xml {
 104     my $xml = shift;
 105     ## to allow calling as MARC::Record::new_from_xml()
 106     ## or MARC::Record->new_from_xml()
 107     $xml = shift if ( ref($xml) || ($xml eq "MARC::Record") );
 108     return( MARC::File::XML::decode( $xml ) );
 109 }
 110
 111 =pod
 112
 113 If you want to write records as XML to a file you can use out() with write()
 114 to serialize more than one record as XML.
 115
 116 =head2 out()
 117
 118 A constructor for creating a MARC::File::XML object that can write XML to a
 119 file. You must pass in the name of a file to write XML to.
 120
 121     my $file = MARC::XML::File->out( $filename );
 122
 123 =cut
 124
 125 sub out {
 126     my ( $class, $filename ) = @_;
 127     my $fh = IO::File->new( ">$filename" ) or croak( $! );
 128     my %self = (
 129         filename    => $filename,
 130         fh          => $fh,
 131         header      => 0
 132     );
 133     return( bless \%self, ref( $class ) || $class );
 134 }
 135
 136 =head2 write()
 137
 138 Used in tandem with out() to write records to a file.
 139
 140     my $file = MARC::File::XML->out( $filename );
 141     $file->write( $record1 );
 142     $file->write( $record2 );
 143
 144 =cut
 145
 146 sub write {
 147     my ( $self, $record ) = @_;
 148     if ( ! $self->{ fh } ) {
 149         croak( "MARC::File::XML object not open for writing" );
 150     }
 151     if ( ! $record ) {
 152         croak( "must pass write() a MARC::Record object" );
 153     }
 154     ## print the XML header if we haven't already
 155     if ( ! $self->{ header } ) {
 156         $self->{ fh }->print( header() );
 157         $self->{ header } = 1;
 158     }
 159     ## print out the record
 160     $self->{ fh }->print( record( $record ) ) || croak( $! );
 161     return( 1 );
 162 }
 163
 164 =head2 close()
 165
 166 When writing records to disk the filehandle is automatically closed when you
 167 the MARC::File::XML object goes out of scope. If you want to close it explicitly
 168 use the close() method.
 169
 170 =cut
 171
 172 sub close {
 173     return( 1 );
 174     my $self = shift;
 175     if ( $self->{ fh } ) {
 176         $self->{ fh }->print( footer() ) if $self->{ header };
 177         $self->{ fh } = undef;
 178         $self->{ filename } = undef;
 179         $self->{ header } = undef;
 180     }
 181     return( 1 );
 182 }
 183
 184 ## makes sure that the XML file is closed off
 185
 186 sub DESTROY {
 187     shift->close();
 188 }
 189
 190 =pod
 191
 192 If you want to generate batches of records as XML, but don't want to write to
 193 disk you'll have to use header(), record() and footer() to generate the
 194 different portions.
 195
 196     $xml = join( "\n",
 197         MARC::File::XML::header(),
 198         MARC::File::XML::record( $record1 ),
 199         MARC::File::XML::record( $record2 ),
 200         MARC::File::XML::record( $record3 ),
 201         MARC::File::XML::footer()
 202     );
 203
 204 =head2 header()
 205
 206 Returns a string of XML to use as the header to your XML file.
 207
 208 This method takes an optional $encoding parameter to set the output encoding
 209 to something other than 'UTF-8'.  This is meant mainly to support slightly
 210 broken records that are in ISO-8859-1 (ANSI) format with 8-bit characters.
 211
 212 =cut
 213
 214 sub header {
 215     my $encoding = shift || 'UTF-8';
 216     return( <<MARC_XML_HEADER );
 217 <?xml version="1.0" encoding="$encoding"?>
 218 <collection xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xsi:schemaLocation="http://www.loc.gov/MARC21/slim http://www.loc.gov/standards/marcxml/schema/MARC21slim.xsd" xmlns="http://www.loc.gov/MARC21/slim">
 219 MARC_XML_HEADER
 220 }
 221
 222 =head2 footer()
 223
 224 Returns a string of XML to use at the end of your XML file.
 225
 226 =cut
 227
 228 sub footer {
 229     return( "</collection>" );
 230 }
 231
 232 =head2 record()
 233
 234 Returns a chunk of XML suitable for placement between the header and the footer.
 235
 236 =cut
 237
 238 sub _perhaps_encode {
 239         my $data = shift;
 240         my $done = shift;
 241         $data = Encode::encode('utf8',$charset->to_utf8($data)) unless ($done);
 242         return $data;
 243 }
 244
 245 sub record {
 246     my $record = shift;
 247     my $_is_unicode = shift;
 248     my @xml = ();
 249     push( @xml, "<record>" );
 250     push( @xml, "  <leader>" . escape( _perhaps_encode($record->leader(), $_is_unicode)) . "</leader>" );
 251     foreach my $field ( $record->fields() ) {
 252         my $tag = $field->tag();
 253         if ( $field->is_control_field() ) {
 254             my $data = $field->data;
 255             push( @xml, qq(  <controlfield tag="$tag">) .
 256                 escape( _perhaps_encode($data, $_is_unicode) ). qq(</controlfield>) );
 257         } else {
 258             my $i1 = $field->indicator( 1 );
 259             my $i2 = $field->indicator( 2 );
 260             push( @xml, qq(  <datafield tag="$tag" ind1="$i1" ind2="$i2">) );
 261             foreach my $subfield ( $field->subfields() ) {
 262                 my ( $code, $data ) = @$subfield;
 263                 push( @xml, qq(    <subfield code="$code">).
 264                     escape( _perhaps_encode($data, $_is_unicode) ).qq(</subfield>) );
 265             }
 266             push( @xml, "  </datafield>" );
 267         }
 268     }
 269     push( @xml, "</record>\n" );
 270     return( join( "\n", @xml ) );
 271 }
 272
 273 my %ESCAPES = (
 274     '&'     => '&amp;',
 275     '<'     => '&lt;',
 276     '>'     => '&gt;',
 277 );
 278 my $ESCAPE_REGEX =
 279     eval 'qr/' .
 280     join( '|', map { $_ = "\Q$_\E" } keys %ESCAPES ) .
 281     '/;'
 282     ;
 283
 284 sub escape {
 285     my $string = shift;
 286     $string =~ s/($ESCAPE_REGEX)/$ESCAPES{$1}/oge;
 287     return( $string );
 288 }
 289
 290 sub _next {
 291     my $self = shift;
 292     my $fh = $self->{ fh };
 293
 294     ## return undef at the end of the file
 295     return if eof($fh);
 296
 297     ## get a chunk of xml for a record
 298     local $/ = '</record>';
 299     my $xml = <$fh>;
 300
 301     ## trim stuff before the start record element
 302     $xml =~ s/.*<record.*?>/<record>/s;
 303
 304     ## return undef if there isn't a good chunk of xml
 305     return if ( $xml !~ m|<record>.*</record>|s );
 306
 307     ## return the chunk of xml
 308     return( $xml );
 309 }
 310
 311 =head2 decode()
 312
 313 You probably don't ever want to call this method directly. If you do
 314 you should pass in a chunk of XML as the argument.
 315
 316 It is normally invoked by a call to next(), see L<MARC::Batch> or L<MARC::File>.
 317
 318 =cut
 319
 320 sub decode {
 321
 322     my $text;
 323     my $location = '';
 324     my $self = shift;
 325
 326     ## see MARC::File::USMARC::decode for explanation of what's going on
 327     ## here
 328     if ( ref($self) =~ /^MARC::File/ ) {
 329         $location = 'in record '.$self->{recnum};
 330         $text = shift;
 331     } else {
 332         $location = 'in record 1';
 333         $text = $self=~/MARC::File/ ? shift : $self;
 334     }
 335
 336     $parser->{ tagStack } = [];
 337     $parser->{ subfields } = [];
 338     $parser->{ Handler }{ record } = MARC::Record->new();
 339     $parser->parse_string( $text );
 340
 341     return( $parser->{ Handler }{ record } );
 342
 343 }
 344
 345 =head2 encode([$encoding])
 346
 347 You probably want to use the as_marc() method on your MARC::Record object
 348 instead of calling this directly. But if you want to you just need to
 349 pass in the MARC::Record object you wish to encode as XML, and you will be
 350 returned the XML as a scalar.
 351
 352 This method takes an optional $encoding parameter to set the output encoding
 353 to something other than 'UTF-8'.  This is meant mainly to support slightly
 354 broken records that are in ISO-8859-1 (ANSI) format with 8-bit characters.
 355
 356 =cut
 357
 358 sub encode {
 359     my $record = shift;
 360     my $encoding = shift;
 361
 362     my $_is_unicode = 0;
 363     my $ldr = $record->leader;
 364     my $needed_charset;
 365
 366     if (defined $encoding) {
 367         # Are we forcing an alternate encoding?  Then leave it alone.
 368
 369     } elsif (substr($ldr,9,1) eq 'a') {
 370         # Does the record think it is already Unicode?
 371         $_is_unicode++;
 372         if ( my ($unneeded_charset) = $record->field('066') ) {
 373                 $record->delete_field( $unneeded_charset );
 374         }
 375
 376     } else {
 377         # Not forcing an encoding, and it's NOT Unicode.  We set the leader to say
 378         # Unicode for the conversion, remove any '066' field, and put it back later.
 379         #
 380         # XXX Need to generat a '066' field here, but I don't understand how yet.
 381         substr($ldr,9,1,'a');
 382         $record->leader( $ldr );
 383         if ( ($needed_charset) = $record->field('066') ) {
 384                 $record->delete_field( $needed_charset );
 385         }
 386
 387     }
 388
 389     my @xml = ();
 390     push( @xml, header($encoding) );
 391     push( @xml, record( $record, $_is_unicode ) );
 392     push( @xml, footer() );
 393
 394     if (defined $needed_charset) {
 395         $record->insert_fields_ordered($needed_charset);
 396         substr($ldr,8,1,' ');
 397         $record->leader( $ldr );
 398     }
 399
 400     return( join( "\n", @xml ) );
 401 }
 402
 403 =head1 TODO
 404
 405 =over 4
 406
 407 =item * Support for character translation using MARC::Charset.
 408
 409 =item * Support for callback filters in decode().
 410
 411 =item * Command line utilities marc2xml, etc.
 412
 413 =back
 414
 415 =head1 SEE ALSO
 416
 417 =over 4
 418
 419 =item L<http://www.loc.gov/standards/marcxml/>
 420
 421 =item L<MARC::File::USMARC>
 422
 423 =item L<MARC::Batch>
 424
 425 =item L<MARC::Record>
 426
 427 =back
 428
 429 =head1 AUTHORS
 430
 431 =over 4
 432
 433 =item * Ed Summers <ehs@pobox.com>
 434
 435 =back
 436
 437 =cut
 438
 439 1;