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