[perl5.git] / t / run / locale.t

#!./perl
BEGIN {
    chdir 't' if -d 't';
    @INC = '../lib';
    require './test.pl';    # for fresh_perl_is() etc
    require './loc_tools.pl'; # to find locales
}

use strict;

########
# These tests are here instead of lib/locale.t because
# some bugs depend on the internal state of the locale
# settings and pragma/locale messes up that state pretty badly.
# We need "fresh runs".
BEGIN {
    eval { require POSIX; POSIX->import("locale_h") };
    if ($@) {
	skip_all("could not load the POSIX module"); # running minitest?
    }
}
use Config;
my $have_strtod = $Config{d_strtod} eq 'define';
my @locales = find_locales( [ 'LC_ALL', 'LC_CTYPE', 'LC_NUMERIC' ]);
skip_all("no locales available") unless @locales;

my $debug = 0;
my $switches = "";
if (defined $ARGV[0] && $ARGV[0] ne "") {
    if ($ARGV[0] ne 'debug') {
        print STDERR "Usage: $0 [ debug ]\n";
        exit 1
    }
    $debug = 1;
    $switches = "switches => [ '-DLv' ]";
}

# reset the locale environment
delete local @ENV{'LANG', (grep /^LC_[A-Z]+$/, keys %ENV)};

# If user wants this to happen, they set the environment variable AND use
# 'debug'
delete local $ENV{'PERL_DEBUG_LOCALE_INIT'} unless $debug;

{
    fresh_perl_is(<<"EOF",
            use locale;
            use POSIX;
            POSIX::setlocale(POSIX::LC_CTYPE(),"C");
            print "h" =~ /[g\\w]/i || 0;
            print "\\n";
EOF
        1, { stderr => 'devnull' }, "/il matching of [bracketed] doesn't skip POSIX class if fails individ char");
}

{
    fresh_perl_is(<<"EOF",
            use locale;
            use POSIX;
            POSIX::setlocale(POSIX::LC_CTYPE(),"C");
            print "0" =~ /[\\d[:punct:]]/l || 0;
            print "\\n";
EOF
        1, { stderr => 'devnull' }, "/l matching of [bracketed] doesn't skip non-first POSIX class");

}

my $non_C_locale;
foreach my $locale (@locales) {
    next if $locale eq "C" || $locale eq 'POSIX';
    $non_C_locale = $locale;
    last;
}

