#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
+#include "fakesdio.h" /* Causes us to use PerlIO below */
typedef SV *SVREF;
typedef PTR_TBL_t *XS__APItest__PtrTable;
THX_run_cleanup(pTHX_ void *cleanup_code_ref)
{
dSP;
+ PUSHSTACK;
ENTER;
SAVETMPS;
PUSHMARK(SP);
call_sv((SV*)cleanup_code_ref, G_VOID|G_DISCARD);
FREETMPS;
LEAVE;
+ POPSTACK;
}
STATIC OP *
static I32
filter_call(pTHX_ int idx, SV *buf_sv, int maxlen)
{
- SV *my_sv = FILTER_DATA(idx);
char *p;
char *end;
int n = FILTER_READ(idx + 1, buf_sv, maxlen);
#endif
+void
+test_force_keys(HV *hv)
+ PREINIT:
+ HE *he;
+ STRLEN count = 0;
+ PPCODE:
+ hv_iterinit(hv);
+ he = hv_iternext(hv);
+ while (he) {
+ SV *sv = HeSVKEY_force(he);
+ ++count;
+ EXTEND(SP, count);
+ PUSHs(sv_mortalcopy(sv));
+ he = hv_iternext(hv);
+ }
+
=pod
sub TIEHASH { bless {}, $_[0] }
AUTOLOADp(...)
PROTOTYPE: *$
CODE:
+ PERL_UNUSED_ARG(items);
RETVAL = newSVpvn_flags(SvPVX(cv), SvCUR(cv), SvUTF8(cv));
OUTPUT:
RETVAL
OUTPUT:
RETVAL
+IV
+xop_from_custom_op ()
+ CODE:
+/* author note: this test doesn't imply Perl_custom_op_xop is or isn't public
+ API or that Perl_custom_op_xop is known to be used outside the core */
+ UNOP *unop;
+ XOP *xop;
+
+ NewOp(1102, unop, 1, UNOP);
+ unop->op_type = OP_CUSTOM;
+ unop->op_ppaddr = pp_xop;
+ unop->op_flags = OPf_KIDS;
+ unop->op_private = 0;
+ unop->op_first = NULL;
+ unop->op_next = NULL;
+
+ xop = Perl_custom_op_xop(aTHX_ (OP *)unop);
+ FreeOp(unop);
+ RETVAL = PTR2IV(xop);
+ OUTPUT:
+ RETVAL
+
BOOT:
{
MY_CXT_INIT;
mXPUSHu(3);
XSRETURN(3);
+void
+call_sv_C()
+PREINIT:
+ CV * i_sub;
+ GV * i_gv;
+ I32 retcnt;
+ SV * errsv;
+ char * errstr;
+ SV * miscsv = sv_newmortal();
+ HV * hv = (HV*)sv_2mortal((SV*)newHV());
+CODE:
+ i_sub = get_cv("i", 0);
+ PUSHMARK(SP);
+ /* PUTBACK not needed since this sub was called with 0 args, and is calling
+ 0 args, so global SP doesn't need to be moved before a call_* */
+ retcnt = call_sv((SV*)i_sub, 0); /* try a CV* */
+ SPAGAIN;
+ SP -= retcnt; /* dont care about return count, wipe everything off */
+ sv_setpvs(miscsv, "i");
+ PUSHMARK(SP);
+ retcnt = call_sv(miscsv, 0); /* try a PV */
+ SPAGAIN;
+ SP -= retcnt;
+ /* no add and SVt_NULL are intentional, sub i should be defined already */
+ i_gv = gv_fetchpvn_flags("i", sizeof("i")-1, 0, SVt_NULL);
+ PUSHMARK(SP);
+ retcnt = call_sv((SV*)i_gv, 0); /* try a GV* */
+ SPAGAIN;
+ SP -= retcnt;
+ /* the tests below are not declaring this being public API behavior,
+ only current internal behavior, these tests can be changed in the
+ future if necessery */
+ PUSHMARK(SP);
+ retcnt = call_sv(&PL_sv_yes, 0); /* does nothing */
+ SPAGAIN;
+ SP -= retcnt;
+ PUSHMARK(SP);
+ retcnt = call_sv(&PL_sv_no, G_EVAL);
+ SPAGAIN;
+ SP -= retcnt;
+ errsv = ERRSV;
+ errstr = SvPV_nolen(errsv);
+ if(strnEQ(errstr, "Undefined subroutine &main:: called at",
+ sizeof("Undefined subroutine &main:: called at") - 1)) {
+ PUSHMARK(SP);
+ retcnt = call_sv((SV*)i_sub, 0); /* call again to increase counter */
+ SPAGAIN;
+ SP -= retcnt;
+ }
+ PUSHMARK(SP);
+ retcnt = call_sv(&PL_sv_undef, G_EVAL);
+ SPAGAIN;
+ SP -= retcnt;
+ errsv = ERRSV;
+ errstr = SvPV_nolen(errsv);
+ if(strnEQ(errstr, "Can't use an undefined value as a subroutine reference at",
+ sizeof("Can't use an undefined value as a subroutine reference at") - 1)) {
+ PUSHMARK(SP);
+ retcnt = call_sv((SV*)i_sub, 0); /* call again to increase counter */
+ SPAGAIN;
+ SP -= retcnt;
+ }
+ PUSHMARK(SP);
+ retcnt = call_sv((SV*)hv, G_EVAL);
+ SPAGAIN;
+ SP -= retcnt;
+ errsv = ERRSV;
+ errstr = SvPV_nolen(errsv);
+ if(strnEQ(errstr, "Not a CODE reference at",
+ sizeof("Not a CODE reference at") - 1)) {
+ PUSHMARK(SP);
+ retcnt = call_sv((SV*)i_sub, 0); /* call again to increase counter */
+ SPAGAIN;
+ SP -= retcnt;
+ }
void
call_sv(sv, flags, ...)
ALIAS:
newCONSTSUB_flags = 1
PREINIT:
- CV* mycv;
+ CV* mycv = NULL;
STRLEN len;
const char *pv = SvPV(name, len);
PPCODE:
PREINIT:
STRLEN len;
const char * const name = SvPV_const(methname, len);
- GV* gv;
+ GV* gv = NULL;
PPCODE:
switch (type) {
case 0:
PREINIT:
STRLEN len;
const char * const name = SvPV_const(methname, len);
- GV* gv;
+ GV* gv = NULL;
PPCODE:
switch (type) {
case 0:
int type
I32 flags
PREINIT:
- GV* gv;
+ GV* gv = NULL;
PPCODE:
switch (type) {
case 0:
PREINIT:
STRLEN len;
const char * const name = SvPV_const(methname, len);
- GV* gv;
+ GV* gv = NULL;
I32 flags = method ? GV_AUTOLOAD_ISMETHOD : 0;
PPCODE:
switch (type) {
PREINIT:
STRLEN len;
const char * const name = SvPV_const(namesv, len);
- I32 i;
+ I32 i = 0;
PPCODE:
switch (type) {
case 0:
test_rv2cv_op_cv()
PROTOTYPE:
PREINIT:
- GV *troc_gv, *wibble_gv;
+ GV *troc_gv;
CV *troc_cv;
OP *o;
CODE:
troc_gv = gv_fetchpv("XS::APItest::test_rv2cv_op_cv", 0, SVt_PVGV);
troc_cv = get_cv("XS::APItest::test_rv2cv_op_cv", 0);
- wibble_gv = gv_fetchpv("XS::APItest::wibble", 0, SVt_PVGV);
o = newCVREF(0, newGVOP(OP_GV, 0, troc_gv));
if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail();
if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv)
MULTICALL;
}
POP_MULTICALL;
+ PERL_UNUSED_VAR(newsp);
XSRETURN_UNDEF;
}
void
stringify(SV *sv)
-PREINIT:
- const char *pv;
CODE:
- pv = SvPV_nolen(sv);
+ (void)SvPV_nolen(sv);
SV *
HvENAME(HV *hv)
SV *
xs_cmp_undef(SV *a, SV *b)
CODE:
+ PERL_UNUSED_ARG(a);
+ PERL_UNUSED_ARG(b);
RETVAL = &PL_sv_undef;
OUTPUT:
RETVAL
CODE:
{
const I32 floor = start_subparse(0,0);
- CV * const cv = PL_compcv;
/* The slab allocator does not like CvROOT being set. */
CvROOT(PL_compcv) = (OP *)1;
op_free(newFOROP(0, 0, newOP(OP_PUSHMARK, 0), 0, 0));
SV* comms;
SV* class_and_method;
CODE:
+ PERL_UNUSED_ARG(items);
class_and_method = GvSV(CvGV(cv));
comms = get_sv("main::the_method", 1);
if (class_and_method == NULL) {
https://perl5.git.perl.org / perl5.git / blobdiff