+ $this->{text} = $text;
+ return $this->_parse($attrset, {});
+}
+
+
+# PRIVATE to parse();
+#
+# Underlying parse function. $attrset is the default attribute-set to
+# use for attributes that are not specified with an explicit set, and
+# $attrhash is hash of attributes (at most one per type per
+# attribute-set) to be applied to all nodes below this point. The
+# keys of this hash are of the form "<attrset>:<type>" and the values
+# are the corresponding attribute values.
+#
+sub _parse {
+ my $this = shift();
+ my($attrset, $attrhash) = @_;
+
+ $this->{text} =~ s/^\s+//;
+
+ ### This rather nasty hack for quoted terms doesn't recognised
+ # backslash-quoted embedded double quotes.
+ if ($this->{text} =~ s/^"(.*?)"//) {
+ return $this->_leaf('term', $1, $attrhash);
+ }
+
+ # Also recognise multi-word terms enclosed in {curly braces}
+ if ($this->{text} =~ s/^{(.*?)}//) {
+ return $this->_leaf('term', $1, $attrhash);
+ }
+
+ my $word = $this->_word();
+ if ($word eq '@attrset') {
+ $attrset = $this->_word();
+ return $this->_parse($attrset, $attrhash);
+
+ } elsif ($word eq '@attr') {
+ $word = $this->_word();
+ if ($word !~ /=/) {
+ $attrset = $word;
+ $word = $this->_word();
+ }
+ my($type, $val) = ($word =~ /(.*)=(.*)/);
+ my %h = %$attrhash;
+ $h{"$attrset:$type"} = $val;
+ return $this->_parse($attrset, \%h);
+
+ } elsif ($word eq '@and' || $word eq '@or' || $word eq '@not') {
+ my $sub1 = $this->_parse($attrset, $attrhash);
+ my $sub2 = $this->_parse($attrset, $attrhash);
+ if ($word eq '@and') {
+ return new Net::Z3950::PQF::AndNode($sub1, $sub2);
+ } elsif ($word eq '@or') {
+ return new Net::Z3950::PQF::OrNode($sub1, $sub2);
+ } elsif ($word eq '@not') {
+ return new Net::Z3950::PQF::NotNode($sub1, $sub2);
+ } else {
+ die "Houston, we have a problem";
+ }
+
+ } elsif ($word eq '@prox') {
+ return $this->_error("proximity not yet implemented");
+
+ } elsif ($word eq '@set') {
+ $word = $this->_word();
+ return $this->_leaf('rset', $word, $attrhash);
+ }
+
+ # It must be a bareword
+ return $this->_leaf('term', $word, $attrhash);
+}
+
+
+# PRIVATE to _parse();
+sub _word {
+ my $this = shift();
+
+ $this->{text} =~ s/^\s+//;
+ $this->{text} =~ s/^(\S+)//;
+ return $1;
+}
+
+
+# PRIVATE to _parse();
+sub _error {
+ my $this = shift();
+ my (@msg) = @_;
+
+ $this->{errmsg} = join("", @msg);
+ return undef;
+}
+
+
+# PRIVATE to _parse();
+sub _leaf {
+ my $this = shift();
+ my($type, $word, $attrhash) = @_;
+
+ my @attrs;
+ foreach my $key (sort keys %$attrhash) {
+ my($attrset, $type) = split /:/, $key;
+ push @attrs, [ $attrset, $type, $attrhash->{$key} ];
+ }
+
+ if ($type eq 'term') {
+ return new Net::Z3950::PQF::TermNode($word, @attrs);
+ } elsif ($type eq 'rset') {
+ return new Net::Z3950::PQF::RsetNode($word, @attrs);
+ } else {
+ die "_leaf() called with type='$type' (should be 'term' or 'rset')";
+ }
projects / perl-pqf.git / blobdiff