2 # CHISE.pm by Shigeki Moro
3 # $Id: CHISE.pm,v 1.2 2003-02-23 09:17:19 moro Exp $
10 my $DB_HOME = '/usr/local/lib/xemacs-21.4.10/i686-pc-linux/char-db';
13 my %alias_reverse = ();
14 for (glob "$DB_HOME/system-char-id/*") {
22 $alias_reverse{$i} = $_;
26 'radical','ideographic-radical',
27 'strokes','total-strokes',
30 #--- exportする予の関数 -------------------------------------#
35 my $class = ref($invocant) || $invocant;
38 my $key = ($self->chars)[0]; # 要エラーチェック
40 for my $dbname (glob "$DB_HOME/system-char-id/*") {
41 $value = &getvalue($dbname, $key);
43 $dbname =~ s/^.*\/([^\/]+)$/$1/;
44 $result->{$alias_reverse{$dbname}} = $value;
47 return bless $result, $class;
53 my $class = ref($invocant) || $invocant;
56 for my $i (keys %$self) {
57 $result->{$alias_reverse{$alias{$i}}} = $$self{$i};
59 return bless $result, $class;
63 # 字オブジェクトが持っている全属性をprint
65 for my $i (keys %$self) {
66 print "$i => $$self{$i}\n";
73 my $self = $model->define_char(%$model, @_);
80 delete $$model{$_} foreach (@_);
81 my $self = $model->define_char(%$model);
86 # 例: $s->morohashi_daikanwa
87 # cf. get_char_attribute
88 for my $attrname (keys %alias) {
89 my $slot = __PACKAGE__ . "::$attrname";
93 my $dbname = exists $alias{$attrname}
94 ? $alias_reverse{$alias{$attrname}}
96 return $self->{$dbname};
99 #for my $attrname (keys %alias) {
100 # my $slot = __PACKAGE__ . "::$attrname";
105 # for my $i ($self->chars) {
106 # my $j = &getvalue("$DB_HOME/system-char-id/$alias{$attrname}", $i);
107 # push @result, $j if $j;
116 my($all_attr, $common_attr) = (0, 0);
117 for my $i (&cup(keys %$a, keys %$b)) {
118 if ($a->{$i} eq $b->{$i}) {
122 $all_attr++ if (exists $a->{$i});
123 $all_attr++ if (exists $b->{$i});
126 return $all_attr ? ($common_attr / $all_attr) : 0;
133 'C1','chinese-cns11643-1',
134 'C2','chinese-cns11643-2',
135 'C3','chinese-cns11643-3',
136 'C4','chinese-cns11643-4',
137 'C5','chinese-cns11643-5',
138 'C6','chinese-cns11643-6',
139 'C7','chinese-cns11643-7',
140 'CB','ideograph-cbeta',
141 'CDP','chinese-big5-cdp',
143 'GT-K','ideograph-gt',
144 'HZK1','ideograph-hanziku-1',
145 'HZK2','ideograph-hanziku-2',
146 'HZK3','ideograph-hanziku-3',
147 'HZK4','ideograph-hanziku-4',
148 'HZK5','ideograph-hanziku-5',
149 'HZK6','ideograph-hanziku-6',
150 'HZK7','ideograph-hanziku-7',
151 'HZK8','ideograph-hanziku-8',
152 'HZK9','ideograph-hanziku-9',
153 'HZK10','ideograph-hanziku-10',
154 'HZK11','ideograph-hanziku-11',
155 'HZK12','ideograph-hanziku-12',
156 'J78','japanese-jisx0208-1978',
157 'J83','japanese-jisx0208',
158 'J90','japanese-jisx0208-1990',
159 'JSP','japanese-jisx0212',
160 'JX1','japanese-jisx0213-1',
161 'JX2','japanese-jisx0213-2',
162 'K0','korean-ksc5601',
163 'M','ideograph-daikanwa',
165 my $keys = join '|', sort keys %alias;
166 my($phname, $phvalue) = ($ph =~ /^\&(?:I\-)?($keys)\-?([0-9a-f]+);$/i);
167 if (exists $alias{$phname}) {
168 if ($alias{$phname} =~ /daikanwa|gt/) {
171 $phvalue = "0x$phvalue";
173 tie my %h, "BerkeleyDB::Hash",
174 -Filename => "$DB_HOME/$alias{$phname}/system-char-id"
175 or die "Cannot open file $alias{$phname}: $! $BerkeleyDB::Error\n";
176 if (exists $h{$phvalue}) {
179 #print STDERR "\tCan't convert $phname - $phvalue (no value in db).\n";
184 #print STDERR "\tCan't convert $phname - $phvalue.\n";
189 #--- モジュール内のみでう予の関数 ----------------------#
195 for my $attrname (keys %$self) {
197 my $dbname = exists $alias{$attrname} ? $alias{$attrname} : $attrname;
198 if (-f "$DB_HOME/$dbname/system-char-id") {
199 @tmp = (&getvalue("$DB_HOME/$dbname/system-char-id", $$self{$attrname}));
200 @result = &cap(\@result, \@tmp);
201 } elsif (-f "$DB_HOME/system-char-id/$dbname") {
202 @tmp = &getkeys("$DB_HOME/system-char-id/$dbname", $$self{$attrname});
203 @result = &cap(\@result, \@tmp);
205 die "cannot find $attrname: $! $BerkeleyDB::Error\n";
215 for my $i ($self->chars) {
217 # To Do: 私用域のはさないようにしないと。
225 my($dbname, $key) = @_;
226 tie my %h, "BerkeleyDB::Hash",
227 -Filename => $dbname;
228 my $value = $h{$key};
235 my($dbname, $value) = @_;
236 tie my %h, "BerkeleyDB::Hash",
237 -Filename => $dbname;
239 for my $key (keys %h) {
240 push @keys, $key if ($h{$key} eq $value);
251 } elsif ($$a[0] eq '*') { # '*'は全体合
253 } elsif ($$b[0] eq '*') {
258 for my $i (@$a, @$b) {
260 push @result, $i if ($result{$i} == 2);
273 for my $i (@_) { $result{$i}++; }
277 #--------------------------------------------------------#