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 -w

BEGIN {
    chdir 't' if -d 't';
    @INC = '../lib';
    require './test.pl';
}

use strict;
no  warnings 'syntax';

{
    # Bug #77084 points out a corruption problem when scalar //g is used
    # on overloaded objects.

my @realloc;
    my $TAG = "foo:bar";
    use overload '""' => sub {$TAG};

my $o = bless [];
    my ($one) = $o =~ /(.*)/g;
    push @realloc, "xxxxxx"; # encourage realloc of SV and PVX
    is $one, $TAG, "list context //g against overloaded object";

my $r = $o =~ /(.*)/g;
    push @realloc, "yyyyyy"; # encourage realloc of SV and PVX
    is $1, $TAG, "scalar context //g against overloaded object";
    pos ($o) = 0;  # Reset pos, as //g in scalar context sets it to non-0.

$o =~ /(.*)/g;
    push @realloc, "zzzzzz"; # encourage realloc of SV and PVX
    is $1, $TAG, "void context //g against overloaded object";
}

{
    # an overloaded stringify returning itself shouldn't loop indefinitely

{
	package Self;
	use overload q{""} => sub {
		    return shift;
		},
	    fallback => 1;
    }

my $obj = bless [], 'Self';
    my $r = qr/$obj/;
    pass("self object, 1 arg");
    $r = qr/foo$obj/;
    pass("self object, 2 args");
}

{
    # [perl #116823]
    # when overloading regex string constants, a different code path
    # was taken if the regex was compile-time, leading to overloaded
    # regex constant string segments not being handled correctly.
    # They were just treated as OP_CONST strings to be concatted together.
    # In particular, if the overload returned a regex object, it would
    # just be stringified rather than having any code blocks processed.

BEGIN {
	overload::constant qr => sub {
	    my ($raw, $cooked, $type) = @_;
	    return $cooked unless defined $::CONST_QR_CLASS;
	    if ($type =~ /qq?/) {
		return bless \$cooked, $::CONST_QR_CLASS;
	    } else {
		return $cooked;
	    }
	};
    }

{
	# returns a qr// object

package OL_QR;
	use overload q{""} => sub {
		my $re = shift;
		return qr/(?{ $OL_QR::count++ })$$re/;
	    },
	fallback => 1;

}

{
	# returns a string

package OL_STR;
	use overload q{""} => sub {
		my $re = shift;
		return qq/(?{ \$OL_STR::count++ })$$re/;
	    },
	fallback => 1;

}

{
	# returns chr(str)

package OL_CHR;
	use overload q{""} => sub {
		my $chr = shift;
		return chr($$chr);
	    },
	fallback => 1;

}

my $qr;

$::CONST_QR_CLASS = 'OL_QR';

$OL_QR::count = 0;
    $qr = eval q{ qr/^foo$/; };
    ok("foo" =~ $qr, "compile-time, OL_QR, single constant segment");
    is($OL_QR::count, 1, "flag");

$OL_QR::count = 0;
    $qr = eval q{ qr/^foo$(?{ $OL_QR::count++ })/; };
    ok("foo" =~ $qr, "compile-time, OL_QR, multiple constant segments");
    is($OL_QR::count, 2, "qr2 flag");

# test /foo.../ when foo is given string overloading,
    # for various permutations of '...'

$::CONST_QR_CLASS = 'OL_STR';

for my $has_re_eval (0, 1) {
	for my $has_qr (0, 1) {
	    for my $has_code (0, 1) {
		for my $has_runtime (0, 1) {
		    for my $has_runtime_code (0, 1) {
			if ($has_runtime_code) {
			    next unless $has_runtime;
			}
			note( "re_eval=$has_re_eval "
			    . "qr=$has_qr "
			    . "code=$has_code "
			    . "runtime=$has_runtime "
			    . "runtime_code=$has_runtime_code");
			my $eval = '';
			$eval .= q{use re 'eval'; } if $has_re_eval;
			$eval .= q{$match = $str =~ };
			$eval .= q{qr} if $has_qr;
			$eval .= q{/^abc};
			$eval .= q{(?{$blocks++})} if $has_code;
			$eval .= q{$runtime} if $has_runtime;
			$eval .= q{/; 1;};

my $runtime = q{def};
			$runtime .= q{(?{$run_blocks++})} if $has_runtime_code;

my $blocks = 0;
			my $run_blocks = 0;
			my $match;
			my $str = "abc";
			$str .= "def" if $runtime;

my $result = eval $eval;
			my $err = $@;
			$result = $result ? 1 : 0;

if (!$has_re_eval) {
			    is($result, 0, "EVAL: $eval");
			    like($err, qr/Eval-group not allowed at runtime/,
				"\$\@:   $eval");
			    next;
			}

is($result, 1, "EVAL: $eval");
			diag("\$@=[$err]") unless $result;

is($match, 1, "MATCH: $eval");
			is($blocks, $has_code, "blocks");
			is($run_blocks, $has_runtime_code, "run_blocks");

}
		}
	    }
	}
    }

# if the pattern gets (undetectably in advance) upgraded to utf8
    # while being concatenated, it could mess up the alignment of the code
    # blocks, giving rise to 'Eval-group not allowed at runtime' errs.

$::CONST_QR_CLASS = 'OL_CHR';

{
	my $count = 0;
	is(eval q{ "\x80\x{100}" =~ /128(?{ $count++ })256/ }, 1,
	    "OL_CHR eval + match");
	is($count, 1, "OL_CHR count");
    }

undef $::CONST_QR_CLASS;
}

{
    # [perl #115004]
    # array interpolation within patterns should handle qr overloading
    # (like it does for scalar vars)

{
	package P115004;
	use overload 'qr' => sub { return  qr/a/ };
    }

my $o = bless [], 'P115004';
    my @a = ($o);

ok("a" =~ /^$o$/, "qr overloading with scalar var interpolation");
    ok("a" =~ /^@a$/, "qr overloading with array var interpolation");

}

{

# if the pattern gets silently re-parsed, ensure that any eval'ed
    # code blocks get the correct lexical scope. The overloading of
    # concat, along with the modification of the text of the code block,
    # ensures that it has to be re-compiled.

{
	package OL_MOD;
	use overload
	    q{""} => sub { my ($pat) = @_; $pat->[0] },
	    q{.}  => sub {
			    my ($a1, $a2) = @_;
			    $a1 = $a1->[0] if ref $a1;
			    $a2 = $a2->[0] if ref $a2;
			    my $s = "$a1$a2";
			    $s =~ s/x_var/y_var/;
			    bless [ $s ];
		     },
	;
    }

BEGIN {
	overload::constant qr => sub { bless [ $_[0] ], 'OL_MOD' };
    }

$::x_var  =		# duplicate to avoid 'only used once' warning
    $::x_var  = "ABC";
    my $x_var = "abc";

$::y_var  =		# duplicate to avoid 'only used once' warning
    $::y_var  = "XYZ";
    my $y_var    = "xyz";

use re 'eval';
    my $a = 'a';
    ok("xyz"  =~ m{^(??{ $x_var })$},   "OL_MOD");
    ok("xyza" =~ m{^(??{ $x_var })$a$}, "OL_MOD runtime");
}

done_testing();