Noise with -w.

[p5sagit/p5-mst-13.2.git] / ext / Encode / lib / Encode / Tcl / Table.pm

package Encode::Tcl::Table;
use strict;
our $VERSION = do { my @r = (q$Revision: 0.92 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };

use base 'Encode::Encoding';

use Carp;
#use Data::Dumper;

sub read
{
    my ($obj,$fh,$name,$type) = @_;
    my($rep, @leading);
    my ($def,$sym,$pages) = split(/\s+/,scalar(<$fh>));
    my @touni;
    my %fmuni;
    my $count = 0;
    $def = hex($def);
    while ($pages--)
    {
	my $line = <$fh>;
	chomp($line);
	my $page = hex($line);
	my @page;
	$leading[$page] = 1 if $page;
	my $ch = $page * 256;
	for (my $i = 0; $i < 16; $i++)
	{
	    my $line = <$fh>;
	    for (my $j = 0; $j < 16; $j++)
	    {
		my $val = hex(substr($line,0,4,''));
		if ($val || !$ch)
		{
		    my $uch = pack('U', $val); # chr($val);
		    push(@page,$uch);
		    $fmuni{$uch} = $ch;
		    $count++;
		}
		else
		{
		    push(@page,undef);
		}
		$ch++;
	    }
	}
	$touni[$page] = \@page;
    }
    $rep = $type ne 'M'
	? $obj->can("rep_$type")
	    : sub
	    {
		($_[0] > 255) || $leading[$_[0]] ? 'n' : 'C';
	    };
    $obj->{'Rep'}   = $rep;
    $obj->{'ToUni'} = \@touni;
    $obj->{'FmUni'} = \%fmuni;
    $obj->{'Def'}   = $def;
    $obj->{'Num'}   = $count;
    return $obj;
}

sub rep_S { 'C' }

sub rep_D { 'n' }

#sub rep_M { ($_[0] > 255) ? 'n' : 'C' }

sub representation
{
    my ($obj,$ch) = @_;
    $ch = 0 unless @_ > 1;
    $obj->{'Rep'}->($ch);
}

sub decode
{
    my($obj,$str,$chk) = @_;
    my $name  = $obj->{'Name'};
    my $rep   = $obj->{'Rep'};
    my $touni = $obj->{'ToUni'};
    my $uni;
    while (length($str))
    {
	my $cc = substr($str,0,1,'');
	my $ch = ord($cc);
	my $x;
	if (&$rep($ch) eq 'C')
	{
	    $x = $touni->[0][$ch];
	}
	else
	{
	    if(! length $str)
	    {
		$str = pack('C',$ch); # split leading byte
		last;
	    }
	    my $c2 = substr($str,0,1,'');
	    $cc .= $c2;
	    $x = $touni->[$ch][ord($c2)];
	}
	unless (defined $x)
	{
	  Encode::Tcl::no_map_in_decode($name, $cc.$str);
	}
	$uni .= $x;
    }
    $_[1] = $str if $chk;
    return $uni;
}

sub encode
{
    my ($obj,$uni,$chk) = @_;
    my $fmuni = $obj->{'FmUni'};
    my $def   = $obj->{'Def'};
    my $name  = $obj->{'Name'};
    my $rep   = $obj->{'Rep'};
    my $str;
    while (length($uni))
    {
	my $ch = substr($uni,0,1,'');
	my $x  = $fmuni->{$ch};
	unless(defined $x)
	{
	    unless($chk)
	    {
	      Encode::Tcl::no_map_in_encode(ord($ch), $name)
	      }
	    return undef;
	}
	$str .= pack(&$rep($x),$x);
    }
    $_[1] = $uni if $chk;
    return $str;
}
1;
__END__

=head1 NAME

Encode::Tcl::Table - Tcl Table encodings

=head1 SYNOPSIS

none

=head1 DESCRIPTION

This module is used internally by Encode::Tcl
and handles types S, D, and M of Tcl encodings.

Implementation for type M is restricted to encodings
in which the number of bytes per a character is up to 2.

=head1 SEE ALSO

L<Encode>

L<Encode::Tcl>

=cut