Added a simple Perl module for connecting to search server and parsing

its results to Perl data structures, converting nested structures and
multiple-valued attributes to arrays.

Also includes the print_tree function which has been originally written
as simple debugging dumper for the parsed query results, but in fact
it's able to dump any complex Perl data structure as long as it's
acyclic.

More to come, including an example (a very simple front-end for the
free version and maybe some more debugging tools).

diff --git a/lib/perl/Makefile b/lib/perl/Makefile
index 580319abf107dc6487fe9bd0599f7735d07f90fc..f0bddeebe97e6e8a3a4c0631e2afd11aa2d0e67a 100644 (file)
--- a/lib/perl/Makefile
+++ b/lib/perl/Makefile
@@ -1,4 +1,4 @@
 # Perl modules
 
 DIRS+=lib/perl
-PROGS+=obj/lib/perl/Config.pm
+PROGS+=$(addprefix obj/lib/perl/,Config.pm Query.pm)

diff --git a/lib/perl/Query.pm b/lib/perl/Query.pm
new file mode 100644 (file)
index 0000000..ed88810
--- /dev/null
+++ b/lib/perl/Query.pm
@@ -0,0 +1,192 @@
+#      Perl module for sending queries to Sherlock search servers and parsing answers
+#
+#      (c) 2002 Martin Mares <mj@ucw.cz>
+#
+#      This software may be freely distributed and used according to the terms
+#      of the GNU Lesser General Public License.
+
+package Sherlock::Query;
+
+use strict;
+use warnings;
+use IO::Socket::INET;
+
+sub parse_tree($$);
+sub do_parse_tree($$$$);
+sub print_tree($$);
+
+sub new($$) {
+       my $class = shift @_;
+       my $server = shift @_;
+       my $self = {
+               SERVER  => $server
+       };
+       bless $self;
+       return $self;
+}
+
+sub command($$) {
+       my ($q,$string) = @_;
+
+       $q->{RAW} = [];
+
+       my $sock = IO::Socket::INET->new(PeerAddr => $q->{SERVER}, Proto => 'tcp')
+               or return "900 Cannot connect to search server: $!";
+       print $sock $string, "\n";
+
+       # Status line
+       my $res = <$sock>;
+       $res =~ /^-(.*)/ and return $1;
+       $res =~ /^\+/ or return "901 Reply parse error";
+
+       # Blocks of output
+       my $block = undef;
+       for(;;) {
+               $res = <$sock>;
+               last if $sock->eof;
+               chomp $res;
+               if ($res eq "") {
+                       $block = undef;
+               } else {
+                       if (!defined $block) {
+                               $block = [];
+                               push @{$q->{RAW}}, $block;
+                       }
+                       push @$block, $res;
+               }
+       }
+
+       return "";
+}
+
+my $hdr_syntax = {
+       'D' => {
+               'D' => "",
+               'W' => [],
+               'P' => [],
+               'n' => [],
+               'T' => "",
+               '-' => "",
+               '.' => [],
+       },
+       '.' => [],
+       '' => ""
+};
+
+my $card_syntax = {
+       'U' => {
+               'U' => "",
+               'D' => "",
+               'E' => "",
+               'L' => "",
+               'T' => "",
+               'c' => "",
+               's' => "",
+               'V' => [],
+               'b' => "",
+               'i' => "",
+               'y' => [],
+               'z' => "",
+       },
+       'M' => [],
+       'X' => [],
+       '' => ""
+};
+
+my $footer_syntax = {
+       '' => ""
+};
+
+sub query($$) {
+       my ($q,$string) = @_;
+
+       # Send the query and gather results
+       if (my $err = $q->command($string)) { return $err; }
+       my $raw = $q->{RAW};
+       @$raw > 0 or return "902 Reply truncated";
+
+       # Split results to header, cards and footer
+       $q->{HEADER} = { RAW => shift @$raw };
+       $q->{FOOTER} = { RAW => [] };
+       if (@$raw && $raw->[@$raw-1]->[0] =~ /^\+/) {
+               $q->{FOOTER}{RAW} = pop @$raw;
+       }
+       $q->{CARDS} = [];
+       while (my $r = shift @$raw) {
+               push @{$q->{CARDS}}, { RAW => $r };
+       }
+
+       # Parse everything
+       parse_tree($q->{HEADER}, $hdr_syntax);
+       foreach my $c (@{$q->{CARDS}}) {
+               parse_tree($c, $card_syntax);
+       }
+       parse_tree($q->{FOOTER}, $footer_syntax);
+
+       # OK
+       return "";
+}
+
+sub parse_tree($$) {
+       my $tree = shift @_;
+       my $syntax = shift @_;
+       do_parse_tree($tree->{RAW}, 0, $tree, $syntax);
+}
+
+sub do_parse_tree($$$$) {
+       my $raw = shift @_;
+       my $i = shift @_;
+       my $cooked = shift @_;
+       my $syntax = shift @_;
+
+       while ($i < @$raw) {
+               $raw->[$i] =~ /^(.)(.*)/;
+               if (!defined($syntax->{$1}) && !defined($syntax->{''})) { return $i; }
+               if (ref $syntax->{$1} eq "ARRAY") {
+                       push @{$cooked->{$1}}, $2;
+                       $i++;
+               } elsif (ref $syntax->{$1} eq "HASH") {
+                       my $block = {};
+                       push @{$cooked->{$1}}, $block;
+                       $i = do_parse_tree($raw, $i, $block, $syntax->{$1});
+               } else {
+                       $cooked->{$1} = $2;
+                       $i++;
+               }
+       }
+}
+
+sub print_tree($$) {
+       my $a = shift @_;
+       my $indent = shift @_;
+
+       if (ref $a eq "ARRAY") {
+               if (@{$a} == 0) { print "[]\n"; }
+               else {
+                       print "[\n";
+                       foreach my $k (@{$a}) {
+                               print "$indent\t";
+                               print_tree($k, "$indent\t");
+                       }
+                       print $indent, "]\n";
+               }
+       } elsif (ref $a) {
+               print "{\n";
+               foreach my $k (sort keys %{$a}) {
+                       print "$indent\t$k => ";
+                       print_tree($a->{$k}, "$indent\t");
+               }
+               print $indent, "}\n";
+       } elsif (defined $a) {
+               print "$a\n";
+       } else {
+               print "UNDEF\n";
+       }
+}
+
+sub print($) {
+       my $q = shift @_;
+       print_tree($q, "");
+}
+
+1;  # OK