[ViewVC] Annotation of: cvs/cfmaps/cfmapidx

#!/opt/bin/perl

# cfmap2idx - inverted index for deliantra maps
# Copyright (C) 2005,2007,2008 Marc Lehmann <cfmaps@schmorp.de>
#
# CFMAPIDX is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with cfmaps; if not, write to the Free Software
# Foundation, Inc. 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA

our $VERSION = '0.923';

use Deliantra;
use Deliantra::Map;

use Fcntl;
use GDBM_File;

sub escape_html($) {
   local $_ = shift;
   s/([<>&])/sprintf "&#%d;", ord $1/ge;
   $_
}

sub search {
   my (@kw) = @_;

   tie %idx, GDBM_File, ".index.dat", O_RDONLY, 0
      or die ".index.dat: $!";

   my $cnt;
   my %res;
   my @found;

   for (map lc, @kw) {
      if (exists $idx{$_}) {
         $cnt++;
         $res{$_}++ for unpack "n*", $idx{$_};
         push @found, $_;
         #warn "$_ found\n";#d#
      } else {
         #warn "$_ not found\n";#d#
      }
   }

   my @paths;

   while (my ($k, $v) = each %res) {
      next unless $v == $cnt;
      push @paths, $idx{"D" . pack "n", $k};
   }

   binmode STDOUT, ":utf8";

   print "<?xml version='1.0' encoding='utf-8'?>",
         '<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">',
         "<html xmlns='http://www.w3.org/1999/xhtml' xml:lang='en'>",
         "<head>",
            "<title>Deliantra Keyword Search</title>",
            "<link rel='stylesheet' type='text/css' media='all' href='/common.css'/>\n",
         "</head>",
         "<body>";

   print "<h1>Search results for '", (join "' &amp; '", map escape_html $_, @found), "'</h1>",
         "<p class='searchcount'>", (scalar @paths), " results found, up to 200 results shown.</p>",
         "<p class='searchresult'><ul>";

   pop @paths while @paths > 200;

   for (sort @paths) {
      print "<li><a href='$_.xhtml'>$_</a></li>";
   }

   print "</ul></p><p class='footer'>created by <a href='http://software.schmorp.de/pkg/cfmaps'>cfmapidx</a> version $VERSION</p>",
         "</body></html>";
}

if ($ARGV[0] eq "-a") {
   shift;

   tie %idx, GDBM_File, ".index.dat~", O_RDWR|O_CREAT, 0644
      or die ".index.dat~: $!";

   my %idx2;

   for my $path (@ARGV) {
      (my $base = $path) =~ s/\.map$//;
      my $docnum = pack "n", ++$idx{Vdocnum};
      $idx{"D$docnum"} = $base;
      my $meta = eval { Deliantra::Map->new_from_file ("$base.map") }
         or next;

      for my $x (0 .. $meta->{width} - 1) {
         for my $y (0 .. $meta->{height} - 1) {
            for my $a (@{ $meta->{map}[$x][$y] }) {
               delete $a->{elevation};
               for my $v (values %$a) {
                  $v = lc $v;
                  $v =~ y/a-zA-Z0-9_\-.\// /c;
                  for (split /\s+/, $v) {
                     $idx2{$_} .= $docnum;

                     if (/[_\-\.\/]/) {
                        $idx2{$_} .= $docnum for (split /[_\-\.\/]/) 
                     }
                  }
               }
            }
         }
      }
   }

   while (my ($k, $v) = each %idx2) {
      $idx{$k} = pack "n*", keys %{ { map +($_ => 1), unpack "n*", $idx{$k}.$v } };
   }

   untie %idx;

} elsif ($ARGV[0] eq "-s") {
   shift;

   search @ARGV;
} else {
   # assume CGI
#   chdir "/var/www/maps.deliantra.net" or exit 69;

   print <<EOF;
Content-Type: application/xhtml+xml

EOF
   $ENV{QUERY_STRING} =~ s/^k=//;
   search split /\s+|\++|(?:%20)+/, $ENV{QUERY_STRING};
}

