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