File Coverage

blib/lib/PICA/XMLParser.pm

Criterion	Covered	Total	%
statement	42	142	29.5
branch	11	84	13.1
condition	3	28	10.7
subroutine	10	19	52.6
pod	11	11	100.0
total	77	284	27.1

package PICA::XMLParser;
{
  $PICA::XMLParser::VERSION = '0.585';
}
#ABSTRACT: Parse PICA+ XML
use strict;

use base qw(XML::SAX::Base Exporter);
use Carp qw(croak);
our @EXPORT_OK = qw(parsefile parsedata);

require PICA::Field;


use PICA::Field;
use PICA::Record;
use XML::SAX::ParserFactory 1.01;
use Carp qw(croak);


sub new {
    my ($class, %params) = @_;
    $class = ref $class || $class;

    my $self = {
        record => {},
        fields => {},

        read_records => [],

        tag => "",
        occurrence => "",
        subfield_code => "",
        subfield_value => "",

        limit  => ($params{Limit} || 0) * 1,
        offset  => ($params{Offset} || 0) * 1,

        # Handlers
        field_handler  => $params{Field} ? $params{Field} : undef,
        record_handler => $params{Record} ? $params{Record} : undef,
        collection_handler => $params{Collection} ? $params{Collection} : undef,

        proceed => $params{Proceed} ? $params{Proceed} : 0,

        read_counter => 0,
    };
    bless $self, $class;
    return $self;
}


sub parsedata {
    my $self = shift;

    if ( ref($self) eq "PICA::XMLParser" ) { # called as a method
      my $data = shift;

      if ( ! $self->{proceed} ) {
          $self->{read_counter} = 0;
          $self->{read_records} = [];
      }

      if( UNIVERSAL::isa( $data, 'PICA::Record' ) ) {
        foreach ( $data->fields ) {
            # TODO: we could improve performance here
            # TODO: merge this into PICA::Parser
            $self->_parseline( $_->string );
        }
      }

      my $parser = XML::SAX::ParserFactory->new(
        RequiredFeatures => { 'http://xml.org/sax/features/namespaces' => 1 }
      )->parser( Handler => $self );

      if (ref($data) eq 'ARRAY') {
          $data = join('',@{$data})
      } elsif (ref($data) eq 'CODE') {
          my $code = $data;
          $data = "";
          my $chunk = &$code();
          while(defined $chunk) {
              $data .= $chunk;
              $chunk = &$code();
          }
      }

      $parser->parse_string($data);

      $self;

    } else { # called as function
        my $data = ($self eq 'PICA::XMLParser') ? shift : $self;
        croak("Missing argument to parsedata") unless defined $data;
        PICA::XMLParser->new( @_ )->parsedata( $data );
    }
}


sub parsefile {
    my $self = shift;

    if ( ref($self) eq "PICA::XMLParser" ) { # called as a method
        my $file = shift;

        if ( ! $self->{proceed} ) {
            $self->{read_counter} = 0;
            $self->{read_records} = [];
        }

        $self->{filename} = $file if ref(\$file) eq 'SCALAR';

        my $parser = XML::SAX::ParserFactory->new(
          RequiredFeatures => { 'http://xml.org/sax/features/namespaces' => 1 }
        )->parser( Handler => $self );

        if (ref($file) eq 'GLOB' or eval { $file->isa("IO::Handle") }) {
            $parser->parse_file($file);
        } else {
            $parser->parse_uri($file);
        }

        $self;

    } else { # called as a function
        my $file = ($self eq 'PICA::XMLParser') ? shift : $self;
        croak("Missing argument to parsefile") unless defined $file;
        PICA::XMLParser->new( @_ )->parsefile( $file );
    }
}


sub records {
   my $self = shift;
   return @{ $self->{read_records} };
}


sub counter {
   my $self = shift;
   return $self->{read_counter};
}


sub finished {
    my $self = shift;
    return $self->{limit} && $self->counter() >= $self->{limit};
}


sub start_document {
    my ($self, $doc) = @_;

    $self->{subfield_code} = "";
    $self->{tag} = "";
    $self->{occurrence} = "";
    $self->{record} = ();
}


