API tests for pad_findmy_*()

3 files changed, 141 insertions, 0 deletions

diff --git a/MANIFEST b/MANIFEST
index 291409ff1d..c0ec18469a 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -3741,6 +3741,7 @@ ext/XS-APItest/t/op_contextualize.t	test op_contextualize() API
 ext/XS-APItest/t/op_list.t	test OP list construction API
 ext/XS-APItest/t/op.t		XS::APItest: tests for OP related APIs
 ext/XS-APItest/t/overload.t	XS::APItest: tests for overload related APIs
+ext/XS-APItest/t/pad_scalar.t	Test pad_findmy_* functions
 ext/XS-APItest/t/peep.t		test PL_peepp/PL_rpeepp
 ext/XS-APItest/t/pmflag.t	Test removal of Perl_pmflag()
 ext/XS-APItest/t/postinc.t	test op_lvalue()
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index d3d7274fca..14415aad47 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -587,6 +587,58 @@ THX_ck_entersub_postinc(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
 	op_lvalue(op_contextualize(argop, G_SCALAR), OP_POSTINC));
 }
 
+STATIC OP *
+THX_ck_entersub_pad_scalar(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
+{
+    OP *pushop, *argop;
+    PADOFFSET padoff = NOT_IN_PAD;
+    SV *a0, *a1;
+    ck_entersub_args_proto(entersubop, namegv, ckobj);
+    pushop = cUNOPx(entersubop)->op_first;
+    if(!pushop->op_sibling) pushop = cUNOPx(pushop)->op_first;
+    argop = pushop->op_sibling;
+    if(argop->op_type != OP_CONST || argop->op_sibling->op_type != OP_CONST)
+	croak("bad argument expression type for pad_scalar()");
+    a0 = cSVOPx_sv(argop);
+    a1 = cSVOPx_sv(argop->op_sibling);
+    switch(SvIV(a0)) {
+	case 1: {
+	    SV *namesv = sv_2mortal(newSVpvs("$"));
+	    sv_catsv(namesv, a1);
+	    padoff = pad_findmy_sv(namesv, 0);
+	} break;
+	case 2: {
+	    char *namepv;
+	    STRLEN namelen;
+	    SV *namesv = sv_2mortal(newSVpvs("$"));
+	    sv_catsv(namesv, a1);
+	    namepv = SvPV(namesv, namelen);
+	    padoff = pad_findmy_pvn(namepv, namelen, 0);
+	} break;
+	case 3: {
+	    char *namepv;
+	    SV *namesv = sv_2mortal(newSVpvs("$"));
+	    sv_catsv(namesv, a1);
+	    namepv = SvPV_nolen(namesv);
+	    padoff = pad_findmy_pv(namepv, 0);
+	} break;
+	case 4: {
+	    padoff = pad_findmy_pvs("$foo", 0);
+	} break;
+	default: croak("bad type value for pad_scalar()");
+    }
+    op_free(entersubop);
+    if(padoff == NOT_IN_PAD) {
+	return newSVOP(OP_CONST, 0, newSVpvs("NOT_IN_PAD"));
+    } else if(PAD_COMPNAME_FLAGS_isOUR(padoff)) {
+	return newSVOP(OP_CONST, 0, newSVpvs("NOT_MY"));
+    } else {
+	OP *padop = newOP(OP_PADSV, 0);
+	padop->op_targ = padoff;
+	return padop;
+    }
+}
+
 /** RPN keyword parser **/
 
 #define sv_is_glob(sv) (SvTYPE(sv) == SVt_PVGV)
@@ -2861,6 +2913,19 @@ CODE:
 OUTPUT:
     RETVAL
 
+void
+pad_scalar(...)
+PROTOTYPE: $$
+CODE:
+    PERL_UNUSED_VAR(items);
+    croak("pad_scalar called as a function");
+
+BOOT:
+{
+    CV *pscv = get_cv("XS::APItest::pad_scalar", 0);
+    cv_set_call_checker(pscv, THX_ck_entersub_pad_scalar, (SV*)pscv);
+}
+
 STRLEN
 underscore_length()
 PROTOTYPE:
diff --git a/ext/XS-APItest/t/pad_scalar.t b/ext/XS-APItest/t/pad_scalar.t
new file mode 100644
index 0000000000..52c8812c6b
--- /dev/null
+++ b/ext/XS-APItest/t/pad_scalar.t
@@ -0,0 +1,75 @@
+use warnings;
+use strict;
+
+use Test::More tests => 76;
+
+use XS::APItest qw(pad_scalar);
+
+is pad_scalar(1, "foo"), "NOT_IN_PAD";
+is pad_scalar(2, "foo"), "NOT_IN_PAD";
+is pad_scalar(3, "foo"), "NOT_IN_PAD";
+is pad_scalar(4, "foo"), "NOT_IN_PAD";
+is pad_scalar(1, "bar"), "NOT_IN_PAD";
+is pad_scalar(2, "bar"), "NOT_IN_PAD";
+is pad_scalar(3, "bar"), "NOT_IN_PAD";
+
+our $foo = "wibble";
+my $bar = "wobble";
+is pad_scalar(1, "foo"), "NOT_MY";
+is pad_scalar(2, "foo"), "NOT_MY";
+is pad_scalar(3, "foo"), "NOT_MY";
+is pad_scalar(4, "foo"), "NOT_MY";
+is pad_scalar(1, "bar"), "wobble";
+is pad_scalar(2, "bar"), "wobble";
+is pad_scalar(3, "bar"), "wobble";
+
+sub aa($);
+sub aa($) {
+    my $xyz;
+    ok \pad_scalar(1, "xyz") == \$xyz;
+    ok \pad_scalar(2, "xyz") == \$xyz;
+    ok \pad_scalar(3, "xyz") == \$xyz;
+    aa(0) if $_[0];
+    ok \pad_scalar(1, "xyz") == \$xyz;
+    ok \pad_scalar(2, "xyz") == \$xyz;
+    ok \pad_scalar(3, "xyz") == \$xyz;
+    is pad_scalar(1, "bar"), "wobble";
+    is pad_scalar(2, "bar"), "wobble";
+    is pad_scalar(3, "bar"), "wobble";
+}
+aa(1);
+
+sub bb() {
+    my $counter = 0;
+    my $foo = \$counter;
+    return sub {
+	ok pad_scalar(1, "foo") == \pad_scalar(1, "counter");
+	ok pad_scalar(2, "foo") == \pad_scalar(1, "counter");
+	ok pad_scalar(3, "foo") == \pad_scalar(1, "counter");
+	ok pad_scalar(4, "foo") == \pad_scalar(1, "counter");
+	if(pad_scalar(1, "counter") % 3 == 0) {
+	    return pad_scalar(1, "counter")++;
+	} elsif(pad_scalar(1, "counter") % 3 == 0) {
+	    return pad_scalar(2, "counter")++;
+	} else {
+	    return pad_scalar(3, "counter")++;
+	}
+    };
+}
+my $a = bb();
+my $b = bb();
+is $a->(), 0;
+is $a->(), 1;
+is $a->(), 2;
+is $a->(), 3;
+is $b->(), 0;
+is $b->(), 1;
+is $a->(), 4;
+is $b->(), 2;
+
+is pad_scalar(1, "foo"), "NOT_MY";
+is pad_scalar(2, "foo"), "NOT_MY";
+is pad_scalar(3, "foo"), "NOT_MY";
+is pad_scalar(4, "foo"), "NOT_MY";
+
+1;