File Coverage

blib/lib/Unicode/LineBreak.pm

Criterion	Covered	Total	%
statement	85	172	49.4
branch	27	60	45.0
condition	2	6	33.3
subroutine	15	16	93.7
pod	3	3	100.0
total	132	257	51.3

#-*- perl -*-

package Unicode::LineBreak;
require 5.008;

### Pragmas:
use strict;
use warnings;
use vars qw($VERSION @EXPORT_OK @ISA $Config @Config);

### Exporting:
use Exporter;
our @EXPORT_OK = qw(UNICODE_VERSION SOMBOK_VERSION context);
our %EXPORT_TAGS = ('all' => [@EXPORT_OK]);

### Inheritance:
our @ISA = qw(Exporter);

### Other modules:
use Carp qw(croak carp);
use Encode qw(is_utf8);
use MIME::Charset;
use Unicode::GCString;

### Globals

### The package version
our $VERSION = '2019.001';

### Public Configuration Attributes
our @Config = (
    BreakIndent => 'YES',
    CharMax => 998,
    ColMax => 76,
    ColMin => 0,
    ComplexBreaking => 'YES',
    Context => 'NONEASTASIAN',
    EAWidth => undef,
    Format => 'SIMPLE',
    HangulAsAL => 'NO',
    LBClass => undef,
    LegacyCM => 'YES',
    Newline => "\n",
    Prep => undef,
    Sizing => 'UAX11',
    Urgent => undef,
    ViramaAsJoiner => 'YES',
);
our $Config = {};
eval { require Unicode::LineBreak::Defaults; };
push @Config, (%$Config);

### Exportable constants
use Unicode::LineBreak::Constants;
use constant 1.01;
my $package = __PACKAGE__;
my @consts = grep { s/^${package}::(\w\w+)$/$1/ } keys %constant::declared;
push @EXPORT_OK, @consts;
push @{$EXPORT_TAGS{'all'}}, @consts;

### Load XS module
require XSLoader;
XSLoader::load('Unicode::LineBreak', $VERSION);

### Load dynamic constants
foreach my $p ((['EA', EAWidths()], ['LB', LBClasses()])) {
    my $prop = shift @{$p};
    my $idx = 0;
    foreach my $val (@{$p}) {
        no strict;
        my $const = "${prop}_${val}";
        *{$const} = eval "sub { $idx }";
        push @EXPORT_OK, $const;
        push @{$EXPORT_TAGS{'all'}}, $const;
        $idx++;
    }
}

### Privates
my $EASTASIAN_CHARSETS = qr{
    ^BIG5 |
    ^CP9\d\d |
    ^EUC- |
    ^GB18030 | ^GB2312 | ^GBK |
    ^HZ |
    ^ISO-2022- |
    ^KS_C_5601 |
    ^SHIFT_JIS
}ix;

my $EASTASIAN_LANGUAGES = qr{
    ^AIN |
    ^JA\b | ^JPN |
    ^KO\b | ^KOR |
    ^ZH\b | ^CHI
}ix;

use overload
    '%{}' => \&as_hashref,
    '${}' => \&as_scalarref,
    '""' => \&as_string,
    ;

sub new {
    my $class = shift;

    my $self = __PACKAGE__->_new();
    $self->config(@Config);
    $self->config(@_);
    bless $self, $class;
}

sub config ($@) {
    my $self = shift;

    # Get config.
    if (scalar @_ == 1) {
        my $k = shift;
        my $ret;

        if (uc $k eq uc 'CharactersMax') {
            return $self->_config('CharMax');
        } elsif (uc $k eq uc 'ColumnsMax') {
            return $self->_config('ColMax');
        } elsif (uc $k eq uc 'ColumnsMin') {
            return $self->_config('ColMin');
        } elsif (uc $k eq uc 'SizingMethod') {
            return $self->_config('Sizing');
        } elsif (uc $k eq uc 'TailorEA') {
            carp "$k is obsoleted.  Use EAWidth";
            $ret = $self->_config('EAWidth');
            if (! defined $ret) {
                return [];
            } else {
                return [map { ($_->[0] => $_->[1]) } @{$ret}];
            }
        } elsif (uc $k eq uc 'TailorLB') {
            carp "$k is obsoleted.  Use LBClass";
            $ret = $self->_config('LBClass');
            if (! defined $ret) {
                return [];
            } else {
                return [map { ($_->[0] => $_->[1]) } @{$ret}];
            }
        } elsif (uc $k eq uc 'UrgentBreaking') {
            return $self->_config('Urgent');
        } elsif (uc $k eq uc 'UserBreaking') {
            carp "$k is obsoleted.  Use Prep";
            $ret = $self->_config('Prep');
            if (! defined $ret) {
                return [];
            } else {
                return $ret;
            }
        } else {
            return $self->_config($k);
        }
    }

    # Set config.
    my @config = ();
    while (0 < scalar @_) {
        my $k = shift;
        my $v = shift;

        if (uc $k eq uc 'CharactersMax') {
            push @config, 'CharMax' => $v;
        } elsif (uc $k eq uc 'ColumnsMax') {
            push @config, 'ColMax' => $v;
        } elsif (uc $k eq uc 'ColumnsMin') {
            push @config, 'ColMin' => $v;
        } elsif (uc $k eq uc 'SizingMethod') {
            push @config, 'Sizing' => $v;
        } elsif (uc $k eq uc 'TailorLB') {
            carp "$k is obsoleted.  Use LBClass";
            push @config, 'LBClass' => undef;
            if (! defined $v) {
                ;
            } else {
                my @v = @{$v};
                while (scalar(@v)) {
                    my $k = shift @v;
                    my $v = shift @v;
                    push @config, 'LBClass' => [ $k => $v ];
                }
            }
        } elsif (uc $k eq uc 'TailorEA') {
            carp "$k is obsoleted.  Use EAWidth";
            push @config, 'EAWidth' => undef;
            if (! defined $v) {
                ;
            } else {
                my @v = @{$v};
                while (scalar(@v)) {
                    my $k = shift @v;
                    my $v = shift @v;
                    push @config, 'EAWidth' => [ $k => $v ];
                }
            }
        } elsif (uc $k eq uc 'UserBreaking') {
            carp "$k is obsoleted.  Use Prep";
            push @config, 'Prep' => undef;
            if (! defined $v) {
                ;
            } elsif (ref $v eq 'ARRAY') {
                push @config, map { ('Prep' => $_) } @{$v};
            } else {
                push @config, 'Prep' => $v;
            }
        } elsif (uc $k eq uc 'UrgentBreaking') {
            push @config, 'Urgent' => $v;
        } else {
            push @config, $k => $v;
        }
    }

    $self->_config(@config) if scalar @config;
}

sub context (@) {
    my %opts = @_;

    my $charset;
    my $language;
    my $context;
    foreach my $k (keys %opts) {
        if (uc $k eq 'CHARSET') {
            if (ref $opts{$k}) {
                $charset = $opts{$k}->as_string;
            } else {
                $charset = MIME::Charset->new($opts{$k})->as_string;
            }
        } elsif (uc $k eq 'LANGUAGE') {
            $language = uc $opts{$k};
            $language =~ s/_/-/;
        }
    }
    if ($charset and $charset =~ /$EASTASIAN_CHARSETS/) {
        $context = 'EASTASIAN';
    } elsif ($language and $language =~ /$EASTASIAN_LANGUAGES/) {
        $context = 'EASTASIAN';
    } else {
        $context = 'NONEASTASIAN';
    }
    $context;
}

1;