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

#! /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 GB2312 translation table
sub gb2unicode {
    generalgb2unicode ("GB2312", @_);
}

# returns a pointer to unicode array
sub generalgb2unicode {
    my ($encoding, $intext) = @_;
    my $mapfile = &util::filename_cat($ENV{'GSDLHOME'}, 
                      "unicode/MAPPINGS/EASTASIA/GB",
                      "$encoding.TXT");
    if (!&loadencoding ($encoding, $mapfile)) {
    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))) >= 0xa0) {
        if ($i+1 < $len) {
        if (($c2 = ord(substr($intext, $i+1, 1))) >= 0xa0) {
            # found a GB character, put black square if cannot translate
            my $c = &transchar ($encodename, ($c1-128)*256+$c2-128);
            $c = 0x25a1 if $c == 0;
            push (@outtext, $c);
            $i += 2;
            
        } else {
            # error second character not > 127
            print STDERR "gb: ERROR second GB character not >= 0xa0\n";
            $i++;
            
        } 
        } 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 GB2312 translation table
sub unicode2gb {
    generalunicode2gb ("GB2312", @_);
}

# 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)
    my $mapfile = &util::filename_cat($ENV{'GSDLHOME'}, 
                      "unicode/MAPPINGS/EASTASIA/GB",
                      "$encoding.TXT");
    if (!&loadencoding ($encoding, $mapfile)) {
    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 = 0x2175 if $gbc == 0;
        $outtext .= chr (($gbc >> 8) + 0x80);
        $outtext .= chr (($gbc & 0xff) + 0x80);
    }
    }

    return $outtext;
}


# loadmapfile 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/);

    &addchartrans ($translations{$to}, hex($line[0]), hex($line[1]));
    &addchartrans ($translations{$from}, hex($line[1]), hex($line[0]));
    }

    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;