package Chise_utils;

require 5.005;
use strict;
use warnings;

require Exporter;

use utf8;
use BerkeleyDB;
use vars qw(%db %chardb
	    %reverse_db %reverse_chardb
	    $atr $idc
	);

our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use Chise_utils ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(
				   %db %chardb
				   %reverse_db %reverse_chardb
				   $idc
				   &get_db
				   &get_reverse_db
				   &get_char_attribute
				   &get_chars_matching
				   &get_chars_containing
				   &get_chars_matching
				   &get_chars_for
				   &de_er
				   &ids_argc
) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(
);
our $VERSION = '0.01';


# Preloaded methods go here.

my $DB_HOME="";
if(-e '/usr/local/lib/chise/char-db'){
    $DB_HOME='/usr/local/lib/chise/char-db';
}elsif(-e '/usr/local/lib/xemacs-21.4.11/i686-pc-linux/char-db'){
    $DB_HOME='/usr/local/lib/xemacs-21.4.11/i686-pc-linux/char-db';
}elsif(-e '/usr/local/lib/xemacs-21.4.11/powerpc-apple-darwin6.4/char-db'){
    $DB_HOME='/usr/local/lib/xemacs-21.4.11/powerpc-apple-darwin6.4/char-db';
}elsif(-e '/usr/local/xemacs-utf2000/lib/xemacs-21.4.11/powerpc-apple-darwin6.4/char-db'){
    $DB_HOME='/usr/local/xemacs-utf2000/lib/xemacs-21.4.11/powerpc-apple-darwin6.4/char-db';
}elsif(-e '/usr/local/lib/xemacs-21.4.10/i686-pc-linux/char-db'){
    $DB_HOME='/usr/local/lib/xemacs-21.4.10/i686-pc-linux/char-db';
}elsif(-e '/usr/local/lib/xemacs-21.4.10/powerpc-apple-darwin6.4/char-db'){
    $DB_HOME='/usr/local/lib/xemacs-21.4.10/powerpc-apple-darwin6.4/char-db';
}elsif(-e '/usr/local/xemacs-utf2000/lib/xemacs-21.4.10/powerpc-apple-darwin6.4/char-db'){
    $DB_HOME='/usr/local/xemacs-utf2000/lib/xemacs-21.4.10/powerpc-apple-darwin6.4/char-db';
}elsif(-e 'd:/work/chise/char-db'){
    $DB_HOME='d:/work/chise/char-db';
}else{
    print STDERR "No database found.\n";
    print STDERR "Pleas set \$DB_HOME to Chise_utils.pm.\n";
    exit 1;
}

$idc="\x{2ff0}-\x{2fff}";

my %er_alias =
    ('C1','chinese-cns11643-1',
     'C2','chinese-cns11643-2',
     'C3','chinese-cns11643-3',
     'C4','chinese-cns11643-4',
     'C5','chinese-cns11643-5',
     'C6','chinese-cns11643-6',
     'C7','chinese-cns11643-7',
     'CB','ideograph-cbeta',
     'CDP','chinese-big5-cdp',
     'GT','ideograph-gt',
     'GT-K','ideograph-gt',
     'HZK1','ideograph-hanziku-1',
     'HZK2','ideograph-hanziku-2',
     'HZK3','ideograph-hanziku-3',
     'HZK4','ideograph-hanziku-4',
     'HZK5','ideograph-hanziku-5',
     'HZK6','ideograph-hanziku-6',
     'HZK7','ideograph-hanziku-7',
     'HZK8','ideograph-hanziku-8',
     'HZK9','ideograph-hanziku-9',
     'HZK10','ideograph-hanziku-10',
     'HZK11','ideograph-hanziku-11',
     'HZK12','ideograph-hanziku-12',
     'J78','japanese-jisx0208-1978',
     'J83','japanese-jisx0208',
     'J90','japanese-jisx0208-1990',
     'JSP','japanese-jisx0212',
     'JX1','japanese-jisx0213-1',
     'JX2','japanese-jisx0213-2',
     'K0','korean-ksc5601',
     'M','ideograph-daikanwa',
     );

for (glob "$DB_HOME/system-char-id/*"){
    next if(/\.txt$/);
    $atr=$_;
    $atr=~s!$DB_HOME/system-char-id/!!;
    $db{$atr}=$_;
}

for (glob "$DB_HOME/*"){
    next if(/\.txt$/ or /system-char-id/);
    $atr=$_;
    $atr=~s!$DB_HOME/!!;
    $reverse_db{$atr}=$_."/system-char-id";
}

