#!/usr/bin/perl
# Copyright (c) 2016-2017 Sullivan Beck. All rights reserved.
# This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
use warnings;
use strict;
no strict 'subs';
no strict 'refs';
my %type = ('country' => 'Country',
'language' => 'Language',
'currency' => 'Currency',
'script' => 'Script',
'langfam' => 'LangFam',
'langext' => 'LangExt',
'langvar' => 'LangVar',
);
my $generic_tests;
sub do_tests {
my($data_type,$inp_file,$test_type,$codeset,$show_errs) = @_;
my $type = $type{$data_type};
$::data_type = $data_type;
$::test_type = $test_type;
$inp_file = $data_type if (! $inp_file);
my($runtests) = shift(@ARGV);
# Load the test function and the data for the tests
my($dir,$tdir);
if ( -f "t/testfunc.pl" ) {
require "./t/testfunc.pl";
require "./t/vals_${inp_file}.pl";
$dir="./lib";
$tdir="t";
} elsif ( -f "testfunc.pl" ) {
require "./testfunc.pl";
require "./vals_${inp_file}.pl";
$dir="../lib";
$tdir=".";
} else {
die "ERROR: cannot find testfunc.pl\n";
}
unshift(@INC,$dir);
$::tests .= $generic_tests if (! defined($show_errs));
if ($test_type eq 'old') {
$::module = "Locale::$type";
eval("use $::module");
my $tmp = $::module . "::show_errors";
&{ $tmp }(0);
} elsif ($test_type eq 'func') {
$::module = "Locale::Codes::$type";
eval("use $::module");
my $tmp = $::module . "::show_errors";
&{ $tmp }(0);
} elsif (defined($codeset)) {
eval("use Locale::Codes");
$::obj = Locale::Codes->new($data_type,$codeset,$show_errs);
$::obj->show_errors(1);
} elsif (defined($show_errs)) {
eval("use Locale::Codes");
$::obj = Locale::Codes->new();
$::obj->type($data_type);
$::obj->show_errors($show_errs);
} else {
eval("use Locale::Codes");
$::obj = new Locale::Codes $data_type;
$::obj->show_errors(0);
}
print "$::data_type [$::test_type]\n";
test_Func(\&test,$::tests,$runtests);
}
sub test {
my ($op,@test) = @_;
my @ret;
my $stderr = '';
{
local *STDERR;
open STDERR, '>', \$stderr;
@ret = _test($op,@test);
}
if ($stderr) {
$stderr =~ s/\n.*//m;
chomp($stderr);
return $stderr;
} else {
return @ret;
}
}
sub _test {
my ($op,@test) = @_;
if ($op eq '2code') {
my $code;
if ($::obj) {
$code = $::obj->name2code(@test);
} else {
$code = &{ "${::data_type}2code" }(@test);
}
return ($code ? lc($code) : $code);
} elsif ($op eq '2name') {
if ($::obj) {
return $::obj->code2name(@test);
} else {
return &{ "code2${::data_type}" }(@test)
}
} elsif ($op eq 'code2code') {
my $code;
if ($::obj) {
$code = $::obj->code2code(@test);
} else {
$code = &{ "${::data_type}_code2code" }(@test);
}
return ($code ? lc($code) : $code);
} elsif ($op eq 'all_codes') {
my $n;
if ($test[$#test] =~ /^\d+$/) {
$n = pop(@test);
}
my @tmp;
if ($::obj) {
@tmp = $::obj->all_codes(@test);
} else {
@tmp = &{ "all_${::data_type}_codes" }(@test);
}
if ($n && @tmp > $n) {
return @tmp[0..($n-1)];
} else {
return @tmp;
}
} elsif ($op eq 'all_names') {
my $n;
if ($test[$#test] =~ /^\d+$/) {
$n = pop(@test);
}
my @tmp;
if ($::obj) {
@tmp = $::obj->all_names(@test);
} else {
@tmp = &{ "all_${::data_type}_names" }(@test);
}
if ($n && @tmp > $n) {
return @tmp[0..($n-1)];
} else {
return @tmp;
}
} elsif ($op eq 'rename') {
if ($::obj) {
return $::obj->rename_code(@test);
} else {
return &{ "${::module}::rename_${::data_type}" }(@test)
}
} elsif ($op eq 'add') {
if ($::obj) {
return $::obj->add_code(@test);
} else {
return &{ "${::module}::add_${::data_type}" }(@test)
}
} elsif ($op eq 'delete') {
if ($::obj) {
return $::obj->delete_code(@test);
} else {
return &{ "${::module}::delete_${::data_type}" }(@test)
}
} elsif ($op eq 'add_alias') {
if ($::obj) {
return $::obj->add_alias(@test);
} else {
return &{ "${::module}::add_${::data_type}_alias" }(@test)
}
} elsif ($op eq 'delete_alias') {
if ($::obj) {
return $::obj->delete_alias(@test);
} else {
return &{ "${::module}::delete_${::data_type}_alias" }(@test)
}
} elsif ($op eq 'replace_code') {
if ($::obj) {
return $::obj->replace_code(@test);
} else {
return &{ "${::module}::rename_${::data_type}_code" }(@test)
}
} elsif ($op eq 'add_code_alias') {
if ($::obj) {
return $::obj->add_code_alias(@test);
} else {
return &{ "${::module}::add_${::data_type}_code_alias" }(@test)
}
} elsif ($op eq 'delete_code_alias') {
if ($::obj) {
return $::obj->delete_code_alias(@test);
} else {
return &{ "${::module}::delete_${::data_type}_code_alias" }(@test)
}
} elsif ($op eq 'codeset') {
if ($::obj) {
return $::obj->codeset(@test);
} else {
return &{ "${::module}::codeset" }(@test)
}
} elsif ($op eq 'type') {
if ($::obj) {
return $::obj->type(@test);
} else {
return &{ "${::module}::type" }(@test)
}
}
}
$generic_tests = "
#################
2code
_undef_
_undef_
2code
_undef_
2code
_blank_
_undef_
2code
UnusedName
_undef_
2code
_undef_
2code
_undef_
_undef_
2name
_undef
_undef_
2name
_undef_
###
add
AAA
newCode
1
2code
newCode
aaa
delete
AAA
1
2code
newCode
_undef_
###
add
AAA
newCode
1
rename
AAA
newCode2
1
2code
newCode
aaa
2code
newCode2
aaa
###
add_alias
newCode2
newAlias
1
2code
newAlias
aaa
delete_alias
newAlias
1
2code
newAlias
_undef_
###
replace_code
AAA
BBB
1
2name
AAA
newCode2
2name
BBB
newCode2
###
add_code_alias
BBB
CCC
1
2name
BBB
newCode2
2name
CCC
newCode2
delete_code_alias
CCC
1
2name
CCC
_undef_
";
1;
# Local Variables:
# mode: cperl
# indent-tabs-mode: nil
# cperl-indent-level: 3
# cperl-continued-statement-offset: 2
# cperl-continued-brace-offset: 0
# cperl-brace-offset: 0
# cperl-brace-imaginary-offset: 0
# cperl-label-offset: 0
# End: