libunicode-linebreak-perl 0.0.20131101-1 / usr / lib / perl5 / Unicode / LineBreak.pm

#-*- 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 = '2013.11';

### 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;