if ($non_C_locale) {
    setlocale(LC_NUMERIC, $non_C_locale);
    isnt(setlocale(LC_NUMERIC), "C", "retrieving current non-C LC_NUMERIC doesn't give 'C'");
    setlocale(LC_ALL, $non_C_locale);
    isnt(setlocale(LC_ALL), "C", "retrieving current non-C LC_ALL doesn't give 'C'");

    my @test_numeric_locales = @locales;

    # Skip this locale on these cywgwin versions as the returned radix character
    # length is wrong
    if (   $^O eq 'cygwin'
        && version->new(($Config{'osvers'} =~ /^(\d+(?:\.\d+)+)/)[0]) le v2.4.1)
    {
        @test_numeric_locales = grep { $_ !~ m/ps_AF/i } @test_numeric_locales;
    }

    # Similarly the arabic locales on solaris don't work right on the
    # multi-byte radix character, generating malformed UTF-8.
    if ($^O eq 'solaris') {
        @test_numeric_locales = grep { $_ !~ m/ ^ ( ar_ | pa_ ) /x }
                                                        @test_numeric_locales;
    }

    fresh_perl_is("for (qw(@test_numeric_locales)) {\n" . <<'EOF',
        use POSIX qw(locale_h);
        use locale;
        setlocale(LC_NUMERIC, "$_") or next;
        my $s = sprintf "%g %g", 3.1, 3.1;
        next if $s eq '3.1 3.1' || $s =~ /^(3.+1) \1$/;
        no warnings "utf8";
        print "$_ $s\n";
    }
EOF
        "", { eval $switches }, "no locales where LC_NUMERIC breaks");

    SKIP: {
        skip("Windows stores locale defaults in the registry", 1 )
                                                                if $^O eq 'MSWin32';
        fresh_perl_is("for (qw(@locales)) {\n" . <<'EOF',
            use POSIX qw(locale_h);
            use locale;
            my $in = 4.2;
            my $s = sprintf "%g", $in; # avoid any constant folding bugs
            next if $s eq "4.2";
            no warnings "utf8";
            print "$_ $s\n";
        }
EOF
        "", { eval $switches }, "LC_NUMERIC without environment nor setlocale() has no effect in any locale");
    }

    # try to find out a locale where LC_NUMERIC makes a difference
    my $original_locale = setlocale(LC_NUMERIC);

    my ($base, $different, $comma, $difference, $utf8_radix);
    my $radix_encoded_as_utf8;
    for ("C", @locales) { # prefer C for the base if available
        use locale;
        setlocale(LC_NUMERIC, $_) or next;
        my $in = 4.2; # avoid any constant folding bugs
        if ((my $s = sprintf("%g", $in)) eq "4.2")  {
            $base ||= $_;
        } else {
            $different ||= $_;
            $difference ||= $s;
            my $radix = localeconv()->{decimal_point};

            # For utf8 locales with a non-ascii radix, it should be encoded as
            # UTF-8 with the internal flag so set.
            if (! defined $utf8_radix
                && $radix =~ /[[:^ascii:]]/u  # /u because /l can raise warnings
                && is_locale_utf8($_))
            {
                $utf8_radix = $_;
                $radix_encoded_as_utf8 = utf8::is_utf8($radix);
            }
            else {
                $comma ||= $_ if $radix eq ',';
            }
        }

        last if $base && $different && $comma && $utf8_radix;
    }
    setlocale(LC_NUMERIC, $original_locale);

    SKIP: {
        skip("no UTF-8 locale available where LC_NUMERIC radix isn't ASCII", 1 )
            unless $utf8_radix;
        ok($radix_encoded_as_utf8 == 1, "UTF-8 locale '$utf8_radix' with non-ASCII"
                                        . " radix is marked UTF-8");
    }

    if ($different) {
        note("using the '$different' locale for LC_NUMERIC tests");
        {
            local $ENV{LC_NUMERIC} = $different;

            fresh_perl_is(<<'EOF', "4.2", { eval $switches },
    format STDOUT =
@.#
4.179
.
    write;
EOF
                "format() does not look at LC_NUMERIC without 'use locale'");

    {
    fresh_perl_is(<<'EOF', "$difference\n", { eval $switches },
    use POSIX;
    use locale;
    format STDOUT =
@.#
4.179
.
    write;
EOF
                "format() looks at LC_NUMERIC with 'use locale'");
            }

            {
                fresh_perl_is(<<'EOF', ",,", { eval $switches },
    use POSIX;
    no warnings "utf8";
    print localeconv()->{decimal_point};
    use locale;
    print localeconv()->{decimal_point};
EOF
                "localeconv() looks at LC_NUMERIC with and without 'use locale'");
            }

            {
                my $categories = ":collate :characters :collate :ctype :monetary :time";
                fresh_perl_is(<<"EOF", "4.2", { eval $switches },
    use locale qw($categories);
    format STDOUT =
@.#
4.179
.
    write;
EOF
                "format() does not look at LC_NUMERIC with 'use locale qw($categories)'");
            }

            {
                fresh_perl_is(<<'EOF', $difference, { eval $switches },
    use locale;
    format STDOUT =
@.#
4.179
.
    write;
EOF
                "format() looks at LC_NUMERIC with 'use locale'");
            }

            for my $category (qw(collate characters collate ctype monetary time)) {
                for my $negation ("!", "not_") {
                    fresh_perl_is(<<"EOF", $difference, { eval $switches },
    use locale ":$negation$category";
format STDOUT =
@.#
4.179
.
    write;
EOF
                    "format() looks at LC_NUMERIC with 'use locale \":"
                    . "$negation$category\"'");
                }
            }

            {
                fresh_perl_is(<<'EOF', $difference, { eval $switches },
    use locale ":numeric";
format STDOUT =
@.#
4.179
.
    write;
EOF
                "format() looks at LC_NUMERIC with 'use locale \":numeric\"'");
            }

            {
                fresh_perl_is(<<'EOF', "4.2", { eval $switches },
format STDOUT =
@.#
4.179
.
    { use locale; write; }
EOF
                "too late to look at the locale at write() time");
            }

            {
                fresh_perl_is(<<'EOF', $difference, { eval $switches },
    use locale;
    format STDOUT =
@.#
4.179
.
    { no locale; write; }
EOF
                "too late to ignore the locale at write() time");
            }
        }

        {
            # do not let "use 5.000" affect the locale!
            # this test is to prevent regression of [rt.perl.org #105784]
            fresh_perl_is(<<"EOF",
                use locale;
                use POSIX;
                my \$i = 0.123;
                POSIX::setlocale(POSIX::LC_NUMERIC(),"$different");
                \$a = sprintf("%.2f", \$i);
                require version;
                \$b = sprintf("%.2f", \$i);
                no warnings "utf8";
                print ".\$a \$b" unless \$a eq \$b
EOF
                "", { eval $switches }, "version does not clobber version");

            fresh_perl_is(<<"EOF",
                use locale;
                use POSIX;
                my \$i = 0.123;
                POSIX::setlocale(POSIX::LC_NUMERIC(),"$different");
                \$a = sprintf("%.2f", \$i);
                eval "use v5.0.0";
                \$b = sprintf("%.2f", \$i);
                no warnings "utf8";
                print "\$a \$b" unless \$a eq \$b
EOF
                "", { eval $switches }, "version does not clobber version (via eval)");
        }

        {
            local $ENV{LC_NUMERIC} = $different;
            fresh_perl_is(<<'EOF', "$difference "x4, { eval $switches },
                use locale;
                use POSIX qw(locale_h);
                my $in = 4.2;
                printf("%g %g %s %s ", $in, 4.2, sprintf("%g", $in), sprintf("%g", 4.2));
EOF
            "sprintf() and printf() look at LC_NUMERIC regardless of constant folding");
        }

        {
            local $ENV{LC_NUMERIC} = $different;
            fresh_perl_is(<<'EOF', "$difference "x4, { eval $switches },
                use locale;
                use POSIX qw(locale_h);
                my $in = 4.2;
                printf("%g %g %s %s ", $in, 4.2, sprintf("%g", $in), sprintf("%g", 4.2));
EOF
            "Uses the above test to verify that on Windows the system default locale has lower priority than LC_NUMERIC");
        }


        # within this block, STDERR is closed. This is because fresh_perl_is()
        # forks a shell, and some shells (like bash) can complain noisily when
        # LC_ALL or similar is set to an invalid value

        {
            open my $saved_stderr, ">&STDERR" or die "Can't dup STDERR: $!";
            close STDERR;

            {
                local $ENV{LC_ALL} = "invalid";
                local $ENV{LC_NUMERIC} = "invalid";
                local $ENV{LANG} = $different;
                local $ENV{PERL_BADLANG} = 0;

                if (! fresh_perl_is(<<"EOF", "$difference", { eval $switches  },
                    if (\$ENV{LC_ALL} ne "invalid") {
                        # Make the test pass if the sh didn't accept the ENV set
                        no warnings "utf8";
                        print "$difference\n";
                        exit 0;
                    }
                    use locale;
                    use POSIX qw(locale_h);
                    my \$in = 4.2;
                    printf("%g", \$in);
EOF
                "LANG is used if LC_ALL, LC_NUMERIC are invalid"))
            {
                note "To see details change this .t, do not close STDERR";
            }
            }

            SKIP: {
                if ($^O eq 'MSWin32') {
                    skip("Win32 uses system default locale in preference to \"C\"",
                            1);
                }
                else {
                    local $ENV{LC_ALL} = "invalid";
                    local $ENV{LC_NUMERIC} = "invalid";
                    local $ENV{LANG} = "invalid";
                    local $ENV{PERL_BADLANG} = 0;

                    if (! fresh_perl_is(<<"EOF", 4.2, { eval $switches  },
                        if (\$ENV{LC_ALL} ne "invalid") {
                            no warnings "utf8";
                            print "$difference\n";
                            exit 0;
                        }
                        use locale;
                        use POSIX qw(locale_h);
                        my \$in = 4.2;
                        printf("%g", \$in);
EOF
                    'C locale is used if LC_ALL, LC_NUMERIC, LANG are invalid'))
                    {
                        note "To see details change this .t, do not close STDERR";
                    }
                }
            }

        open STDERR, ">&", $saved_stderr or die "Can't dup \$saved_stderr: $!";
        }

        {
            local $ENV{LC_NUMERIC} = $different;
            fresh_perl_is(<<"EOF",
                use POSIX qw(locale_h);

                BEGIN { setlocale(LC_NUMERIC, \"$different\"); };
                setlocale(LC_ALL, "C");
                use 5.008;
                print setlocale(LC_NUMERIC);
EOF
            "C", { stderr => 'devnull' },
            "No compile error on v-strings when setting the locale to non-dot radix at compile time when default environment has non-dot radix");
        }

        unless ($comma) {
            skip("no locale available where LC_NUMERIC is a comma", 3);
        }
        else {

            fresh_perl_is(<<"EOF",
                my \$i = 1.5;
                {
                    use locale;
                    use POSIX;
                    POSIX::setlocale(POSIX::LC_NUMERIC(),"$comma");
                    print \$i, "\n";
                }
                print \$i, "\n";
EOF
                "1,5\n1.5", { stderr => 'devnull' }, "Radix print properly in locale scope, and without");

            fresh_perl_is(<<"EOF",
                my \$i = 1.5;   # Should be exactly representable as a base 2
                                # fraction, so can use 'eq' below
                use locale;
                use POSIX;
                POSIX::setlocale(POSIX::LC_NUMERIC(),"$comma");
                print \$i, "\n";
                \$i += 1;
                print \$i, "\n";
EOF
                "1,5\n2,5", { stderr => 'devnull' }, "Can do math when radix is a comma"); # [perl 115800]

          SKIP: {
            unless ($have_strtod) {
                skip("no strtod()", 1);
            }
            else {
                fresh_perl_is(<<"EOF",
                    use POSIX;
                    POSIX::setlocale(POSIX::LC_NUMERIC(),"$comma");
                    my \$one_point_5 = POSIX::strtod("1,5");
                    \$one_point_5 =~ s/0+\$//;  # Remove any trailing zeros
                    print \$one_point_5, "\n";
EOF
                "1.5", { stderr => 'devnull' }, "POSIX::strtod() uses underlying locale");
            }
          }
        }
    }

    {
        my @valid_categories = valid_locale_categories();

        my $valid_string = "";
        my $invalid_string = "";

        # Deliberately don't include all categories, so as to test this situation
        for my $i (0 .. @valid_categories - 2) {
            my $category = $valid_categories[$i];
            if ($category ne "LC_ALL") {
                $invalid_string .= ";" if $invalid_string ne "";
                $invalid_string .= "$category=foo_BAR";

                next unless $non_C_locale;
                $valid_string .= ";" if $valid_string ne "";
                $valid_string .= "$category=$non_C_locale";
            }
        }

        fresh_perl(<<"EOF",
                use locale;
                use POSIX;
                POSIX::setlocale(LC_ALL, "$invalid_string");
EOF
            {});
        is ($?, 0, "In setting complicated invalid LC_ALL, final individ category doesn't need a \';'");

        skip("no non-C locale available", 1 ) unless $non_C_locale;
        fresh_perl(<<"EOF",
                use locale;
                use POSIX;
                POSIX::setlocale(LC_ALL, "$valid_string");
EOF
            {});
        is ($?, 0, "In setting complicated valid LC_ALL, final individ category doesn't need a \';'");

    }

}

done_testing();
Commit	Line	Data
9c6df44e NT	1	#!./perl
	2	BEGIN {
	3	chdir 't' if -d 't';
	4	@INC = '../lib';
	5	require './test.pl'; # for fresh_perl_is() etc
a5dfa8d3	6	require './loc_tools.pl'; # to find locales
9c6df44e NT	7	}
	8
	9	use strict;
	10
	11	########
903eb63f	12	# These tests are here instead of lib/locale.t because
05760874	13	# some bugs depend on the internal state of the locale
9c6df44e	14	# settings and pragma/locale messes up that state pretty badly.
903eb63f	15	# We need "fresh runs".
9c6df44e	16	BEGIN {
903eb63f	17	eval { require POSIX; POSIX->import("locale_h") };
9c6df44e NT	18	if ($@) {
	19	skip_all("could not load the POSIX module"); # running minitest?
	20	}
	21	}
	22	use Config;
371d5d44	23	my $have_strtod = $Config{d_strtod} eq 'define';
cd1f7080	24	my @locales = find_locales( [ 'LC_ALL', 'LC_CTYPE', 'LC_NUMERIC' ]);
9c6df44e NT	25	skip_all("no locales available") unless @locales;
9c6df44e NT	26
40f10af4 KW	27	my $debug = 0;
	28	my $switches = "";
	29	if (defined $ARGV[0] && $ARGV[0] ne "") {
	30	if ($ARGV[0] ne 'debug') {
	31	print STDERR "Usage: $0 [ debug ]\n";
	32	exit 1
	33	}
	34	$debug = 1;
	35	$switches = "switches => [ '-DLv' ]";
	36	}
	37
c53481e7	38	# reset the locale environment
d5e32b93	39	delete local @ENV{'LANG', (grep /^LC_[A-Z]+$/, keys %ENV)};
c53481e7	40
40f10af4 KW	41	# If user wants this to happen, they set the environment variable AND use
	42	# 'debug'
	43	delete local $ENV{'PERL_DEBUG_LOCALE_INIT'} unless $debug;
	44
385130eb KW	45	{
	46	fresh_perl_is(<<"EOF",
	47	use locale;
	48	use POSIX;
	49	POSIX::setlocale(POSIX::LC_CTYPE(),"C");
	50	print "h" =~ /[g\\w]/i \|\| 0;
	51	print "\\n";
	52	EOF
	53	1, { stderr => 'devnull' }, "/il matching of [bracketed] doesn't skip POSIX class if fails individ char");
	54	}
	55
	56	{
	57	fresh_perl_is(<<"EOF",
	58	use locale;
	59	use POSIX;
	60	POSIX::setlocale(POSIX::LC_CTYPE(),"C");
	61	print "0" =~ /[\\d[:punct:]]/l \|\| 0;
	62	print "\\n";
	63	EOF
	64	1, { stderr => 'devnull' }, "/l matching of [bracketed] doesn't skip non-first POSIX class");
	65
	66	}
49efabc8	67
a7fa5053	68	my $non_C_locale;
49efabc8	69	foreach my $locale (@locales) {
a7fa5053 KW	70	next if $locale eq "C" \|\| $locale eq 'POSIX';
a7fa5053 KW	71	$non_C_locale = $locale;
49efabc8 KW	72	last;
	73	}
	74
385130eb	75	if ($non_C_locale) {
a7fa5053 KW	76	setlocale(LC_NUMERIC, $non_C_locale);
	77	isnt(setlocale(LC_NUMERIC), "C", "retrieving current non-C LC_NUMERIC doesn't give 'C'");
	78	setlocale(LC_ALL, $non_C_locale);
	79	isnt(setlocale(LC_ALL), "C", "retrieving current non-C LC_ALL doesn't give 'C'");
a7fa5053	80
385130eb	81	my @test_numeric_locales = @locales;
dc51aebe	82
385130eb KW	83	# Skip this locale on these cywgwin versions as the returned radix character
	84	# length is wrong
	85	if ( $^O eq 'cygwin'
	86	&& version->new(($Config{'osvers'} =~ /^(\d+(?:\.\d+)+)/)[0]) le v2.4.1)
	87	{
	88	@test_numeric_locales = grep { $_ !~ m/ps_AF/i } @test_numeric_locales;
	89	}
9c6df44e	90
e3e8c0d6 KW	91	# Similarly the arabic locales on solaris don't work right on the
	92	# multi-byte radix character, generating malformed UTF-8.
	93	if ($^O eq 'solaris') {
	94	@test_numeric_locales = grep { $_ !~ m/ ^ ( ar_ \| pa_ ) /x }
	95	@test_numeric_locales;
	96	}
	97
385130eb	98	fresh_perl_is("for (qw(@test_numeric_locales)) {\n" . <<'EOF',
5be9e824 KW	99	use POSIX qw(locale_h);
5be9e824 KW	100	use locale;
385130eb KW	101	setlocale(LC_NUMERIC, "$_") or next;
	102	my $s = sprintf "%g %g", 3.1, 3.1;
	103	next if $s eq '3.1 3.1' \|\| $s =~ /^(3.+1) \1$/;
6ec573cf	104	no warnings "utf8";
5be9e824 KW	105	print "$_ $s\n";
5be9e824 KW	106	}
903eb63f	107	EOF
385130eb	108	"", { eval $switches }, "no locales where LC_NUMERIC breaks");
903eb63f	109
385130eb KW	110	SKIP: {
	111	skip("Windows stores locale defaults in the registry", 1 )
	112	if $^O eq 'MSWin32';
	113	fresh_perl_is("for (qw(@locales)) {\n" . <<'EOF',
	114	use POSIX qw(locale_h);
	115	use locale;
	116	my $in = 4.2;
	117	my $s = sprintf "%g", $in; # avoid any constant folding bugs
	118	next if $s eq "4.2";
6ec573cf	119	no warnings "utf8";
385130eb	120	print "$_ $s\n";
c1284011	121	}
385130eb KW	122	EOF
385130eb KW	123	"", { eval $switches }, "LC_NUMERIC without environment nor setlocale() has no effect in any locale");
903eb63f NT	124	}
903eb63f NT	125
385130eb KW	126	# try to find out a locale where LC_NUMERIC makes a difference
385130eb KW	127	my $original_locale = setlocale(LC_NUMERIC);
903eb63f	128
385130eb KW	129	my ($base, $different, $comma, $difference, $utf8_radix);
	130	my $radix_encoded_as_utf8;
	131	for ("C", @locales) { # prefer C for the base if available
	132	use locale;
	133	setlocale(LC_NUMERIC, $_) or next;
	134	my $in = 4.2; # avoid any constant folding bugs
	135	if ((my $s = sprintf("%g", $in)) eq "4.2") {
	136	$base \|\|= $_;
	137	} else {
	138	$different \|\|= $_;
	139	$difference \|\|= $s;
	140	my $radix = localeconv()->{decimal_point};
	141
	142	# For utf8 locales with a non-ascii radix, it should be encoded as
	143	# UTF-8 with the internal flag so set.
	144	if (! defined $utf8_radix
8dcd53c9	145	&& $radix =~ /[[:^ascii:]]/u # /u because /l can raise warnings
385130eb KW	146	&& is_locale_utf8($_))
	147	{
	148	$utf8_radix = $_;
	149	$radix_encoded_as_utf8 = utf8::is_utf8($radix);
	150	}
	151	else {
	152	$comma \|\|= $_ if $radix eq ',';
	153	}
	154	}
c1284011	155
385130eb KW	156	last if $base && $different && $comma && $utf8_radix;
	157	}
	158	setlocale(LC_NUMERIC, $original_locale);
