1#!./perl 2 3# These tests are in a separate file, because they use fresh_perl_is() 4# from test.pl. 5 6# The mb* functions use the "underlying locale" that is not affected by 7# the Perl one. So we run the tests in a separate "fresh_perl" process 8# with the correct LC_CTYPE set in the environment. 9 10BEGIN { 11 require Config; import Config; 12 if ($^O ne 'VMS' and $Config{'extensions'} !~ /\bPOSIX\b/) { 13 print "1..0\n"; 14 exit 0; 15 } 16 unshift @INC, "../../t"; 17 require 'loc_tools.pl'; 18 require 'charset_tools.pl'; 19 require 'test.pl'; 20} 21 22my $utf8_locale = find_utf8_ctype_locale(); 23 24plan tests => 13; 25 26use POSIX qw(); 27 28SKIP: { 29 skip("mblen() not present", 7) unless $Config{d_mblen}; 30 31 is(&POSIX::mblen("a", &POSIX::MB_CUR_MAX), 1, 'mblen() works on ASCII input'); 32 is(&POSIX::mblen("b"), 1, '... and the 2nd parameter is optional'); 33 34 skip("LC_CTYPE locale support not available", 4) 35 unless locales_enabled('LC_CTYPE'); 36 37 skip("no utf8 locale available", 4) unless $utf8_locale; 38 # Here we need to influence LC_CTYPE, but it's not enough to just 39 # set this because LC_ALL could override it. It's also not enough 40 # to delete LC_ALL because it could be used to override other 41 # variables such as LANG in the underlying test environment. 42 # Continue to set LC_CTYPE just in case... 43 local $ENV{LC_CTYPE} = $utf8_locale; 44 local $ENV{LC_ALL} = $utf8_locale; 45 46 fresh_perl_like( 47 'use POSIX; print &POSIX::MB_CUR_MAX', 48 qr/[4-6]/, {}, 'MB_CUR_MAX is at least 4 in a UTF-8 locale'); 49 50 SKIP: { 51 my ($major, $minor, $rest) = $Config{osvers} =~ / (\d+) \. (\d+) .* /x; 52 skip("mblen() broken (at least for c.utf8) on early HP-UX", 3) 53 if $Config{osname} eq 'hpux' 54 && $major < 11 || ($major == 11 && $minor < 31); 55 56 fresh_perl_is( 57 'use POSIX; &POSIX::mblen(undef,0); print &POSIX::mblen("' 58 . I8_to_native("\x{c3}\x{28}") 59 . '", 2)', 60 -1, {}, 'mblen() recognizes invalid multibyte characters'); 61 62 fresh_perl_is( 63 'use POSIX; &POSIX::mblen(undef,0); 64 my $sigma = "\N{GREEK SMALL LETTER SIGMA}"; 65 utf8::encode($sigma); 66 print &POSIX::mblen($sigma, 2)', 67 2, {}, 'mblen() works on UTF-8 characters'); 68 69 fresh_perl_is( 70 'use POSIX; &POSIX::mblen(undef,0); 71 my $wide; print &POSIX::mblen("\N{GREEK SMALL LETTER SIGMA}", 1);', 72 -1, {}, 'mblen() returns -1 when input length is too short'); 73 } 74} 75 76SKIP: { 77 skip("mbtowc() not present", 5) unless $Config{d_mbtowc}; 78 79 my $wide; 80 81 is(&POSIX::mbtowc($wide, "a"), 1, 'mbtowc() returns correct length on ASCII input'); 82 is($wide , ord "a", 'mbtowc() returns correct ordinal on ASCII input'); 83 84 skip("LC_CTYPE locale support not available", 3) 85 unless locales_enabled('LC_CTYPE'); 86 87 skip("no utf8 locale available", 3) unless $utf8_locale; 88 89 local $ENV{LC_CTYPE} = $utf8_locale; 90 local $ENV{LC_ALL} = $utf8_locale; 91 local $ENV{PERL_UNICODE}; 92 delete $ENV{PERL_UNICODE}; 93 94 SKIP: { 95 my ($major, $minor, $rest) = $Config{osvers} =~ / (\d+) \. (\d+) .* /x; 96 skip("mbtowc() broken (at least for c.utf8) on early HP-UX", 3) 97 if $Config{osname} eq 'hpux' 98 && $major < 11 || ($major == 11 && $minor < 31); 99 100 fresh_perl_is( 101 'use POSIX; &POSIX::mbtowc(undef, undef,0); my $wide; print &POSIX::mbtowc($wide, "' 102 . I8_to_native("\x{c3}\x{28}") 103 . '", 2)', 104 -1, {}, 'mbtowc() recognizes invalid multibyte characters'); 105 106 fresh_perl_is( 107 'use POSIX; &POSIX::mbtowc(undef,undef,0); 108 my $sigma = "\N{GREEK SMALL LETTER SIGMA}"; 109 utf8::encode($sigma); 110 my $wide; my $len = &POSIX::mbtowc($wide, $sigma, 2); 111 print "$len:$wide"', 112 "2:963", {}, 'mbtowc() works on UTF-8 characters'); 113 114 fresh_perl_is( 115 'use POSIX; &POSIX::mbtowc(undef,undef,0); 116 my $wide; print &POSIX::mbtowc($wide, "\N{GREEK SMALL LETTER SIGMA}", 1);', 117 -1, {}, 'mbtowc() returns -1 when input length is too short'); 118 } 119} 120 121SKIP: { 122 skip("mbtowc or wctomb() not present", 2) unless $Config{d_mbtowc} && $Config{d_wctomb}; 123 124 fresh_perl_is('use POSIX; &POSIX::wctomb(undef,0); my $string; my $len = &POSIX::wctomb($string, ord "A"); print "$len:$string"', 125 "1:A", {}, 'wctomb() works on ASCII input'); 126 127 skip("LC_CTYPE locale support not available", 1) 128 unless locales_enabled('LC_CTYPE'); 129 130 skip("no utf8 locale available", 1) unless $utf8_locale; 131 132 local $ENV{LC_CTYPE} = $utf8_locale; 133 local $ENV{LC_ALL} = $utf8_locale; 134 local $ENV{PERL_UNICODE}; 135 delete $ENV{PERL_UNICODE}; 136 137 SKIP: { 138 my ($major, $minor, $rest) = $Config{osvers} =~ / (\d+) \. (\d+) .* /x; 139 skip("wctomb() broken (at least for c.utf8) on early HP-UX", 1) 140 if $Config{osname} eq 'hpux' 141 && $major < 11 || ($major == 11 && $minor < 31); 142 143 fresh_perl_is('use POSIX; &POSIX::wctomb(undef,0); my $string; my $len = &POSIX::wctomb($string, 0x100); print "$len:$string"', 144 "2:" . I8_to_native("\x{c4}\x{80}"), 145 {}, 'wctomb() works on UTF-8 characters'); 146 147 } 148} 149