lib/perl/Query.pm

   1 #       Perl module for sending queries to Sherlock search servers and parsing answers
   2 #
   3 #       (c) 2002 Martin Mares <mj@ucw.cz>
   4 #
   5 #       This software may be freely distributed and used according to the terms
   6 #       of the GNU Lesser General Public License.
   7
   8 package Sherlock::Query;
   9
  10 use strict;
  11 use warnings;
  12 use IO::Socket::INET;
  13
  14 sub parse_tree($$);
  15 sub do_parse_tree($$$$);
  16 sub print_tree($$);
  17
  18 sub new($$) {
  19         my $class = shift @_;
  20         my $server = shift @_;
  21         my $self = {
  22                 SERVER  => $server
  23         };
  24         bless $self;
  25         return $self;
  26 }
  27
  28 sub command($$) {
  29         my ($q,$string) = @_;
  30
  31         $q->{RAW} = [];
  32
  33         my $sock = IO::Socket::INET->new(PeerAddr => $q->{SERVER}, Proto => 'tcp')
  34                 or return "900 Cannot connect to search server: $!";
  35         print $sock $string, "\n";
  36
  37         # Status line
  38         my $res = <$sock>;
  39         $res =~ /^-(.*)/ and return $1;
  40         $res =~ /^\+/ or return "901 Reply parse error";
  41
  42         # Blocks of output
  43         my $block = undef;
  44         for(;;) {
  45                 $res = <$sock>;
  46                 last if $sock->eof;
  47                 chomp $res;
  48                 if ($res eq "") {
  49                         $block = undef;
  50                 } else {
  51                         if (!defined $block) {
  52                                 $block = [];
  53                                 push @{$q->{RAW}}, $block;
  54                         }
  55                         push @$block, $res;
  56                 }
  57         }
  58
  59         return "";
  60 }
  61
  62 my $hdr_syntax = {
  63         'D' => {
  64                 'D' => "",
  65                 'W' => [],
  66                 'P' => [],
  67                 'n' => [],
  68                 'T' => "",
  69                 '-' => "",
  70                 '.' => [],
  71         },
  72         '.' => [],
  73         '' => ""
  74 };
  75
  76 my $card_syntax = {
  77         'U' => {
  78                 'U' => "",
  79                 'D' => "",
  80                 'E' => "",
  81                 'L' => "",
  82                 'T' => "",
  83                 'c' => "",
  84                 's' => "",
  85                 'V' => [],
  86                 'b' => "",
  87                 'i' => "",
  88                 'y' => [],
  89                 'z' => "",
  90         },
  91         'M' => [],
  92         'X' => [],
  93         '' => ""
  94 };
  95
  96 my $footer_syntax = {
  97         '' => ""
  98 };
  99
 100 sub query($$) {
 101         my ($q,$string) = @_;
 102
 103         # Send the query and gather results
 104         if (my $err = $q->command($string)) { return $err; }
 105         my $raw = $q->{RAW};
 106         @$raw > 0 or return "902 Reply truncated";
 107
 108         # Split results to header, cards and footer
 109         $q->{HEADER} = { RAW => shift @$raw };
 110         $q->{FOOTER} = { RAW => [] };
 111         if (@$raw && $raw->[@$raw-1]->[0] =~ /^\+/) {
 112                 $q->{FOOTER}{RAW} = pop @$raw;
 113         }
 114         $q->{CARDS} = [];
 115         while (my $r = shift @$raw) {
 116                 push @{$q->{CARDS}}, { RAW => $r };
 117         }
 118
 119         # Parse everything
 120         parse_tree($q->{HEADER}, $hdr_syntax);
 121         foreach my $c (@{$q->{CARDS}}) {
 122                 parse_tree($c, $card_syntax);
 123         }
 124         parse_tree($q->{FOOTER}, $footer_syntax);
 125
 126         # OK
 127         return "";
 128 }
 129
 130 sub parse_tree($$) {
 131         my $tree = shift @_;
 132         my $syntax = shift @_;
 133         do_parse_tree($tree->{RAW}, 0, $tree, $syntax);
 134 }
 135
 136 sub do_parse_tree($$$$) {
 137         my $raw = shift @_;
 138         my $i = shift @_;
 139         my $cooked = shift @_;
 140         my $syntax = shift @_;
 141
 142         while ($i < @$raw) {
 143                 $raw->[$i] =~ /^(.)(.*)/;
 144                 if (!defined($syntax->{$1}) && !defined($syntax->{''})) { return $i; }
 145                 if (ref $syntax->{$1} eq "ARRAY") {
 146                         push @{$cooked->{$1}}, $2;
 147                         $i++;
 148                 } elsif (ref $syntax->{$1} eq "HASH") {
 149                         my $block = {};
 150                         push @{$cooked->{$1}}, $block;
 151                         $i = do_parse_tree($raw, $i, $block, $syntax->{$1});
 152                 } else {
 153                         $cooked->{$1} = $2;
 154                         $i++;
 155                 }
 156         }
 157 }
 158
 159 sub print_tree($$) {
 160         my $a = shift @_;
 161         my $indent = shift @_;
 162
 163         if (ref $a eq "ARRAY") {
 164                 if (@{$a} == 0) { print "[]\n"; }
 165                 else {
 166                         print "[\n";
 167                         foreach my $k (@{$a}) {
 168                                 print "$indent\t";
 169                                 print_tree($k, "$indent\t");
 170                         }
 171                         print $indent, "]\n";
 172                 }
 173         } elsif (ref $a) {
 174                 print "{\n";
 175                 foreach my $k (sort keys %{$a}) {
 176                         print "$indent\t$k => ";
 177                         print_tree($a->{$k}, "$indent\t");
 178                 }
 179                 print $indent, "}\n";
 180         } elsif (defined $a) {
 181                 print "$a\n";
 182         } else {
 183                 print "UNDEF\n";
 184         }
 185 }
 186
 187 sub print($) {
 188         my $q = shift @_;
 189         print_tree($q, "");
 190 }
 191
 192 1;  # OK