STATIC void
S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid)
{
- SV * const namesv = cv_name((CV *)gv, NULL);
+ 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,
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,
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;
}
if (proto >= proto_end)
{
- SV * const namesv = cv_name((CV *)namegv, NULL);
+ 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;
default:
oops: {
Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
- SVfARG(cv_name((CV *)namegv, NULL)),
+ SVfARG(cv_name((CV *)namegv, NULL, 0)),
SVfARG(protosv));
}
}
if (!optional && proto_end > proto &&
(*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
{
- SV * const namesv = cv_name((CV *)namegv, NULL);
+ SV * const namesv = cv_name((CV *)namegv, NULL, 0);
yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf,
SVfARG(namesv)), SvUTF8(namesv));
}
https://perl5.git.perl.org / perl5.git / blobdiff