--- trunk/lib/WebPAC/Normalize.pm	2005/11/12 21:21:50	38
+++ trunk/lib/WebPAC/Normalize.pm	2006/04/30 12:17:19	436
@@ -2,6 +2,8 @@
 
 use warnings;
 use strict;
+use blib;
+use WebPAC::Common;
 use base 'WebPAC::Common';
 use Data::Dumper;
 
@@ -11,11 +13,11 @@
 
 =head1 VERSION
 
-Version 0.01
+Version 0.09
 
 =cut
 
-our $VERSION = '0.01';
+our $VERSION = '0.09';
 
 =head1 SYNOPSIS
 
@@ -47,6 +49,10 @@
 code defined as code ref on format after field substitution to producing
 output
 
+There is one built-in filter called C<regex> which can be use like this:
+
+  filter{regex(s/foo/bar/)}
+
 =item *
 
 optional C<lookup{...}> will be then performed. See C<WebPAC::Lookups>.
@@ -82,11 +88,15 @@
 	db => $db_obj,
 	lookup_regex => $lookup->regex,
 	lookup => $lookup_obj,
+	prefix => 'foobar',
   );
 
 Parametar C<filter> defines user supplied snippets of perl code which can
 be use with C<filter{...}> notation.
 
+C<prefix> is used to form filename for database record (to support multiple
+source files which are joined in one database).
+
 Recommended parametar C<lookup_regex> is used to enable parsing of lookups
 in structures. If you pass this parametar, you must also pass C<lookup>
 which is C<WebPAC::Lookup> object.
@@ -111,9 +121,53 @@
 
 	$log->logdie("lookup must be WebPAC::Lookup object") if ($self->{'lookup'} && ! $self->{'lookup'}->isa('WebPAC::Lookup'));
 
+	$log->warn("no prefix defined. please check that!") unless ($self->{'prefix'});
+
+	$log->debug("using lookup regex: ", $self->{lookup_regex}) if ($r && $l);
+
+	if (! $self->{filter} || ! $self->{filter}->{regex}) {
+		$log->debug("adding built-in filter regex");
+		$self->{filter}->{regex} = sub {
+			my ($val, $regex) = @_;
+			eval "\$val =~ $regex";
+			return $val;
+		};
+	}
+
 	$self ? return $self : return undef;
 }
 
+=head2 all_tags
+
+Returns all tags in document in specified order
+
+  my $sorted_tags = $self->all_tags();
+
+=cut
+
+sub all_tags {
+	my $self = shift;
+
+	if (! $self->{_tags_by_order}) {
+
+		my $log = $self->_get_logger;
+		# sanity check
+		$log->logdie("can't find self->{inport_xml}->{indexer}") unless ($self->{import_xml}->{indexer});
+
+		my @tags = keys %{ $self->{'import_xml'}->{'indexer'}};
+		$log->debug("unsorted tags: " . join(", ", @tags));
+
+		@tags = sort { $self->_sort_by_order } @tags;
+
+		$log->debug("sorted tags: " . join(",", @tags) );
+
+		$self->{_tags_by_order} = \@tags;
+	}
+
+	return $self->{_tags_by_order};
+}
+
+
 
 =head2 data_structure
 
@@ -122,13 +176,7 @@
 
 This structures are used to produce output.
 
- my @ds = $webpac->data_structure($rec);
-
-B<Note: historical oddity follows>
-
-This method will also set C<< $webpac->{'currnet_filename'} >> if there is
-C<< <filename> >> tag and C<< $webpac->{'headline'} >> if there is
-C<< <headline> >> tag.
+ my $ds = $webpac->data_structure($rec);
 
 =cut
 
@@ -140,31 +188,28 @@
 	my $rec = shift;
 	$log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
 
