File Coverage

blib/lib/PICA/Record.pm

Criterion	Covered	Total	%
statement	310	360	86.1
branch	118	158	74.6
condition	41	57	71.9
subroutine	44	49	89.8
pod	31	31	100.0
total	544	655	83.0

package PICA::Record;
{
  $PICA::Record::VERSION = '0.585';
}
#ABSTRACT: Perl module for handling PICA+ records
use strict;
use utf8;
use 5.10.0;

use base qw(Exporter);
our @EXPORT = qw(readpicarecord writepicarecord);
our @EXPORT_OK = qw(picarecord pgrep pmap);
our %EXPORT_TAGS = (all => [@EXPORT, @EXPORT_OK]);

our $XMLNAMESPACE = 'info:srw/schema/5/picaXML-v1.0';

our @CARP_NOT = qw(PICA::Field PICA::Parser);

use POSIX qw(strftime);
use PICA::Field;
use PICA::Parser;
use Scalar::Util qw(looks_like_number);
use URI::Escape;
use XML::Writer;
use Encode;
use PerlIO;
use Carp qw(croak confess);

use overload
    'bool' => sub { ! $_[0]->empty },
    '""'   => sub { $_[0]->string };

use sort 'stable';


# private method to append a field
my $append_field = sub {
    my ($self, $field) = @_;
    # confess('append_failed') unless ref($field) eq 'PICA::Field';
    if ( $field->tag eq '003@' ) {
        $self->{_ppn} = $field->sf('0');
        if ( $self->field('003@') ) {
            $self->update( '003@', $field );
            return 0;
        }
    }
    # TODO: limit occ and iln, epn
    return 0 if $field->empty;

    push(@{ $self->{_fields} }, $field);
    return 1;
};

# private method to compile and cache a regular expression
my %field_regex;
my $get_regex = sub {
    my $reg = shift;

    return $reg if ref($reg) eq 'Regexp';

    my $regex = $field_regex{ $reg };

    if (!defined $regex) {
        # Compile & stash
        $regex = qr/^$reg$/;
        $field_regex{ $reg } = $regex;
    }

    return $regex;
};



sub new {
    my $class = shift; # if $_[0] and UNIVERSAL::isa( $_[0], 'PICA::Record'
    # shift if defined $_[0] and $_[0] eq $class; # called as function

    $class = $class || ref($class); # Handle cloning
    my $self = bless {
        _fields => [],
        _ppn => undef
    }, $class;

    return $self unless @_;

    my $first = $_[0];

    if (defined $first) {

        if ($#_ == 0 and ref(\$first) eq 'SCALAR') {
            my @lines = split("\n", $first);
            my @l2 = split("\x1E", $first);
            if (@l2 > @lines) { # normalized
                @lines = @l2;
            }

            foreach my $line (@lines) {
                $line =~ s/^\x1D//;         # start of record
                next if $line =~ /^\s*$/;   # skip empty lines

                my $field = PICA::Field->parse($line);
                $append_field->( $self, $field ) if $field;
            }
        } elsif (ref($first) eq 'GLOB' or eval { $first->isa('IO::Handle') }) {
            PICA::Parser->parsefile( $first, Limit => 1, Field => sub {
                $append_field->( $self, shift );
                return;
            });
        } else {
            $self->append( @_ );
        }
    } else {
        croak('Undefined parameter in PICA::Record->new');
    }

    return $self;
} # new()


sub copy {
    my $self = shift;
    return PICA::Record->new( $self );
}


sub field {
    my $self = shift;
    my $limit = looks_like_number($_[0]) ? shift : 0;
    my @specs = @_;

    my $test = ref($specs[-1]) eq 'CODE' ? pop @specs : undef;
    @specs = (".*") if $test and not @specs;

    return unless @specs;
    my @list = ();

    for my $tag ( @specs ) {
        my $regex = $get_regex->($tag);

        for my $maybe ( $self->fields ) {
            if ( $maybe->tag() =~ $regex ) {
                local $_ = $maybe;
                if ( not $test or $test->($maybe) ) {
                    return $maybe unless wantarray;
                    push( @list, $maybe );
                    if ($limit > 0) {
                        return @list unless --$limit;
                    }
                }
            }
        }
    }

    return @list;
} # field()

# Shortcut
*f = \&field;


