kagedb/makeidsdb.pl

   1 ###############################################################################
   2 # makeidsdb.pl
   3 #
   4 #   create DB file for KAGE/cgi from CHISE-IDS *.txt
   5 #   by Koichi Kamichi
   6 ###############################################################################
   7
   8 if($#ARGV != 0 || !(-d $ARGV[0])){
   9         print "Usage: perl makeidsdb.pl ids_dir\n";
  10         exit;
  11 }
  12 $idsdir = $ARGV[0];
  13 $idsdir =~ s/\/?$//; # remove the last slash
  14
  15 if(-e "idsdb"){
  16   print "Remove old idsdb first.\n";
  17         exit;
  18 }
  19
  20 use Fcntl;
  21 use BerkeleyDB;
  22
  23 tie %db, "BerkeleyDB::Hash", -Filename => "idsdb", -Flags => DB_CREATE
  24 or die "An error occured at ceating DB file.\n";
  25 %db = ();
  26
  27 opendir(DH, "$ARGV[0]");
  28 @dirlist = readdir(DH);
  29
  30 $counter = 1;
  31
  32 foreach(@dirlist){
  33         if(m/IDS-.*\.txt/){
  34
  35                 open(FH, "<$ARGV[0]/$_");
  36                 @buffer = <FH>;
  37                 if($buffer[0] =~ m/utf-8-mcs-er/){
  38                         foreach(@buffer){
  39
  40                                 $_ =~ m/(.*?)[\s]?\t(.*)\t(.*)\n/; # remove space after Daikanwa's No.
  41                                 $key = &properucs2kageucs($1);
  42                                 $value = &utf8er2kageer($3);
  43                                 if(($key ne $value) && ($value ne "")){
  44                                         print "\rcreating ... [$counter] key : $key      ";
  45                                         $db{$key} = $value;
  46                                         $counter++;
  47                                 }
  48
  49                         }
  50                 }
  51                 close(FH);
  52
  53         }
  54 }
  55
  56 closedir(DH);
  57 untie(%db);
  58 print "\rdone.\n";
  59
  60 ###############################################################################
  61
  62 sub properucs2kageucs{
  63         my $ax = @_[0];
  64
  65         $ax =~ s/\'/s/; # replace single quote for Daikanwa No.
  66         $ax =~ s/\"/d/; # replace double quote for Daikanwa No.
  67         $ax =~ s/U\+/u/;
  68         $ax =~ s/U\-0*/u/;
  69
  70         return lc($ax);
  71 }
  72
  73 sub utf8er2kageer{
  74         my $result, $first, $semicolon, $ax;
  75
  76         $result = "";
  77
  78         for(my $pointer = 0; $pointer < length(@_[0]);){
  79                 $first = unpack("C", substr(@_[0], $pointer, 1));
  80     if(0x00 <= $first && $first <= 0x7f){ # 1 byte
  81
  82         # the top letter is must be "&"
  83         if($first == 0x26){
  84                                 $semicolon = index(@_[0], ';', $pointer);
  85                                 $ax = substr(@_[0], $pointer + 1, $semicolon - $pointer - 1).".";
  86                                 $ax =~ s/^I-//; # remove "I-"
  87                                 $ax =~ s/\'/s/; # replace single quote for Daikanwa No.
  88                                 $ax =~ s/\"/d/; # replace double quote for Daikanwa No.
  89                                 $result .= $ax;
  90
  91                                 $pointer = $semicolon + 1;
  92         }
  93         else{
  94                 $pointer += 1;
  95         }
  96
  97                 }
  98     elsif(0xc0 <= $first && $first <= 0xdf){ # 2 bytes
  99                         # may not be exist
 100         $pointer += 2;
 101     }
 102     elsif(0xe0 <= $first && $first <= 0xef){ # 3 bytes
 103         $ax = (unpack("C", substr(@_[0], $pointer, 1)) & 0x0f) << 12;
 104         $ax += (unpack("C", substr(@_[0], $pointer + 1, 1)) & 0x3f) << 6;
 105         $ax += (unpack("C", substr(@_[0], $pointer + 2, 1)) & 0x3f);
 106         $result .= sprintf("u%x.", $ax);
 107                         $pointer += 3;
 108     }
 109     elsif(0xf0 <= $first && $first <= 0xf7){ # 4 bytes
 110         $ax = (unpack("C", substr(@_[0], $pointer, 1)) & 0x07) << 18;
 111         $ax += (unpack("C", substr(@_[0], $pointer + 1, 1)) & 0x3f) << 12;
 112         $ax += (unpack("C", substr(@_[0], $pointer + 2, 1)) & 0x3f) << 6;
 113         $ax += (unpack("C", substr(@_[0], $pointer + 3, 1)) & 0x3f);
 114         $result .= sprintf("u%x.", $ax);
 115         $pointer += 4;
 116     }
 117     elsif(0xf8 <= $first && $first <= 0xfb){ # 5 bytes
 118         $ax = (unpack("C", substr(@_[0], $pointer, 1)) & 0x03) << 24;
 119         $ax += (unpack("C", substr(@_[0], $pointer + 1, 1)) & 0x3f) << 18;
 120         $ax += (unpack("C", substr(@_[0], $pointer + 2, 1)) & 0x3f) << 12;
 121         $ax += (unpack("C", substr(@_[0], $pointer + 3, 1)) & 0x3f) << 6;
 122         $ax += (unpack("C", substr(@_[0], $pointer + 4, 1)) & 0x3f);
 123         $result .= sprintf("u%x.", $ax);
 124         $pointer += 5;
 125     }
 126     elsif(0xfc <= $first && $first <= 0xfd){ # 6 bytes
 127         $ax = (unpack("C", substr(@_[0], $pointer, 1)) & 0x01) << 30;
 128         $ax += (unpack("C", substr(@_[0], $pointer + 1, 1)) & 0x3f) << 24;
 129         $ax += (unpack("C", substr(@_[0], $pointer + 2, 1)) & 0x3f) << 18;
 130         $ax += (unpack("C", substr(@_[0], $pointer + 3, 1)) & 0x3f) << 12;
 131         $ax += (unpack("C", substr(@_[0], $pointer + 4, 1)) & 0x3f) << 6;
 132         $ax += (unpack("C", substr(@_[0], $pointer + 5, 1)) & 0x3f);
 133         $result .= sprintf("u%x.", $ax);
 134         $pointer += 6;
 135     }
 136
 137         }
 138
 139         chop($result); # remove the last period char.
 140         return lc($result);
 141
 142 }