UTF2000.pm

   1 #
   2 # UTF2000.pm by Shigeki Moro
   3 # UTF2000.pm,v 1.6 2003-01-31 18:25:24 moro Exp
   4 #
   5 package UTF2000;
   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 #--------------------------------------------------------#
  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 newchar {
  51   # �����しい�����字オブジェクトの生成
  52   my $invocant = shift;
  53   my $class = ref($invocant) || $invocant;
  54   my $self  = { @_ };
  55   return bless $self, $class;
  56 }
  57
  58 sub dumpAttr {
  59   # �����字オブジェクトが持っている全属性を表示
  60   my $self = shift;
  61   for my $i (keys %$self) {
  62     print "$i => $$self{$i}\n";
  63   }
  64 }
  65
  66 sub addAttr {
  67   # �����字オブジェクトに属性を追加
  68   my $model = shift;
  69   my $self = $model->newchar(%$model, @_);
  70   return $self;
  71 }
  72
  73 sub delAttr (@) {
  74   # �����字オブジェクトから属性を削除
  75   my $model = shift;
  76   delete $$model{$_} foreach (@_);
  77   my $self = $model->newchar(%$model);
  78   return $self;
  79 }
  80
  81 # 属性名で属性値を�����す
  82 # 例: $s->morohashi_daikanwa
  83 for my $attrname (keys %alias) {
  84   my $slot = __PACKAGE__ . "::$attrname";
  85   no strict "refs";
  86   *$slot = sub {
  87     my $self = shift;
  88     my @result;
  89     for my $i ($self->chars) {
  90       my $j = &getvalue("$DB_HOME/system-char-id/$alias{$attrname}", $i);
  91       push @result, $j if $j;
  92     }
  93     return @result;
  94   }
  95 }
  96
  97 sub utf8 {
  98   # UTF-8を�����す
  99   my $self = shift;
 100   my @result;
 101   for my $i ($self->chars) {
 102     $i =~ s/^\?//;
 103     # To Do: 私用�����域のは�����さないようにしないと。
 104     push @result, $i;
 105   }
 106   return @result;
 107 }
 108
 109 #--------------------------------------------------------#
 110
 111 sub chars {
 112   # ?... の配列を�����す
 113   my $self = shift;
 114   my @result = ('*');
 115   for my $attrname (keys %$self) {
 116     my @tmp = ();
 117     my $dbname = exists $alias{$attrname} ? $alias{$attrname} : $attrname;
 118     if (-f "$DB_HOME/$dbname/system-char-id") {
 119       @tmp = (&getvalue("$DB_HOME/$dbname/system-char-id", $$self{$attrname}));
 120       @result = &cap(\@result, \@tmp);
 121     } elsif (-f "$DB_HOME/system-char-id/$dbname") {
 122       @tmp = &getkeys("$DB_HOME/system-char-id/$dbname", $$self{$attrname});
 123       @result = &cap(\@result, \@tmp);
 124     } else {
 125       die "cannot find $attrname: $! $BerkeleyDB::Error\n";
 126     }
 127   }
 128   return @result;
 129 }
 130
 131 sub getvalue ($$) {
 132   # キーから値を�����り出す
 133   my($dbname, $key) = @_;
 134   tie my %h, "BerkeleyDB::Hash",
 135     -Filename => $dbname;
 136   my $value = $h{$key};
 137   untie %h;
 138   return $value;
 139 }
 140
 141 sub getkeys ($$) {
 142   # 値からキーの配列を�����り出す
 143   my($dbname, $value) = @_;
 144   tie my %h, "BerkeleyDB::Hash",
 145     -Filename => $dbname;
 146   my @keys = ();
 147   for my $key (keys %h) {
 148     push @keys, $key if ($h{$key} eq $value);
 149   }
 150   untie %h;
 151   return @keys;
 152 }
 153
 154 sub cap {
 155   # 2つの配列の積�����合を求める
 156   my($a, $b) = @_;
 157   if (!@$a or !@$b) {
 158     return ();
 159   } elsif ($$a[0] eq '*') { # '*'は全体�����合
 160     return @$b;
 161   } elsif ($$b[0] eq '*') {
 162     return @$a;
 163   } else {
 164     my %result = ();
 165     my @result = ();
 166     for my $i (@$a, @$b) {
 167       $result{$i}++;
 168       push @result, $i if ($result{$i} == 2);
 169     }
 170     return @result;
 171     #return grep {
 172     #  my $c = $_;
 173     #  grep /^$c$/, @$b;
 174     #} @$a;
 175   }
 176 }
 177
 178 #--------------------------------------------------------#
 179 1;