1#!./perl 2 3BEGIN { 4 require Config; 5 if (($Config::Config{'extensions'} !~ /\bre\b/) ){ 6 print "1..0 # Skip -- Perl configured without re module\n"; 7 exit 0; 8 } 9 require 'test.pl'; # For watchdog 10} 11 12use strict; 13use warnings; 14 15use re qw(is_regexp regexp_pattern 16 regname regnames regnames_count); 17{ 18 use feature 'unicode_strings'; # Force 'u' pat mod 19 my $qr=qr/foo/pi; 20 no feature 'unicode_strings'; 21 my $rx = $$qr; 22 23 ok(is_regexp($qr),'is_regexp(REGEXP ref)'); 24 ok(is_regexp($rx),'is_regexp(REGEXP)'); 25 ok(!is_regexp(''),'is_regexp("")'); 26 27 is((regexp_pattern($qr))[0],'foo','regexp_pattern[0] (ref)'); 28 is((regexp_pattern($qr))[1],'uip','regexp_pattern[1] (ref)'); 29 is(regexp_pattern($qr),'(?^upi:foo)','scalar regexp_pattern (ref)'); 30 31 is((regexp_pattern($rx))[0],'foo','regexp_pattern[0] (bare REGEXP)'); 32 is((regexp_pattern($rx))[1],'uip','regexp_pattern[1] (bare REGEXP)'); 33 is(regexp_pattern($rx),'(?^upi:foo)', 'scalar regexp_pattern (bare REGEXP)'); 34 35 ok(!regexp_pattern(''),'!regexp_pattern("")'); 36} 37 38if ('1234'=~/(?:(?<A>\d)|(?<C>!))(?<B>\d)(?<A>\d)(?<B>\d)/){ 39 my @names = sort +regnames(); 40 is("@names","A B","regnames"); 41 @names = sort +regnames(0); 42 is("@names","A B","regnames"); 43 my $names = regnames(); 44 ok(($names eq "B" || $names eq "A"), "regnames in scalar context"); 45 @names = sort +regnames(1); 46 is("@names","A B C","regnames"); 47 is(join("", @{regname("A",1)}),"13"); 48 is(join("", @{regname("B",1)}),"24"); 49 { 50 if ('foobar'=~/(?<foo>foo)(?<bar>bar)/) { 51 is(regnames_count(),2); 52 } else { 53 ok(0); ok(0); 54 } 55 } 56 is(regnames_count(),3); 57} 58 59{ 60 my ($pat, $mods); 61 $|=1; 62 63 my $re = qr/a/d; 64 ($pat, $mods) = regexp_pattern($re); 65 is($mods, "", "Verify /d results in default mod"); 66 $re = qr/a/u; 67 ($pat, $mods) = regexp_pattern($re); 68 is($mods, "u", "Verify /u is understood"); 69 $re = qr/a/l; 70 ($pat, $mods) = regexp_pattern($re); 71 is($mods, "l", "Verify /l is understood"); 72 $re = qr/a/a; 73 ($pat, $mods) = regexp_pattern($re); 74 is($mods, "a", "Verify /a is understood"); 75 $re = qr/a/aa; 76 ($pat, $mods) = regexp_pattern($re); 77 is($mods, "aa", "Verify /aa is understood"); 78} 79 80{ 81 # tests for new regexp flags 82 my $text = "\xE4"; 83 my $check; 84 85 { 86 # check u/d-flag without setting a locale 87 $check = $text =~ /(?u)\w/; 88 ok( $check ); 89 $check = $text =~ /(?d)\w/; 90 ok( !$check ); 91 } 92 93 SKIP: { 94 skip_if_miniperl("no dynamic loading on miniperl, no POSIX", 3); 95 skip 'No locale testing without d_setlocale', 3 if(!$Config::Config{d_setlocale}); 96 require POSIX; 97 my $current_locale = POSIX::setlocale( &POSIX::LC_CTYPE, 'de_DE.ISO-8859-1' ); 98 if ( !$current_locale || $current_locale ne 'de_DE.ISO-8859-1' ) { 99 skip( 'cannot use locale de_DE.ISO-8859-1', 3 ); 100 } 101 102 $check = $text =~ /(?u)\w/; 103 ok( $check ); 104 $check = $text =~ /(?d)\w/; 105 ok( !$check ); 106 $check = $text =~ /(?l)\w/; 107 ok( $check ); 108 } 109 110 SKIP: { 111 skip_if_miniperl("no dynamic loading on miniperl, no POSIX", 3); 112 skip 'No locale testing without d_setlocale', 3 if(!$Config::Config{d_setlocale}); 113 require POSIX; 114 my $current_locale = POSIX::setlocale( &POSIX::LC_CTYPE, 'C' ); 115 if ( !$current_locale || $current_locale ne 'C' ) { 116 skip( 'cannot set locale C', 3 ); 117 } 118 119 $check = $text =~ /(?u)\w/; 120 ok( $check ); 121 $check = $text =~ /(?d)\w/; 122 ok( !$check ); 123 $check = $text =~ /(?l)\w/; 124 ok( !$check ); 125 } 126} 127 128# New tests go here ^^^ 129 130 { # Keep these tests last, as whole script will be interrupted if times out 131 # Bug #72998; this can loop 132 watchdog(10); 133 eval '"\x{100}\x{FB00}" =~ /\x{100}\N{U+66}+/i'; 134 pass("Didn't loop"); 135 136 # Bug #78058; this can loop 137 no warnings; # Because the 8 may be warned on 138 eval 'qr/\18/'; 139 pass(q"qr/\18/ didn't loop"); 140 } 141 142done_testing(); 143 144__END__ 145# New tests go up there^^^ 146