kagedb/index.cgi

   1 #!/usr/bin/perl
   2
   3 #==============================================================================
   4 #
   5 # KAGE/DB
   6 #
   7 # This script is the frontend of KAGE/DB. Running as CGI.
   8 #
   9 #==============================================================================
  10
  11 use BerkeleyDB;
  12
  13 $info = "";
  14 $admin = "yes";
  15 $dbdir = "/var/www/kagedb";
  16
  17 #=============== output header
  18 print qq|Content-type: text/html;
  19
  20 <html lang="ja">
  21 <head>
  22 <meta http-equiv="Content-Type" content="text/html; charset=UTF-8" />
  23 <style>
  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; }
  30 div { margin: 10px; }
  31 span.large { font-size: 40px; }
  32 </style>
  33 <title>KAGE/DB</title>
  34 </head>
  35 <body>|;
  36
  37 use CGI;
  38 $cgi = new CGI;
  39
  40 if($admin eq "yes"){
  41         #=============== prepare idsDB
  42         tie %idsdb, "BerkeleyDB::Hash",
  43         -Filename => "$dbdir/idsdb"
  44          or print "DB error occured.";
  45
  46         #=============== prepare partsDB
  47         tie %partsdb, "BerkeleyDB::Hash",
  48         -Filename => "$dbdir/partsdb"
  49          or print "DB error occured.";
  50
  51         #=============== prepare aliasDB
  52         tie %aliasdb, "BerkeleyDB::Hash",
  53         -Filename => "$dbdir/aliasdb"
  54          or print "DB error occured.";
  55 }else{
  56         #=============== prepare idsDB
  57         tie %idsdb, "BerkeleyDB::Hash",
  58         -Filename => "$dbdir/idsdb",
  59         -Flags => DB_RDONLY
  60          or print "DB error occured.";
  61
  62         #=============== prepare partsDB
  63         tie %partsdb, "BerkeleyDB::Hash",
  64         -Filename => "$dbdir/partsdb",
  65         -Flags => DB_RDONLY
  66          or print "DB error occured.";
  67
  68         #=============== prepare aliasDB
  69         tie %aliasdb, "BerkeleyDB::Hash",
  70         -Filename => "$dbdir/aliasdb",
  71         -Flags => DB_RDONLY
  72          or print "DB error occured.";
  73 }
  74
  75 #=============== update DB
  76 if($admin eq "yes"){
  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;
  82                 if($data eq ""){
  83                         delete $aliasdb{$title};
  84                 }
  85         }
  86         elsif($command eq 'update_partsdb'){
  87                 $data =~ s/\r/\$/g;
  88                 $data =~ s/\n/\$/g;
  89                 $data =~ s/\$\$/\$/g;
  90                 $data =~ s/\$$//g;
  91                 $partsdb{$title} = $data;
  92                 if($data eq ""){
  93                         delete $partsdb{$title};
  94                 }
  95         }
  96 }
  97
  98 #=============== get query string
  99 $query = $cgi->param('query');
 100 $query =~ s/[\<\>\\\&\#]//g;
 101
 102 if($query =~ m/^[^a-z]/){
 103         $query = &utf8er2kageer($query);
 104 }
 105
 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 .= "&#x2190; ".pack("U", eval("0x$1"))." &#x2192; ";
 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>";
 137 }else{
 138         $query_char = "";
 139         $query_char_zengo = "";
 140 }
 141
 142 #=============== output html form
 143 #print qq|<h1>Query</h1>
 144 print qq|
 145 <form>
 146 Query :
 147 <input type="text" name="query" value="$query" size="10">
 148 <input type="submit" value="submit">
 149 $query_char_zengo
 150 </form>
 151 <hr>|;
 152
 153 #=============== output results
 154 print "<h1>Result for $query$query_char</h1>";
 155
 156 print "<table width=\"100%\"><tr><td valign=\"top\" width=\"35%\">";
 157
 158 print "<h2>idsdb</h2>";
 159 if(exists($idsdb{$query})){
 160         $_ = $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>";
 167   }
 168 }else{
 169         print "<div>no resutls</div>";
 170 }
 171
 172 print "</td><td valign=\"top\" rowspan=\"2\">";
 173
 174 print "<h2>partsdb</h2>";
 175 if(exists($partsdb{$query})){
 176         print "<img src=\"/v0.4/engine/kage.cgi?$query\">";
 177         $_ = $partsdb{$query};
 178         $_ =~ s/\$/\n/g;
 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>";
 185         print "<br>";
 186         print "<textarea cols=\"60\" rows=\"10\" name=\"data\">$_</textarea>";
 187         print "</form>";
 188 }else{
 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>";
 196         print "<br>";
 197         print "<textarea cols=\"60\" rows=\"10\" name=\"data\"></textarea>";
 198         print "</form>";
 199 }
 200 print "</td></tr>";
 201 print "<tr><td>";
 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\">"; }
 214         print "</form>";
 215 }else{
 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\">"; }
 223         print "</form>";
 224 }
 225 print "</td></tr></table>";
 226
 227 #=============== output footer
 228 print qq|<hr>
 229 <div align="right"><a href="http://fonts.jp/">fonts.jp</a></div>
 230 </body>
 231 </html>|;
 232
 233 #=============== free DB
 234 untie(%idsdb);
 235 untie(%partsdb);
 236
 237 sub do_search{
 238         my $result, $buffer;
 239
 240         $result = $db{"?@_[0]"};
 241
 242         if($result ne ""){
 243                 #=============== S->ids
 244                 $result =~ s/\(//g;
 245                 $result =~ s/\)//g;
 246                 $result =~ s/\?//g;
 247                 $result =~ s/\ //g;
 248                 $result =~ s/ideographic-structure//g;
 249
 250                 $buffer = $result;
 251
 252                 print "<h2>@_[0]</h2>";
 253                 print "<span>";
 254     print &print_char($buffer);
 255     print "</span>";
 256
 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);
 263                                 $i = $i + 2;
 264                                 &do_search($next);
 265                         }
 266                         elsif(0xe0 <= $first && $first <= 0xef){ # 3 bytes
 267                                 my $next = substr($result, $i, 3);
 268                                 $i = $i + 3;
 269                                 &do_search($next);
 270                         }
 271                         elsif(0xf0 == $first){ # 4 bytes(but SIP)
 272                                 my $next = substr($result, $i, 4);
 273                                 $i = $i + 4;
 274                                 &do_search($next);
 275                         }
 276                         elsif(0xf1 <= $first && $first <= 0xf7){ # 4 bytes
 277                                 my $next = substr($result, $i, 4);
 278                                 $i = $i + 4;
 279                                 &search_all($next);
 280                                 &do_search($next);
 281                         }
 282                         elsif(0xf8 <= $first && $first <= 0xfb){ # 5 bytes
 283                                 my $next = substr($result, $i, 5);
 284                                 $i = $i + 5;
 285                                 &search_all($next);
 286                                 &do_search($next);
 287                         }
 288                         elsif(0xfc <= $first && $first <= 0xfd){ # 6 bytes
 289                                 my $next = substr($result, $i, 6);
 290                                 $i = $i + 6;
 291                                 &search_all($next);
 292                                 &do_search($next);
 293                         }
 294                         else{ # 1 byte
 295                                 my $next = substr($result, $i, 1);
 296                                 $i = $i + 1;
 297                                 &search_all($next);
 298                                 &do_search($next);
 299                         }
 300                 }
 301         }
 302 }
 303
 304 sub search_all{
 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 '.'){
 309                         my %db;
 310                         tie %db, "BerkeleyDB::Hash",
 311                         -Filename => "/home/httpd/chise-db/character/feature/$_",
 312                         -Flags => DB_RDONLY
 313                          or print "DB error occured.";
 314                         if(exists($db{'?'.@_[0]})){
 315                                 $info .= sprintf("[$_ -> %d(%X)]", $db{'?'.@_[0]}, $db{'?'.@_[0]});
 316                         }
 317                         untie(%db);
 318                 }
 319         }
 320         closedir(DH);
 321 }
 322
 323 sub get_char{
 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}';
 327         my $temp;
 328         for(my $i = 0; $i < length(@_[0]);){
 329                 $_ = substr(@_[0], $i);
 330                 if(m/^(?:$b4)/){
 331                         print "[".unpack("H*", substr(@_[0], $i, 4))."]";
 332                         $i = $i + 4;
 333                 }
 334                 elsif(m/^(?:$b5)/){
 335                         print "[".unpack("H*", substr(@_[0], $i, 5))."]";
 336                         $i = $i + 5;
 337                 }
 338                 elsif(m/^(?:$b6)/){
 339                         print "[".unpack("H*", substr(@_[0], $i, 6))."]";
 340                         $i = $i + 6;
 341                 }
 342                 elsif(m/^⿰/){
 343                         print qq|<img src="http://fonts.jp/archives/search/0.png" alt="U+2FF0" align="absbottom">|;
 344                         $i = $i + 3;
 345                 }
 346                 elsif(m/^⿱/){
 347                         print qq|<img src="http://fonts.jp/archives/search/1.png" alt="U+2FF1" align="absbottom">|;
 348                         $i = $i + 3;
 349                 }
 350                 elsif(m/^⿲/){
 351                         print qq|<img src="http://fonts.jp/archives/search/2.png" alt="U+2FF2" align="absbottom">|;
 352                         $i = $i + 3;
 353                 }
 354                 elsif(m/^⿳/){
 355                         print qq|<img src="http://fonts.jp/archives/search/3.png" alt="U+2FF3" align="absbottom">|;
 356                         $i = $i + 3;
 357                 }
 358                 elsif(m/^⿴/){
 359                         print qq|<img src="http://fonts.jp/archives/search/4.png" alt="U+2FF4" align="absbottom">|;
 360                         $i = $i + 3;
 361                 }
 362                 elsif(m/^⿵/){
 363                         print qq|<img src="http://fonts.jp/archives/search/5.png" alt="U+2FF5" align="absbottom">|;
 364                         $i = $i + 3;
 365                 }
 366                 elsif(m/^⿶/){
 367                         print qq|<img src="http://fonts.jp/archives/search/6.png" alt="U+2FF6" align="absbottom">|;
 368                         $i = $i + 3;
 369                 }
 370                 elsif(m/^⿷/){
 371                         print qq|<img src="http://fonts.jp/archives/search/7.png" alt="U+2FF7" align="absbottom">|;
 372                         $i = $i + 3;
 373                 }
 374                 elsif(m/^⿸/){
 375                         print qq|<img src="http://fonts.jp/archives/search/8.png" alt="U+2FF8" align="absbottom">|;
 376                         $i = $i + 3;
 377                 }
 378                 elsif(m/^⿹/){
 379                         print qq|<img src="http://fonts.jp/archives/search/9.png" alt="U+2FF9" align="absbottom">|;
 380                         $i = $i + 3;
 381                 }
 382                 elsif(m/^⿺/){
 383                         print qq|<img src="http://fonts.jp/archives/search/a.png" alt="U+2FFA" align="absbottom">|;
 384                         $i = $i + 3;
 385                 }
 386                 elsif(m/^⿻/){
 387                         print qq|<img src="http://fonts.jp/archives/search/b.png" alt="U+2FFB" align="absbottom">|;
 388                         $i = $i + 3;
 389                 }
 390                 else{
 391                 #use Encode 'from_to';
 392                         return substr(@_[0], $i, 3);
 393 #print "{".from_to(substr(@_[0], $i, 3), 'utf-8', 'UTF-32')."}";
 394                         $i = $i + 3;
 395                 }
 396         }
 397 }
 398
 399 ###############################################################################
 400
 401 sub properucs2kageucs{
 402         my $ax = @_[0];
 403
 404         $ax =~ s/\'/s/; # replace single quote for Daikanwa No.
 405         $ax =~ s/\"/d/; # replace double quote for Daikanwa No.
 406         $ax =~ s/U\+/u/;
 407         $ax =~ s/U\-0*/u/;
 408
 409         return lc($ax);
 410 }
 411
 412 sub utf8er2kageer{
 413         my $result, $first, $semicolon, $ax;
 414
 415         $result = "";
 416
 417         for(my $pointer = 0; $pointer < length(@_[0]);){
 418                 $first = unpack("C", substr(@_[0], $pointer, 1));
 419     if(0x00 <= $first && $first <= 0x7f){ # 1 byte
 420
 421         # the top letter is must be "&"
 422         if($first == 0x26){
 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.
 428                                 $result .= $ax;
 429
 430                                 $pointer = $semicolon + 1;
 431         }
 432         else{
 433                 $pointer += 1;
 434         }
 435
 436                 }
 437     elsif(0xc0 <= $first && $first <= 0xdf){ # 2 bytes
 438                         # may not be exist
 439         $pointer += 2;
 440     }
 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);
 446                         $pointer += 3;
 447     }
 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);
 454         $pointer += 4;
 455     }
 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);
 463         $pointer += 5;
 464     }
 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);
 473         $pointer += 6;
 474     }
 475
 476         }
 477
 478         chop($result); # remove the last period char.
 479         return lc($result);
 480
 481 }