File Coverage

blib/lib/Biblio/SICI.pm

Criterion	Covered	Total	%
statement	130	164	79.2
branch	44	100	44.0
condition	30	60	50.0
subroutine	16	16	100.0
pod	6	6	100.0
total	226	346	65.3

package Biblio::SICI;
{
  $Biblio::SICI::VERSION = '0.04';
}

# ABSTRACT: Provides methods for assembling, parsing, manipulating and serialising SICIs

use strict;
use warnings;
use 5.010001;

use Moo;
use Sub::Quote;

use Biblio::SICI::ItemSegment;
use Biblio::SICI::ContributionSegment;
use Biblio::SICI::ControlSegment;

use Biblio::SICI::Util qw( calculate_check_char );


has 'item' => (
	is   => 'ro',
	lazy => 1,
	isa => quote_sub(q{ die unless ( defined $_[0] and $_[0]->isa('Biblio::SICI::ItemSegment') ) }),
	builder =>
		quote_sub(q{ my ($self) = @_; return Biblio::SICI::ItemSegment->new( _sici => $self ); }),
	init_arg => undef,
);


has 'contribution' => (
	is   => 'ro',
	lazy => 1,
	isa  => quote_sub(
		q{ die unless ( defined $_[0] and $_[0]->isa('Biblio::SICI::ContributionSegment') ) }),
	builder => quote_sub(
		q{ my ($self) = @_; return Biblio::SICI::ContributionSegment->new( _sici => $self ); }),
	init_arg => undef,
);


has 'control' => (
	is   => 'ro',
	lazy => 1,
	isa  => quote_sub(
		q{ my ($val) = @_; die unless ( defined $val and $val->isa('Biblio::SICI::ControlSegment') ) }
	),
	builder => quote_sub(
		q{ my ($self) = @_; return Biblio::SICI::ControlSegment->new( _sici => $self ); }),
	init_arg => undef,
);


has 'mode' => (
	is       => 'rw',
	isa      => quote_sub(q{ my ($val) = @_; die unless ( $val eq 'strict' or $val eq 'lax' ) }),
	required => 1,
	coerce   => sub {
		my ($val) = @_;
		$val = join( '', split( " ", lc($val) ) );
		return $val if ( $val eq 'strict' or $val eq 'lax' );
		return 'lax';
	},
	default => quote_sub(q{ "lax" }),
);


has 'parsedString' => ( is => 'rwp', init_arg => undef, );


