wisdomカード検索cgi

wsearch.cgi

#!/usr/bin/perl
# (C) 2nd-player
# this script is licensed under CC BY-NC-SA 2.1 JP
# https://creativecommons.org/licenses/by-nc-sa/2.1/jp/

use utf8;
use strict;
use Encode qw/encode decode/;

BEGIN{ 
	chdir( substr($ENV{SCRIPT_FILENAME}, 0, rindex($ENV{SCRIPT_FILENAME}, "/")) ) if exists $ENV{MOD_PERL};
}

use lib './lib/';

our @wisdex;
our @wispw;
our $dbver;
my @tmp;
unless(@wisdex){
  local $/ = "\n";
  @wisdex = ();
  @wispw = ();
  open(WISDOM, '<:encoding(cp932)', 'dat/pokemon_text.dat') || die 'failed to open pokemon_text.dat';
  while($_ = <WISDOM>){
    @tmp = split(/,/, $_,12);
    $wisdex[$tmp[0]] = [@tmp] if $_ =~ /^\d/;
  }
  $dbver = $wisdex[0]->[10];
  close WISDOM;
  open(WISDOM, '<:utf8', 'dat/wispw.csv') || die 'failed to open wispw.csv';
  while($_ = <WISDOM>){
    @tmp = split(/,/, $_,3);
    next unless $_ =~ /^\d/;
    $tmp[1] =~ tr/ /_/;
    $wispw[$tmp[0]] = $tmp[1];
  }
  close WISDOM;
}

our @colors = ("", "草", "炎", "水", "雷", "超", "闘", "悪", "鋼", "無", "竜", "妖" );
#public static readonly string[] AttributeNames = new string[12]{ "", "草", "炎", "水", "雷", "超", "闘", "悪", "鋼", "無", "竜", "妖" };

######################################################
sub UrlEncodeUTF8 ($) {
# == memo ==
# unreserved characters (RFC3986):
# arabic numeral, roman alphabet, underscore, hyphen-minus, period, tilde
# see also RFC1866 section8.2.1
my $str;
$str = encode('utf8',$_[0]);
$str =~ s/([^ 0-9a-zA-Z_\-\/.~])/"%".uc(unpack("H2",$1))/eg;
$str =~ s/ /+/g;
return $str;
}

sub UrlDecodeUTF8 ($) {
my $str = $_[0];
$str =~ s/\+/ /g;
$str =~ s/%([0-9a-fA-F]{2})/pack("H2",$1)/eg;
$str = decode('utf8',$str);
return $str;
}

######################################################
my %params;
my $txt;
my $query;
if ($ENV{GATEWAY_INTERFACE}){
if ($ENV{'REQUEST_METHOD'} eq 'POST') {
	read (STDIN, $query, $ENV{'CONTENT_LENGTH'});
}else{
	$query = $ENV{QUERY_STRING};
}
}else{
$query = "q=" . UrlEncodeUTF8($ARGV[0] || "FIND") . "&n=F";
}

