From fb981d17207f1c86f2a20aad717239f5c6b827d2 Mon Sep 17 00:00:00 2001
From: Martin Mares <mj@ucw.cz>
Date: Mon, 2 Sep 2002 19:38:09 +0000
Subject: [PATCH] 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).
---
 lib/perl/Makefile |   2 +-
 lib/perl/Query.pm | 192 ++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 193 insertions(+), 1 deletion(-)
 create mode 100644 lib/perl/Query.pm

diff --git a/lib/perl/Makefile b/lib/perl/Makefile
index 580319ab..f0bddeeb 100644
--- 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
index 00000000..ed888102
--- /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
-- 
2.39.2