Enable perl core tests to pass when the vendor has no locale support

p5pRT commented 11 years ago

Migrated from rt.perl.org#116693 (status was 'resolved')

Searchable as RT116693$

p5pRT commented 11 years ago

From castaway@desert-island.me.uk

Created by castaway@desert-island.me.uk

Please find attached a patch which allows Perl's core tests to pass/skip
on systems which do not implement the "locale" system\, as expected by "use
locale" and "use POSIX ':local_h'". The patch also makes "use locale" die
if $Config{d_setlocale} is not true.

This is the case with Android\, which I am targetting in my cross-compiler
grant. (It uses ICU instead\, adding support for that is left as a later
exercise!)

Perl Info

``` Flags: category=core severity=low Site configuration information for perl 5.17.8: Configured by castaway at Fri Feb 8 12:40:58 GMT 2013. Summary of my perl5 (revision 5 version 17 subversion 8) configuration: Derived from: 1999188643dea06da9c3a6a24085bd91bb0aa7f9 Platform: osname=linux, osvers=3.0.4insel, archname=i686-linux uname='linux insel 3.0.4insel #1 smp sat oct 29 23:51:24 bst 2011 i686 amd athlon(tm) ii x2 4400e processor authenticamd gnulinux ' config_args='-des -Dusedevel -Dd_setlocale=undef -Dd_locconv=undef -Dd_setlocale_r=undef -Di_locale=undef' hint=recommended, useposix=true, d_sigaction=define useithreads=undef, usemultiplicity=undef useperlio=define, d_sfio=undef, uselargefiles=define, usesocks=undef use64bitint=undef, use64bitall=undef, uselongdouble=undef usemymalloc=n, bincompat5005=undef Compiler: cc='cc', ccflags ='-fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64', optimize='-O2', cppflags='-fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include' ccversion='', gccversion='4.5.4', gccosandvers='' intsize=4, longsize=4, ptrsize=4, doublesize=8, byteorder=1234 d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=12 ivtype='long', ivsize=4, nvtype='double', nvsize=8, Off_t='off_t', lseeksize=8 alignbytes=4, prototype=define Linker and Libraries: ld='cc', ldflags =' -fstack-protector -L/usr/local/lib' libpth=/usr/local/lib /lib/../lib /usr/lib/../lib /lib /usr/lib libs=-lnsl -lndbm -lgdbm -ldb -ldl -lm -lcrypt -lutil -lc -lgdbm_compat perllibs=-lnsl -ldl -lm -lcrypt -lutil -lc libc=/lib/libc-2.11.2.so, so=so, useshrplib=false, libperl=libperl.a gnulibc_version='2.11.2' Dynamic Linking: dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags='-Wl,-E' cccdlflags='-fPIC', lddlflags='-shared -O2 -L/usr/local/lib -fstack-protector' Locally applied patches: @INC for perl 5.17.8: lib /home/castaway/perl/lib /home/theorb/perl/lib /usr/local/lib/perl5/site_perl/5.17.8/i686-linux /usr/local/lib/perl5/site_perl/5.17.8 /usr/local/lib/perl5/5.17.8/i686-linux /usr/local/lib/perl5/5.17.8 /usr/local/lib/perl5/site_perl . Environment for perl 5.17.8: HOME=/home/castaway LANG=en_GB.UTF-8 LANGUAGE (unset) LD_LIBRARY_PATH=/home/missys/sqllib/lib LOGDIR (unset) PATH=/usr/local/bin:/usr/bin:/bin:/opt/bin:/usr/i686-pc-linux-gnu/gcc-bin/4.5.4:/usr/i686-pc-linux-gnu/armv6j-hardfloat-linux-gnueabi/gcc-bin/4.5.4:/usr/i686-pc-linux-gnu/avr/gcc-bin/4.3.4:/opt/sun-jdk-1.4.2.18/bin:/opt/sun-jdk-1.4.2.18/jre/bin:/opt/sun-jdk-1.4.2.18/jre/javaws:/usr/qt/3/bin:/usr/kde/3.4/bin:/usr/games/bin:/home/missys/sqllib/bin:/home/missys/sqllib/adm:/home/missys/sqllib/misc PERL5LIB=/home/castaway/perl/lib:/home/theorb/perl/lib PERL_AUTOINSTALL_PREFER_CPAN=1 PERL_BADLANG (unset) SHELL=/bin/bash ```

p5pRT commented 11 years ago

From castaway@desert-island.me.uk

0001-Enable-perl-core-tests-to-pass-when-locale-support-i.patch