Revision:	1.13
Committed:	Thu Oct 22 09:09:58 2009 UTC (16 years, 10 months ago) by root
Branch:	MAIN
Changes since 1.12:	+6 -4 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	#!/opt/bin/perl
2
3	root	1.9	# cfmap2idx - inverted index for deliantra maps
4			# Copyright (C) 2005,2007,2008 Marc Lehmann <cfmaps@schmorp.de>
5	root	1.1	#
6			# CFMAPIDX is free software; you can redistribute it and/or modify
7			# it under the terms of the GNU General Public License as published by
8			# the Free Software Foundation; either version 2 of the License, or
9			# (at your option) any later version.
10			#
11			# This program is distributed in the hope that it will be useful,
12			# but WITHOUT ANY WARRANTY; without even the implied warranty of
13			# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14			# GNU General Public License for more details.
15			#
16			# You should have received a copy of the GNU General Public License
17	root	1.6	# along with cfmaps; if not, write to the Free Software
18	root	1.1	# Foundation, Inc. 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
19
20	root	1.12	our $VERSION = '0.923';
21	root	1.1
22	root	1.9	use Deliantra;
23	elmex	1.10	use Deliantra::Map;
24	root	1.12
25			use Fcntl;
26	root	1.13	use GDBM_File;
27	root	1.1
28			sub escape_html($) {
29			local $_ = shift;
30			s/([<>&])/sprintf "&#%d;", ord $1/ge;
31			$_
32			}
33
34	root	1.3	sub search {
35			my (@kw) = @_;
36
37	root	1.13	tie %idx, GDBM_File, ".index.dat", O_RDONLY, 0
38	root	1.3	or die ".index.dat: $!";
39
40			my $cnt;
41			my %res;
42			my @found;
43
44			for (map lc, @kw) {
45			if (exists $idx{$_}) {
46			$cnt++;
47			$res{$_}++ for unpack "n*", $idx{$_};
48			push @found, $_;
49			#warn "$_ found\n";#d#
50			} else {
51			#warn "$_ not found\n";#d#
52			}
53			}
54
55			my @paths;
56
57			while (my ($k, $v) = each %res) {
58			next unless $v == $cnt;
59			push @paths, $idx{"D" . pack "n", $k};
60			}
61
62			binmode STDOUT, ":utf8";
63
64			print "<?xml version='1.0' encoding='utf-8'?>",
65			'<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">',
66			"<html xmlns='http://www.w3.org/1999/xhtml' xml:lang='en'>",
67			"<head>",
68	root	1.9	"<title>Deliantra Keyword Search</title>",
69	root	1.3	"<link rel='stylesheet' type='text/css' media='all' href='/common.css'/>\n",
70			"</head>",
71			"<body>";
72
73			print "<h1>Search results for '", (join "' & '", map escape_html $_, @found), "'</h1>",
74			"<p class='searchcount'>", (scalar @paths), " results found, up to 200 results shown.</p>",
75			"<p class='searchresult'><ul>";
76
77			pop @paths while @paths > 200;
78
79			for (sort @paths) {
80			print "<li><a href='$_.xhtml'>$_</a></li>";
81			}
82
83	root	1.5	print "</ul></p><p class='footer'>created by <a href='http://software.schmorp.de/pkg/cfmaps'>cfmapidx</a> version $VERSION</p>",
84	root	1.3	"</body></html>";
85			}
86
87	root	1.1	if ($ARGV[0] eq "-a") {
88			shift;
89
90	root	1.13	tie %idx, GDBM_File, ".index.dat~", O_RDWR\|O_CREAT, 0644
91	root	1.1	or die ".index.dat~: $!";
92
93			my %idx2;
94
95			for my $path (@ARGV) {
96	root	1.7	(my $base = $path) =~ s/\.map$//;
97	root	1.1	my $docnum = pack "n", ++$idx{Vdocnum};
98	root	1.7	$idx{"D$docnum"} = $base;
99	root	1.13	my $meta = eval { Deliantra::Map->new_from_file ("$base.map") }
100			or next;
101	root	1.1
102			for my $x (0 .. $meta->{width} - 1) {
103			for my $y (0 .. $meta->{height} - 1) {
104			for my $a (@{ $meta->{map}[$x][$y] }) {
105	root	1.13	delete $a->{elevation};
106	root	1.1	for my $v (values %$a) {
107			$v = lc $v;
108	root	1.3	$v =~ y/a-zA-Z0-9_\-.\// /c;
109	root	1.1	for (split /\s+/, $v) {
110			$idx2{$_} .= $docnum;
111
112	root	1.3	if (/[_\-\.\/]/) {
113			$idx2{$_} .= $docnum for (split /[_\-\.\/]/)
114	root	1.1	}
115			}
116			}
117			}
118			}
119			}
120			}
121
122			while (my ($k, $v) = each %idx2) {
123			$idx{$k} = pack "n", keys %{ { map +($_ => 1), unpack "n", $idx{$k}.$v } };
124			}
125
126	root	1.12	untie %idx;
127
128	root	1.1	} elsif ($ARGV[0] eq "-s") {
129			shift;
130
131	root	1.3	search @ARGV;
132			} else {
133			# assume CGI
134	root	1.12	# chdir "/var/www/maps.deliantra.net" or exit 69;
135	root	1.3
136			print <<EOF;
137			Content-Type: application/xhtml+xml
138
139			EOF
140			$ENV{QUERY_STRING} =~ s/^k=//;
141			search split /\s+\|\++\|(?:%20)+/, $ENV{QUERY_STRING};
142	root	1.1	}
143