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 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 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     unless(defined($chardb{$atr})){
 146         &get_db($atr) or return "";
 147     }
 148     if($chardb{$atr}->{"?$char"}){
 149         return $chardb{$atr}->{"?$char"};
 150     }else{
 151         return "";
 152     }
 153 }
 154
 155 sub get_chars_containing{
 156     my($atr,$value)=@_;
 157     my($char,@res);
 158     &get_db($atr);
 159     if(defined(%{$chardb{$atr}})){
 160         foreach $char (keys %{$chardb{$atr}}){
 161             if($chardb{$atr}->{$char}=~/$value/){
 162                 $char=~s/^\?//;
 163                 push @res,$char;
 164             }
 165         }
 166     }
 167     return @res;
 168 }
 169
 170 sub get_chars_matching{
 171     my($atr,$value)=@_;
 172     my($char,@res);
 173     if(defined($reverse_db{$atr})){
 174         &get_reverse_db($atr);
 175         if(defined(%{$reverse_chardb{$atr}})){
 176             if($char=$reverse_chardb{$atr}->{$value}){
 177                 $char=~s/^\?//;
 178                 push @res,$char;
 179             }
 180         }
 181     }else{
 182         &get_db($atr);
 183         if(defined(%{$chardb{$atr}})){
 184             foreach $char (keys %{$chardb{$atr}}){
 185                 if($chardb{$atr}->{$char} eq $value){
 186                     $char=~s/^\?//;
 187                     push @res,$char;
 188                 }
 189             }
 190         }
 191     }
 192     return @res;
 193 }
 194
 195 sub get_chars_for{
 196     my($query)=@_;
 197     my @q=split(",",$query);
 198     my(%res,@res,$atr,$value);
 199     my $i=0;
 200     foreach $query (@q){
 201         if($query=~/=~/){
 202             ($atr,$value)=split("=~",$query,2);
 203             $i++;
 204             foreach (&get_chars_containing($atr,$value)){
 205                 $res{$_}++;
 206             }
 207         }elsif($query=~/==/){
 208             ($atr,$value)=split(/==/,$query,2);
 209             $i++;
 210             foreach (&get_chars_matching($atr,$value)){
 211                 $res{$_}++;
 212             }
 213         }
 214     }
 215     foreach (keys %res){
 216         if($res{$_}==$i){
 217             push @res,$_;
 218         }
 219     }
 220     return @res;
 221 }
 222
 223 sub de_er{
 224     my($er)=@_;
 225     my($output_char,$atr,$value);
 226     my $keys = join '|', keys %er_alias;
 227     if($er=~/^\d+$/){
 228         $output_char=pack("U",$er);
 229     }elsif($er=~/^U[\+\-]([a-fA-F\d]+)/){
 230         $output_char=pack("U",hex($1));
 231     }elsif($er=~/(?:I\-)?($keys)\-?([0-9a-f]+)/i){
 232         ($atr,$value)=($1,$2);
 233         unless($er_alias{$atr}=~/daikanwa|gt/){
 234             $value=hex($value);
 235         }
 236         ($output_char)=&get_chars_matching($er_alias{$atr},$value);
 237     }
 238     if($output_char){
 239       return $output_char;
 240     }else{
 241       return $er;
 242     }
 243 }
 244
 245 sub ids_argc{
 246     my($char)=@_;
 247     my $char_id=unpack("U",$char);
 248     if($char_id==0x2ff2 or $char_id==0x2ff3){
 249         return 3;
 250     }elsif($char_id>=0x2ff0 and $char_id<=0x2fff){
 251         return 2;
 252     }else{
 253         return 0;
 254     }
 255 }
 256
 257 # Autoload methods go after =cut, and are processed by the autosplit program.
 258
 259 1;
 260 __END__
 261 # Below is stub documentation for your module. You better edit it!
 262
 263 =head1 NAME
 264
 265 Chise_utils - Perl extension for blah blah blah
 266
 267 =head1 SYNOPSIS
 268
 269   use Chise_utils;
 270   blah blah blah
 271
 272 =head1 DESCRIPTION
 273
 274 Stub documentation for Chise_utils, created by h2xs. It looks like the
 275 author of the extension was negligent enough to leave the stub
 276 unedited.
 277
 278 Blah blah blah.
 279
 280 =head2 EXPORT
 281
 282 None by default.
 283
 284
 285 =head1 AUTHOR
 286
 287 A. U. Thor, a.u.thor@a.galaxy.far.far.away
 288
 289 =head1 SEE ALSO
 290
 291 perl(1).
 292
 293 =cut