CHISE.pm

   1 #
   2 # CHISE.pm by Shigeki Moro
   3 # $Id: CHISE.pm,v 1.2 2003-02-23 09:17:19 moro Exp $
   4 #
   5 package CHISE;
   6
   7 use strict;
   8 use BerkeleyDB;
   9
  10 my $DB_HOME = '/usr/local/lib/xemacs-21.4.10/i686-pc-linux/char-db';
  11
  12 my %alias = ();
  13 my %alias_reverse = ();
  14 for (glob "$DB_HOME/system-char-id/*") {
  15   s/^.*\/([^\/]+)$/$1/;
  16   my $i = $_;
  17   s/\->/to_/;
  18   s/<\-/from_/;
  19   s/=>/map_/;
  20   s/\-/_/g;
  21   $alias{$_} = $i;
  22   $alias_reverse{$i} = $_;
  23 }
  24 %alias = (
  25           %alias,
  26           'radical','ideographic-radical',
  27           'strokes','total-strokes',
  28 );
  29
  30 #--- exportする予�����の関数 -------------------------------------#
  31
  32 sub new {
  33   # 既存の�����字オブジェクトの生成
  34   my $invocant = shift;
  35   my $class = ref($invocant) || $invocant;
  36   my $self  = { @_ };
  37   bless $self, $class;
  38   my $key = ($self->chars)[0]; # 要エラーチェック
  39   my($value, $result);
  40   for my $dbname (glob "$DB_HOME/system-char-id/*") {
  41     $value = &getvalue($dbname, $key);
  42     if ($value) {
  43       $dbname =~ s/^.*\/([^\/]+)$/$1/;
  44       $result->{$alias_reverse{$dbname}} = $value;
  45     }
  46   }
  47   return bless $result, $class;
  48 }
  49
  50 sub define_char {
  51   # �����しい�����字オブジェクトの生成
  52   my $invocant = shift;
  53   my $class = ref($invocant) || $invocant;
  54   my $self = {@_};
  55   my $result = ();
  56   for my $i (keys %$self) {
  57     $result->{$alias_reverse{$alias{$i}}} = $$self{$i};
  58   }
  59   return bless $result, $class;
  60 }
  61
  62 sub dumpAttr {
  63   # �����字オブジェクトが持っている全属性をprint
  64   my $self = shift;
  65   for my $i (keys %$self) {
  66     print "$i => $$self{$i}\n";
  67   }
  68 }
  69
  70 sub addAttr {
  71   # �����字オブジェクトに属性を追加
  72   my $model = shift;
  73   my $self = $model->define_char(%$model, @_);
  74   return $self;
  75 }
  76
  77 sub delAttr (@) {
  78   # �����字オブジェクトから属性を削除
  79   my $model = shift;
  80   delete $$model{$_} foreach (@_);
  81   my $self = $model->define_char(%$model);
  82   return $self;
  83 }
  84
  85 # 属性名で属性値を�����す
  86 # 例: $s->morohashi_daikanwa
  87 # cf. get_char_attribute
  88 for my $attrname (keys %alias) {
  89   my $slot = __PACKAGE__ . "::$attrname";
  90   no strict "refs";
  91   *$slot = sub {
  92     my $self = shift;
  93     my $dbname = exists $alias{$attrname}
  94       ? $alias_reverse{$alias{$attrname}}
  95       : $attrname;
  96     return $self->{$dbname};
  97   }
  98 }
  99 #for my $attrname (keys %alias) {
 100 #  my $slot = __PACKAGE__ . "::$attrname";
 101 #  no strict "refs";
 102 #  *$slot = sub {
 103 #    my $self = shift;
 104 #    my @result;
 105 #    for my $i ($self->chars) {
 106 #      my $j = &getvalue("$DB_HOME/system-char-id/$alias{$attrname}", $i);
 107 #      push @result, $j if $j;
 108 #    }
 109 #    return @result;
 110 #  }
 111 #}
 112
 113 sub compare {
 114   # �����字オブジェクトと比�����
 115   my($a, $b) = @_;
 116   my($all_attr, $common_attr) = (0, 0);
 117   for my $i (&cup(keys %$a, keys %$b)) {
 118     if ($a->{$i} eq $b->{$i}) {
 119       $all_attr++;
 120       $common_attr++;
 121     } else {
 122       $all_attr++ if (exists $a->{$i});
 123       $all_attr++ if (exists $b->{$i});
 124     }
 125   }
 126   return $all_attr ? ($common_attr / $all_attr) : 0;
 127 }
 128
 129 sub ph2char ($) {
 130   # �����体参照から?xを得る
 131   my $ph = shift;
 132   my %alias = (
 133                'C1','chinese-cns11643-1',
 134                'C2','chinese-cns11643-2',
 135                'C3','chinese-cns11643-3',
 136                'C4','chinese-cns11643-4',
 137                'C5','chinese-cns11643-5',
 138                'C6','chinese-cns11643-6',
 139                'C7','chinese-cns11643-7',
 140                'CB','ideograph-cbeta',
 141                'CDP','chinese-big5-cdp',
 142                'GT','ideograph-gt',
 143                'GT-K','ideograph-gt',
 144                'HZK1','ideograph-hanziku-1',
 145                'HZK2','ideograph-hanziku-2',
 146                'HZK3','ideograph-hanziku-3',
 147                'HZK4','ideograph-hanziku-4',
 148                'HZK5','ideograph-hanziku-5',
 149                'HZK6','ideograph-hanziku-6',
 150                'HZK7','ideograph-hanziku-7',
 151                'HZK8','ideograph-hanziku-8',
 152                'HZK9','ideograph-hanziku-9',
 153                'HZK10','ideograph-hanziku-10',
 154                'HZK11','ideograph-hanziku-11',
 155                'HZK12','ideograph-hanziku-12',
 156                'J78','japanese-jisx0208-1978',
 157                'J83','japanese-jisx0208',
 158                'J90','japanese-jisx0208-1990',
 159                'JSP','japanese-jisx0212',
 160                'JX1','japanese-jisx0213-1',
 161                'JX2','japanese-jisx0213-2',
 162                'K0','korean-ksc5601',
 163                'M','ideograph-daikanwa',
 164               );
 165   my $keys = join '|', sort keys %alias;
 166   my($phname, $phvalue) = ($ph =~ /^\&(?:I\-)?($keys)\-?([0-9a-f]+);$/i);
 167   if (exists $alias{$phname}) {
 168     if ($alias{$phname} =~ /daikanwa|gt/) {
 169       $phvalue =~ s/^0+//;
 170     } else {
 171       $phvalue = "0x$phvalue";
 172     }
 173     tie my %h, "BerkeleyDB::Hash",
 174       -Filename => "$DB_HOME/$alias{$phname}/system-char-id"
 175       or die "Cannot open file $alias{$phname}: $! $BerkeleyDB::Error\n";
 176     if (exists $h{$phvalue}) {
 177       return $h{$phvalue};
 178     } else {
 179       #print STDERR "\tCan't convert $phname - $phvalue (no value in db).\n";
 180       return $ph;
 181     }
 182     untie %h;
 183   } else {
 184     #print STDERR "\tCan't convert $phname - $phvalue.\n";
 185     return $ph;
 186   }
 187 }
 188
 189 #--- モジュール内のみで�����う予�����の関数 ----------------------#
 190
 191 sub chars {
 192   # ?... の配列を�����す
 193   my $self = shift;
 194   my @result = ('*');
 195   for my $attrname (keys %$self) {
 196     my @tmp = ();
 197     my $dbname = exists $alias{$attrname} ? $alias{$attrname} : $attrname;
 198     if (-f "$DB_HOME/$dbname/system-char-id") {
 199       @tmp = (&getvalue("$DB_HOME/$dbname/system-char-id", $$self{$attrname}));
 200       @result = &cap(\@result, \@tmp);
 201     } elsif (-f "$DB_HOME/system-char-id/$dbname") {
 202       @tmp = &getkeys("$DB_HOME/system-char-id/$dbname", $$self{$attrname});
 203       @result = &cap(\@result, \@tmp);
 204     } else {
 205       die "cannot find $attrname: $! $BerkeleyDB::Error\n";
 206     }
 207   }
 208   return @result;
 209 }
 210
 211 sub utf8 {
 212   # UTF-8を�����す
 213   my $self = shift;
 214   my @result;
 215   for my $i ($self->chars) {
 216     $i =~ s/^\?//;
 217     # To Do: 私用�����域のは�����さないようにしないと。
 218     push @result, $i;
 219   }
 220   return @result;
 221 }
 222
 223 sub getvalue ($$) {
 224   # キーから値を�����り出す
 225   my($dbname, $key) = @_;
 226   tie my %h, "BerkeleyDB::Hash",
 227     -Filename => $dbname;
 228   my $value = $h{$key};
 229   untie %h;
 230   return $value;
 231 }
 232
 233 sub getkeys ($$) {
 234   # 値からキーの配列を�����り出す
 235   my($dbname, $value) = @_;
 236   tie my %h, "BerkeleyDB::Hash",
 237     -Filename => $dbname;
 238   my @keys = ();
 239   for my $key (keys %h) {
 240     push @keys, $key if ($h{$key} eq $value);
 241   }
 242   untie %h;
 243   return @keys;
 244 }
 245
 246 sub cap {
 247   # 2つの配列の積�����合を求める
 248   my($a, $b) = @_;
 249   if (!@$a or !@$b) {
 250     return ();
 251   } elsif ($$a[0] eq '*') { # '*'は全体�����合
 252     return @$b;
 253   } elsif ($$b[0] eq '*') {
 254     return @$a;
 255   } else {
 256     my %result = ();
 257     my @result = ();
 258     for my $i (@$a, @$b) {
 259       $result{$i}++;
 260       push @result, $i if ($result{$i} == 2);
 261     }
 262     return @result;
 263     #return grep {
 264     #  my $c = $_;
 265     #  grep /^$c$/, @$b;
 266     #} @$a;
 267   }
 268 }
 269
 270 sub cup {
 271   # 2つの配列の和�����合を求める
 272   my %result = ();
 273   for my $i (@_) { $result{$i}++; }
 274   return keys %result;
 275 }
 276
 277 #--------------------------------------------------------#
 278 1;