lib/Net/Z3950/PQF.pm

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