From: 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/cgi-bin/gitweb.cgi?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;