package WebPAC::Normalize;
use Exporter 'import';
@EXPORT = qw/
	_set_rec _set_lookup
	_get_ds _clean_ds

	tag search display
	marc marc_indicators marc_repeatable_subfield

	rec1 rec2 rec
	regex prefix suffix surround
	first lookup join_with
/;

use warnings;
use strict;

#use base qw/WebPAC::Common/;
use Data::Dump qw/dump/;
use Encode qw/from_to/;

# debugging warn(s)
my $debug = 0;


=head1 NAME

WebPAC::Normalize - describe normalisaton rules using sets

=head1 VERSION

Version 0.06

=cut

our $VERSION = '0.06';

=head1 SYNOPSIS

This module uses C<conf/normalize/*.pl> files to perform normalisation
from input records using perl functions which are specialized for set
processing.

Sets are implemented as arrays, and normalisation file is valid perl, which
means that you check it's validity before running WebPAC using
C<perl -c normalize.pl>.

Normalisation can generate multiple output normalized data. For now, supported output
types (on the left side of definition) are: C<tag>, C<display>, C<search> and
C<marc>.

=head1 FUNCTIONS

Functions which start with C<_> are private and used by WebPAC internally.
All other functions are available for use within normalisation rules.

=head2 data_structure

Return data structure

  my $ds = WebPAC::Normalize::data_structure(
  	lookup => $lookup->lookup_hash,
	row => $row,
	rules => $normalize_pl_config,
	marc_encoding => 'utf-8',
  );

Options C<lookup>, C<row>, C<rules> and C<log> are mandatory while all
other are optional.

This function will B<die> if normalizastion can't be evaled.

Since this function isn't exported you have to call it with 
C<WebPAC::Normalize::data_structure>.

=cut

sub data_structure {
	my $arg = {@_};

	die "need row argument" unless ($arg->{row});
	die "need normalisation argument" unless ($arg->{rules});

	no strict 'subs';
	_set_lookup( $arg->{lookup} );
	_set_rec( $arg->{row} );
	_clean_ds( %{ $arg } );
	eval "$arg->{rules}";
	die "error evaling $arg->{rules}: $@\n" if ($@);

	return _get_ds();
}

=head2 _set_rec

Set current record hash

  _set_rec( $rec );

=cut

my $rec;

sub _set_rec {
	$rec = shift or die "no record hash";
}

=head2 _get_ds

Return hash formatted as data structure

  my $ds = _get_ds();

=cut

my ($out,$marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators);

sub _get_ds {
	return $out;
}

=head2 _clean_ds

Clean data structure hash for next record

  _clean_ds();

=cut

sub _clean_ds {
	my $a = {@_};
	($out,$marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators) = ();
	$marc_encoding = $a->{marc_encoding};
}

=head2 _set_lookup

Set current lookup hash

  _set_lookup( $lookup );

=cut

my $lookup;

sub _set_lookup {
	$lookup = shift;
}

=head2 _get_marc_fields

Get all fields defined by calls to C<marc>

	$marc->add_fields( WebPAC::Normalize:_get_marc_fields() );



We are using I<magic> which detect repeatable fields only from
sequence of field/subfield data generated by normalization.

Repeatable field is created if there is second occurence of same subfield or
if any of indicators are different. This is sane for most cases except for
non-repeatable fields with repeatable subfields.

You can change behaviour of that using C<marc_repeatable_subfield>.

=cut

sub _get_marc_fields {

	return if (! $marc_record || ref($marc_record) ne 'ARRAY' || $#{ $marc_record } < 0);

	# first, sort all existing fields 
	# XXX might not be needed, but modern perl might randomize elements in hash
	my @sorted_marc_record = sort {
		$a->[0] . $a->[3] cmp $b->[0] . $b->[3]	
	} @{ $marc_record };

	# output marc fields
	my @m;

	# count unique field-subfields (used for offset when walking to next subfield)
	my $u;
	map { $u->{ $_->[0] . $_->[3]  }++ } @sorted_marc_record;

	if ($debug) {
		warn "## marc_repeatable_subfield ", dump( $marc_repeatable_subfield ), $/;
		warn "## marc_record ", dump( $marc_record ), $/;
		warn "## sorted_marc_record ", dump( \@sorted_marc_record ), $/;
		warn "## subfield count ", dump( $u ), $/;
	}

	my $len = $#sorted_marc_record;
	my $visited;
	my $i = 0;
	my $field;

	foreach ( 0 .. $len ) {

		# find next element which isn't visited
		while ($visited->{$i}) {
			$i = ($i + 1) % ($len + 1);
		}

		# mark it visited
		$visited->{$i}++;

		my $row = $sorted_marc_record[$i];

		# field and subfield which is key for
		# marc_repeatable_subfield and u
		my $fsf = $row->[0] . $row->[3];

		if ($debug > 1) {

			print "### field so far [", $#$field, "] : ", dump( $field ), " ", $field ? 'T' : 'F', $/;
			print "### this [$i]: ", dump( $row ),$/;
			print "### sf: ", $row->[3], " vs ", $field->[3],
				$marc_repeatable_subfield->{ $row->[0] . $row->[3] } ? ' (repeatable)' : '', $/,
				if ($#$field >= 0);

		}

		# if field exists
		if ( $#$field >= 0 ) {
			if (
				$row->[0] ne $field->[0] ||		# field
				$row->[1] ne $field->[1] ||		# i1
				$row->[2] ne $field->[2]		# i2
			) {
				push @m, $field;
				warn "## saved/1 ", dump( $field ),$/ if ($debug);
				$field = $row;

			} elsif (
				( $row->[3] lt $field->[-2] )		# subfield which is not next (e.g. a after c)
				||
				( $row->[3] eq $field->[-2] &&		# same subfield, but not repeatable
					! $marc_repeatable_subfield->{ $fsf }
				)
			) {
				push @m, $field;
				warn "## saved/2 ", dump( $field ),$/ if ($debug);
				$field = $row;

			} else {
				# append new subfields to existing field
				push @$field, ( $row->[3], $row->[4] );
			}
		} else {
			# insert first field
			$field = $row;
		}

		if (! $marc_repeatable_subfield->{ $fsf }) {
			# make step to next subfield
			$i = ($i + $u->{ $fsf } ) % ($len + 1);
		}
	}

	if ($#$field >= 0) {
		push @m, $field;
		warn "## saved/3 ", dump( $field ),$/ if ($debug);
	}

	return @m;
}

=head1 Functions to create C<data_structure>

Those functions generally have to first in your normalization file.

=head2 tag

Define new tag for I<search> and I<display>.

  tag('Title', rec('200','a') );


=cut

sub tag {
	my $name = shift or die "tag needs name as first argument";
	my @o = grep { defined($_) && $_ ne '' } @_;
	return unless (@o);
	$out->{$name}->{tag} = $name;
	$out->{$name}->{search} = \@o;
	$out->{$name}->{display} = \@o;
}

=head2 display

Define tag just for I<display>

  @v = display('Title', rec('200','a') );

=cut

sub display {
	my $name = shift or die "display needs name as first argument";
	my @o = grep { defined($_) && $_ ne '' } @_;
	return unless (@o);
	$out->{$name}->{tag} = $name;
	$out->{$name}->{display} = \@o;
}

=head2 search

Prepare values just for I<search>

  @v = search('Title', rec('200','a') );

=cut

sub search {
	my $name = shift or die "search needs name as first argument";
	my @o = grep { defined($_) && $_ ne '' } @_;
	return unless (@o);
	$out->{$name}->{tag} = $name;
	$out->{$name}->{search} = \@o;
}

=head2 marc

Save value for MARC field

  marc('900','a', rec('200','a') );

=cut

sub marc {
	my $f = shift or die "marc needs field";
	die "marc field must be numer" unless ($f =~ /^\d+$/);

	my $sf = shift or die "marc needs subfield";

	foreach (@_) {
		my $v = $_;		# make var read-write for Encode
		next unless (defined($v) && $v !~ /^\s*$/);
		from_to($v, 'iso-8859-2', $marc_encoding) if ($marc_encoding);
		my ($i1,$i2) = defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' ');
		push @{ $marc_record }, [ $f, $i1, $i2, $sf => $v ];
	}
}

=head2 marc_repeatable_subfield

Save values for MARC repetable subfield

  marc_repeatable_subfield('910', 'z', rec('909') );

=cut

sub marc_repeatable_subfield {
	my ($f,$sf) = @_;
	die "marc_repeatable_subfield need field and subfield!\n" unless ($f && $sf);
	$marc_repeatable_subfield->{ $f . $sf }++;
	marc(@_);
}

=head2 marc_indicators

Set both indicators for MARC field

  marc_indicators('900', ' ', 1);

Any indicator value other than C<0-9> will be treated as undefined.

=cut

sub marc_indicators {
	my $f = shift || die "marc_indicators need field!\n";
	my ($i1,$i2) = @_;
	die "marc_indicators($f, ...) need i1!\n" unless(defined($i1));
	die "marc_indicators($f, $i1, ...) need i2!\n" unless(defined($i2));

	$i1 = ' ' if ($i1 !~ /^\d$/);
	$i2 = ' ' if ($i2 !~ /^\d$/);
	@{ $marc_indicators->{$f} } = ($i1,$i2);
}


=head1 Functions to extract data from input

This function should be used inside functions to create C<data_structure> described
above.

=head2 rec1

Return all values in some field

  @v = rec1('200')

TODO: order of values is probably same as in source data, need to investigate that

=cut

sub rec1 {
	my $f = shift;
	return unless (defined($rec) && defined($rec->{$f}));
	if (ref($rec->{$f}) eq 'ARRAY') {
		return map { 
			if (ref($_) eq 'HASH') {
				values %{$_};
			} else {
				$_;
			}
		} @{ $rec->{$f} };
	} elsif( defined($rec->{$f}) ) {
		return $rec->{$f};
	}
}

=head2 rec2

Return all values in specific field and subfield

  @v = rec2('200','a')

=cut

sub rec2 {
	my $f = shift;
	return unless (defined($rec && $rec->{$f}));
	my $sf = shift;
	return map { $_->{$sf} } grep { ref($_) eq 'HASH' && $_->{$sf} } @{ $rec->{$f} };
}

=head2 rec

syntaxtic sugar for

  @v = rec('200')
  @v = rec('200','a')

=cut

sub rec {
	if ($#_ == 0) {
		return rec1(@_);
	} elsif ($#_ == 1) {
		return rec2(@_);
	}
}

=head2 regex

Apply regex to some or all values

  @v = regex( 's/foo/bar/g', @v );

=cut

sub regex {
	my $r = shift;
	my @out;
	#warn "r: $r\n", dump(\@_);
	foreach my $t (@_) {
		next unless ($t);
		eval "\$t =~ $r";
		push @out, $t if ($t && $t ne '');
	}
	return @out;
}

=head2 prefix

Prefix all values with a string

  @v = prefix( 'my_', @v );

=cut

sub prefix {
	my $p = shift or die "prefix needs string as first argument";
	return map { $p . $_ } grep { defined($_) } @_;
}

=head2 suffix

suffix all values with a string

  @v = suffix( '_my', @v );

=cut

sub suffix {
	my $s = shift or die "suffix needs string as first argument";
	return map { $_ . $s } grep { defined($_) } @_;
}

=head2 surround

surround all values with a two strings

  @v = surround( 'prefix_', '_suffix', @v );

=cut

sub surround {
	my $p = shift or die "surround need prefix as first argument";
	my $s = shift or die "surround needs suffix as second argument";
	return map { $p . $_ . $s } grep { defined($_) } @_;
}

=head2 first

Return first element

  $v = first( @v );

=cut

sub first {
	my $r = shift;
	return $r;
}

=head2 lookup

Consult lookup hashes for some value

  @v = lookup( $v );
  @v = lookup( @v );

=cut

sub lookup {
	my $k = shift or return;
	return unless (defined($lookup->{$k}));
	if (ref($lookup->{$k}) eq 'ARRAY') {
		return @{ $lookup->{$k} };
	} else {
		return $lookup->{$k};
	}
}

=head2 join_with

Joins walues with some delimiter

  $v = join_with(", ", @v);

=cut

sub join_with {
	my $d = shift;
	return join($d, grep { defined($_) && $_ ne '' } @_);
}

# END
1;
