const char *const end = p + len;
while (p < end) {
STRLEN len;
- UV chr = utf8_to_uvuni((U8 *)p, &len);
+ UV chr = utf8_to_uvuni_buf((U8 *)p, (U8 *) end, &len);
new_p = (char *)uvuni_to_utf8((U8 *)new_p, chr ^ 32);
p += len;
}
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, SvUTF8(namesv));
+ } break;
+ case 3: {
+ char *namepv;
+ SV *namesv = sv_2mortal(newSVpvs("$"));
+ sv_catsv(namesv, a1);
+ namepv = SvPV_nolen(namesv);
+ padoff = pad_findmy_pv(namepv, SvUTF8(namesv));
+ } 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)
}
if(s-start < 2) croak("RPN syntax error");
lex_read_to(s);
- {
- /* because pad_findmy() doesn't really use length yet */
- SV *namesv = sv_2mortal(newSVpvn(start, s-start));
- varpos = pad_findmy(SvPVX(namesv), s-start, 0);
- }
+ varpos = pad_findmy_pvn(start, s-start, 0);
if(varpos == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(varpos))
croak("RPN only supports \"my\" variables");
padop = newOP(OP_PADSV, 0);
OP *sop = parse_barestmt(0);
SV *label = parse_label(PARSE_OPTIONAL);
if (label) sv_2mortal(label);
- return newSTATEOP(0, label ? savepv(SvPVX(label)) : NULL, sop);
+ return newSTATEOP(label ? SvUTF8(label) : 0,
+ label ? savepv(SvPVX(label)) : NULL,
+ sop);
}
#define parse_keyword_labelconst() THX_parse_keyword_labelconst(aTHX)
return SvCUR(buf_sv);
}
+static AV *
+myget_linear_isa(pTHX_ HV *stash, U32 level) {
+ GV **gvp = (GV **)hv_fetchs(stash, "ISA", 0);
+ PERL_UNUSED_ARG(level);
+ return gvp && *gvp && GvAV(*gvp)
+ ? GvAV(*gvp)
+ : (AV *)sv_2mortal((SV *)newAV());
+}
+
-XS(XS_XS__APItest__XSUB_XS_VERSION_undef);
-XS(XS_XS__APItest__XSUB_XS_VERSION_empty);
-XS(XS_XS__APItest__XSUB_XS_APIVERSION_invalid);
+XS_EXTERNAL(XS_XS__APItest__XSUB_XS_VERSION_undef);
+XS_EXTERNAL(XS_XS__APItest__XSUB_XS_VERSION_empty);
+XS_EXTERNAL(XS_XS__APItest__XSUB_XS_APIVERSION_invalid);
+
+static struct mro_alg mymro;
+
+static Perl_check_t addissub_nxck_add;
+
+static OP *
+addissub_myck_add(pTHX_ OP *op)
+{
+ SV **flag_svp = hv_fetchs(GvHV(PL_hintgv), "XS::APItest/addissub", 0);
+ OP *aop, *bop;
+ U8 flags;
+ if (!(flag_svp && SvTRUE(*flag_svp) && (op->op_flags & OPf_KIDS) &&
+ (aop = cBINOPx(op)->op_first) && (bop = aop->op_sibling) &&
+ !bop->op_sibling))
+ return addissub_nxck_add(aTHX_ op);
+ aop->op_sibling = NULL;
+ cBINOPx(op)->op_first = NULL;
+ op->op_flags &= ~OPf_KIDS;
+ flags = op->op_flags;
+ op_free(op);
+ return newBINOP(OP_SUBTRACT, flags, aop, bop);
+}
#include "const-c.inc"
OUTPUT:
RETVAL
+AV *
+test_utf8n_to_uvuni(s, len, flags)
+
+ SV *s
+ SV *len
+ SV *flags
+ PREINIT:
+ STRLEN retlen;
+ UV ret;
+ STRLEN slen;
+
+ CODE:
+ /* Call utf8n_to_uvuni() with the inputs. It always asks for the
+ * actual length to be returned
+ *
+ * Length to assume <s> is; not checked, so could have buffer overflow
+ */
+ RETVAL = newAV();
+ sv_2mortal((SV*)RETVAL);
+
+ ret
+ = utf8n_to_uvuni((U8*) SvPV(s, slen), SvUV(len), &retlen, SvUV(flags));
+
+ /* Returns the return value in [0]; <retlen> in [1] */
+ av_push(RETVAL, newSVuv(ret));
+ if (retlen == (STRLEN) -1) {
+ av_push(RETVAL, newSViv(-1));
+ }
+ else {
+ av_push(RETVAL, newSVuv(retlen));
+ }
+
+ OUTPUT:
+ RETVAL
+
MODULE = XS::APItest:Overload PACKAGE = XS::APItest::Overload
void
ptr_table_clear(table)
XS::APItest::PtrTable table
+MODULE = XS::APItest::AutoLoader PACKAGE = XS::APItest::AutoLoader
+
+SV *
+AUTOLOAD()
+ CODE:
+ RETVAL = newSVpvn_flags(SvPVX(cv), SvCUR(cv), SvUTF8(cv));
+ OUTPUT:
+ RETVAL
+
+SV *
+AUTOLOADp(...)
+ PROTOTYPE: *$
+ CODE:
+ RETVAL = newSVpvn_flags(SvPVX(cv), SvCUR(cv), SvUTF8(cv));
+ OUTPUT:
+ RETVAL
+
+
MODULE = XS::APItest PACKAGE = XS::APItest
PROTOTYPES: DISABLE
+BOOT:
+ mymro.resolve = myget_linear_isa;
+ mymro.name = "justisa";
+ mymro.length = 7;
+ mymro.kflags = 0;
+ mymro.hash = 0;
+ Perl_mro_register(aTHX_ &mymro);
+
HV *
xop_custom_ops ()
CODE:
PUSHs(sv_2mortal(newSViv(i)));
void
+newCONSTSUB_type(stash, name, flags, type, sv)
+ HV* stash
+ SV* name
+ I32 flags
+ int type
+ SV* sv
+ PREINIT:
+ CV* cv;
+ STRLEN len;
+ const char *pv = SvPV(name, len);
+ PPCODE:
+ switch (type) {
+ case 0:
+ cv = newCONSTSUB(stash, pv, SvOK(sv) ? sv : NULL);
+ break;
+ case 1:
+ cv = newCONSTSUB_flags(
+ stash, pv, len, flags | SvUTF8(name), SvOK(sv) ? sv : NULL
+ );
+ break;
+ }
+ EXTEND(SP, 2);
+ PUSHs( CvCONST(cv) ? &PL_sv_yes : &PL_sv_no );
+ PUSHs((SV*)CvGV(cv));
+
+void
+gv_init_type(namesv, multi, flags, type)
+ SV* namesv
+ int multi
+ I32 flags
+ int type
+ PREINIT:
+ STRLEN len;
+ const char * const name = SvPV_const(namesv, len);
+ GV *gv = *(GV**)hv_fetch(PL_defstash, name, len, TRUE);
+ PPCODE:
+ if (SvTYPE(gv) == SVt_PVGV)
+ Perl_croak(aTHX_ "GV is already a PVGV");
+ if (multi) flags |= GV_ADDMULTI;
+ switch (type) {
+ case 0:
+ gv_init(gv, PL_defstash, name, len, multi);
+ break;
+ case 1:
+ gv_init_sv(gv, PL_defstash, namesv, flags);
+ break;
+ case 2:
+ gv_init_pv(gv, PL_defstash, name, flags | SvUTF8(namesv));
+ break;
+ case 3:
+ gv_init_pvn(gv, PL_defstash, name, len, flags | SvUTF8(namesv));
+ break;
+ }
+ XPUSHs( gv ? (SV*)gv : &PL_sv_undef);
+
+void
+gv_fetchmeth_type(stash, methname, type, level, flags)
+ HV* stash
+ SV* methname
+ int type
+ I32 level
+ I32 flags
+ PREINIT:
+ STRLEN len;
+ const char * const name = SvPV_const(methname, len);
+ GV* gv;
+ PPCODE:
+ switch (type) {
+ case 0:
+ gv = gv_fetchmeth(stash, name, len, level);
+ break;
+ case 1:
+ gv = gv_fetchmeth_sv(stash, methname, level, flags);
+ break;
+ case 2:
+ gv = gv_fetchmeth_pv(stash, name, level, flags | SvUTF8(methname));
+ break;
+ case 3:
+ gv = gv_fetchmeth_pvn(stash, name, len, level, flags | SvUTF8(methname));
+ break;
+ }
+ XPUSHs( gv ? MUTABLE_SV(gv) : &PL_sv_undef );
+
+void
+gv_fetchmeth_autoload_type(stash, methname, type, level, flags)
+ HV* stash
+ SV* methname
+ int type
+ I32 level
+ I32 flags
+ PREINIT:
+ STRLEN len;
+ const char * const name = SvPV_const(methname, len);
+ GV* gv;
+ PPCODE:
+ switch (type) {
+ case 0:
+ gv = gv_fetchmeth_autoload(stash, name, len, level);
+ break;
+ case 1:
+ gv = gv_fetchmeth_sv_autoload(stash, methname, level, flags);
+ break;
+ case 2:
+ gv = gv_fetchmeth_pv_autoload(stash, name, level, flags | SvUTF8(methname));
+ break;
+ case 3:
+ gv = gv_fetchmeth_pvn_autoload(stash, name, len, level, flags | SvUTF8(methname));
+ break;
+ }
+ XPUSHs( gv ? MUTABLE_SV(gv) : &PL_sv_undef );
+
+void
+gv_fetchmethod_flags_type(stash, methname, type, flags)
+ HV* stash
+ SV* methname
+ int type
+ I32 flags
+ PREINIT:
+ GV* gv;
+ PPCODE:
+ switch (type) {
+ case 0:
+ gv = gv_fetchmethod_flags(stash, SvPVX_const(methname), flags);
+ break;
+ case 1:
+ gv = gv_fetchmethod_sv_flags(stash, methname, flags);
+ break;
+ case 2:
+ gv = gv_fetchmethod_pv_flags(stash, SvPV_nolen(methname), flags | SvUTF8(methname));
+ break;
+ case 3: {
+ STRLEN len;
+ const char * const name = SvPV_const(methname, len);
+ gv = gv_fetchmethod_pvn_flags(stash, name, len, flags | SvUTF8(methname));
+ break;
+ }
+ }
+ XPUSHs( gv ? (SV*)gv : &PL_sv_undef);
+
+void
+gv_autoload_type(stash, methname, type, method)
+ HV* stash
+ SV* methname
+ int type
+ I32 method
+ PREINIT:
+ STRLEN len;
+ const char * const name = SvPV_const(methname, len);
+ GV* gv;
+ I32 flags = method ? GV_AUTOLOAD_ISMETHOD : 0;
+ PPCODE:
+ switch (type) {
+ case 0:
+ gv = gv_autoload4(stash, name, len, method);
+ break;
+ case 1:
+ gv = gv_autoload_sv(stash, methname, flags);
+ break;
+ case 2:
+ gv = gv_autoload_pv(stash, name, flags | SvUTF8(methname));
+ break;
+ case 3:
+ gv = gv_autoload_pvn(stash, name, len, flags | SvUTF8(methname));
+ break;
+ }
+ XPUSHs( gv ? (SV*)gv : &PL_sv_undef);
+
+void
+whichsig_type(namesv, type)
+ SV* namesv
+ int type
+ PREINIT:
+ STRLEN len;
+ const char * const name = SvPV_const(namesv, len);
+ I32 i;
+ PPCODE:
+ switch (type) {
+ case 0:
+ i = whichsig(name);
+ break;
+ case 1:
+ i = whichsig_sv(namesv);
+ break;
+ case 2:
+ i = whichsig_pv(name);
+ break;
+ case 3:
+ i = whichsig_pvn(name, len);
+ break;
+ }
+ XPUSHs(sv_2mortal(newSViv(i)));
+
+void
eval_sv(sv, flags)
SV* sv
I32 flags
sv_setsv_cow_hashkey_notcore()
void
+sv_set_deref(SV *sv, SV *sv2, int which)
+ CODE:
+ {
+ STRLEN len;
+ const char *pv = SvPV(sv2,len);
+ if (!SvROK(sv)) croak("Not a ref");
+ sv = SvRV(sv);
+ switch (which) {
+ case 0: sv_setsv(sv,sv2); break;
+ case 1: sv_setpv(sv,pv); break;
+ case 2: sv_setpvn(sv,pv,len); break;
+ }
+ }
+
+void
rmagical_cast(sv, type)
SV *sv;
SV *type;
#undef msvpvs
#undef msviv
+void
+test_coplabel()
+ PREINIT:
+ COP *cop;
+ const char *label;
+ STRLEN len;
+ U32 utf8;
+ CODE:
+ cop = &PL_compiling;
+ Perl_cop_store_label(aTHX_ cop, "foo", 3, 0);
+ label = Perl_cop_fetch_label(aTHX_ cop, &len, &utf8);
+ if (strcmp(label,"foo")) croak("fail # cop_fetch_label label");
+ if (len != 3) croak("fail # cop_fetch_label len");
+ if (utf8) croak("fail # cop_fetch_label utf8");
+ /* SMALL GERMAN UMLAUT A */
+ Perl_cop_store_label(aTHX_ cop, "fo\xc3\xa4", 4, SVf_UTF8);
+ label = Perl_cop_fetch_label(aTHX_ cop, &len, &utf8);
+ if (strcmp(label,"fo\xc3\xa4")) croak("fail # cop_fetch_label label");
+ if (len != 4) croak("fail # cop_fetch_label len");
+ if (!utf8) croak("fail # cop_fetch_label utf8");
+
+
HV *
example_cophh_2hv()
PREINIT:
HeVAL(entry) = NULL;
}
+HV *
+newHVhv(HV *hv)
+CODE:
+ RETVAL = newHVhv(hv);
+OUTPUT:
+ RETVAL
+
+bool
+SvIsCOW(SV *sv)
+CODE:
+ RETVAL = SvIsCOW(sv);
+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);
+}
+
+SV*
+fetch_pad_names( cv )
+CV* cv
+ PREINIT:
+ I32 i;
+ AV *pad_namelist;
+ AV *retav = newAV();
+ CODE:
+ pad_namelist = (AV*) *av_fetch(CvPADLIST(cv), 0, FALSE);
+
+ for ( i = av_len(pad_namelist); i >= 0; i-- ) {
+ SV** name_ptr = av_fetch(pad_namelist, i, 0);
+
+ if (name_ptr && SvPOKp(*name_ptr)) {
+ av_push(retav, newSVsv(*name_ptr));
+ }
+ }
+ RETVAL = newRV_noinc((SV*)retav);
+ OUTPUT:
+ RETVAL
+
+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
+
+void
+stringify(SV *sv)
+PREINIT:
+ const char *pv;
+CODE:
+ pv = SvPV_nolen(sv);
+
+SV *
+HvENAME(HV *hv)
+CODE:
+ RETVAL = hv && HvENAME(hv)
+ ? newSVpvn_flags(
+ HvENAME(hv),HvENAMELEN(hv),
+ (HvENAMEUTF8(hv) ? SVf_UTF8 : 0)
+ )
+ : NULL;
+OUTPUT:
+ RETVAL
+
+int
+xs_cmp(int a, int b)
+CODE:
+ /* Odd sorting (odd numbers first), to make sure we are actually
+ being called */
+ RETVAL = a % 2 != b % 2
+ ? a % 2 ? -1 : 1
+ : a < b ? -1 : a == b ? 0 : 1;
+OUTPUT:
+ RETVAL
+
+SV *
+xs_cmp_undef(SV *a, SV *b)
+CODE:
+ RETVAL = &PL_sv_undef;
+OUTPUT:
+ RETVAL
+
+char *
+SvPVbyte(SV *sv)
+CODE:
+ RETVAL = SvPVbyte_nolen(sv);
+OUTPUT:
+ RETVAL
+
+char *
+SvPVutf8(SV *sv)
+CODE:
+ RETVAL = SvPVutf8_nolen(sv);
+OUTPUT:
+ RETVAL
+
+void
+setup_addissub()
+CODE:
+ wrap_op_checker(OP_ADD, addissub_myck_add, &addissub_nxck_add);
+
+#ifdef USE_ITHREADS
+
+bool
+test_alloccopstash()
+CODE:
+ RETVAL = PL_stashpad[alloccopstash(PL_defstash)] == PL_defstash;
+OUTPUT:
+ RETVAL
+
+#endif
+
+MODULE = XS::APItest PACKAGE = XS::APItest::AUTOLOADtest
+
+int
+AUTOLOAD(...)
+ INIT:
+ SV* comms;
+ SV* class_and_method;
+ SV* tmp;
+ CODE:
+ class_and_method = GvSV(CvGV(cv));
+ comms = get_sv("main::the_method", 1);
+ if (class_and_method == NULL) {
+ RETVAL = 1;
+ } else if (!SvOK(class_and_method)) {
+ RETVAL = 2;
+ } else if (!SvPOK(class_and_method)) {
+ RETVAL = 3;
+ } else {
+ sv_setsv(comms, class_and_method);
+ RETVAL = 0;
+ }
+ OUTPUT: RETVAL
+
+
MODULE = XS::APItest PACKAGE = XS::APItest::Magic
PROTOTYPES: DISABLE
#ifdef USE_LOCALE_COLLATE
test_get_this_vtable(collxfrm);
#endif
- test_get_this_vtable(amagic);
- test_get_this_vtable(amagicelem);
test_get_this_vtable(backref);
test_get_this_vtable(utf8);
https://perl5.git.perl.org / perl5.git / blobdiff