dslinux/user/perl/lib/I18N/LangTags/t 01_about_verbose.t 05_main.t 07_listy.t 10_http.t 20_locales.t 50_super.t 55_supers_strict.t 80_all_env.t
cayenne
dslinux_cayenne at user.in-berlin.de
Mon Dec 4 18:00:46 CET 2006
Update of /cvsroot/dslinux/dslinux/user/perl/lib/I18N/LangTags/t
In directory antilope:/tmp/cvs-serv17422/lib/I18N/LangTags/t
Added Files:
01_about_verbose.t 05_main.t 07_listy.t 10_http.t 20_locales.t
50_super.t 55_supers_strict.t 80_all_env.t
Log Message:
Adding fresh perl source to HEAD to branch from
--- NEW FILE: 01_about_verbose.t ---
require 5;
# Time-stamp: "2004-03-30 17:02:59 AST"
# Summary of, well, things.
use Test;
BEGIN {plan tests => 2};
ok 1;
use I18N::LangTags;
use I18N::LangTags::List;
use I18N::LangTags::Detect;
#chdir "t" if -e "t";
{
my @out;
push @out,
"\n\nPerl v",
defined($^V) ? sprintf('%vd', $^V) : $],
" under $^O ",
(defined(&Win32::BuildNumber) and defined &Win32::BuildNumber())
? ("(Win32::BuildNumber ", &Win32::BuildNumber(), ")") : (),
(defined $MacPerl::Version)
? ("(MacPerl version $MacPerl::Version)") : (),
"\n"
;
# Ugly code to walk the symbol tables:
my %v;
my @stack = (''); # start out in %::
my $this;
my $count = 0;
my $pref;
while(@stack) {
$this = shift @stack;
die "Too many packages?" if ++$count > 1000;
next if exists $v{$this};
next if $this eq 'main'; # %main:: is %::
#print "Peeking at $this => ${$this . '::VERSION'}\n";
if(defined ${$this . '::VERSION'} ) {
$v{$this} = ${$this . '::VERSION'}
} elsif(
defined *{$this . '::ISA'} or defined &{$this . '::import'}
or ($this ne '' and grep defined *{$_}{'CODE'}, values %{$this . "::"})
# If it has an ISA, an import, or any subs...
) {
# It's a class/module with no version.
$v{$this} = undef;
} else {
# It's probably an unpopulated package.
## $v{$this} = '...';
}
$pref = length($this) ? "$this\::" : '';
push @stack, map m/^(.+)::$/ ? "$pref$1" : (), keys %{$this . '::'};
#print "Stack: @stack\n";
}
push @out, " Modules in memory:\n";
delete @v{'', '[none]'};
foreach my $p (sort {lc($a) cmp lc($b)} keys %v) {
$indent = ' ' x (2 + ($p =~ tr/:/:/));
push @out, ' ', $indent, $p, defined($v{$p}) ? " v$v{$p};\n" : ";\n";
}
push @out, sprintf "[at %s (local) / %s (GMT)]\n",
scalar(gmtime), scalar(localtime);
my $x = join '', @out;
$x =~ s/^/#/mg;
print $x;
}
print "# Running",
(chr(65) eq 'A') ? " in an ASCII world.\n" : " in a non-ASCII world.\n",
"#\n",
;
print "# \@INC:\n", map("# [$_]\n", @INC), "#\n#\n";
print "# \%INC:\n";
foreach my $x (sort {lc($a) cmp lc($b)} keys %INC) {
print "# [$x] = [", $INC{$x} || '', "]\n";
}
ok 1;
--- NEW FILE: 07_listy.t ---
require 5;
# Time-stamp: "2003-10-10 17:37:34 ADT"
use strict;
use Test;
BEGIN { plan tests => 17 };
BEGIN { ok 1 }
use I18N::LangTags::List;
print "# Perl v$], I18N::LangTags::List v$I18N::LangTags::List::VERSION\n";
ok I18N::LangTags::List::name('fr'), 'French';
ok I18N::LangTags::List::name('fr-fr');
ok !I18N::LangTags::List::name('El Zorcho');
ok !I18N::LangTags::List::name();
ok !I18N::LangTags::List::is_decent();
ok I18N::LangTags::List::is_decent('fr');
ok I18N::LangTags::List::is_decent('fr-blorch');
ok !I18N::LangTags::List::is_decent('El Zorcho');
ok !I18N::LangTags::List::is_decent('sgn');
ok I18N::LangTags::List::is_decent('sgn-us');
ok !I18N::LangTags::List::is_decent('i');
ok I18N::LangTags::List::is_decent('i-mingo');
ok I18N::LangTags::List::is_decent('i-mingo-tom');
ok !I18N::LangTags::List::is_decent('cel');
ok I18N::LangTags::List::is_decent('cel-gaulish');
ok 1; # one for the road
--- NEW FILE: 55_supers_strict.t ---
# Time-stamp: "2004-03-30 17:49:58 AST"
#sub I18N::LangTags::Detect::DEBUG () {10}
use I18N::LangTags qw(implicate_supers_strictly);
use Test;
BEGIN { plan tests => 19 };
print "#\n# Testing strict (non-tight) insertion of super-ordinate language tags...\n#\n";
my @in = grep m/\S/, split /[\n\r]/, q{
NIX => NIX
sv => sv
en => en
hai => hai
pt-br => pt-br pt
pt-br fr => pt-br fr pt
pt-br fr pt => pt-br fr pt
pt-br fr pt de => pt-br fr pt de
de pt-br fr pt => de pt-br fr pt
de pt-br fr => de pt-br fr pt
hai pt-br fr => hai pt-br fr pt
# Now test multi-part complicateds:
pt-br-janeiro fr => pt-br-janeiro fr pt-br pt
pt-br-janeiro de fr => pt-br-janeiro de fr pt-br pt
pt-br-janeiro de pt fr => pt-br-janeiro de pt fr pt-br
ja pt-br-janeiro fr => ja pt-br-janeiro fr pt-br pt
ja pt-br-janeiro de fr => ja pt-br-janeiro de fr pt-br pt
ja pt-br-janeiro de pt fr => ja pt-br-janeiro de pt fr pt-br
pt-br-janeiro de pt-br fr => pt-br-janeiro de pt-br fr pt
# an odd case, since we don't filter for uniqueness in this sub
};
foreach my $in (@in) {
$in =~ s/^\s+//s;
$in =~ s/\s+$//s;
$in =~ s/#.+//s;
next unless $in =~ m/\S/;
my(@in, @should);
{
die "What kind of line is <$in>?!"
unless $in =~ m/^(.+)=>(.+)$/s;
my($i,$s) = ($1, $2);
@in = ($i =~ m/(\S+)/g);
@should = ($s =~ m/(\S+)/g);
#print "{@in}{@should}\n";
}
my @out = I18N::LangTags::implicate_supers_strictly(
("@in" eq 'NIX') ? () : @in
);
#print "O: ", join(' ', map "<$_>", @out), "\n";
@out = 'NIX' unless @out;
if( @out == @should
and lc( join "\e", @out ) eq lc( join "\e", @should )
) {
print "# Happily got [@out] from [$in]\n";
ok 1;
} else {
ok 0;
print "#!!Got: [@out]\n",
"#!! but wanted: [@should]\n",
"#!! from \"$in\"\n#\n";
}
}
print "#\n#\n# Bye-bye!\n";
ok 1;
--- NEW FILE: 10_http.t ---
# Time-stamp: "2004-06-17 23:06:22 PDT"
use I18N::LangTags::Detect;
use Test;
BEGIN { plan tests => 87 };
my @in = grep m/\S/, split /\n/, q{
[ sv ] sv
[ en ] en
[ en fi ] en, fi
[ en-us ] en-us
[ en-us ] en-US
[ en-us ] EN-US
[ en-au en i-klingon x-klingon en-gb en-us mt-mt mt ja ] EN-au, JA;q=0.14, i-klingon;q=0.83, en-gb;q=0.71, en-us;q=0.57, mt-mt;q=0.43, mt;q=0.29, en;q=0.86
[ en-au en i-klingon x-klingon en-gb en-us mt-mt mt tli ja ] EN-au, tli;q=0.201, JA;q=0.14, i-klingon;q=0.83, en-gb;q=0.71, en-us;q=0.57, mt-mt;q=0.43, mt;q=0.29, en;q=0.86
[ en-au en en-gb en-us ja ] en-au, ja;q=0.20, en-gb;q=0.60, en-us;q=0.40, en;q=0.80
[ en-au en en-gb en-us mt-mt mt ja ] EN-au, JA;q=0.14, en-gb;q=0.71, en-us;q=0.57, mt-mt;q=0.43, mt;q=0.29, en;q=0.86
[ en-au en en-gb en-us ja ] en-au, ja;q=0.20, en-gb;q=0.60, en-us;q=0.40, en;q=0.80
[ en fr ] en;q=1,fr;q=.5
[ en fr ] en;q=1,fr;q=.99
[ en ru ko ] en, ru;q=0.7, ko;q=0.3
[ en ru ko ] en, ru;q=0.7, KO;q=0.3
[ en-us en ] en-us, en;q=0.50
[ en fr ] fr ; q = 0.9, en
[ en fr ] en,fr;q=.90
[ ru en-uk en fr ] ru, en-UK;q=0.5, en;q=0.3, fr;q=0.1
[ en-us fr es-mx ] en-us,fr;q=0.7,es-mx;q=0.3
[ en-us en ] en-us, en;q=0.50
[ da en-gb en ] da, en-gb;q=0.8, en;q=0.7
[ da en-gb en ] da, en;q=0.7, en-gb;q=0.8
[ da en-gb en ] da, en-gb;q=0.8, en;q=0.7
[ da en-gb en ] da,en;q=0.7,en-gb;q=0.8
[ da en-gb en ] da, en-gb ; q=0.8, en ; q=0.7
[ da en-gb en ] da , en-gb ; q = 0.8 , en ; q =0.7
[ da en-gb en ] da (yup, Danish) , en-gb ; q = 0.8 , en ; q =0.7
[ no dk en-uk en-us ] en-UK;q=0.7, en-US;q=0.6, no;q=1.0, dk;q=0.8
[ no dk en-uk en-us ] en-US;q=0.6, en-UK;q=0.7, no;q=1.0, dk;q=0.8
[ no dk en-uk en-us ] en-UK;q=0.7, no;q=1.0, en-US;q=0.6, dk;q=0.8
[ no dk en-uk en-us ] en-UK;q=0.7, no;q=1.0, dk;q=0.8, en-US;q=0.6
[ fi en ] fi;q=1, en;q=0.2
[ de-de de en en-us en-gb ] de-DE, de;q=0.80, en;q=0.60, en-US;q=0.40, en-GB;q=0.20
[ ru ] ru; q=1, *; q=0.1
[ ru en ] ru, en; q=0.1
[ ja en ] ja,en;q=0.5
[ en ] en; q=1.0
[ ja ] ja; q=1.0
[ ja ] ja; q=1.0
[ en ja ] en; q=0.5, ja; q=0.5
[ fr-ca fr en ] fr-ca, fr;q=0.8, en;q=0.7
[ NIX ] NIX
};
foreach my $in (@in) {
$in =~ s/^\s*\[([^\]]+)\]\s*//s or die "Bad input: $in";
my @should = do { my $x = $1; $x =~ m/(\S+)/g };
if($in eq 'NIX') { $in = ''; @should = (); }
local $ENV{'HTTP_ACCEPT_LANGUAGE'};
foreach my $modus (
sub {
print "# Testing with arg...\n";
$ENV{'HTTP_ACCEPT_LANGUAGE'} = 'PLORK';
return $_[0];
},
sub {
print "# Testing wath HTTP_ACCEPT_LANGUAGE...\n";
$ENV{'HTTP_ACCEPT_LANGUAGE'} = $_[0];
return();
},
) {
my @args = &$modus($in);
# ////////////////////////////////////////////////////
my @out = I18N::LangTags::Detect->http_accept_langs(@args);
# \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
if(
@out == @should
and lc( join "\e", @out ) eq lc( join "\e", @should )
) {
print "# Happily got [@out] from [$in]\n";
ok 1;
} else {
ok 0;
print "#Got: [@out]\n",
"# but wanted: [@should]\n",
"# < \"$in\"\n#\n";
}
}
}
print "#\n#\n# Bye-bye!\n";
ok 1;
--- NEW FILE: 80_all_env.t ---
require 5;
use Test;
# Time-stamp: "2004-07-01 14:33:50 ADT"
BEGIN { plan tests => 20; }
use I18N::LangTags::Detect 1.01;
print "# Hi there...\n";
ok 1;
print "# Using I18N::LangTags::Detect v$I18N::LangTags::Detect::VERSION\n";
print "# Make sure we can assign to ENV entries\n",
"# (Otherwise we can't run the subsequent tests)...\n";
$ENV{'MYORP'} = 'Zing'; ok $ENV{'MYORP'}, 'Zing';
$ENV{'SWUZ'} = 'KLORTHO HOOBOY'; ok $ENV{'SWUZ'}, 'KLORTHO HOOBOY';
delete $ENV{'MYORP'};
delete $ENV{'SWUZ'};
sub j { "[" . join(' ', map "\"$_\"", @_) . "]" ;}
sub show {
print "# (Seeing {", join(' ',
map(qq{<$_>}, @_)), "} at line ", (caller)[2], ")\n";
printenv();
return $_[0] || '';
}
sub printenv {
print "# ENV:\n";
foreach my $k (sort keys %ENV) {
my $p = $ENV{$k}; $p =~ s/\n/\n#/g;
print "# [$k] = [$p]\n"; }
print "# [end of ENV]\n#\n";
}
$ENV{'IGNORE_WIN32_LOCALE'} = 1; # a hack, just for testing's sake.
print "# Test LANGUAGE...\n";
$ENV{'REQUEST_METHOD'} = '';
$ENV{'LANGUAGE'} = 'Eu-MT';
$ENV{'LC_ALL'} = '';
$ENV{'LC_MESSAGES'} = '';
$ENV{'LANG'} = '';
ok show( scalar I18N::LangTags::Detect::detect()), "eu-mt";
ok show( j I18N::LangTags::Detect::detect()), q{["eu-mt"]};
print "# Test LC_ALL...\n";
$ENV{'REQUEST_METHOD'} = '';
$ENV{'LANGUAGE'} = '';
$ENV{'LC_ALL'} = 'Eu-MT';
$ENV{'LC_MESSAGES'} = '';
$ENV{'LANG'} = '';
ok show( scalar I18N::LangTags::Detect::detect()), "eu-mt";
ok show( j I18N::LangTags::Detect::detect()), q{["eu-mt"]};
print "# Test LC_MESSAGES...\n";
$ENV{'REQUEST_METHOD'} = '';
$ENV{'LANGUAGE'} = '';
$ENV{'LC_ALL'} = '';
$ENV{'LC_MESSAGES'} = 'Eu-MT';
$ENV{'LANG'} = '';
ok show( scalar I18N::LangTags::Detect::detect()), "eu-mt";
ok show( j I18N::LangTags::Detect::detect()), q{["eu-mt"]};
print "# Test LANG...\n";
$ENV{'REQUEST_METHOD'} = '';
$ENV{'LANGUAGE'} = '';
$ENV{'LC_ALL'} = '';
$ENV{'LC_MESSAGES'} = '';
$ENV{'LANG'} = 'Eu_MT';
ok show( scalar I18N::LangTags::Detect::detect()), "eu-mt";
ok show( j I18N::LangTags::Detect::detect()), q{["eu-mt"]};
print "# Test LANG...\n";
$ENV{'LANGUAGE'} = '';
$ENV{'REQUEST_METHOD'} = '';
$ENV{'LC_ALL'} = '';
$ENV{'LC_MESSAGES'} = '';
$ENV{'LANG'} = 'Eu_MT';
ok show( scalar I18N::LangTags::Detect::detect()), "eu-mt";
ok show( j I18N::LangTags::Detect::detect()), q{["eu-mt"]};
print "# Test HTTP_ACCEPT_LANGUAGE...\n";
$ENV{'REQUEST_METHOD'} = 'GET';
$ENV{'HTTP_ACCEPT_LANGUAGE'} = 'eu-MT';
ok show( scalar I18N::LangTags::Detect::detect()), "eu-mt";
ok show( j I18N::LangTags::Detect::detect()), q{["eu-mt"]};
$ENV{'HTTP_ACCEPT_LANGUAGE'} = 'x-plorp, zaz, eu-MT, i-klung';
ok show( scalar I18N::LangTags::Detect::detect()), "x-plorp";
ok show( j I18N::LangTags::Detect::detect()), qq{["x-plorp" "i-plorp" "zaz" "eu-mt" "i-klung" "x-klung"]};
$ENV{'HTTP_ACCEPT_LANGUAGE'} = 'x-plorp, zaz, eU-Mt, i-klung';
ok show( scalar I18N::LangTags::Detect::detect()), "x-plorp";
ok show( j I18N::LangTags::Detect::detect()), qq{["x-plorp" "i-plorp" "zaz" "eu-mt" "i-klung" "x-klung"]};
print "# Byebye!\n";
ok 1;
--- NEW FILE: 05_main.t ---
require 5;
# Time-stamp: "2004-03-30 17:52:14 AST"
use strict;
use Test;
BEGIN { plan tests => 64 };
BEGIN { ok 1 }
use I18N::LangTags (':ALL');
print "# Perl v$], I18N::LangTags v$I18N::LangTags::VERSION\n";
ok !is_language_tag('');
ok is_language_tag('fr');
ok is_language_tag('fr-ca');
ok is_language_tag('fr-CA');
ok !is_language_tag('fr-CA-');
ok !is_language_tag('fr_CA');
ok is_language_tag('fr-ca-joual');
ok !is_language_tag('frca');
ok is_language_tag('nav'); # (not actual tag)
ok is_language_tag('nav-shiprock'); # (not actual tag)
ok !is_language_tag('nav-ceremonial'); # subtag too long
ok !is_language_tag('x');
ok !is_language_tag('i');
ok is_language_tag('i-borg'); # NB: fictitious tag
ok is_language_tag('x-borg');
ok is_language_tag('x-borg-prot5123');
ok same_language_tag('x-borg-prot5123', 'i-BORG-Prot5123' );
ok !same_language_tag('en', 'en-us' );
ok 0 == similarity_language_tag('en-ca', 'fr-ca');
ok 1 == similarity_language_tag('en-ca', 'en-us');
ok 2 == similarity_language_tag('en-us-southern', 'en-us-western');
ok 2 == similarity_language_tag('en-us-southern', 'en-us');
ok grep $_ eq 'hi', panic_languages('kok');
ok grep $_ eq 'en', panic_languages('x-woozle-wuzzle');
ok ! grep $_ eq 'mr', panic_languages('it');
ok grep $_ eq 'es', panic_languages('it');
ok grep $_ eq 'it', panic_languages('es');
print "# Now the ::List tests...\n";
print "# Perl v$], I18N::LangTags::List v$I18N::LangTags::List::VERSION\n";
use I18N::LangTags::List;
foreach my $lt (qw(
en
en-us
en-kr
el
elx
i-mingo
i-mingo-tom
x-mingo-tom
it
it-it
it-IT
it-FR
ak
aka
jv
jw
no
no-nyn
nn
i-lux
lb
wa
yi
ji
den-syllabic
den-syllabic-western
den-western
den-latin
cre-syllabic
cre-syllabic-western
cre-western
cre-latin
cr-syllabic
cr-syllabic-western
cr-western
cr-latin
)) {
my $name = I18N::LangTags::List::name($lt);
if($name) {
ok(1);
print "# $lt -> $name\n";
} else {
ok(0);
print "# Failed lookup on $lt\n";
}
}
print "# So there!\n";
--- NEW FILE: 50_super.t ---
# Time-stamp: "2004-03-30 17:46:17 AST"
use Test;
BEGIN { plan tests => 26 };
print "#\n# Testing normal (tight) insertion of super-ordinate language tags...\n#\n";
use I18N::LangTags qw(implicate_supers);
my @in = grep m/\S/, split /[\n\r]/, q{
NIX => NIX
sv => sv
en => en
hai => hai
pt-br => pt-br pt
pt-br fr => pt-br pt fr
pt-br fr pt => pt-br fr pt
pt-br fr pt de => pt-br fr pt de
de pt-br fr pt => de pt-br fr pt
de pt-br fr => de pt-br pt fr
hai pt-br fr => hai pt-br pt fr
# Now test multi-part complicateds:
pt-br-janeiro => pt-br-janeiro pt-br pt
pt-br-janeiro fr => pt-br-janeiro pt-br pt fr
pt-br-janeiro de fr => pt-br-janeiro pt-br pt de fr
pt-br-janeiro de pt fr => pt-br-janeiro pt-br de pt fr
pt-br-janeiro pt-br-saopaolo => pt-br-janeiro pt-br pt pt-br-saopaolo
pt-br-janeiro fr pt-br-saopaolo => pt-br-janeiro pt-br pt fr pt-br-saopaolo
pt-br-janeiro de pt-br-saopaolo fr => pt-br-janeiro pt-br pt de pt-br-saopaolo fr
pt-br-janeiro de pt-br fr pt-br-saopaolo => pt-br-janeiro de pt-br pt fr pt-br-saopaolo
pt-br de en fr pt-br-janeiro => pt-br pt de en fr pt-br-janeiro
pt-br de en fr => pt-br pt de en fr
ja pt-br-janeiro fr => ja pt-br-janeiro pt-br pt fr
ja pt-br-janeiro de fr => ja pt-br-janeiro pt-br pt de fr
ja pt-br-janeiro de pt fr => ja pt-br-janeiro pt-br de pt fr
pt-br-janeiro de pt-br fr => pt-br-janeiro de pt-br pt fr
# an odd case, since we don't filter for uniqueness in this sub
};
sub uniq { my %seen; return grep(!($seen{$_}++), @_); }
foreach my $in (@in) {
$in =~ s/^\s+//s;
$in =~ s/\s+$//s;
$in =~ s/#.+//s;
next unless $in =~ m/\S/;
my(@in, @should);
{
die "What kind of line is <$in>?!"
unless $in =~ m/^(.+)=>(.+)$/s;
my($i,$s) = ($1, $2);
@in = ($i =~ m/(\S+)/g);
@should = ($s =~ m/(\S+)/g);
#print "{@in}{@should}\n";
}
my @out = implicate_supers(
("@in" eq 'NIX') ? () : @in
);
#print "O: ", join(' ', map "<$_>", @out), "\n";
@out = 'NIX' unless @out;
if( @out == @should
and lc( join "\e", @out ) eq lc( join "\e", @should )
) {
print "# Happily got [@out] from [$in]\n";
ok 1;
} else {
ok 0;
print "#!!Got: [@out]\n",
"#!! but wanted: [@should]\n",
"#!! from \"$in\"\n#\n";
}
}
print "#\n#\n# Bye-bye!\n";
ok 1;
--- NEW FILE: 20_locales.t ---
require 5;
# Time-stamp: "2004-10-06 23:07:06 ADT"
use strict;
use Test;
BEGIN { plan tests => 22 };
BEGIN { ok 1 }
use I18N::LangTags (':ALL');
print "# Perl v$], I18N::LangTags v$I18N::LangTags::VERSION\n";
print "# Loaded from ", $INC{'I18N/LangTags.pm'} || "??", "\n";
ok lc locale2language_tag('en'), 'en';
ok lc locale2language_tag('en_US'), 'en-us';
ok lc locale2language_tag('en_US.ISO8859-1'), 'en-us';
ok lc(locale2language_tag('C')||''), '';
ok lc(locale2language_tag('POSIX')||''), '';
ok lc locale2language_tag('eu_mt'), 'eu-mt';
ok lc locale2language_tag('eu'), 'eu';
ok lc locale2language_tag('it'), 'it';
ok lc locale2language_tag('it_IT'), 'it-it';
ok lc locale2language_tag('it_IT.utf8'), 'it-it';
ok lc locale2language_tag('it_IT.utf8 at euro'), 'it-it';
ok lc locale2language_tag('it_IT at euro'), 'it-it';
ok lc locale2language_tag('zh_CN.gb18030'), 'zh-cn';
ok lc locale2language_tag('zh_CN.gbk'), 'zh-cn';
ok lc locale2language_tag('zh_CN.utf8'), 'zh-cn';
ok lc locale2language_tag('zh_HK'), 'zh-hk';
ok lc locale2language_tag('zh_HK.utf8'), 'zh-hk';
ok lc locale2language_tag('zh_TW'), 'zh-tw';
ok lc locale2language_tag('zh_TW.euctw'), 'zh-tw';
ok lc locale2language_tag('zh_TW.utf8'), 'zh-tw';
print "# So there!\n";
ok 1;
More information about the dslinux-commit
mailing list