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_containing($atr,$value)){
 126                 $res{$_}++;
 127             }
 128         }elsif($query=~/=/){
 129             ($atr,$value)=split(/=+/,$query,2);
 130             $i++;
 131             foreach (&get_chars_matching($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($er)=@_;
 146     my($output_char);
 147     if($er=~/^\d+$/){
 148         $output_char=pack("U",$er);
 149     }elsif($er=~/^U[\+\-]([a-fA-F\d]+)/){
 150         $output_char=pack("U",hex($1));
 151     }elsif($er=~m/^CDP\-([a-fA-F\d]+)/){
 152         ($output_char)=&get_chars_matching("chinese-big5-cdp",$1);
 153         # chinese-big5-cdp      CDP- 4 X),
 154     }elsif($er=~m/^M\-([\d]+)/){
 155         ($output_char)=&get_chars_matching("ideograph-daikanwa",$1);
 156         # ideograph-daikanwa    M-   5 d),
 157     }elsif($er=~m/^CB\-([\d]+)/){
 158         ($output_char)=&get_chars_matching("ideograph-cbeta",$1);
 159         # ideograph-cbeta       CB   5 d),
 160     }elsif($er=~m/^GT\-([\d]+)/){
 161         ($output_char)=&get_chars_matching("ideograph-gt",$1);
 162         # ideograph-gt          GT-  5 d),
 163     }elsif($er=~m/^GT\-K\-([\d]+)/){
 164         ($output_char)=&get_chars_matching("ideograph-gt-k",$1);
 165         # ideograph-gt-k        GT-K 5 d),
 166     }elsif($er=~m/^J90\-([a-fA-F\d]+)/){
 167         ($output_char)=&get_chars_matching("japanese-jisx0208-1990",$1);
 168         # japanese-jisx0208-1990 J90- 4 X),
 169     }elsif($er=~m/^J83\-([a-fA-F\d]+)/){
 170         ($output_char)=&get_chars_matching("japanese-jisx0208",$1);
 171         # japanese-jisx0208     J83- 4 X),
 172     }elsif($er=~m/^JX1\-([a-fA-F\d]+)/){
 173         ($output_char)=&get_chars_matching("japanese-jisx0213-1",$1);
 174         # japanese-jisx0213-1   JX1- 4 X),
 175     }elsif($er=~m/^JX2\-([a-fA-F\d]+)/){
 176         ($output_char)=&get_chars_matching("japanese-jisx0213-2",$1);
 177         # japanese-jisx0213-2   JX2- 4 X),
 178     }elsif($er=~m/^JSP\-([a-fA-F\d]+)/){
 179         ($output_char)=&get_chars_matching("japanese-jisx0212",$1);
 180         # japanese-jisx0212     JSP- 4 X),
 181     }elsif($er=~m/^J78\-([a-fA-F\d]+)/){
 182         ($output_char)=&get_chars_matching("japanese-jisx0208-1978",$1);
 183         # japanese-jisx0208-1978 J78- 4 X),
 184     }elsif($er=~m/^C1\-([a-fA-F\d]+)/){
 185         ($output_char)=&get_chars_matching("chinese-cns11643-1",$1);
 186         # chinese-cns11643-1    C1-  4 X),
 187     }elsif($er=~m/^C2\-([a-fA-F\d]+)/){
 188         ($output_char)=&get_chars_matching("chinese-cns11643-2",$1);
 189         # chinese-cns11643-2    C2-  4 X),
 190     }elsif($er=~m/^C3\-([a-fA-F\d]+)/){
 191         ($output_char)=&get_chars_matching("chinese-cns11643-3",$1);
 192         # chinese-cns11643-3    C3-  4 X),
 193     }elsif($er=~m/^C4\-([a-fA-F\d]+)/){
 194         ($output_char)=&get_chars_matching("chinese-cns11643-4",$1);
 195         # chinese-cns11643-4    C4-  4 X),
 196     }elsif($er=~m/^C5\-([a-fA-F\d]+)/){
 197         ($output_char)=&get_chars_matching("chinese-cns11643-5",$1);
 198         # chinese-cns11643-5    C5-  4 X),
 199     }elsif($er=~m/^C6\-([a-fA-F\d]+)/){
 200         ($output_char)=&get_chars_matching("chinese-cns11643-6",$1);
 201         # chinese-cns11643-6    C6-  4 X),
 202     }elsif($er=~m/^C7\-([a-fA-F\d]+)/){
 203         ($output_char)=&get_chars_matching("chinese-cns11643-7",$1);
 204         # chinese-cns11643-7    C7-  4 X),
 205     }elsif($er=~m/^K0\-([a-fA-F\d]+)/){
 206         ($output_char)=&get_chars_matching("korean-ksc5601",$1);
 207         # korean-ksc5601        K0- 4 X),
 208     }
 209     if($output_char){
 210       return $output_char;
 211     }else{
 212       return $er;
 213     }
 214 }
 215
 216 sub ids_argc{
 217     my($char)=@_;
 218     my $char_id=unpack("U",$char);
 219     if($char_id==0x2ff2 or $char_id==0x2ff3){
 220         return 3;
 221     }elsif($char_id>=0x2ff0 and $char_id<=0x2fff){
 222         return 2;
 223     }else{
 224         return 0;
 225     }
 226 }
 227
 228 # Autoload methods go after =cut, and are processed by the autosplit program.
 229
 230 1;
 231 __END__
 232 # Below is stub documentation for your module. You better edit it!
 233
 234 =head1 NAME
 235
 236 Chise_utils - Perl extension for blah blah blah
 237
 238 =head1 SYNOPSIS
 239
 240   use Chise_utils;
 241   blah blah blah
 242
 243 =head1 DESCRIPTION
 244
 245 Stub documentation for Chise_utils, created by h2xs. It looks like the
 246 author of the extension was negligent enough to leave the stub
 247 unedited.
 248
 249 Blah blah blah.
 250
 251 =head2 EXPORT
 252
 253 None by default.
 254
 255
 256 =head1 AUTHOR
 257
 258 A. U. Thor, a.u.thor@a.galaxy.far.far.away
 259
 260 =head1 SEE ALSO
 261
 262 perl(1).
 263
 264 =cut