In perl.git, the branch zefram/pad_api has been updated <http://perl5.git.perl.org/perl.git/commitdiff/b9a964e23d8f8ae74e1d750d25cd13ca7251e738?hp=5306b33bb667cbb8551f6323f04fbb61cb1368de>
- Log ----------------------------------------------------------------- commit b9a964e23d8f8ae74e1d750d25cd13ca7251e738 Author: Zefram <[email protected]> Date: Sun Dec 12 21:10:22 2010 +0000 API tests for pad_findmy_*() M MANIFEST M ext/XS-APItest/APItest.xs A ext/XS-APItest/t/pad_scalar.t commit 5fdbfdc805825683e878a94e68a2ba20fab426e7 Author: Zefram <[email protected]> Date: Sun Dec 12 20:09:00 2010 +0000 API test for find_rundefsv() M MANIFEST M ext/XS-APItest/APItest.xs A ext/XS-APItest/t/underscore_length.t ----------------------------------------------------------------------- Summary of changes: MANIFEST | 2 + ext/XS-APItest/APItest.xs | 79 ++++++++++++++++++++++++++++++++++ ext/XS-APItest/t/pad_scalar.t | 75 ++++++++++++++++++++++++++++++++ ext/XS-APItest/t/underscore_length.t | 20 +++++++++ 4 files changed, 176 insertions(+), 0 deletions(-) create mode 100644 ext/XS-APItest/t/pad_scalar.t create mode 100644 ext/XS-APItest/t/underscore_length.t diff --git a/MANIFEST b/MANIFEST index 084f8f1..9956ab6 100644 --- a/MANIFEST +++ b/MANIFEST @@ -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() @@ -3480,6 +3481,7 @@ ext/XS-APItest/t/svsetsv.t Test behaviour of sv_setsv with/without PERL_CORE ext/XS-APItest/t/swaplabel.t test recursive descent label parsing ext/XS-APItest/t/swaptwostmts.t test recursive descent statement parsing ext/XS-APItest/t/temp_lv_sub.t XS::APItest: tests for lvalue subs returning temps +ext/XS-APItest/t/underscore_length.t Test find_rundefsv() ext/XS-APItest/t/utf16_to_utf8.t Test behaviour of utf16_to_utf8{,reversed} ext/XS-APItest/t/utf8.t Tests for code in utf8.c ext/XS-APItest/t/xs_special_subs_require.t for require too diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 4e1e238..ae807d6 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(SvPAD_OUR(*av_fetch(PL_comppad_name, padoff, 0))) { + 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,33 @@ 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: +PREINIT: + SV *u; + U8 *pv; + STRLEN bytelen; +CODE: + u = find_rundefsv(); + pv = (U8*)SvPV(u, bytelen); + RETVAL = SvUTF8(u) ? utf8_length(pv, pv+bytelen) : bytelen; +OUTPUT: + RETVAL + MODULE = XS::APItest PACKAGE = XS::APItest::Magic PROTOTYPES: DISABLE diff --git a/ext/XS-APItest/t/pad_scalar.t b/ext/XS-APItest/t/pad_scalar.t new file mode 100644 index 0000000..52c8812 --- /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; diff --git a/ext/XS-APItest/t/underscore_length.t b/ext/XS-APItest/t/underscore_length.t new file mode 100644 index 0000000..7ca6906 --- /dev/null +++ b/ext/XS-APItest/t/underscore_length.t @@ -0,0 +1,20 @@ +use warnings; +use strict; + +use Test::More tests => 4; + +use XS::APItest qw(underscore_length); + +$_ = "foo"; +is underscore_length(), 3; + +$_ = "snowman \x{2603}"; +is underscore_length(), 9; + +my $_ = "xyzzy"; +is underscore_length(), 5; + +$_ = "pile of poo \x{1f4a9}"; +is underscore_length(), 13; + +1; -- Perl5 Master Repository