sub get_db{
    my($atr)=@_;
    return 1 if(defined(%{$chardb{$atr}}));
    if(defined($db{$atr}) and -f $db{$atr}){
	tie %{$chardb{$atr}}, "BerkeleyDB::Hash",
	-Filename => $db{$atr};
    }else{
	return undef;
    }
}

sub get_reverse_db{
    my($atr)=@_;
    return 1 if(defined(%{$reverse_chardb{$atr}}));
    if(defined($reverse_db{$atr}) and -f $reverse_db{$atr}){
	tie %{$reverse_chardb{$atr}}, "BerkeleyDB::Hash",
	-Filename => $reverse_db{$atr};
    }else{
	return undef;
    }
}


sub get_char_attribute{
    my($char,$atr)=@_;
    &get_db($atr) or return "";
    if($chardb{$atr}->{"?$char"}){
	return $chardb{$atr}->{"?$char"};
    }else{
	return "";
    }
}

sub get_chars_containing{
    my($atr,$value)=@_;
    my($char,@res);
    if(&get_db($atr)){
	foreach $char (keys %{$chardb{$atr}}){
	    if($chardb{$atr}->{$char}=~/$value/){
		$char=~s/^\?//;
		push @res,$char;
	    }
	}
    }
    return @res;
}

sub get_chars_matching{
    my($atr,$value)=@_;
    my($char,@res);
    if(defined($reverse_db{$atr})){
	if(&get_reverse_db($atr)){
	    if($char=$reverse_chardb{$atr}->{$value}){
		$char=~s/^\?//;
		push @res,$char;
	    }
	}
    }
    # else{
    # fall back if DB inconsistency exists.
    unless(@res){
	if(&get_db($atr)){
	    foreach $char (keys %{$chardb{$atr}}){
		if($chardb{$atr}->{$char} eq $value){
		    $char=~s/^\?//;
		    push @res,$char;
		}
	    }
	}
    }
    return @res;
}

sub get_chars_for{
    my($query)=@_;
    my @q=split(",",$query);
    my(%res,@res,$atr,$value);
    my $i=0;
    foreach $query (@q){
        if($query=~/=~/){
	    ($atr,$value)=split("=~",$query,2);
	    $i++;
	    foreach (&get_chars_containing($atr,$value)){
		$res{$_}++;
	    }
	}elsif($query=~/==/){
	    ($atr,$value)=split(/==/,$query,2);
	    $i++;
	    foreach (&get_chars_matching($atr,$value)){
		$res{$_}++;
	    }
	}
    }
    foreach (keys %res){
	if($res{$_}==$i){
	    push @res,$_;
	}
    }
    return @res;
}

sub de_er{
    my($er)=@_;
    my($output_char,$atr,$value);
    my $keys = join '|', keys %er_alias;
    if($er=~/^\d+$/){
	$output_char=pack("U",$er);
    }elsif($er=~/^U[\+\-]([a-fA-F\d]+)/){
	$output_char=pack("U",hex($1));
    }elsif($er=~/(?:I\-)?($keys)\-?([0-9a-fA-F]+)/){
	($atr,$value)=($1,$2);
	unless($er_alias{$atr}=~/daikanwa|gt/){
	    $value=hex($value);
	}
	($output_char)=&get_chars_matching($er_alias{$atr},$value);
    }
    if($output_char){
      return $output_char;
    }else{
      return $er;
    }
}

sub ids_argc{
    my($char)=@_;
    my $char_id=unpack("U",$char);
    if($char_id==0x2ff2 or $char_id==0x2ff3){
	return 3;
    }elsif($char_id>=0x2ff0 and $char_id<=0x2fff){
	return 2;
    }else{
	return 0;
    }
}

# Autoload methods go after =cut, and are processed by the autosplit program.

1;
__END__
# Below is stub documentation for your module. You better edit it!

=head1 NAME

Chise_utils - Perl extension for blah blah blah

=head1 SYNOPSIS

  use Chise_utils;
  blah blah blah

=head1 DESCRIPTION

Stub documentation for Chise_utils, created by h2xs. It looks like the
author of the extension was negligent enough to leave the stub
unedited.

Blah blah blah.

=head2 EXPORT

None by default.


=head1 AUTHOR

A. U. Thor, a.u.thor@a.galaxy.far.far.away

=head1 SEE ALSO

perl(1).

=cut
