Gecko [ www.blackthorn-inc.com ]

Name	Size	Permission	Date
charset.t	13.16 KB	-r--r--r--	2014-12-27 11:49
fold_grind.t	39.63 KB	-r--r--r--	2014-12-27 12:37
no_utf8_pm.t	500 B	-r--r--r--	2014-12-27 11:49
overload.t	5.94 KB	-r--r--r--	2014-12-27 11:49
pat.t	48.6 KB	-r--r--r--	2015-01-24 15:03
pat_advanced.t	87.75 KB	-r--r--r--	2014-12-27 11:49
pat_advanced_thr.t	56 B	-r--r--r--	2014-12-27 11:49
pat_psycho.t	6.42 KB	-r--r--r--	2014-12-27 12:37
pat_psycho_thr.t	56 B	-r--r--r--	2014-12-27 11:49
pat_re_eval.t	37.05 KB	-r--r--r--	2014-12-27 11:49
pat_re_eval_thr.t	56 B	-r--r--r--	2014-12-27 11:49
pat_rt_report.t	36.98 KB	-r--r--r--	2014-12-27 11:49
pat_rt_report_thr.t	56 B	-r--r--r--	2014-12-27 11:49
pat_special_cc.t	1.64 KB	-r--r--r--	2014-12-27 11:49
pat_special_cc_thr.t	56 B	-r--r--r--	2014-12-27 11:49
pat_thr.t	56 B	-r--r--r--	2014-12-27 11:49
pos.t	957 B	-r--r--r--	2014-12-27 11:49
qr-72922.t	1.12 KB	-r--r--r--	2014-12-27 11:49
qr.t	1.95 KB	-r--r--r--	2014-12-27 11:49
qr_gc.t	416 B	-r--r--r--	2014-12-27 11:49
qrstack.t	191 B	-r--r--r--	2014-12-27 11:49
re_tests	62.97 KB	-r--r--r--	2014-12-27 11:49
recompile.t	4.63 KB	-r--r--r--	2014-12-27 11:49
reg_60508.t	687 B	-r--r--r--	2014-12-27 11:49
reg_email.t	3.33 KB	-r--r--r--	2014-12-27 11:49
reg_email_thr.t	56 B	-r--r--r--	2014-12-27 11:49
reg_eval.t	2.35 KB	-r--r--r--	2014-12-27 11:49
reg_eval_scope.t	8.85 KB	-r--r--r--	2014-12-27 11:49
reg_fold.t	6.14 KB	-r--r--r--	2014-12-27 11:49
reg_mesg.t	24.47 KB	-r--r--r--	2014-12-27 11:49
reg_namedcapture.t	760 B	-r--r--r--	2014-12-27 11:49
reg_nc_tie.t	2.22 KB	-r--r--r--	2014-12-27 11:49
reg_pmod.t	2.1 KB	-r--r--r--	2014-12-27 11:49
reg_posixcc.t	4.92 KB	-r--r--r--	2014-12-27 11:49
regex_sets.t	4.62 KB	-r--r--r--	2014-12-27 11:49
regex_sets_compat.t	492 B	-r--r--r--	2014-12-27 11:49
regexp.t	14.42 KB	-r--r--r--	2014-12-27 11:49
regexp_noamp.t	257 B	-r--r--r--	2014-12-27 11:49
regexp_notrie.t	275 B	-r--r--r--	2014-12-27 11:49
regexp_qr.t	194 B	-r--r--r--	2014-12-27 11:49
regexp_qr_embed.t	209 B	-r--r--r--	2014-12-27 11:49
regexp_qr_embed_thr.t	235 B	-r--r--r--	2014-12-27 11:49
regexp_trielist.t	289 B	-r--r--r--	2014-12-27 11:49
regexp_unicode_prop.t	11.15 KB	-r--r--r--	2014-12-27 11:49
regexp_unicode_prop_thr.t	56 B	-r--r--r--	2014-12-27 11:49
rt122747.t	555 B	-r--r--r--	2015-01-10 12:06
rxcode.t	3.15 KB	-r--r--r--	2015-01-11 13:46
subst.t	24.25 KB	-r--r--r--	2014-12-27 11:49
substT.t	170 B	-r--r--r--	2014-12-27 11:49
subst_amp.t	1.45 KB	-r--r--r--	2014-12-27 11:49
subst_wamp.t	211 B	-r--r--r--	2014-12-27 11:49
uniprops.t	543 B	-r--r--r--	2014-12-27 12:37

Rename

#!./perl
#
# This is a home for regular expression tests that don't fit into
# the format supported by re/regexp.t.  If you want to add a test
# that does fit that format, add it to re/re_tests, not here.
#
# this file includes test that my burn a lot of CPU or otherwise be heavy
# on resources. Set env var $PERL_SKIP_PSYCHO_TEST to skip this file

use strict;
use warnings;
use 5.010;

sub run_tests;

$| = 1;

BEGIN {
    chdir 't' if -d 't';
    @INC = ('../lib','.');
    require './test.pl';
    if ($^O eq 'dec_osf') {
        skip_all("$^O cannot handle this test");
    }
}

skip_all('$PERL_SKIP_PSYCHO_TEST set') if $ENV{PERL_SKIP_PSYCHO_TEST};

