New file

diff --git a/UTF2000.pm b/UTF2000.pm
new file mode 100644 (file)
index 0000000..bc7f123
--- /dev/null
+++ b/UTF2000.pm
@@ -0,0 +1,150 @@
+package UTF2000;
+
+use strict;
+use BerkeleyDB;
+
+my $DB_HOME = '/usr/local/lib/xemacs-21.4.10/i686-pc-linux/char-db';
+
+my %alias = ();
+for (glob "$DB_HOME/system-char-id/*") {
+  s/^.*\/([^\/]+)$/$1/;
+  my $i = $_;
+  s/\->/to_/;
+  s/<\-/from_/;
+  s/=>/map_/;
+  s/\-/_/g;
+  $alias{$_} = $i;
+}
+%alias = (
+         %alias,
+         'radical','ideographic-radical',
+         'strokes','ideographic-strokes',
+);
+
+#--------------------------------------------------------#
+
+sub new {
+  my $invocant = shift;
+  my $class = ref($invocant) || $invocant;
+  my $self  = { @_ };
+  return bless $self, $class;
+}
+
+sub dumpAttr {
+  my $self = shift;
+  for my $i (keys %$self) {
+    print "$i => $$self{$i}\n";
+  }
+}
+
+sub addAttr {
+  my $model = shift;
+  my $self = $model->new(%$model, @_);
+  return $self;
+}
+
+sub delAttr (@) {
+  my $model = shift;
+  delete $$model{$_} foreach (@_);
+  my $self = $model->new(%$model);
+  return $self;
+}
+
+# 
+for my $attrname (keys %alias) {
+  my $slot = __PACKAGE__ . "::$attrname";
+  no strict "refs";
+  *$slot = sub {
+    my $self = shift;
+    my @result;
+    for my $i ($self->chars) {
+      my $j = &getvalue("$DB_HOME/system-char-id/$alias{$attrname}", $i);
+      push @result, $j if $j;
+    }
+    return @result;
+  }
+}
+
+sub utf8 {
+  # UTF-8を�����す
+  my $self = shift;
+  my @result;
+  for my $i ($self->chars) {
+    $i =~ s/^\?//;
+    # To Do: 私用�����域のは�����さないようにしないと。
+    push @result, $i;
+  }
+  return @result;
+}
+
+#--------------------------------------------------------#
+
+sub chars {
+  # ?... を�����す
+  my $self = shift;
+  my @result = ('*');
+  for my $attrname (keys %$self) {
+    my @tmp = ();
+    my $dbname = exists $alias{$attrname} ? $alias{$attrname} : $attrname;
+    if (-f "$DB_HOME/$dbname/system-char-id") {
+      @tmp = (&getvalue("$DB_HOME/$dbname/system-char-id", $$self{$attrname}));
+      @result = &cap(\@result, \@tmp);
+    } elsif (-f "$DB_HOME/system-char-id/$dbname") {
+      @tmp = &getkeys("$DB_HOME/system-char-id/$dbname", $$self{$attrname});
+      @result = &cap(\@result, \@tmp);
+    } else {
+      die "cannot find $attrname: $! $BerkeleyDB::Error\n";
+    }
+  }
+  return @result;
+}
+
+sub getvalue ($$) {
+  # キーから値を�����り出す
+  my($dbname, $key) = @_;
+  tie my %h, "BerkeleyDB::Hash",
+    -Filename => $dbname;
+  my $value = $h{$key};
+  untie %h;
+  return $value;
+}
+
+sub getkeys ($$) {
+  # 値からキーの配列を�����り出す
+  my($dbname, $value) = @_;
+  tie my %h, "BerkeleyDB::Hash",
+    -Filename => $dbname;
+  my @keys = ();
+  for my $key (keys %h) {
+    push @keys, $key if ($h{$key} eq $value);
+  }
+  untie %h;
+  return @keys;
+}
+
+sub cap {
+  # 2つの配列の積�����合を求める
+  my($a, $b) = @_;
+  if (!@$a or !@$b) {
+    return ();
+  } elsif ($$a[0] eq '*') { # '*'は全体�����合
+    return @$b;
+  } elsif ($$b[0] eq '*') {
+    return @$a;
+  } else {
+    my %result = ();
+    my @result = ();
+    for my $i (@$a, @$b) {
+      $result{$i}++;
+      push @result, $i if ($result{$i} == 2);
+    }
+    return @result;
+    #return grep {
+    #  my $c = $_;
+    #  grep /^$c$/, @$b;
+    #} @$a;
+  }
+}
+
+#--------------------------------------------------------#
+1;