From: Martin Mares <mj@ucw.cz>
Date: Sat, 11 Dec 2004 11:41:06 +0000 (+0000)
Subject: Moved CGI.pm and Query.pm to Sherlock library.
X-Git-Tag: holmes-import~855
X-Git-Url: http://mj.ucw.cz/gitweb/?a=commitdiff_plain;h=b63ec31b9272a50ffbfdd58afed9630e70eab517;p=libucw.git

Moved CGI.pm and Query.pm to Sherlock library.
---

diff --git a/lib/perl/CGI.pm b/lib/perl/CGI.pm
deleted file mode 100644
index aeb6c505..00000000
--- a/lib/perl/CGI.pm
+++ /dev/null
@@ -1,129 +0,0 @@
-#	Poor Man's CGI Module for Perl
-#
-#	(c) 2002 Martin Mares <mj@ucw.cz>
-#	Slightly modified by Tomas Valla <tom@ucw.cz>
-#
-#	This software may be freely distributed and used according to the terms
-#	of the GNU Lesser General Public License.
-
-package Sherlock::CGI;
-
-use strict;
-use warnings;
-
-BEGIN {
-	# The somewhat hairy Perl export mechanism
-	use Exporter();
-	our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
-	$VERSION = 1.0;
-	@ISA = qw(Exporter);
-	@EXPORT = qw(&html_escape &url_escape &self_ref &self_form);
-	@EXPORT_OK = qw();
-	%EXPORT_TAGS = ();
-}
-
-sub url_escape($) {
-	my $x = shift @_;
-	$x =~ s/([^-\$_.!*'(),0-9A-Za-z\x80-\xff])/"%".unpack('H2',$1)/ge;
-	return $x;
-}
-
-sub html_escape($) {
-	my $x = shift @_;
-	$x =~ s/&/&amp;/g;
-	$x =~ s/</&lt;/g;
-	$x =~ s/>/&gt;/g;
-	$x =~ s/"/&quot;/g;
-	return $x;
-}
-
-our $arg_table;
-
-sub parse_arg_string($) {
-	my ($s) = @_;
-	$s =~ s/\s+//;
-	foreach $_ (split /[&:]/,$s) {
-		(/^([^=]+)=(.*)$/) or next;
-		my $arg = $arg_table->{$1} or next;
-		$_ = $2;
-		s/\+/ /g;
-		s/%(..)/pack("c",hex $1)/eg;
-		s/(\r|\n|\t)/ /g;
-		s/^\s+//;
-		s/\s+$//;
-		if (my $rx = $arg->{'check'}) {
-			if (!/^$rx$/) { $_ = $arg->{'default'}; }
-		}
-		
-		my $r = ref($arg->{'var'});
-		if ($r eq 'SCALAR') {
-			${$arg->{'var'}} = $_;
-		} elsif ($r eq 'ARRAY') {
-			push @{$arg->{'var'}}, $_;
-		}
-	}
-}
-
-sub parse_args($) {
-	$arg_table = shift @_;
-	foreach my $a (values %$arg_table) {
-		my $r = ref($a->{'var'});
-		defined($a->{'default'}) or $a->{'default'}="";
-		if ($r eq 'SCALAR') {
-			${$a->{'var'}} = $a->{'default'};
-		} elsif ($r eq 'ARRAY') {
-			@{$a->{'var'}} = ();
-		}
-	}
-	defined $ENV{"GATEWAY_INTERFACE"} or die "Not called as a CGI script";
-	my $method = $ENV{"REQUEST_METHOD"};
-	if ($method eq "GET") {
-		parse_arg_string($ENV{"QUERY_STRING"});
-	} elsif ($method eq "POST") {
-		if ($ENV{"CONTENT_TYPE"} =~ /^application\/x-www-form-urlencoded\b/i) {
-			while (<STDIN>) {
-				chomp;
-				parse_arg_string($_);
-			}
-		} else {
-			return "Unknown content type for POST data";
-		}
-	} else {
-		return "Unknown request method";
-	}
-}
-
-sub make_out_args($) {
-	my ($overrides) = @_;
-	my $out = {};
-	foreach my $name (keys %$arg_table) {
-		my $arg = $arg_table->{$name};
-		defined $arg->{'pass'} && !$arg->{'pass'} && !exists $overrides->{$name} && next;
-		my $value;
-		if (!defined($value = $overrides->{$name})) {
-			if (exists $overrides->{$name}) {
-				$value = $arg->{'default'};
-			} else {
-				$value = ${$arg->{'var'}};
-			}
-		}
-		if ($value ne $arg->{'default'}) {
-			$out->{$name} = $value;
-		}
-	}
-	return $out;
-}
-
-sub self_ref(@) {
-	my %h = @_;
-	my $out = make_out_args(\%h);
-	return "?" . join(':', map { "$_=" . url_escape($out->{$_}) } sort keys %$out);
-}
-
-sub self_form(@) {
-	my %h = @_;
-	my $out = make_out_args(\%h);
-	return join('', map { "<input type=hidden name=$_ value='" . html_escape($out->{$_}) . "'>\n" } sort keys %$out);
-}
-
-1;  # OK
diff --git a/lib/perl/Makefile b/lib/perl/Makefile
index eceb6f69..3ddce873 100644
--- a/lib/perl/Makefile
+++ b/lib/perl/Makefile
@@ -1,7 +1,7 @@
 # Perl modules
 
 DIRS+=lib/perl
-PROGS+=$(addprefix obj/lib/perl/,Config.pm Query.pm CGI.pm)
+PROGS+=$(addprefix obj/lib/perl/,Config.pm)
 
 ifdef CONFIG_WATSON
 include lib/perl/Ulimit/Makefile
diff --git a/lib/perl/Query.pm b/lib/perl/Query.pm
deleted file mode 100644
index a25fcd5f..00000000
--- a/lib/perl/Query.pm
+++ /dev/null
@@ -1,264 +0,0 @@
-#	Perl module for sending queries to Sherlock search servers and parsing answers
-#
-#	(c) 2002--2003 Martin Mares <mj@ucw.cz>
-#
-#	This software may be freely distributed and used according to the terms
-#	of the GNU Lesser General Public License.
-
-=head1 NAME
-
-Sherlock::Query -- Communication with Sherlock Search Servers
-
-=head1 DESCRIPTION
-
-This perl library offers a simple interface for connecting to Sherlock
-search servers, sending queries or control commands and parsing the
-results.
-
-First of all, you have to use
-
-	my $conn = new Sherlock::Query('server:port');
-
-to create a new connection object (unconnected yet). Then you can call
-
-	my $res = $conn->command('command');
-
-to establish the connection, send a given command to the search server
-and gather the results (see below) or, if you want to send a normal query,
-
-	my $res = $conn->query('"simple" OR "query"');
-
-which does the same as C<< $conn->command(...) >>, but it also parses the
-results to a representation convenient for handling in Perl programs
-(again, see below).
-
-Currently, you can use a single connection to send only a single command or query.
-
-=head1 RESULTS
-
-The I<raw answer> of the search server (i.e., the lines it has returned) is always
-available as C<< $conn->{RAW} >> as a list of strings, each representing a single
-line.
-
-Parsed results of queries are stored in a more complicated way, but before
-explaining it, let's mention a couple of axioms: Any search server I<object>
-(header, footer, a single document of answer) is always stored as a hash keyed
-by attribute names. Ordinary single-valued attributes are stored as strings,
-multi-valued attributes as (references to) arrays of strings. When an object
-contains sub-objects, they are stored as references to other hashes, possibly
-encapsulated within a list if there can be multiple such objects. Most objects
-have an extra attribute C<RAW> containing the original description of the
-object, a sub-list of C<< $conn->{RAW} >>.
-
-The parsed answer consists of three parts (please follow F<doc/search> to
-get a better picture of what does the server answer): header C<< $conn->{HEADER} >>
-(an object, as described above), footer C<< $conn->{FOOTER} >> (object) and document
-cards C<< $conn->{CARDS} >> (a list of objects).
-
-The I<header> contains all the standard header attributes and also C<< $hdr->{D} >>
-which is a list of sub-objects, each corresponding to a single database and
-containing per-database attributes like C<W> (word list).
-
-The I<footer> is pretty straightforward and it just contains what you'd
-expect it to.
-
-Each I<card> contains the usual document attributes (see F<doc/objects> for
-a list) plus C<< $card->{U} >> which is a list of sub-objects corresponding
-to URL's of the document and containing per-URL attributes like C<U> (URL),
-C<s> (original size) and C<T> (content type).
-
-When in doubt, call the C<print> method which will print the whole contents
-of the connection object. It's actually a much more general (but pretty
-simple due to Perl being able to be a very introspective language) routine
-usable for dumping any acyclic Perl data structure composed of strings,
-hashes, arrays and references to them. You can access this general routine
-by calling C<format({ print; }, $what)> which dumps C<$what> and for
-each line of output it calls the given subroutine.
-
-=head1 SEE ALSO
-
-A good example of use of this module is the C<query> utility and
-of course the example front-end (F<front-end/query.cgi>).
-
-=head1 AUTHOR
-
-Martin Mares <mj@ucw.cz>
-
-=cut
-
-package Sherlock::Query;
-
-use strict;
-use warnings;
-use IO::Socket::INET;
-
-sub parse_tree($$);
-sub do_parse_tree($$$$);
-sub format_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 $stat = <$sock>;
-	$stat = "-903 Incomplete reply" if !defined $stat;
-	chomp $stat;
-	$stat =~ /^[+-]/ or return "-901 Reply parse error";
-
-	# Blocks of output
-	my $block = undef;
-	for(;;) {
-		my $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 $stat;
-}
-
-our $hdr_syntax = {
-	'(D' => {
-		'W' => [],
-		'P' => [],
-		'n' => [],
-		'.' => [],
-	},
-	'.' => [],
-};
-
-our $card_syntax = {
-	'(U' => {
-		'V' => [],
-		'y' => [],
-		'E' => [],
-	},
-	'M' => [],
-	'X' => [],
-};
-
-our $footer_syntax = {
-};
-
-sub query($$) {
-	my ($q,$string) = @_;
-
-	# Send the query and gather results
-	my $stat = $q->command($string);
-	my @raw = @{$q->{RAW}};
-
-	# Split results to header, cards and footer
-	$q->{HEADER} = { RAW => [] };
-	if (@raw) { $q->{HEADER}{RAW} = shift @raw; }
-	elsif (!$stat) { return "-902 Incomplete reply"; }
-	$q->{FOOTER} = { RAW => [] };
-	if (@raw && $raw[@raw-1]->[0] =~ /^\+/) {
-		$q->{FOOTER}{RAW} = pop @raw;
-	}
-	$q->{CARDS} = [];
-	while (@raw) {
-		push @{$q->{CARDS}}, { RAW => shift @raw };
-	}
-
-	# Parse everything
-	parse_tree($q->{HEADER}, $hdr_syntax);
-	foreach my $c (@{$q->{CARDS}}) {
-		parse_tree($c, $card_syntax);
-	}
-	parse_tree($q->{FOOTER}, $footer_syntax);
-
-	return $stat;
-}
-
-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 ($1 eq ")") {
-			return $i+1;
-		} elsif (!defined($syntax->{$1})) {
-			$cooked->{$1} = $2 if !defined($cooked->{$1});
-			$i++;
-		} elsif (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+1, $block, $syntax->{$1});
-		}
-	}
-	return $i;
-}
-
-sub format_tree($$$) {
-	my ($func, $a, $indent) = @_;
-	if (ref $a eq "ARRAY") {
-		if (@{$a} == 0) { &$func("[]\n"); }
-		else {
-			&$func("[\n");
-			foreach my $k (@{$a}) {
-				&$func("$indent\t");
-				format_tree($func, $k, "$indent\t");
-			}
-			&$func($indent . "]\n");
-		}
-	} elsif (ref $a) {
-		&$func("{\n");
-		foreach my $k (sort keys %{$a}) {
-			&$func("$indent\t$k => ");
-			format_tree($func, $a->{$k}, "$indent\t");
-		}
-		&$func($indent . "}\n");
-	} elsif (defined $a) {
-		&$func("$a\n");
-	} else {
-		&$func("UNDEF\n");
-	}
-}
-
-sub format($&$) {
-	my ($q, $func, $what) = @_;
-	format_tree($func, $what, "");
-}
-
-sub print($) {
-	my $q = shift @_;
-	format_tree(sub { print $_[0]; }, $q, "");
-}
-
-1;  # OK