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 require 'loc_tools.pl'; # To see if platform has locales 11} 12 13use strict; 14use warnings; 15 16use re qw(is_regexp regexp_pattern 17 regname regnames regnames_count); 18{ 19 use feature 'unicode_strings'; # Force 'u' pat mod 20 my $qr=qr/foo/pi; 21 no feature 'unicode_strings'; 22 my $rx = $$qr; 23 24 ok(is_regexp($qr),'is_regexp(REGEXP ref)'); 25 ok(is_regexp($rx),'is_regexp(REGEXP)'); 26 ok(!is_regexp(''),'is_regexp("")'); 27 28 is((regexp_pattern($qr))[0],'foo','regexp_pattern[0] (ref)'); 29 is((regexp_pattern($qr))[1],'uip','regexp_pattern[1] (ref)'); 30 is(regexp_pattern($qr),'(?^upi:foo)','scalar regexp_pattern (ref)'); 31 32 is((regexp_pattern($rx))[0],'foo','regexp_pattern[0] (bare REGEXP)'); 33 is((regexp_pattern($rx))[1],'uip','regexp_pattern[1] (bare REGEXP)'); 34 is(regexp_pattern($rx),'(?^upi:foo)', 'scalar regexp_pattern (bare REGEXP)'); 35 36 ok(!regexp_pattern(''),'!regexp_pattern("")'); 37 is +()=regexp_pattern(''), 0, 'regexp_pattern("") in list cx'; 38} 39 40if ('1234'=~/(?:(?<A>\d)|(?<C>!))(?<B>\d)(?<A>\d)(?<B>\d)/){ 41 my @names = sort +regnames(); 42 is("@names","A B","regnames"); 43 @names = sort +regnames(0); 44 is("@names","A B","regnames"); 45 my $names = regnames(); 46 ok(($names eq "B" || $names eq "A"), "regnames in scalar context"); 47 @names = sort +regnames(1); 48 is("@names","A B C","regnames"); 49 is(join("", @{regname("A",1)}),"13"); 50 is(join("", @{regname("B",1)}),"24"); 51 { 52 if ('foobar'=~/(?<foo>foo)(?<bar>bar)/) { 53 is(regnames_count(),2); 54 } else { 55 ok(0); ok(0); 56 } 57 } 58 is(regnames_count(),3); 59} 60 61{ 62 my ($pat, $mods); 63 $|=1; 64 65 my $re = qr/a/d; 66 ($pat, $mods) = regexp_pattern($re); 67 is($mods, "", "Verify /d results in default mod"); 68 $re = qr/a/u; 69 ($pat, $mods) = regexp_pattern($re); 70 is($mods, "u", "Verify /u is understood"); 71 $re = qr/a/l; 72 ($pat, $mods) = regexp_pattern($re); 73 is($mods, "l", "Verify /l is understood"); 74 $re = qr/a/a; 75 ($pat, $mods) = regexp_pattern($re); 76 is($mods, "a", "Verify /a is understood"); 77 $re = qr/a/aa; 78 ($pat, $mods) = regexp_pattern($re); 79 is($mods, "aa", "Verify /aa is understood"); 80} 81 82{ 83 # tests for new regexp flags 84 my $text = chr utf8::unicode_to_native(0xE4); 85 my $check; 86 87 { 88 # check u/d-flag without setting a locale 89 $check = $text =~ /(?u)\w/; 90 ok( $check ); 91 $check = $text =~ /(?d)\w/; 92 ok( !$check ); 93 } 94 95 SKIP: { 96 skip 'No locales available', 3 unless locales_enabled('LC_CTYPE'); 97 require POSIX; 98 my $current_locale = POSIX::setlocale( &POSIX::LC_CTYPE, 'de_DE.ISO-8859-1' ); 99 if ( !$current_locale || $current_locale ne 'de_DE.ISO-8859-1' ) { 100 skip( 'cannot use locale de_DE.ISO-8859-1', 3 ); 101 } 102 103 $check = $text =~ /(?u)\w/; 104 ok( $check ); 105 $check = $text =~ /(?d)\w/; 106 ok( !$check ); 107 $check = $text =~ /(?l)\w/; 108 ok( $check ); 109 } 110 111 SKIP: { 112 skip 'No locales available', 3 unless locales_enabled('LC_CTYPE'); 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