Repository List / webpac / trunk / filter / mem_lookup.pm @ HEAD

# this filter is used to find narrower terms in thesaurus which has
# only broader terms defined
#
# it's general purpose memory lookup filter actually with following
# sintax:
#
# prefix syntax before key value is arbitrary. I use here "d" to denote
# display value and "a" to denote array (although they are stored the
# same: as array with one or more elements)
# 
# store operations:
# key: d900, val: 250 (what to display)
# <isis filter="mem_lookup">d900 => 250</isis>
# key: a4611, val: 900 (parent fields has childs)
# <isis filter="mem_lookup">a4611 => 900</isis>
# 
# lookup:
# key: a900 (lookup array, delimited by delimiters in one line)
# <isis filter="mem_lookup" type="display">[a900]</isis>
# 
# - each key can have more than one value
# - storing something into lookup WON'T return any value to
#   indexer, so it's save to leave type="" undefiend
# - lookup will (of course) return one or more values

use warnings;
use strict;

sub mem_lookup {
	my @out;
	foreach (@_) {
		if (/^(.+)\s=>\s(.+)$/) {
			my ($k,$v) = ($1,$2);
			# store in array if it doesn't exist
			if (! grep(/^\Q$v\E$/, @{$main::cache->{mem_lookup}->{$k}})) {
				push @{$main::cache->{mem_lookup}->{$k}}, $v;
#print STDERR "## mem_lookup store: $k => $v [",join("|",@{$main::cache->{mem_lookup}->{$k}}),"]\n";
			}
		} elsif (/^(.*)\[([^\[]*)\[([^\[\]]+)\]([^\]]*)\](.*)$/) {
			# indirect lookup [prefix[key]suffix]
			my ($pre,$prek,$k,$postk,$post) = ($1,$2,$3,$4,$5);
			if ($main::cache->{mem_lookup}->{$k}) {
				my @keys = @{$main::cache->{mem_lookup}->{$k}};
#print STDERR "## mem_lookup fetch keys $pre|$prek|$k|$postk|$post == [".join("|",@keys)."]\n";
				foreach my $k2 (@keys) {
					my $full_k = $prek.$k2.$postk;
					if ($main::cache->{mem_lookup}->{$full_k}) {
						foreach my $v (@{$main::cache->{mem_lookup}->{$full_k}}) {
							my ($pret,$postt) = ($pre,$post);
							$pret=~s/\[$k\]/$k2/g;
							$postt=~s/\[$k\]/$k2/g;
							push @out,$pret.$v.$postt;
						}
					}
				}
#print STDERR "## mem_lookup return values $pre\[$prek\[$k\]$postk\]$post == [".join("|",@out)."]\n";

			}
		} elsif (/^(.*)\[([^\[\]]+)\](.*)$/) {
			# direct lookup [key]
			my ($pre,$k,$post) = ($1,$2,$3);
			if ($main::cache->{mem_lookup}->{$k}) {
#print STDERR "## mem_lookup fetch $k == ".join("|",@{$main::cache->{mem_lookup}->{$k}})."\n";
				foreach my $v (@{$main::cache->{mem_lookup}->{$k}}) {
					push @out,$pre.$v.$post;
				}
			}
#print STDERR "## mem_lookup return values $k == ".join("|",@out)."\n";

		} else {
			# value is undef
			#warn "mem_lookup: invalid filter specification: '$_'";
		}
	}
#print STDERR "mem_lookup dump: ",Dumper($main::cache->{mem_lookup}),"\n";
#print STDERR "out: ".Dumper(@out)."\n" if (@out);
	return wantarray ? @out : shift @out;
}

1;