plan tests => 15;  # Update this when adding/deleting tests.

run_tests() unless caller;

#
# Tests start here.
#
sub run_tests {
    print "# Set PERL_SKIP_PSYCHO_TEST to skip these tests\n";

{

# stress test tries

my @normal = qw [the are some normal words];

local $" = "|";

note "setting up trie psycho vars ...";
        my @psycho = (@normal, map chr $_, 255 .. 20000);
        my $psycho1 = "@psycho";
        for (my $i = @psycho; -- $i;) {
            my $j = int rand (1 + $i);
            @psycho [$i, $j] = @psycho [$j, $i];
        }
        my $psycho2 = "@psycho";

foreach my $word (@normal) {
            ok $word =~ /($psycho1)/ && $1 eq $word, qq{"$word" =~ /\$psycho1/};
            ok $word =~ /($psycho2)/ && $1 eq $word, qq{"$word" =~ /\$psycho1/};
        }
    }

{
        # stress test CURLYX/WHILEM.
        #
        # This test includes varying levels of nesting, and according to
        # profiling done against build 28905, exercises every code line in the
        # CURLYX and WHILEM blocks, except those related to LONGJMP, the
        # super-linear cache and warnings. It executes about 0.5M regexes

no warnings 'regexp';   # Silence "has useless greediness modifier"
        my $r = qr/^
                    (?:
                        ( (?:a|z+)+ )
                        (?:
                            ( (?:b|z+){3,}? )
                            (
                                (?:
                                    (?:
                                        (?:c|z+){1,1}?z
                                    )?
                                    (?:c|z+){1,1}
                                )*
                            )
                            (?:z*){2,}
                            ( (?:z+|d)+ )
                            (?:
                                ( (?:e|z+)+ )
                            )*
                            ( (?:f|z+)+ )
                        )*
                        ( (?:z+|g)+ )
                        (?:
                            ( (?:h|z+)+ )
                        )*
                        ( (?:i|z+)+ )
                    )+
                    ( (?:j|z+)+ )
                    (?:
                        ( (?:k|z+)+ )
                    )*
                    ( (?:l|z+)+ )
              $/x;
        use warnings 'regexp';
          
        my $ok = 1;
        my $msg = "CURLYX stress test";
        OUTER:
          for my $a ("x","a","aa") {
            for my $b ("x","bbb","bbbb") {
              my $bs = $a.$b;
              for my $c ("x","c","cc") {
                my $cs = $bs.$c;
                for my $d ("x","d","dd") {
                  my $ds = $cs.$d;
                  for my $e ("x","e","ee") {
                    my $es = $ds.$e;
                    for my $f ("x","f","ff") {
                      my $fs = $es.$f;
                      for my $g ("x","g","gg") {
                        my $gs = $fs.$g;
                        for my $h ("x","h","hh") {
                          my $hs = $gs.$h;
                          for my $i ("x","i","ii") {
                            my $is = $hs.$i;
                            for my $j ("x","j","jj") {
                              my $js = $is.$j;
                              for my $k ("x","k","kk") {
                                my $ks = $js.$k;
                                for my $l ("x","l","ll") {
                                  my $ls = $ks.$l;
                                  if ($ls =~ $r) {
                                    if ($ls =~ /x/) {
                                      $msg .= ": unexpected match for [$ls]";
                                      $ok = 0;
                                      last OUTER;
                                    }
                                    my $cap = "$1$2$3$4$5$6$7$8$9$10$11$12";
                                    unless ($ls eq $cap) {
                                      $msg .= ": capture: [$ls], got [$cap]";
                                      $ok = 0;
                                      last OUTER;
                                    }
                                  }
                                  else {
                                    unless ($ls =~ /x/) {
                                      $msg = ": failed for [$ls]";
                                      $ok = 0;
                                      last OUTER;
                                    }
                                  }
                                }
                              }
                            }
                          }
                        }
                      }
                    }
                  }
                }
              }
            }
        }
        ok($ok, $msg);
    }

{
	# these bits of test code used to run quadratically. If we break
	# anything, they'll start to take minutes to run, rather than
	# seconds. We don't actually measure times or set alarms, since
	# that tends to be very fragile and prone to false positives.
	# Instead, just hope that if someone is messing with
	# performance-related code, they'll re-run the test suite and
	# notice it suddenly takes a lot longer.

my $x;

$x = 'x' x 1_000_000;
	1 while $x =~ /(.)/g;
	pass "ascii =~ /(.)/";

{
	    local ${^UTF8CACHE} = 1; # defeat debugging
	    $x = "\x{100}" x 1_000_000;
	    1 while $x =~ /(.)/g;
	    pass "utf8 =~ /(.)/";
	}

# run these in separate processes, since they set $&

fresh_perl_is(<<'EOF', "ok\n", {}, 'ascii =~ /(.)/, mention $&');
$&;
$x = 'x' x 1_000_000;
1 while $x =~ /(.)/g;
print "ok\n";
EOF

fresh_perl_is(<<'EOF', "ok\n", {}, 'utf8 =~ /(.)/, mention $&');
$&;
local ${^UTF8CACHE} = 1; # defeat debugging
$x = "\x{100}" x 1_000_000;
1 while $x =~ /(.)/g;
print "ok\n";
EOF

}
} # End of sub run_tests