if (!*where)
*where = newSV_type(type);
+ if (type == SVt_PVAV && GvNAMELEN(gv) == 3
+ && strnEQ(GvNAME(gv), "ISA", 3))
+ sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0);
return gv;
}
Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
{
GV * const oldgv = CvGV(cv);
+ HEK *hek;
PERL_ARGS_ASSERT_CVGV_SET;
if (oldgv == gv)
sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv));
}
}
+ else if ((hek = CvNAME_HEK(cv))) unshare_hek(hek);
- SvANY(cv)->xcv_gv = gv;
+ SvANY(cv)->xcv_gv_u.xcv_gv = gv;
assert(!CvCVGV_RC(cv));
if (!gv)
gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ));
if (flags & GV_ADDMULTI || doproto) /* doproto means it */
GvMULTI_on(gv); /* _was_ mentioned */
- if (doproto) { /* Replicate part of newSUB here. */
+ if (doproto) {
CV *cv;
- ENTER;
if (has_constant) {
/* newCONSTSUB takes ownership of the reference from us. */
cv = newCONSTSUB_flags(stash, name, len, flags, has_constant);
from a reference to CV. */
if (exported_constant)
GvIMPORTED_CV_on(gv);
+ CvSTASH_set(cv, PL_curstash); /* XXX Why is this needed? */
} else {
- (void) start_subparse(0,0); /* Create empty CV in compcv. */
- cv = PL_compcv;
- GvCV_set(gv,cv);
+ cv = newSTUB(gv,1);
}
- LEAVE;
-
- mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar($) { (shift) } sub ASDF::baz($); *ASDF::baz = \&Foo::bar */
- CvGV_set(cv, gv);
- CvFILE_set_from_cop(cv, PL_curcop);
- CvSTASH_set(cv, PL_curstash);
if (proto) {
sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen,
SV_HAS_TRAILING_NUL);
case KEY_BEGIN : case KEY_CHECK : case KEY_cmp: case KEY_CORE :
case KEY_default : case KEY_DESTROY:
case KEY_do : case KEY_dump : case KEY_else : case KEY_elsif :
- case KEY_END : case KEY_eq : case KEY_eval : case KEY_exists :
+ case KEY_END : case KEY_eq : case KEY_eval :
case KEY_for : case KEY_foreach: case KEY_format: case KEY_ge :
- case KEY_given : case KEY_glob : case KEY_goto : case KEY_grep :
+ case KEY_given : case KEY_goto : case KEY_grep :
case KEY_gt : case KEY_if: case KEY_INIT: case KEY_last: case KEY_le:
case KEY_local: case KEY_lt: case KEY_m : case KEY_map : case KEY_my:
case KEY_ne : case KEY_next : case KEY_no: case KEY_or: case KEY_our:
- case KEY_package: case KEY_pos: case KEY_print : case KEY_printf:
- case KEY_prototype: case KEY_q: case KEY_qq: case KEY_qr: case KEY_qw:
+ case KEY_package: case KEY_print: case KEY_printf:
+ case KEY_q : case KEY_qq : case KEY_qr : case KEY_qw :
case KEY_qx : case KEY_redo : case KEY_require: case KEY_return:
- case KEY_s : case KEY_say : case KEY_scalar : case KEY_sort :
- case KEY_split: case KEY_state: case KEY_study : case KEY_sub :
- case KEY_tr : case KEY_undef: case KEY_UNITCHECK: case KEY_unless:
+ case KEY_s : case KEY_say : case KEY_sort :
+ case KEY_state: case KEY_sub :
+ case KEY_tr : case KEY_UNITCHECK: case KEY_unless:
case KEY_until: case KEY_use : case KEY_when : case KEY_while :
case KEY_x : case KEY_xor : case KEY_y :
return NULL;
case KEY_chdir:
case KEY_chomp: case KEY_chop: case KEY_defined: case KEY_delete:
- case KEY_each: case KEY_eof: case KEY_exec:
+ case KEY_each : case KEY_eof : case KEY_exec : case KEY_exists:
case KEY_keys:
case KEY_lstat:
case KEY_pop:
case KEY_push:
case KEY_shift:
- case KEY_splice:
+ case KEY_splice: case KEY_split:
case KEY_stat:
case KEY_system:
case KEY_truncate: case KEY_unlink:
1
);
assert(GvCV(gv) == cv);
- if (opnum != OP_VEC && opnum != OP_SUBSTR)
+ if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS
+ && opnum != OP_UNDEF)
CvLVALUE_off(cv); /* Now *that* was a neat trick. */
LEAVE;
PL_parser = oldparser;
}
packlen = HvNAMELEN_get(stash);
- if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
+ if ((packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER"))
+ || (packlen == 5 && strEQ(hvname, "SUPER"))) {
HV* basestash;
- packlen -= 7;
- basestash = gv_stashpvn(hvname, packlen,
+ basestash = packlen == 5
+ ? PL_defstash
+ : gv_stashpvn(hvname, packlen - 7,
GV_ADD | (HvNAMEUTF8(stash) ? SVf_UTF8 : 0));
linear_av = mro_get_linear_isa(basestash);
}
superisa = GvAVn(gv);
GvMULTI_on(gv);
sv_magic(MUTABLE_SV(superisa), MUTABLE_SV(gv), PERL_MAGIC_isa, NULL, 0);
-#ifdef USE_ITHREADS
- av_push(superisa, newSVpvn_flags(CopSTASHPV(PL_curcop),
- CopSTASH_len(PL_curcop) < 0
- ? -CopSTASH_len(PL_curcop)
- : CopSTASH_len(PL_curcop),
- SVf_UTF8*(CopSTASH_len(PL_curcop) < 0)
- ));
-#else
av_push(superisa, newSVhek(CopSTASH(PL_curcop)
- ? HvNAME_HEK(CopSTASH(PL_curcop)) : NULL));
-#endif
+ ? HvENAME_HEK(CopSTASH(PL_curcop)) : NULL));
return stash;
}
Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags)
{
dVAR;
- register const char *nend;
+ const char *nend;
const char *nsplit = NULL;
GV* gv;
HV* ostash = stash;
/* ->SUPER::method should really be looked up in original stash */
SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_
"%"HEKf"::SUPER",
- HEKfARG(HvNAME_HEK((HV*)CopSTASH(PL_curcop)))
+ HEKfARG(HvENAME_HEK((HV*)CopSTASH(PL_curcop)))
));
/* __PACKAGE__::SUPER stash should be autovivified */
stash = gv_get_super_pkg(SvPVX_const(tmpstr), SvCUR(tmpstr), SvUTF8(tmpstr));
DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
- origname, HvNAME_get(stash), name) );
+ origname, HvENAME_get(stash), name) );
}
else {
/* don't autovifify if ->NoSuchStash::method */
}
LEAVE;
varsv = GvSVn(vargv);
+ SvTAINTED_off(varsv); /* previous $AUTOLOAD taint is obsolete */
+ /* XXX: this process is not careful to avoid extra magic gets and sets; tied $AUTOLOAD will get noise */
sv_setsv(varsv, packname);
sv_catpvs(varsv, "::");
/* Ensure SvSETMAGIC() is called if necessary. In particular, to clear
C<flags> is 0 (or any other setting that does not create packages) then NULL
is returned.
+Flags may be one of:
+
+ GV_ADD
+ SVf_UTF8
+ GV_NOADD_NOINIT
+ GV_NOINIT
+ GV_NOEXPAND
+ GV_ADDMG
+
+The most important of which are probably GV_ADD and SVf_UTF8.
=cut
*/
const svtype sv_type)
{
dVAR;
- register const char *name = nambeg;
- register GV *gv = NULL;
+ const char *name = nambeg;
+ GV *gv = NULL;
GV**gvp;
I32 len;
- register const char *name_cursor;
+ const char *name_cursor;
HV *stash = NULL;
const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
const I32 no_expand = flags & GV_NOEXPAND;
require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
}
if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
- if (*name == '[')
- require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
- else if (*name == '&' || *name == '`' || *name == '\'') {
- PL_sawampersand = TRUE;
- (void)GvSVn(gv);
- }
+ switch (*name) {
+ case '[':
+ require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
+ break;
+ case '`':
+ PL_sawampersand |= SAWAMPERSAND_LEFT;
+ (void)GvSVn(gv);
+ break;
+ case '&':
+ PL_sawampersand |= SAWAMPERSAND_MIDDLE;
+ (void)GvSVn(gv);
+ break;
+ case '\'':
+ PL_sawampersand |= SAWAMPERSAND_RIGHT;
+ (void)GvSVn(gv);
+ break;
+ }
}
}
else if (len == 3 && sv_type == SVt_PVAV
sv_type == SVt_PVCV ||
sv_type == SVt_PVFM ||
sv_type == SVt_PVIO
- )) { PL_sawampersand = TRUE; }
+ )) { PL_sawampersand |=
+ (*name == '`')
+ ? SAWAMPERSAND_LEFT
+ : (*name == '&')
+ ? SAWAMPERSAND_MIDDLE
+ : SAWAMPERSAND_RIGHT;
+ }
goto magicalize;
case ':': /* $: */
case '\014': /* $^L */
sv_setpvs(GvSVn(gv),"\f");
- PL_formfeed = GvSVn(gv);
+ PL_formfeed = GvSV(gv);
break;
case ';': /* $; */
sv_setpvs(GvSVn(gv),"\034");
Perl_gv_check(pTHX_ const HV *stash)
{
dVAR;
- register I32 i;
+ I32 i;
PERL_ARGS_ASSERT_GV_CHECK;
for (i = 0; i <= (I32) HvMAX(stash); i++) {
const HE *entry;
for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
- register GV *gv;
+ GV *gv;
HV *hv;
if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
(gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
}
#endif
else if (SvTRUE(sv))
+ /* don't need to set overloading here because fallback => 1
+ * is the default setting for classes without overloading */
amt.fallback=AMGfallYES;
- else if (SvOK(sv))
+ else if (SvOK(sv)) {
amt.fallback=AMGfallNEVER;
+ filled = 1;
+ have_ovl = 1;
+ }
+ else {
+ filled = 1;
+ have_ovl = 1;
+ }
for (i = 1; i < lim; i++)
amt.table[i] = NULL;
int assign = AMGf_assign & flags;
const int assignshift = assign ? 1 : 0;
int use_default_op = 0;
+ int force_scalar = 0;
#ifdef DEBUGGING
int fl=0;
#endif
force_cpy = force_cpy || assign;
}
}
+
+ switch (method) {
+ /* in these cases, we're calling '+' or '-' as a fallback for a ++ or --
+ * operation. we need this to return a value, so that it can be assigned
+ * later on, in the postpr block (case inc_amg/dec_amg), even if the
+ * increment or decrement was itself called in void context */
+ case inc_amg:
+ if (off == add_amg)
+ force_scalar = 1;
+ break;
+ case dec_amg:
+ if (off == subtr_amg)
+ force_scalar = 1;
+ break;
+ /* in these cases, we're calling an assignment variant of an operator
+ * (+= rather than +, for instance). regardless of whether it's a
+ * fallback or not, it always has to return a value, which will be
+ * assigned to the proper variable later */
+ case add_amg:
+ case subtr_amg:
+ case mult_amg:
+ case div_amg:
+ case modulo_amg:
+ case pow_amg:
+ case lshift_amg:
+ case rshift_amg:
+ case repeat_amg:
+ case concat_amg:
+ case band_amg:
+ case bor_amg:
+ case bxor_amg:
+ if (assign)
+ force_scalar = 1;
+ break;
+ /* the copy constructor always needs to return a value */
+ case copy_amg:
+ force_scalar = 1;
+ break;
+ /* because of the way these are implemented (they don't perform the
+ * dereferencing themselves, they return a reference that perl then
+ * dereferences later), they always have to be in scalar context */
+ case to_sv_amg:
+ case to_av_amg:
+ case to_hv_amg:
+ case to_gv_amg:
+ case to_cv_amg:
+ force_scalar = 1;
+ break;
+ /* these don't have an op of their own; they're triggered by their parent
+ * op, so the context there isn't meaningful ('$a and foo()' in void
+ * context still needs to pass scalar context on to $a's bool overload) */
+ case bool__amg:
+ case numer_amg:
+ case string_amg:
+ force_scalar = 1;
+ break;
+ }
+
#ifdef DEBUGGING
if (!notfound) {
DEBUG_o(Perl_deb(aTHX_
BINOP myop;
SV* res;
const bool oldcatch = CATCH_GET;
+ I32 oldmark, nret;
+ int gimme = force_scalar ? G_SCALAR : GIMME_V;
CATCH_SET(TRUE);
Zero(&myop, 1, BINOP);
myop.op_last = (OP *) &myop;
myop.op_next = NULL;
- myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
+ myop.op_flags = OPf_STACKED;
+
+ switch (gimme) {
+ case G_VOID:
+ myop.op_flags |= OPf_WANT_VOID;
+ break;
+ case G_ARRAY:
+ if (flags & AMGf_want_list) {
+ myop.op_flags |= OPf_WANT_LIST;
+ break;
+ }
+ /* FALLTHROUGH */
+ default:
+ myop.op_flags |= OPf_WANT_SCALAR;
+ break;
+ }
PUSHSTACKi(PERLSI_OVERLOAD);
ENTER;
}
PUSHs(MUTABLE_SV(cv));
PUTBACK;
+ oldmark = TOPMARK;
if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
CALLRUNOPS(aTHX);
LEAVE;
SPAGAIN;
+ nret = SP - (PL_stack_base + oldmark);
+
+ switch (gimme) {
+ case G_VOID:
+ /* returning NULL has another meaning, and we check the context
+ * at the call site too, so this can be differentiated from the
+ * scalar case */
+ res = &PL_sv_undef;
+ SP = PL_stack_base + oldmark;
+ break;
+ case G_ARRAY: {
+ if (flags & AMGf_want_list) {
+ res = sv_2mortal((SV *)newAV());
+ av_extend((AV *)res, nret);
+ while (nret--)
+ av_store((AV *)res, nret, POPs);
+ break;
+ }
+ /* FALLTHROUGH */
+ }
+ default:
+ res = POPs;
+ break;
+ }
- res=POPs;
PUTBACK;
POPSTACK;
CATCH_SET(oldcatch);
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/