source: trunk/gsdl/perllib/gb.pm@ 1218

###########################################################################
#
# gb.pm --
# A component of the Greenstone digital library software
# from the New Zealand Digital Library Project at the 
# University of Waikato, New Zealand.
#
# Copyright (C) 1999 New Zealand Digital Library Project
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
###########################################################################

#! /usr/local/bin/perl5 -w

# useful methods for dealing with the GuoBiao (GB) encoding

package gb;

use util;

# %encodings is of the form:
#
# encodings{encodingname-encodingname}->blocktranslation
# blocktranslation->[[0-255],[256-511], ..., [65280-65535]]
#
# Any of the top translation blocks can point to an undefined
# value. This data structure aims to allow fast translation and 
# efficient storage.

# @array256 is used for initialisation, there must be
# a better way...
@array256 = (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
         0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
         0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
         0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
         0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
         0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
         0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
         0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
         0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
         0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
         0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
         0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
         0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
         0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
         0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
         0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);


%translations = ();


# gb2unicode uses the GBK translation table
sub gb2unicode {
    generalgb2unicode ("GBK", @_);
}

# returns a pointer to unicode array
sub generalgb2unicode {
    my ($encoding, $intext) = @_;

    if (!&loadmapencoding ("$encoding-unicode")) {
    print STDERR "gb: ERROR - could not load encoding $encoding\n";
    return [];
    }
    
    my @outtext = ();
    my $encodename = "$encoding-unicode";
    my $len = length($intext);
    my ($c1, $c2);
    my $i = 0;

    while ($i < $len) {
    if (($c1 = ord(substr($intext, $i, 1))) >= 0x81) {
        if ($i+1 < $len) {
        # found a GB character, put black square if cannot translate
        $c2 = ord(substr($intext, $i+1, 1));
        my $c = &transchar ($encodename, ($c1 << 8) | $c2);
        $c = 0x25a1 if $c == 0;
        push (@outtext, $c);
        $i += 2;
        
        } else {
        # error
        print STDERR "gb: ERROR missing second half of GB character\n";
        $i++;
        }
        
    } else {
        # normal ascii character
        push (@outtext, $c1) if ($c1 < 0x80);
        $i++;
    }
    }
    
    return \@outtext;
}


# unicode2gb uses the GBK translation table
sub unicode2gb {
    generalunicode2gb ("GBK", @_);
}

# returns a gb string. Note that this will not translate
# traditional forms of characters to their simplified forms
# Any traditional characters in the unicode will not be translated
sub generalunicode2gb {
    my ($encoding, $intext) = @_;

    # load the encoding (if it is not already loaded)
    if (!&loadmapencoding ("unicode-$encoding")) {
    print STDERR "gb: ERROR - could not load encoding $encoding\n";
    return "";
    }
    
    # translate the string
    my ($num, $gbc);
    my $outtext = "";
    my $encodename = "unicode-$encoding";
    foreach $num (@$intext) {
    if ($num < 0x80) {
        # normal ascii character
        $outtext .= chr ($num);
    } else {
        # gb character
        my $gbc = &transchar ($encodename, $num);
        $gbc = 0xa1f5 if $gbc == 0;
        $outtext .= chr ($gbc >> 8);
        $outtext .= chr ($gbc & 0xff);
    }
    }

    return $outtext;
}


# It returns 1 if successful, 0 if unsuccessful
sub loadmapencoding {
    my ($encoding) = @_;
    
    # check to see if the encoding has already been loaded
    return 1 if (defined $translations{$encoding});

    my $filename = $encoding;
    $filename =~ s/\-//;
    $filename =~ s/unicode/u/i;
    $filename =~ tr/A-Z/a-z/;
    $filename .= ".ump"; # unicode map file

    return 0 unless open (MAPFILE, "$ENV{'GSDLHOME'}/unicode/$filename");
    binmode (MAPFILE); # f$#@!!! windows

    $translations{$encoding} = [@array256];
    my $block = $translations{$encoding};

    my ($in,$i,$j);
    while (read(MAPFILE, $in, 1) == 1) {
    $i = unpack ("C", $in);
    $block->[$i] = [@array256];
    for ($j=0; $j<256 && read(MAPFILE, $in, 2)==2; $j++) {
        my ($n1, $n2) = unpack ("CC", $in);
        $block->[$i]->[$j] = ($n1*256) + $n2;
    }
    }

    close (MAPFILE);
}



# loadencoding expects the mapfile to contain (at least) two
# tab-seperated fields. The first field is the mapped value
# and the second field is the unicode value.
#
# It returns 1 if successful, 0 if unsuccessful
sub loadencoding {
    my ($encoding, $mapfile) = @_;
    
    my $to = "$encoding-unicode";
    my $from = "unicode-$encoding";

    # check to see if the encoding has already been loaded
    if (defined $translations{$to} && defined $translations{$from}) {
    return 1;
    }

    return 0 unless open (MAPFILE, $mapfile);

    my ($line, @line);
    $translations{$to} = [@array256];
    $translations{$from} = [@array256];
    while (defined ($line = <MAPFILE>)) {
    # remove comments
    $line =~ s/\#.*$//;
    next unless $line =~ /\S/;

    # split the line into fields and do a few
    # simple sanity checks
    @line = split (/\t/, $line);
    next unless (scalar(@line) >= 2 &&
             $line[0] =~ /^0x/ &&
             $line[1] =~ /^0x/);

    my $gbc = hex($line[0]);
    my $unic = hex($line[1]);

    # gbk has already had the necessary most significant
    # bits set (it is used in the encoding
    $gbc = $gbc | 0x8080 unless ($encoding =~ /gbk/i);

    &addchartrans ($translations{$to}, $gbc, $unic);
    &addchartrans ($translations{$from}, $unic, $gbc);
    }

    close (MAPFILE);

    return 1;
}

sub showfilled {
    my ($block) = @_;
    my $count = 0;
    foreach $el (@$block) {
    if (ref ($el) eq "ARRAY") {
        print "1";
        $count++;
    } else {
        print "0";
    }
    }
    print "\n";
    print "total: $count\n";
}


# addchartrans adds one character translation to a translation block.
# It also simplifies the translation block if possible.
sub addchartrans {
    my ($block, $from, $to) = @_;
    my $i = 0;

    my $high = ($from / 256) % 256;
    my $low = $from % 256;

    if (ref ($block->[$high]) ne "ARRAY") {
    $block->[$high] = [@array256];
    }
    $block->[$high]->[$low] = $to;
}


sub transchar {
    my ($encoding, $from) = @_;
    my $high = ($from / 256) % 256;
    my $low = $from % 256;

    return 0 unless defined $translations{$encoding};

    my $block = $translations{$encoding};

    if (ref ($block->[$high]) ne "ARRAY") {
    return 0;
    }
    return $block->[$high]->[$low];
}


1;