5 if (($Config::Config{'extensions'} !~ /\bre\b/) ){
6 print "1..0 # Skip -- Perl configured without re module\n";
9 require 'test.pl'; # For watchdog
15 use re qw(is_regexp regexp_pattern
16 regname regnames regnames_count);
18 use feature 'unicode_strings'; # Force 'u' pat mod
20 no feature 'unicode_strings';
23 ok(is_regexp($qr),'is_regexp(REGEXP ref)');
24 ok(is_regexp($rx),'is_regexp(REGEXP)');
25 ok(!is_regexp(''),'is_regexp("")');
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)');
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)');
35 ok(!regexp_pattern(''),'!regexp_pattern("")');
38 if ('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");
50 if ('foobar'=~/(?<foo>foo)(?<bar>bar)/) {
51 is(regnames_count(),2);
56 is(regnames_count(),3);
64 ($pat, $mods) = regexp_pattern($re);
65 is($mods, "", "Verify /d results in default mod");
67 ($pat, $mods) = regexp_pattern($re);
68 is($mods, "u", "Verify /u is understood");
70 ($pat, $mods) = regexp_pattern($re);
71 is($mods, "l", "Verify /l is understood");
73 ($pat, $mods) = regexp_pattern($re);
74 is($mods, "a", "Verify /a is understood");
76 ($pat, $mods) = regexp_pattern($re);
77 is($mods, "aa", "Verify /aa is understood");
81 # tests for new regexp flags
86 # check u/d-flag without setting a locale
87 $check = $text =~ /(?u)\w/;
89 $check = $text =~ /(?d)\w/;
94 skip_if_miniperl("no dynamic loading on miniperl, no POSIX", 3);
96 my $current_locale = POSIX::setlocale( &POSIX::LC_CTYPE, 'de_DE.ISO-8859-1' );
97 if ( !$current_locale || $current_locale ne 'de_DE.ISO-8859-1' ) {
98 skip( 'cannot use locale de_DE.ISO-8859-1', 3 );
101 $check = $text =~ /(?u)\w/;
103 $check = $text =~ /(?d)\w/;
105 $check = $text =~ /(?l)\w/;
110 skip_if_miniperl("no dynamic loading on miniperl, no POSIX", 3);
112 my $current_locale = POSIX::setlocale( &POSIX::LC_CTYPE, 'C' );
113 if ( !$current_locale || $current_locale ne 'C' ) {
114 skip( 'cannot set locale C', 3 );
117 $check = $text =~ /(?u)\w/;
119 $check = $text =~ /(?d)\w/;
121 $check = $text =~ /(?l)\w/;
126 # New tests go here ^^^
128 { # Keep these tests last, as whole script will be interrupted if times out
129 # Bug #72998; this can loop
131 eval '"\x{100}\x{FB00}" =~ /\x{100}\N{U+66}+/i';
134 # Bug #78058; this can loop
135 no warnings; # Because the 8 may be warned on
137 pass(q"qr/\18/ didn't loop");
143 # New tests go up there^^^