Chise_utils/Chise_utils.pm

   1 package Chise_utils;
   2
   3 require 5.005;
   4 use strict;
   5 use warnings;
   6
   7 require Exporter;
   8
   9 use utf8;
  10 use BerkeleyDB;
  11 use vars qw(%db %chardb
  12             %reverse_db %reverse_chardb
  13             $atr $idc
  14         );
  15
  16 our @ISA = qw(Exporter);
  17
  18 # Items to export into callers namespace by default. Note: do not export
  19 # names by default without a very good reason. Use EXPORT_OK instead.
  20 # Do not simply export all your public functions/methods/constants.
  21
  22 # This allows declaration       use Chise_utils ':all';
  23 # If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
  24 # will save memory.
  25 our %EXPORT_TAGS = ( 'all' => [ qw(
  26                                    %db %chardb
  27                                    %reverse_db %reverse_chardb
  28                                    $idc
  29                                    &get_db
  30                                    &get_reverse_db
  31                                    &get_char_attribute
  32                                    &get_chars_matching
  33                                    &get_chars_containing
  34                                    &get_chars_matching
  35                                    &get_chars_for
  36                                    &de_er
  37                                    &ids_argc
  38 ) ] );
  39
  40 our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
  41
  42 our @EXPORT = qw(
  43 );
  44 our $VERSION = '0.01';
  45
  46
  47 # Preloaded methods go here.
  48
  49 my $DB_HOME="";
  50 if(-e '/usr/local/lib/xemacs-21.4.11/i686-pc-linux/char-db'){
  51     $DB_HOME='/usr/local/lib/xemacs-21.4.11/i686-pc-linux/char-db';
  52 }elsif(-e '/usr/local/lib/xemacs-21.4.11/powerpc-apple-darwin6.4/char-db'){
  53     $DB_HOME='/usr/local/lib/xemacs-21.4.11/powerpc-apple-darwin6.4/char-db';
  54 }elsif(-e '/usr/local/xemacs-utf2000/lib/xemacs-21.4.11/powerpc-apple-darwin6.4/char-db'){
  55     $DB_HOME='/usr/local/xemacs-utf2000/lib/xemacs-21.4.11/powerpc-apple-darwin6.4/char-db';
  56 }elsif(-e '/usr/local/lib/xemacs-21.4.10/i686-pc-linux/char-db'){
  57     $DB_HOME='/usr/local/lib/xemacs-21.4.10/i686-pc-linux/char-db';
  58 }elsif(-e '/usr/local/lib/xemacs-21.4.10/powerpc-apple-darwin6.4/char-db'){
  59     $DB_HOME='/usr/local/lib/xemacs-21.4.10/powerpc-apple-darwin6.4/char-db';
  60 }elsif(-e '/usr/local/xemacs-utf2000/lib/xemacs-21.4.10/powerpc-apple-darwin6.4/char-db'){
  61     $DB_HOME='/usr/local/xemacs-utf2000/lib/xemacs-21.4.10/powerpc-apple-darwin6.4/char-db';
  62 }elsif(-e 'd:/work/chise/char-db'){
  63     $DB_HOME='d:/work/chise/char-db';
  64 }else{
  65     print STDERR "No database found.\n";
  66     print STDERR "Pleas set \$DB_HOME to Chise_utils.pm.\n";
  67     exit 1;
  68 }
  69
  70 $idc="\x{2ff0}-\x{2fff}";
  71
  72 my %er_alias =
  73     ('C1','chinese-cns11643-1',
  74      'C2','chinese-cns11643-2',
  75      'C3','chinese-cns11643-3',
  76      'C4','chinese-cns11643-4',
  77      'C5','chinese-cns11643-5',
  78      'C6','chinese-cns11643-6',
  79      'C7','chinese-cns11643-7',
  80      'CB','ideograph-cbeta',
  81      'CDP','chinese-big5-cdp',
  82      'GT','ideograph-gt',
  83      'GT-K','ideograph-gt',
  84      'HZK1','ideograph-hanziku-1',
  85      'HZK2','ideograph-hanziku-2',
  86      'HZK3','ideograph-hanziku-3',
  87      'HZK4','ideograph-hanziku-4',
  88      'HZK5','ideograph-hanziku-5',
  89      'HZK6','ideograph-hanziku-6',
  90      'HZK7','ideograph-hanziku-7',
  91      'HZK8','ideograph-hanziku-8',
  92      'HZK9','ideograph-hanziku-9',
  93      'HZK10','ideograph-hanziku-10',
  94      'HZK11','ideograph-hanziku-11',
  95      'HZK12','ideograph-hanziku-12',
  96      'J78','japanese-jisx0208-1978',
  97      'J83','japanese-jisx0208',
  98      'J90','japanese-jisx0208-1990',
  99      'JSP','japanese-jisx0212',
 100      'JX1','japanese-jisx0213-1',
 101      'JX2','japanese-jisx0213-2',
 102      'K0','korean-ksc5601',
 103      'M','ideograph-daikanwa',
 104      );
 105
 106 for (glob "$DB_HOME/system-char-id/*"){
 107     next if(/\.txt$/);
 108     $atr=$_;
 109     $atr=~s!$DB_HOME/system-char-id/!!;
 110     $db{$atr}=$_;
 111 }
 112
 113 for (glob "$DB_HOME/*"){
 114     next if(/\.txt$/ or /system-char-id/);
 115     $atr=$_;
 116     $atr=~s!$DB_HOME/!!;
 117     $reverse_db{$atr}=$_."/system-char-id";
 118 }
 119
 120 sub get_db{
 121     my($atr)=@_;
 122     return 1 if(defined(%{$chardb{$atr}}));
 123     if(defined($db{$atr}) and -f $db{$atr}){
 124         tie %{$chardb{$atr}}, "BerkeleyDB::Hash",
 125         -Filename => $db{$atr};
 126     }else{
 127         return undef;
 128     }
 129 }
 130
 131 sub get_reverse_db{
 132     my($atr)=@_;
 133     return 1 if(defined(%{$reverse_chardb{$atr}}));
 134     if(defined($reverse_db{$atr}) and -f $reverse_db{$atr}){
 135         tie %{$reverse_chardb{$atr}}, "BerkeleyDB::Hash",
 136         -Filename => $reverse_db{$atr};
 137     }else{
 138         return undef;
 139     }
 140 }
 141
 142
 143 sub get_char_attribute{
 144     my($char,$atr)=@_;
 145     &get_db($atr) or return "";
 146     if($chardb{$atr}->{"?$char"}){
 147         return $chardb{$atr}->{"?$char"};
 148     }else{
 149         return "";
 150     }
 151 }
 152
 153 sub get_chars_containing{
 154     my($atr,$value)=@_;
 155     my($char,@res);
 156     if(&get_db($atr)){
 157         foreach $char (keys %{$chardb{$atr}}){
 158             if($chardb{$atr}->{$char}=~/$value/){
 159                 $char=~s/^\?//;
 160                 push @res,$char;
 161             }
 162         }
 163     }
 164     return @res;
 165 }
 166
 167 sub get_chars_matching{
 168     my($atr,$value)=@_;
 169     my($char,@res);
 170     if(defined($reverse_db{$atr})){
 171         if(&get_reverse_db($atr)){
 172             if($char=$reverse_chardb{$atr}->{$value}){
 173                 $char=~s/^\?//;
 174                 push @res,$char;
 175             }
 176         }
 177     }
 178     # else{
 179     # fall back if DB inconsistency exists.
 180     unless(@res){
 181         if(&get_db($atr)){
 182             foreach $char (keys %{$chardb{$atr}}){
 183                 if($chardb{$atr}->{$char} eq $value){
 184                     $char=~s/^\?//;
 185                     push @res,$char;
 186                 }
 187             }
 188         }
 189     }
 190     return @res;
 191 }
 192
 193 sub get_chars_for{
 194     my($query)=@_;
 195     my @q=split(",",$query);
 196     my(%res,@res,$atr,$value);
 197     my $i=0;
 198     foreach $query (@q){
 199         if($query=~/=~/){
 200             ($atr,$value)=split("=~",$query,2);
 201             $i++;
 202             foreach (&get_chars_containing($atr,$value)){
 203                 $res{$_}++;
 204             }
 205         }elsif($query=~/==/){
 206             ($atr,$value)=split(/==/,$query,2);
 207             $i++;
 208             foreach (&get_chars_matching($atr,$value)){
 209                 $res{$_}++;
 210             }
 211         }
 212     }
 213     foreach (keys %res){
 214         if($res{$_}==$i){
 215             push @res,$_;
 216         }
 217     }
 218     return @res;
 219 }
 220
 221 sub de_er{
 222     my($er)=@_;
 223     my($output_char,$atr,$value);
 224     my $keys = join '|', keys %er_alias;
 225     if($er=~/^\d+$/){
 226         $output_char=pack("U",$er);
 227     }elsif($er=~/^U[\+\-]([a-fA-F\d]+)/){
 228         $output_char=pack("U",hex($1));
 229     }elsif($er=~/(?:I\-)?($keys)\-?([0-9a-fA-F]+)/){
 230         ($atr,$value)=($1,$2);
 231         unless($er_alias{$atr}=~/daikanwa|gt/){
 232             $value=hex($value);
 233         }
 234         ($output_char)=&get_chars_matching($er_alias{$atr},$value);
 235     }
 236     if($output_char){
 237       return $output_char;
 238     }else{
 239       return $er;
 240     }
 241 }
 242
 243 sub ids_argc{
 244     my($char)=@_;
 245     my $char_id=unpack("U",$char);
 246     if($char_id==0x2ff2 or $char_id==0x2ff3){
 247         return 3;
 248     }elsif($char_id>=0x2ff0 and $char_id<=0x2fff){
 249         return 2;
 250     }else{
 251         return 0;
 252     }
 253 }
 254
 255 # Autoload methods go after =cut, and are processed by the autosplit program.
 256
 257 1;
 258 __END__
 259 # Below is stub documentation for your module. You better edit it!
 260
 261 =head1 NAME
 262
 263 Chise_utils - Perl extension for blah blah blah
 264
 265 =head1 SYNOPSIS
 266
 267   use Chise_utils;
 268   blah blah blah
 269
 270 =head1 DESCRIPTION
 271
 272 Stub documentation for Chise_utils, created by h2xs. It looks like the
 273 author of the extension was negligent enough to leave the stub
 274 unedited.
 275
 276 Blah blah blah.
 277
 278 =head2 EXPORT
 279
 280 None by default.
 281
 282
 283 =head1 AUTHOR
 284
 285 A. U. Thor, a.u.thor@a.galaxy.far.far.away
 286
 287 =head1 SEE ALSO
 288
 289 perl(1).
 290
 291 =cut