File Coverage

blib/lib/PICA/Data.pm

Criterion	Covered	Total	%
statement	25	91	27.4
branch	0	48	0.0
condition	0	9	0.0
subroutine	9	14	64.2
pod			n/a
total	34	162	20.9

package PICA::Data;
use strict;
use warnings;

our $VERSION = '0.33';

use Exporter 'import';
our @EXPORT_OK = qw(pica_parser pica_writer pica_path pica_xml_struct
    pica_values pica_value pica_fields pica_holdings pica_items);
our %EXPORT_TAGS = (all => [@EXPORT_OK]);

our $ILN_PATH = PICA::Path->new('101@a');
our $EPN_PATH = PICA::Path->new('203@/**0');

use Carp qw(croak);
use Scalar::Util qw(reftype blessed);
use List::Util qw(first);
use IO::Handle;
use PICA::Path;

sub pica_values {
    my ($record, $path) = @_;

    $path = eval { PICA::Path->new($path) } unless ref $path;
    return unless ref $path;

    return $path->record_subfields($record);
}

sub pica_fields {
    my ($record, $path) = @_;

    $path = eval { PICA::Path->new($path) } unless ref $path;
    return [] unless defined $path;

    return $path->record_fields($record);
}

sub pica_value {
    my ($record, $path) = @_;

    $record = $record->{record} if reftype $record eq 'HASH';
    $path = eval { PICA::Path->new($path) } unless ref $path;
    return unless defined $path;

    foreach my $field (@$record) {
        next unless $path->match_field($field);
        my @values = $path->match_subfields($field);
        return $values[0] if @values;
    }

    return;
}

sub pica_items {
    my ($record) = @_;

    my $blessed = blessed($record);
    $record = $record->{record} if reftype $record eq 'HASH';
    my (@items, $current, $occurrence);

    foreach my $field (@$record) {
        if ($field->[0] =~ /^2/) {

            if ( ($occurrence // '') ne $field->[1] ) {
                if ($current) {
                    push @items, $current;
                    $current = undef;
                }
                $occurrence = $field->[1];
            }

            $current //= { record => [] };

            push @{$current->{record}}, [ @$field ];
            if ($field->[0] eq '203@') {
                ($current->{_id}) = $EPN_PATH->match_subfields($field);
            }
        } elsif ($current) {
            push @items, $current;
            $current    = undef;
            $occurrence = undef;
        }
    }

    push @items, $current if $current;

    if ($blessed) {
        bless $_, $blessed for @items;
    }

    return \@items;
}

sub pica_holdings {
    my ($record) = @_;

    my $blessed = blessed($record);
    $record = $record->{record} if reftype $record eq 'HASH';
    my (@holdings, $field_buffer, $iln);

    foreach my $field (@$record) {
        my $tag = substr $field->[0], 0, 1;
        if ($tag eq '0') {
            next;
        } elsif ($tag eq '1') {
            if ($field->[0] eq '101@') {
                my ($id) = $ILN_PATH->match_subfields($field);
                if ( defined $iln && ($id // '') ne $iln ) {
                    push @holdings, { record => $field_buffer, _id => $iln };
                }
                $field_buffer = [ [@$field] ];
                $iln = $id;
                next;
            }
        }
        push @$field_buffer, [@$field];
    }

    if (@$field_buffer) {
        push @holdings, { record => $field_buffer, _id => $iln };
    }

    if ($blessed) {
        bless $_, $blessed for @holdings;
    }

    return \@holdings;
}

*values   = *pica_values;
*value    = *pica_value;
*fields   = *pica_fields;
*holdings = *pica_holdings;
*items    = *pica_items;

use PICA::Parser::XML;
use PICA::Parser::Plus;
use PICA::Parser::Plain;
use PICA::Parser::Binary;
use PICA::Writer::XML;
use PICA::Writer::Plus;
use PICA::Writer::Plain;
use PICA::Writer::Binary;
use PICA::Writer::PPXML;

sub pica_parser {
    _pica_module('PICA::Parser', @_)
}

sub pica_writer {
    _pica_module('PICA::Writer', @_)
}

sub pica_path {
    PICA::Path->new(@_)
}

sub _pica_module {
    my $base = shift;
    my $type = lc(shift) // '';

    if ( $type =~ /^(pica)?plus$/ ) {
        "${base}::Plus"->new(@_);
    } elsif ( $type eq 'binary' ) {
        "${base}::Binary"->new(@_);
    } elsif ( $type =~ /^(pica)?plain$/ ) {
        "${base}::Plain"->new(@_);
    } elsif ( $type =~ /^(pica)?xml$/ ) {
        "${base}::XML"->new(@_);
    } elsif ( $type =~ /^(pica)?ppxml$/ ) {
        "${base}::PPXML"->new(@_);
    } else {
        croak "unknown PICA parser type: $type";
    }
}

sub write {
    my $pica = shift;
    my $writer = $_[0];
    unless (blessed $writer) {
        $writer = pica_writer(@_ ? @_ : 'plain');
    }
    $writer->write($pica);
}

sub string {
    my ($pica, $type, %options) = @_;
    my $string = "";
    $type ||= 'plain';
    $options{fh} = \$string;
    $options{start} //= 0;
    pica_writer( $type => %options )->write($pica);
    return $string;
}

sub pica_xml_struct {
    my ($xml, %options) = @_;
    my $record;

    foreach my $f (@{$xml->[2]}) {
        next unless $f->[0] eq 'datafield';
        push @$record, [
            map ( { $f->[1]->{$_} } qw(tag occurrence) ),
            map ( { $_->[1]->{code} => $_->[2]->[0] } @{$f->[2]} )
        ]
    }

    my ($id) = map { $_->[-1] } grep { $_->[0] =~ '003@' } @$record;
    $record = { _id => $id, record => $record };
    bless $record, 'PICA::Data' if !!$options{bless};
    return $record;
}

1;
__END__