diff options
author | Zefram <zefram@fysh.org> | 2010-12-12 21:10:22 +0000 |
---|---|---|
committer | Zefram <zefram@fysh.org> | 2010-12-12 21:29:05 +0000 |
commit | 6f32a03690842c43dc4256032abc6fce50665f23 (patch) | |
tree | 233010c9e0c43524040824c4326cc61f18aa71de | |
parent | 5fdbfdc805825683e878a94e68a2ba20fab426e7 (diff) | |
download | perl-zefram/pad_api.tar.gz |
API tests for pad_findmy_*()zefram/pad_api
-rw-r--r-- | MANIFEST | 1 | ||||
-rw-r--r-- | ext/XS-APItest/APItest.xs | 65 | ||||
-rw-r--r-- | ext/XS-APItest/t/pad_scalar.t | 75 |
3 files changed, 141 insertions, 0 deletions
@@ -3459,6 +3459,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 fd72ca9b3c..0ac5e7754c 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) @@ -2752,6 +2804,19 @@ BOOT: cv_set_call_checker(asscv, THX_ck_entersub_postinc, (SV*)asscv); } +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; |