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