File Coverage

blib/lib/Unicode/Collate/Locale.pm

Criterion	Covered	Total	%
statement	50	52	96.1
branch	23	26	88.4
condition	6	6	100.0
subroutine	9	9	100.0
pod	2	3	66.6
total	90	96	93.7

package Unicode::Collate::Locale;

use strict;
use warnings;
use Carp;
use base qw(Unicode::Collate);

our $VERSION = '1.30';

my $PL_EXT  = '.pl';

my %LocaleFile = map { ($_, $_) } qw(
   af ar as az be bn ca cs cu cy da dsb ee eo es et fa fi fil fo gu
   ha haw he hi hr hu hy ig is ja kk kl kn ko kok lkt ln lt lv
   mk ml mr mt nb nn nso om or pa pl ro sa se si sk sl sq sr sv
   ta te th tn to tr uk ur vi vo wae wo yo zh
);
   $LocaleFile{'default'} = '';
# aliases
   $LocaleFile{'bs'}      = 'hr';
   $LocaleFile{'bs_Cyrl'} = 'sr';
   $LocaleFile{'sr_Latn'} = 'hr';
# short file names
   $LocaleFile{'de__phonebook'}   = 'de_phone';
   $LocaleFile{'de_AT_phonebook'} = 'de_at_ph';
   $LocaleFile{'es__traditional'} = 'es_trad';
   $LocaleFile{'fr_CA'}           = 'fr_ca';
   $LocaleFile{'fi__phonebook'}   = 'fi_phone';
   $LocaleFile{'si__dictionary'}  = 'si_dict';
   $LocaleFile{'sv__reformed'}    = 'sv_refo';
   $LocaleFile{'ug_Cyrl'}         = 'ug_cyrl';
   $LocaleFile{'zh__big5han'}     = 'zh_big5';
   $LocaleFile{'zh__gb2312han'}   = 'zh_gb';
   $LocaleFile{'zh__pinyin'}      = 'zh_pin';
   $LocaleFile{'zh__stroke'}      = 'zh_strk';
   $LocaleFile{'zh__zhuyin'}      = 'zh_zhu';

my %TypeAlias = qw(
    phone     phonebook
    phonebk   phonebook
    dict      dictionary
    reform    reformed
    trad      traditional
    big5      big5han
    gb2312    gb2312han
);

sub _locale {
    my $locale = shift;
    if ($locale) {
	$locale = lc $locale;
	$locale =~ tr/\-\ \./_/;
	$locale =~ s/_([0-9a-z]+)\z/$TypeAlias{$1} ?
				  "_$TypeAlias{$1}" : "_$1"/e;
	$LocaleFile{$locale} and return $locale;

	my @code = split /_/, $locale;
	my $lan = shift @code;
	my $scr = @code && length $code[0] == 4 ? ucfirst shift @code : '';
	my $reg = @code && length $code[0] <  4 ? uc      shift @code : '';
	my $var = @code                         ?         shift @code : '';

	my @list;
	push @list, (
	    "${lan}_${scr}_${reg}_$var",
	    "${lan}_${scr}__$var", # empty $scr should not be ${lan}__$var.
	    "${lan}_${reg}_$var",  # empty $reg may be ${lan}__$var.
	    "${lan}__$var",
	) if $var ne '';
	push @list, (
	    "${lan}_${scr}_${reg}",
	    "${lan}_${scr}",
	    "${lan}_${reg}",
	     ${lan},
	);
	for my $loc (@list) {
	    $LocaleFile{$loc} and return $loc;
	}
    }
    return 'default';
}

sub getlocale {
    return shift->{accepted_locale};
}

sub locale_version {
    return shift->{locale_version};
}

sub _fetchpl {
    my $accepted = shift;
    my $f = $LocaleFile{$accepted};
    return if !$f;
    $f .= $PL_EXT;

    # allow to search @INC
#   use File::Spec;
#   my $path = File::Spec->catfile('Unicode', 'Collate', 'Locale', $f);
    my $path = "Unicode/Collate/Locale/$f";
    my $h = do $path;
    croak "Unicode/Collate/Locale/$f can't be found" if !$h;
    return $h;
}

sub new {
    my $class = shift;
    my %hash = @_;
    $hash{accepted_locale} = _locale($hash{locale});

    if (exists $hash{table}) {
	croak "your table can't be used with Unicode::Collate::Locale";
    }

    my $href = _fetchpl($hash{accepted_locale});
    while (my($k,$v) = each %$href) {
	if (!exists $hash{$k}) {
	    $hash{$k} = $v;
	} elsif ($k eq 'entry') {
	    $hash{$k} = $v.$hash{$k};
	} else {
	    croak "$k is reserved by $hash{locale}, can't be overwritten";
	}
    }
    return $class->SUPER::new(%hash);
}

1;
__END__