Implement the parser. Everyting except proximity nodes (who uses

them?) and quoted terms that include blackslash-quoted embedded
quotes.

diff --git a/lib/Net/Z3950/PQF.pm b/lib/Net/Z3950/PQF.pm
index 92aae90..bbdbc9e 100644 (file)
--- a/lib/Net/Z3950/PQF.pm
+++ b/lib/Net/Z3950/PQF.pm
@@ -1,4 +1,4 @@
-# $Id: PQF.pm,v 1.2 2004-12-17 15:28:30 mike Exp $
+# $Id: PQF.pm,v 1.3 2004-12-17 16:58:09 mike Exp $

 
 package Net::Z3950::PQF;
 
 
 package Net::Z3950::PQF;
 

@@ -59,6 +59,7 @@ sub new {
     my $class = shift();
 
     return bless {
     my $class = shift();
 
     return bless {

+       text => undef,

        errmsg => undef,
     }, $class;
 }
        errmsg => undef,
     }, $class;
 }

@@ -70,7 +71,7 @@ sub new {
  $node = $parser->parse($query);
  if (!defined $node)
      die "parse($query) failed: " . $parser->errmsg();
  $node = $parser->parse($query);
  if (!defined $node)
      die "parse($query) failed: " . $parser->errmsg();

- } 
+ }

 
 Parses the PQF string provided as its argument.  If an error occurs,
 then an undefined value is returned, and the error message can be
 
 Parses the PQF string provided as its argument.  If an error occurs,
 then an undefined value is returned, and the error message can be

@@ -90,10 +91,105 @@ second argument is absent, the default attribute set is BIB-1.
 
 sub parse {
     my $this = shift();
 
 sub parse {
     my $this = shift();

-    my($attrset) = @_;
+    my($text, $attrset) = @_;

     $attrset = "bib-1" if !defined $attrset;
 
     $attrset = "bib-1" if !defined $attrset;
 

-    die "parse($this) not yet implemented";
+    $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 rather nasty hack for quoted terms doesn't recognised
+    #  backslash-quoted embedded double quotes.
+    $this->{text} =~ s/^\s+//;
+    if ($this->{text} =~ s/^"(.*?)"//) {
+       return $this->_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");
+
+    }
+
+    # It must be a bareword
+    return $this->_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 _term {
+    my $this = shift();
+    my($word, $attrhash) = @_;
+
+    my @attrs;
+    foreach my $key (sort keys %$attrhash) {
+       my($attrset, $type) = split /:/, $key;
+       push @attrs, [ $attrset, $type, $attrhash->{$key} ];
+    }
+
+    return new Net::Z3950::PQF::TermNode($word, @attrs);

 }
 
 
 }
 
 

@@ -128,7 +224,7 @@ Mike Taylor, E<lt>mike@indexdata.comE<gt>
 Copyright 2004 by Index Data ApS.
 
 This library is free software; you can redistribute it and/or modify
 Copyright 2004 by Index Data ApS.
 
 This library is free software; you can redistribute it and/or modify

-it under the same terms as Perl itself. 
+it under the same terms as Perl itself.

 
 =cut
 
 
 =cut