3 #==============================================================================
7 # This script is the frontend of KAGE/DB. Running as CGI.
9 #==============================================================================
15 $dbdir = "/var/www/kagedb";
17 #=============== output header
18 print qq|Content-type: text/html;
22 <meta http-equiv="Content-Type" content="text/html; charset=UTF-8" />
24 h1 { margin: 5px 0; padding: 10px; font-size: 20px; border: 1px solid #3333ff; clear: both;}
25 h2 { margin: 0; font-size: 18px; background: #9999ff; clear: both; }
26 img { width: 75; height: 75; float: left; margin: 10px; border: 1px dotted blue;}
27 hr { clear: both; border: 2px solid #000099; }
28 textarea { margin: 5px 0 5px 5px; }
29 input { margin: 10px 0 0 5px; }
31 span.large { font-size: 40px; }
33 <title>KAGE/DB</title>
41 #=============== prepare idsDB
42 tie %idsdb, "BerkeleyDB::Hash",
43 -Filename => "$dbdir/idsdb"
44 or print "DB error occured.";
46 #=============== prepare partsDB
47 tie %partsdb, "BerkeleyDB::Hash",
48 -Filename => "$dbdir/partsdb"
49 or print "DB error occured.";
51 #=============== prepare aliasDB
52 tie %aliasdb, "BerkeleyDB::Hash",
53 -Filename => "$dbdir/aliasdb"
54 or print "DB error occured.";
56 #=============== prepare idsDB
57 tie %idsdb, "BerkeleyDB::Hash",
58 -Filename => "$dbdir/idsdb",
60 or print "DB error occured.";
62 #=============== prepare partsDB
63 tie %partsdb, "BerkeleyDB::Hash",
64 -Filename => "$dbdir/partsdb",
66 or print "DB error occured.";
68 #=============== prepare aliasDB
69 tie %aliasdb, "BerkeleyDB::Hash",
70 -Filename => "$dbdir/aliasdb",
72 or print "DB error occured.";
75 #=============== update DB
77 $command = $cgi->param('command');
78 $data = $cgi->param('data');
79 $title = $cgi->param('title');
80 if($command eq 'update_aliasdb'){
81 $aliasdb{$title} = $data;
83 delete $aliasdb{$title};
86 elsif($command eq 'update_partsdb'){
91 $partsdb{$title} = $data;
93 delete $partsdb{$title};
98 #=============== get query string
99 $query = $cgi->param('query');
100 $query =~ s/[\<\>\\\&\#]//g;
102 if($query =~ m/^[^a-z]/){
103 $query = &utf8er2kageer($query);
106 if($query =~ m/u([0-9a-f]{4,5})/){
107 $query_char = "<span class=\"large\">[".pack("U", eval("0x$1"))."]</span>";
108 $query_char_zengo = "<div align=\"center\">";
109 $query_char_zengo .= "[<a href=\"?query=".pack("U", eval("0x$1")-256)."\">".pack("U", eval("0x$1")-256)."</a>] ";
110 $query_char_zengo .= "[<a href=\"?query=".pack("U", eval("0x$1")-128)."\">".pack("U", eval("0x$1")-128)."</a>] ";
111 $query_char_zengo .= "[<a href=\"?query=".pack("U", eval("0x$1")-64 )."\">".pack("U", eval("0x$1")-64 )."</a>] ";
112 $query_char_zengo .= "[<a href=\"?query=".pack("U", eval("0x$1")-32 )."\">".pack("U", eval("0x$1")-32 )."</a>] ";
113 $query_char_zengo .= "[<a href=\"?query=".pack("U", eval("0x$1")-16 )."\">".pack("U", eval("0x$1")-16 )."</a>] ";
114 $query_char_zengo .= " ... ";
115 $query_char_zengo .= "[<a href=\"?query=".pack("U", eval("0x$1")-7)."\">".pack("U", eval("0x$1")-7)."</a>] ";
116 $query_char_zengo .= "[<a href=\"?query=".pack("U", eval("0x$1")-6)."\">".pack("U", eval("0x$1")-6)."</a>] ";
117 $query_char_zengo .= "[<a href=\"?query=".pack("U", eval("0x$1")-5)."\">".pack("U", eval("0x$1")-5)."</a>] ";
118 $query_char_zengo .= "[<a href=\"?query=".pack("U", eval("0x$1")-4)."\">".pack("U", eval("0x$1")-4)."</a>] ";
119 $query_char_zengo .= "[<a href=\"?query=".pack("U", eval("0x$1")-3)."\">".pack("U", eval("0x$1")-3)."</a>] ";
120 $query_char_zengo .= "[<a href=\"?query=".pack("U", eval("0x$1")-2)."\">".pack("U", eval("0x$1")-2)."</a>] ";
121 $query_char_zengo .= "[<a href=\"?query=".pack("U", eval("0x$1")-1)."\">".pack("U", eval("0x$1")-1)."</a>] ";
122 $query_char_zengo .= "← ".pack("U", eval("0x$1"))." → ";
123 $query_char_zengo .= "[<a href=\"?query=".pack("U", eval("0x$1")+1)."\">".pack("U", eval("0x$1")+1)."</a>] ";
124 $query_char_zengo .= "[<a href=\"?query=".pack("U", eval("0x$1")+2)."\">".pack("U", eval("0x$1")+2)."</a>] ";
125 $query_char_zengo .= "[<a href=\"?query=".pack("U", eval("0x$1")+3)."\">".pack("U", eval("0x$1")+3)."</a>] ";
126 $query_char_zengo .= "[<a href=\"?query=".pack("U", eval("0x$1")+4)."\">".pack("U", eval("0x$1")+4)."</a>] ";
127 $query_char_zengo .= "[<a href=\"?query=".pack("U", eval("0x$1")+5)."\">".pack("U", eval("0x$1")+5)."</a>] ";
128 $query_char_zengo .= "[<a href=\"?query=".pack("U", eval("0x$1")+6)."\">".pack("U", eval("0x$1")+6)."</a>] ";
129 $query_char_zengo .= "[<a href=\"?query=".pack("U", eval("0x$1")+7)."\">".pack("U", eval("0x$1")+7)."</a>] ";
130 $query_char_zengo .= " ... ";
131 $query_char_zengo .= "[<a href=\"?query=".pack("U", eval("0x$1")+16 )."\">".pack("U", eval("0x$1")+16 )."</a>] ";
132 $query_char_zengo .= "[<a href=\"?query=".pack("U", eval("0x$1")+32 )."\">".pack("U", eval("0x$1")+32 )."</a>] ";
133 $query_char_zengo .= "[<a href=\"?query=".pack("U", eval("0x$1")+64 )."\">".pack("U", eval("0x$1")+64 )."</a>] ";
134 $query_char_zengo .= "[<a href=\"?query=".pack("U", eval("0x$1")+128)."\">".pack("U", eval("0x$1")+128)."</a>] ";
135 $query_char_zengo .= "[<a href=\"?query=".pack("U", eval("0x$1")+256)."\">".pack("U", eval("0x$1")+256)."</a>] ";
136 $query_char_zengo .= "</div>";
139 $query_char_zengo = "";
142 #=============== output html form
143 #print qq|<h1>Query</h1>
147 <input type="text" name="query" value="$query" size="10">
148 <input type="submit" value="submit">
153 #=============== output results
154 print "<h1>Result for $query$query_char</h1>";
156 print "<table width=\"100%\"><tr><td valign=\"top\" width=\"35%\">";
158 print "<h2>idsdb</h2>";
159 if(exists($idsdb{$query})){
161 s/([^.]*)/<a href="?query=$1">$1<\/a>/g;
162 print "<img src=\"/v0.4/engine/kage.cgi?$idsdb{$query}\">";
163 #print "<img src=\"/v0.4/engine/kage.cgi?shotai=gothic&$idsdb{$query}\">";
164 print "<div>$_</div>";
165 if($idsdb{$query} =~ /^u2ff0\./){
166 print "<a href=\"../kage/mappin.cgi?target=$query\">簡易調整</a><span style=\"font-size:9pt;\">(test)</span>";
169 print "<div>no resutls</div>";
172 print "</td><td valign=\"top\" rowspan=\"2\">";
174 print "<h2>partsdb</h2>";
175 if(exists($partsdb{$query})){
176 print "<img src=\"/v0.4/engine/kage.cgi?$query\">";
177 $_ = $partsdb{$query};
179 print "<form method=\"post\">";
180 print "<input type=\"hidden\" name=\"command\" value=\"update_partsdb\">";
181 print "<input type=\"text\" name=\"title\" value=\"$query\" size=\"10\">";
182 print "<input type=\"hidden\" name=\"query\" value=\"$query\">";
183 if($admin eq "yes"){ print "<input type=\"submit\" value=\"update\">"; }
184 print "<a href=\"/kage/fled-update.cgi?mypage=$query&mydata=".$partsdb{$query}."\" target=\"edit\">Edit glyph</a>";
186 print "<textarea cols=\"60\" rows=\"10\" name=\"data\">$_</textarea>";
189 print "<div>no resutls</div>";
190 print "<form method=\"post\">";
191 print "<input type=\"hidden\" name=\"command\" value=\"update_partsdb\">";
192 print "<input type=\"text\" name=\"title\" value=\"$query\" size=\"10\">";
193 print "<input type=\"hidden\" name=\"query\" value=\"$query\">";
194 if($admin eq "yes"){ print "<input type=\"submit\" value=\"create\">"; }
195 print "<a href=\"/kage/fled-update.cgi\" target=\"edit\">Edit new glyph</a>";
197 print "<textarea cols=\"60\" rows=\"10\" name=\"data\"></textarea>";
202 print "<h2>aliasdb</h2>";
203 if(exists($aliasdb{$query})){
204 $_ = $aliasdb{$query};
205 s/([^.]*)/<a href="?query=$1">$1<\/a>/g;
206 print "<img src=\"/v0.4/engine/kage.cgi?$aliasdb{$query}\">";
207 print "<div>$_</div>";
208 print "<form method=\"post\">";
209 print "<input type=\"hidden\" name=\"command\" value=\"update_aliasdb\">";
210 print "<input type=\"text\" name=\"data\" value=\"$aliasdb{$query}\" size=\"10\">";
211 print "<input type=\"hidden\" name=\"title\" value=\"$query\">";
212 print "<input type=\"hidden\" name=\"query\" value=\"$query\">";
213 if($admin eq "yes"){ print "<input type=\"submit\" value=\"update\">"; }
216 print "<div>no resutls</div>";
217 print "<form method=\"post\">";
218 print "<input type=\"hidden\" name=\"command\" value=\"update_aliasdb\">";
219 print "<input type=\"text\" name=\"data\" size=\"10\">";
220 print "<input type=\"hidden\" name=\"title\" value=\"$query\">";
221 print "<input type=\"hidden\" name=\"query\" value=\"$query\">";
222 if($admin eq "yes"){ print "<input type=\"submit\" value=\"create\">"; }
225 print "</td></tr></table>";
227 #=============== output footer
229 <div align="right"><a href="http://fonts.jp/">fonts.jp</a></div>
233 #=============== free DB
240 $result = $db{"?@_[0]"};
243 #=============== S->ids
248 $result =~ s/ideographic-structure//g;
252 print "<h2>@_[0]</h2>";
254 print &print_char($buffer);
257 #=============== recursive search
258 my $length = length($result);
259 for(my $i = 0; $i < $length;){
260 $first = unpack("C", substr($result, $i, 1));
261 if(0xc2 <= $first && $first <= 0xdf){ # 2 bytes
262 my $next = substr($result, $i, 2);
266 elsif(0xe0 <= $first && $first <= 0xef){ # 3 bytes
267 my $next = substr($result, $i, 3);
271 elsif(0xf0 == $first){ # 4 bytes(but SIP)
272 my $next = substr($result, $i, 4);
276 elsif(0xf1 <= $first && $first <= 0xf7){ # 4 bytes
277 my $next = substr($result, $i, 4);
282 elsif(0xf8 <= $first && $first <= 0xfb){ # 5 bytes
283 my $next = substr($result, $i, 5);
288 elsif(0xfc <= $first && $first <= 0xfd){ # 6 bytes
289 my $next = substr($result, $i, 6);
295 my $next = substr($result, $i, 1);
305 $info .= "<h2>".unpack("H*", @_[0])."</h2>";
306 opendir(DH, "/home/httpd/chise-db/character/feature/");
307 foreach(readdir(DH)){
308 if(substr($_, 0, 1) ne '.'){
310 tie %db, "BerkeleyDB::Hash",
311 -Filename => "/home/httpd/chise-db/character/feature/$_",
313 or print "DB error occured.";
314 if(exists($db{'?'.@_[0]})){
315 $info .= sprintf("[$_ -> %d(%X)]", $db{'?'.@_[0]}, $db{'?'.@_[0]});
324 my $b4 = '[\xf1-\xf7][\x80-\xbf]{3}'; # print directly if char is f0(before u+30000)
325 my $b5 = '[\xf8-\xfb][\x80-\xbf]{4}'; # some corner-cutting is here
326 my $b6 = '[\xfc-\xfd][\x80-\xbf]{5}';
328 for(my $i = 0; $i < length(@_[0]);){
329 $_ = substr(@_[0], $i);
331 print "[".unpack("H*", substr(@_[0], $i, 4))."]";
335 print "[".unpack("H*", substr(@_[0], $i, 5))."]";
339 print "[".unpack("H*", substr(@_[0], $i, 6))."]";
343 print qq|<img src="http://fonts.jp/archives/search/0.png" alt="U+2FF0" align="absbottom">|;
347 print qq|<img src="http://fonts.jp/archives/search/1.png" alt="U+2FF1" align="absbottom">|;
351 print qq|<img src="http://fonts.jp/archives/search/2.png" alt="U+2FF2" align="absbottom">|;
355 print qq|<img src="http://fonts.jp/archives/search/3.png" alt="U+2FF3" align="absbottom">|;
359 print qq|<img src="http://fonts.jp/archives/search/4.png" alt="U+2FF4" align="absbottom">|;
363 print qq|<img src="http://fonts.jp/archives/search/5.png" alt="U+2FF5" align="absbottom">|;
367 print qq|<img src="http://fonts.jp/archives/search/6.png" alt="U+2FF6" align="absbottom">|;
371 print qq|<img src="http://fonts.jp/archives/search/7.png" alt="U+2FF7" align="absbottom">|;
375 print qq|<img src="http://fonts.jp/archives/search/8.png" alt="U+2FF8" align="absbottom">|;
379 print qq|<img src="http://fonts.jp/archives/search/9.png" alt="U+2FF9" align="absbottom">|;
383 print qq|<img src="http://fonts.jp/archives/search/a.png" alt="U+2FFA" align="absbottom">|;
387 print qq|<img src="http://fonts.jp/archives/search/b.png" alt="U+2FFB" align="absbottom">|;
391 #use Encode 'from_to';
392 return substr(@_[0], $i, 3);
393 #print "{".from_to(substr(@_[0], $i, 3), 'utf-8', 'UTF-32')."}";
399 ###############################################################################
401 sub properucs2kageucs{
404 $ax =~ s/\'/s/; # replace single quote for Daikanwa No.
405 $ax =~ s/\"/d/; # replace double quote for Daikanwa No.
413 my $result, $first, $semicolon, $ax;
417 for(my $pointer = 0; $pointer < length(@_[0]);){
418 $first = unpack("C", substr(@_[0], $pointer, 1));
419 if(0x00 <= $first && $first <= 0x7f){ # 1 byte
421 # the top letter is must be "&"
423 $semicolon = index(@_[0], ';', $pointer);
424 $ax = substr(@_[0], $pointer + 1, $semicolon - $pointer - 1).".";
425 $ax =~ s/^I-//; # remove "I-"
426 $ax =~ s/\'/s/; # replace single quote for Daikanwa No.
427 $ax =~ s/\"/d/; # replace double quote for Daikanwa No.
430 $pointer = $semicolon + 1;
437 elsif(0xc0 <= $first && $first <= 0xdf){ # 2 bytes
441 elsif(0xe0 <= $first && $first <= 0xef){ # 3 bytes
442 $ax = (unpack("C", substr(@_[0], $pointer, 1)) & 0x0f) << 12;
443 $ax += (unpack("C", substr(@_[0], $pointer + 1, 1)) & 0x3f) << 6;
444 $ax += (unpack("C", substr(@_[0], $pointer + 2, 1)) & 0x3f);
445 $result .= sprintf("u%x.", $ax);
448 elsif(0xf0 <= $first && $first <= 0xf7){ # 4 bytes
449 $ax = (unpack("C", substr(@_[0], $pointer, 1)) & 0x07) << 18;
450 $ax += (unpack("C", substr(@_[0], $pointer + 1, 1)) & 0x3f) << 12;
451 $ax += (unpack("C", substr(@_[0], $pointer + 2, 1)) & 0x3f) << 6;
452 $ax += (unpack("C", substr(@_[0], $pointer + 3, 1)) & 0x3f);
453 $result .= sprintf("u%x.", $ax);
456 elsif(0xf8 <= $first && $first <= 0xfb){ # 5 bytes
457 $ax = (unpack("C", substr(@_[0], $pointer, 1)) & 0x03) << 24;
458 $ax += (unpack("C", substr(@_[0], $pointer + 1, 1)) & 0x3f) << 18;
459 $ax += (unpack("C", substr(@_[0], $pointer + 2, 1)) & 0x3f) << 12;
460 $ax += (unpack("C", substr(@_[0], $pointer + 3, 1)) & 0x3f) << 6;
461 $ax += (unpack("C", substr(@_[0], $pointer + 4, 1)) & 0x3f);
462 $result .= sprintf("u%x.", $ax);
465 elsif(0xfc <= $first && $first <= 0xfd){ # 6 bytes
466 $ax = (unpack("C", substr(@_[0], $pointer, 1)) & 0x01) << 30;
467 $ax += (unpack("C", substr(@_[0], $pointer + 1, 1)) & 0x3f) << 24;
468 $ax += (unpack("C", substr(@_[0], $pointer + 2, 1)) & 0x3f) << 18;
469 $ax += (unpack("C", substr(@_[0], $pointer + 3, 1)) & 0x3f) << 12;
470 $ax += (unpack("C", substr(@_[0], $pointer + 4, 1)) & 0x3f) << 6;
471 $ax += (unpack("C", substr(@_[0], $pointer + 5, 1)) & 0x3f);
472 $result .= sprintf("u%x.", $ax);
478 chop($result); # remove the last period char.