path: root/t/re/overload.t

#!./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();