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