sub subfield {
    my $self = shift;
    my $limit = looks_like_number($_[0]) ? shift : 0;
    return unless defined $_[0];

    my @list = ();

    while (@_) {
        my $tag = shift;
        my $subfield;

        croak "Not a field or full pattern: $tag"
            unless $tag =~ /^([^\$_]{3,})([\$_]([^\$_]+))?/;
        if (defined $2) {
            ($tag, $subfield) = ($1, $3);
        } else {
            $subfield = shift;
        }

        croak("Missing subfield for $tag")
            unless defined $subfield;

        my $tag_regex = $get_regex->($tag);
        for my $f ( $self->fields ) {
            if ( $f->tag() =~ $tag_regex ) {
                my @s = $f->subfield($subfield);
                if (@s) {
                    return shift @s unless wantarray;
                    if ($limit > 0) {
                        if (scalar @s >= $limit) {
                            push @list, @s[0..($limit-1)];
                            return @list;
                        }
                        $limit -= scalar @s;
                    }
                    push( @list, @s );
                }
            }
        }
    }

    return $list[0] unless wantarray;
    return @list;
} # subfield()

# Shortcut
*sf = \&subfield;


sub values {
    my $self = shift;
    my @values = $self->subfield( @_ );
    return @values;
}


sub fields() {
    my $self = shift;
    croak("You called all_fields() but you probably want field()") if @_;
    return @{$self->{_fields}};
}


sub size {
    my $self = shift;
    return 1 * @{$self->{_fields}};
}


sub occurrence {
    my $self = shift;
    return unless $self->{_fields}->[0];
    return $self->{_fields}->[0]->occurrence;
}

sub occ {
    return shift->occurrence;
}


sub main {
    my $self = shift;
    my @fields = $self->field("0...(/..)?");

    return PICA::Record->new(@fields);
}


