use strict;
use warnings;
use 5.010;
+our ($REGMARK, $REGERROR);
sub run_tests;
sub run_tests {
{
- no warnings 'deprecated';
-
- my $message = '\C matches octet';
- $_ = "a\x{100}b";
- ok(/(.)(\C)(\C)(.)/, $message);
- is($1, "a", $message);
- if ($::IS_ASCII) { # ASCII (or equivalent), should be UTF-8
- is($2, "\xC4", $message);
- is($3, "\x80", $message);
- }
- elsif ($::IS_EBCDIC) { # EBCDIC (or equivalent), should be UTF-EBCDIC
- is($2, "\x8C", $message);
- is($3, "\x41", $message);
- }
- else {
- SKIP: {
- ok 0, "Unexpected platform", "ord ('A') =" . ord 'A';
- skip "Unexpected platform";
- }
- }
- is($4, "b", $message);
- }
-
- {
- no warnings 'deprecated';
-
- my $message = '\C matches octet';
- $_ = "\x{100}";
- ok(/(\C)/g, $message);
- if ($::IS_ASCII) {
- is($1, "\xC4", $message);
- }
- elsif ($::IS_EBCDIC) {
- is($1, "\x8C", $message);
- }
- else {
- ok 0, "Unexpected platform", "ord ('A') = " . ord 'A';
- }
- ok(/(\C)/g, $message);
- if ($::IS_ASCII) {
- is($1, "\x80", $message);
- }
- elsif ($::IS_EBCDIC) {
- is($1, "\x41", $message);
- }
- else {
- ok 0, "Unexpected platform", "ord ('A') = " . ord 'A';
- }
- }
-
- {
# Japhy -- added 03/03/2001
() = (my $str = "abc") =~ /(...)/;
$str = "def";
## Should probably put in tests for all the POSIX stuff,
## but not sure how to guarantee a specific locale......
- skip "Not an ASCII platform", 2 unless $::IS_ASCII;
my $message = 'Test [[:cntrl:]]';
my $AllBytes = join "" => map {chr} 0 .. 255;
(my $x = $AllBytes) =~ s/[[:cntrl:]]//g;
+ $x = join "", sort { $a cmp $b }
+ map { chr utf8::native_to_unicode(ord $_) } split "", $x;
is($x, join("", map {chr} 0x20 .. 0x7E, 0x80 .. 0xFF), $message);
($x = $AllBytes) =~ s/[^[:cntrl:]]//g;
+ $x = join "", sort { $a cmp $b }
+ map { chr utf8::native_to_unicode(ord $_) } split "", $x;
is($x, (join "", map {chr} 0x00 .. 0x1F, 0x7F), $message);
}
}
{
- no warnings 'deprecated';
-
- my $message = '. matches \n with /s';
- my $str1 = "foo\nbar";
- my $str2 = "foo\n\x{100}bar";
- my ($a, $b) = map {chr} $::IS_ASCII ? (0xc4, 0x80) : (0x8c, 0x41);
- my @a;
- @a = $str1 =~ /./g; is(@a, 6, $message); is("@a", "f o o b a r", $message);
- @a = $str1 =~ /./gs; is(@a, 7, $message); is("@a", "f o o \n b a r", $message);
- @a = $str1 =~ /\C/g; is(@a, 7, $message); is("@a", "f o o \n b a r", $message);
- @a = $str1 =~ /\C/gs; is(@a, 7, $message); is("@a", "f o o \n b a r", $message);
- @a = $str2 =~ /./g; is(@a, 7, $message); is("@a", "f o o \x{100} b a r", $message);
- @a = $str2 =~ /./gs; is(@a, 8, $message); is("@a", "f o o \n \x{100} b a r", $message);
- @a = $str2 =~ /\C/g; is(@a, 9, $message); is("@a", "f o o \n $a $b b a r", $message);
- @a = $str2 =~ /\C/gs; is(@a, 9, $message); is("@a", "f o o \n $a $b b a r", $message);
- }
-
- {
no warnings 'digit';
# Check that \x## works. 5.6.1 and 5.005_03 fail some of these.
my $x;
=~ /^(\X)!/ &&
$1 eq "\N{LATIN CAPITAL LETTER E}\N{COMBINING GRAVE ACCENT}", $message);
- no warnings 'deprecated';
-
- $message = '\C and \X';
- like("!abc!", qr/a\Cc/, $message);
- like("!abc!", qr/a\Xc/, $message);
}
{
$& eq "Francais", $message);
ok("Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" =~ /Fran.ais/ &&
$& eq "Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais", $message);
- {
- no warnings 'deprecated';
- ok("Fran\N{LATIN SMALL LETTER C}ais" =~ /Fran\Cais/ &&
- $& eq "Francais", $message);
- # COMBINING CEDILLA is two bytes when encoded
- like("Franc\N{COMBINING CEDILLA}ais", qr/Franc\C\Cais/, $message);
- }
ok("Fran\N{LATIN SMALL LETTER C}ais" =~ /Fran\Xais/ &&
$& eq "Francais", $message);
ok("Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" =~ /Fran\Xais/ &&
# differently
undef $w;
eval q [ok "\N{TOO-LONG-STR}" =~ /^\N{TOO-LONG-STR}$/, 'Verify that what once was too long a string works'];
- eval 'q(syntax error) =~ /\N{MALFORMED}/';
- ok $@ && $@ =~ /Malformed/, 'Verify that malformed utf8 gives an error';
eval 'q() =~ /\N{4F}/';
ok $@ && $@ =~ /Invalid character/, 'Verify that leading digit in name gives error';
eval 'q() =~ /\N{COM,MA}/';
{
# Test named commits and the $REGERROR var
- our $REGERROR;
+ local $REGERROR;
for my $name ('', ':foo') {
for my $pat ("(*PRUNE$name)",
($name ? "(*MARK$name)" : "") . "(*SKIP$name)",
# Test named commits and the $REGERROR var
package Fnorble;
our $REGERROR;
+ local $REGERROR;
for my $name ('', ':foo') {
for my $pat ("(*PRUNE$name)",
($name ? "(*MARK$name)" : "") . "(*SKIP$name)",
{
# Test named commits and the $REGERROR var
my $message = '$REGERROR';
- our $REGERROR;
+ local $REGERROR;
for my $word (qw (bar baz bop)) {
$REGERROR = "";
"aaaaa$word" =~
{
my $message = '$REGMARK';
our @r = ();
- our ($REGMARK, $REGERROR);
+ local $REGMARK;
+ local $REGERROR;
like('foofoo', qr/foo (*MARK:foo) (?{push @r,$REGMARK}) /x, $message);
is("@r","foo", $message);
is($REGMARK, "foo", $message);
{
# Test for keys in %+ and %-
my $message = 'Test keys in %+ and %-';
- no warnings 'uninitialized', 'deprecated', 'experimental::lexical_topic';
- my $_ = "abcdef";
+ no warnings 'uninitialized';
+ local $_ = "abcdef";
/(?<foo>a)|(?<foo>b)/;
is((join ",", sort keys %+), "foo", $message);
is((join ",", sort keys %-), "foo", $message);
{
# length() on captures, the numbered ones end up in Perl_magic_len
- no warnings 'deprecated', 'experimental::lexical_topic';
- my $_ = "aoeu " . uni_to_native("\xe6") . "var ook";
+ local $_ = "aoeu " . uni_to_native("\xe6") . "var ook";
/^ \w+ \s (?<eek>\S+)/x;
is(length $`, 0, q[length $`]);
}
{
+ fresh_perl_is(<<'EOF',
+ my $s = "\x{41c}";
+ $s =~ /(.*)/ or die;
+ $ls = lc $1;
+ print $ls eq lc $s ? "good\n" : "bad: [$ls]\n";
+EOF
+ "good\n",
+ {},
+ "swash triggered by lc() doesn't corrupt \$1"
+ );
+ }
+
+ {
#' RT #119075
no warnings 'regexp'; # Silence "has useless greediness modifier"
local $@;
is "$1" || $@, "at", 'empty \N{...} stringified and retoked';
}
+ is (scalar split(/\b{sb}/, "Don't think twice. It's all right."),
+ 2, '\b{wb} splits sentences correctly');
+
+
+ # !!! NOTE! Keep the following tests last -- they may crash perl
- #
- # Keep the following tests last -- they may crash perl
- #
print "# Tests that follow may crash perl\n";
{
eval '/\k/';
sub Is_32_Bit_Super { return "110000\tFFFFFFFF\n" }
sub Is_Portable_Super { return '!utf8::Any' } # Matches beyond 32 bits
- SKIP:
{ # Assertion was failing on on 64-bit platforms; just didn't work on 32.
- skip("EBCDIC only goes to 31 bits", 4) if $::IS_EBCDIC;
no warnings qw(non_unicode portable);
+ no warnings 'deprecated'; # These are above IV_MAX
use Config;
# We use 'ok' instead of 'like' because the warnings are lexically
# scoped, and want to turn them off, so have to do the match in this
- # scope. (EBCDIC platforms can't handle above 2**32 - 1
+ # scope.
if ($Config{uvsize} < 8) {
ok(chr(0xFFFF_FFFE) =~ /\p{Is_32_Bit_Super}/,
"chr(0xFFFF_FFFE) can match a Unicode property");
"Overlapping ranges in user-defined properties");
}
+ { # [perl #125990], the final 2 tests below each caused a panic.
+ # The \0's are not necessary; it could be a printable character
+ # instead, but were in the ticket, so using them.
+ my $sharp_s = chr utf8::unicode_to_native(0xdf);
+ my $string = ("\0" x 8)
+ . ($sharp_s x 3)
+ . ("\0" x 42)
+ . "ý";
+ my $folded_string = ("\0" x 8)
+ . ("ss" x 3)
+ . ("\0" x 42)
+ . "ý";
+ utf8::downgrade($string);
+ utf8::downgrade($folded_string);
+
+ like($string, qr/$string/i, "LATIN SMALL SHARP S matches itself under /id");
+ unlike($folded_string, qr/$string/i, "LATIN SMALL SHARP S doesn't match 'ss' under /di");
+ like($folded_string, qr/\N{}$string/i, "\\N{} earlier than LATIN SMALL SHARP S transforms /di into /ui, matches 'ss'");
+ like($folded_string, qr/$string\N{}/i, "\\N{} after LATIN SMALL SHARP S transforms /di into /ui, matches 'ss'");
+ }
+
{ # Regexp:Grammars was broken:
# http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2013-06/msg01290.html
fresh_perl_like('use warnings; "abc" =~ qr{(?&foo){0}abc(?<foo>)}',
'No segfault on qr{(?&foo){0}abc(?<foo>)}');
}
+ SKIP:
+ { # [perl #125826] buffer overflow in TRIE_STORE_REVCHAR
+ # (during compilation, so use a fresh perl)
+ $Config{uvsize} == 8
+ or skip("need large code-points for this test", 1);
+
+ # This is above IV_MAX on 32 bit machines, so turn off those warnings
+ fresh_perl_is('no warnings "deprecated"; /\x{E000000000}|/ and print qq(ok\n)', "ok\n", {},
+ "buffer overflow in TRIE_STORE_REVCHAR");
+ }
+
# !!! NOTE that tests that aren't at all likely to crash perl should go
- # a ways above, above these last ones.
+ # a ways above, above these last ones. There's a comment there that, like
+ # this comment, contains the word 'NOTE'
done_testing();
} # End of sub run_tests
https://perl5.git.perl.org / perl5.git / blobdiff