HV* Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create) { char smallbuf[256]; char *tmpbuf; HV *stash; GV *tmpgv; if (namelen + 3 < sizeof smallbuf) tmpbuf = smallbuf; else New(606, tmpbuf, namelen + 3, char); Copy(name,tmpbuf,namelen,char); tmpbuf[namelen++] = ':'; tmpbuf[namelen++] = ':'; tmpbuf[namelen] = '\0'; tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV); if (tmpbuf != smallbuf) Safefree(tmpbuf); if (!tmpgv) return 0; if (!GvHV(tmpgv)) GvHV(tmpgv) = newHV(); stash = GvHV(tmpgv); if (!HvNAME(stash)) HvNAME(stash) = savepv(name); return stash; }
/* Converts perl values to equivalent JavaScript values */ JSBool PJS_ConvertPerlToJSType(JSContext *cx, JSObject *seen, JSObject *obj, SV *ref, jsval *rval) { int destroy_seen = 0; /* TODO - do we _need_ to clean up after us? */ if (sv_isobject(ref) && strcmp(HvNAME(SvSTASH(SvRV(ref))), PJS_BOXED_PACKAGE) == 0) { /* XXX: test this more */ ref = *av_fetch((AV *) SvRV(SvRV(ref)), 0, 0); } if (sv_isobject(ref)) { /* blessed */ PJS_Context *pcx; PJS_Class *pjsc; JSObject *newobj; HV *stash = SvSTASH(SvRV(ref)); char *name = HvNAME(stash); if (strcmp(name, PJS_FUNCTION_PACKAGE) == 0) { JSFunction *func = INT2PTR(JSFunction *, SvIV((SV *) SvRV(PJS_call_perl_method("content", ref, NULL)))); JSObject *obj = JS_GetFunctionObject(func); *rval = OBJECT_TO_JSVAL(obj); return JS_TRUE; } if (strcmp(name, PJS_GENERATOR_PACKAGE) == 0) { JSObject *obj = INT2PTR(JSObject *, SvIV((SV *) SvRV(PJS_call_perl_method("content", ref, NULL)))); *rval = OBJECT_TO_JSVAL(obj); return JS_TRUE; }
GV* Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) { char autoload[] = "AUTOLOAD"; STRLEN autolen = sizeof(autoload)-1; GV* gv; CV* cv; HV* varstash; GV* vargv; SV* varsv; if (len == autolen && strnEQ(name, autoload, autolen)) return Nullgv; if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE))) return Nullgv; cv = GvCV(gv); if (!CvROOT(cv)) return Nullgv; /* * Inheriting AUTOLOAD for non-methods works ... for now. */ if (ckWARN(WARN_DEPRECATED) && !method && (GvCVGEN(gv) || GvSTASH(gv) != stash)) Perl_warner(aTHX_ WARN_DEPRECATED, "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated", HvNAME(stash), (int)len, name); /* * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name. * The subroutine's original name may not be "AUTOLOAD", so we don't * use that, but for lack of anything better we will use the sub's * original package to look up $AUTOLOAD. */ varstash = GvSTASH(CvGV(cv)); vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE); ENTER; #ifdef USE_THREADS sv_lock((SV *)varstash); #endif if (!isGV(vargv)) gv_init(vargv, varstash, autoload, autolen, FALSE); LEAVE; varsv = GvSV(vargv); #ifdef USE_THREADS sv_lock(varsv); #endif sv_setpv(varsv, HvNAME(stash)); sv_catpvn(varsv, "::", 2); sv_catpvn(varsv, name, len); SvTAINTED_off(varsv); return gv; }
static SV *modperl_hv_request_find(pTHX_ SV *in, char *classname, CV *cv) { static char *r_keys[] = { "r", "_r", NULL }; HV *hv = (HV *)SvRV(in); SV *sv = (SV *)NULL; int i; for (i=0; r_keys[i]; i++) { int klen = i + 1; /* assumes r_keys[] will never change */ SV **svp; if ((svp = hv_fetch(hv, r_keys[i], klen, FALSE)) && (sv = *svp)) { if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVHV)) { /* dig deeper */ return modperl_hv_request_find(aTHX_ sv, classname, cv); } break; } } if (!sv) { Perl_croak(aTHX_ "method `%s' invoked by a `%s' object with no `r' key!", cv ? GvNAME(CvGV(cv)) : "unknown", (SvRV(in) && SvSTASH(SvRV(in))) ? HvNAME(SvSTASH(SvRV(in))) : "unknown"); } return SvROK(sv) ? SvRV(sv) : sv; }
modperl_handler_t *modperl_handler_new_from_sv(pTHX_ apr_pool_t *p, SV *sv) { char *name = NULL; GV *gv; if (SvROK(sv)) { sv = SvRV(sv); } switch (SvTYPE(sv)) { case SVt_PV: name = SvPVX(sv); return modperl_handler_new(p, apr_pstrdup(p, name)); break; case SVt_PVCV: if (CvANON((CV*)sv)) { return modperl_handler_new_anon(aTHX_ p, (CV*)sv); } if (!(gv = CvGV((CV*)sv))) { Perl_croak(aTHX_ "can't resolve the code reference"); } name = apr_pstrcat(p, HvNAME(GvSTASH(gv)), "::", GvNAME(gv), NULL); return modperl_handler_new(p, name); default: break; }; return NULL; }
static void S_attributes__push_fetch(pTHX_ SV *sv) { dSP; switch (SvTYPE(sv)) { case SVt_PVCV: { cv_flags_t cvflags = CvFLAGS((const CV *)sv); if (cvflags & CVf_LVALUE) { XPUSHs(newSVpvs_flags("lvalue", SVs_TEMP)); } if (cvflags & CVf_METHOD) { XPUSHs(newSVpvs_flags("method", SVs_TEMP)); } if (cvflags & CVf_PURE) { XPUSHs(newSVpvs_flags("pure", SVs_TEMP)); } if (cvflags & CVf_TYPED) { HV *typestash = CvTYPE((CV*)sv); XPUSHs(newSVpvn_flags(HvNAME(typestash), HvNAMELEN(typestash), SVs_TEMP|HvNAMEUTF8(typestash))); } break; } default: break; } PUTBACK; }
int mop_get_code_info (SV *coderef, char **pkg, char **name) { if (!SvOK(coderef) || !SvROK(coderef) || SvTYPE(SvRV(coderef)) != SVt_PVCV) { return 0; } coderef = SvRV(coderef); /* sub is still being compiled */ if (!CvGV(coderef)) { return 0; } /* I think this only gets triggered with a mangled coderef, but if we hit it without the guard, we segfault. The slightly odd return value strikes me as an improvement (mst) */ if ( isGV_with_GP(CvGV(coderef)) ) { GV *gv = CvGV(coderef); *pkg = HvNAME( GvSTASH(gv) ? GvSTASH(gv) : CvSTASH(coderef) ); *name = GvNAME( CvGV(coderef) ); } else { *pkg = "__UNKNOWN__"; *name = "__ANON__"; } return 1; }
GV * Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) { register const char *nend; const char *nsplit = 0; GV* gv; for (nend = name; *nend; nend++) { if (*nend == '\'') nsplit = nend; else if (*nend == ':' && *(nend + 1) == ':') nsplit = ++nend; } if (nsplit) { const char *origname = name; name = nsplit + 1; if (*nsplit == ':') --nsplit; if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) { /* ->SUPER::method should really be looked up in original stash */ SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER", CopSTASHPV(PL_curcop))); stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE); DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n", origname, HvNAME(stash), name) ); } else stash = gv_stashpvn(origname, nsplit - origname, TRUE); } gv = gv_fetchmeth(stash, name, nend - name, 0); if (!gv) { if (strEQ(name,"import") || strEQ(name,"unimport")) gv = (GV*)&PL_sv_yes; else if (autoload) gv = gv_autoload4(stash, name, nend - name, TRUE); } else if (autoload) { CV* cv = GvCV(gv); if (!CvROOT(cv) && !CvXSUB(cv)) { GV* stubgv; GV* autogv; if (CvANON(cv)) stubgv = gv; else { stubgv = CvGV(cv); if (GvCV(stubgv) != cv) /* orphaned import */ stubgv = gv; } autogv = gv_autoload4(GvSTASH(stubgv), GvNAME(stubgv), GvNAMELEN(stubgv), TRUE); if (autogv) gv = autogv; } } return gv; }
void Point::from_SV_check(SV* point_sv) { if (sv_isobject(point_sv) && (SvTYPE(SvRV(point_sv)) == SVt_PVMG)) { if (!sv_isa(point_sv, perl_class_name(this)) && !sv_isa(point_sv, perl_class_name_ref(this))) CONFESS("Not a valid %s object (got %s)", perl_class_name(this), HvNAME(SvSTASH(SvRV(point_sv)))); *this = *(Point*)SvIV((SV*)SvRV( point_sv )); } else { this->from_SV(point_sv); } }
SV * PerlIOVia_method(pTHX_ PerlIO * f, char *method, CV ** save, int flags, ...) { PerlIOVia *s = PerlIOSelf(f, PerlIOVia); CV *cv = (*save) ? *save : PerlIOVia_fetchmethod(aTHX_ s, method, save); SV *result = Nullsv; va_list ap; va_start(ap, flags); if (cv != (CV *) - 1) { IV count; dSP; SV *arg; PUSHSTACKi(PERLSI_MAGIC); ENTER; SPAGAIN; PUSHMARK(sp); XPUSHs(s->obj); while ((arg = va_arg(ap, SV *))) { XPUSHs(arg); } if (*PerlIONext(f)) { if (!s->fh) { GV *gv = newGVgen(HvNAME(s->stash)); GvIOp(gv) = newIO(); s->fh = newRV_noinc((SV *) gv); s->io = GvIOp(gv); } IoIFP(s->io) = PerlIONext(f); IoOFP(s->io) = PerlIONext(f); XPUSHs(s->fh); } else { PerlIO_debug("No next\n"); /* FIXME: How should this work for OPEN etc? */ } PUTBACK; count = call_sv((SV *) cv, flags); if (count) { SPAGAIN; result = POPs; PUTBACK; } else { result = &PL_sv_undef; } LEAVE; POPSTACK; }
CV * PerlIOVia_fetchmethod(pTHX_ PerlIOVia * s, char *method, CV ** save) { GV *gv = gv_fetchmeth(s->stash, method, strlen(method), 0); #if 0 Perl_warn(aTHX_ "Lookup %s::%s => %p", HvNAME(s->stash), method, gv); #endif if (gv) { return *save = GvCV(gv); } else { return *save = (CV *) - 1; } }
SV *p5_call_parent_method(PerlInterpreter *my_perl, char *package, SV *obj, I32 context, char *name, int len, SV *args[], I32 *count, I32 *err, I32 *type) { PERL_SET_CONTEXT(my_perl); { dSP; int i; SV * retval = NULL; int flags = (context ? G_SCALAR : G_ARRAY) | G_EVAL; ENTER; SAVETMPS; HV * const pkg = package != NULL ? gv_stashpv(package, 0) : SvSTASH((SV*)SvRV(obj)); GV * const gv = Perl_gv_fetchmethod_autoload(aTHX_ pkg, name, TRUE); if (gv && isGV(gv)) { PUSHMARK(SP); if (len > 1) { XPUSHs(package != NULL ? sv_2mortal(args[0]) : args[0]); for (i = 1; i < len; i++) { if (args[i] != NULL) /* skip Nil which gets turned into NULL */ XPUSHs(sv_2mortal(args[i])); } } else if (len > 0) if (args != NULL) /* skip Nil which gets turned into NULL */ XPUSHs(package != NULL ? sv_2mortal((SV*)args) : (SV*)args); PUTBACK; SV * const rv = sv_2mortal(newRV((SV*)GvCV(gv))); *count = call_sv(rv, flags); SPAGAIN; handle_p5_error(err); retval = pop_return_values(my_perl, sp, *count, type); SPAGAIN; } else { ERRSV = newSVpvf("Could not find method \"%s\" of \"%s\" object", name, HvNAME(pkg)); } PUTBACK; FREETMPS; LEAVE; return retval; } }
AV *p5_call_method(PerlInterpreter *my_perl, char *package, SV *obj, char *name, int len, SV *args[]) { dSP; int i; AV * const retval = newAV(); int flags = G_ARRAY | G_EVAL; PERL_SET_CONTEXT(my_perl); ENTER; SAVETMPS; HV * const pkg = package != NULL ? gv_stashpv(package, 0) : SvSTASH((SV*)SvRV(obj)); GV * const gv = Perl_gv_fetchmethod_autoload(aTHX_ pkg, name, TRUE); if (gv && isGV(gv)) { I32 count; PUSHMARK(SP); for (i = 0; i < len; i++) { XPUSHs(sv_2mortal(args[i])); } PUTBACK; SV * const rv = sv_2mortal(newRV((SV*)GvCV(gv))); count = call_sv(rv, flags); SPAGAIN; if (count > 0) av_extend(retval, count - 1); for (i = count - 1; i >= 0; i--) { SV * const next = POPs; SvREFCNT_inc(next); if (av_store(retval, i, next) == NULL) SvREFCNT_dec(next); /* see perlguts Working with AVs */ } } else { ERRSV = newSVpvf("Could not find method \"%s\" of \"%s\" object", name, HvNAME(pkg)); } PUTBACK; FREETMPS; LEAVE; return retval; }
MP_INLINE int modperl_io_handle_tied(pTHX_ GV *handle, char *classname) { MAGIC *mg; SV *sv = TIEHANDLE_SV(handle); if (SvMAGICAL(sv) && (mg = mg_find(sv, PERL_MAGIC_tiedscalar))) { char *package = HvNAME(SvSTASH((SV*)SvRV(mg->mg_obj))); if (!strEQ(package, classname)) { MP_TRACE_r(MP_FUNC, "%s tied to %s", GvNAME(handle), package); return TRUE; } } return FALSE; }
STATIC void S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params) { const GV *const gv = CvGV(cv); PERL_ARGS_ASSERT_CROAK_XS_USAGE; if (gv) { const char *const gvname = GvNAME(gv); const HV *const stash = GvSTASH(gv); const char *const hvname = stash ? HvNAME(stash) : NULL; if (hvname) Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params); else Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params); } else { /* Pants. I don't think that it should be possible to get here. */ Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params); } }
STATIC SV * S_isa_lookup(pTHX_ HV *stash, const char *name, int len, int level) { AV* av; GV* gv; GV** gvp; HV* hv = Nullhv; SV* subgen = Nullsv; if (!stash) return &PL_sv_undef; if (strEQ(HvNAME(stash), name)) return &PL_sv_yes; if (level > 100) Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'", HvNAME(stash)); gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE); if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv)) && (hv = GvHV(gv))) { if (SvIV(subgen) == PL_sub_generation) { SV* sv; SV** svp = (SV**)hv_fetch(hv, name, len, FALSE); if (svp && (sv = *svp) != (SV*)&PL_sv_undef) { DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n", name, HvNAME(stash)) ); return sv; } } else { DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n", HvNAME(stash)) ); hv_clear(hv); sv_setiv(subgen, PL_sub_generation); } } gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE); if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) { if (!hv || !subgen) { gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE); gv = *gvp; if (SvTYPE(gv) != SVt_PVGV) gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE); if (!hv) hv = GvHVn(gv); if (!subgen) { subgen = newSViv(PL_sub_generation); GvSV(gv) = subgen; } } if (hv) { SV** svp = AvARRAY(av); /* NOTE: No support for tied ISA */ I32 items = AvFILLp(av) + 1; while (items--) { SV* sv = *svp++; HV* basestash = gv_stashsv(sv, FALSE); if (!basestash) { if (ckWARN(WARN_MISC)) Perl_warner(aTHX_ WARN_SYNTAX, "Can't locate package %s for @%s::ISA", SvPVX(sv), HvNAME(stash)); continue; } if (&PL_sv_yes == isa_lookup(basestash, name, len, level + 1)) { (void)hv_store(hv,name,len,&PL_sv_yes,0); return &PL_sv_yes; } } (void)hv_store(hv,name,len,&PL_sv_no,0); } } return boolSV(strEQ(name, "UNIVERSAL")); }
GV * Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) { register const char *name = nambeg; register GV *gv = 0; GV**gvp; I32 len; register const char *namend; HV *stash = 0; if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */ name++; for (namend = name; *namend; namend++) { if ((*namend == ':' && namend[1] == ':') || (*namend == '\'' && namend[1])) { if (!stash) stash = PL_defstash; if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */ return Nullgv; len = namend - name; if (len > 0) { char smallbuf[256]; char *tmpbuf; if (len + 3 < sizeof smallbuf) tmpbuf = smallbuf; else New(601, tmpbuf, len+3, char); Copy(name, tmpbuf, len, char); tmpbuf[len++] = ':'; tmpbuf[len++] = ':'; tmpbuf[len] = '\0'; gvp = (GV**)hv_fetch(stash,tmpbuf,len,add); gv = gvp ? *gvp : Nullgv; if (gv && gv != (GV*)&PL_sv_undef) { if (SvTYPE(gv) != SVt_PVGV) gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI)); else GvMULTI_on(gv); } if (tmpbuf != smallbuf) Safefree(tmpbuf); if (!gv || gv == (GV*)&PL_sv_undef) return Nullgv; if (!(stash = GvHV(gv))) stash = GvHV(gv) = newHV(); if (!HvNAME(stash)) HvNAME(stash) = savepvn(nambeg, namend - nambeg); } if (*namend == ':') namend++; namend++; name = namend; if (!*name) return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE); } }
/* =for apidoc mro_get_linear_isa Returns the mro linearisation for the given stash. By default, this will be whatever C<mro_get_linear_isa_dfs> returns unless some other MRO is in effect for the stash. The return value is a read-only AV*. You are responsible for C<SvREFCNT_inc()> on the return value if you plan to store it anywhere semi-permanently (otherwise it might be deleted out from under you the next time the cache is invalidated). =cut */ AV* Perl_mro_get_linear_isa(pTHX_ HV *stash) { struct mro_meta* meta; AV *isa; PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA; if(!SvOOK(stash)) Perl_croak(aTHX_ "Can't linearize anonymous symbol table"); meta = HvMROMETA(stash); if (!meta->mro_which) Perl_croak(aTHX_ "panic: invalid MRO!"); isa = meta->mro_which->resolve(aTHX_ stash, 0); if (meta->mro_which != &dfs_alg) { /* skip for dfs, for speed */ SV * const namesv = (HvENAME(stash)||HvNAME(stash)) ? newSVhek(HvENAME_HEK(stash) ? HvENAME_HEK(stash) : HvNAME_HEK(stash)) : NULL; if(namesv && (AvFILLp(isa) == -1 || !sv_eq(*AvARRAY(isa), namesv))) { AV * const old = isa; SV **svp; SV **ovp = AvARRAY(old); SV * const * const oend = ovp + AvFILLp(old) + 1; isa = (AV *)sv_2mortal((SV *)newAV()); av_extend(isa, AvFILLp(isa) = AvFILLp(old)+1); *AvARRAY(isa) = namesv; svp = AvARRAY(isa)+1; while (ovp < oend) *svp++ = SvREFCNT_inc(*ovp++); } else SvREFCNT_dec(namesv); } if (!meta->isa) { HV *const isa_hash = newHV(); /* Linearisation didn't build it for us, so do it here. */ SV *const *svp = AvARRAY(isa); SV *const *const svp_end = svp + AvFILLp(isa) + 1; const HEK *canon_name = HvENAME_HEK(stash); if (!canon_name) canon_name = HvNAME_HEK(stash); while (svp < svp_end) { (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0); } (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name), HEK_LEN(canon_name), HEK_FLAGS(canon_name), HV_FETCH_ISSTORE, &PL_sv_undef, HEK_HASH(canon_name)); (void) hv_store(isa_hash, "UNIVERSAL", 9, &PL_sv_undef, 0); SvREADONLY_on(isa_hash); meta->isa = isa_hash; } return isa; }
void c_test (int max){ int i; for (f=1) } #line 23 "ko_6_1_0_perllint_01cc.c" #ifndef PERL_UNUSED_VAR # define PERL_UNUSED_VAR(var) if (0) var = var #endif #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE #define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params) /* prototype to pass -Wmissing-prototypes */ STATIC void S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params); STATIC void S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params) { const GV *const gv = CvGV(cv); PERL_ARGS_ASSERT_CROAK_XS_USAGE; if (gv) { const char *const gvname = GvNAME(gv); const HV *const stash = GvSTASH(gv); const char *const hvname = stash ? HvNAME(stash) : NULL; if (hvname) Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params); else Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params); } else { /* Pants. I don't think that it should be possible to get here. */ Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params); } } #undef PERL_ARGS_ASSERT_CROAK_XS_USAGE #ifdef PERL_IMPLICIT_CONTEXT #define croak_xs_usage(a,b) S_croak_xs_usage(aTHX_ a,b) #else #define croak_xs_usage S_croak_xs_usage #endif #endif /* NOTE: the prototype of newXSproto() is different in versions of perls, * so we define a portable version of newXSproto() */ #ifdef newXS_flags #define newXSproto_portable(name, c_impl, file, proto) newXS_flags(name, c_impl, file, proto, 0) #else #define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv) #endif /* !defined(newXS_flags) */ #line 75 "ko_6_1_0_perllint_01cc.c" XS(XS_main_c_test); /* prototype to pass -Wmissing-prototypes */ XS(XS_main_c_test) { #ifdef dVAR dVAR; dXSARGS; #else dXSARGS; #endif if (items != 1) croak_xs_usage(cv, "max"); PERL_UNUSED_VAR(ax); /* -Wall */ SP -= items; { int max = (int)SvIV(ST(0)); #line 22 "ko_6_1_0_perllint_01cc.xs" I32* temp; #line 93 "ko_6_1_0_perllint_01cc.c" #line 24 "ko_6_1_0_perllint_01cc.xs" temp = PL_markstack_ptr++; c_test(max); if (PL_markstack_ptr != temp) { /* truly void, because dXSARGS not invoked */ PL_markstack_ptr = temp; XSRETURN_EMPTY; /* return empty stack */ } /* must have used dXSARGS; list context implied */ return; /* assume stack size is correct */ #line 104 "ko_6_1_0_perllint_01cc.c" PUTBACK; return; } } #ifdef __cplusplus extern "C" #endif XS(boot_ko_6_1_0_perllint_01cc); /* prototype to pass -Wmissing-prototypes */ XS(boot_ko_6_1_0_perllint_01cc) { #ifdef dVAR dVAR; dXSARGS; #else dXSARGS; #endif #if (PERL_REVISION == 5 && PERL_VERSION < 9) char* file = __FILE__; #else const char* file = __FILE__; #endif PERL_UNUSED_VAR(cv); /* -W */ PERL_UNUSED_VAR(items); /* -W */ XS_VERSION_BOOTCHECK ; newXS("main::c_test", XS_main_c_test, file); #if (PERL_REVISION == 5 && PERL_VERSION >= 9) if (PL_unitcheckav) call_list(PL_scopestack_ix, PL_unitcheckav); #endif XSRETURN_YES; }
static GPtrArray * do_marshal (CV *cv, I32 ax, I32 items, CORBA_InterfaceDef_FullInterfaceDescription *desc, I32 index, CORBA_Object obj, GIOPConnection *connection, GIOP_unsigned_long request_id) { OpNameData *operation_name_data; static struct iovec operation_vec; char *name = NULL; GIOPSendBuffer *send_buffer = NULL; SV *error_sv = NULL; GPtrArray *return_types = NULL; dTHR; /* Determine the operation name used over GIOP */ if (index >= PORBIT_OPERATION_BASE && index < PORBIT_GETTER_BASE) { name = g_strdup (desc->operations._buffer[index-PORBIT_OPERATION_BASE].name); } else if (index >= PORBIT_GETTER_BASE && index < PORBIT_SETTER_BASE) { name = g_strconcat ("_get_", desc->attributes._buffer[index-PORBIT_GETTER_BASE].name, NULL); } else if (index >= PORBIT_SETTER_BASE) { name = g_strconcat ("_set_", desc->attributes._buffer[index-PORBIT_SETTER_BASE].name, NULL); } /* Create a SendBuffer for the result */ operation_name_data = (OpNameData *)g_malloc (sizeof (OpNameData) + strlen(name)); operation_name_data->len = strlen(name) + 1; strcpy (operation_name_data->opname, name); operation_vec.iov_base = operation_name_data; operation_vec.iov_len = sizeof(CORBA_unsigned_long) + operation_name_data->len; send_buffer = giop_send_request_buffer_use(connection, NULL, request_id, !IS_ONEWAY(desc,index), &(obj->active_profile->object_key_vec), &operation_vec, &ORBit_default_principal_iovec); if (!send_buffer) { error_sv = porbit_system_except ("IDL:omg.org/CORBA/COMM_FAILURE:1.0", 0, CORBA_COMPLETED_NO); goto exception; } /* Do the marshalling. We accumulate the return types into an array for * use while demarshalling. */ return_types = g_ptr_array_new(); if (index >= PORBIT_OPERATION_BASE && index < PORBIT_GETTER_BASE) { CORBA_OperationDescription *opr = &desc->operations._buffer[index-PORBIT_OPERATION_BASE]; CORBA_unsigned_long i, st_index; if (opr->result->kind != CORBA_tk_void) g_ptr_array_add (return_types, opr->result); st_index = 1; for (i = 0 ; i<opr->parameters._length; i++) { SV *arg = (st_index<(CORBA_unsigned_long)items) ? ST(st_index) : &PL_sv_undef; switch (opr->parameters._buffer[i].mode) { case CORBA_PARAM_IN: if (!porbit_put_sv (send_buffer, opr->parameters._buffer[i].type, arg)) { warn ("Error marshalling parameter '%s'", opr->parameters._buffer[i].name); error_sv = porbit_system_except ("IDL:omg.org/CORBA/MARSHAL:1.0", 0, CORBA_COMPLETED_NO); goto exception; } st_index++; break; case CORBA_PARAM_INOUT: if (!SvROK(arg) || !porbit_put_sv (send_buffer, opr->parameters._buffer[i].type, SvRV (arg))) { if (!SvROK (arg)) warn ("INOUT parameter must be a reference"); else warn ("Error marshalling parameter '%s'", opr->parameters._buffer[i].name); error_sv = porbit_system_except ("IDL:omg.org/CORBA/MARSHAL:1.0", 0, CORBA_COMPLETED_NO); goto exception; } st_index++; /* Fall through */ case CORBA_PARAM_OUT: g_ptr_array_add (return_types, opr->parameters._buffer[i].type); break; } } } else if (index >= PORBIT_GETTER_BASE && index < PORBIT_SETTER_BASE) { g_ptr_array_add (return_types, desc->attributes._buffer[index-PORBIT_GETTER_BASE].type); } else if (index >= PORBIT_SETTER_BASE) { if (items < 2) { warn("%s::%s called without second argument", HvNAME(CvSTASH(cv)), name); error_sv = porbit_system_except ("IDL:omg.org/CORBA/MARSHAL:1.0", 0, CORBA_COMPLETED_NO); goto exception; } if (!porbit_put_sv (send_buffer, desc->attributes._buffer[index-PORBIT_SETTER_BASE].type, ST(1))) { warn ("Error marshalling attribute value"); error_sv = porbit_system_except ("IDL:omg.org/CORBA/MARSHAL:1.0", 0, CORBA_COMPLETED_NO); goto exception; } } /* Invoke the operation */ giop_send_buffer_write(send_buffer); exception: giop_send_buffer_unuse(send_buffer); g_free (operation_name_data); g_free (name); if (error_sv) { if (return_types) g_ptr_array_free (return_types, TRUE); porbit_throw (error_sv); } return return_types; }
char *p5_stash_name(PerlInterpreter *my_perl, SV *obj) { HV * const pkg = SvSTASH((SV*)SvRV(obj)); return HvNAME(pkg); }
GV * Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) { AV* av; GV* topgv; GV* gv; GV** gvp; CV* cv; if (!stash) return 0; if ((level > 100) || (level < -100)) Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'", name, HvNAME(stash)); DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,HvNAME(stash)) ); gvp = (GV**)hv_fetch(stash, name, len, (level >= 0)); if (!gvp) topgv = Nullgv; else { topgv = *gvp; if (SvTYPE(topgv) != SVt_PVGV) gv_init(topgv, stash, name, len, TRUE); if ((cv = GvCV(topgv))) { /* If genuine method or valid cache entry, use it */ if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation) return topgv; /* Stale cached entry: junk it */ SvREFCNT_dec(cv); GvCV(topgv) = cv = Nullcv; GvCVGEN(topgv) = 0; } else if (GvCVGEN(topgv) == PL_sub_generation) return 0; /* cache indicates sub doesn't exist */ } gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE); av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : Nullav; /* create and re-create @.*::SUPER::ISA on demand */ if (!av || !SvMAGIC(av)) { char* packname = HvNAME(stash); STRLEN packlen = strlen(packname); if (packlen >= 7 && strEQ(packname + packlen - 7, "::SUPER")) { HV* basestash; packlen -= 7; basestash = gv_stashpvn(packname, packlen, TRUE); gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE); if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) { gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE); if (!gvp || !(gv = *gvp)) Perl_croak(aTHX_ "Cannot create %s::ISA", HvNAME(stash)); if (SvTYPE(gv) != SVt_PVGV) gv_init(gv, stash, "ISA", 3, TRUE); SvREFCNT_dec(GvAV(gv)); GvAV(gv) = (AV*)SvREFCNT_inc(av); } } } if (av) { SV** svp = AvARRAY(av); /* NOTE: No support for tied ISA */ I32 items = AvFILLp(av) + 1; while (items--) { SV* sv = *svp++; HV* basestash = gv_stashsv(sv, FALSE); if (!basestash) { if (ckWARN(WARN_MISC)) Perl_warner(aTHX_ WARN_MISC, "Can't locate package %s for @%s::ISA", SvPVX(sv), HvNAME(stash)); continue; } gv = gv_fetchmeth(basestash, name, len, (level >= 0) ? level + 1 : level - 1); if (gv) goto gotcha; } } /* if at top level, try UNIVERSAL */ if (level == 0 || level == -1) { HV* lastchance; if ((lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE))) { if ((gv = gv_fetchmeth(lastchance, name, len, (level >= 0) ? level + 1 : level - 1))) { gotcha: /* * Cache method in topgv if: * 1. topgv has no synonyms (else inheritance crosses wires) * 2. method isn't a stub (else AUTOLOAD fails spectacularly) */ if (topgv && GvREFCNT(topgv) == 1 && (cv = GvCV(gv)) && (CvROOT(cv) || CvXSUB(cv))) { if ((cv = GvCV(topgv))) SvREFCNT_dec(cv); GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv)); GvCVGEN(topgv) = PL_sub_generation; } return gv; } else if (topgv && GvREFCNT(topgv) == 1) { /* cache the fact that the method is not defined */ GvCVGEN(topgv) = PL_sub_generation; } } } return 0; }
GV* Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) { char autoload[] = "AUTOLOAD"; STRLEN autolen = sizeof(autoload)-1; GV* gv; CV* cv; HV* varstash; GV* vargv; SV* varsv; char *packname = ""; if (len == autolen && strnEQ(name, autoload, autolen)) return Nullgv; if (stash) { if (SvTYPE(stash) < SVt_PVHV) { packname = SvPV_nolen((SV*)stash); stash = Nullhv; } else { packname = HvNAME(stash); } } if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE))) return Nullgv; cv = GvCV(gv); if (!(CvROOT(cv) || CvXSUB(cv))) return Nullgv; /* * Inheriting AUTOLOAD for non-methods works ... for now. */ if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) && !method && (GvCVGEN(gv) || GvSTASH(gv) != stash)) Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated", packname, (int)len, name); if (CvXSUB(cv)) { /* rather than lookup/init $AUTOLOAD here * only to have the XSUB do another lookup for $AUTOLOAD * and split that value on the last '::', * pass along the same data via some unused fields in the CV */ CvSTASH(cv) = stash; SvPVX(cv) = (char *)name; /* cast to lose constness warning */ SvCUR(cv) = len; return gv; } /* * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name. * The subroutine's original name may not be "AUTOLOAD", so we don't * use that, but for lack of anything better we will use the sub's * original package to look up $AUTOLOAD. */ varstash = GvSTASH(CvGV(cv)); vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE); ENTER; if (!isGV(vargv)) gv_init(vargv, varstash, autoload, autolen, FALSE); LEAVE; varsv = GvSV(vargv); sv_setpv(varsv, packname); sv_catpvn(varsv, "::", 2); sv_catpvn(varsv, name, len); SvTAINTED_off(varsv); return gv; }
GV * Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) { register const char *nend; const char *nsplit = 0; GV* gv; HV* ostash = stash; if (stash && SvTYPE(stash) < SVt_PVHV) stash = Nullhv; for (nend = name; *nend; nend++) { if (*nend == '\'') nsplit = nend; else if (*nend == ':' && *(nend + 1) == ':') nsplit = ++nend; } if (nsplit) { const char *origname = name; name = nsplit + 1; if (*nsplit == ':') --nsplit; if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) { /* ->SUPER::method should really be looked up in original stash */ SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER", CopSTASHPV(PL_curcop))); /* __PACKAGE__::SUPER stash should be autovivified */ stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE); DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n", origname, HvNAME(stash), name) ); } else { /* don't autovifify if ->NoSuchStash::method */ stash = gv_stashpvn(origname, nsplit - origname, FALSE); /* however, explicit calls to Pkg::SUPER::method may happen, and may require autovivification to work */ if (!stash && (nsplit - origname) >= 7 && strnEQ(nsplit - 7, "::SUPER", 7) && gv_stashpvn(origname, nsplit - origname - 7, FALSE)) stash = gv_stashpvn(origname, nsplit - origname, TRUE); } ostash = stash; } gv = gv_fetchmeth(stash, name, nend - name, 0); if (!gv) { if (strEQ(name,"import") || strEQ(name,"unimport")) gv = (GV*)&PL_sv_yes; else if (autoload) gv = gv_autoload4(ostash, name, nend - name, TRUE); } else if (autoload) { CV* cv = GvCV(gv); if (!CvROOT(cv) && !CvXSUB(cv)) { GV* stubgv; GV* autogv; if (CvANON(cv)) stubgv = gv; else { stubgv = CvGV(cv); if (GvCV(stubgv) != cv) /* orphaned import */ stubgv = gv; } autogv = gv_autoload4(GvSTASH(stubgv), GvNAME(stubgv), GvNAMELEN(stubgv), TRUE); if (autogv) gv = autogv; } } return gv; }
SV* THX_MopMcV_get_name(pTHX_ SV* metaclass) { return newSVpv(HvNAME(SvRV(metaclass)), 0); }