sub holdings {
    my ($self, $iln) = @_;

    my %holdings = ();
    my @fields = ();
    my $prevtag;
    my $curiln = '';
    my @pending;

    foreach my $f (@{$self->{_fields}}) {
        next if $f->tag =~ /^0/;

        if ($f->tag eq '101@' and defined $f->sf('a')) {
            $curiln = $f->sf('a');
            $holdings{$curiln} //= [ ];
            if (@pending) {
                push @{ $holdings{$curiln} }, @pending;
                @pending = ();
            }
            push @{ $holdings{$curiln} }, $f;
        } elsif( $curiln eq '' ) {
            push @pending, $f;
        } else {
            push @{ $holdings{$curiln} }, $f;
        }

        push @fields, $f;
        $prevtag = $f->tag;
    }

    push @{ $holdings{$curiln} }, @pending if @pending;

    if ($iln) {
        %holdings = ($iln => $holdings{$iln});
        %holdings = () unless $holdings{$iln};
    }

    foreach my $iln (keys %holdings) {
        @{$holdings{$iln}} = sort {
            my ($ta,$tb) = ($a->tag, $b->tag);
            $ta =~ s{^(2...)/(..)$}{2$2$1};
            $tb =~ s{^(2...)/(..)$}{2$2$1};
            $ta cmp $tb;
        } @{$holdings{$iln}};
    }

    my @h =  sort { ($a->iln // '0') <=> ($b->iln // '0') }
            map { PICA::Record->new( @$_ ) } CORE::values(%holdings);

    return $iln ? $h[0] : @h;
}


sub items {
  my $self = shift;

  my @copies = ();
  my @fields = ();
  my $prevocc;

  foreach my $f (@{$self->{_fields}}) {
      next unless $f->tag =~ /^[^0]/;

      if ($f->tag =~ /^1/) {
          $prevocc = undef;
          push @copies, PICA::Record->new(@fields) if (@fields);
          @fields = ();
      } else {
          next unless $f->tag =~ /^2...\/(..)/;

          if (!($prevocc && $prevocc eq $1)) {
              $prevocc = $1;
              push @copies, PICA::Record->new(@fields) if (@fields);
              @fields = ();
          }

          push @fields, $f;
      }
  }
  push @copies, PICA::Record->new(@fields) if (@fields);
  return @copies;
}


sub empty {
    my $self = shift;
    foreach my $field (@{$self->{_fields}}) {
        return 0 if !$field->empty;
    }
    return 1;
}


sub ppn {
    my $self = shift;
    if ( @_ ) {
        my $ppn = shift;
        if (defined $ppn) {
            $append_field->( $self, PICA::Field->new('003@', '0' => $ppn) )
        } else {
            $self->remove('003@');
        }
    }
    return $self->{_ppn};
}


sub epn {
    my $self = shift;
    #for(my $i=0; $i<@_; $i++) {
    #    # TODO: add EPNs
    #}
    return $self->subfield('203@/..$0');
}


sub iln {
    # TODO: set ILN with this method and check uniqueness
    my $self = shift;
    return $self->subfield('101@$a');
}


sub append {
    my $self = shift;
    # TODO: this method can be simplified by use of ->new (see appendif)

    my $c = 0;

    while (@_) {
        # Append a field (whithout creating a copy)
        while (@_ and UNIVERSAL::isa($_[0],'PICA::Field') ) {
            $c += $append_field->( $self, shift );
        }
        # Append a whole record (copy all its fields)
        while (@_ and UNIVERSAL::isa($_[0],'PICA::Record')) {
            my $record = shift;
            for my $field ( $record->fields ) {
                $c += $append_field->( $self, $field->copy );
            }
        }
        if (@_) {
            my @params = (shift); # tag
            while (@_ and defined $_[0] and length($_[0]) == 1) {
                push @params, shift; # subfield
                push @params, shift; # value
            }
            $c += $append_field->( $self, PICA::Field->new( @params ) ) if @params > 1;
        }
    }

#use Data::Dumper;
#print Dumper(\@_)."\n";
#        local $Carp::CarpLevel = 1;


    return $c;
}


sub appendif {
    my $self = shift;
    my $append = PICA::Record->new( @_ );
    for my $field ( $append->fields ) {
        $field = $field->purged();
        $append_field->( $self, $field ) if $field;
    }
    $self;
}


sub update {
    my $self = shift;
    my $tag = shift;

    croak("Not a valid tag: $tag")
        unless PICA::Field::parse_pp_tag( $tag );

    my $replace;

    return unless @_; # ignore

    if ( not defined $_[0] ) {
        $replace = shift;
    } elsif ( UNIVERSAL::isa( $_[0], 'PICA::Field' ) or ref($_[0]) eq 'CODE' ) {
        $replace = shift;
    } else {
        $replace = PICA::Field->new($tag, @_);
    }

    my $regex = $get_regex->($tag);

    for my $field ( $self->fields ) {
        if ( $field->tag() =~ $regex ) {
            my $rep = $replace;
            if ( UNIVERSAL::isa( $replace, 'CODE' ) ) {
                $rep = $rep->( $field );
                $rep = undef unless UNIVERSAL::isa( $rep, 'PICA::Field' );
            }
            if (defined $rep) {
                $self->{_ppn} = $rep->sf('0') if $rep->tag eq '003@';
                $field->replace( $rep );
            }
            return unless ref($replace) eq 'CODE';
        }
    }
}


sub remove {
    my $self = shift;
    my @specs = @_;

    return 0 if !@specs;
    my $c = 0;

    for my $tag ( @specs ) {
        my $regex = $get_regex->($tag);

        my $i=0;
        for my $maybe ( $self->fields ) {
            if ( $maybe->tag() =~ $regex ) {
                $self->{_ppn} = undef if $maybe->tag() eq '003@';
                splice( @{$self->{_fields}}, $i, 1);
                $c++;
            } else {
                $i++;
            }
        }
    } # for $tag

    return $c;
}


sub sort {
    my $self = shift;

    my $main     = $self->main;
    my @holdings = $self->holdings;

    @{$self->{_fields}} = sort { $a->tag cmp $b->tag } @{$main->{_fields}};

    foreach my $h ( @holdings ) {
        push @{$self->{_fields}}, @{$h->{_fields}};
    }

    $self;
}


sub add_headers {
    my ($self, %params) = @_;

    my $eln = $params{eln};
    croak("add_headers needs an ELN") unless defined $eln;

    my $status = $params{status};
    croak("add_headers needs status") unless defined $status;

    my @timestamp = defined $params{timestamp} ? @{$params{timestamp}} : localtime;
    # TODO: Test timestamp

    my $hdate = strftime ("$eln:%d-%m-%g", @timestamp);
    my $htime = strftime ("%H:%M:%S", @timestamp);

    # Pica3: 000K - Unicode-Kennzeichen
    $self->append( "001U", '0' => 'utf8' );

    # PICA3: 0200 - Kennung und Datum der Ersterfassung
    # http://www.gbv.de/vgm/info/mitglieder/02Verbund/01Erschliessung/02Richtlinien/01KatRicht/0200.pdf
    $self->append( "001A", '0' => $hdate );

    # PICA3: 0200 - Kennung und Datum der letzten Aenderung
    # http://www.gbv.de/vgm/info/mitglieder/02Verbund/01Erschliessung/02Richtlinien/01KatRicht/0210.pdf
    $self->append( "001B", '0' => $hdate, 't' => $htime );

    # PICA3: 0230 - Kennung und Datum der Statusaenderung
    # http://www.gbv.de/vgm/info/mitglieder/02Verbund/01Erschliessung/02Richtlinien/01KatRicht/0230.pdf
    $self->append( "001D", '0' => $hdate );

    # PCIA3: 0500 - Bibliographische Gattung und Status
    # http://www.gbv.de/vgm/info/mitglieder/02Verbund/01Erschliessung/02Richtlinien/01KatRicht/0500.pdf
    $self->append( "002@", '0' => $status );
}


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

    $args{endfield} = "\n" unless defined($args{endfield});

    my @lines = ();
    for my $field ( @{$self->{_fields}} ) {
        push( @lines, $field->string(%args) );
    }
    return join('', @lines);
}


sub normalized() {
    my $self = shift;
    my $prefix = shift;
    $prefix = "" if (!$prefix);

    my @lines = ();
    for my $field ( @{$self->{_fields}} ) {
        push( @lines, $field->normalized() );
    }

    return "\x1D\x0A" . $prefix . join( "", @lines );
}


sub xml {
    my $self = shift;
    my $writer = $_[0];
    my ($string, $sref);

    # write to a string
    if (not UNIVERSAL::isa( $writer, 'XML::Writer' )) {
        my %params = @_;
        if (not defined $params{OUTPUT}) {
            $sref = \$string;
            $params{OUTPUT} = $sref;
        }
        $writer = PICA::Writer::xmlwriter( %params );
    }

    if ( UNIVERSAL::isa( $writer, 'XML::Writer::Namespaces' ) ) {
        $writer->startTag( [$PICA::Record::XMLNAMESPACE, 'record'] );
    } else {
        $writer->startTag( 'record' );
    }
    for my $field ( @{$self->{_fields}} ) {
        $field->xml( $writer );
    }
    $writer->endTag();

    return defined $sref ? $$sref : undef;
}


sub html  {
    my $self = shift;
    my %options = @_;

    my @html = ("\n");
    for my $field ( @{$self->{_fields}} ) {
        push @html, $field->html( %options );
    }
    push @html, "";

    return join("", @html) . "\n";
}


sub write {
    my $record = shift;
    my $writer = PICA::Writer->new( @_ );
    return $writer unless $writer;
    $writer->write( $record )->end;
}



sub pgrep (&@) {
    my $block  = shift;
    my $record = (@_ == 1 and UNIVERSAL::isa( $_[0],'PICA::Record' ))
               ? $_[0] : PICA::Record->new( @_ );
    my @fields;

    for my $f ( $record->fields ) {
        local $_ = $f;
        push @fields, $f if $block->();
    }

    return PICA::Record->new( @fields );
}


sub pmap (&@) {
    my $block  = shift;
    my $record = (@_ == 1 and UNIVERSAL::isa( $_[0],'PICA::Record' ))
               ? $_[0] : PICA::Record->new( @_ );
    my @fields;

    for my $f ( $record->fields ) {
        local $_ = $f;
        my @r = $block->();
        if (@r == 1 and UNIVERSAL::isa( $_[0],'PICA::Field' )) {
            push @fields, $r[0];
        } else {
            push @fields, PICA::Field->new( @r );
        }
    }

    return PICA::Record->new( @fields );
}


sub readpicarecord {
    my ($file, %options) = @_;
    if ( wantarray and defined $options{Limit} ) {
        return PICA::Parser->parsefile( $file, %options )->records();
    }
    $options{Limit} = 1;
    my ($record) = PICA::Parser->parsefile( $file, %options )->records();
    return undef unless $record and not $record->empty;
    return $record;
}


*writepicarecord = *write;


sub picarecord {
    return PICA::Record->new( @_ );
}

1;

__END__