MARC::File::XML - Work with MARC data encoded as XML

    ## Loading with USE options
    use MARC::File::XML ( BinaryEncoding => 'utf8', RecordFormat => 'UNIMARC' );

    ## Setting the record format without USE options
    MARC::File::XML->default_record_format('USMARC');

    ## reading with MARC::Batch
    my $batch = MARC::Batch->new( 'XML', $filename );
    my $record = $batch->next();

    ## or reading with MARC::File::XML explicitly
    my $file = MARC::File::XML->in( $filename );
    my $record = $file->next();

    ## serialize a single MARC::Record object as XML
    print $record->as_xml();

    ## write a bunch of records to a file
    my $file = MARC::File::XML->out( 'myfile.xml' );
    $file->write( $record1 );
    $file->write( $record2 );
    $file->write( $record3 );
    $file->close();

    ## instead of writing to disk, get the xml directly 
    my $xml = join( "\n", 
        MARC::File::XML::header(),
        MARC::File::XML::record( $record1 ),
        MARC::File::XML::record( $record2 ),
        MARC::File::XML::footer()
    );

    MARC::File::XML->default_record_format('UNIMARC');

    print $record->as_xml([$format]);

    print $record->as_xml_record('UNIMARC');

    my $record = MARC::Record->new_from_xml( $xml, $encoding, $format );

    my $file = MARC::File::XML->out( $filename [, $encoding] );

    my $file = MARC::File::XML->out( $filename );
    $file->write( $record1 );
    $file->write( $record2 );

    $xml = join( "\n",
        MARC::File::XML::header(),
        MARC::File::XML::record( $record1 ),
        MARC::File::XML::record( $record2 ),
        MARC::File::XML::record( $record3 ),
        MARC::File::XML::footer()
    );

package MARC::File::XML;

use warnings;
use strict;
use vars qw( $VERSION %_load_args );
use base qw( MARC::File );
use MARC::Record;
use MARC::Field;
use MARC::File::SAX;
use XML::SAX qw(Namespaces Validation);

use MARC::Charset qw( marc8_to_utf8 utf8_to_marc8 );
use IO::File;
use Carp qw( croak );
use Encode ();

$VERSION = '0.93';

my $factory = XML::SAX::ParserFactory->new();
$factory->require_feature(Namespaces);

sub import {
    my $class = shift;
    %_load_args = @_;
    $_load_args{ DefaultEncoding } ||= 'UTF-8';
    $_load_args{ RecordFormat } ||= 'USMARC';
}

sub default_record_format {
    my $self = shift;
    my $format = shift;

    $_load_args{RecordFormat} = $format if ($format);

    return $_load_args{RecordFormat};
}

sub MARC::Record::as_xml {
    my $record = shift;
    my $format = shift || $_load_args{RecordFormat};
    return(  MARC::File::XML::encode( $record, $format ) );
}

sub MARC::Record::as_xml_record {
    my $record = shift;
    my $format = shift || $_load_args{RecordFormat};
    return(  MARC::File::XML::encode( $record, $format, 1 ) );
}

sub MARC::Record::new_from_xml {
    my $xml = shift;
    ## to allow calling as MARC::Record::new_from_xml()
    ## or MARC::Record->new_from_xml()
    $xml = shift if ( ref($xml) || ($xml eq "MARC::Record") );

    my $enc = shift || $_load_args{BinaryEncoding};
    my $format = shift || $_load_args{RecordFormat};
    return( MARC::File::XML::decode( $xml, $enc, $format ) );
}

sub out {
    my ( $class, $filename, $enc ) = @_;
    my $fh = IO::File->new( ">$filename" ) or croak( $! );
    $enc ||= $_load_args{DefaultEncoding};

    if ($enc =~ /^utf-?8$/oi) {
        $fh->binmode(':utf8');
    } else {
        $fh->binmode(':raw');
    }

    my %self = ( 
        filename    => $filename,
        fh          => $fh, 
        header      => 0,
        encoding    => $enc
    );
    return( bless \%self, ref( $class ) || $class );
}

sub write {
    my ( $self, $record, $enc ) = @_;
    if ( ! $self->{ fh } ) { 
        croak( "MARC::File::XML object not open for writing" );
    }
    if ( ! $record ) { 
        croak( "must pass write() a MARC::Record object" );
    }
    ## print the XML header if we haven't already
    if ( ! $self->{ header } ) { 
        $enc ||= $self->{ encoding } || $_load_args{DefaultEncoding};
        $self->{ fh }->print( header( $enc ) );
        $self->{ header } = 1;
    } 
    ## print out the record
    $self->{ fh }->print( record( $record ) ) || croak( $! );
    return( 1 );
}

sub close {
    my $self = shift;
    if ( $self->{ fh } ) {
        $self->{ fh }->print( footer() ) if $self->{ header };
        $self->{ fh } = undef;
        $self->{ filename } = undef;
        $self->{ header } = undef;
    }
    return( 1 );
}

## makes sure that the XML file is closed off

sub DESTROY {
    shift->close();
}

sub header {
    my $enc = shift; 
    $enc = shift if ( $enc && (ref($enc) || ($enc eq "MARC::File::XML")) );
    $enc ||= 'UTF-8';
    return( <<MARC_XML_HEADER );
<?xml version="1.0" encoding="$enc"?>
<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">
MARC_XML_HEADER
}

sub footer {
    return( "</collection>" );
}

