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

# Check that we don't recompile runtime patterns when the pattern hasn't
# changed
#
# Works by checking the debugging output of 'use re debug' and, if
# available, -Dr. We use both to check that the different code paths
# with Perl_foo() verses the my_foo() under ext/re/ don't cause any
# changes.

use strict;
use warnings;

$| = 1;

BEGIN {
    chdir 't' if -d 't';
    @INC = ('../lib','.');
    require './test.pl';
    skip_all_if_miniperl("no dynamic loading on miniperl, no re");
}

plan tests => 48;

my $results = runperl(
			switches => [ '-Dr' ],
			prog => '1',
			stderr   => 1,
		    );
my $has_Dr = $results !~ /Recompile perl with -DDEBUGGING/;

my $tmpfile = tempfile();

# Check that a pattern triggers a regex compilation exactly N times,
# using either -Dr or 'use re debug'
# This is partially based on _fresh_perl() in test.pl

sub _comp_n {
    my ($use_Dr, $n, $prog, $desc) = @_;
    open my $tf, ">$tmpfile" or die "Cannot open $tmpfile: $!";

my $switches = [];
    if ($use_Dr) {
	push @$switches, '-Dr';
    }
    else {
	$prog = qq{use re qw(debug);\n$prog};
    }

print $tf $prog;
    close $tf or die "Cannot close $tmpfile: $!";
    my $results = runperl(
			switches => $switches,
			progfile => $tmpfile,
			stderr   => 1,
		    );

my $status = $?;

my $count = () = $results =~ /Final program:/g;
    if ($count == $n && !$status) {
	pass($desc);
    }
    else {
	fail($desc);
        _diag "# COUNT:    $count EXPECTED $n\n";
        _diag "# STATUS:   $status\n";
        _diag "# SWITCHES: @$switches\n";
        _diag "# PROG: \n$prog\n";
	# this is verbose; uncomment for debugging
        #_diag "# OUTPUT:\n------------------\n $results-------------------\n";
    }
}

# Check that a pattern triggers a regex compilation exactly N times,

sub comp_n {
    my ($n, $prog, $desc) = @_;
    if ($has_Dr) {
	_comp_n(1, $n, $prog, "$desc -Dr");
    }
    else {
	SKIP: {
	    skip("-Dr not compiled in");
	}
    }
    _comp_n(0, @_);
}

# Check that a pattern triggers a regex compilation exactly once.

sub comp_1 {
    comp_n(1, @_);
}

comp_1(<<'CODE', 'simple');
"a" =~ /$_/ for qw(a a a);
CODE

comp_1(<<'CODE', 'simple qr');
"a" =~ qr/$_/ for qw(a a a);
CODE

comp_1(<<'CODE', 'literal utf8');
"a" =~ /$_/ for "\x{100}", "\x{100}", "\x{100}";
CODE

comp_1(<<'CODE', 'literal utf8 qr');
"a" =~ qr/$_/ for "\x{100}", "\x{100}", "\x{100}";
CODE

comp_1(<<'CODE', 'longjmp literal utf8');
my $x = chr(0x80);
"a" =~ /$x$_/ for "\x{100}", "\x{100}", "\x{100}";
CODE

comp_1(<<'CODE', 'longjmp literal utf8 qr');
my $x = chr(0x80);
"a" =~ qr/$x$_/ for "\x{100}", "\x{100}", "\x{100}";
CODE

comp_1(<<'CODE', 'utf8');
"a" =~ /$_/ for '\x{100}', '\x{100}', '\x{100}';
CODE

comp_1(<<'CODE', 'utf8 qr');
"a" =~ qr/$_/ for '\x{100}', '\x{100}', '\x{100}';
CODE

comp_1(<<'CODE', 'longjmp utf8');
my $x = chr(0x80);
"a" =~ /$x$_/ for '\x{100}', '\x{100}', '\x{100}';
CODE

comp_1(<<'CODE', 'longjmp utf8');
my $x = chr(0x80);
"a" =~ qr/$x$_/ for '\x{100}', '\x{100}', '\x{100}';
CODE

comp_n(3, <<'CODE', 'mixed utf8');
"a" =~ /$_/ for "\x{c4}\x{80}",  "\x{100}", "\x{c4}\x{80}";
CODE

comp_n(3, <<'CODE', 'mixed utf8 qr');
"a" =~ qr/$_/ for "\x{c4}\x{80}",  "\x{100}", "\x{c4}\x{80}";
CODE

# note that that for runtime code, each pattern is compiled twice; the
# second time to allow the parser to see the code.

comp_n(6, <<'CODE', 'runtime code');
my $x = '(?{1})';
BEGIN { $^H |= 0x00200000 } # lightweight "use re 'eval'"
"a" =~ /a$_/ for $x, $x, $x;
CODE

comp_n(6, <<'CODE', 'runtime code qr');
my $x = '(?{1})';
BEGIN { $^H |= 0x00200000 } # lightweight "use re 'eval'"
"a" =~ qr/a$_/ for $x, $x, $x;
CODE

comp_n(4, <<'CODE', 'embedded code');
my $x = qr/(?{1})/;
"a" =~ /a$_/ for $x, $x, $x;
CODE

comp_n(4, <<'CODE', 'embedded code qr');
my $x = qr/(?{1})/;
"a" =~ qr/a$_/ for $x, $x, $x;
CODE

comp_n(7, <<'CODE', 'mixed code');
my $x = qr/(?{1})/;
my $y = '(?{1})';
BEGIN { $^H |= 0x00200000 } # lightweight "use re 'eval'"
"a" =~ /a$x$_/ for $y, $y, $y;
CODE

comp_n(7, <<'CODE', 'mixed code qr');
my $x = qr/(?{1})/;
my $y = '(?{1})';
BEGIN { $^H |= 0x00200000 } # lightweight "use re 'eval'"
"a" =~ qr/a$x$_/ for $y, $y, $y;
CODE

comp_n(6, <<'CODE', 'embedded code qr');
my $x = qr/a/i;
my $y = qr/a/;
"a" =~ qr/a$_/ for $x, $y, $x, $y;
CODE

comp_n(2, <<'CODE', '(??{"constant"})');
"bb" =~ /(??{"abc"})/;
CODE

comp_n(2, <<'CODE', '(??{"folded"."constant"})');
"bb" =~ /(??{"ab"."c"})/;
CODE

comp_n(2, <<'CODE', '(??{$preused_scalar})');
$s = "abc";
"bb" =~ /(??{$s})/;
CODE

comp_n(2, <<'CODE', '(??{number})');
"bb" =~ /(??{123})/;
CODE

comp_n(2, <<'CODE', '(??{$pvlv_regexp})');
sub {
   $_[0] = ${qr/abc/};
  "bb" =~ /(??{$_[0]})/;
}->($_[0]);
CODE