allow encoding to be passed to as_xml
[Evergreen.git] / 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;