From: moro <moro>
Date: Sun, 2 Feb 2003 12:25:10 +0000 (+0000)
Subject: delete UTF2000.pm and add CHISE.pm. / bug-fix.
X-Git-Url: http://git.chise.org/gitweb/?a=commitdiff_plain;h=1a0dec300372096daf2afa5be230409301465be8;p=chise%2Fperl.git

delete UTF2000.pm and add CHISE.pm. / bug-fix.
---

diff --git a/CHISE.pm b/CHISE.pm
new file mode 100644
index 0000000..f4eca2f
--- /dev/null
+++ b/CHISE.pm
@@ -0,0 +1,216 @@
+#
+# CHISE.pm by Shigeki Moro
+# $Id: CHISE.pm,v 1.1 2003-02-02 12:25:10 moro Exp $
+#
+package CHISE;
+
+use strict;
+use BerkeleyDB;
+
+my $DB_HOME = '/usr/local/lib/xemacs-21.4.10/i686-pc-linux/char-db';
+
+my %alias = ();
+my %alias_reverse = ();
+for (glob "$DB_HOME/system-char-id/*") {
+  s/^.*\/([^\/]+)$/$1/;
+  my $i = $_;
+  s/\->/to_/;
+  s/<\-/from_/;
+  s/=>/map_/;
+  s/\-/_/g;
+  $alias{$_} = $i;
+  $alias_reverse{$i} = $_;
+}
+%alias = (
+	  %alias,
+	  'radical','ideographic-radical',
+	  'strokes','total-strokes',
+);
+
+#--------------------------------------------------------#
+
+sub new {
+  # 既存のø½Š²¡å­—オブジェクトの生成
+  my $invocant = shift;
+  my $class = ref($invocant) || $invocant;
+  my $self  = { @_ };
+  bless $self, $class;
+  my $key = ($self->chars)[0]; # 要エラーチェック
+  my($value, $result);
+  for my $dbname (glob "$DB_HOME/system-char-id/*") {
+    $value = &getvalue($dbname, $key);
+    if ($value) {
+      $dbname =~ s/^.*\/([^\/]+)$/$1/;
+      $result->{$alias_reverse{$dbname}} = $value;
+    }
+  }
+  return bless $result, $class;
+}
+
+sub define_char {
+  # ø½Š¢–しいø½Š²¡å­—オブジェクトの生成
+  my $invocant = shift;
+  my $class = ref($invocant) || $invocant;
+  my $self = {@_};
+  my $result = ();
+  for my $i (keys %$self) {
+    $result->{$alias_reverse{$alias{$i}}} = $$self{$i};
+  }
+  return bless $result, $class;
+}
+
+sub dumpAttr {
+  # ø½Š²¡å­—オブジェクトが持っている全属性を表示
+  my $self = shift;
+  for my $i (keys %$self) {
+    print "$i => $$self{$i}\n";
+  }
+}
+
+sub addAttr {
+  # ø½Š²¡å­—オブジェクトに属性を追加
+  my $model = shift;
+  my $self = $model->define_char(%$model, @_);
+  return $self;
+}
+
+sub delAttr (@) {
+  # ø½Š²¡å­—オブジェクトから属性を削除
+  my $model = shift;
+  delete $$model{$_} foreach (@_);
+  my $self = $model->define_char(%$model);
+  return $self;
+}
+
+# 属性名で属性値をø½Š²¿ã™
+# 例: $s->morohashi_daikanwa
+for my $attrname (keys %alias) {
+  my $slot = __PACKAGE__ . "::$attrname";
+  no strict "refs";
+  *$slot = sub {
+    my $self = shift;
+    my $dbname = exists $alias{$attrname}
+      ? $alias_reverse{$alias{$attrname}}
+      : $attrname;
+    return $self->{$dbname};
+  }
+}
+#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 compare {
+  my($a, $b) = @_;
+  my($all_attr, $common_attr) = (0, 0);
+  for my $i (&cup(keys %$a, keys %$b)) {
+    if ($a->{$i} eq $b->{$i}) {
+      $all_attr++;
+      $common_attr++;
+    } else {
+      $all_attr++ if (exists $a->{$i});
+      $all_attr++ if (exists $b->{$i});
+    }
+  }
+  return $all_attr ? ($common_attr / $all_attr) : 0;
+}
+
+#--------------------------------------------------------#
+
+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;
+  }
+}
+
+sub cup {
+  # 2つの配列の和ø½ŠŸ›åˆã‚’求める
+  my %result = ();
+  for my $i (@_) { $result{$i}++; }
+  return keys %result;
+}
+
+#--------------------------------------------------------#
+1;
diff --git a/UTF2000.pm b/UTF2000.pm
deleted file mode 100644
index fb430a1..0000000
--- a/UTF2000.pm
+++ /dev/null
@@ -1,212 +0,0 @@
-#
-# UTF2000.pm by Shigeki Moro
-# UTF2000.pm,v 1.6 2003/01/31 18:25:24 moro Exp
-#
-package UTF2000;
-
-use strict;
-use BerkeleyDB;
-
-my $DB_HOME = '/usr/local/lib/xemacs-21.4.10/i686-pc-linux/char-db';
-
-my %alias = ();
-my %alias_reverse = ();
-for (glob "$DB_HOME/system-char-id/*") {
-  s/^.*\/([^\/]+)$/$1/;
-  my $i = $_;
-  s/\->/to_/;
-  s/<\-/from_/;
-  s/=>/map_/;
-  s/\-/_/g;
-  $alias{$_} = $i;
-  $alias_reverse{$i} = $_;
-}
-%alias = (
-	  %alias,
-	  'radical','ideographic-radical',
-	  'strokes','total-strokes',
-);
-
-#--------------------------------------------------------#
-
-sub new {
-  # 既存のø½Š²¡å­—オブジェクトの生成
-  my $invocant = shift;
-  my $class = ref($invocant) || $invocant;
-  my $self  = { @_ };
-  bless $self, $class;
-  my $key = ($self->chars)[0]; # 要エラーチェック
-  my($value, $result);
-  for my $dbname (glob "$DB_HOME/system-char-id/*") {
-    $value = &getvalue($dbname, $key);
-    if ($value) {
-      $dbname =~ s/^.*\/([^\/]+)$/$1/;
-      $result->{$alias_reverse{$dbname}} = $value;
-    }
-  }
-  return bless $result, $class;
-}
-
-sub define_char {
-  # ø½Š¢–しいø½Š²¡å­—オブジェクトの生成
-  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->define_char(%$model, @_);
-  return $self;
-}
-
-sub delAttr (@) {
-  # ø½Š²¡å­—オブジェクトから属性を削除
-  my $model = shift;
-  delete $$model{$_} foreach (@_);
-  my $self = $model->define_char(%$model);
-  return $self;
-}
-
-# 属性名で属性値をø½Š²¿ã™
-# 例: $s->morohashi_daikanwa
-for my $attrname (keys %alias) {
-  my $slot = __PACKAGE__ . "::$attrname";
-  no strict "refs";
-  *$slot = sub {
-    my $self = shift;
-    my $dbname = exists $alias{$attrname}
-      ? $alias_reverse{$alias{$attrname}}
-	: $attrname;
-    return $self->{$dbname};
-  }
-}
-#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 compare {
-  my($a, $b) = @_;
-  my($all_attr, $common_attr) = (0, 0);
-  for my $i (&cup(keys %$a, keys %$b)) {
-    if ($a->{$i} eq $b->{$i}) {
-      $all_attr++;
-      $common_attr++;
-    } else {
-      $all_attr++ if (exists $a->{$i});
-      $all_attr++ if (exists $b->{$i});
-    }
-  }
-  return $all_attr ? ($common_attr / $all_attr) : 0;
-}
-
-#--------------------------------------------------------#
-
-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;
-  }
-}
-
-sub cup {
-  # 2つの配列の和ø½ŠŸ›åˆã‚’求める
-  my %result = ();
-  for my $i (@_) { $result{$i}++; }
-  return keys %result;
-}
-
-#--------------------------------------------------------#
-1;