--- /dev/null
+#
+# 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;
+++ /dev/null
-#
-# 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;
projects / chise / perl.git / commitdiff