File Coverage

blib/lib/Lingua/ZH/CCDICT.pm

Criterion	Covered	Total	%
statement	109	111	98.2
branch	42	50	84.0
condition	2	3	66.6
subroutine	27	27	100.0
pod	10	10	100.0
total	190	201	94.5

package Lingua::ZH::CCDICT;

use strict;
use warnings;

use 5.006001;

use vars qw ($VERSION);

$VERSION = '0.05';

use File::Spec;
use Params::Validate qw(:all);
use Sub::Name qw( subname );
use Lingua::ZH::CCDICT::Romanization;
use Lingua::ZH::CCDICT::Romanization::Pinyin;

my %storage;
BEGIN { %storage = map { lc $_ => $_ } ( qw( InMemory XML BerkeleyDB ) ) }


sub new
{
    my $class = shift;
    my %p = validate_with( params => \@_,
                           spec   =>
                           { storage =>
                             { callbacks =>
                               { 'is a valid storage type' =>
                                 sub { $storage{ lc $_[0] } } },
                             },
                           },
                           allow_extra => 1,
                         );

    my $storage_class = __PACKAGE__ . '::Storage::' . $storage{ lc delete $p{storage} };

    eval "use $storage_class";
    die $@ if $@;

    return $storage_class->new(%p);
}

my %Ignore = map { $_ => 1 } qw( fUTF8 fCNS11643 fGB fBig5 );

my %CCDICTToInternal =
    ( fTotalStrokes => 'stroke_count',
      fCangjie      => 'cangjie',
      fFourCorner   => 'four_corner',
    );

my %RomanizationToInternal =
    ( fHakka        => 'pinjim',
      fCantonese    => 'jyutping',
      fMandarin     => 'pinyin',
    );

my %RomanizationType = map { $_ => 1 } values %RomanizationToInternal;

sub parse_source_file
{
    my $self = shift;
    my $file = shift;
    my $status_fh = $ENV{CCDICT_VERBOSE} ? \*STDERR : undef;
    my $lines_per = 5000;

    unless ( defined $file )
    {
        my $pack_as_file = File::Spec->catfile( split /::/, __PACKAGE__ );
        $pack_as_file .= '.pm';

        (my $dir = $INC{$pack_as_file}) =~ s/\.pm$//;

        $file = File::Spec->catfile( $dir, 'Data.pm' );
    }

    open my $fh, '<', $file
        or die "Cannot read $file: $!";

    my $last_char;
    my %entry;
    while (<$fh>)
    {
        chomp;

        next unless substr( $_, 0, 1 ) eq 'U';

        my ( $unicode, $type, $data ) = split /\t/, $_, 3;

        s/^\s+|\s+$//g for $unicode, $type, $data;

        next if $Ignore{$type};

        my ( $codepoint, $homograph ) = $unicode =~ /U\+([\dABCDEF]+)\.(\d)/;

        die "Bad line (line #$.):\n$_\n\n" unless $codepoint;

        # not sure how to handle this, to be honest.
        next if $homograph;

        # generate a real Unicode character in Perl
        my $unicode_char = chr( hex($codepoint) );

        $last_char = $unicode_char unless defined $last_char;

        # this relies on the fact that data for each char is grouped
        # together on consecutive lines in the ccdict.txt file.
        if ( $unicode_char ne $last_char )
        {
            $self->_add_entry( $last_char, { %entry, unicode => $last_char } );

            %entry = ();

            $last_char = $unicode_char;
        }

        if ( exists $CCDICTToInternal{$type} )
        {
            my $internal = $CCDICTToInternal{$type};

            $entry{$internal} = $data;
        }
        elsif ( exists $RomanizationToInternal{$type} )
        {
            my $internal = $RomanizationToInternal{$type};

            my $class = $self->_romanization_class($internal);

            my $is_obsolete = 0;
            foreach my $syl ( split /[\s;]+/, $data )
            {
                # Deal with various mysterious bits and mistakes
                next if $syl eq '}';
                next if $syl eq '(also)';
                next if $syl eq '(old)';

                next if $syl =~ /^p?\d+$/;

                next if $syl =~ /^\(coll/;

                $syl =~ s/^{?([^}]+)}$/$1/;
                $syl =~ s/{[^}]+}?$//;

                if ( $syl eq 'obs' )
                {
                    $is_obsolete = 1;
                    next;
                }

                my $romanized = $class->new( syllable => $syl,
                                             obsolete => $is_obsolete,
                                           );

                next unless $romanized;

                push @{ $entry{$internal} }, $romanized;
            }
        }
        elsif ( $type eq 'fR/S' )
        {
            my ( $radical, $index ) = split /\./, $data;

            $entry{radical} = $radical;
            $entry{index} = $index;
        }
        elsif ( $type eq 'fEnglish' )
        {
            $entry{english} =
                [ grep { defined && length } split /\s*\[\d\d?\]\s*/, $data ];
        }
        else
        {
            die "Invalid line: $_\n";
        }

        if (  ! ( $. % $lines_per ) && $status_fh )
        {
            print $status_fh "$. lines processed\n";
        }
    }

    $self->_add_entry( $last_char, { %entry, unicode => $last_char } );
}

sub _add_entry
{
    my $self    = shift;
    my $unicode = shift;
    my $entry   = shift;

    return unless defined $entry->{radical};

    $self->_real_add_entry( $unicode, $entry );
}

sub _romanization_class
{
    return
        ( $_[1] eq 'pinyin' ?
          'Lingua::ZH::CCDICT::Romanization::Pinyin' :
          'Lingua::ZH::CCDICT::Romanization'
        );
}

sub _is_romanization_type
{
    return $RomanizationType{ $_[1] };
}

sub _InternalTypes
{
    return values %CCDICTToInternal, values %RomanizationToInternal, 'index', 'radical';
}

# Some of these may be overridden in subclasses, but they provide an
# easy default
foreach my $type ( __PACKAGE__->_InternalTypes() )
{
    my $sub =
        __PACKAGE__->_is_romanization_type($type)
        ? sub { my $s = shift;
                $s->_match( $type => map { lc } @_ ) }
        : sub { my $s = shift;
                $s->_match( $type => @_ ) };

    my $sub_name = "match_$type";
    no strict 'refs';

    *{$sub_name} = subname $sub_name => $sub;
}


1;

__END__