sub parse {
	my ( $self, $string ) = @_;
	my $strictMode = $self->mode() eq 'strict' ? 1 : 0;

	if ( defined $string ) {
		$string =~ s/\r/ /go;
		$string =~ s/\n/ /go;
		$string = join( '', split( " ", $string ) );
	}

	unless ($string) {
		$strictMode ? die 'no string to parse' : return ( undef, undef, ['no string to parse'] );
	}
	$self->_set_parsedString($string);

	my $checkChar = '';
	if ( $string =~ /;([0-9])(?:-.)?\Z/ ) {
		if ( "$1" ne "2" ) {
			$strictMode
				? die 'unsupported SICI version'
				: return ( undef, undef, ['unsupported SICI version'] );
		}
		else {
			$self->control()->version(2);
			if ( $string =~ s/;2-(.)\Z// ) {
				$checkChar = $1;
			}
		}
	}

	my $parserProblems = [];

	my @chars = split( //, $string );
	my $tmp = '';
	while ( exists( $chars[0] ) and $chars[0] !~ /[(<]/ ) {
		$tmp .= shift @chars;
	}

	if ( $tmp and exists( $chars[0] ) ) {
		if ( $chars[0] eq '(' ) {

			# warn 'ISSN candidate: ' . $tmp;
			$self->item()->issn($tmp);
			shift @chars;
		}
		elsif ( $chars[0] eq '<' ) {
			push @{$parserProblems}, "item information missing";

			# warn 'Missing item info';
			# warn 'Enumeration candidate: ' . $tmp;
			if ( $tmp =~ /\A([A-Z0-9\/]+):([A-Z0-9\/]+)(?::([+*]))?\Z/ ) {
				$self->item()->volume($1);
				$self->item()->issue($2);
				$self->item()->supplOrIdx($3) if $3;
			}
			elsif ($tmp) {
				$self->item()->enumeration($tmp);
			}
			shift @chars;
			goto CONTRIB;
		}
		else {
			$strictMode ? die 'unparsable string' : return ( undef, undef, ['unparsable string'] );
		}
	} ## end if ( $tmp and exists( ...))
	else {
		$strictMode ? die 'unparsable string' : return ( undef, undef, ['unparsable string'] );
	}

	$tmp = '';
	while ( exists( $chars[0] ) and $chars[0] ne ')' ) {
		$tmp .= shift @chars;
	}
	if ( $tmp and exists( $chars[0] ) and $chars[0] eq ')' ) {

		# warn 'Chronology candidate: ' . $tmp;
		$self->item()->chronology($tmp);
		shift @chars;
	}
	elsif ( exists( $chars[0] ) and $chars[0] eq ')' ) {
		shift @chars;
	}
	else {
		$strictMode ? die 'unparsable string' : return ( undef, undef, ['unparsable string'] );
	}

	$tmp = '';
	while ( exists( $chars[0] ) and $chars[0] ne '<' ) {
		$tmp .= shift @chars;
	}
	if ( $tmp and exists( $chars[0] ) and $chars[0] eq '<' ) {

		# warn 'Enumeration candidate: ' . $tmp;
		if ( $tmp =~ /\A([A-Z0-9\/]+):([A-Z0-9\/]+)(?::([+*]))?\Z/ ) {
			$self->item()->volume($1);
			$self->item()->issue($2);
			$self->item()->supplOrIdx($3) if $3;
		}
		elsif ($tmp) {
			$self->item()->enumeration($tmp);
		}
		shift @chars;
	}
	elsif ( exists( $chars[0] ) and $chars[0] eq '<' ) {
		shift @chars;
	}
	else {
		$strictMode ? die 'unparsable string' : return ( undef, undef, ['unparsable string'] );
	}

	CONTRIB:
	$tmp = '';
	while ( exists( $chars[0] ) and $chars[0] ne '>' ) {
		$tmp .= shift @chars;
	}
	if ( $tmp and exists( $chars[0] ) and $chars[0] eq '>' ) {

		# warn 'Contribution candidate: ' . $tmp;
		if ( $tmp =~ /\A::(.+)\Z/ ) {
			$self->contribution()->localNumber($1);
		}
		elsif ( $tmp =~ /\A:([^:]+)(?::(.+))?\Z/ ) {
			$self->contribution()->titleCode($1);
			$self->contribution()->localNumber($2) if $2;
		}
		elsif ( $tmp =~ /\A([^:]+):([^:]+)(?::(.+))?\Z/ ) {
			$self->contribution()->location($1);
			$self->contribution()->titleCode($2);
			$self->contribution()->localNumber($3) if $3;
		}
		else {
			$self->contribution()->location($tmp);
		}
		shift @chars;
	}
	elsif ( exists( $chars[0] ) and $chars[0] eq '>' ) {
		shift @chars;
	}
	else {
		$strictMode ? die 'unparsable string' : return ( undef, undef, ['unparsable string'] );
	}

	my $csi = '';
	if ( exists( $chars[0] ) ) {
		$csi = shift @chars;
	}

	if ( exists( $chars[0] ) and $chars[0] eq '.' ) {
		shift @chars;
	}
	elsif ( exists( $chars[0] ) ) {
		shift(@chars) while ( $chars[0] ne '.' );
	}

	if ( exists( $chars[0] ) ) {
		$self->control()->dpi( shift @chars );
	}

	if ( exists( $chars[0] ) and $chars[0] eq '.' ) {
		shift @chars;
	}
	elsif ( exists( $chars[0] ) ) {
		shift(@chars) while ( $chars[0] ne '.' );
	}

	if ( exists( $chars[0] ) and exists( $chars[1] ) ) {
		$self->control()->mfi( join( '', splice( @chars, 0, 2 ) ) );
	}

	my $isValid = $self->is_valid();
	if ( $strictMode && !$isValid ) {
		die 'parsing failed: invalid SICI';
	}

	if ( $checkChar ne $self->checkchar() ) {
		push @{$parserProblems}, "wrong check char; was '$checkChar', should have been '$1'";
	}
	if ( $checkChar !~ /\A[0-9A-Z#]\Z/ ) {
		push @{$parserProblems}, 'invalid original check char';
	}

	if ( $self->control()->csi() ne $csi ) {
		push @{$parserProblems}, 'wrong csi in string input';
	}

	my $roundTrip = ( $self->parsedString() eq $self->to_string() ? 1 : 0 );
	return ( $isValid, $roundTrip, $parserProblems );
} ## end sub parse


sub to_string {
	my $self = shift;

	my $str = $self->_to_string();
	my $cs  = calculate_check_char($str);

	return $str . $cs;
}

sub _to_string {
	my $self = shift;

	my $item    = $self->item()->to_string();
	my $contrib = $self->contribution()->to_string();
	my $control = $self->control()->to_string();

	return sprintf( '%s<%s>%s-', $item, $contrib, $control );
}


sub checkchar {
	my $self = shift;

	my $siciAsString = $self->_to_string();

	return calculate_check_char($siciAsString);
}


sub reset {
	my $self = shift;
	$self->item()->reset();
	$self->contribution()->reset();
	$self->control()->reset();
	return;
}


sub is_valid {
	my $self = shift;

	my $itemIsValid    = $self->item()->is_valid();
	my $contribIsValid = $self->contribution()->is_valid();
	my $controlIsValid = $self->control()->is_valid();

	if ( $itemIsValid && $contribIsValid && $controlIsValid ) {
		return 1;
	}

	return 0;
}


sub list_problems {
	my $self = shift;

	my $hasProblems = 0;
	my %problems    = ();
	if ( not $self->item()->is_valid() ) {
		$hasProblems++;
		$problems{'item'} = { $self->item()->list_problems() };
	}
	if ( not $self->contribution()->is_valid() ) {
		$hasProblems++;
		$problems{'contribution'} = { $self->contribution()->list_problems() };
	}
	if ( not $self->control()->is_valid() ) {
		$hasProblems++;
		$problems{'control'} = { $self->control()->list_problems() };
	}

	if ($hasProblems) {
		return %problems;
	}
	return;
}

1;

__END__