sub record {
    my $record = shift;
    my $format = shift;
    my $include_full_record_header = shift;
    my $enc = shift;

    $format ||= $_load_args{RecordFormat};

    my $_transcode = 0;
    my $ldr = $record->leader;
    my $original_encoding = substr($ldr,9,1);

    # Does the record think it is already Unicode?
    if ($original_encoding ne 'a' && lc($format) !~ /^unimarc/o) {
        # If not, we'll make it so
        $_transcode++;
        substr($ldr,9,1,'a');
        $record->leader( $ldr );
    }

    my @xml = ();

    if ($include_full_record_header) {
        push @xml, <<HEADER
<?xml version="1.0" encoding="$enc"?>
<record
    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">
HEADER

    } else {
        push( @xml, "<record>" );
    }

    push( @xml, "  <leader>" . escape( $record->leader ) . "</leader>" );

    foreach my $field ( $record->fields() ) {
        my ($tag) = escape( $field->tag() );
        if ( $field->is_control_field() ) { 
            my $data = $field->data;
            push( @xml, qq(  <controlfield tag="$tag">) .
                    escape( ($_transcode ? marc8_to_utf8($data) : $data) ). qq(</controlfield>) );
        } else {
            my ($i1) = escape( $field->indicator( 1 ) );
            my ($i2) = escape( $field->indicator( 2 ) );
            push( @xml, qq(  <datafield tag="$tag" ind1="$i1" ind2="$i2">) );
            foreach my $subfield ( $field->subfields() ) { 
                my ( $code, $data ) = ( escape( $$subfield[0] ), $$subfield[1] );
                push( @xml, qq(    <subfield code="$code">).
                        escape( ($_transcode ? marc8_to_utf8($data) : $data) ).qq(</subfield>) );
            }
            push( @xml, "  </datafield>" );
        }
    }
    push( @xml, "</record>\n" );

    if ($_transcode) {
        substr($ldr,9,1,$original_encoding);
        $record->leader( $ldr );
    }

    return( join( "\n", @xml ) );
}

my %ESCAPES = (
    '&'     => '&amp;',
    '<'     => '&lt;',
    '>'     => '&gt;',
);
my $ESCAPE_REGEX = 
    eval 'qr/' . 
    join( '|', map { $_ = "\Q$_\E" } keys %ESCAPES ) .
    '/;'
    ;

sub escape {
    my $string = shift;
    return '' if ! defined $string or $string eq '';
    $string =~ s/($ESCAPE_REGEX)/$ESCAPES{$1}/oge;
    return( $string );
}

sub _next {
    my $self = shift;
    my $fh = $self->{ fh };

    ## return undef at the end of the file
    return if eof($fh);

    ## get a chunk of xml for a record
    local $/ = 'record>';
    my $xml = <$fh>;

    ## do we have enough?
    $xml .= <$fh> if $xml !~ m!</([^:]+:){0,1}record>$!;
    ## trim stuff before the start record element 
    $xml =~ s/.*?<(([^:]+:){0,1})record.*?>/<$1record>/s;

    ## return undef if there isn't a good chunk of xml
    return if ( $xml !~ m|<(([^:]+:){0,1})record>.*</\1record>|s );

    ## if we have a namespace prefix, restore the declaration
    if ($xml =~ /<([^:]+:)record>/) {
        $xml =~ s!<([^:]+):record>!<$1:record xmlns:$1="http://www.loc.gov/MARC21/slim">!;
    }

    ## return the chunk of xml
    return( $xml );
}

sub decode { 
    my $text; 
    my $location = '';
    my $self = shift;

    ## see MARC::File::USMARC::decode for explanation of what's going on
    ## here
    if ( ref($self) =~ /^MARC::File/ ) {
        $location = 'in record '.$self->{recnum};
        $text = shift;
    } else {
        $location = 'in record 1';
        $text = $self=~/MARC::File/ ? shift : $self;
    }

    my $enc = shift || $_load_args{BinaryEncoding};
    my $format = shift || $_load_args{RecordFormat};

    my $handler = MARC::File::SAX->new();
    my $parser = $factory->parser(
        Handler => $handler, 
        ProtocolEncoding => $_load_args{DefaultEncoding}
    );
    $parser->{ Handler }{ toMARC8 } = decideMARC8Binary($format,$enc);

    $parser->parse_string( $text );

    return( $handler->record() );
}

sub decideMARC8Binary {
    my $format = shift;
    my $enc = shift;

    return 0 if (defined($format) && lc($format) =~ /^unimarc/o);
    return 0 if (defined($enc) && lc($enc) =~ /^utf-?8/o);
    return 1;
}

sub encode {
    my $record = shift;
    my $format = shift || $_load_args{RecordFormat};
    my $without_collection_header = shift;
    my $enc = shift || $_load_args{DefaultEncoding};

    if (lc($format) =~ /^unimarc/o) {
        $enc = _unimarc_encoding( $format => $record );
    }

    my @xml = ();
    push( @xml, header( $enc ) ) unless ($without_collection_header);
    # verbose, but naming the header output flags this way to avoid
    # the potential confusion identified in CPAN bug #34082
    # http://rt.cpan.org/Public/Bug/Display.html?id=34082
    my $include_full_record_header = ($without_collection_header) ? 1 : 0;
    push( @xml, record( $record, $format, $include_full_record_header, $enc ) );
    push( @xml, footer() ) unless ($without_collection_header);

    return( join( "\n", @xml ) );
}

sub _unimarc_encoding {
    my $f = shift;
    my $r = shift;

    my $pos = 26;
    $pos = 13 if (lc($f) eq 'unimarcauth');

    my $enc = substr( $r->subfield(100 => 'a'), $pos, 2 );

    if ($enc eq '01' || $enc eq '03') {
        return 'ISO-8859-1';
    } elsif ($enc eq '50') {
        return 'UTF-8';
    } else {
        die "Unsupported UNIMARC character encoding [$enc] for XML output for $f; 100\$a -> " . $r->subfield(100 => 'a');
    }
}

1;