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.11/i686-pc-linux/char-db/system-char-id'){
  46     $DB_HOME='/usr/local/lib/xemacs-21.4.11/i686-pc-linux/char-db/system-char-id';
  47 }elsif(-e '/usr/local/lib/xemacs-21.4.11/powerpc-apple-darwin6.4/char-db/system-char-id'){
  48     $DB_HOME='/usr/local/lib/xemacs-21.4.11/powerpc-apple-darwin6.4/char-db/system-char-id';
  49 }elsif(-e '/usr/local/xemacs-utf2000/lib/xemacs-21.4.11/powerpc-apple-darwin6.4/char-db/system-char-id'){
  50     $DB_HOME='/usr/local/xemacs-utf2000/lib/xemacs-21.4.11/powerpc-apple-darwin6.4/char-db/system-char-id';
  51 }elsif(-e '/usr/local/lib/xemacs-21.4.10/i686-pc-linux/char-db/system-char-id'){
  52     $DB_HOME='/usr/local/lib/xemacs-21.4.10/i686-pc-linux/char-db/system-char-id';
  53 }elsif(-e '/usr/local/lib/xemacs-21.4.10/powerpc-apple-darwin6.4/char-db/system-char-id'){
  54     $DB_HOME='/usr/local/lib/xemacs-21.4.10/powerpc-apple-darwin6.4/char-db/system-char-id';
  55 }elsif(-e '/usr/local/xemacs-utf2000/lib/xemacs-21.4.10/powerpc-apple-darwin6.4/char-db/system-char-id'){
  56     $DB_HOME='/usr/local/xemacs-utf2000/lib/xemacs-21.4.10/powerpc-apple-darwin6.4/char-db/system-char-id';
  57 }elsif(-e 'd:/work/chise/char-db/system-char-id'){
  58     $DB_HOME='d:/work/chise/char-db/system-char-id';
  59 }else{
  60     print STDERR "No database found.\n";
  61     print STDERR "Pleas set \$DB_HOME to Chise_utils.pm.\n";
  62     exit 1;
  63 }
  64
  65 $idc="\x{2ff0}-\x{2fff}";
  66
  67 for (<$DB_HOME/*>){
  68     next if(/\.txt$/);
  69     $atr=$_;
  70     $atr=~s!$DB_HOME/!!;
  71     $db{$atr}=$_;
  72 }
  73
  74 foreach $atr (keys %db){
  75     if(defined($db{$atr}) and -f $db{$atr}){
  76         tie %{$chardb{$atr}}, "BerkeleyDB::Hash",
  77         -Filename => $db{$atr};
  78     }else{
  79         print STDERR "no target\n";
  80         exit 1;
  81     }
  82 }
  83
  84
  85 sub get_char_attribute{
  86     my($char,$atr)=@_;
  87     if($chardb{$atr}->{"?$char"}){
  88         return $chardb{$atr}->{"?$char"};
  89     }else{
  90         return "";
  91     }
  92 }
  93
  94 sub get_chars_containing{
  95     my($atr,$value)=@_;
  96     my($char,@res);
  97     if(defined(%{$chardb{$atr}})){
  98         foreach $char (keys %{$chardb{$atr}}){
  99             if($chardb{$atr}->{$char}=~/$value/){
 100                 $char=~s/^\?//;
 101                 push @res,$char;
 102             }
 103         }
 104     }
 105     return @res;
 106 }
 107
 108 sub get_chars_matching{
 109     my($atr,$value)=@_;
 110     my($char,@res);
 111     if(defined(%{$chardb{$atr}})){
 112         foreach $char (keys %{$chardb{$atr}}){
 113             if($chardb{$atr}->{$char} eq $value){
 114                 $char=~s/^\?//;
 115                 push @res,$char;
 116             }
 117         }
 118     }
 119     return @res;
 120 }
 121
 122 sub get_chars_for{
 123     my($query)=@_;
 124     my @q=split(",",$query);
 125     my(%res,@res,$atr,$value);
 126     my $i=0;
 127     foreach $query (@q){
 128         if($query=~/=~/){
 129             ($atr,$value)=split("=~",$query,2);
 130             $i++;
 131             foreach (&get_chars_containing($atr,$value)){
 132                 $res{$_}++;
 133             }
 134         }elsif($query=~/=/){
 135             ($atr,$value)=split(/=+/,$query,2);
 136             $i++;
 137             foreach (&get_chars_matching($atr,$value)){
 138                 $res{$_}++;
 139             }
 140         }
 141     }
 142     foreach (keys %res){
 143         if($res{$_}==$i){
 144             push @res,$_;
 145         }
 146     }
 147     return @res;
 148 }
 149
 150 sub de_er{
 151     my($er)=@_;
 152     my($output_char);
 153     if($er=~/^\d+$/){
 154         $output_char=pack("U",$er);
 155     }elsif($er=~/^U[\+\-]([a-fA-F\d]+)/){
 156         $output_char=pack("U",hex($1));
 157     }elsif($er=~m/^CDP\-([a-fA-F\d]+)/){
 158         ($output_char)=&get_chars_matching("chinese-big5-cdp",$1);
 159         # chinese-big5-cdp      CDP- 4 X),
 160     }elsif($er=~m/^M\-([\d]+)/){
 161         ($output_char)=&get_chars_matching("ideograph-daikanwa",$1);
 162         # ideograph-daikanwa    M-   5 d),
 163     }elsif($er=~m/^CB\-([\d]+)/){
 164         ($output_char)=&get_chars_matching("ideograph-cbeta",$1);
 165         # ideograph-cbeta       CB   5 d),
 166     }elsif($er=~m/^GT\-([\d]+)/){
 167         ($output_char)=&get_chars_matching("ideograph-gt",$1);
 168         # ideograph-gt          GT-  5 d),
 169     }elsif($er=~m/^GT\-K\-([\d]+)/){
 170         ($output_char)=&get_chars_matching("ideograph-gt-k",$1);
 171         # ideograph-gt-k        GT-K 5 d),
 172     }elsif($er=~m/^J90\-([a-fA-F\d]+)/){
 173         ($output_char)=&get_chars_matching("japanese-jisx0208-1990",$1);
 174         # japanese-jisx0208-1990 J90- 4 X),
 175     }elsif($er=~m/^J83\-([a-fA-F\d]+)/){
 176         ($output_char)=&get_chars_matching("japanese-jisx0208",$1);
 177         # japanese-jisx0208     J83- 4 X),
 178     }elsif($er=~m/^JX1\-([a-fA-F\d]+)/){
 179         ($output_char)=&get_chars_matching("japanese-jisx0213-1",$1);
 180         # japanese-jisx0213-1   JX1- 4 X),
 181     }elsif($er=~m/^JX2\-([a-fA-F\d]+)/){
 182         ($output_char)=&get_chars_matching("japanese-jisx0213-2",$1);
 183         # japanese-jisx0213-2   JX2- 4 X),
 184     }elsif($er=~m/^JSP\-([a-fA-F\d]+)/){
 185         ($output_char)=&get_chars_matching("japanese-jisx0212",$1);
 186         # japanese-jisx0212     JSP- 4 X),
 187     }elsif($er=~m/^J78\-([a-fA-F\d]+)/){
 188         ($output_char)=&get_chars_matching("japanese-jisx0208-1978",$1);
 189         # japanese-jisx0208-1978 J78- 4 X),
 190     }elsif($er=~m/^C1\-([a-fA-F\d]+)/){
 191         ($output_char)=&get_chars_matching("chinese-cns11643-1",$1);
 192         # chinese-cns11643-1    C1-  4 X),
 193     }elsif($er=~m/^C2\-([a-fA-F\d]+)/){
 194         ($output_char)=&get_chars_matching("chinese-cns11643-2",$1);
 195         # chinese-cns11643-2    C2-  4 X),
 196     }elsif($er=~m/^C3\-([a-fA-F\d]+)/){
 197         ($output_char)=&get_chars_matching("chinese-cns11643-3",$1);
 198         # chinese-cns11643-3    C3-  4 X),
 199     }elsif($er=~m/^C4\-([a-fA-F\d]+)/){
 200         ($output_char)=&get_chars_matching("chinese-cns11643-4",$1);
 201         # chinese-cns11643-4    C4-  4 X),
 202     }elsif($er=~m/^C5\-([a-fA-F\d]+)/){
 203         ($output_char)=&get_chars_matching("chinese-cns11643-5",$1);
 204         # chinese-cns11643-5    C5-  4 X),
 205     }elsif($er=~m/^C6\-([a-fA-F\d]+)/){
 206         ($output_char)=&get_chars_matching("chinese-cns11643-6",$1);
 207         # chinese-cns11643-6    C6-  4 X),
 208     }elsif($er=~m/^C7\-([a-fA-F\d]+)/){
 209         ($output_char)=&get_chars_matching("chinese-cns11643-7",$1);
 210         # chinese-cns11643-7    C7-  4 X),
 211     }elsif($er=~m/^K0\-([a-fA-F\d]+)/){
 212         ($output_char)=&get_chars_matching("korean-ksc5601",$1);
 213         # korean-ksc5601        K0- 4 X),
 214     }
 215     if($output_char){
 216       return $output_char;
 217     }else{
 218       return $er;
 219     }
 220 }
 221
 222 sub ids_argc{
 223     my($char)=@_;
 224     my $char_id=unpack("U",$char);
 225     if($char_id==0x2ff2 or $char_id==0x2ff3){
 226         return 3;
 227     }elsif($char_id>=0x2ff0 and $char_id<=0x2fff){
 228         return 2;
 229     }else{
 230         return 0;
 231     }
 232 }
 233
 234 # Autoload methods go after =cut, and are processed by the autosplit program.
 235
 236 1;
 237 __END__
 238 # Below is stub documentation for your module. You better edit it!
 239
 240 =head1 NAME
 241
 242 Chise_utils - Perl extension for blah blah blah
 243
 244 =head1 SYNOPSIS
 245
 246   use Chise_utils;
 247   blah blah blah
 248
 249 =head1 DESCRIPTION
 250
 251 Stub documentation for Chise_utils, created by h2xs. It looks like the
 252 author of the extension was negligent enough to leave the stub
 253 unedited.
 254
 255 Blah blah blah.
 256
 257 =head2 EXPORT
 258
 259 None by default.
 260
 261
 262 =head1 AUTHOR
 263
 264 A. U. Thor, a.u.thor@a.galaxy.far.far.away
 265
 266 =head1 SEE ALSO
 267
 268 perl(1).
 269
 270 =cut