This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
t/re/pat_{psycho,re_eval,special_cc}.t can use test.pl direct.
[perl5.git] / t / re / pat_psycho.t
CommitLineData
e425a60b
YO
1#!./perl
2#
3# This is a home for regular expression tests that don't fit into
4# the format supported by re/regexp.t. If you want to add a test
5# that does fit that format, add it to re/re_tests, not here.
6
7use strict;
8use warnings;
9use 5.010;
10
11
12sub run_tests;
13
14$| = 1;
15
e425a60b
YO
16
17BEGIN {
18 chdir 't' if -d 't';
9d45b377 19 @INC = ('../lib','.');
90b541eb 20 require './test.pl';
e425a60b 21}
e425a60b 22
e425a60b 23
9d45b377 24plan tests => 11; # Update this when adding/deleting tests.
e425a60b 25
9d45b377 26run_tests() unless caller;
e425a60b
YO
27
28#
29# Tests start here.
30#
31sub run_tests {
32
9d45b377 33 SKIP:
e425a60b 34 {
9d45b377
YO
35 print "# Set PERL_SKIP_PSYCHO_TEST to skip this test\n";
36 my @normal = qw [the are some normal words];
e425a60b 37
9d45b377 38 skip "Skipped Psycho", 2 * @normal if $ENV {PERL_SKIP_PSYCHO_TEST};
e425a60b 39
9d45b377 40 local $" = "|";
e425a60b 41
9d45b377
YO
42 my @psycho = (@normal, map chr $_, 255 .. 20000);
43 my $psycho1 = "@psycho";
44 for (my $i = @psycho; -- $i;) {
45 my $j = int rand (1 + $i);
46 @psycho [$i, $j] = @psycho [$j, $i];
e425a60b 47 }
9d45b377 48 my $psycho2 = "@psycho";
e425a60b 49
9d45b377
YO
50 foreach my $word (@normal) {
51 ok $word =~ /($psycho1)/ && $1 eq $word, 'Psycho';
52 ok $word =~ /($psycho2)/ && $1 eq $word, 'Psycho';
e425a60b
YO
53 }
54 }
55
56
9d45b377 57 SKIP:
e425a60b 58 {
9d45b377
YO
59 # stress test CURLYX/WHILEM.
60 #
61 # This test includes varying levels of nesting, and according to
62 # profiling done against build 28905, exercises every code line in the
63 # CURLYX and WHILEM blocks, except those related to LONGJMP, the
64 # super-linear cache and warnings. It executes about 0.5M regexes
e425a60b 65
9d45b377
YO
66 skip "No psycho tests" if $ENV {PERL_SKIP_PSYCHO_TEST};
67 print "# Set PERL_SKIP_PSYCHO_TEST to skip this test\n";
68 my $r = qr/^
69 (?:
70 ( (?:a|z+)+ )
71 (?:
72 ( (?:b|z+){3,}? )
73 (
74 (?:
75 (?:
76 (?:c|z+){1,1}?z
77 )?
78 (?:c|z+){1,1}
79 )*
80 )
81 (?:z*){2,}
82 ( (?:z+|d)+ )
83 (?:
84 ( (?:e|z+)+ )
85 )*
86 ( (?:f|z+)+ )
87 )*
88 ( (?:z+|g)+ )
89 (?:
90 ( (?:h|z+)+ )
91 )*
92 ( (?:i|z+)+ )
93 )+
94 ( (?:j|z+)+ )
95 (?:
96 ( (?:k|z+)+ )
97 )*
98 ( (?:l|z+)+ )
99 $/x;
100
101 my $ok = 1;
102 my $msg = "CURLYX stress test";
103 OUTER:
104 for my $a ("x","a","aa") {
105 for my $b ("x","bbb","bbbb") {
106 my $bs = $a.$b;
107 for my $c ("x","c","cc") {
108 my $cs = $bs.$c;
109 for my $d ("x","d","dd") {
110 my $ds = $cs.$d;
111 for my $e ("x","e","ee") {
112 my $es = $ds.$e;
113 for my $f ("x","f","ff") {
114 my $fs = $es.$f;
115 for my $g ("x","g","gg") {
116 my $gs = $fs.$g;
117 for my $h ("x","h","hh") {
118 my $hs = $gs.$h;
119 for my $i ("x","i","ii") {
120 my $is = $hs.$i;
121 for my $j ("x","j","jj") {
122 my $js = $is.$j;
123 for my $k ("x","k","kk") {
124 my $ks = $js.$k;
125 for my $l ("x","l","ll") {
126 my $ls = $ks.$l;
127 if ($ls =~ $r) {
128 if ($ls =~ /x/) {
129 $msg .= ": unexpected match for [$ls]";
130 $ok = 0;
131 last OUTER;
132 }
133 my $cap = "$1$2$3$4$5$6$7$8$9$10$11$12";
134 unless ($ls eq $cap) {
135 $msg .= ": capture: [$ls], got [$cap]";
136 $ok = 0;
137 last OUTER;
138 }
139 }
140 else {
141 unless ($ls =~ /x/) {
142 $msg = ": failed for [$ls]";
143 $ok = 0;
144 last OUTER;
145 }
146 }
147 }
148 }
149 }
150 }
151 }
152 }
153 }
154 }
155 }
156 }
157 }
e425a60b 158 }
9d45b377 159 ok($ok, $msg);
e425a60b 160 }
e425a60b
YO
161} # End of sub run_tests
162
1631;