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/chise/char-db'){
  51     $DB_HOME='/usr/local/lib/chise/char-db';
  52 }elsif(-e '/usr/local/lib/xemacs-21.4.11/i686-pc-linux/char-db'){
  53     $DB_HOME='/usr/local/lib/xemacs-21.4.11/i686-pc-linux/char-db';
  54 }elsif(-e '/usr/local/lib/xemacs-21.4.11/powerpc-apple-darwin6.4/char-db'){
  55     $DB_HOME='/usr/local/lib/xemacs-21.4.11/powerpc-apple-darwin6.4/char-db';
  56 }elsif(-e '/usr/local/xemacs-utf2000/lib/xemacs-21.4.11/powerpc-apple-darwin6.4/char-db'){
  57     $DB_HOME='/usr/local/xemacs-utf2000/lib/xemacs-21.4.11/powerpc-apple-darwin6.4/char-db';
  58 }elsif(-e '/usr/local/lib/xemacs-21.4.10/i686-pc-linux/char-db'){
  59     $DB_HOME='/usr/local/lib/xemacs-21.4.10/i686-pc-linux/char-db';
  60 }elsif(-e '/usr/local/lib/xemacs-21.4.10/powerpc-apple-darwin6.4/char-db'){
  61     $DB_HOME='/usr/local/lib/xemacs-21.4.10/powerpc-apple-darwin6.4/char-db';
  62 }elsif(-e '/usr/local/xemacs-utf2000/lib/xemacs-21.4.10/powerpc-apple-darwin6.4/char-db'){
  63     $DB_HOME='/usr/local/xemacs-utf2000/lib/xemacs-21.4.10/powerpc-apple-darwin6.4/char-db';
  64 }elsif(-e 'd:/work/chise/char-db'){
  65     $DB_HOME='d:/work/chise/char-db';
  66 }else{
  67     print STDERR "No database found.\n";
  68     print STDERR "Pleas set \$DB_HOME to Chise_utils.pm.\n";
  69     exit 1;
  70 }
  71
  72 $idc="\x{2ff0}-\x{2fff}";
  73
  74 my %er_alias =
  75     ('C1','chinese-cns11643-1',
  76      'C2','chinese-cns11643-2',
  77      'C3','chinese-cns11643-3',
  78      'C4','chinese-cns11643-4',
  79      'C5','chinese-cns11643-5',
  80      'C6','chinese-cns11643-6',
  81      'C7','chinese-cns11643-7',
  82      'CB','ideograph-cbeta',
  83      'CDP','chinese-big5-cdp',
  84      'GT','ideograph-gt',
  85      'GT-K','ideograph-gt',
  86      'HZK1','ideograph-hanziku-1',
  87      'HZK2','ideograph-hanziku-2',
  88      'HZK3','ideograph-hanziku-3',
  89      'HZK4','ideograph-hanziku-4',
  90      'HZK5','ideograph-hanziku-5',
  91      'HZK6','ideograph-hanziku-6',
  92      'HZK7','ideograph-hanziku-7',
  93      'HZK8','ideograph-hanziku-8',
  94      'HZK9','ideograph-hanziku-9',
  95      'HZK10','ideograph-hanziku-10',
  96      'HZK11','ideograph-hanziku-11',
  97      'HZK12','ideograph-hanziku-12',
  98      'J78','japanese-jisx0208-1978',
  99      'J83','japanese-jisx0208',
 100      'J90','japanese-jisx0208-1990',
 101      'JSP','japanese-jisx0212',
 102      'JX1','japanese-jisx0213-1',
 103      'JX2','japanese-jisx0213-2',
 104      'K0','korean-ksc5601',
 105      'M','ideograph-daikanwa',
 106      );
 107
 108 for (glob "$DB_HOME/system-char-id/*"){
 109     next if(/\.txt$/);
 110     $atr=$_;
 111     $atr=~s!$DB_HOME/system-char-id/!!;
 112     $db{$atr}=$_;
 113 }
 114
 115 for (glob "$DB_HOME/*"){
 116     next if(/\.txt$/ or /system-char-id/);
 117     $atr=$_;
 118     $atr=~s!$DB_HOME/!!;
 119     $reverse_db{$atr}=$_."/system-char-id";
 120 }
 121
 122 sub get_db{
 123     my($atr)=@_;
 124     return 1 if(defined(%{$chardb{$atr}}));
 125     if(defined($db{$atr}) and -f $db{$atr}){
 126         tie %{$chardb{$atr}}, "BerkeleyDB::Hash",
 127         -Filename => $db{$atr};
 128     }else{
 129         return undef;
 130     }
 131 }
 132
 133 sub get_reverse_db{
 134     my($atr)=@_;
 135     return 1 if(defined(%{$reverse_chardb{$atr}}));
 136     if(defined($reverse_db{$atr}) and -f $reverse_db{$atr}){
 137         tie %{$reverse_chardb{$atr}}, "BerkeleyDB::Hash",
 138         -Filename => $reverse_db{$atr};
 139     }else{
 140         return undef;
 141     }
 142 }
 143
 144
 145 sub get_char_attribute{
 146     my($char,$atr)=@_;
 147     &get_db($atr) or return "";
 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     if(&get_db($atr)){
 159         foreach $char (keys %{$chardb{$atr}}){
 160             if($chardb{$atr}->{$char}=~/$value/){
 161                 $char=~s/^\?//;
 162                 push @res,$char;
 163             }
 164         }
 165     }
 166     return @res;
 167 }
 168
 169 sub get_chars_matching{
 170     my($atr,$value)=@_;
 171     my($char,@res);
 172     if(defined($reverse_db{$atr})){
 173         if(&get_reverse_db($atr)){
 174             if($char=$reverse_chardb{$atr}->{$value}){
 175                 $char=~s/^\?//;
 176                 push @res,$char;
 177             }
 178         }
 179     }
 180     else{
 181 #    # fall back if DB inconsistency exists.
 182 #    unless(@res){
 183         if(&get_db($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-fA-F]+)/){
 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