o->op_ppaddr = PL_ppaddr[type]; \
} STMT_END
-STATIC SV*
-S_gv_ename(pTHX_ GV *gv)
-{
- SV* const tmpsv = sv_newmortal();
-
- PERL_ARGS_ASSERT_GV_ENAME;
-
- gv_efullname3(tmpsv, gv, NULL);
- return tmpsv;
-}
-
STATIC OP *
S_no_fh_allowed(pTHX_ OP *o)
{
STATIC void
S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid)
{
- SV * const namesv = gv_ename(gv);
+ SV * const namesv = cv_name((CV *)gv, NULL, 0);
PERL_ARGS_ASSERT_BAD_TYPE_GV;
yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
SvREFCNT_inc_simple_void(gv);
#ifdef USE_ITHREADS
if (cPADOPo->op_padix > 0) {
- /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
- * may still exist on the pad */
pad_swipe(cPADOPo->op_padix, TRUE);
cPADOPo->op_padix = 0;
}
case OP_PUSHRE:
#ifdef USE_ITHREADS
if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
- /* No GvIN_PAD_off here, because other references may still
- * exist on the pad */
pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
}
#else
=for apidoc op_sibling_splice
A general function for editing the structure of an existing chain of
-op_sibling nodes. By analogy with the perl-level splice() function, allows
+op_sibling nodes. By analogy with the perl-level splice() function, allows
you to delete zero or more sequential nodes, replacing them with zero or
more different nodes. Performs the necessary op_first/op_last
housekeeping on the parent node and op_sibling manipulation on the
-children. The last deleted node will be marked as as the last node by
+children. The last deleted node will be marked as as the last node by
updating the op_sibling or op_lastsib field as appropriate.
Note that op_next is not manipulated, and nodes are not freed; that is the
-responsibility of the caller. It also won't create a new list op for an
+responsibility of the caller. It also won't create a new list op for an
empty list etc; use higher-level functions like op_append_elem() for that.
parent is the parent node of the sibling chain.
-start is the node preceding the first node to be spliced. Node(s)
-following it will be deleted, and ops will be inserted after it. If it is
+start is the node preceding the first node to be spliced. Node(s)
+following it will be deleted, and ops will be inserted after it. If it is
NULL, the first node onwards is deleted, and nodes are inserted at the
beginning.
-del_count is the number of nodes to delete. If zero, no nodes are deleted.
+del_count is the number of nodes to delete. If zero, no nodes are deleted.
If -1 or greater than or equal to the number of remaining kids, all
remaining kids are deleted.
/*
=for apidoc op_parent
-returns the parent OP of o, if it has a parent. Returns NULL otherwise.
+returns the parent OP of o, if it has a parent. Returns NULL otherwise.
(Currently perl must be built with C<-DPERL_OP_PARENT> for this feature to
work.
no_bareword_allowed(o);
else {
if (ckWARN(WARN_VOID)) {
+ NV nv;
/* don't warn on optimised away booleans, eg
* use constant Foo, 5; Foo || print; */
if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
/* the constants 0 and 1 are permitted as they are
conventionally used as dummies in constructs like
1 while some_condition_with_side_effects; */
- else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
+ else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
useless = NULL;
else if (SvPOK(sv)) {
SV * const dsv = newSVpvs("");
padop->op_type = (OPCODE)type;
padop->op_ppaddr = PL_ppaddr[type];
padop->op_padix =
- pad_alloc(type, IS_PADGV(sv) ? SVf_READONLY : SVs_PADTMP);
+ pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
SvREFCNT_dec(PAD_SVl(padop->op_padix));
PAD_SETSV(padop->op_padix, sv);
assert(sv);
PERL_ARGS_ASSERT_NEWGVOP;
#ifdef USE_ITHREADS
- GvIN_PAD_on(gv);
return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
#else
return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
left->op_next = flip;
right->op_next = flop;
- range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
+ range->op_targ = pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK, 0, 0);
sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
- flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
+ flip->op_targ = pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK, 0, 0);;
sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
+ SvPADTMP_on(PAD_SV(flip->op_targ));
flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
}
if (const_sv) {
SvREFCNT_inc_simple_void_NN(const_sv);
- SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP;
+ SvFLAGS(const_sv) |= SVs_PADTMP;
if (cv) {
assert(!CvROOT(cv) && !CvCONST(cv));
cv_forget_slab(cv);
else *spot = cv_clone(clonee);
SvREFCNT_dec_NN(clonee);
cv = *spot;
- SvPADMY_on(cv);
}
if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
PADOFFSET depth = CvDEPTH(outcv);
bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
#ifdef PERL_DEBUG_READONLY_OPS
OPSLAB *slab = NULL;
-#endif
bool special = FALSE;
+#endif
if (o_is_gv) {
gv = (GV*)o;
}
if (const_sv) {
SvREFCNT_inc_simple_void_NN(const_sv);
- SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP;
+ SvFLAGS(const_sv) |= SVs_PADTMP;
if (cv) {
assert(!CvROOT(cv) && !CvCONST(cv));
cv_forget_slab(cv);
assert(CvGV(cv) == gv);
}
else {
+ dVAR;
U32 hash;
PERL_HASH(hash, name, namlen);
CvNAME_HEK_set(cv,
share_hek(name,
- name_is_utf8 ? -namlen : namlen,
+ name_is_utf8
+ ? -(SSize_t)namlen
+ : (SSize_t)namlen,
hash));
}
if (!CvHASGV(cv)) {
if (isGV(gv)) CvGV_set(cv, gv);
else {
+ dVAR;
U32 hash;
PERL_HASH(hash, name, namlen);
CvNAME_HEK_set(cv, share_hek(name,
- name_is_utf8 ? -namlen : namlen,
+ name_is_utf8
+ ? -(SSize_t)namlen
+ : (SSize_t)namlen,
hash));
}
CvFILE_set_from_cop(cv, PL_curcop);
if (block && has_name) {
if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
- SV * const tmpstr = cv_name(cv,NULL);
+ SV * const tmpstr = cv_name(cv,NULL,0);
GV * const db_postponed = gv_fetchpvs("DB::postponed",
GV_ADDMULTI, SVt_PVHV);
HV *hv;
if (PL_parser && PL_parser->error_count)
clear_special_blocks(name, gv, cv);
else
- special = process_special_blocks(floor, name, gv, cv);
+#ifdef PERL_DEBUG_READONLY_OPS
+ special =
+#endif
+ process_special_blocks(floor, name, gv, cv);
}
}
assert (sizeof(PADOP) <= sizeof(SVOP));
kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
- if (isGV(gv)) GvIN_PAD_on(gv);
PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
#else
kid->op_sv = SvREFCNT_inc_simple_NN(gv);
}
else {
OP * const newop
- = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
+ = newUNOP(OP_READLINE, o->op_flags | OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
op_free(o);
return newop;
}
kid->op_next = kid;
o->op_flags |= OPf_SPECIAL;
}
+ else if (kid->op_type == OP_CONST
+ && kid->op_private & OPpCONST_BARE) {
+ char tmpbuf[256];
+ STRLEN len;
+ PADOFFSET off;
+ const char * const name = SvPV(kSVOP_sv, len);
+ *tmpbuf = '&';
+ assert (len < 256);
+ Copy(name, tmpbuf+1, len, char);
+ off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
+ if (off != NOT_IN_PAD) {
+ if (PAD_COMPNAME_FLAGS_isOUR(off)) {
+ SV * const fq =
+ newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
+ sv_catpvs(fq, "::");
+ sv_catsv(fq, kSVOP_sv);
+ SvREFCNT_dec_NN(kSVOP_sv);
+ kSVOP->op_sv = fq;
+ }
+ else {
+ OP * const padop = newOP(OP_PADCV, 0);
+ padop->op_targ = off;
+ cUNOPx(firstkid)->op_first = padop;
+ op_free(kid);
+ }
+ }
+ }
firstkid = OP_SIBLING(firstkid);
}
if (proto >= proto_end)
{
- SV * const namesv = gv_ename(namegv);
+ SV * const namesv = cv_name((CV *)namegv, NULL, 0);
yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf,
SVfARG(namesv)), SvUTF8(namesv));
return entersubop;
continue;
default:
oops: {
- SV* const tmpsv = sv_newmortal();
- gv_efullname3(tmpsv, namegv, NULL);
Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
- SVfARG(tmpsv), SVfARG(protosv));
+ SVfARG(cv_name((CV *)namegv, NULL, 0)),
+ SVfARG(protosv));
}
}
if (!optional && proto_end > proto &&
(*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
{
- SV * const namesv = gv_ename(namegv);
+ SV * const namesv = cv_name((CV *)namegv, NULL, 0);
yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf,
SVfARG(namesv)), SvUTF8(namesv));
}
} else {
*ckfun_p = Perl_ck_entersub_args_proto_or_list;
*ckobj_p = (SV*)cv;
- if (flagsp) *flagsp = MGf_REQUIRE_GV;
+ if (flagsp) *flagsp = 0;
}
}
{
PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
PERL_UNUSED_CONTEXT;
- return S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL);
+ S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL);
}
/*
callmg->mg_flags |= MGf_REFCOUNTED;
}
callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
- | (flags & MGf_REQUIRE_GV) | MGf_COPY;
+ | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY;
}
}
https://perl5.git.perl.org / perl5.git / blobdiff