sub end_document {
    my ($self, $doc) = @_;
}


sub start_element {
    my ($self, $el) = @_;
    my $name = $el->{LocalName};
    my %attrs = map { $_->{LocalName} => $_->{Value} } values %{ $el->{Attributes} };

    my $ns = $el->{NamespaceURI};
    $name = '{'.$ns.'}:'.$name if $ns and $ns ne $PICA::Record::XMLNAMESPACE;

    if ($name eq "subfield") {

        my $code = $attrs{"code"};
        if (defined $code) {
            if ($code =~ $PICA::Field::SUBFIELD_CODE_REGEXP) {
                $self->{subfield_code} = $code;
                $self->{subfield_value} = "";
            } else {
               croak "Invalid subfield code '$code'"; # . $self->_getPosition($parser));
            }
        } else {
            croak "Missing attribute 'code'"; # . $self->_getPosition($parser));
        }
    } elsif ($name eq "field" or $name eq "datafield") {
        my $tag = $attrs{tag};
        if (defined $tag) {
            if (!($tag =~ $PICA::Field::FIELD_TAG_REGEXP)) {
                croak "Invalid field tag '$tag'"; # . $self->_getPosition($parser));
            }
        } else {
            croak "Missing attribute 'tag'"; # . $self->_getPosition($parser));
        }
        my $occurrence = $attrs{occurrence};
        if ($occurrence && !($occurrence =~ $PICA::Field::FIELD_OCCURRENCE_REGEXP)) {
            croak "Invalid occurrence '$occurrence'"; # . $self->_getPosition($parser));
        }

        $self->{tag} = $tag;
        $self->{occurrence} = $occurrence ? $occurrence : undef;
        $self->{subfields} = ();

    } elsif ($name eq "record") {
        $self->{fields} = [];
    } elsif ($name eq "collection") {
        $self->{records} = [];
    } else {
        croak "Unknown element '$name'"; # . $self->_getPosition($parser));
    }
}


sub end_element {
    my ($self, $el) = @_;
    my $name = $el->{LocalName};
    # TODO: $el->{NamespaceURI}

    if ($name eq "subfield") {
        push (@{$self->{subfields}}, ($self->{subfield_code}, $self->{subfield_value}));
    } elsif ($name eq "field" or $name eq "datafield") {

#        return if $self->{tag} eq ''; # ignore

#        croak ("Field " . $self->{tag} . " is empty" . $self->_getPosition($parser)) unless $self->{subfields};
        croak ("Field " . $self->{tag} . " is empty") unless $self->{subfields};

        my $field = bless {
            _tag => $self->{tag},
            _occurrence => $self->{occurrence},
            _subfields => [@{$self->{subfields}}]
        }, 'PICA::Field'; # TODO: use constructor instead

        if ($self->{field_handler}) {
            $field = $self->{field_handler}( $field );
        }

        if (UNIVERSAL::isa($field,"PICA::Field")) {
            push (@{$self->{fields}}, $field);
        }
    } elsif ($name eq "record") {
        return if $self->finished();

        $self->{read_counter}++;

        if (! ($self->{offset} && $self->{read_counter} < $self->{offset}) ) {
            my $record =  PICA::Record->new( @{$self->{fields}} );

            if ($self->{record_handler}) {
                $record = $self->{record_handler}( $record );
            }
            if ($record) {
                push @{ $self->{read_records} }, $record;
            }
        }

    } elsif ($name eq "collection") {
        $self->{collection_handler}( $self->records() )
            if $self->{collection_handler};
    } else {
        croak("Unknown element '$name'"); # . $self->_getPosition($parser));
    }
}


sub characters {
    my ($self, $string) = @_;
    ($string) = values %$string;

    # all character data outside of subfield content will be ignored without warning
    if (defined $self->{subfield_code}) {
        $string =~ s/[\n\r]+/ /g; # remove newlines
        $self->{subfield_value} .= $string;
    }
}


sub _getPosition {
    my ($self, $parser) = @_;

    if ($self->{filename}) {
        return " in " . $self->{filename} . ", line " . $parser->current_line();
    } else {
        return " in line " . $parser->current_line();
    }
}

1;

__END__