while ($query =~ s/([^&=]*)=([^&=]*)//) {
	if (defined $params{$1}){
		$params{$1} .= '|' . UrlDecodeUTF8($2);
	}else{
		$params{$1} = UrlDecodeUTF8($2);
	}
}
for (keys %params){
 $params{$_} =~ tr/@%&{}//d;
# "@{[expr()]}"
# qr/(?{ code })/
}
my @resultset = ();
my $searchfrom = \@wisdex;
my @re = ();
if ($params{q}){
@re = split(/ +/, $params{q});
while (@re){
my $pat = qr/$re[0]/;
shift @re;
@resultset = grep { defined($_) && (${$_}[11] =~ /$pat/) } @$searchfrom;
$searchfrom = \@resultset;
}
#[0]3363,[1]ヤミカラス,[2]悪,[3]たねポケモン,[4]70,[5]雷,[6]闘,[7]1,[8]★,[9]PCG4「金の空、銀の海」,[10]PCG4,[11]くらやみのうた(ry)
}
if ($params{c} > 0){
  my $pat = qr/$colors[$params{c}]/;
  @resultset = grep { defined($_) && (${$_}[2] =~ /$pat/) } @$searchfrom;
  $searchfrom = \@resultset;
}
if ($params{w} > 0){
  my $pat = qr/$colors[$params{w}]/;
  @resultset = grep { defined($_) && (${$_}[5] =~ /$pat/) } @$searchfrom;
  $searchfrom = \@resultset;
}
if ($params{6} > 0){
  my $pat = qr/$colors[$params{6}]/;
  @resultset = grep { defined($_) && (${$_}[2] =~ /$pat/) } @$searchfrom;
  $searchfrom = \@resultset;
}
if ($params{n}){
@re = split(/ +/, $params{n});
while (@re){
  my $pat = qr/$re[0]/;
  shift @re;
  @resultset = grep { defined($_) && (${$_}[1] =~ /$pat/) } @$searchfrom;
  $searchfrom = \@resultset;
}
}
#}
 $txt = "<h1>Wisdom-EX card search</h1>";
 $txt .= "<p>" . scalar(@resultset) . " cards</p>";
if (@resultset > 500){
 $txt .= "<p>TOO MANY RESULT! only 500 cards are listed here</p>";
  splice (@resultset, $params{o} + 500,$#resultset - 500 - $params{o},());
}
 $txt .= "<table class='bluetable'>";
 for(@resultset){
  $_->[1] = '<a href="https://wiki.xn--rckteqa2e.com/wiki/' . UrlEncodeUTF8($wispw[$_->[0]]) . '">' . $_->[1] . '</a>';
  $txt .= "<tr><td>" . join('</td><td>',@{$_}) . "</td></tr>";
 }
 $txt .= "</table>";
my @colorbox;
my $i;
for (qw/c w r/){
#$params{$_} ||= 0;
my $tmp = "<select id='$_' name='$_' size='1'>";
for $i(0 .. $#colors){
$tmp .= qq|<option value="$i"|;
$tmp .= " selected" if $params{$_} == $i;
$tmp .= ">$colors[$i]</option>";
}
$tmp .= "</select>";
push @colorbox, $tmp;
}
my $body = <<EOF;
<!DOCTYPE html>
<html><head><meta charset="UTF-8" />
<title>Tcgシミュレータ「Wisdom-EX」 カード検索[β]</title>
<link rel="stylesheet" type="text/css" href="../w.css"></head><body><p id="sitetitle"><a href="../">ポケモンWiki没資料庫 × Wisdom-EX</a></p>
$txt
<hr />
<form method="get" action="./wsearch.cgi">
<table style="min-width:100%">
<tr><th>カード名</th>
<td style="width:100%"><input id="n" type="text" name="n" value="$params{n}" style="width:100%" /></td></tr>
<tr><th style="white-space:nowrap">カード<br />テキスト</th>
<td><input id="q" type="text" name="q" value="$params{q}" style="width:100%" /></td></tr>
<tr><th>色</th><td>$colorbox[0]</td></tr>
<tr><th>弱点</th><td>$colorbox[1]</td></tr>
<tr><th>抵抗</th><td>$colorbox[2]</td></tr>
<tr><td><input type='submit' value='search' /></td></tr>
</table>
</form>
<!--$dbver-->
<hr />
<h2>about this CGI</h2>
<p>Wisdom-EXの内部DBを検索するためのCGI</p>
<ul>
<li>自分の作業用に作ったのでUIが雑なのは勘弁。</li>
<li>テキスト入力欄は空白で区切って複数語入力するとAND検索になります。</li>
<li>実は正規表現検索ですが、セキュリティの懸念から一部記号は無効化してあります。</li>
</ul>
<a href="../">back</a>
</body></html>
EOF

$body = encode('utf8', $body);
print "Content-Type: text/html\015\012";

print "Content-Length: " . length($body) . "\015\012";
print "\015\012", $body, "\015\012";