UTF2000.pm

   1 package UTF2000;
   2
   3 use strict;
   4 use BerkeleyDB;
   5
   6 my $DB_HOME = '/usr/local/lib/xemacs-21.4.10/i686-pc-linux/char-db';
   7
   8 my %alias = ();
   9 for (glob "$DB_HOME/system-char-id/*") {
  10   s/^.*\/([^\/]+)$/$1/;
  11   my $i = $_;
  12   s/\->/to_/;
  13   s/<\-/from_/;
  14   s/=>/map_/;
  15   s/\-/_/g;
  16   $alias{$_} = $i;
  17 }
  18 %alias = (
  19           %alias,
  20           'radical','ideographic-radical',
  21           'strokes','ideographic-strokes',
  22 );
  23
  24 #--------------------------------------------------------#
  25
  26 sub new {
  27   my $invocant = shift;
  28   my $class = ref($invocant) || $invocant;
  29   my $self  = { @_ };
  30   return bless $self, $class;
  31 }
  32
  33 sub dumpAttr {
  34   my $self = shift;
  35   for my $i (keys %$self) {
  36     print "$i => $$self{$i}\n";
  37   }
  38 }
  39
  40 sub addAttr {
  41   my $model = shift;
  42   my $self = $model->new(%$model, @_);
  43   return $self;
  44 }
  45
  46 sub delAttr (@) {
  47   my $model = shift;
  48   delete $$model{$_} foreach (@_);
  49   my $self = $model->new(%$model);
  50   return $self;
  51 }
  52
  53 #
  54 for my $attrname (keys %alias) {
  55   my $slot = __PACKAGE__ . "::$attrname";
  56   no strict "refs";
  57   *$slot = sub {
  58     my $self = shift;
  59     my @result;
  60     for my $i ($self->chars) {
  61       my $j = &getvalue("$DB_HOME/system-char-id/$alias{$attrname}", $i);
  62       push @result, $j if $j;
  63     }
  64     return @result;
  65   }
  66 }
  67
  68 sub utf8 {
  69   # UTF-8を�����す
  70   my $self = shift;
  71   my @result;
  72   for my $i ($self->chars) {
  73     $i =~ s/^\?//;
  74     # To Do: 私用�����域のは�����さないようにしないと。
  75     push @result, $i;
  76   }
  77   return @result;
  78 }
  79
  80 #--------------------------------------------------------#
  81
  82 sub chars {
  83   # ?... を�����す
  84   my $self = shift;
  85   my @result = ('*');
  86   for my $attrname (keys %$self) {
  87     my @tmp = ();
  88     my $dbname = exists $alias{$attrname} ? $alias{$attrname} : $attrname;
  89     if (-f "$DB_HOME/$dbname/system-char-id") {
  90       @tmp = (&getvalue("$DB_HOME/$dbname/system-char-id", $$self{$attrname}));
  91       @result = &cap(\@result, \@tmp);
  92     } elsif (-f "$DB_HOME/system-char-id/$dbname") {
  93       @tmp = &getkeys("$DB_HOME/system-char-id/$dbname", $$self{$attrname});
  94       @result = &cap(\@result, \@tmp);
  95     } else {
  96       die "cannot find $attrname: $! $BerkeleyDB::Error\n";
  97     }
  98   }
  99   return @result;
 100 }
 101
 102 sub getvalue ($$) {
 103   # キーから値を�����り出す
 104   my($dbname, $key) = @_;
 105   tie my %h, "BerkeleyDB::Hash",
 106     -Filename => $dbname;
 107   my $value = $h{$key};
 108   untie %h;
 109   return $value;
 110 }
 111
 112 sub getkeys ($$) {
 113   # 値からキーの配列を�����り出す
 114   my($dbname, $value) = @_;
 115   tie my %h, "BerkeleyDB::Hash",
 116     -Filename => $dbname;
 117   my @keys = ();
 118   for my $key (keys %h) {
 119     push @keys, $key if ($h{$key} eq $value);
 120   }
 121   untie %h;
 122   return @keys;
 123 }
 124
 125 sub cap {
 126   # 2つの配列の積�����合を求める
 127   my($a, $b) = @_;
 128   if (!@$a or !@$b) {
 129     return ();
 130   } elsif ($$a[0] eq '*') { # '*'は全体�����合
 131     return @$b;
 132   } elsif ($$b[0] eq '*') {
 133     return @$a;
 134   } else {
 135     my %result = ();
 136     my @result = ();
 137     for my $i (@$a, @$b) {
 138       $result{$i}++;
 139       push @result, $i if ($result{$i} == 2);
 140     }
 141     return @result;
 142     #return grep {
 143     #  my $c = $_;
 144     #  grep /^$c$/, @$b;
 145     #} @$a;
 146   }
 147 }
 148
 149 #--------------------------------------------------------#
 150 1;