Chise_utils/Chise_utils.pm

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