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 $atr
  12         );
  13
  14 our @ISA = qw(Exporter);
  15
  16 # Items to export into callers namespace by default. Note: do not export
  17 # names by default without a very good reason. Use EXPORT_OK instead.
  18 # Do not simply export all your public functions/methods/constants.
  19
  20 # This allows declaration       use Chise_utils ':all';
  21 # If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
  22 # will save memory.
  23 our %EXPORT_TAGS = ( 'all' => [ qw(
  24                                    %db %chardb
  25                                    &get_char_attribute
  26                                    &get_chars_matching
  27                                    &get_chars_containing
  28                                    &get_chars_matching
  29                                    &get_chars_for
  30                                    &de_er
  31 ) ] );
  32
  33 our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
  34
  35 our @EXPORT = qw(
  36 );
  37 our $VERSION = '0.01';
  38
  39
  40 # Preloaded methods go here.
  41
  42 my $DB_HOME="";
  43 if(-e '/usr/local/lib/xemacs-21.4.10/i686-pc-linux/char-db/system-char-id'){
  44     $DB_HOME='/usr/local/lib/xemacs-21.4.10/i686-pc-linux/char-db/system-char-id';
  45 }elsif(-e 'd:/work/chise/char-db/system-char-id'){
  46     $DB_HOME='d:/work/chise/char-db/system-char-id';
  47 }elsif(-e '/usr/local/lib/xemacs-21.4.10/powerpc-apple-darwin6.4/char-db/system-char-id'){
  48     $DB_HOME='/usr/local/lib/xemacs-21.4.10/powerpc-apple-darwin6.4/char-db/system-char-id';
  49 }elsif(-e '/usr/local/xemacs-utf2000/lib/xemacs-21.4.10/powerpc-apple-darwin6.4/char-db/system-char-id'){
  50     $DB_HOME='/usr/local/xemacs-utf2000/lib/xemacs-21.4.10/powerpc-apple-darwin6.4/char-db/system-char-id';
  51 }else{
  52     print STDERR "No database found.\n";
  53     print STDERR "Pleas set \$DB_HOME to Chise_utils.pm.\n";
  54     exit 1;
  55 }
  56
  57 for (<$DB_HOME/*>){
  58     next if(/\.txt$/);
  59     $atr=$_;
  60     $atr=~s!$DB_HOME/!!;
  61     $db{$atr}=$_;
  62 }
  63
  64 foreach $atr (keys %db){
  65     if(defined($db{$atr}) and -f $db{$atr}){
  66         tie %{$chardb{$atr}}, "BerkeleyDB::Hash",
  67         -Filename => $db{$atr};
  68     }else{
  69         print STDERR "no target\n";
  70         exit 1;
  71     }
  72 }
  73
  74
  75 sub get_char_attribute{
  76     my($char,$atr)=@_;
  77     if($chardb{$atr}->{"?$char"}){
  78         return $chardb{$atr}->{"?$char"};
  79     }else{
  80         return "no attribute for $char";
  81     }
  82 }
  83
  84 sub get_chars_containing{
  85     my($atr,$value)=@_;
  86     my($char,@res);
  87     if(defined(%{$chardb{$atr}})){
  88         foreach $char (keys %{$chardb{$atr}}){
  89             if($chardb{$atr}->{$char}=~/$value/){
  90                 push @res,$char;
  91             }
  92         }
  93     }
  94     return @res;
  95 }
  96
  97 sub get_chars_matching{
  98     my($atr,$value)=@_;
  99     my($char,@res);
 100     if(defined(%{$chardb{$atr}})){
 101         foreach $char (keys %{$chardb{$atr}}){
 102             if($chardb{$atr}->{$char}=~/^$value$/){
 103                 push @res,$char;
 104             }
 105         }
 106     }
 107     return @res;
 108 }
 109
 110 sub get_chars_for{
 111     my($query)=@_;
 112     my @q=split(",",$query);
 113     my(%res,@res,$atr,$value);
 114     my $i=0;
 115     foreach $query (@q){
 116         if($query=~/==/){
 117             ($atr,$value)=split("==",$query,2);
 118             $i++;
 119             foreach (&get_chars_matching($atr,$value)){
 120                 $res{$_}++;
 121             }
 122         }elsif($query=~/=~/){
 123             ($atr,$value)=split("=~",$query,2);
 124             $i++;
 125             foreach (&get_chars_containing($atr,$value)){
 126                 $res{$_}++;
 127             }
 128         }
 129     }
 130     foreach (keys %res){
 131         if($res{$_}==$i){
 132             push @res,$_;
 133         }
 134     }
 135     return @res;
 136 }
 137
 138 sub de_er{
 139     my($char)=@_;
 140     if($char=~/^\d+$/){
 141         $char=pack("U",$char);
 142     }elsif($char=~/U[\+\-](\d+)/){
 143         $char=pack("U",$1);
 144     }elsif($char=~m/CDP\-(\d+)/){
 145         # chinese-big5-cdp      CDP- 4 X),
 146         # ideograph-daikanwa    M-   5 d),
 147         # ideograph-cbeta       CB   5 d),
 148         # ideograph-gt          GT-  5 d),
 149         # ideograph-gt-k        GT-K 5 d),
 150         # japanese-jisx0208-1990 J90- 4 X),
 151         # japanese-jisx0208     J83- 4 X),
 152         # japanese-jisx0213-1   JX1- 4 X),
 153         # japanese-jisx0213-2   JX2- 4 X),
 154         # japanese-jisx0212     JSP- 4 X),
 155         # japanese-jisx0208-1978 J78- 4 X),
 156         # chinese-cns11643-1    C1-  4 X),
 157         # chinese-cns11643-2    C2-  4 X),
 158         # chinese-cns11643-3    C3-  4 X),
 159         # chinese-cns11643-4    C4-  4 X),
 160         # chinese-cns11643-5    C5-  4 X),
 161         # chinese-cns11643-6    C6-  4 X),
 162         # chinese-cns11643-7    C7-  4 X),
 163         # korean-ksc5601        K0- 4 X),
 164     }
 165     return $char;
 166 }
 167
 168 # Autoload methods go after =cut, and are processed by the autosplit program.
 169
 170 1;
 171 __END__
 172 # Below is stub documentation for your module. You better edit it!
 173
 174 =head1 NAME
 175
 176 Chise_utils - Perl extension for blah blah blah
 177
 178 =head1 SYNOPSIS
 179
 180   use Chise_utils;
 181   blah blah blah
 182
 183 =head1 DESCRIPTION
 184
 185 Stub documentation for Chise_utils, created by h2xs. It looks like the
 186 author of the extension was negligent enough to leave the stub
 187 unedited.
 188
 189 Blah blah blah.
 190
 191 =head2 EXPORT
 192
 193 None by default.
 194
 195
 196 =head1 AUTHOR
 197
 198 A. U. Thor, a.u.thor@a.galaxy.far.far.away
 199
 200 =head1 SEE ALSO
 201
 202 perl(1).
 203
 204 =cut