903eb63f	159
385130eb KW	160	SKIP: {
	161	skip("no UTF-8 locale available where LC_NUMERIC radix isn't ASCII", 1 )
	162	unless $utf8_radix;
	163	ok($radix_encoded_as_utf8 == 1, "UTF-8 locale '$utf8_radix' with non-ASCII"
	164	. " radix is marked UTF-8");
	165	}
	166
	167	if ($different) {
	168	note("using the '$different' locale for LC_NUMERIC tests");
	169	{
	170	local $ENV{LC_NUMERIC} = $different;
	171
	172	fresh_perl_is(<<'EOF', "4.2", { eval $switches },
	173	format STDOUT =
903eb63f NT	174	@.#
	175	4.179
	176	.
385130eb	177	write;
903eb63f	178	EOF
385130eb	179	"format() does not look at LC_NUMERIC without 'use locale'");
903eb63f	180
385130eb KW	181	{
	182	fresh_perl_is(<<'EOF', "$difference\n", { eval $switches },
	183	use POSIX;
	184	use locale;
	185	format STDOUT =
903eb63f NT	186	@.#
	187	4.179
	188	.
385130eb	189	write;
903eb63f	190	EOF
385130eb KW	191	"format() looks at LC_NUMERIC with 'use locale'");
385130eb KW	192	}
903eb63f	193
385130eb KW	194	{
	195	fresh_perl_is(<<'EOF', ",,", { eval $switches },
	196	use POSIX;
6ec573cf	197	no warnings "utf8";
385130eb KW	198	print localeconv()->{decimal_point};
	199	use locale;
	200	print localeconv()->{decimal_point};
a835cd47	201	EOF
385130eb KW	202	"localeconv() looks at LC_NUMERIC with and without 'use locale'");
385130eb KW	203	}
a835cd47	204
385130eb KW	205	{
	206	my $categories = ":collate :characters :collate :ctype :monetary :time";
	207	fresh_perl_is(<<"EOF", "4.2", { eval $switches },
	208	use locale qw($categories);
	209	format STDOUT =
d6ded950 KW	210	@.#
	211	4.179
	212	.
385130eb	213	write;
d6ded950	214	EOF
385130eb KW	215	"format() does not look at LC_NUMERIC with 'use locale qw($categories)'");
385130eb KW	216	}
d6ded950	217
385130eb KW	218	{
	219	fresh_perl_is(<<'EOF', $difference, { eval $switches },
	220	use locale;
	221	format STDOUT =
d6ded950 KW	222	@.#
	223	4.179
	224	.
385130eb	225	write;
d6ded950	226	EOF
385130eb KW	227	"format() looks at LC_NUMERIC with 'use locale'");
385130eb KW	228	}
d6ded950	229
385130eb KW	230	for my $category (qw(collate characters collate ctype monetary time)) {
	231	for my $negation ("!", "not_") {
	232	fresh_perl_is(<<"EOF", $difference, { eval $switches },
	233	use locale ":$negation$category";
d6ded950 KW	234	format STDOUT =
	235	@.#
	236	4.179
	237	.
385130eb	238	write;
d6ded950	239	EOF
385130eb KW	240	"format() looks at LC_NUMERIC with 'use locale \":"
	241	. "$negation$category\"'");
	242	}
d6ded950	243	}
d6ded950	244
385130eb KW	245	{
	246	fresh_perl_is(<<'EOF', $difference, { eval $switches },
	247	use locale ":numeric";
b34856cb KW	248	format STDOUT =
	249	@.#
	250	4.179
	251	.
385130eb	252	write;
b34856cb	253	EOF
385130eb KW	254	"format() looks at LC_NUMERIC with 'use locale \":numeric\"'");
385130eb KW	255	}
b34856cb	256
385130eb KW	257	{
385130eb KW	258	fresh_perl_is(<<'EOF', "4.2", { eval $switches },
903eb63f NT	259	format STDOUT =
	260	@.#
	261	4.179
	262	.
385130eb	263	{ use locale; write; }
903eb63f	264	EOF
385130eb KW	265	"too late to look at the locale at write() time");
385130eb KW	266	}
903eb63f	267
385130eb KW	268	{
	269	fresh_perl_is(<<'EOF', $difference, { eval $switches },
	270	use locale;
	271	format STDOUT =
903eb63f NT	272	@.#
	273	4.179
	274	.
385130eb	275	{ no locale; write; }
903eb63f	276	EOF
385130eb KW	277	"too late to ignore the locale at write() time");
385130eb KW	278	}
903eb63f	279	}
8d0b139e	280
385130eb KW	281	{
	282	# do not let "use 5.000" affect the locale!
	283	# this test is to prevent regression of [rt.perl.org #105784]
	284	fresh_perl_is(<<"EOF",
	285	use locale;
	286	use POSIX;
	287	my \$i = 0.123;
	288	POSIX::setlocale(POSIX::LC_NUMERIC(),"$different");
	289	\$a = sprintf("%.2f", \$i);
	290	require version;
	291	\$b = sprintf("%.2f", \$i);
6ec573cf	292	no warnings "utf8";
385130eb	293	print ".\$a \$b" unless \$a eq \$b
8d0b139e	294	EOF
385130eb	295	"", { eval $switches }, "version does not clobber version");
8d0b139e	296
385130eb KW	297	fresh_perl_is(<<"EOF",
	298	use locale;
	299	use POSIX;
	300	my \$i = 0.123;
	301	POSIX::setlocale(POSIX::LC_NUMERIC(),"$different");
	302	\$a = sprintf("%.2f", \$i);
	303	eval "use v5.0.0";
	304	\$b = sprintf("%.2f", \$i);
6ec573cf	305	no warnings "utf8";
385130eb	306	print "\$a \$b" unless \$a eq \$b
b3fd6149	307	EOF
385130eb KW	308	"", { eval $switches }, "version does not clobber version (via eval)");
385130eb KW	309	}
02aba72f	310
385130eb KW	311	{
	312	local $ENV{LC_NUMERIC} = $different;
	313	fresh_perl_is(<<'EOF', "$difference "x4, { eval $switches },
	314	use locale;
	315	use POSIX qw(locale_h);
	316	my $in = 4.2;
	317	printf("%g %g %s %s ", $in, 4.2, sprintf("%g", $in), sprintf("%g", 4.2));
481465ea	318	EOF
385130eb KW	319	"sprintf() and printf() look at LC_NUMERIC regardless of constant folding");
385130eb KW	320	}
ff4377fe	321
0ba5b45d	322	{
385130eb KW	323	local $ENV{LC_NUMERIC} = $different;
385130eb KW	324	fresh_perl_is(<<'EOF', "$difference "x4, { eval $switches },
250680e3 DM	325	use locale;
250680e3 DM	326	use POSIX qw(locale_h);
385130eb KW	327	my $in = 4.2;
385130eb KW	328	printf("%g %g %s %s ", $in, 4.2, sprintf("%g", $in), sprintf("%g", 4.2));
65ebb059	329	EOF
385130eb	330	"Uses the above test to verify that on Windows the system default locale has lower priority than LC_NUMERIC");
65ebb059	331	}
65ebb059	332
385130eb KW	333
	334	# within this block, STDERR is closed. This is because fresh_perl_is()
	335	# forks a shell, and some shells (like bash) can complain noisily when
	336	# LC_ALL or similar is set to an invalid value
	337
	338	{
	339	open my $saved_stderr, ">&STDERR" or die "Can't dup STDERR: $!";
	340	close STDERR;
	341
	342	{
68021d02 KW	343	local $ENV{LC_ALL} = "invalid";
68021d02 KW	344	local $ENV{LC_NUMERIC} = "invalid";
385130eb	345	local $ENV{LANG} = $different;
62fe37a7	346	local $ENV{PERL_BADLANG} = 0;
250680e3	347
385130eb	348	if (! fresh_perl_is(<<"EOF", "$difference", { eval $switches },
68021d02	349	if (\$ENV{LC_ALL} ne "invalid") {
385130eb	350	# Make the test pass if the sh didn't accept the ENV set
6ec573cf	351	no warnings "utf8";
68021d02 KW	352	print "$difference\n";
	353	exit 0;
	354	}
	355	use locale;
	356	use POSIX qw(locale_h);
68021d02 KW	357	my \$in = 4.2;
68021d02 KW	358	printf("%g", \$in);
65ebb059	359	EOF
385130eb KW	360	"LANG is used if LC_ALL, LC_NUMERIC are invalid"))
	361	{
	362	note "To see details change this .t, do not close STDERR";
	363	}
65ebb059	364	}
ff4377fe	365
385130eb KW	366	SKIP: {
	367	if ($^O eq 'MSWin32') {
	368	skip("Win32 uses system default locale in preference to \"C\"",
	369	1);
	370	}
	371	else {
	372	local $ENV{LC_ALL} = "invalid";
	373	local $ENV{LC_NUMERIC} = "invalid";
	374	local $ENV{LANG} = "invalid";
	375	local $ENV{PERL_BADLANG} = 0;
	376
	377	if (! fresh_perl_is(<<"EOF", 4.2, { eval $switches },
	378	if (\$ENV{LC_ALL} ne "invalid") {
6ec573cf	379	no warnings "utf8";
385130eb KW	380	print "$difference\n";
	381	exit 0;
	382	}
	383	use locale;
	384	use POSIX qw(locale_h);
	385	my \$in = 4.2;
	386	printf("%g", \$in);
bc8ec7cc	387	EOF
385130eb KW	388	'C locale is used if LC_ALL, LC_NUMERIC, LANG are invalid'))
	389	{
	390	note "To see details change this .t, do not close STDERR";
	391	}
	392	}
	393	}
bc8ec7cc	394
385130eb KW	395	open STDERR, ">&", $saved_stderr or die "Can't dup \$saved_stderr: $!";
385130eb KW	396	}
02aba72f	397
385130eb KW	398	{
	399	local $ENV{LC_NUMERIC} = $different;
	400	fresh_perl_is(<<"EOF",
	401	use POSIX qw(locale_h);
02aba72f	402
385130eb KW	403	BEGIN { setlocale(LC_NUMERIC, \"$different\"); };
	404	setlocale(LC_ALL, "C");
	405	use 5.008;
	406	print setlocale(LC_NUMERIC);
02aba72f	407	EOF
385130eb KW	408	"C", { stderr => 'devnull' },
	409	"No compile error on v-strings when setting the locale to non-dot radix at compile time when default environment has non-dot radix");
	410	}
371d5d44	411
385130eb KW	412	unless ($comma) {
385130eb KW	413	skip("no locale available where LC_NUMERIC is a comma", 3);
371d5d44 KW	414	}
371d5d44 KW	415	else {
385130eb	416
371d5d44	417	fresh_perl_is(<<"EOF",
385130eb KW	418	my \$i = 1.5;
	419	{
	420	use locale;
	421	use POSIX;
	422	POSIX::setlocale(POSIX::LC_NUMERIC(),"$comma");
	423	print \$i, "\n";
	424	}
	425	print \$i, "\n";
371d5d44	426	EOF
385130eb	427	"1,5\n1.5", { stderr => 'devnull' }, "Radix print properly in locale scope, and without");
02aba72f	428
385130eb KW	429	fresh_perl_is(<<"EOF",
	430	my \$i = 1.5; # Should be exactly representable as a base 2
	431	# fraction, so can use 'eq' below
ee48a02a KW	432	use locale;
ee48a02a KW	433	use POSIX;
385130eb KW	434	POSIX::setlocale(POSIX::LC_NUMERIC(),"$comma");
	435	print \$i, "\n";
	436	\$i += 1;
	437	print \$i, "\n";
ee48a02a	438	EOF
385130eb	439	"1,5\n2,5", { stderr => 'devnull' }, "Can do math when radix is a comma"); # [perl 115800]
ee48a02a	440
c4fe5c4d	441	SKIP: {
385130eb KW	442	unless ($have_strtod) {
	443	skip("no strtod()", 1);
	444	}
	445	else {
	446	fresh_perl_is(<<"EOF",
	447	use POSIX;
	448	POSIX::setlocale(POSIX::LC_NUMERIC(),"$comma");
	449	my \$one_point_5 = POSIX::strtod("1,5");
	450	\$one_point_5 =~ s/0+\$//; # Remove any trailing zeros
	451	print \$one_point_5, "\n";
6e79ab66	452	EOF
385130eb KW	453	"1.5", { stderr => 'devnull' }, "POSIX::strtod() uses underlying locale");
385130eb KW	454	}
c4fe5c4d	455	}
385130eb	456	}
6e79ab66 KW	457	}
6e79ab66 KW	458
385130eb KW	459	{
385130eb KW	460	my @valid_categories = valid_locale_categories();
0945d175	461
385130eb KW	462	my $valid_string = "";
385130eb KW	463	my $invalid_string = "";
0945d175	464
385130eb KW	465	# Deliberately don't include all categories, so as to test this situation
	466	for my $i (0 .. @valid_categories - 2) {
	467	my $category = $valid_categories[$i];
	468	if ($category ne "LC_ALL") {
	469	$invalid_string .= ";" if $invalid_string ne "";
	470	$invalid_string .= "$category=foo_BAR";
0945d175	471
385130eb KW	472	next unless $non_C_locale;
	473	$valid_string .= ";" if $valid_string ne "";
	474	$valid_string .= "$category=$non_C_locale";
	475	}
0945d175	476	}
bee74f4b	477
385130eb KW	478	fresh_perl(<<"EOF",
	479	use locale;
	480	use POSIX;
	481	POSIX::setlocale(LC_ALL, "$invalid_string");
0945d175	482	EOF
385130eb KW	483	{});
385130eb KW	484	is ($?, 0, "In setting complicated invalid LC_ALL, final individ category doesn't need a \';'");
0945d175	485
385130eb KW	486	skip("no non-C locale available", 1 ) unless $non_C_locale;
	487	fresh_perl(<<"EOF",
	488	use locale;
	489	use POSIX;
	490	POSIX::setlocale(LC_ALL, "$valid_string");
0945d175	491	EOF
385130eb KW	492	{});
	493	is ($?, 0, "In setting complicated valid LC_ALL, final individ category doesn't need a \';'");
	494
	495	}
0945d175 KW	496
	497	}
	498
385130eb	499	done_testing();