Commit | Line | Data |
---|---|---|
192c1e27 JH |
1 | #!./perl |
2 | ||
3 | BEGIN { | |
cedc31d0 NC |
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 | |
192c1e27 JH |
10 | } |
11 | ||
12 | use strict; | |
13 | use warnings; | |
14 | ||
192c1e27 JH |
15 | use re qw(is_regexp regexp_pattern |
16 | regname regnames regnames_count); | |
17 | { | |
9de15fec | 18 | use feature 'unicode_strings'; # Force 'u' pat mod |
192c1e27 | 19 | my $qr=qr/foo/pi; |
9de15fec | 20 | no feature 'unicode_strings'; |
df052ff8 BM |
21 | my $rx = $$qr; |
22 | ||
23 | ok(is_regexp($qr),'is_regexp(REGEXP ref)'); | |
24 | ok(is_regexp($rx),'is_regexp(REGEXP)'); | |
192c1e27 | 25 | ok(!is_regexp(''),'is_regexp("")'); |
df052ff8 BM |
26 | |
27 | is((regexp_pattern($qr))[0],'foo','regexp_pattern[0] (ref)'); | |
9de15fec KW |
28 | is((regexp_pattern($qr))[1],'uip','regexp_pattern[1] (ref)'); |
29 | is(regexp_pattern($qr),'(?^upi:foo)','scalar regexp_pattern (ref)'); | |
df052ff8 BM |
30 | |
31 | is((regexp_pattern($rx))[0],'foo','regexp_pattern[0] (bare REGEXP)'); | |
9de15fec KW |
32 | is((regexp_pattern($rx))[1],'uip','regexp_pattern[1] (bare REGEXP)'); |
33 | is(regexp_pattern($rx),'(?^upi:foo)', 'scalar regexp_pattern (bare REGEXP)'); | |
df052ff8 | 34 | |
192c1e27 JH |
35 | ok(!regexp_pattern(''),'!regexp_pattern("")'); |
36 | } | |
37 | ||
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(); | |
4c7a7875 | 44 | ok(($names eq "B" || $names eq "A"), "regnames in scalar context"); |
192c1e27 JH |
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 | } | |
7dcb3b25 | 58 | |
f1c60533 | 59 | { |
94b03d7d KW |
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"); | |
94b03d7d KW |
78 | } |
79 | ||
80 | { | |
f1c60533 | 81 | # tests for new regexp flags |
f6bb1928 | 82 | my $text = "\xE4"; |
f1c60533 RB |
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: { | |
8c49cd2e NC |
94 | skip_if_miniperl("no dynamic loading on miniperl, no POSIX", 3); |
95 | require POSIX; | |
f1c60533 RB |
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 ); | |
99 | } | |
100 | ||
101 | $check = $text =~ /(?u)\w/; | |
102 | ok( $check ); | |
103 | $check = $text =~ /(?d)\w/; | |
104 | ok( !$check ); | |
105 | $check = $text =~ /(?l)\w/; | |
106 | ok( $check ); | |
107 | } | |
108 | ||
109 | SKIP: { | |
8c49cd2e NC |
110 | skip_if_miniperl("no dynamic loading on miniperl, no POSIX", 3); |
111 | require POSIX; | |
c3f22386 KW |
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 ); | |
f1c60533 RB |
115 | } |
116 | ||
117 | $check = $text =~ /(?u)\w/; | |
118 | ok( $check ); | |
119 | $check = $text =~ /(?d)\w/; | |
120 | ok( !$check ); | |
121 | $check = $text =~ /(?l)\w/; | |
122 | ok( !$check ); | |
123 | } | |
124 | } | |
125 | ||
f299c5a1 | 126 | # New tests go here ^^^ |
102f161f TC |
127 | |
128 | { # Keep these tests last, as whole script will be interrupted if times out | |
129 | # Bug #72998; this can loop | |
7c47ab27 | 130 | watchdog(10); |
102f161f TC |
131 | eval '"\x{100}\x{FB00}" =~ /\x{100}\N{U+66}+/i'; |
132 | pass("Didn't loop"); | |
133 | ||
134 | # Bug #78058; this can loop | |
102f161f TC |
135 | no warnings; # Because the 8 may be warned on |
136 | eval 'qr/\18/'; | |
f15ebdc7 | 137 | pass(q"qr/\18/ didn't loop"); |
102f161f TC |
138 | } |
139 | ||
f299c5a1 NC |
140 | done_testing(); |
141 | ||
142 | __END__ | |
143 | # New tests go up there^^^ |