File Coverage

blib/lib/Unicode/CharWidth.pm

Criterion	Covered	Total	%
statement	68	111	61.2
branch	5	22	22.7
condition	4	17	23.5
subroutine	20	28	71.4
pod			n/a
total	97	178	54.4

package Unicode::CharWidth;

use 5.010;
use strict;
use warnings;

=head1 NAME

Unicode::CharWidth - Character Width properties

=head1 VERSION

Version 1.03

=cut

our $VERSION = '1.03';

# the names of the character classes we'll define
# we arrange them so, that in an array of 4 elements the mbwidth value
# indexes the corresponding element, -1 being equivalent to 3

use Carp;
our @CARP_NOT = qw(utf8); # otherwise we see errors from unicode_heavy.pl

use constant CLASS_NAMES => (
    'InZerowidth',   # mbwidth ==  0
    'InSinglewidth', # mbwidth ==  1
    'InDoublewidth', # mbwidth ==  2
    'InNowidth',     # mbwidth == -1
);

use constant WIDTH_VALUES => (0 .. 2, -1); # order corresponds to CLASS_NAMES
use constant STD_QUICKSTART => 'UCW_startup';

sub import {
    my $class = shift;
    my ($arg) = @_;
    if ( $arg and $arg eq '-gen' ) {
        _gen_and_save_proptab(_startup_path());
        carp 'Exiting';
        exit 0; # so no useful program runs with this option
    }
    _compile_functions();
    @_ = ($class);
    require Exporter;
    goto(Exporter->can('import') or die q(Exporter can't import?));
}

our @EXPORT = CLASS_NAMES;

# compile the four exported functions
sub _compile_functions {
    my $tabs = _get_proptab(_startup_path());
    for my $name ( CLASS_NAMES ) {
        my $tab = $tabs->{$name};
        no strict 'refs';
        *$name = sub { $tab };
    }
}

use Dir::Self;
use File::Spec::Functions ();

sub _startup_path {
    File::Spec::Functions::catfile(
        __DIR__, STD_QUICKSTART()
    )
}

sub _get_proptab {
    my $file = _startup_path();
    _read_startup($file) || croak(
        "Missing $file in distribution " . __PACKAGE__
    )
}

sub _gen_and_save_proptab {
    unless ( _effective_locale() =~ /\.UTF-8$/ ) {
        croak "Generation must be under a UTF-8 locale"
    }
    _write_startup(_gen_proptab(), _startup_path());
}

sub _effective_locale {
    $ENV{LC_CTYPE} || $ENV{LANG} || $ENV{LC_ALL} || ''
}

use constant MAX_UNICODE => 0x10FFFF;

sub _gen_proptab {
    require Text::CharWidth;
    my @proptab; # we'll make it a hash later (_reform_proptab)
    # make room for as many elements as we have class names
    # so index -1 is index 3 (InNowidth)
    $#proptab = $#{ [CLASS_NAMES] };
    my $last_width = 99; # won't occur
    for my $code ( 0 .. MAX_UNICODE ) {
        my $width = Text::CharWidth::mbwidth(chr $code);
        if ( $width == $last_width ) {
            # continue current interval
            $proptab[$width]->[-1]->[1] = $code;
        } else {
            # start new interval (pair) for current length
            push @{ $proptab[$width] }, [$code, $code];
        }
        $last_width = $width;
    }
    _reform_proptab(@proptab) # make a hash of strings, keyed by class name
}

sub _reform_proptab {
    my @proptab = @_;
    for my $tab ( @proptab ) {
        $tab = join "\n", map _one_or_two(@$_), @$tab;
    }
    my %proptab;
    @proptab{CLASS_NAMES()} = @proptab;
    \ %proptab
}

use constant CODEPOINT_FMT => '%04X';

sub _one_or_two {
    my ($from, $to) = @_;
    my $fmt = CODEPOINT_FMT; # print only first element if second is equal
    $fmt .= " $fmt" if $from != $to; # ... or both elements
    sprintf $fmt, $from, $to
}

use Storable ();

sub _read_startup {
    my ($file) = @_;
    my $tab = eval { Storable::retrieve($file) } or croak(
        _strip_error($@)
    );
    unless ( _validate_proptab($tab) ) {
        croak("File '$file' wasn't created by " . __PACKAGE__);
    }
    $tab;
}

sub _write_startup {
    my ($proptab, $file) = @_;
    # only write validated $proptab
    die "Failing our own validation" unless _validate_proptab($proptab);
    if ( eval { Storable::nstore($proptab, $file); 1 } ) {
        carp "Created startup file $file";
    } else {
        # remove file/line from message and re-croak
        croak _strip_error($@);
    }
    return # nothing in particular, no-one cares
}

sub _strip_error {
    my ($error) = @_;
    $error =~ s/at .* line \d+.*//s;
    ucfirst $error
}

        $@ =~ s/at .* line \d+.*//s;
use List::Util ();

sub _validate_proptab {
    my ($tab) = @_;
    my $ncn = @{ [CLASS_NAMES] }; # number of class names
    ref $tab eq 'HASH' and
    $ncn == grep { exists $tab->{$_} } CLASS_NAMES and
    $ncn == grep { defined $tab->{$_} } CLASS_NAMES and
    $ncn == grep { $tab->{$_} =~ /^[[:xdigit:]\s]*$/ } CLASS_NAMES
}

__PACKAGE__
__END__