```diff From 1999188643dea06da9c3a6a24085bd91bb0aa7f9 Mon Sep 17 00:00:00 2001 From: Jess Robinson Date: Fri, 8 Feb 2013 12:30:05 +0000 Subject: [PATCH] Enable perl core tests to pass when locale support is not available. use locale - this will now die if $Config{d_setlocale} is not true. All tests that use locale will skip if $Config{d_setlocale} is not true. This enables us to pass tests on Android which uses ICU instead of locales. --- ext/Pod-Html/lib/Pod/Html.pm | 9 +- ext/XS-APItest/t/handy.t | 36 +++-- ext/re/t/re_funcs_u.t | 2 + ext/re/t/reflags.t | 6 +- lib/locale.pm | 17 ++- lib/version/t/07locale.t | 2 + t/op/quotemeta.t | 14 ++- t/op/taint.t | 410 +++++++++++++++++++++++++++--------------- t/re/charset.t | 5 +- t/re/fold_grind.t | 25 ++-- t/re/pat.t | 47 ++++- t/run/locale.t | 19 ++- t/uni/fold.t | 10 +- t/uni/overload.t | 13 +- 14 files changed, 421 insertions(+), 194 deletions(-) diff --git a/ext/Pod-Html/lib/Pod/Html.pm b/ext/Pod-Html/lib/Pod/Html.pm index 5b4c51c..72b37c2 100644 --- a/ext/Pod-Html/lib/Pod/Html.pm +++ b/ext/Pod-Html/lib/Pod/Html.pm @@ -3,7 +3,7 @@ use strict; require Exporter; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); -$VERSION = 1.17; +$VERSION = 1.18; @ISA = qw(Exporter); @EXPORT = qw(pod2html htmlify); @EXPORT_OK = qw(anchorify); @@ -16,8 +16,11 @@ use File::Spec; use File::Spec::Unix; use Getopt::Long; use Pod::Simple::Search; - -use locale; # make \w work right in non-ASCII lands +BEGIN { + if($Config{d_setlocale}) { + require locale; import locale; # make \w work right in non-ASCII lands + } +} =head1 NAME diff --git a/ext/XS-APItest/t/handy.t b/ext/XS-APItest/t/handy.t index 5ecbaa7..eb620ec 100644 --- a/ext/XS-APItest/t/handy.t +++ b/ext/XS-APItest/t/handy.t @@ -2,6 +2,7 @@ use strict; use Test::More; +use Config; use XS::APItest; @@ -11,17 +12,24 @@ sub truth($) { # Converts values so is() works return (shift) ? 1 : 0; } -require POSIX; -my $locale = POSIX::setlocale( &POSIX::LC_ALL, "C"); -if (defined $locale && $locale eq 'C') { - use locale; - - # Some locale implementations don't have the 128-255 characters all - # mean nothing. Skip the locale tests in that situation - for my $i (128 .. 255) { - if (chr($i) =~ /[[:print:]]/) { - undef $locale; - last; +my $locale; +if($Config{d_setlocale}) { + require POSIX; + $locale = POSIX::setlocale( &POSIX::LC_ALL, "C"); + if (defined $locale && $locale eq 'C') { + BEGIN { + if($Config{d_setlocale}) { + require locale; import locale; # make \w work right in non-ASCII lands + } + } + + # Some locale implementations don't have the 128-255 characters all + # mean nothing. Skip the locale tests in that situation + for my $i (128 .. 255) { + if (chr($i) =~ /[[:print:]]/) { + undef $locale; + last; + } } } } @@ -138,7 +146,7 @@ foreach my $name (sort keys %properties) { } if (defined $locale) { - use locale; + require locale; import locale; $ret = truth eval "test_is${function}_LC($i)"; if ($@) { @@ -160,7 +168,7 @@ foreach my $name (sort keys %properties) { } if (defined $locale && $name ne 'vertws') { - use locale; + require locale; import locale; $ret = truth eval "test_is${function}_LC_uvchr('$i')"; if ($@) { @@ -184,7 +192,7 @@ foreach my $name (sort keys %properties) { } if ($name ne 'vertws' && defined $locale) { - use locale; + require locale; import locale; $ret = truth eval "test_is${function}_LC_utf8('$char')"; if ($@) { diff --git a/ext/re/t/re_funcs_u.t b/ext/re/t/re_funcs_u.t index 3eec289..706437e 100644 --- a/ext/re/t/re_funcs_u.t +++ b/ext/re/t/re_funcs_u.t @@ -92,6 +92,7 @@ if ('1234'=~/(?:(?\d)|(?!))(?\d)(?\d)(?\d)/){ SKIP: { skip_if_miniperl("no dynamic loading on miniperl, no POSIX", 3); + skip 'No locale testing without d_setlocale', 3 if(!$Config::Config{d_setlocale}); require POSIX; my $current_locale = POSIX::setlocale( &POSIX::LC_CTYPE, 'de_DE.ISO-8859-1' ); if ( !$current_locale || $current_locale ne 'de_DE.ISO-8859-1' ) { @@ -108,6 +109,7 @@ if ('1234'=~/(?:(?\d)|(?!))(?\d)(?\d)(?\d)/){ SKIP: { skip_if_miniperl("no dynamic loading on miniperl, no POSIX", 3); + skip 'No locale testing without d_setlocale', 3 if(!$Config::Config{d_setlocale}); require POSIX; my $current_locale = POSIX::setlocale( &POSIX::LC_CTYPE, 'C' ); if ( !$current_locale || $current_locale ne 'C' ) { diff --git a/ext/re/t/reflags.t b/ext/re/t/reflags.t index b2cbf80..482b2c8 100644 --- a/ext/re/t/reflags.t +++ b/ext/re/t/reflags.t @@ -60,7 +60,11 @@ SKIP: { ) { skip "no locale support", 7 } - use locale; + BEGIN { + if($Config::Config{d_setlocale}) { + require locale; import locale; + } + } use re '/u'; is qr//, '(?^u:)', 'use re "/u" with active locale'; no re '/u'; diff --git a/lib/locale.pm b/lib/locale.pm index e57a5fd..ed254cc 100644 --- a/lib/locale.pm +++ b/lib/locale.pm @@ -1,6 +1,7 @@ package locale; -our $VERSION = '1.01'; +our $VERSION = '1.02'; +use Config; $Carp::Internal{ (__PACKAGE__) } = 1; @@ -46,6 +47,14 @@ Unicode and locales, including UTF-8 locales. See L for more detailed information on how Perl supports locales. +=head1 NOTE + +If your system does not support locales, then loading this module will +cause the program to die with a message: + + "Your vendor does not support locales, you cannot use the locale + module." + =cut # A separate bit is used for each of the two forms of the pragma, as they are @@ -60,6 +69,12 @@ $locale::not_chars_hint_bits = 0x10; sub import { shift; # should be 'locale'; not checked + + if(!$Config{d_setlocale}) { + ## No locale support found on this Perl, giving up: + die('Your vendor does not support locales, you cannot use the locale module.'); + } + my $found_not_chars = 0; while (defined (my $arg = shift)) { if ($arg eq ":not_characters") { diff --git a/lib/version/t/07locale.t b/lib/version/t/07locale.t index 01b51a7..a2005f8 100644 --- a/lib/version/t/07locale.t +++ b/lib/version/t/07locale.t @@ -8,6 +8,7 @@ use File::Basename; use File::Temp qw/tempfile/; use POSIX qw/locale_h/; use Test::More tests => 7; +use Config; BEGIN { use_ok('version', 0.9901); @@ -15,6 +16,7 @@ BEGIN { SKIP: { skip 'No locale testing for Perl < 5.6.0', 6 if $] < 5.006; + skip 'No locale testing without d_setlocale', 6 if(!$Config{d_setlocale}); # test locale handling my $warning; local $SIG{__WARN__} = sub { $warning = $_[0] }; diff --git a/t/op/quotemeta.t b/t/op/quotemeta.t index d62563c..1b8613a 100644 --- a/t/op/quotemeta.t +++ b/t/op/quotemeta.t @@ -76,7 +76,9 @@ is(length(quotemeta($char)), 1, "quotemeta '\\N{U+D8}' in UTF-8 length"); is(quotemeta("\x{d8}"), "\\\x{d8}", "quotemeta Latin1 no unicode_strings quoted"); is(length(quotemeta("\x{d8}")), 2, "quotemeta Latin1 no unicode_strings quoted length"); - use locale; + SKIP: { + skip 'No locale testing without d_setlocale', 8 if(!$Config{d_setlocale}); + require locale; import locale; my $char = ":"; is(quotemeta($char), "\\$char", "quotemeta '$char' locale"); @@ -94,6 +96,7 @@ is(length(quotemeta($char)), 1, "quotemeta '\\N{U+D8}' in UTF-8 length"); $char = "\x{D8}"; # Every non-ASCII Latin1 is quoted in locale. is(quotemeta($char), "\\$char", "quotemeta '\\x{D8}' locale"); is(length(quotemeta($char)), 2, "quotemeta '\\x{D8}' locale length"); + } } { use feature 'unicode_strings'; @@ -102,7 +105,13 @@ is(length(quotemeta($char)), 1, "quotemeta '\\N{U+D8}' in UTF-8 length"); is(quotemeta("\x{d8}"), "\x{d8}", "quotemeta Latin1 unicode_strings nonquoted"); is(length(quotemeta("\x{d8}")), 1, "quotemeta Latin1 unicode_strings nonquoted length"); - use locale; + SKIP: { + skip 'No locale testing without d_setlocale', 12 if(!$Config{d_setlocale}); + BEGIN { + if($Config{d_setlocale}) { + require locale; import locale; + } + } my $char = ":"; utf8::upgrade($char); @@ -128,6 +137,7 @@ is(length(quotemeta($char)), 1, "quotemeta '\\N{U+D8}' in UTF-8 length"); is(length(quotemeta("\x{263a}")), 2, "quotemeta locale Unicode quoted length"); is(quotemeta("\x{100}"), "\x{100}", "quotemeta locale Unicode nonquoted"); is(length(quotemeta("\x{100}")), 1, "quotemeta locale Unicode nonquoted length"); + } } $a = "foo|bar"; diff --git a/t/op/taint.t b/t/op/taint.t index d621de6..268157f 100644 --- a/t/op/taint.t +++ b/t/op/taint.t @@ -296,25 +296,43 @@ my $TEST = 'TEST'; is($res, 1, "$desc: res value"); is($one, 'a', "$desc: \$1 value"); - $desc = "match with pattern tainted via locale"; - - $s = 'abcd'; - { use locale; $res = $s =~ /(\w+)/; $one = $1; } - isnt_tainted($s, "$desc: s not tainted"); - isnt_tainted($res, "$desc: res not tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($res, 1, "$desc: res value"); - is($one, 'abcd', "$desc: \$1 value"); - - $desc = "match /g with pattern tainted via locale"; - - $s = 'abcd'; - { use locale; $res = $s =~ /(\w)/g; $one = $1; } - isnt_tainted($s, "$desc: s not tainted"); - isnt_tainted($res, "$desc: res not tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($res, 1, "$desc: res value"); - is($one, 'a', "$desc: \$1 value"); + SKIP: { + skip 'No locale testing without d_setlocale', 10 if(!$Config{d_setlocale}); + + $desc = "match with pattern tainted via locale"; + + $s = 'abcd'; + { + BEGIN { + if($Config{d_setlocale}) { + require locale; import locale; + } + } + $res = $s =~ /(\w+)/; $one = $1; + } + isnt_tainted($s, "$desc: s not tainted"); + isnt_tainted($res, "$desc: res not tainted"); + is_tainted($one, "$desc: \$1 tainted"); + is($res, 1, "$desc: res value"); + is($one, 'abcd', "$desc: \$1 value"); + + $desc = "match /g with pattern tainted via locale"; + + $s = 'abcd'; + { + BEGIN { + if($Config{d_setlocale}) { + require locale; import locale; + } + } + $res = $s =~ /(\w)/g; $one = $1; + } + isnt_tainted($s, "$desc: s not tainted"); + isnt_tainted($res, "$desc: res not tainted"); + is_tainted($one, "$desc: \$1 tainted"); + is($res, 1, "$desc: res value"); + is($one, 'a', "$desc: \$1 value"); + } $desc = "match with pattern tainted, list cxt"; @@ -339,27 +357,45 @@ my $TEST = 'TEST'; is($res2,'b', "$desc: res2 value"); is($one, 'd', "$desc: \$1 value"); - $desc = "match with pattern tainted via locale, list cxt"; - - $s = 'abcd'; - { use locale; ($res) = $s =~ /(\w+)/; $one = $1; } - isnt_tainted($s, "$desc: s not tainted"); - is_tainted($res, "$desc: res tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($res, 'abcd', "$desc: res value"); - is($one, 'abcd', "$desc: \$1 value"); - - $desc = "match /g with pattern tainted via locale, list cxt"; + SKIP: { + skip 'No locale testing without d_setlocale', 12 if(!$Config{d_setlocale}); - $s = 'abcd'; - { use locale; ($res, $res2) = $s =~ /(\w)/g; $one = $1; } - isnt_tainted($s, "$desc: s not tainted"); - is_tainted($res, "$desc: res tainted"); - is_tainted($res2, "$desc: res2 tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($res, 'a', "$desc: res value"); - is($res2,'b', "$desc: res2 value"); - is($one, 'd', "$desc: \$1 value"); + $desc = "match with pattern tainted via locale, list cxt"; + + $s = 'abcd'; + { + BEGIN { + if($Config{d_setlocale}) { + require locale; import locale; + } + } + ($res) = $s =~ /(\w+)/; $one = $1; + } + isnt_tainted($s, "$desc: s not tainted"); + is_tainted($res, "$desc: res tainted"); + is_tainted($one, "$desc: \$1 tainted"); + is($res, 'abcd', "$desc: res value"); + is($one, 'abcd', "$desc: \$1 value"); + + $desc = "match /g with pattern tainted via locale, list cxt"; + + $s = 'abcd'; + { + BEGIN { + if($Config{d_setlocale}) { + require locale; import locale; + } + } + ($res, $res2) = $s =~ /(\w)/g; $one = $1; + } + isnt_tainted($s, "$desc: s not tainted"); + is_tainted($res, "$desc: res tainted"); + is_tainted($res2, "$desc: res2 tainted"); + is_tainted($one, "$desc: \$1 tainted"); + is($res, 'a', "$desc: res value"); + is($res2,'b', "$desc: res2 value"); + is($one, 'd', "$desc: \$1 value"); + } $desc = "substitution with string tainted"; @@ -481,38 +517,63 @@ my $TEST = 'TEST'; is($res, 'xyz', "$desc: res value"); is($one, 'abcd', "$desc: \$1 value"); - $desc = "substitution with pattern tainted via locale"; - - $s = 'abcd'; - { use locale; $res = $s =~ s/(\w+)/xyz/; $one = $1; } - is_tainted($s, "$desc: s tainted"); - isnt_tainted($res, "$desc: res not tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($s, 'xyz', "$desc: s value"); - is($res, 1, "$desc: res value"); - is($one, 'abcd', "$desc: \$1 value"); - - $desc = "substitution /g with pattern tainted via locale"; - - $s = 'abcd'; - { use locale; $res = $s =~ s/(\w)/x/g; $one = $1; } - is_tainted($s, "$desc: s tainted"); - is_tainted($res, "$desc: res tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($s, 'xxxx', "$desc: s value"); - is($res, 4, "$desc: res value"); - is($one, 'd', "$desc: \$1 value"); - - $desc = "substitution /r with pattern tainted via locale"; + SKIP: { + skip 'No locale testing without d_setlocale', 18 if(!$Config{d_setlocale}); - $s = 'abcd'; - { use locale; $res = $s =~ s/(\w+)/xyz/r; $one = $1; } - isnt_tainted($s, "$desc: s not tainted"); - is_tainted($res, "$desc: res tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($s, 'abcd', "$desc: s value"); - is($res, 'xyz', "$desc: res value"); - is($one, 'abcd', "$desc: \$1 value"); + $desc = "substitution with pattern tainted via locale"; + + $s = 'abcd'; + { + BEGIN { + if($Config{d_setlocale}) { + require locale; import locale; + } + } + $res = $s =~ s/(\w+)/xyz/; $one = $1; + } + is_tainted($s, "$desc: s tainted"); + isnt_tainted($res, "$desc: res not tainted"); + is_tainted($one, "$desc: \$1 tainted"); + is($s, 'xyz', "$desc: s value"); + is($res, 1, "$desc: res value"); + is($one, 'abcd', "$desc: \$1 value"); + + $desc = "substitution /g with pattern tainted via locale"; + + $s = 'abcd'; + { + BEGIN { + if($Config{d_setlocale}) { + require locale; import locale; + } + } + $res = $s =~ s/(\w)/x/g; $one = $1; + } + is_tainted($s, "$desc: s tainted"); + is_tainted($res, "$desc: res tainted"); + is_tainted($one, "$desc: \$1 tainted"); + is($s, 'xxxx', "$desc: s value"); + is($res, 4, "$desc: res value"); + is($one, 'd', "$desc: \$1 value"); + + $desc = "substitution /r with pattern tainted via locale"; + + $s = 'abcd'; + { + BEGIN { + if($Config{d_setlocale}) { + require locale; import locale; + } + } + $res = $s =~ s/(\w+)/xyz/r; $one = $1; + } + isnt_tainted($s, "$desc: s not tainted"); + is_tainted($res, "$desc: res tainted"); + is_tainted($one, "$desc: \$1 tainted"); + is($s, 'abcd', "$desc: s value"); + is($res, 'xyz', "$desc: res value"); + is($one, 'abcd', "$desc: \$1 value"); + } $desc = "substitution with replacement tainted"; @@ -652,25 +713,43 @@ my $TEST = 'TEST'; is($res, 1, "$desc: res value"); is($one, 'a', "$desc: \$1 value"); - $desc = "use re 'taint': match with pattern tainted via locale"; - - $s = 'abcd'; - { use locale; $res = $s =~ /(\w+)/; $one = $1; } - isnt_tainted($s, "$desc: s not tainted"); - isnt_tainted($res, "$desc: res not tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($res, 1, "$desc: res value"); - is($one, 'abcd', "$desc: \$1 value"); - - $desc = "use re 'taint': match /g with pattern tainted via locale"; + SKIP: { + skip 'No locale testing without d_setlocale', 10 if(!$Config{d_setlocale}); - $s = 'abcd'; - { use locale; $res = $s =~ /(\w)/g; $one = $1; } - isnt_tainted($s, "$desc: s not tainted"); - isnt_tainted($res, "$desc: res not tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($res, 1, "$desc: res value"); - is($one, 'a', "$desc: \$1 value"); + $desc = "use re 'taint': match with pattern tainted via locale"; + + $s = 'abcd'; + { + BEGIN { + if($Config{d_setlocale}) { + require locale; import locale; + } + } + $res = $s =~ /(\w+)/; $one = $1; + } + isnt_tainted($s, "$desc: s not tainted"); + isnt_tainted($res, "$desc: res not tainted"); + is_tainted($one, "$desc: \$1 tainted"); + is($res, 1, "$desc: res value"); + is($one, 'abcd', "$desc: \$1 value"); + + $desc = "use re 'taint': match /g with pattern tainted via locale"; + + $s = 'abcd'; + { + BEGIN { + if($Config{d_setlocale}) { + require locale; import locale; + } + } + $res = $s =~ /(\w)/g; $one = $1; + } + isnt_tainted($s, "$desc: s not tainted"); + isnt_tainted($res, "$desc: res not tainted"); + is_tainted($one, "$desc: \$1 tainted"); + is($res, 1, "$desc: res value"); + is($one, 'a', "$desc: \$1 value"); + } $desc = "use re 'taint': match with pattern tainted, list cxt"; @@ -695,27 +774,45 @@ my $TEST = 'TEST'; is($res2,'b', "$desc: res2 value"); is($one, 'd', "$desc: \$1 value"); - $desc = "use re 'taint': match with pattern tainted via locale, list cxt"; + SKIP: { + skip 'No locale testing without d_setlocale', 12 if(!$Config{d_setlocale}); - $s = 'abcd'; - { use locale; ($res) = $s =~ /(\w+)/; $one = $1; } - isnt_tainted($s, "$desc: s not tainted"); - is_tainted($res, "$desc: res tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($res, 'abcd', "$desc: res value"); - is($one, 'abcd', "$desc: \$1 value"); - - $desc = "use re 'taint': match /g with pattern tainted via locale, list cxt"; - - $s = 'abcd'; - { use locale; ($res, $res2) = $s =~ /(\w)/g; $one = $1; } - isnt_tainted($s, "$desc: s not tainted"); - is_tainted($res, "$desc: res tainted"); - is_tainted($res2, "$desc: res2 tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($res, 'a', "$desc: res value"); - is($res2,'b', "$desc: res2 value"); - is($one, 'd', "$desc: \$1 value"); + $desc = "use re 'taint': match with pattern tainted via locale, list cxt"; + + $s = 'abcd'; + { + BEGIN { + if($Config{d_setlocale}) { + require locale; import locale; + } + } + ($res) = $s =~ /(\w+)/; $one = $1; + } + isnt_tainted($s, "$desc: s not tainted"); + is_tainted($res, "$desc: res tainted"); + is_tainted($one, "$desc: \$1 tainted"); + is($res, 'abcd', "$desc: res value"); + is($one, 'abcd', "$desc: \$1 value"); + + $desc = "use re 'taint': match /g with pattern tainted via locale, list cxt"; + + $s = 'abcd'; + { + BEGIN { + if($Config{d_setlocale}) { + require locale; import locale; + } + } + ($res, $res2) = $s =~ /(\w)/g; $one = $1; + } + isnt_tainted($s, "$desc: s not tainted"); + is_tainted($res, "$desc: res tainted"); + is_tainted($res2, "$desc: res2 tainted"); + is_tainted($one, "$desc: \$1 tainted"); + is($res, 'a', "$desc: res value"); + is($res2,'b', "$desc: res2 value"); + is($one, 'd', "$desc: \$1 value"); + } $desc = "use re 'taint': substitution with string tainted"; @@ -838,38 +935,63 @@ my $TEST = 'TEST'; is($res, 'xyz', "$desc: res value"); is($one, 'abcd', "$desc: \$1 value"); - $desc = "use re 'taint': substitution with pattern tainted via locale"; + SKIP: { + skip 'No locale testing without d_setlocale', 18 if(!$Config{d_setlocale}); - $s = 'abcd'; - { use locale; $res = $s =~ s/(\w+)/xyz/; $one = $1; } - is_tainted($s, "$desc: s tainted"); - isnt_tainted($res, "$desc: res not tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($s, 'xyz', "$desc: s value"); - is($res, 1, "$desc: res value"); - is($one, 'abcd', "$desc: \$1 value"); - - $desc = "use re 'taint': substitution /g with pattern tainted via locale"; - - $s = 'abcd'; - { use locale; $res = $s =~ s/(\w)/x/g; $one = $1; } - is_tainted($s, "$desc: s tainted"); - is_tainted($res, "$desc: res tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($s, 'xxxx', "$desc: s value"); - is($res, 4, "$desc: res value"); - is($one, 'd', "$desc: \$1 value"); - - $desc = "use re 'taint': substitution /r with pattern tainted via locale"; - - $s = 'abcd'; - { use locale; $res = $s =~ s/(\w+)/xyz/r; $one = $1; } - isnt_tainted($s, "$desc: s not tainted"); - is_tainted($res, "$desc: res tainted"); - is_tainted($one, "$desc: \$1 tainted"); - is($s, 'abcd', "$desc: s value"); - is($res, 'xyz', "$desc: res value"); - is($one, 'abcd', "$desc: \$1 value"); + $desc = "use re 'taint': substitution with pattern tainted via locale"; + + $s = 'abcd'; + { + BEGIN { + if($Config{d_setlocale}) { + require locale; import locale; + } + } + $res = $s =~ s/(\w+)/xyz/; $one = $1; + } + is_tainted($s, "$desc: s tainted"); + isnt_tainted($res, "$desc: res not tainted"); + is_tainted($one, "$desc: \$1 tainted"); + is($s, 'xyz', "$desc: s value"); + is($res, 1, "$desc: res value"); + is($one, 'abcd', "$desc: \$1 value"); + + $desc = "use re 'taint': substitution /g with pattern tainted via locale"; + + $s = 'abcd'; + { + BEGIN { + if($Config{d_setlocale}) { + require locale; import locale; + } + } + $res = $s =~ s/(\w)/x/g; $one = $1; + } + is_tainted($s, "$desc: s tainted"); + is_tainted($res, "$desc: res tainted"); + is_tainted($one, "$desc: \$1 tainted"); + is($s, 'xxxx', "$desc: s value"); + is($res, 4, "$desc: res value"); + is($one, 'd', "$desc: \$1 value"); + + $desc = "use re 'taint': substitution /r with pattern tainted via locale"; + + $s = 'abcd'; + { + BEGIN { + if($Config{d_setlocale}) { + require locale; import locale; + } + } + $res = $s =~ s/(\w+)/xyz/r; $one = $1; + } + isnt_tainted($s, "$desc: s not tainted"); + is_tainted($res, "$desc: res tainted"); + is_tainted($one, "$desc: \$1 tainted"); + is($s, 'abcd', "$desc: s value"); + is($res, 'xyz', "$desc: res value"); + is($one, 'abcd', "$desc: \$1 value"); + } $desc = "use re 'taint': substitution with replacement tainted"; @@ -2188,9 +2310,15 @@ pass("no death when TARG of ref is tainted"); isnt_tainted $$, "PID not tainted when read in tainted expression"; } -{ +SKIP: { + skip 'No locale testing without d_setlocale', 4 if(!$Config{d_setlocale}); + use feature 'fc'; - use locale; + BEGIN { + if($Config{d_setlocale}) { + require locale; import locale; + } + } my ($latin1, $utf8) = ("\xDF") x 2; utf8::downgrade($latin1); utf8::upgrade($utf8); diff --git a/t/re/charset.t b/t/re/charset.t index 8d98125..ee3625a 100644 --- a/t/re/charset.t +++ b/t/re/charset.t @@ -3,6 +3,7 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; + require Config; import Config; require './test.pl'; } @@ -35,11 +36,11 @@ $testcases{'[:space:]'} = $testcases{'\s'}; $testcases{'[:word:]'} = $testcases{'\w'}; my @charsets = qw(a d u aa); -if (! is_miniperl()) { +if (! is_miniperl() && $Config{d_setlocale}) { require POSIX; my $current_locale = POSIX::setlocale( &POSIX::LC_ALL, "C") // ""; if ($current_locale eq 'C') { - use locale; + require locale; import locale; # Some locale implementations don't have the 128-255 characters all # mean nothing. Skip the locale tests in that situation diff --git a/t/re/fold_grind.t b/t/re/fold_grind.t index 4e13110..d073498 100644 --- a/t/re/fold_grind.t +++ b/t/re/fold_grind.t @@ -6,6 +6,7 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; + require Config; import Config; skip_all_if_miniperl("no dynamic loading on miniperl, no Encode nor POSIX"); } @@ -405,18 +406,20 @@ sub pairs (@) { } my @charsets = qw(d u a aa); -my $current_locale = POSIX::setlocale( &POSIX::LC_ALL, "C") // ""; -if ($current_locale eq 'C') { - use locale; - - # Some locale implementations don't have the range 128-255 characters all - # mean nothing. Skip the locale tests in that situation. - for my $i (128 .. 255) { - my $char = chr($i); - goto bad_locale if uc($char) ne $char || lc($char) ne $char; +if($Config{d_setlocale}) { + my $current_locale = POSIX::setlocale( &POSIX::LC_ALL, "C") // ""; + if ($current_locale eq 'C') { + require locale; import locale; + + # Some locale implementations don't have the range 128-255 characters all + # mean nothing. Skip the locale tests in that situation. + for my $i (128 .. 255) { + my $char = chr($i); + goto bad_locale if uc($char) ne $char || lc($char) ne $char; + } + push @charsets, 'l'; + bad_locale: } - push @charsets, 'l'; -bad_locale: } # Finally ready to do the tests diff --git a/t/re/pat.t b/t/re/pat.t index 768119f..748705d 100644 --- a/t/re/pat.t +++ b/t/re/pat.t @@ -16,6 +16,7 @@ $| = 1; BEGIN { chdir 't' if -d 't'; @INC = ('../lib','.'); + require Config; import Config; require './test.pl'; } @@ -516,24 +517,52 @@ sub run_tests { is(qr/(?u)\b\v$/, '(?^:(?u)\b\v$)', 'Verify (?u) compiles'); my $dual = qr/\b\v$/; - use locale; - my $locale = qr/\b\v$/; - is($locale, '(?^l:\b\v$)', 'Verify has l modifier when compiled under use locale'); - no locale; + my $locale; + + SKIP: { + skip 'No locale testing without d_setlocale', 1 if(!$Config{d_setlocale}); + + BEGIN { + if($Config{d_setlocale}) { + require locale; import locale; + } + } + $locale = qr/\b\v$/; + is($locale, '(?^l:\b\v$)', 'Verify has l modifier when compiled under use locale'); + no locale; + } use feature 'unicode_strings'; my $unicode = qr/\b\v$/; is($unicode, '(?^u:\b\v$)', 'Verify has u modifier when compiled under unicode_strings'); is(qr/abc$dual/, '(?^u:abc(?^:\b\v$))', 'Verify retains d meaning when interpolated under locale'); - is(qr/abc$locale/, '(?^u:abc(?^l:\b\v$))', 'Verify retains l when interpolated under unicode_strings'); + + SKIP: { + skip 'No locale testing without d_setlocale', 1 if(!$Config{d_setlocale}); + + is(qr/abc$locale/, '(?^u:abc(?^l:\b\v$))', 'Verify retains l when interpolated under unicode_strings'); + } no feature 'unicode_strings'; - is(qr/abc$locale/, '(?^:abc(?^l:\b\v$))', 'Verify retains l when interpolated outside locale and unicode strings'); + SKIP: { + skip 'No locale testing without d_setlocale', 1 if(!$Config{d_setlocale}); + + is(qr/abc$locale/, '(?^:abc(?^l:\b\v$))', 'Verify retains l when interpolated outside locale and unicode strings'); + } + is(qr/def$unicode/, '(?^:def(?^u:\b\v$))', 'Verify retains u when interpolated outside locale and unicode strings'); - use locale; - is(qr/abc$dual/, '(?^l:abc(?^:\b\v$))', 'Verify retains d meaning when interpolated under locale'); - is(qr/abc$unicode/, '(?^l:abc(?^u:\b\v$))', 'Verify retains u when interpolated under locale'); + SKIP: { + skip 'No locale testing without d_setlocale', 2 if(!$Config{d_setlocale}); + + BEGIN { + if($Config{d_setlocale}) { + require locale; import locale; + } + } + is(qr/abc$dual/, '(?^l:abc(?^:\b\v$))', 'Verify retains d meaning when interpolated under locale'); + is(qr/abc$unicode/, '(?^l:abc(?^u:\b\v$))', 'Verify retains u when interpolated under locale'); + } } { diff --git a/t/run/locale.t b/t/run/locale.t index 7bbb0a9..d01e3bc 100644 --- a/t/run/locale.t +++ b/t/run/locale.t @@ -64,7 +64,11 @@ my $original_locale = setlocale(LC_NUMERIC); my ($base, $different, $difference); for ("C", @locales) { # prefer C for the base if available - use locale; + BEGIN { + if($Config{d_setlocale}) { + require locale; import locale; + } + } setlocale(LC_NUMERIC, $_) or next; my $in = 4.2; # avoid any constant folding bugs if ((my $s = sprintf("%g", $in)) eq "4.2") { @@ -113,14 +117,15 @@ format STDOUT = @.# 4.179 . -{ use locale; write; } +{ require locale; import locale; write; } EOF "too late to look at the locale at write() time"); } { fresh_perl_is(<<'EOF', $difference, {}, -use locale; format STDOUT = +use locale; +format STDOUT = @.# 4.179 . @@ -134,7 +139,11 @@ EOF # 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; + BEGIN { + if($Config{d_setlocale}) { + require locale; import locale; + } + } use POSIX; my \$i = 0.123; POSIX::setlocale(POSIX::LC_NUMERIC(),"$different"); @@ -163,7 +172,7 @@ EOF local $ENV{LC_NUMERIC} = $_; local $ENV{LC_ALL}; # so it never overrides LC_NUMERIC fresh_perl_is(<<'EOF', "$difference "x4, {}, - use locale; + use locale; use POSIX qw(locale_h); setlocale(LC_NUMERIC, ""); my $in = 4.2; diff --git a/t/uni/fold.t b/t/uni/fold.t index 4c0ef7d..91356bb 100644 --- a/t/uni/fold.t +++ b/t/uni/fold.t @@ -7,6 +7,7 @@ use warnings; BEGIN { chdir 't' if -d 't'; @INC = '../lib'; + require Config; import Config; require './test.pl'; } @@ -426,8 +427,13 @@ foreach my $test_ref (@CF) { utf8::downgrade($latin1); #No-op, but doesn't hurt utf8::upgrade($utf8); is(fc($latin1), fc($utf8), "fc() gives the same results for \\x{$_} in Latin-1 and UTF-8 under unicode_strings"); - { - use locale; + SKIP: { + skip 'No locale testing without d_setlocale', 2 if(!$Config{d_setlocale}); + BEGIN { + if($Config{d_setlocale}) { + require locale; import locale; + } + } is(fc($latin1), lc($latin1), "use locale; fc(qq{\\x{$_}}), lc(qq{\\x{$_}}) when qq{\\x{$_}} is in latin-1"); is(fc($utf8), lc($utf8), "use locale; fc(qq{\\x{$_}}), lc(qq{\\x{$_}}) when qq{\\x{$_}} is in latin-1"); } diff --git a/t/uni/overload.t b/t/uni/overload.t index 7bf4841..bd87b66 100644 --- a/t/uni/overload.t +++ b/t/uni/overload.t @@ -3,6 +3,7 @@ BEGIN { chdir 't'; @INC = '../lib'; + require Config; import Config; require './test.pl'; } @@ -95,8 +96,10 @@ is ($uc, "\351", "e acute -> E acute"); my $have_setlocale = 0; eval { require POSIX; - import POSIX ':locale_h'; - $have_setlocale++; + if($Config{d_setlocale}) { + import POSIX ':locale_h'; + $have_setlocale++; + } }; SKIP: { @@ -107,7 +110,11 @@ SKIP: { } elsif ($^O eq 'dec_osf' || $^O eq 'VMS') { skip "$^O has broken en_GB.ISO8859-1 locale", 24; } else { - use locale; + BEGIN { + if($Config{d_setlocale}) { + require locale; import locale; + } + } my $u = UTF8Toggle->new("\311"); my $lc = lc $u; is (length $lc, 1); -- 1.7.8.6 ```

Perl / perl5