lib/Net/Z3950/PQF.pm

   1 # $Id: PQF.pm,v 1.7 2004-12-23 10:24:12 mike Exp $
   2
   3 package Net::Z3950::PQF;
   4
   5 use 5.006;
   6 use strict;
   7 use warnings;
   8
   9 use Net::Z3950::PQF::Node;
  10
  11 our $VERSION = '0.03';
  12
  13
  14 =head1 NAME
  15
  16 Net::Z3950::PQF - Perl extension for parsing PQF (Prefix Query Format)
  17
  18 =head1 SYNOPSIS
  19
  20  use Net::Z3950::PQF;
  21  $parser = new Net::Z3950::PQF();
  22  $node = $parser->parse('@and @attr 1=1003 kernighan @attr 1=4 unix');
  23  print $node->render(0);
  24
  25 =head1 DESCRIPTION
  26
  27 This library provides a parser for PQF (Prefix Query Format), an ugly
  28 but precise string format for expressing Z39.50 Type-1 queries.  This
  29 format is widely used behind the scenes of Z39.50 applications, and is
  30 also used extensively with test-harness programs such as the YAZ
  31 command-line client, C<yaz-client>.  A few particularly misguided
  32 souls have been known to type it by hand.
  33
  34 Unlike PQF itself, this module
  35 is simple to use.  Create a parser object, then pass PQF strings
  36 into its C<parse()> method to yield parse-trees.  The trees are made
  37 up of nodes whose types are subclasses of
  38 C<Net::Z3950::PQF::Node>.
  39 and have names of the form
  40 C<Net::Z3950::PQF::somethingNode>.  You may find it helpful to use
  41 C<Data::Dumper> to visualise the structure of the returned
  42 parse-trees.
  43
  44 What is a PQF parse-tree good for?  Not much.  You can render a
  45 human-readable version by invoking the top node's C<render()> method,
  46 which is probably useful only for debugging.  If you want to do
  47 anything useful, such as implementing an actual query server that
  48 understands PQF, you'll have to walk the tree.
  49
  50 =head1 METHODS
  51
  52 =head2 new()
  53
  54  $parser = new Net::Z3950::PQF();
  55
  56 Creates a new parser object.
  57
  58 =cut
  59
  60 sub new {
  61     my $class = shift();
  62
  63     return bless {
  64         text => undef,
  65         errmsg => undef,
  66     }, $class;
  67 }
  68
  69
  70 =head2 parse()
  71
  72  $query = '@and @attr 1=1003 kernighan @attr 1=4 unix';
  73  $node = $parser->parse($query);
  74  if (!defined $node) {
  75      die "parse($query) failed: " . $parser->errmsg();
  76  }
  77
  78 Parses the PQF string provided as its argument.  If an error occurs,
  79 then an undefined value is returned, and the error message can be
  80 obtained by calling the C<errmsg()> method.  Otherwise, the top node
  81 of the parse tree is returned.
  82
  83  $node2 = $parser->parse($query, "zthes");
  84  $node3 = $parser->parse($query, "1.2.840.10003.3.13");
  85
  86 A second argument may be provided after the query itself.  If it is
  87 provided, then it is taken to be either the name or the OID of a
  88 default attribute set, which attributes specified in the query belong
  89 to if no alternative attribute set is explicitly specified within the
  90 query.  When this second argument is absent, the default attribute set
  91 is BIB-1.
  92
  93 =cut
  94
  95 sub parse {
  96     my $this = shift();
  97     my($text, $attrset) = @_;
  98     $attrset = "bib-1" if !defined $attrset;
  99
 100     $this->{text} = $text;
 101     return $this->_parse($attrset, {});
 102 }
 103
 104
 105 # PRIVATE to parse();
 106 #
 107 # Underlying parse function.  $attrset is the default attribute-set to
 108 # use for attributes that are not specified with an explicit set, and
 109 # $attrhash is hash of attributes (at most one per type per
 110 # attribute-set) to be applied to all nodes below this point.  The
 111 # keys of this hash are of the form "<attrset>:<type>" and the values
 112 # are the corresponding attribute values.
 113 #
 114 sub _parse {
 115     my $this = shift();
 116     my($attrset, $attrhash) = @_;
 117
 118     $this->{text} =~ s/^\s+//;
 119
 120     ### This rather nasty hack for quoted terms doesn't recognised
 121     #   backslash-quoted embedded double quotes.
 122     if ($this->{text} =~ s/^"(.*?)"//) {
 123         return $this->_leaf('term', $1, $attrhash);
 124     }
 125
 126     # Also recognise multi-word terms enclosed in {curly braces}
 127     if ($this->{text} =~ s/^{(.*?)}//) {
 128         return $this->_leaf('term', $1, $attrhash);
 129     }
 130
 131     my $word = $this->_word();
 132     if ($word eq '@attrset') {
 133         $attrset = $this->_word();
 134         return $this->_parse($attrset, $attrhash);
 135
 136     } elsif ($word eq '@attr') {
 137         $word = $this->_word();
 138         if ($word !~ /=/) {
 139             $attrset = $word;
 140             $word = $this->_word();
 141         }
 142         my($type, $val) = ($word =~ /(.*)=(.*)/);
 143         my %h = %$attrhash;
 144         $h{"$attrset:$type"} = $val;
 145         return $this->_parse($attrset, \%h);
 146
 147     } elsif ($word eq '@and' || $word eq '@or' || $word eq '@not') {
 148         my $sub1 = $this->_parse($attrset, $attrhash);
 149         my $sub2 = $this->_parse($attrset, $attrhash);
 150         if ($word eq '@and') {
 151             return new Net::Z3950::PQF::AndNode($sub1, $sub2);
 152         } elsif ($word eq '@or') {
 153             return new Net::Z3950::PQF::OrNode($sub1, $sub2);
 154         } elsif ($word eq '@not') {
 155             return new Net::Z3950::PQF::NotNode($sub1, $sub2);
 156         } else {
 157             die "Houston, we have a problem";
 158         }
 159
 160     } elsif ($word eq '@prox') {
 161         return $this->_error("proximity not yet implemented");
 162
 163     } elsif ($word eq '@set') {
 164         $word = $this->_word();
 165         return $this->_leaf('rset', $word, $attrhash);
 166     }
 167
 168     # It must be a bareword
 169     return $this->_leaf('term', $word, $attrhash);
 170 }
 171
 172
 173 # PRIVATE to _parse();
 174 sub _word {
 175     my $this = shift();
 176
 177     $this->{text} =~ s/^\s+//;
 178     $this->{text} =~ s/^(\S+)//;
 179     return $1;
 180 }
 181
 182
 183 # PRIVATE to _parse();
 184 sub _error {
 185     my $this = shift();
 186     my (@msg) = @_;
 187
 188     $this->{errmsg} = join("", @msg);
 189     return undef;
 190 }
 191
 192
 193 # PRIVATE to _parse();
 194 sub _leaf {
 195     my $this = shift();
 196     my($type, $word, $attrhash) = @_;
 197
 198     my @attrs;
 199     foreach my $key (sort keys %$attrhash) {
 200         my($attrset, $type) = split /:/, $key;
 201         push @attrs, [ $attrset, $type, $attrhash->{$key} ];
 202     }
 203
 204     if ($type eq 'term') {
 205         return new Net::Z3950::PQF::TermNode($word, @attrs);
 206     } elsif ($type eq 'rset') {
 207         return new Net::Z3950::PQF::RsetNode($word, @attrs);
 208     } else {
 209         die "_leaf() called with type='$type' (should be 'term' or 'rset')";
 210     }
 211 }
 212
 213
 214 =head2 errmsg()
 215
 216  print $parser->errmsg();
 217
 218 Returns the last error-message generated by a failed attempt to parse
 219 a query.
 220
 221 =cut
 222
 223 sub errmsg {
 224     my $this = shift();
 225     return $this->{errmsg};
 226 }
 227
 228
 229 =head1 SEE ALSO
 230
 231 The C<Net::Z3950::PQF::Node> module.
 232
 233 The definition of the Type-1 query in the Z39.50 standard, the
 234 relevant section of which is on-line at
 235 http://www.loc.gov/z3950/agency/markup/09.html#3.7
 236
 237 The documentation of Prefix Query Format in the YAZ Manual, the
 238 relevant section of which is on-line at
 239 http://indexdata.com/yaz/doc/tools.tkl#PQF
 240
 241 =head1 AUTHOR
 242
 243 Mike Taylor, E<lt>mike@indexdata.comE<gt>
 244
 245 =head1 COPYRIGHT AND LICENSE
 246
 247 Copyright 2004 by Index Data ApS.
 248
 249 This library is free software; you can redistribute it and/or modify
 250 it under the same terms as Perl itself.
 251
 252 =cut
 253
 254
 255 1;