This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
28acf882d51633b45b72143bbfed4d3ec87058ab
[perl5.git] / t / re / speed.t
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, that specifically should run fast.
5 #
6 # All the tests in this file are ones that run exceptionally slowly
7 # (each test taking seconds or even minutes) in the absence of particular
8 # optimisations. Thus it is a sort of canary for optimisations being
9 # broken.
10 #
11 # Although it includes a watchdog timeout, this is set to a generous limit
12 # to allow for running on slow systems; therefore a broken optimisation
13 # might be indicated merely by this test file taking unusually long to
14 # run, rather than actually timing out.
15 #
16
17 BEGIN {
18     chdir 't' if -d 't';
19     @INC = ('../lib','.','../ext/re');
20     require Config; import Config;
21     require './test.pl';
22     skip_all('no re module') unless defined &DynaLoader::boot_DynaLoader;
23     skip_all_without_unicode_tables();
24 }
25
26 plan tests => 57;  # Update this when adding/deleting tests.
27
28 use strict;
29 use warnings;
30 use 5.010;
31
32 sub run_tests;
33
34 $| = 1;
35
36 run_tests() unless caller;
37
38 #
39 # Tests start here.
40 #
41 sub run_tests {
42
43
44     watchdog(($::running_as_thread && $::running_as_thread) ? 50 : 75);
45
46     {
47         # [perl #120446]
48         # this code should be virtually instantaneous. If it takes 10s of
49         # seconds, there a bug in intuit_start.
50         # (this test doesn't actually test for slowness - that involves
51         # too much danger of false positives on loaded machines - but by
52         # putting it here, hopefully someone might notice if it suddenly
53         # runs slowly)
54         my $s = ('a' x 1_000_000) . 'b';
55         my $i = 0;
56         for (1..10_000) {
57             pos($s) = $_;
58             $i++ if $s =~/\Gb/g;
59         }
60         is($i, 0, "RT 120446: mustn't run slowly");
61     }
62
63     {
64         # [perl #120692]
65         # these tests should be virtually instantaneous. If they take 10s of
66         # seconds, there's a bug in intuit_start.
67
68         my $s = 'ab' x 1_000_000;
69         utf8::upgrade($s);
70         1 while $s =~ m/\Ga+ba+b/g;
71         pass("RT#120692 \\G mustn't run slowly");
72
73         $s=~ /^a{1,2}x/ for  1..10_000;
74         pass("RT#120692 a{1,2} mustn't run slowly");
75
76         $s=~ /ab.{1,2}x/;
77         pass("RT#120692 ab.{1,2} mustn't run slowly");
78
79         $s = "-a-bc" x 250_000;
80         $s .= "1a1bc";
81         utf8::upgrade($s);
82         ok($s =~ /\da\d{0,30000}bc/, "\\d{30000}");
83
84         $s = "-ab\n" x 250_000;
85         $s .= "abx";
86         ok($s =~ /^ab.*x/m, "distant float with /m");
87
88         my $r = qr/^abcd/;
89         $s = "abcd-xyz\n" x 500_000;
90         $s =~ /$r\d{1,2}xyz/m for 1..200;
91         pass("BOL within //m  mustn't run slowly");
92
93         $s = "abcdefg" x 1_000_000;
94         $s =~ /(?-m:^)abcX?fg/m for 1..100;
95         pass("BOL within //m  mustn't skip absolute anchored check");
96
97         $s = "abcdefg" x 1_000_000;
98         $s =~ /^XX\d{1,10}cde/ for 1..100;
99         pass("abs anchored float string should fail quickly");
100
101         # if /.*.../ fails to be optimised well (PREGf_IMPLICIT),
102         # things tend to go quadratic (RT #123743)
103
104         $s = ('0' x 200_000) . '::: 0c';
105         ok ($s !~ /.*:::\s*ab/,    'PREGf_IMPLICIT');
106         ok ($s !~ /.*:::\s*ab/i,   'PREGf_IMPLICIT/i');
107         ok ($s !~ /.*:::\s*ab/m,   'PREGf_IMPLICIT/m');
108         ok ($s !~ /.*:::\s*ab/mi,  'PREGf_IMPLICIT/mi');
109         ok ($s !~ /.*:::\s*ab/s,   'PREGf_IMPLICIT/s');
110         ok ($s !~ /.*:::\s*ab/si,  'PREGf_IMPLICIT/si');
111         ok ($s !~ /.*:::\s*ab/ms,  'PREGf_IMPLICIT/ms');
112         ok ($s !~ /.*:::\s*ab/msi, 'PREGf_IMPLICIT/msi');
113         ok ($s !~ /.*?:::\s*ab/,   'PREGf_IMPLICIT');
114         ok ($s !~ /.*?:::\s*ab/i,  'PREGf_IMPLICIT/i');
115         ok ($s !~ /.*?:::\s*ab/m,  'PREGf_IMPLICIT/m');
116         ok ($s !~ /.*?:::\s*ab/mi, 'PREGf_IMPLICIT/mi');
117         ok ($s !~ /.*?:::\s*ab/s,  'PREGf_IMPLICIT/s');
118         ok ($s !~ /.*?:::\s*ab/si, 'PREGf_IMPLICIT/si');
119         ok ($s !~ /.*?:::\s*ab/ms, 'PREGf_IMPLICIT/ms');
120         ok ($s !~ /.*?:::\s*ab/msi,'PREGf_IMPLICIT/msi');
121
122         for my $star ('*', '{0,}') {
123             for my $greedy ('', '?') {
124                 for my $flags ('', 'i', 'm', 'mi') {
125                     for my $s ('', 's') {
126                         my $XBOL = $s ? 'SBOL' : 'MBOL';
127                         my $text = "anchored($XBOL) implicit";
128                         fresh_perl_like(<<"PROG", qr/\b\Q$text\E\b/, {}, "/.${star}${greedy}X/${flags}${s} anchors implicitly");
129 BEGIN { \@INC = ('../lib', '.', '../ext/re'); }
130 use re 'debug';
131 qr/.${star}${greedy}:::\\s*ab/${flags}${s}
132 PROG
133                     }
134                 }
135             }
136         }
137     }
138
139 } # End of sub run_tests
140
141 1;