CopFILE_free(cop);
CopSTASH_free(cop);
if (! specialWARN(cop->cop_warnings))
- SvREFCNT_dec(cop->cop_warnings);
+ PerlMemShared_free(cop->cop_warnings);
if (! specialCopIO(cop->cop_io)) {
#ifdef USE_ITHREADS
/*EMPTY*/
{
dVAR;
if (o) {
- if (o->op_type == OP_LINESEQ ||
- o->op_type == OP_SCOPE ||
- o->op_type == OP_LEAVE ||
- o->op_type == OP_LEAVETRY)
+ const OPCODE type = o->op_type;
+
+ if (type == OP_LINESEQ || type == OP_SCOPE ||
+ type == OP_LEAVE || type == OP_LEAVETRY)
{
OP *kid;
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
{
OP *o;
bool ismatchop = 0;
+ const OPCODE ltype = left->op_type;
+ const OPCODE rtype = right->op_type;
- if ( (left->op_type == OP_RV2AV ||
- left->op_type == OP_RV2HV ||
- left->op_type == OP_PADAV ||
- left->op_type == OP_PADHV)
- && ckWARN(WARN_MISC))
+ if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
+ || ltype == OP_PADHV) && ckWARN(WARN_MISC))
{
- const char * const desc = PL_op_desc[(right->op_type == OP_SUBST ||
- right->op_type == OP_TRANS)
- ? right->op_type : OP_MATCH];
- const char * const sample = ((left->op_type == OP_RV2AV ||
- left->op_type == OP_PADAV)
- ? "@array" : "%hash");
+ const char * const desc
+ = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
+ ? rtype : OP_MATCH];
+ const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
+ ? "@array" : "%hash");
Perl_warner(aTHX_ packWARN(WARN_MISC),
"Applying %s to %s will act on scalar(%s)",
desc, sample, sample);
}
- if (right->op_type == OP_CONST &&
+ if (rtype == OP_CONST &&
cSVOPx(right)->op_private & OPpCONST_BARE &&
cSVOPx(right)->op_private & OPpCONST_STRICT)
{
no_bareword_allowed(right);
}
- ismatchop = right->op_type == OP_MATCH ||
- right->op_type == OP_SUBST ||
- right->op_type == OP_TRANS;
+ ismatchop = rtype == OP_MATCH ||
+ rtype == OP_SUBST ||
+ rtype == OP_TRANS;
if (ismatchop && right->op_private & OPpTARGET_MY) {
right->op_targ = 0;
right->op_private &= ~OPpTARGET_MY;
}
if (!(right->op_flags & OPf_STACKED) && ismatchop) {
+ OP *newleft;
+
right->op_flags |= OPf_STACKED;
- if (right->op_type != OP_MATCH &&
- ! (right->op_type == OP_TRANS &&
+ if (rtype != OP_MATCH &&
+ ! (rtype == OP_TRANS &&
right->op_private & OPpTRANS_IDENTICAL))
- left = mod(left, right->op_type);
+ newleft = mod(left, rtype);
+ else
+ newleft = left;
if (right->op_type == OP_TRANS)
- o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
+ o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
else
- o = prepend_elem(right->op_type, scalar(left), right);
+ o = prepend_elem(rtype, scalar(newleft), right);
if (type == OP_NOT)
return newUNOP(OP_NOT, 0, scalar(o));
return o;
}
return o;
}
-
+
int
Perl_block_start(pTHX_ int full)
{
pad_block_start(full);
SAVEHINTS();
PL_hints &= ~HINT_BLOCK_SCOPE;
- SAVESPTR(PL_compiling.cop_warnings);
- if (! specialWARN(PL_compiling.cop_warnings)) {
- PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
- SAVEFREESV(PL_compiling.cop_warnings) ;
- }
+ SAVECOMPILEWARNINGS();
+ PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
SAVESPTR(PL_compiling.cop_io);
if (! specialCopIO(PL_compiling.cop_io)) {
PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
OP* const retval = scalarseq(seq);
LEAVE_SCOPE(floor);
- PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
+ CopHINTS_set(&PL_compiling, PL_hints);
if (needblockscope)
PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
pad_leavemy();
register OP *curop;
OP *newop;
I32 type = o->op_type;
- SV *sv;
+ SV *sv = NULL;
int ret = 0;
I32 oldscope;
OP *old_next;
goto nope; /* Don't try to run w/ errors */
for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
- if ((curop->op_type != OP_CONST ||
- (curop->op_private & OPpCONST_BARE)) &&
- curop->op_type != OP_LIST &&
- curop->op_type != OP_SCALAR &&
- curop->op_type != OP_NULL &&
- curop->op_type != OP_PUSHMARK)
+ const OPCODE type = curop->op_type;
+ if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
+ type != OP_LIST &&
+ type != OP_SCALAR &&
+ type != OP_NULL &&
+ type != OP_PUSHMARK)
{
goto nope;
}
#ifndef PERL_MAD
op_free(o);
#endif
+ assert(sv);
if (type == OP_RV2GV)
newop = newGVOP(OP_GV, 0, (GV*)sv);
else
const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
U8* tsave = NULL;
U8* rsave = NULL;
+ const U32 flags = UTF8_ALLOW_DEFAULT;
if (!from_utf) {
STRLEN len = tlen;
i = 0;
transv = newSVpvs("");
while (t < tend) {
- cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
+ cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
t += ulen;
if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
t++;
- cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
+ cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
t += ulen;
}
else {
while (t < tend || tfirst <= tlast) {
/* see if we need more "t" chars */
if (tfirst > tlast) {
- tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
+ tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
t += ulen;
if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
t++;
- tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
+ tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
t += ulen;
}
else
/* now see if we need more "r" chars */
if (rfirst > rlast) {
if (r < rend) {
- rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
+ rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
r += ulen;
if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
r++;
- rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
+ rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
r += ulen;
}
else
STATIC I32
S_is_list_assignment(pTHX_ register const OP *o)
{
+ unsigned type;
+ U8 flags;
+
if (!o)
return TRUE;
- if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
+ if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
o = cUNOPo->op_first;
- if (o->op_type == OP_COND_EXPR) {
+ flags = o->op_flags;
+ type = o->op_type;
+ if (type == OP_COND_EXPR) {
const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
return FALSE;
}
- if (o->op_type == OP_LIST &&
- (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
+ if (type == OP_LIST &&
+ (flags & OPf_WANT) == OPf_WANT_SCALAR &&
o->op_private & OPpLVAL_INTRO)
return FALSE;
- if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
- o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
- o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
+ if (type == OP_LIST || flags & OPf_PARENS ||
+ type == OP_RV2AV || type == OP_RV2HV ||
+ type == OP_ASLICE || type == OP_HSLICE)
return TRUE;
- if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
+ if (type == OP_PADAV || type == OP_PADHV)
return TRUE;
- if (o->op_type == OP_RV2SV)
+ if (type == OP_RV2SV)
return FALSE;
return FALSE;
o->op_private |= OPpASSIGN_COMMON;
}
if (right && right->op_type == OP_SPLIT) {
- OP* tmpop;
- if ((tmpop = ((LISTOP*)right)->op_first) &&
- tmpop->op_type == OP_PUSHRE)
- {
+ OP* tmpop = ((LISTOP*)right)->op_first;
+ if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
PMOP * const pm = (PMOP*)tmpop;
if (left->op_type == OP_RV2AV &&
!(left->op_private & OPpLVAL_INTRO) &&
cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
}
cop->op_flags = (U8)flags;
- cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
+ CopHINTS_set(cop, PL_hints);
#ifdef NATIVE_HINTS
cop->op_private |= NATIVE_HINTS;
#endif
- PL_compiling.op_private = cop->op_private;
+ CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
cop->op_next = (OP*)cop;
if (label) {
}
cop->cop_seq = seq;
CopARYBASE_set(cop, CopARYBASE_get(PL_curcop));
- if (specialWARN(PL_curcop->cop_warnings))
- cop->cop_warnings = PL_curcop->cop_warnings ;
- else
- cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
+ cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
if (specialCopIO(PL_curcop->cop_io))
cop->cop_io = PL_curcop->cop_io;
else
cop->cop_io = newSVsv(PL_curcop->cop_io) ;
cop->cop_hints = PL_curcop->cop_hints;
if (cop->cop_hints) {
+ HINTS_REFCNT_LOCK;
cop->cop_hints->refcounted_he_refcnt++;
+ HINTS_REFCNT_UNLOCK;
}
if (PL_copline == NOLINE)
cont = append_elem(OP_LINESEQ, cont, unstack);
}
+ assert(block);
listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
+ assert(listop);
redo = LINKLIST(listop);
if (expr) {
loop = tmp;
}
#else
- Renew(loop, 1, LOOP);
+ loop = PerlMemShared_realloc(loop, sizeof(LOOP));
#endif
loop->op_targ = padoff;
wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
}
void
-Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
-{
- if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
+Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
+ const STRLEN len)
+{
+ /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
+ relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
+ if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
+ || (p && (len != SvCUR(cv) /* Not the same length. */
+ || memNE(p, SvPVX_const(cv), len))))
+ && ckWARN_d(WARN_PROTOTYPE)) {
SV* const msg = sv_newmortal();
SV* name = NULL;
sv_catpvs(msg, ": none");
sv_catpvs(msg, " vs ");
if (p)
- Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
+ Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
else
sv_catpvs(msg, "none");
Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
{
Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
}
- cv_ckproto((CV*)gv, NULL, ps);
+ cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
}
if (ps)
sv_setpvn((SV*)gv, ps, ps_len);
* skipping the prototype check
*/
if (exists || SvPOK(cv))
- cv_ckproto(cv, gv, ps);
+ cv_ckproto_len(cv, gv, ps, ps_len);
/* already defined (or promised)? */
if (exists || GvASSUMECV(gv)) {
if ((!block
}
}
if (const_sv) {
- SvREFCNT_inc_void_NN(const_sv);
+ SvREFCNT_inc_simple_void_NN(const_sv);
if (cv) {
assert(!CvROOT(cv) && !CvCONST(cv));
sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
else {
/* This makes sub {}; work as expected. */
if (block->op_type == OP_STUB) {
- OP* newblock = newSTATEOP(0, NULL, 0);
+ OP* const newblock = newSTATEOP(0, NULL, 0);
#ifdef PERL_MAD
op_getmad(block,newblock,'B');
#else
call_list(oldscope, PL_beginav);
PL_curcop = &PL_compiling;
- PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
+ CopHINTS_set(&PL_compiling, PL_hints);
LEAVE;
}
else if (strEQ(s, "END") && !PL_error_count) {
{
dVAR;
CV* cv;
+#ifdef USE_ITHREADS
+ const char *const temp_p = CopFILE(PL_curcop);
+ const STRLEN len = strlen(temp_p);
+#else
+ SV *const temp_sv = CopFILESV(PL_curcop);
+ STRLEN len;
+ const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
+#endif
+ char *const file = temp_p ? savepvn(temp_p, len) : NULL;
ENTER;
CopSTASH_set(PL_curcop,stash);
}
- cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
+ /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
+ and so doesn't get free()d. (It's expected to be from the C pre-
+ processor __FILE__ directive). But we need a dynamically allocated one,
+ and we need it to get freed. So we cheat, and take advantage of the
+ fact that the first 0 bytes of any string always look the same. */
+ cv = newXS(name, const_sv_xsub, file);
CvXSUBANY(cv).any_ptr = sv;
CvCONST_on(cv);
- sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
+ /* prototype is "". But this gets free()d. :-) */
+ sv_usepvn_flags((SV*)cv, file, len, SV_HAS_TRAILING_NUL);
+ /* This gives us a prototype of "", rather than the file name. */
+ SvCUR_set(cv, 0);
#ifdef USE_ITHREADS
if (stash)
o = modkids(ck_fun(o), type);
kid = cUNOPo->op_first;
newop = kUNOP->op_first->op_sibling;
- if (newop &&
- (newop->op_sibling ||
- !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
- newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
- newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
-
- return o;
+ if (newop) {
+ const OPCODE type = newop->op_type;
+ if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
+ type == OP_PADAV || type == OP_PADHV ||
+ type == OP_RV2AV || type == OP_RV2HV)
+ return o;
}
#ifdef PERL_MAD
op_getmad(kUNOP->op_first,newop,'K');
}
else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
SVOP * const kid = (SVOP*)cUNOPo->op_first;
+ const OPCODE kidtype = kid->op_type;
- if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
+ if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
OP * const newop = newGVOP(type, OPf_REF,
gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
#ifdef PERL_MAD
}
if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
o->op_private |= OPpFT_ACCESS;
- if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
- && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
+ if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
+ && kidtype != OP_STAT && kidtype != OP_LSTAT)
o->op_private |= OPpFT_STACKED;
}
else {
OP *
Perl_ck_sassign(pTHX_ OP *o)
{
- OP *kid = cLISTOPo->op_first;
+ OP * const kid = cLISTOPo->op_first;
/* has a disposable target? */
if ((PL_opargs[kid->op_type] & OA_TARGLEX)
&& !(kid->op_flags & OPf_STACKED)
dVAR;
OP *firstkid;
- if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
- {
+ if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
HV * const hinthv = GvHV(PL_hintgv);
if (hinthv) {
SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
if (!kid->op_sibling)
append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
+ assert(kid->op_sibling);
kid = kid->op_sibling;
scalar(kid);
OP *o2 = prev->op_sibling;
OP *cvop;
char *proto = NULL;
+ const char *proto_end = NULL;
CV *cv = NULL;
GV *namegv = NULL;
int optional = 0;
tmpop->op_private |= OPpEARLY_CV;
else {
if (SvPOK(cv)) {
+ STRLEN len;
namegv = CvANON(cv) ? gv : CvGV(cv);
- proto = SvPV_nolen((SV*)cv);
+ proto = SvPV((SV*)cv, len);
+ proto_end = proto + len;
}
if (CvASSERTION(cv)) {
if (PL_hints & HINT_ASSERTING) {
else
o3 = o2;
if (proto) {
- switch (*proto) {
- case '\0':
+ if (proto >= proto_end)
return too_many_arguments(o, gv_ename(namegv));
+
+ switch (*proto) {
case ';':
optional = 1;
proto++;
prev = o2;
o2 = o2->op_sibling;
} /* while */
- if (proto && !optional &&
- (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
+ if (proto && !optional && proto_end > proto &&
+ (*proto != '@' && *proto != '%' && *proto != ';'))
return too_few_arguments(o, gv_ename(namegv));
if(delete_op) {
#ifdef PERL_MAD
Perl_ck_chdir(pTHX_ OP *o)
{
if (o->op_flags & OPf_KIDS) {
- SVOP *kid = (SVOP*)cUNOPo->op_first;
+ SVOP * const kid = (SVOP*)cUNOPo->op_first;
if (kid && kid->op_type == OP_CONST &&
(kid->op_private & OPpCONST_BARE))
if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
&& ckWARN(WARN_SYNTAX))
{
- if (o->op_next->op_sibling &&
- o->op_next->op_sibling->op_type != OP_EXIT &&
- o->op_next->op_sibling->op_type != OP_WARN &&
- o->op_next->op_sibling->op_type != OP_DIE) {
- const line_t oldline = CopLINE(PL_curcop);
-
- CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
- Perl_warner(aTHX_ packWARN(WARN_EXEC),
- "Statement unlikely to be reached");
- Perl_warner(aTHX_ packWARN(WARN_EXEC),
- "\t(Maybe you meant system() when you said exec()?)\n");
- CopLINE_set(PL_curcop, oldline);
+ if (o->op_next->op_sibling) {
+ const OPCODE type = o->op_next->op_sibling->op_type;
+ if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
+ const line_t oldline = CopLINE(PL_curcop);
+ CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
+ Perl_warner(aTHX_ packWARN(WARN_EXEC),
+ "Statement unlikely to be reached");
+ Perl_warner(aTHX_ packWARN(WARN_EXEC),
+ "\t(Maybe you meant system() when you said exec()?)\n");
+ CopLINE_set(PL_curcop, oldline);
+ }
}
}
break;
https://perl5.git.perl.org / perl5.git / blobdiff