JSObject*
PJS_NewPerlSub(
pTHX_
JSContext *cx,
JSObject *parent,
SV *cvref
) {
JSObject *newobj = PJS_CreateJSVis(
aTHX_ cx,
JS_NewObject(cx, &perlsub_class, NULL, parent),
cvref
);
if(newobj) {
CV *cv = (CV *)SvRV(cvref);
const char *fname = CvANON(cv) ? "(anonymous)" : GvENAME(CvGV(cv));
JSString *jstr = JS_InternString(cx, fname);
if(!jstr || !JS_DefineProperty(cx, newobj, "name",
STRING_TO_JSVAL(jstr),
NULL, NULL,
JSPROP_READONLY | JSPROP_PERMANENT)
) {
PJS_unrootJSVis(cx, newobj);
newobj = NULL;
}
}
return newobj;
}
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;
}
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;
}
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;
}
/* helper for the default modify handler for builtin attributes */
static int
modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
{
SV *attr;
int nret;
for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
STRLEN len;
const char *name = SvPV_const(attr, len);
const bool negated = (*name == '-');
HV *typestash;
if (negated) {
name++;
len--;
}
switch (SvTYPE(sv)) {
case SVt_PVCV:
switch ((int)len) {
case 4:
if (memEQ(name, "pure", 4)) {
if (negated)
Perl_croak(aTHX_ "Illegal :-pure attribute");
CvPURE_on(sv);
goto next_attr;
}
break;
case 5:
if (memEQ(name, "const", 5)) {
if (negated)
CvCONST_off(sv);
else {
#ifndef USE_CPERL
const bool warn = (!CvANON(sv) || CvCLONED(sv))
&& !CvCONST(sv);
CvCONST_on(sv);
if (warn)
break;
#else
CvCONST_on(sv);
#endif
}
goto next_attr;
}
break;
case 6:
switch (name[3]) {
case 'l':
if (memEQ(name, "lvalue", 6)) {
bool warn =
!CvISXSUB(MUTABLE_CV(sv))
&& CvROOT(MUTABLE_CV(sv))
&& !CvLVALUE(MUTABLE_CV(sv)) != negated;
if (negated)
CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_LVALUE;
else
CvFLAGS(MUTABLE_CV(sv)) |= CVf_LVALUE;
if (warn) break;
goto next_attr;
}
break;
case 'h':
if (memEQ(name, "method", 6)) {
if (negated)
CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_METHOD;
else
CvFLAGS(MUTABLE_CV(sv)) |= CVf_METHOD;
goto next_attr;
}
break;
}
break;
default:
if (len > 10 && memEQ(name, "prototype(", 10)) {
SV * proto = newSVpvn(name+10,len-11);
HEK *const hek = CvNAME_HEK((CV *)sv);
SV *subname;
if (name[len-1] != ')')
Perl_croak(aTHX_ "Unterminated attribute parameter in attribute list");
if (hek)
subname = sv_2mortal(newSVhek(hek));
else
subname=(SV *)CvGV((const CV *)sv);
if (ckWARN(WARN_ILLEGALPROTO))
Perl_validate_proto(aTHX_ subname, proto, TRUE);
Perl_cv_ckproto_len_flags(aTHX_ (const CV *)sv,
(const GV *)subname,
name+10,
len-11,
SvUTF8(attr));
sv_setpvn(MUTABLE_SV(sv), name+10, len-11);
if (SvUTF8(attr)) SvUTF8_on(MUTABLE_SV(sv));
goto next_attr;
}
break;
}
if (!negated && (typestash = gv_stashpvn(name, len, SvUTF8(attr)))) {
CvTYPED_on(sv);
CvTYPE_set((CV*)sv, typestash);
continue;
}
break;
case SVt_IV:
case SVt_PVIV:
case SVt_PVMG:
if (memEQ(name, "unsigned", 8)
&& (SvIOK(sv) || SvUOK(sv)))
{
if (negated) /* :-unsigned alias for :signed */
SvIsUV_off(sv);
else
SvIsUV_on(sv);
continue;
}
/* fallthru - all other data types */
default:
if (memEQ(name, "const", 5)
&& !(SvFLAGS(sv) & SVf_PROTECT))
{
if (negated)
SvREADONLY_off(sv);
else
SvREADONLY_on(sv);
continue;
}
if (memEQs(name, len, "shared")) {
if (negated)
Perl_croak(aTHX_ "A variable may not be unshared");
SvSHARE(sv);
continue;
}
break;
}
/* anything recognized had a 'continue' above */
*retlist++ = attr;
nret++;
next_attr:
;
}
return nret;
}
