}
STATIC void
-S_no_bareword_allowed(pTHX_ const OP *o)
+S_no_bareword_allowed(pTHX_ OP *o)
{
PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
qerror(Perl_mess(aTHX_
"Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
SVfARG(cSVOPo_sv)));
+ o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
}
/* "register" allocation */
o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
break;
+ case OP_SASSIGN: {
+ OP *rv2gv;
+ UNOP *refgen, *rv2cv;
+ LISTOP *exlist;
+
+ if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
+ break;
+
+ rv2gv = ((BINOP *)o)->op_last;
+ if (!rv2gv || rv2gv->op_type != OP_RV2GV)
+ break;
+
+ refgen = (UNOP *)((BINOP *)o)->op_first;
+
+ if (!refgen || refgen->op_type != OP_REFGEN)
+ break;
+
+ exlist = (LISTOP *)refgen->op_first;
+ if (!exlist || exlist->op_type != OP_NULL
+ || exlist->op_targ != OP_LIST)
+ break;
+
+ if (exlist->op_first->op_type != OP_PUSHMARK)
+ break;
+
+ rv2cv = (UNOP*)exlist->op_last;
+
+ if (rv2cv->op_type != OP_RV2CV)
+ break;
+
+ assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
+ assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
+ assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
+
+ o->op_private |= OPpASSIGN_CV_TO_GV;
+ rv2gv->op_private |= OPpDONT_INIT_GV;
+ rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
+
+ break;
+ }
+
case OP_OR:
case OP_AND:
kid = cLOGOPo->op_first;
OP *prop_op = (OP *) mp->mad_val;
/* We only need "Relocate sv to the pad for thread safety.", but this
easiest way to make sure it traverses everything */
+ if (prop_op->op_type == OP_CONST)
+ cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
finalize_op(prop_op);
}
mp = mp->mad_next;
PL_curcop = ((COP*)o); /* for warnings */
break;
case OP_EXEC:
- if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
+ if ( o->op_sibling
+ && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
&& ckWARN(WARN_SYNTAX))
{
- if (o->op_next->op_sibling) {
- const OPCODE type = o->op_next->op_sibling->op_type;
+ if (o->op_sibling->op_sibling) {
+ const OPCODE type = o->op_sibling->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));
+ CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
Perl_warner(aTHX_ packWARN(WARN_EXEC),
"Statement unlikely to be reached");
Perl_warner(aTHX_ packWARN(WARN_EXEC),
break;
case OP_CONST:
+ if (cSVOPo->op_private & OPpCONST_STRICT)
+ no_bareword_allowed(o);
+ /* FALLTHROUGH */
#ifdef USE_ITHREADS
case OP_HINTSEVAL:
case OP_METHOD_NAMED:
return o;
}
+ assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
+
switch (o->op_type) {
case OP_UNDEF:
localize = 0;
break;
goto nomod;
case OP_ENTERSUB:
- if ((type == OP_UNDEF || type == OP_REFGEN) &&
+ if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
!(o->op_flags & OPf_STACKED)) {
o->op_type = OP_RV2CV; /* entersub => rv2cv */
/* Both ENTERSUB and RV2CV use this bit, but for different pur-
op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
break;
}
- else if (o->op_private & OPpENTERSUB_NOMOD)
- return o;
else { /* lvalue subroutine call */
o->op_private |= OPpLVAL_INTRO
|(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
case OP_LIST:
localize = 0;
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
- op_lvalue(kid, type);
+ /* elements might be in void context because the list is
+ in scalar context or because they are attribute sub calls */
+ if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
+ op_lvalue(kid, type);
break;
case OP_RETURN:
op_append_elem(OP_LIST,
op_prepend_elem(OP_LIST, pack, list(arg)),
newSVOP(OP_METHOD_NAMED, 0, meth)));
- imop->op_private |= OPpENTERSUB_NOMOD;
/* Combine the ops. */
*imopsp = op_append_elem(OP_LIST, *imopsp, imop);
PERL_ARGS_ASSERT_NEWPROG;
if (PL_in_eval) {
+ PERL_CONTEXT *cx;
if (PL_eval_root)
return;
PL_eval_root = newUNOP(OP_LEAVEEVAL,
((PL_in_eval & EVAL_KEEPERR)
? OPf_SPECIAL : 0), o);
+
+ cx = &cxstack[cxstack_ix];
+ assert(CxTYPE(cx) == CXt_EVAL);
+
+ if ((cx->blk_gimme & G_WANT) == G_VOID)
+ scalarvoid(PL_eval_root);
+ else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
+ list(PL_eval_root);
+ else
+ scalar(PL_eval_root);
+
/* don't use LINKLIST, since PL_eval_root might indirect through
* a rather expensive function call and LINKLIST evaluates its
* argument more than once */
OpREFCNT_set(PL_eval_root, 1);
PL_eval_root->op_next = 0;
CALL_PEEP(PL_eval_start);
+ finalize_optree(PL_eval_root);
+
}
else {
if (o->op_type == OP_STUB) {
PERL_STATIC_INLINE bool
S_aassign_common_vars(pTHX_ OP* o)
{
- OP *lastop = o;
OP *curop;
- for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
+ for (curop = cUNOPo->op_first; curop; curop=curop->op_sibling) {
if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
if (curop->op_type == OP_GV) {
GV *gv = cGVOPx_gv(curop);
curop->op_type == OP_RV2AV ||
curop->op_type == OP_RV2HV ||
curop->op_type == OP_RV2GV) {
- if (lastop->op_type != OP_GV) /* funny deref? */
+ if (cUNOPx(curop)->op_first->op_type != OP_GV) /* funny deref? */
return TRUE;
}
else if (curop->op_type == OP_PUSHRE) {
else
return TRUE;
}
- lastop = curop;
+
+ if (curop->op_flags & OPf_KIDS) {
+ if (aassign_common_vars(curop))
+ return TRUE;
+ }
}
return FALSE;
}
PL_generation++;
if (aassign_common_vars(o))
o->op_private |= OPpASSIGN_COMMON;
+ LINKLIST(o);
}
if (right && right->op_type == OP_SPLIT && !PL_madskills) {
flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
+ /* check barewords before they might be optimized aways */
+ if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
+ no_bareword_allowed(left);
+ if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
+ no_bareword_allowed(right);
+
flip->op_next = o;
if (!flip->op_private || !flop->op_private)
LINKLIST(o); /* blow off optimizer unless constant */
{
PERL_ARGS_ASSERT_CV_CKPROTO_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))))
CvOUTSIDE(PL_compcv) = temp_cv;
CvPADLIST(PL_compcv) = temp_av;
-#ifdef USE_ITHREADS
- if (CvFILE(cv) && !CvISXSUB(cv)) {
- /* for XSUBs CvFILE point directly to static memory; __FILE__ */
+ if (CvFILE(cv) && CvDYNFILE(cv)) {
Safefree(CvFILE(cv));
}
-#endif
CvFILE_set_from_cop(cv, PL_curcop);
CvSTASH_set(cv, PL_curstash);
CopSTASH_set(PL_curcop,stash);
}
- /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
+ /* file becomes the CvFILE. For an XS, it's usually 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. */
PERL_ARGS_ASSERT_NEWXS_FLAGS;
if (flags & XS_DYNAMIC_FILENAME) {
- /* We need to "make arrangements" (ie cheat) to ensure that the
- filename lasts as long as the PVCV we just created, but also doesn't
- leak */
- STRLEN filename_len = strlen(filename);
- STRLEN proto_and_file_len = filename_len;
- char *proto_and_file;
- STRLEN proto_len;
-
- if (proto) {
- proto_len = strlen(proto);
- proto_and_file_len += proto_len;
-
- Newx(proto_and_file, proto_and_file_len + 1, char);
- Copy(proto, proto_and_file, proto_len, char);
- Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
- } else {
- proto_len = 0;
- proto_and_file = savepvn(filename, filename_len);
- }
-
- /* This gets free()d. :-) */
- sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
- SV_HAS_TRAILING_NUL);
- if (proto) {
- /* This gives us the correct prototype, rather than one with the
- file name appended. */
- SvCUR_set(cv, proto_len);
- } else {
- SvPOK_off(cv);
- }
- CvFILE(cv) = proto_and_file + proto_len;
- } else {
- sv_setpv(MUTABLE_SV(cv), proto);
+ CvFILE(cv) = savepv(filename);
+ CvDYNFILE_on(cv);
}
+ sv_setpv(MUTABLE_SV(cv), proto);
return cv;
}
(void)gv_fetchfile(filename);
CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
an external constant string */
+ assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
CvISXSUB_on(cv);
CvXSUB(cv) = subaddr;
return ck_entersub_args_list(entersubop);
}
+OP *
+Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
+{
+ int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
+ OP *aop = cUNOPx(entersubop)->op_first;
+
+ PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
+
+ if (!opnum) {
+ OP *prev, *cvop;
+ if (!aop->op_sibling)
+ aop = cUNOPx(aop)->op_first;
+ prev = aop;
+ aop = aop->op_sibling;
+ for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
+ if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) {
+ aop = aop->op_sibling;
+ continue;
+ }
+ if (aop != cvop)
+ (void)too_many_arguments(entersubop, GvNAME(namegv));
+
+ op_free(entersubop);
+ switch(GvNAME(namegv)[2]) {
+ case 'F': return newSVOP(OP_CONST, 0,
+ newSVpv(CopFILE(PL_curcop),0));
+ case 'L': return newSVOP(
+ OP_CONST, 0,
+ Perl_newSVpvf(aTHX_
+ "%"IVdf, (IV)CopLINE(PL_curcop)
+ )
+ );
+ case 'P': return newSVOP(OP_CONST, 0,
+ (PL_curstash
+ ? newSVhek(HvNAME_HEK(PL_curstash))
+ : &PL_sv_undef
+ )
+ );
+ }
+ assert(0);
+ }
+ else {
+ OP *prev, *cvop;
+ U32 paren;
+#ifdef PERL_MAD
+ bool seenarg = FALSE;
+#endif
+ if (!aop->op_sibling)
+ aop = cUNOPx(aop)->op_first;
+
+ prev = aop;
+ aop = aop->op_sibling;
+ prev->op_sibling = NULL;
+ for (cvop = aop;
+ cvop->op_sibling;
+ prev=cvop, cvop = cvop->op_sibling)
+#ifdef PERL_MAD
+ if (PL_madskills && cvop->op_sibling
+ && cvop->op_type != OP_STUB) seenarg = TRUE
+#endif
+ ;
+ prev->op_sibling = NULL;
+ paren = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
+ op_free(cvop);
+ if (aop == cvop) aop = NULL;
+ op_free(entersubop);
+
+ switch (PL_opargs[opnum] & OA_CLASS_MASK) {
+ case OA_UNOP:
+ case OA_BASEOP_OR_UNOP:
+ case OA_FILESTATOP:
+ return aop ? newUNOP(opnum,paren,aop) : newOP(opnum,paren);
+ case OA_BASEOP:
+ if (aop) {
+#ifdef PERL_MAD
+ if (!PL_madskills || seenarg)
+#endif
+ (void)too_many_arguments(aop, GvNAME(namegv));
+ op_free(aop);
+ }
+ return newOP(opnum,0);
+ default:
+ return convert(opnum,0,aop);
+ }
+ }
+ assert(0);
+ return entersubop;
+}
+
/*
=for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
}
break;
- case OP_CONST:
- if (cSVOPo->op_private & OPpCONST_STRICT)
- no_bareword_allowed(o);
- break;
-
case OP_CONCAT:
if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
if (o->op_next->op_private & OPpTARGET_MY) {
break;
}
- case OP_SASSIGN: {
- OP *rv2gv;
- UNOP *refgen, *rv2cv;
- LISTOP *exlist;
-
- if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
- break;
-
- if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
- break;
-
- rv2gv = ((BINOP *)o)->op_last;
- if (!rv2gv || rv2gv->op_type != OP_RV2GV)
- break;
-
- refgen = (UNOP *)((BINOP *)o)->op_first;
-
- if (!refgen || refgen->op_type != OP_REFGEN)
- break;
-
- exlist = (LISTOP *)refgen->op_first;
- if (!exlist || exlist->op_type != OP_NULL
- || exlist->op_targ != OP_LIST)
- break;
-
- if (exlist->op_first->op_type != OP_PUSHMARK)
- break;
-
- rv2cv = (UNOP*)exlist->op_last;
-
- if (rv2cv->op_type != OP_RV2CV)
- break;
-
- assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
- assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
- assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
-
- o->op_private |= OPpASSIGN_CV_TO_GV;
- rv2gv->op_private |= OPpDONT_INIT_GV;
- rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
-
- break;
- }
-
-
case OP_QR:
case OP_MATCH:
if (!(cPMOP->op_pmflags & PMf_ONCE)) {
=for apidoc core_prototype
This function assigns the prototype of the named core function to C<sv>, or
to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
-NULL if the core function has no prototype.
-
-If the C<name> is not a Perl keyword, it croaks if C<croak> is true, or
-returns NULL if C<croak> is false.
+NULL if the core function has no prototype. C<code> is a code as returned
+by C<keyword()>. It must be negative and unequal to -KEY_CORE.
=cut
*/
SV *
-Perl_core_prototype(pTHX_ SV *sv, const char *name, const STRLEN len,
- const bool croak)
+Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
+ int * const opnum)
{
- const int code = keyword(name, len, 1);
int i = 0, n = 0, seen_question = 0, defgv = 0;
I32 oa;
#define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
+ bool nullret = FALSE;
PERL_ARGS_ASSERT_CORE_PROTOTYPE;
- if (!code) {
- if (croak)
- return (SV *)Perl_die(aTHX_
- "Can't find an opnumber for \"%s\"", name
- );
- return NULL;
- }
-
- if (code > 0) return NULL; /* Not overridable */
+ assert (code < 0 && code != -KEY_CORE);
if (!sv) sv = sv_newmortal();
-#define retsetpvs(x) sv_setpvs(sv, x); return sv
+#define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
switch (-code) {
case KEY_and : case KEY_chop: case KEY_chomp:
case KEY_cmp : case KEY_exec: case KEY_eq :
case KEY_ge : case KEY_gt : case KEY_le :
- case KEY_lstat : case KEY_lt : case KEY_ne : case KEY_or :
- case KEY_stat : case KEY_system: case KEY_x : case KEY_xor:
- return NULL;
- case KEY_keys: case KEY_values: case KEY_each:
- retsetpvs("+");
- case KEY_push: case KEY_unshift:
- retsetpvs("+@");
- case KEY_pop: case KEY_shift:
- retsetpvs(";+");
+ case KEY_lt : case KEY_ne : case KEY_or :
+ case KEY_select: case KEY_system: case KEY_x : case KEY_xor:
+ if (!opnum) return NULL; nullret = TRUE; goto findopnum;
+ case KEY_keys: retsetpvs("+", OP_KEYS);
+ case KEY_values: retsetpvs("+", OP_VALUES);
+ case KEY_each: retsetpvs("+", OP_EACH);
+ case KEY_push: retsetpvs("+@", OP_PUSH);
+ case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
+ case KEY_pop: retsetpvs(";+", OP_POP);
+ case KEY_shift: retsetpvs(";+", OP_SHIFT);
case KEY_splice:
- retsetpvs("+;$$@");
+ retsetpvs("+;$$@", OP_SPLICE);
case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
- retsetpvs("");
+ retsetpvs("", 0);
case KEY_readpipe:
name = "backtick";
}
#undef retsetpvs
+ findopnum:
while (i < MAXO) { /* The slow way. */
if (strEQ(name, PL_op_name[i])
|| strEQ(name, PL_op_desc[i]))
{
+ if (nullret) { assert(opnum); *opnum = i; return NULL; }
goto found;
}
i++;
}
- return NULL; /* Should not happen... */
+ assert(0); return NULL; /* Should not happen... */
found:
defgv = PL_opargs[i] & OA_DEFGV;
oa = PL_opargs[i] >> OASHIFT;
while (oa) {
- if (oa & OA_OPTIONAL && !seen_question && (!defgv || n)) {
+ if (oa & OA_OPTIONAL && !seen_question && (
+ !defgv || n || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
+ )) {
seen_question = 1;
str[n++] = ';';
}
str[n++] = '$';
str[n++] = '@';
str[n++] = '%';
+ if (i == OP_LOCK) str[n++] = '&';
str[n++] = '*';
str[n++] = ']';
}
}
if (defgv && str[0] == '$')
str[0] = '_';
+ if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
str[n++] = '\0';
sv_setpvn(sv, str, n - 1);
+ if (opnum) *opnum = i;
return sv;
}
https://perl5.git.perl.org / perl5.git / blobdiff