+	$log->debug("data_structure rec = ", sub { Dumper($rec) });
+
+	$log->logdie("need unique ID (mfn) in field 000 of record " . Dumper($rec) ) unless (defined($rec->{'000'}));
+
+	my $id = $rec->{'000'}->[0] || $log->logdie("field 000 isn't array!");
+
 	my $cache_file;
 
 	if ($self->{'db'}) {
-		my @ds = $self->{'db'}->load_ds($rec);
-		$log->debug("load_ds( rec = ", sub { Dumper($rec) }, ") = ", sub { Dumper(@ds) });
-		return @ds if ($#ds > 0);
+		my $ds = $self->{'db'}->load_ds( id => $id, prefix => $self->{prefix} );
+		$log->debug("load_ds( rec = ", sub { Dumper($rec) }, ") = ", sub { Dumper($ds) });
+		return $ds if ($ds);
 		$log->debug("cache miss, creating");
 	}
 
-	undef $self->{'currnet_filename'};
-	undef $self->{'headline'};
-
-	my @sorted_tags;
-	if ($self->{tags_by_order}) {
-		@sorted_tags = @{$self->{tags_by_order}};
-	} else {
-		@sorted_tags = sort { $self->_sort_by_order } keys %{$self->{'import_xml'}->{'indexer'}};
-		$self->{tags_by_order} = \@sorted_tags;
-	}
+	my $tags = $self->all_tags();
 
-	my @ds;
+	$log->debug("tags: ",sub { join(", ",@{ $tags }) });
 
-	$log->debug("tags: ",sub { join(", ",@sorted_tags) });
+	my $ds;
 
-	foreach my $field (@sorted_tags) {
+	foreach my $field (@{ $tags }) {
 
 		my $row;
 
@@ -176,15 +221,18 @@
 			$log->logdie("expected tag HASH and got $tag") unless (ref($tag) eq 'HASH');
 			$format = $tag->{'value'} || $tag->{'content'};
 
-			$log->debug("format: $format");
-
 			my @v;
 			if ($self->{'lookup_regex'} && $format =~ $self->{'lookup_regex'}) {
-				@v = $self->fill_in_to_arr($rec,$format);
+				@v = $self->_rec_to_arr($rec,$format,'fill_in');
+			} else {
+				@v = $self->_rec_to_arr($rec,$format,'parse');
+			}
+			if (! @v) {
+				$log->debug("$field <",$self->{tag},"> format: $format no values");
+				next;
 			} else {
-				@v = $self->parse_to_arr($rec,$format);
+				$log->debug("$field <",$self->{tag},"> format: $format values: ", join(",", @v));
 			}
-			next if (! @v);
 
 			if ($tag->{'sort'}) {
 				@v = $self->sort_arr(@v);
@@ -195,28 +243,19 @@
 				@v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;
 			}
 
-			if ($field eq 'filename') {
-				$self->{'current_filename'} = join('',@v);
-				$log->debug("filename: ",$self->{'current_filename'});
-			} elsif ($field eq 'headline') {
-				$self->{'headline'} .= join('',@v);
-				$log->debug("headline: ",$self->{'headline'});
-				next; # don't return headline in data_structure!
-			}
-
 			# delimiter will join repeatable fields
 			if ($tag->{'delimiter'}) {
 				@v = ( join($tag->{'delimiter'}, @v) );
 			}
 
 			# default types 
-			my @types = qw(display swish);
+			my @types = qw(display search);
 			# override by type attribute
 			@types = ( $tag->{'type'} ) if ($tag->{'type'});
 
 			foreach my $type (@types) {
 				# append to previous line?
-				$log->debug("type: $type ",sub { join(" ",@v) }, $row->{'append'} || 'no append');
+				$log->debug("tag $field / $type [",sub { join(",",@v) }, "] ", $row->{'append'} || 'no append');
 				if ($tag->{'append'}) {
 
 					# I will delimit appended part with
@@ -243,14 +282,14 @@
 
 			# TODO: name_sigular, name_plural
 			my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};
-			$row->{'name'} = $name ? $self->_x($name) : $field;
+			my $row_name = $name ? $self->_x($name) : $field;
 
 			# post-sort all values in field
 			if ($self->{'import_xml'}->{'indexer'}->{$field}->{'sort'}) {
 				$log->warn("sort at field tag not implemented");
 			}
 
-			push @ds, $row;
+			$ds->{$row_name} = $row;
 
 			$log->debug("row $field: ",sub { Dumper($row) });
 		}
@@ -258,14 +297,16 @@
 	}
 
 	$self->{'db'}->save_ds(
-		ds => \@ds,
-		current_filename => $self->{'current_filename'},
-		headline => $self->{'headline'},
+		id => $id,
+		ds => $ds,
+		prefix => $self->{prefix},
 	) if ($self->{'db'});
 
-	$log->debug("ds: ", sub { Dumper(@ds) });
+	$log->debug("ds: ", sub { Dumper($ds) });
 
-	return @ds;
+	$log->logconfess("data structure returned is not array any more!") if wantarray;
+
+	return $ds;
 
 }
 
@@ -277,12 +318,22 @@
 
  my $text = $webpac->parse($rec,'eval{"v901^a" eq "Deskriptor"}descriptor: v250^a', $i);
 
+Filters are implemented here. While simple form of filters looks like this:
+
+  filter{name_of_filter}
+
+but, filters can also have variable number of parametars like this:
+
+  filter{name_of_filter(param,param,param)}
+
 =cut
 
+my $warn_once;
+
 sub parse {
 	my $self = shift;
 
-	my ($rec, $format_utf8, $i) = @_;
+	my ($rec, $format_utf8, $i, $rec_size) = @_;
 
 	return if (! $format_utf8);
 
@@ -296,7 +347,7 @@
 
 	my @out;
 
-	$log->debug("format: $format");
+	$log->debug("format: $format [$i]");
 
 	my $eval_code;
 	# remove eval{...} from beginning
@@ -306,29 +357,45 @@
 	# remove filter{...} from beginning
 	$filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
 
+	# did we found any (att all) field from format in row?
+	my $found_any;
+	# prefix before first field which we preserve it $found_any
 	my $prefix;
-	my $all_found=0;
+
+	my $f_step = 1;
 
 	while ($format =~ s/^(.*?)(v|s)(\d+)(?:\^(\w))?//s) {
 
 		my $del = $1 || '';
-		$prefix ||= $del if ($all_found == 0);
+		$prefix = $del if ($f_step == 1);
+
+		my $fld_type = lc($2);
 
 		# repeatable index
 		my $r = $i;
-		$r = 0 if (lc("$2") eq 's');
+		if ($fld_type eq 's') {
+			if ($found_any->{'v'}) {
+				$r = 0;
+			} else {
+				return;
+			}
+		}
 
 		my $found = 0;
-		my $tmp = $self->get_data(\$rec,$3,$4,$r,\$found);
+		my $tmp = $self->get_data(\$rec,$3,$4,$r,\$found,$rec_size);
 
 		if ($found) {
-			push @out, $del;
-			push @out, $tmp;
-			$all_found += $found;
+			$found_any->{$fld_type} += $found;
+
+			# we will skip delimiter before first occurence of field!
+			push @out, $del unless($found_any->{$fld_type} == 1);
+			push @out, $tmp if ($tmp);
 		}
+		$f_step++;
 	}
 
-	return if (! $all_found);
+	# test if any fields found?
+	return if (! $found_any->{'v'} && ! $found_any->{'s'});
 
 	my $out = join('',@out);
 
@@ -348,47 +415,26 @@
 		return if (! $self->_eval($eval));
 	}
 	
-	if ($filter_name && $self->{'filter'}->{$filter_name}) {
-		$log->debug("about to filter{$filter_name} format: $out");
-		$out = $self->{'filter'}->{$filter_name}->($out);
-		return unless(defined($out));
-		$log->debug("filter result: $out");
+	if ($filter_name) {
+		my @filter_args;
+		if ($filter_name =~ s/(\w+)\((.*)\)/$1/) {
+			@filter_args = split(/,/, $2);
+		}
+		if ($self->{'filter'}->{$filter_name}) {
+			$log->debug("about to filter{$filter_name} format: $out with arguments: ", join(",", @filter_args));
+			unshift @filter_args, $out;
+			$out = $self->{'filter'}->{$filter_name}->(@filter_args);
+			return unless(defined($out));
+			$log->debug("filter result: $out");
+		} elsif (! $warn_once->{$filter_name}) {
+			$log->warn("trying to use undefined filter $filter_name");
+			$warn_once->{$filter_name}++;
+		}
 	}
 
 	return $out;
 }
 
-=head2 parse_to_arr
-
-Similar to C<parse>, but returns array of all repeatable fields
-
- my @arr = $webpac->parse_to_arr($rec,'v250^a');
-
-=cut
-
-sub parse_to_arr {
-	my $self = shift;
-
-	my ($rec, $format_utf8) = @_;
-
-	my $log = $self->_get_logger();
-
-	$log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
-	return if (! $format_utf8);
-
-	my $i = 0;
-	my @arr;
-
-	while (my $v = $self->parse($rec,$format_utf8,$i++)) {
-		push @arr, $v;
-	}
-
-	$log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
-
-	return @arr;
-}
-
-
 =head2 fill_in
 
 Workhourse of all: takes record from in-memory structure of database and
@@ -410,6 +456,11 @@
 This method will automatically decode UTF-8 string to local code page
 if needed.
 
+There is optional parametar C<$record_size> which can be used to get sizes of
+all C<field^subfield> combinations in this format.
+
+ my $text = $webpac->fill_in($rec,'got: v900^a v900^x',0,\$rec_size); 
+
 =cut
 
 sub fill_in {
@@ -417,10 +468,13 @@
 
 	my $log = $self->_get_logger();
 
-	my $rec = shift || $log->logconfess("need data record");
-	my $format = shift || $log->logconfess("need format to parse");
+	my ($rec,$format,$i,$rec_size) = @_;
+
+	$log->logconfess("need data record") unless ($rec);
+	$log->logconfess("need format to parse") unless($format);
+
 	# iteration (for repeatable fields)
-	my $i = shift || 0;
+	$i ||= 0;
 
 	$log->logdie("infitite loop in format $format") if ($i > ($self->{'max_mfn'} || 9999));
 
@@ -432,6 +486,7 @@
 	}
 
 	my $found = 0;
+	my $just_single = 1;
 
 	my $eval_code;
 	# remove eval{...} from beginning
@@ -441,11 +496,21 @@
 	# remove filter{...} from beginning
 	$filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
 
-	# do actual replacement of placeholders
-	# repeatable fields
-	$format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found)/ges;
-	# non-repeatable fields
-	$format =~ s/s(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,0,\$found)/ges;
+	{
+		# fix warnings
+		no warnings 'uninitialized';
+
+		# do actual replacement of placeholders
+		# repeatable fields
+		if ($format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found,$rec_size)/ges) {
+			$just_single = 0;
+		}
+
+		# non-repeatable fields
+		if ($format =~ s/s(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,0,\$found,$rec_size)/ges) {
+			return if ($i > 0 && $just_single);
+		}
+	}
 
 	if ($found) {
 		$log->debug("format: $format");
@@ -462,7 +527,9 @@
 		# do we have lookups?
 		if ($self->{'lookup'}) {
 			if ($self->{'lookup'}->can('lookup')) {
-				return $self->{'lookup'}->lookup($format);
+				my @lookup = $self->{lookup}->lookup($format);
+				$log->debug("lookup $format", join(", ", @lookup));
+				return @lookup;
 			} else {
 				$log->warn("Have lookup object but can't invoke lookup method");
 			}
@@ -475,31 +542,47 @@
 }
 
 
-=head2 fill_in_to_arr
+=head2 _rec_to_arr
 
-Similar to C<fill_in>, but returns array of all repeatable fields. Usable
+Similar to C<parse> and C<fill_in>, but returns array of all repeatable fields. Usable
 for fields which have lookups, so they shouldn't be parsed but rather
-C<fill_id>ed.
+C<paste>d or C<fill_id>ed. Last argument is name of operation: C<paste> or C<fill_in>.
 
- my @arr = $webpac->fill_in_to_arr($rec,'[v900];;[v250^a]');
+ my @arr = $webpac->fill_in_to_arr($rec,'[v900];;[v250^a]','paste');
 
 =cut
 
-sub fill_in_to_arr {
+sub _rec_to_arr {
 	my $self = shift;
 
-	my ($rec, $format_utf8) = @_;
+	my ($rec, $format_utf8, $code) = @_;
 
 	my $log = $self->_get_logger();
 
 	$log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
 	return if (! $format_utf8);
 
+	$log->debug("using $code on $format_utf8");
+
 	my $i = 0;
+	my $max = 0;
 	my @arr;
+	my $rec_size = {};
 
-	while (my @v = $self->fill_in($rec,$format_utf8,$i++)) {
-		push @arr, @v;
+	while ($i <= $max) {
+		my @v = $self->$code($rec,$format_utf8,$i++,\$rec_size);
+		if ($rec_size) {
+			foreach my $f (keys %{ $rec_size }) {
+				$max = $rec_size->{$f} if ($rec_size->{$f} > $max);
+			}
+			$log->debug("max set to $max");
+			undef $rec_size;
+		}
+		if (@v) {
+			push @arr, @v;
+		} else {
+			push @arr, '' if ($max > $i);
+		}
 	}
 
 	$log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
@@ -512,48 +595,77 @@
 
 Returns value from record.
 
- my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);
+ my $text = $self->get_data(\$rec,$f,$sf,$i,\$found,\$rec_size);
+
+Required arguments are:
+
+=over 8
+
+=item C<$rec>
+
+record reference
+
+=item C<$f>
+
+field
+
+=item C<$sf>
+
+optional subfield
 
-Arguments are:
-record reference C<$rec>,
-field C<$f>,
-optional subfiled C<$sf>,
-index for repeatable values C<$i>.
+=item C<$i>
 
-Optinal variable C<$found> will be incremeted if there
-is field.
+index offset for repeatable values ( 0 ... $rec_size->{'400^a'} )
 
-Returns value or empty string.
+=item C<$found>
+
+optional variable that will be incremeted if preset
+
+=item C<$rec_size>
+
+hash to hold maximum occurances of C<field^subfield> combinations
+(which can be accessed using keys in same format)
+
+=back
+
+Returns value or empty string, updates C<$found> and C<rec_size>
+if present.
 
 =cut
 
 sub get_data {
 	my $self = shift;
 
-	my ($rec,$f,$sf,$i,$found) = @_;
+	my ($rec,$f,$sf,$i,$found,$cache) = @_;
+
+	return '' unless ($$rec->{$f} && ref($$rec->{$f}) eq 'ARRAY');
 
-	if ($$rec->{$f}) {
-		return '' if (! $$rec->{$f}->[$i]);
+	if (defined($$cache)) {
+		$$cache->{ $f . ( $sf ? '^' . $sf : '' ) } ||= scalar @{ $$rec->{$f} };
+	}
+
+	return '' unless ($$rec->{$f}->[$i]);
+
+	{
 		no strict 'refs';
-		if ($sf && $$rec->{$f}->[$i]->{$sf}) {
-			$$found++ if (defined($$found));
+		if (defined($sf)) {
+			$$found++ if (defined($$found) && $$rec->{$f}->[$i]->{$sf});
 			return $$rec->{$f}->[$i]->{$sf};
-		} elsif ($$rec->{$f}->[$i]) {
+		} else {
 			$$found++ if (defined($$found));
-			# it still might have subfield, just
-			# not specified, so we'll dump all
+			# it still might have subfields, just
+			# not specified, so we'll dump some debug info
 			if ($$rec->{$f}->[$i] =~ /HASH/o) {
 				my $out;
 				foreach my $k (keys %{$$rec->{$f}->[$i]}) {
-					$out .= $$rec->{$f}->[$i]->{$k}." ";
+					my $v = $$rec->{$f}->[$i]->{$k};
+					$out .= '$' . $k .':' . $v if ($v);
 				}
 				return $out;
 			} else {
 				return $$rec->{$f}->[$i];
 			}
 		}
-	} else {
-		return '';
 	}
 }
 
@@ -674,4 +786,4 @@
 
 =cut
 
-1; # End of WebPAC::DB
+1; # End of WebPAC::Normalize