- kid = cLISTOPo->op_first;
- kid = OpSIBLING(kid); /* get past pushmark */
- assert(OpSIBLING(kid));
- name = S_op_varname(aTHX_ OpSIBLING(kid));
- if (!name) /* XS module fiddling with the op tree */
- break;
- S_op_pretty(aTHX_ kid, &keysv, &key);
- assert(SvPOK(name));
- sv_chop(name,SvPVX(name)+1);
- if (key)
- /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
- Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "%%%" SVf "%c%s%c in scalar context better written "
- "as $%" SVf "%c%s%c",
- SVfARG(name), lbrack, key, rbrack, SVfARG(name),
- lbrack, key, rbrack);
- else
- /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
- Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "%%%" SVf "%c%" SVf "%c in scalar context better "
- "written as $%" SVf "%c%" SVf "%c",
- SVfARG(name), lbrack, SVfARG(keysv), rbrack,
- SVfARG(name), lbrack, SVfARG(keysv), rbrack);
- }
- }
- return o;
+ default:
+ if (o->op_flags & OPf_KIDS)
+ next_kid = cUNOPo->op_first; /* do all kids */
+ break;
+
+ /* the children of these ops are usually a list of statements,
+ * except the leaves, whose first child is a corresponding enter
+ */
+ case OP_SCOPE:
+ case OP_LINESEQ:
+ case OP_LIST:
+ kid = cLISTOPo->op_first;
+ goto do_kids;
+ case OP_LEAVE:
+ case OP_LEAVETRY:
+ kid = cLISTOPo->op_first;
+ scalar(kid);
+ kid = OpSIBLING(kid);
+ do_kids:
+ while (kid) {
+ OP *sib = OpSIBLING(kid);
+ /* Apply void context to all kids except the last, which
+ * is scalar (ignoring a trailing ex-nextstate in determining
+ * if it's the last kid). E.g.
+ * $scalar = do { void; void; scalar }
+ * Except that 'when's are always scalar, e.g.
+ * $scalar = do { given(..) {
+ * when (..) { scalar }
+ * when (..) { scalar }
+ * ...
+ * }}
+ */
+ if (!sib
+ || ( !OpHAS_SIBLING(sib)
+ && sib->op_type == OP_NULL
+ && ( sib->op_targ == OP_NEXTSTATE
+ || sib->op_targ == OP_DBSTATE )
+ )
+ )
+ {
+ /* tail call optimise calling scalar() on the last kid */
+ next_kid = kid;
+ goto do_next;
+ }
+ else if (kid->op_type == OP_LEAVEWHEN)
+ scalar(kid);
+ else
+ scalarvoid(kid);
+ kid = sib;
+ }
+ NOT_REACHED; /* NOTREACHED */
+ break;
+
+ case OP_SORT:
+ Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
+ break;
+
+ case OP_KVHSLICE:
+ case OP_KVASLICE:
+ {
+ /* Warn about scalar context */
+ const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
+ const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
+ SV *name;
+ SV *keysv;
+ const char *key = NULL;
+
+ /* This warning can be nonsensical when there is a syntax error. */
+ if (PL_parser && PL_parser->error_count)
+ break;
+
+ if (!ckWARN(WARN_SYNTAX)) break;
+
+ kid = cLISTOPo->op_first;
+ kid = OpSIBLING(kid); /* get past pushmark */
+ assert(OpSIBLING(kid));
+ name = S_op_varname(aTHX_ OpSIBLING(kid));
+ if (!name) /* XS module fiddling with the op tree */
+ break;
+ S_op_pretty(aTHX_ kid, &keysv, &key);
+ assert(SvPOK(name));
+ sv_chop(name,SvPVX(name)+1);
+ if (key)
+ /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "%%%" SVf "%c%s%c in scalar context better written "
+ "as $%" SVf "%c%s%c",
+ SVfARG(name), lbrack, key, rbrack, SVfARG(name),
+ lbrack, key, rbrack);
+ else
+ /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "%%%" SVf "%c%" SVf "%c in scalar context better "
+ "written as $%" SVf "%c%" SVf "%c",
+ SVfARG(name), lbrack, SVfARG(keysv), rbrack,
+ SVfARG(name), lbrack, SVfARG(keysv), rbrack);
+ }
+ } /* switch */
+
+ /* If next_kid is set, someone in the code above wanted us to process
+ * that kid and all its remaining siblings. Otherwise, work our way
+ * back up the tree */
+ do_next:
+ while (!next_kid) {
+ if (o == top_op)
+ return top_op; /* at top; no parents/siblings to try */
+ if (OpHAS_SIBLING(o))
+ next_kid = o->op_sibparent;
+ else {
+ o = o->op_sibparent; /*try parent's next sibling */
+ switch (o->op_type) {
+ case OP_SCOPE:
+ case OP_LINESEQ:
+ case OP_LIST:
+ case OP_LEAVE:
+ case OP_LEAVETRY:
+ /* should really restore PL_curcop to its old value, but
+ * setting it to PL_compiling is better than do nothing */
+ PL_curcop = &PL_compiling;
+ }
+ }
+ }
+ o = next_kid;
+ } /* while */