1 #line 2 "op.c"
2 /* op.c
3 *
4 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
5 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 *
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
9 *
10 */
11
12 /*
13 * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
14 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
15 * youngest of the Old Took's daughters); and Mr. Drogo was his second
16 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
17 * either way, as the saying is, if you follow me.' --the Gaffer
18 *
19 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
20 */
21
22 /* This file contains the functions that create, manipulate and optimize
23 * the OP structures that hold a compiled perl program.
24 *
25 * Note that during the build of miniperl, a temporary copy of this file
26 * is made, called opmini.c.
27 *
28 * A Perl program is compiled into a tree of OP nodes. Each op contains:
29 * * structural OP pointers to its children and siblings (op_sibling,
30 * op_first etc) that define the tree structure;
31 * * execution order OP pointers (op_next, plus sometimes op_other,
32 * op_lastop etc) that define the execution sequence plus variants;
33 * * a pointer to the C "pp" function that would execute the op;
34 * * any data specific to that op.
35 * For example, an OP_CONST op points to the pp_const() function and to an
36 * SV containing the constant value. When pp_const() is executed, its job
37 * is to push that SV onto the stack.
38 *
39 * OPs are mainly created by the newFOO() functions, which are mainly
40 * called from the parser (in perly.y) as the code is parsed. For example
41 * the Perl code $a + $b * $c would cause the equivalent of the following
42 * to be called (oversimplifying a bit):
43 *
44 * newBINOP(OP_ADD, flags,
45 * newSVREF($a),
46 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
47 * )
48 *
49 * As the parser reduces low-level rules, it creates little op subtrees;
50 * as higher-level rules are resolved, these subtrees get joined together
51 * as branches on a bigger subtree, until eventually a top-level rule like
52 * a subroutine definition is reduced, at which point there is one large
53 * parse tree left.
54 *
55 * The execution order pointers (op_next) are generated as the subtrees
56 * are joined together. Consider this sub-expression: A*B + C/D: at the
57 * point when it's just been parsed, the op tree looks like:
58 *
59 * [+]
60 * |
61 * [*]------[/]
62 * | |
63 * A---B C---D
64 *
65 * with the intended execution order being:
66 *
67 * [PREV] => A => B => [*] => C => D => [/] => [+] => [NEXT]
68 *
69 * At this point all the nodes' op_next pointers will have been set,
70 * except that:
71 * * we don't know what the [NEXT] node will be yet;
72 * * we don't know what the [PREV] node will be yet, but when it gets
73 * created and needs its op_next set, it needs to be set to point to
74 * A, which is non-obvious.
75 * To handle both those cases, we temporarily set the top node's
76 * op_next to point to the first node to be executed in this subtree (A in
77 * this case). This means that initially a subtree's op_next chain,
78 * starting from the top node, will visit each node in execution sequence
79 * then point back at the top node.
80 * When we embed this subtree in a larger tree, its top op_next is used
81 * to get the start node, then is set to point to its new neighbour.
82 * For example the two separate [*],A,B and [/],C,D subtrees would
83 * initially have had:
84 * [*] => A; A => B; B => [*]
85 * and
86 * [/] => C; C => D; D => [/]
87 * When these two subtrees were joined together to make the [+] subtree,
88 * [+]'s op_next was set to [*]'s op_next, i.e. A; then [*]'s op_next was
89 * set to point to [/]'s op_next, i.e. C.
90 *
91 * This op_next linking is done by the LINKLIST() macro and its underlying
92 * op_linklist() function. Given a top-level op, if its op_next is
93 * non-null, it's already been linked, so leave it. Otherwise link it with
94 * its children as described above, possibly recursively if any of the
95 * children have a null op_next.
96 *
97 * In summary: given a subtree, its top-level node's op_next will either
98 * be:
99 * NULL: the subtree hasn't been LINKLIST()ed yet;
100 * fake: points to the start op for this subtree;
101 * real: once the subtree has been embedded into a larger tree
102 */
103
104 /*
105
106 Here's an older description from Larry.
107
108 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
109
110 A bottom-up pass
111 A top-down pass
112 An execution-order pass
113
114 The bottom-up pass is represented by all the "newOP" routines and
115 the ck_ routines. The bottom-upness is actually driven by yacc.
116 So at the point that a ck_ routine fires, we have no idea what the
117 context is, either upward in the syntax tree, or either forward or
118 backward in the execution order. (The bottom-up parser builds that
119 part of the execution order it knows about, but if you follow the "next"
120 links around, you'll find it's actually a closed loop through the
121 top level node.)
122
123 Whenever the bottom-up parser gets to a node that supplies context to
124 its components, it invokes that portion of the top-down pass that applies
125 to that part of the subtree (and marks the top node as processed, so
126 if a node further up supplies context, it doesn't have to take the
127 plunge again). As a particular subcase of this, as the new node is
128 built, it takes all the closed execution loops of its subcomponents
129 and links them into a new closed loop for the higher level node. But
130 it's still not the real execution order.
131
132 The actual execution order is not known till we get a grammar reduction
133 to a top-level unit like a subroutine or file that will be called by
134 "name" rather than via a "next" pointer. At that point, we can call
135 into peep() to do that code's portion of the 3rd pass. It has to be
136 recursive, but it's recursive on basic blocks, not on tree nodes.
137 */
138
139 /* To implement user lexical pragmas, there needs to be a way at run time to
140 get the compile time state of %^H for that block. Storing %^H in every
141 block (or even COP) would be very expensive, so a different approach is
142 taken. The (running) state of %^H is serialised into a tree of HE-like
143 structs. Stores into %^H are chained onto the current leaf as a struct
144 refcounted_he * with the key and the value. Deletes from %^H are saved
145 with a value of PL_sv_placeholder. The state of %^H at any point can be
146 turned back into a regular HV by walking back up the tree from that point's
147 leaf, ignoring any key you've already seen (placeholder or not), storing
148 the rest into the HV structure, then removing the placeholders. Hence
149 memory is only used to store the %^H deltas from the enclosing COP, rather
150 than the entire %^H on each COP.
151
152 To cause actions on %^H to write out the serialisation records, it has
153 magic type 'H'. This magic (itself) does nothing, but its presence causes
154 the values to gain magic type 'h', which has entries for set and clear.
155 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
156 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
157 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
158 it will be correctly restored when any inner compiling scope is exited.
159 */
160
161 #include "EXTERN.h"
162 #define PERL_IN_OP_C
163 #include "perl.h"
164 #include "keywords.h"
165 #include "feature.h"
166 #include "regcomp.h"
167
168 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
169 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
170 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
171
172 static const char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar";
173
174 /* Used to avoid recursion through the op tree in scalarvoid() and
175 op_free()
176 */
177
178 #define dDEFER_OP \
179 SSize_t defer_stack_alloc = 0; \
180 SSize_t defer_ix = -1; \
181 OP **defer_stack = NULL;
182 #define DEFER_OP_CLEANUP Safefree(defer_stack)
183 #define DEFERRED_OP_STEP 100
184 #define DEFER_OP(o) \
185 STMT_START { \
186 if (UNLIKELY(defer_ix == (defer_stack_alloc-1))) { \
187 defer_stack_alloc += DEFERRED_OP_STEP; \
188 assert(defer_stack_alloc > 0); \
189 Renew(defer_stack, defer_stack_alloc, OP *); \
190 } \
191 defer_stack[++defer_ix] = o; \
192 } STMT_END
193 #define DEFER_REVERSE(count) \
194 STMT_START { \
195 UV cnt = (count); \
196 if (cnt > 1) { \
197 OP **top = defer_stack + defer_ix; \
198 /* top - (cnt) + 1 isn't safe here */ \
199 OP **bottom = top - (cnt - 1); \
200 OP *tmp; \
201 assert(bottom >= defer_stack); \
202 while (top > bottom) { \
203 tmp = *top; \
204 *top-- = *bottom; \
205 *bottom++ = tmp; \
206 } \
207 } \
208 } STMT_END;
209
210 #define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL)
211
212 /* remove any leading "empty" ops from the op_next chain whose first
213 * node's address is stored in op_p. Store the updated address of the
214 * first node in op_p.
215 */
216
217 STATIC void
S_prune_chain_head(OP ** op_p)218 S_prune_chain_head(OP** op_p)
219 {
220 while (*op_p
221 && ( (*op_p)->op_type == OP_NULL
222 || (*op_p)->op_type == OP_SCOPE
223 || (*op_p)->op_type == OP_SCALAR
224 || (*op_p)->op_type == OP_LINESEQ)
225 )
226 *op_p = (*op_p)->op_next;
227 }
228
229
230 /* See the explanatory comments above struct opslab in op.h. */
231
232 #ifdef PERL_DEBUG_READONLY_OPS
233 # define PERL_SLAB_SIZE 128
234 # define PERL_MAX_SLAB_SIZE 4096
235 # include <sys/mman.h>
236 #endif
237
238 #ifndef PERL_SLAB_SIZE
239 # define PERL_SLAB_SIZE 64
240 #endif
241 #ifndef PERL_MAX_SLAB_SIZE
242 # define PERL_MAX_SLAB_SIZE 2048
243 #endif
244
245 /* rounds up to nearest pointer */
246 #define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
247 #define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
248
249 /* malloc a new op slab (suitable for attaching to PL_compcv) */
250
251 static OPSLAB *
S_new_slab(pTHX_ size_t sz)252 S_new_slab(pTHX_ size_t sz)
253 {
254 #ifdef PERL_DEBUG_READONLY_OPS
255 OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
256 PROT_READ|PROT_WRITE,
257 MAP_ANON|MAP_PRIVATE, -1, 0);
258 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
259 (unsigned long) sz, slab));
260 if (slab == MAP_FAILED) {
261 perror("mmap failed");
262 abort();
263 }
264 slab->opslab_size = (U16)sz;
265 #else
266 OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
267 #endif
268 #ifndef WIN32
269 /* The context is unused in non-Windows */
270 PERL_UNUSED_CONTEXT;
271 #endif
272 slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
273 return slab;
274 }
275
276 /* requires double parens and aTHX_ */
277 #define DEBUG_S_warn(args) \
278 DEBUG_S( \
279 PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
280 )
281
282 /* Returns a sz-sized block of memory (suitable for holding an op) from
283 * a free slot in the chain of op slabs attached to PL_compcv.
284 * Allocates a new slab if necessary.
285 * if PL_compcv isn't compiling, malloc() instead.
286 */
287
288 void *
Perl_Slab_Alloc(pTHX_ size_t sz)289 Perl_Slab_Alloc(pTHX_ size_t sz)
290 {
291 OPSLAB *slab;
292 OPSLAB *slab2;
293 OPSLOT *slot;
294 OP *o;
295 size_t opsz, space;
296
297 /* We only allocate ops from the slab during subroutine compilation.
298 We find the slab via PL_compcv, hence that must be non-NULL. It could
299 also be pointing to a subroutine which is now fully set up (CvROOT()
300 pointing to the top of the optree for that sub), or a subroutine
301 which isn't using the slab allocator. If our sanity checks aren't met,
302 don't use a slab, but allocate the OP directly from the heap. */
303 if (!PL_compcv || CvROOT(PL_compcv)
304 || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
305 {
306 o = (OP*)PerlMemShared_calloc(1, sz);
307 goto gotit;
308 }
309
310 /* While the subroutine is under construction, the slabs are accessed via
311 CvSTART(), to avoid needing to expand PVCV by one pointer for something
312 unneeded at runtime. Once a subroutine is constructed, the slabs are
313 accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
314 allocated yet. See the commit message for 8be227ab5eaa23f2 for more
315 details. */
316 if (!CvSTART(PL_compcv)) {
317 CvSTART(PL_compcv) =
318 (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
319 CvSLABBED_on(PL_compcv);
320 slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
321 }
322 else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
323
324 opsz = SIZE_TO_PSIZE(sz);
325 sz = opsz + OPSLOT_HEADER_P;
326
327 /* The slabs maintain a free list of OPs. In particular, constant folding
328 will free up OPs, so it makes sense to re-use them where possible. A
329 freed up slot is used in preference to a new allocation. */
330 if (slab->opslab_freed) {
331 OP **too = &slab->opslab_freed;
332 o = *too;
333 DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
334 while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
335 DEBUG_S_warn((aTHX_ "Alas! too small"));
336 o = *(too = &o->op_next);
337 if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
338 }
339 if (o) {
340 *too = o->op_next;
341 Zero(o, opsz, I32 *);
342 o->op_slabbed = 1;
343 goto gotit;
344 }
345 }
346
347 #define INIT_OPSLOT \
348 slot->opslot_slab = slab; \
349 slot->opslot_next = slab2->opslab_first; \
350 slab2->opslab_first = slot; \
351 o = &slot->opslot_op; \
352 o->op_slabbed = 1
353
354 /* The partially-filled slab is next in the chain. */
355 slab2 = slab->opslab_next ? slab->opslab_next : slab;
356 if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
357 /* Remaining space is too small. */
358
359 /* If we can fit a BASEOP, add it to the free chain, so as not
360 to waste it. */
361 if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
362 slot = &slab2->opslab_slots;
363 INIT_OPSLOT;
364 o->op_type = OP_FREED;
365 o->op_next = slab->opslab_freed;
366 slab->opslab_freed = o;
367 }
368
369 /* Create a new slab. Make this one twice as big. */
370 slot = slab2->opslab_first;
371 while (slot->opslot_next) slot = slot->opslot_next;
372 slab2 = S_new_slab(aTHX_
373 (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
374 ? PERL_MAX_SLAB_SIZE
375 : (DIFF(slab2, slot)+1)*2);
376 slab2->opslab_next = slab->opslab_next;
377 slab->opslab_next = slab2;
378 }
379 assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
380
381 /* Create a new op slot */
382 slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
383 assert(slot >= &slab2->opslab_slots);
384 if (DIFF(&slab2->opslab_slots, slot)
385 < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
386 slot = &slab2->opslab_slots;
387 INIT_OPSLOT;
388 DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
389
390 gotit:
391 /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
392 assert(!o->op_moresib);
393 assert(!o->op_sibparent);
394
395 return (void *)o;
396 }
397
398 #undef INIT_OPSLOT
399
400 #ifdef PERL_DEBUG_READONLY_OPS
401 void
Perl_Slab_to_ro(pTHX_ OPSLAB * slab)402 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
403 {
404 PERL_ARGS_ASSERT_SLAB_TO_RO;
405
406 if (slab->opslab_readonly) return;
407 slab->opslab_readonly = 1;
408 for (; slab; slab = slab->opslab_next) {
409 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
410 (unsigned long) slab->opslab_size, slab));*/
411 if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
412 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
413 (unsigned long)slab->opslab_size, errno);
414 }
415 }
416
417 void
Perl_Slab_to_rw(pTHX_ OPSLAB * const slab)418 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
419 {
420 OPSLAB *slab2;
421
422 PERL_ARGS_ASSERT_SLAB_TO_RW;
423
424 if (!slab->opslab_readonly) return;
425 slab2 = slab;
426 for (; slab2; slab2 = slab2->opslab_next) {
427 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
428 (unsigned long) size, slab2));*/
429 if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
430 PROT_READ|PROT_WRITE)) {
431 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
432 (unsigned long)slab2->opslab_size, errno);
433 }
434 }
435 slab->opslab_readonly = 0;
436 }
437
438 #else
439 # define Slab_to_rw(op) NOOP
440 #endif
441
442 /* This cannot possibly be right, but it was copied from the old slab
443 allocator, to which it was originally added, without explanation, in
444 commit 083fcd5. */
445 #ifdef NETWARE
446 # define PerlMemShared PerlMem
447 #endif
448
449 /* make freed ops die if they're inadvertently executed */
450 #ifdef DEBUGGING
451 static OP *
S_pp_freed(pTHX)452 S_pp_freed(pTHX)
453 {
454 DIE(aTHX_ "panic: freed op 0x%p called\n", PL_op);
455 }
456 #endif
457
458
459 /* Return the block of memory used by an op to the free list of
460 * the OP slab associated with that op.
461 */
462
463 void
Perl_Slab_Free(pTHX_ void * op)464 Perl_Slab_Free(pTHX_ void *op)
465 {
466 OP * const o = (OP *)op;
467 OPSLAB *slab;
468
469 PERL_ARGS_ASSERT_SLAB_FREE;
470
471 #ifdef DEBUGGING
472 o->op_ppaddr = S_pp_freed;
473 #endif
474
475 if (!o->op_slabbed) {
476 if (!o->op_static)
477 PerlMemShared_free(op);
478 return;
479 }
480
481 slab = OpSLAB(o);
482 /* If this op is already freed, our refcount will get screwy. */
483 assert(o->op_type != OP_FREED);
484 o->op_type = OP_FREED;
485 o->op_next = slab->opslab_freed;
486 slab->opslab_freed = o;
487 DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
488 OpslabREFCNT_dec_padok(slab);
489 }
490
491 void
Perl_opslab_free_nopad(pTHX_ OPSLAB * slab)492 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
493 {
494 const bool havepad = !!PL_comppad;
495 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
496 if (havepad) {
497 ENTER;
498 PAD_SAVE_SETNULLPAD();
499 }
500 opslab_free(slab);
501 if (havepad) LEAVE;
502 }
503
504 /* Free a chain of OP slabs. Should only be called after all ops contained
505 * in it have been freed. At this point, its reference count should be 1,
506 * because OpslabREFCNT_dec() skips doing rc-- when it detects that rc == 1,
507 * and just directly calls opslab_free().
508 * (Note that the reference count which PL_compcv held on the slab should
509 * have been removed once compilation of the sub was complete).
510 *
511 *
512 */
513
514 void
Perl_opslab_free(pTHX_ OPSLAB * slab)515 Perl_opslab_free(pTHX_ OPSLAB *slab)
516 {
517 OPSLAB *slab2;
518 PERL_ARGS_ASSERT_OPSLAB_FREE;
519 PERL_UNUSED_CONTEXT;
520 DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
521 assert(slab->opslab_refcnt == 1);
522 do {
523 slab2 = slab->opslab_next;
524 #ifdef DEBUGGING
525 slab->opslab_refcnt = ~(size_t)0;
526 #endif
527 #ifdef PERL_DEBUG_READONLY_OPS
528 DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
529 (void*)slab));
530 if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
531 perror("munmap failed");
532 abort();
533 }
534 #else
535 PerlMemShared_free(slab);
536 #endif
537 slab = slab2;
538 } while (slab);
539 }
540
541 /* like opslab_free(), but first calls op_free() on any ops in the slab
542 * not marked as OP_FREED
543 */
544
545 void
Perl_opslab_force_free(pTHX_ OPSLAB * slab)546 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
547 {
548 OPSLAB *slab2;
549 #ifdef DEBUGGING
550 size_t savestack_count = 0;
551 #endif
552 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
553 slab2 = slab;
554 do {
555 OPSLOT *slot;
556 for (slot = slab2->opslab_first;
557 slot->opslot_next;
558 slot = slot->opslot_next) {
559 if (slot->opslot_op.op_type != OP_FREED
560 && !(slot->opslot_op.op_savefree
561 #ifdef DEBUGGING
562 && ++savestack_count
563 #endif
564 )
565 ) {
566 assert(slot->opslot_op.op_slabbed);
567 op_free(&slot->opslot_op);
568 if (slab->opslab_refcnt == 1) goto free;
569 }
570 }
571 } while ((slab2 = slab2->opslab_next));
572 /* > 1 because the CV still holds a reference count. */
573 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
574 #ifdef DEBUGGING
575 assert(savestack_count == slab->opslab_refcnt-1);
576 #endif
577 /* Remove the CV’s reference count. */
578 slab->opslab_refcnt--;
579 return;
580 }
581 free:
582 opslab_free(slab);
583 }
584
585 #ifdef PERL_DEBUG_READONLY_OPS
586 OP *
Perl_op_refcnt_inc(pTHX_ OP * o)587 Perl_op_refcnt_inc(pTHX_ OP *o)
588 {
589 if(o) {
590 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
591 if (slab && slab->opslab_readonly) {
592 Slab_to_rw(slab);
593 ++o->op_targ;
594 Slab_to_ro(slab);
595 } else {
596 ++o->op_targ;
597 }
598 }
599 return o;
600
601 }
602
603 PADOFFSET
Perl_op_refcnt_dec(pTHX_ OP * o)604 Perl_op_refcnt_dec(pTHX_ OP *o)
605 {
606 PADOFFSET result;
607 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
608
609 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
610
611 if (slab && slab->opslab_readonly) {
612 Slab_to_rw(slab);
613 result = --o->op_targ;
614 Slab_to_ro(slab);
615 } else {
616 result = --o->op_targ;
617 }
618 return result;
619 }
620 #endif
621 /*
622 * In the following definition, the ", (OP*)0" is just to make the compiler
623 * think the expression is of the right type: croak actually does a Siglongjmp.
624 */
625 #define CHECKOP(type,o) \
626 ((PL_op_mask && PL_op_mask[type]) \
627 ? ( op_free((OP*)o), \
628 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
629 (OP*)0 ) \
630 : PL_check[type](aTHX_ (OP*)o))
631
632 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
633
634 #define OpTYPE_set(o,type) \
635 STMT_START { \
636 o->op_type = (OPCODE)type; \
637 o->op_ppaddr = PL_ppaddr[type]; \
638 } STMT_END
639
640 STATIC OP *
S_no_fh_allowed(pTHX_ OP * o)641 S_no_fh_allowed(pTHX_ OP *o)
642 {
643 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
644
645 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
646 OP_DESC(o)));
647 return o;
648 }
649
650 STATIC OP *
S_too_few_arguments_pv(pTHX_ OP * o,const char * name,U32 flags)651 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
652 {
653 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
654 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
655 return o;
656 }
657
658 STATIC OP *
S_too_many_arguments_pv(pTHX_ OP * o,const char * name,U32 flags)659 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
660 {
661 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
662
663 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
664 return o;
665 }
666
667 STATIC void
S_bad_type_pv(pTHX_ I32 n,const char * t,const OP * o,const OP * kid)668 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
669 {
670 PERL_ARGS_ASSERT_BAD_TYPE_PV;
671
672 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
673 (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
674 }
675
676 /* remove flags var, its unused in all callers, move to to right end since gv
677 and kid are always the same */
678 STATIC void
S_bad_type_gv(pTHX_ I32 n,GV * gv,const OP * kid,const char * t)679 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
680 {
681 SV * const namesv = cv_name((CV *)gv, NULL, 0);
682 PERL_ARGS_ASSERT_BAD_TYPE_GV;
683
684 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)",
685 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
686 }
687
688 STATIC void
S_no_bareword_allowed(pTHX_ OP * o)689 S_no_bareword_allowed(pTHX_ OP *o)
690 {
691 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
692
693 qerror(Perl_mess(aTHX_
694 "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use",
695 SVfARG(cSVOPo_sv)));
696 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
697 }
698
699 /* "register" allocation */
700
701 PADOFFSET
Perl_allocmy(pTHX_ const char * const name,const STRLEN len,const U32 flags)702 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
703 {
704 PADOFFSET off;
705 const bool is_our = (PL_parser->in_my == KEY_our);
706
707 PERL_ARGS_ASSERT_ALLOCMY;
708
709 if (flags & ~SVf_UTF8)
710 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
711 (UV)flags);
712
713 /* complain about "my $<special_var>" etc etc */
714 if ( len
715 && !( is_our
716 || isALPHA(name[1])
717 || ( (flags & SVf_UTF8)
718 && isIDFIRST_utf8_safe((U8 *)name+1, name + len))
719 || (name[1] == '_' && len > 2)))
720 {
721 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
722 && isASCII(name[1])
723 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
724 /* diag_listed_as: Can't use global %s in "%s" */
725 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
726 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
727 PL_parser->in_my == KEY_state ? "state" : "my"));
728 } else {
729 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
730 PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
731 }
732 }
733
734 /* allocate a spare slot and store the name in that slot */
735
736 off = pad_add_name_pvn(name, len,
737 (is_our ? padadd_OUR :
738 PL_parser->in_my == KEY_state ? padadd_STATE : 0),
739 PL_parser->in_my_stash,
740 (is_our
741 /* $_ is always in main::, even with our */
742 ? (PL_curstash && !memEQs(name,len,"$_")
743 ? PL_curstash
744 : PL_defstash)
745 : NULL
746 )
747 );
748 /* anon sub prototypes contains state vars should always be cloned,
749 * otherwise the state var would be shared between anon subs */
750
751 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
752 CvCLONE_on(PL_compcv);
753
754 return off;
755 }
756
757 /*
758 =head1 Optree Manipulation Functions
759
760 =for apidoc alloccopstash
761
762 Available only under threaded builds, this function allocates an entry in
763 C<PL_stashpad> for the stash passed to it.
764
765 =cut
766 */
767
768 #ifdef USE_ITHREADS
769 PADOFFSET
Perl_alloccopstash(pTHX_ HV * hv)770 Perl_alloccopstash(pTHX_ HV *hv)
771 {
772 PADOFFSET off = 0, o = 1;
773 bool found_slot = FALSE;
774
775 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
776
777 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
778
779 for (; o < PL_stashpadmax; ++o) {
780 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
781 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
782 found_slot = TRUE, off = o;
783 }
784 if (!found_slot) {
785 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
786 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
787 off = PL_stashpadmax;
788 PL_stashpadmax += 10;
789 }
790
791 PL_stashpad[PL_stashpadix = off] = hv;
792 return off;
793 }
794 #endif
795
796 /* free the body of an op without examining its contents.
797 * Always use this rather than FreeOp directly */
798
799 static void
S_op_destroy(pTHX_ OP * o)800 S_op_destroy(pTHX_ OP *o)
801 {
802 FreeOp(o);
803 }
804
805 /* Destructor */
806
807 /*
808 =for apidoc Am|void|op_free|OP *o
809
810 Free an op. Only use this when an op is no longer linked to from any
811 optree.
812
813 =cut
814 */
815
816 void
Perl_op_free(pTHX_ OP * o)817 Perl_op_free(pTHX_ OP *o)
818 {
819 dVAR;
820 OPCODE type;
821 dDEFER_OP;
822
823 do {
824
825 /* Though ops may be freed twice, freeing the op after its slab is a
826 big no-no. */
827 assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
828 /* During the forced freeing of ops after compilation failure, kidops
829 may be freed before their parents. */
830 if (!o || o->op_type == OP_FREED)
831 continue;
832
833 type = o->op_type;
834
835 /* an op should only ever acquire op_private flags that we know about.
836 * If this fails, you may need to fix something in regen/op_private.
837 * Don't bother testing if:
838 * * the op_ppaddr doesn't match the op; someone may have
839 * overridden the op and be doing strange things with it;
840 * * we've errored, as op flags are often left in an
841 * inconsistent state then. Note that an error when
842 * compiling the main program leaves PL_parser NULL, so
843 * we can't spot faults in the main code, only
844 * evaled/required code */
845 #ifdef DEBUGGING
846 if ( o->op_ppaddr == PL_ppaddr[o->op_type]
847 && PL_parser
848 && !PL_parser->error_count)
849 {
850 assert(!(o->op_private & ~PL_op_private_valid[type]));
851 }
852 #endif
853
854 if (o->op_private & OPpREFCOUNTED) {
855 switch (type) {
856 case OP_LEAVESUB:
857 case OP_LEAVESUBLV:
858 case OP_LEAVEEVAL:
859 case OP_LEAVE:
860 case OP_SCOPE:
861 case OP_LEAVEWRITE:
862 {
863 PADOFFSET refcnt;
864 OP_REFCNT_LOCK;
865 refcnt = OpREFCNT_dec(o);
866 OP_REFCNT_UNLOCK;
867 if (refcnt) {
868 /* Need to find and remove any pattern match ops from the list
869 we maintain for reset(). */
870 find_and_forget_pmops(o);
871 continue;
872 }
873 }
874 break;
875 default:
876 break;
877 }
878 }
879
880 /* Call the op_free hook if it has been set. Do it now so that it's called
881 * at the right time for refcounted ops, but still before all of the kids
882 * are freed. */
883 CALL_OPFREEHOOK(o);
884
885 if (o->op_flags & OPf_KIDS) {
886 OP *kid, *nextkid;
887 assert(cUNOPo->op_first); /* OPf_KIDS implies op_first non-null */
888 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
889 nextkid = OpSIBLING(kid); /* Get before next freeing kid */
890 if (kid->op_type == OP_FREED)
891 /* During the forced freeing of ops after
892 compilation failure, kidops may be freed before
893 their parents. */
894 continue;
895 if (!(kid->op_flags & OPf_KIDS))
896 /* If it has no kids, just free it now */
897 op_free(kid);
898 else
899 DEFER_OP(kid);
900 }
901 }
902 if (type == OP_NULL)
903 type = (OPCODE)o->op_targ;
904
905 if (o->op_slabbed)
906 Slab_to_rw(OpSLAB(o));
907
908 /* COP* is not cleared by op_clear() so that we may track line
909 * numbers etc even after null() */
910 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
911 cop_free((COP*)o);
912 }
913
914 op_clear(o);
915 FreeOp(o);
916 if (PL_op == o)
917 PL_op = NULL;
918 } while ( (o = POP_DEFERRED_OP()) );
919
920 DEFER_OP_CLEANUP;
921 }
922
923 /* S_op_clear_gv(): free a GV attached to an OP */
924
925 STATIC
926 #ifdef USE_ITHREADS
S_op_clear_gv(pTHX_ OP * o,PADOFFSET * ixp)927 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
928 #else
929 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
930 #endif
931 {
932
933 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
934 || o->op_type == OP_MULTIDEREF)
935 #ifdef USE_ITHREADS
936 && PL_curpad
937 ? ((GV*)PAD_SVl(*ixp)) : NULL;
938 #else
939 ? (GV*)(*svp) : NULL;
940 #endif
941 /* It's possible during global destruction that the GV is freed
942 before the optree. Whilst the SvREFCNT_inc is happy to bump from
943 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
944 will trigger an assertion failure, because the entry to sv_clear
945 checks that the scalar is not already freed. A check of for
946 !SvIS_FREED(gv) turns out to be invalid, because during global
947 destruction the reference count can be forced down to zero
948 (with SVf_BREAK set). In which case raising to 1 and then
949 dropping to 0 triggers cleanup before it should happen. I
950 *think* that this might actually be a general, systematic,
951 weakness of the whole idea of SVf_BREAK, in that code *is*
952 allowed to raise and lower references during global destruction,
953 so any *valid* code that happens to do this during global
954 destruction might well trigger premature cleanup. */
955 bool still_valid = gv && SvREFCNT(gv);
956
957 if (still_valid)
958 SvREFCNT_inc_simple_void(gv);
959 #ifdef USE_ITHREADS
960 if (*ixp > 0) {
961 pad_swipe(*ixp, TRUE);
962 *ixp = 0;
963 }
964 #else
965 SvREFCNT_dec(*svp);
966 *svp = NULL;
967 #endif
968 if (still_valid) {
969 int try_downgrade = SvREFCNT(gv) == 2;
970 SvREFCNT_dec_NN(gv);
971 if (try_downgrade)
972 gv_try_downgrade(gv);
973 }
974 }
975
976
977 void
Perl_op_clear(pTHX_ OP * o)978 Perl_op_clear(pTHX_ OP *o)
979 {
980
981 dVAR;
982
983 PERL_ARGS_ASSERT_OP_CLEAR;
984
985 switch (o->op_type) {
986 case OP_NULL: /* Was holding old type, if any. */
987 /* FALLTHROUGH */
988 case OP_ENTERTRY:
989 case OP_ENTEREVAL: /* Was holding hints. */
990 case OP_ARGDEFELEM: /* Was holding signature index. */
991 o->op_targ = 0;
992 break;
993 default:
994 if (!(o->op_flags & OPf_REF)
995 || (PL_check[o->op_type] != Perl_ck_ftst))
996 break;
997 /* FALLTHROUGH */
998 case OP_GVSV:
999 case OP_GV:
1000 case OP_AELEMFAST:
1001 #ifdef USE_ITHREADS
1002 S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
1003 #else
1004 S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
1005 #endif
1006 break;
1007 case OP_METHOD_REDIR:
1008 case OP_METHOD_REDIR_SUPER:
1009 #ifdef USE_ITHREADS
1010 if (cMETHOPx(o)->op_rclass_targ) {
1011 pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
1012 cMETHOPx(o)->op_rclass_targ = 0;
1013 }
1014 #else
1015 SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
1016 cMETHOPx(o)->op_rclass_sv = NULL;
1017 #endif
1018 /* FALLTHROUGH */
1019 case OP_METHOD_NAMED:
1020 case OP_METHOD_SUPER:
1021 SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
1022 cMETHOPx(o)->op_u.op_meth_sv = NULL;
1023 #ifdef USE_ITHREADS
1024 if (o->op_targ) {
1025 pad_swipe(o->op_targ, 1);
1026 o->op_targ = 0;
1027 }
1028 #endif
1029 break;
1030 case OP_CONST:
1031 case OP_HINTSEVAL:
1032 SvREFCNT_dec(cSVOPo->op_sv);
1033 cSVOPo->op_sv = NULL;
1034 #ifdef USE_ITHREADS
1035 /** Bug #15654
1036 Even if op_clear does a pad_free for the target of the op,
1037 pad_free doesn't actually remove the sv that exists in the pad;
1038 instead it lives on. This results in that it could be reused as
1039 a target later on when the pad was reallocated.
1040 **/
1041 if(o->op_targ) {
1042 pad_swipe(o->op_targ,1);
1043 o->op_targ = 0;
1044 }
1045 #endif
1046 break;
1047 case OP_DUMP:
1048 case OP_GOTO:
1049 case OP_NEXT:
1050 case OP_LAST:
1051 case OP_REDO:
1052 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1053 break;
1054 /* FALLTHROUGH */
1055 case OP_TRANS:
1056 case OP_TRANSR:
1057 if ( (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
1058 && (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)))
1059 {
1060 #ifdef USE_ITHREADS
1061 if (cPADOPo->op_padix > 0) {
1062 pad_swipe(cPADOPo->op_padix, TRUE);
1063 cPADOPo->op_padix = 0;
1064 }
1065 #else
1066 SvREFCNT_dec(cSVOPo->op_sv);
1067 cSVOPo->op_sv = NULL;
1068 #endif
1069 }
1070 else {
1071 PerlMemShared_free(cPVOPo->op_pv);
1072 cPVOPo->op_pv = NULL;
1073 }
1074 break;
1075 case OP_SUBST:
1076 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1077 goto clear_pmop;
1078
1079 case OP_SPLIT:
1080 if ( (o->op_private & OPpSPLIT_ASSIGN) /* @array = split */
1081 && !(o->op_flags & OPf_STACKED)) /* @{expr} = split */
1082 {
1083 if (o->op_private & OPpSPLIT_LEX)
1084 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1085 else
1086 #ifdef USE_ITHREADS
1087 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1088 #else
1089 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1090 #endif
1091 }
1092 /* FALLTHROUGH */
1093 case OP_MATCH:
1094 case OP_QR:
1095 clear_pmop:
1096 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1097 op_free(cPMOPo->op_code_list);
1098 cPMOPo->op_code_list = NULL;
1099 forget_pmop(cPMOPo);
1100 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1101 /* we use the same protection as the "SAFE" version of the PM_ macros
1102 * here since sv_clean_all might release some PMOPs
1103 * after PL_regex_padav has been cleared
1104 * and the clearing of PL_regex_padav needs to
1105 * happen before sv_clean_all
1106 */
1107 #ifdef USE_ITHREADS
1108 if(PL_regex_pad) { /* We could be in destruction */
1109 const IV offset = (cPMOPo)->op_pmoffset;
1110 ReREFCNT_dec(PM_GETRE(cPMOPo));
1111 PL_regex_pad[offset] = &PL_sv_undef;
1112 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1113 sizeof(offset));
1114 }
1115 #else
1116 ReREFCNT_dec(PM_GETRE(cPMOPo));
1117 PM_SETRE(cPMOPo, NULL);
1118 #endif
1119
1120 break;
1121
1122 case OP_ARGCHECK:
1123 PerlMemShared_free(cUNOP_AUXo->op_aux);
1124 break;
1125
1126 case OP_MULTICONCAT:
1127 {
1128 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
1129 /* aux[PERL_MULTICONCAT_IX_PLAIN_PV] and/or
1130 * aux[PERL_MULTICONCAT_IX_UTF8_PV] point to plain and/or
1131 * utf8 shared strings */
1132 char *p1 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
1133 char *p2 = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
1134 if (p1)
1135 PerlMemShared_free(p1);
1136 if (p2 && p1 != p2)
1137 PerlMemShared_free(p2);
1138 PerlMemShared_free(aux);
1139 }
1140 break;
1141
1142 case OP_MULTIDEREF:
1143 {
1144 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1145 UV actions = items->uv;
1146 bool last = 0;
1147 bool is_hash = FALSE;
1148
1149 while (!last) {
1150 switch (actions & MDEREF_ACTION_MASK) {
1151
1152 case MDEREF_reload:
1153 actions = (++items)->uv;
1154 continue;
1155
1156 case MDEREF_HV_padhv_helem:
1157 is_hash = TRUE;
1158 /* FALLTHROUGH */
1159 case MDEREF_AV_padav_aelem:
1160 pad_free((++items)->pad_offset);
1161 goto do_elem;
1162
1163 case MDEREF_HV_gvhv_helem:
1164 is_hash = TRUE;
1165 /* FALLTHROUGH */
1166 case MDEREF_AV_gvav_aelem:
1167 #ifdef USE_ITHREADS
1168 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1169 #else
1170 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1171 #endif
1172 goto do_elem;
1173
1174 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1175 is_hash = TRUE;
1176 /* FALLTHROUGH */
1177 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1178 #ifdef USE_ITHREADS
1179 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1180 #else
1181 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1182 #endif
1183 goto do_vivify_rv2xv_elem;
1184
1185 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1186 is_hash = TRUE;
1187 /* FALLTHROUGH */
1188 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1189 pad_free((++items)->pad_offset);
1190 goto do_vivify_rv2xv_elem;
1191
1192 case MDEREF_HV_pop_rv2hv_helem:
1193 case MDEREF_HV_vivify_rv2hv_helem:
1194 is_hash = TRUE;
1195 /* FALLTHROUGH */
1196 do_vivify_rv2xv_elem:
1197 case MDEREF_AV_pop_rv2av_aelem:
1198 case MDEREF_AV_vivify_rv2av_aelem:
1199 do_elem:
1200 switch (actions & MDEREF_INDEX_MASK) {
1201 case MDEREF_INDEX_none:
1202 last = 1;
1203 break;
1204 case MDEREF_INDEX_const:
1205 if (is_hash) {
1206 #ifdef USE_ITHREADS
1207 /* see RT #15654 */
1208 pad_swipe((++items)->pad_offset, 1);
1209 #else
1210 SvREFCNT_dec((++items)->sv);
1211 #endif
1212 }
1213 else
1214 items++;
1215 break;
1216 case MDEREF_INDEX_padsv:
1217 pad_free((++items)->pad_offset);
1218 break;
1219 case MDEREF_INDEX_gvsv:
1220 #ifdef USE_ITHREADS
1221 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1222 #else
1223 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1224 #endif
1225 break;
1226 }
1227
1228 if (actions & MDEREF_FLAG_last)
1229 last = 1;
1230 is_hash = FALSE;
1231
1232 break;
1233
1234 default:
1235 assert(0);
1236 last = 1;
1237 break;
1238
1239 } /* switch */
1240
1241 actions >>= MDEREF_SHIFT;
1242 } /* while */
1243
1244 /* start of malloc is at op_aux[-1], where the length is
1245 * stored */
1246 PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1247 }
1248 break;
1249 }
1250
1251 if (o->op_targ > 0) {
1252 pad_free(o->op_targ);
1253 o->op_targ = 0;
1254 }
1255 }
1256
1257 STATIC void
S_cop_free(pTHX_ COP * cop)1258 S_cop_free(pTHX_ COP* cop)
1259 {
1260 PERL_ARGS_ASSERT_COP_FREE;
1261
1262 CopFILE_free(cop);
1263 if (! specialWARN(cop->cop_warnings))
1264 PerlMemShared_free(cop->cop_warnings);
1265 cophh_free(CopHINTHASH_get(cop));
1266 if (PL_curcop == cop)
1267 PL_curcop = NULL;
1268 }
1269
1270 STATIC void
S_forget_pmop(pTHX_ PMOP * const o)1271 S_forget_pmop(pTHX_ PMOP *const o)
1272 {
1273 HV * const pmstash = PmopSTASH(o);
1274
1275 PERL_ARGS_ASSERT_FORGET_PMOP;
1276
1277 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1278 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1279 if (mg) {
1280 PMOP **const array = (PMOP**) mg->mg_ptr;
1281 U32 count = mg->mg_len / sizeof(PMOP**);
1282 U32 i = count;
1283
1284 while (i--) {
1285 if (array[i] == o) {
1286 /* Found it. Move the entry at the end to overwrite it. */
1287 array[i] = array[--count];
1288 mg->mg_len = count * sizeof(PMOP**);
1289 /* Could realloc smaller at this point always, but probably
1290 not worth it. Probably worth free()ing if we're the
1291 last. */
1292 if(!count) {
1293 Safefree(mg->mg_ptr);
1294 mg->mg_ptr = NULL;
1295 }
1296 break;
1297 }
1298 }
1299 }
1300 }
1301 if (PL_curpm == o)
1302 PL_curpm = NULL;
1303 }
1304
1305 STATIC void
S_find_and_forget_pmops(pTHX_ OP * o)1306 S_find_and_forget_pmops(pTHX_ OP *o)
1307 {
1308 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1309
1310 if (o->op_flags & OPf_KIDS) {
1311 OP *kid = cUNOPo->op_first;
1312 while (kid) {
1313 switch (kid->op_type) {
1314 case OP_SUBST:
1315 case OP_SPLIT:
1316 case OP_MATCH:
1317 case OP_QR:
1318 forget_pmop((PMOP*)kid);
1319 }
1320 find_and_forget_pmops(kid);
1321 kid = OpSIBLING(kid);
1322 }
1323 }
1324 }
1325
1326 /*
1327 =for apidoc Am|void|op_null|OP *o
1328
1329 Neutralizes an op when it is no longer needed, but is still linked to from
1330 other ops.
1331
1332 =cut
1333 */
1334
1335 void
Perl_op_null(pTHX_ OP * o)1336 Perl_op_null(pTHX_ OP *o)
1337 {
1338 dVAR;
1339
1340 PERL_ARGS_ASSERT_OP_NULL;
1341
1342 if (o->op_type == OP_NULL)
1343 return;
1344 op_clear(o);
1345 o->op_targ = o->op_type;
1346 OpTYPE_set(o, OP_NULL);
1347 }
1348
1349 void
Perl_op_refcnt_lock(pTHX)1350 Perl_op_refcnt_lock(pTHX)
1351 PERL_TSA_ACQUIRE(PL_op_mutex)
1352 {
1353 #ifdef USE_ITHREADS
1354 dVAR;
1355 #endif
1356 PERL_UNUSED_CONTEXT;
1357 OP_REFCNT_LOCK;
1358 }
1359
1360 void
Perl_op_refcnt_unlock(pTHX)1361 Perl_op_refcnt_unlock(pTHX)
1362 PERL_TSA_RELEASE(PL_op_mutex)
1363 {
1364 #ifdef USE_ITHREADS
1365 dVAR;
1366 #endif
1367 PERL_UNUSED_CONTEXT;
1368 OP_REFCNT_UNLOCK;
1369 }
1370
1371
1372 /*
1373 =for apidoc op_sibling_splice
1374
1375 A general function for editing the structure of an existing chain of
1376 op_sibling nodes. By analogy with the perl-level C<splice()> function, allows
1377 you to delete zero or more sequential nodes, replacing them with zero or
1378 more different nodes. Performs the necessary op_first/op_last
1379 housekeeping on the parent node and op_sibling manipulation on the
1380 children. The last deleted node will be marked as as the last node by
1381 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1382
1383 Note that op_next is not manipulated, and nodes are not freed; that is the
1384 responsibility of the caller. It also won't create a new list op for an
1385 empty list etc; use higher-level functions like op_append_elem() for that.
1386
1387 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1388 the splicing doesn't affect the first or last op in the chain.
1389
1390 C<start> is the node preceding the first node to be spliced. Node(s)
1391 following it will be deleted, and ops will be inserted after it. If it is
1392 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1393 beginning.
1394
1395 C<del_count> is the number of nodes to delete. If zero, no nodes are deleted.
1396 If -1 or greater than or equal to the number of remaining kids, all
1397 remaining kids are deleted.
1398
1399 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1400 If C<NULL>, no nodes are inserted.
1401
1402 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1403 deleted.
1404
1405 For example:
1406
1407 action before after returns
1408 ------ ----- ----- -------
1409
1410 P P
1411 splice(P, A, 2, X-Y-Z) | | B-C
1412 A-B-C-D A-X-Y-Z-D
1413
1414 P P
1415 splice(P, NULL, 1, X-Y) | | A
1416 A-B-C-D X-Y-B-C-D
1417
1418 P P
1419 splice(P, NULL, 3, NULL) | | A-B-C
1420 A-B-C-D D
1421
1422 P P
1423 splice(P, B, 0, X-Y) | | NULL
1424 A-B-C-D A-B-X-Y-C-D
1425
1426
1427 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1428 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1429
1430 =cut
1431 */
1432
1433 OP *
Perl_op_sibling_splice(OP * parent,OP * start,int del_count,OP * insert)1434 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1435 {
1436 OP *first;
1437 OP *rest;
1438 OP *last_del = NULL;
1439 OP *last_ins = NULL;
1440
1441 if (start)
1442 first = OpSIBLING(start);
1443 else if (!parent)
1444 goto no_parent;
1445 else
1446 first = cLISTOPx(parent)->op_first;
1447
1448 assert(del_count >= -1);
1449
1450 if (del_count && first) {
1451 last_del = first;
1452 while (--del_count && OpHAS_SIBLING(last_del))
1453 last_del = OpSIBLING(last_del);
1454 rest = OpSIBLING(last_del);
1455 OpLASTSIB_set(last_del, NULL);
1456 }
1457 else
1458 rest = first;
1459
1460 if (insert) {
1461 last_ins = insert;
1462 while (OpHAS_SIBLING(last_ins))
1463 last_ins = OpSIBLING(last_ins);
1464 OpMAYBESIB_set(last_ins, rest, NULL);
1465 }
1466 else
1467 insert = rest;
1468
1469 if (start) {
1470 OpMAYBESIB_set(start, insert, NULL);
1471 }
1472 else {
1473 assert(parent);
1474 cLISTOPx(parent)->op_first = insert;
1475 if (insert)
1476 parent->op_flags |= OPf_KIDS;
1477 else
1478 parent->op_flags &= ~OPf_KIDS;
1479 }
1480
1481 if (!rest) {
1482 /* update op_last etc */
1483 U32 type;
1484 OP *lastop;
1485
1486 if (!parent)
1487 goto no_parent;
1488
1489 /* ought to use OP_CLASS(parent) here, but that can't handle
1490 * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1491 * either */
1492 type = parent->op_type;
1493 if (type == OP_CUSTOM) {
1494 dTHX;
1495 type = XopENTRYCUSTOM(parent, xop_class);
1496 }
1497 else {
1498 if (type == OP_NULL)
1499 type = parent->op_targ;
1500 type = PL_opargs[type] & OA_CLASS_MASK;
1501 }
1502
1503 lastop = last_ins ? last_ins : start ? start : NULL;
1504 if ( type == OA_BINOP
1505 || type == OA_LISTOP
1506 || type == OA_PMOP
1507 || type == OA_LOOP
1508 )
1509 cLISTOPx(parent)->op_last = lastop;
1510
1511 if (lastop)
1512 OpLASTSIB_set(lastop, parent);
1513 }
1514 return last_del ? first : NULL;
1515
1516 no_parent:
1517 Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1518 }
1519
1520 /*
1521 =for apidoc op_parent
1522
1523 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1524
1525 =cut
1526 */
1527
1528 OP *
Perl_op_parent(OP * o)1529 Perl_op_parent(OP *o)
1530 {
1531 PERL_ARGS_ASSERT_OP_PARENT;
1532 while (OpHAS_SIBLING(o))
1533 o = OpSIBLING(o);
1534 return o->op_sibparent;
1535 }
1536
1537 /* replace the sibling following start with a new UNOP, which becomes
1538 * the parent of the original sibling; e.g.
1539 *
1540 * op_sibling_newUNOP(P, A, unop-args...)
1541 *
1542 * P P
1543 * | becomes |
1544 * A-B-C A-U-C
1545 * |
1546 * B
1547 *
1548 * where U is the new UNOP.
1549 *
1550 * parent and start args are the same as for op_sibling_splice();
1551 * type and flags args are as newUNOP().
1552 *
1553 * Returns the new UNOP.
1554 */
1555
1556 STATIC OP *
S_op_sibling_newUNOP(pTHX_ OP * parent,OP * start,I32 type,I32 flags)1557 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1558 {
1559 OP *kid, *newop;
1560
1561 kid = op_sibling_splice(parent, start, 1, NULL);
1562 newop = newUNOP(type, flags, kid);
1563 op_sibling_splice(parent, start, 0, newop);
1564 return newop;
1565 }
1566
1567
1568 /* lowest-level newLOGOP-style function - just allocates and populates
1569 * the struct. Higher-level stuff should be done by S_new_logop() /
1570 * newLOGOP(). This function exists mainly to avoid op_first assignment
1571 * being spread throughout this file.
1572 */
1573
1574 LOGOP *
Perl_alloc_LOGOP(pTHX_ I32 type,OP * first,OP * other)1575 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1576 {
1577 dVAR;
1578 LOGOP *logop;
1579 OP *kid = first;
1580 NewOp(1101, logop, 1, LOGOP);
1581 OpTYPE_set(logop, type);
1582 logop->op_first = first;
1583 logop->op_other = other;
1584 if (first)
1585 logop->op_flags = OPf_KIDS;
1586 while (kid && OpHAS_SIBLING(kid))
1587 kid = OpSIBLING(kid);
1588 if (kid)
1589 OpLASTSIB_set(kid, (OP*)logop);
1590 return logop;
1591 }
1592
1593
1594 /* Contextualizers */
1595
1596 /*
1597 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1598
1599 Applies a syntactic context to an op tree representing an expression.
1600 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1601 or C<G_VOID> to specify the context to apply. The modified op tree
1602 is returned.
1603
1604 =cut
1605 */
1606
1607 OP *
Perl_op_contextualize(pTHX_ OP * o,I32 context)1608 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1609 {
1610 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1611 switch (context) {
1612 case G_SCALAR: return scalar(o);
1613 case G_ARRAY: return list(o);
1614 case G_VOID: return scalarvoid(o);
1615 default:
1616 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1617 (long) context);
1618 }
1619 }
1620
1621 /*
1622
1623 =for apidoc Am|OP*|op_linklist|OP *o
1624 This function is the implementation of the L</LINKLIST> macro. It should
1625 not be called directly.
1626
1627 =cut
1628 */
1629
1630 OP *
Perl_op_linklist(pTHX_ OP * o)1631 Perl_op_linklist(pTHX_ OP *o)
1632 {
1633 OP *first;
1634
1635 PERL_ARGS_ASSERT_OP_LINKLIST;
1636
1637 if (o->op_next)
1638 return o->op_next;
1639
1640 /* establish postfix order */
1641 first = cUNOPo->op_first;
1642 if (first) {
1643 OP *kid;
1644 o->op_next = LINKLIST(first);
1645 kid = first;
1646 for (;;) {
1647 OP *sibl = OpSIBLING(kid);
1648 if (sibl) {
1649 kid->op_next = LINKLIST(sibl);
1650 kid = sibl;
1651 } else {
1652 kid->op_next = o;
1653 break;
1654 }
1655 }
1656 }
1657 else
1658 o->op_next = o;
1659
1660 return o->op_next;
1661 }
1662
1663 static OP *
S_scalarkids(pTHX_ OP * o)1664 S_scalarkids(pTHX_ OP *o)
1665 {
1666 if (o && o->op_flags & OPf_KIDS) {
1667 OP *kid;
1668 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1669 scalar(kid);
1670 }
1671 return o;
1672 }
1673
1674 STATIC OP *
S_scalarboolean(pTHX_ OP * o)1675 S_scalarboolean(pTHX_ OP *o)
1676 {
1677 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1678
1679 if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1680 !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1681 (o->op_type == OP_NOT && cUNOPo->op_first->op_type == OP_SASSIGN &&
1682 cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1683 !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1684 if (ckWARN(WARN_SYNTAX)) {
1685 const line_t oldline = CopLINE(PL_curcop);
1686
1687 if (PL_parser && PL_parser->copline != NOLINE) {
1688 /* This ensures that warnings are reported at the first line
1689 of the conditional, not the last. */
1690 CopLINE_set(PL_curcop, PL_parser->copline);
1691 }
1692 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1693 CopLINE_set(PL_curcop, oldline);
1694 }
1695 }
1696 return scalar(o);
1697 }
1698
1699 static SV *
S_op_varname_subscript(pTHX_ const OP * o,int subscript_type)1700 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1701 {
1702 assert(o);
1703 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1704 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1705 {
1706 const char funny = o->op_type == OP_PADAV
1707 || o->op_type == OP_RV2AV ? '@' : '%';
1708 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1709 GV *gv;
1710 if (cUNOPo->op_first->op_type != OP_GV
1711 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1712 return NULL;
1713 return varname(gv, funny, 0, NULL, 0, subscript_type);
1714 }
1715 return
1716 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1717 }
1718 }
1719
1720 static SV *
S_op_varname(pTHX_ const OP * o)1721 S_op_varname(pTHX_ const OP *o)
1722 {
1723 return S_op_varname_subscript(aTHX_ o, 1);
1724 }
1725
1726 static void
S_op_pretty(pTHX_ const OP * o,SV ** retsv,const char ** retpv)1727 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1728 { /* or not so pretty :-) */
1729 if (o->op_type == OP_CONST) {
1730 *retsv = cSVOPo_sv;
1731 if (SvPOK(*retsv)) {
1732 SV *sv = *retsv;
1733 *retsv = sv_newmortal();
1734 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1735 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1736 }
1737 else if (!SvOK(*retsv))
1738 *retpv = "undef";
1739 }
1740 else *retpv = "...";
1741 }
1742
1743 static void
S_scalar_slice_warning(pTHX_ const OP * o)1744 S_scalar_slice_warning(pTHX_ const OP *o)
1745 {
1746 OP *kid;
1747 const bool h = o->op_type == OP_HSLICE
1748 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
1749 const char lbrack =
1750 h ? '{' : '[';
1751 const char rbrack =
1752 h ? '}' : ']';
1753 SV *name;
1754 SV *keysv = NULL; /* just to silence compiler warnings */
1755 const char *key = NULL;
1756
1757 if (!(o->op_private & OPpSLICEWARNING))
1758 return;
1759 if (PL_parser && PL_parser->error_count)
1760 /* This warning can be nonsensical when there is a syntax error. */
1761 return;
1762
1763 kid = cLISTOPo->op_first;
1764 kid = OpSIBLING(kid); /* get past pushmark */
1765 /* weed out false positives: any ops that can return lists */
1766 switch (kid->op_type) {
1767 case OP_BACKTICK:
1768 case OP_GLOB:
1769 case OP_READLINE:
1770 case OP_MATCH:
1771 case OP_RV2AV:
1772 case OP_EACH:
1773 case OP_VALUES:
1774 case OP_KEYS:
1775 case OP_SPLIT:
1776 case OP_LIST:
1777 case OP_SORT:
1778 case OP_REVERSE:
1779 case OP_ENTERSUB:
1780 case OP_CALLER:
1781 case OP_LSTAT:
1782 case OP_STAT:
1783 case OP_READDIR:
1784 case OP_SYSTEM:
1785 case OP_TMS:
1786 case OP_LOCALTIME:
1787 case OP_GMTIME:
1788 case OP_ENTEREVAL:
1789 return;
1790 }
1791
1792 /* Don't warn if we have a nulled list either. */
1793 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1794 return;
1795
1796 assert(OpSIBLING(kid));
1797 name = S_op_varname(aTHX_ OpSIBLING(kid));
1798 if (!name) /* XS module fiddling with the op tree */
1799 return;
1800 S_op_pretty(aTHX_ kid, &keysv, &key);
1801 assert(SvPOK(name));
1802 sv_chop(name,SvPVX(name)+1);
1803 if (key)
1804 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1805 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1806 "Scalar value @%" SVf "%c%s%c better written as $%" SVf
1807 "%c%s%c",
1808 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1809 lbrack, key, rbrack);
1810 else
1811 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1812 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1813 "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1814 SVf "%c%" SVf "%c",
1815 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1816 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1817 }
1818
1819 OP *
Perl_scalar(pTHX_ OP * o)1820 Perl_scalar(pTHX_ OP *o)
1821 {
1822 OP *kid;
1823
1824 /* assumes no premature commitment */
1825 if (!o || (PL_parser && PL_parser->error_count)
1826 || (o->op_flags & OPf_WANT)
1827 || o->op_type == OP_RETURN)
1828 {
1829 return o;
1830 }
1831
1832 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1833
1834 switch (o->op_type) {
1835 case OP_REPEAT:
1836 scalar(cBINOPo->op_first);
1837 if (o->op_private & OPpREPEAT_DOLIST) {
1838 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1839 assert(kid->op_type == OP_PUSHMARK);
1840 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1841 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1842 o->op_private &=~ OPpREPEAT_DOLIST;
1843 }
1844 }
1845 break;
1846 case OP_OR:
1847 case OP_AND:
1848 case OP_COND_EXPR:
1849 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1850 scalar(kid);
1851 break;
1852 /* FALLTHROUGH */
1853 case OP_SPLIT:
1854 case OP_MATCH:
1855 case OP_QR:
1856 case OP_SUBST:
1857 case OP_NULL:
1858 default:
1859 if (o->op_flags & OPf_KIDS) {
1860 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1861 scalar(kid);
1862 }
1863 break;
1864 case OP_LEAVE:
1865 case OP_LEAVETRY:
1866 kid = cLISTOPo->op_first;
1867 scalar(kid);
1868 kid = OpSIBLING(kid);
1869 do_kids:
1870 while (kid) {
1871 OP *sib = OpSIBLING(kid);
1872 if (sib && kid->op_type != OP_LEAVEWHEN
1873 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1874 || ( sib->op_targ != OP_NEXTSTATE
1875 && sib->op_targ != OP_DBSTATE )))
1876 scalarvoid(kid);
1877 else
1878 scalar(kid);
1879 kid = sib;
1880 }
1881 PL_curcop = &PL_compiling;
1882 break;
1883 case OP_SCOPE:
1884 case OP_LINESEQ:
1885 case OP_LIST:
1886 kid = cLISTOPo->op_first;
1887 goto do_kids;
1888 case OP_SORT:
1889 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1890 break;
1891 case OP_KVHSLICE:
1892 case OP_KVASLICE:
1893 {
1894 /* Warn about scalar context */
1895 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1896 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1897 SV *name;
1898 SV *keysv;
1899 const char *key = NULL;
1900
1901 /* This warning can be nonsensical when there is a syntax error. */
1902 if (PL_parser && PL_parser->error_count)
1903 break;
1904
1905 if (!ckWARN(WARN_SYNTAX)) break;
1906
1907 kid = cLISTOPo->op_first;
1908 kid = OpSIBLING(kid); /* get past pushmark */
1909 assert(OpSIBLING(kid));
1910 name = S_op_varname(aTHX_ OpSIBLING(kid));
1911 if (!name) /* XS module fiddling with the op tree */
1912 break;
1913 S_op_pretty(aTHX_ kid, &keysv, &key);
1914 assert(SvPOK(name));
1915 sv_chop(name,SvPVX(name)+1);
1916 if (key)
1917 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1918 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1919 "%%%" SVf "%c%s%c in scalar context better written "
1920 "as $%" SVf "%c%s%c",
1921 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1922 lbrack, key, rbrack);
1923 else
1924 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1925 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1926 "%%%" SVf "%c%" SVf "%c in scalar context better "
1927 "written as $%" SVf "%c%" SVf "%c",
1928 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1929 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1930 }
1931 }
1932 return o;
1933 }
1934
1935 OP *
Perl_scalarvoid(pTHX_ OP * arg)1936 Perl_scalarvoid(pTHX_ OP *arg)
1937 {
1938 dVAR;
1939 OP *kid;
1940 SV* sv;
1941 OP *o = arg;
1942 dDEFER_OP;
1943
1944 PERL_ARGS_ASSERT_SCALARVOID;
1945
1946 do {
1947 U8 want;
1948 SV *useless_sv = NULL;
1949 const char* useless = NULL;
1950
1951 if (o->op_type == OP_NEXTSTATE
1952 || o->op_type == OP_DBSTATE
1953 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1954 || o->op_targ == OP_DBSTATE)))
1955 PL_curcop = (COP*)o; /* for warning below */
1956
1957 /* assumes no premature commitment */
1958 want = o->op_flags & OPf_WANT;
1959 if ((want && want != OPf_WANT_SCALAR)
1960 || (PL_parser && PL_parser->error_count)
1961 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1962 {
1963 continue;
1964 }
1965
1966 if ((o->op_private & OPpTARGET_MY)
1967 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1968 {
1969 /* newASSIGNOP has already applied scalar context, which we
1970 leave, as if this op is inside SASSIGN. */
1971 continue;
1972 }
1973
1974 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1975
1976 switch (o->op_type) {
1977 default:
1978 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1979 break;
1980 /* FALLTHROUGH */
1981 case OP_REPEAT:
1982 if (o->op_flags & OPf_STACKED)
1983 break;
1984 if (o->op_type == OP_REPEAT)
1985 scalar(cBINOPo->op_first);
1986 goto func_ops;
1987 case OP_CONCAT:
1988 if ((o->op_flags & OPf_STACKED) &&
1989 !(o->op_private & OPpCONCAT_NESTED))
1990 break;
1991 goto func_ops;
1992 case OP_SUBSTR:
1993 if (o->op_private == 4)
1994 break;
1995 /* FALLTHROUGH */
1996 case OP_WANTARRAY:
1997 case OP_GV:
1998 case OP_SMARTMATCH:
1999 case OP_AV2ARYLEN:
2000 case OP_REF:
2001 case OP_REFGEN:
2002 case OP_SREFGEN:
2003 case OP_DEFINED:
2004 case OP_HEX:
2005 case OP_OCT:
2006 case OP_LENGTH:
2007 case OP_VEC:
2008 case OP_INDEX:
2009 case OP_RINDEX:
2010 case OP_SPRINTF:
2011 case OP_KVASLICE:
2012 case OP_KVHSLICE:
2013 case OP_UNPACK:
2014 case OP_PACK:
2015 case OP_JOIN:
2016 case OP_LSLICE:
2017 case OP_ANONLIST:
2018 case OP_ANONHASH:
2019 case OP_SORT:
2020 case OP_REVERSE:
2021 case OP_RANGE:
2022 case OP_FLIP:
2023 case OP_FLOP:
2024 case OP_CALLER:
2025 case OP_FILENO:
2026 case OP_EOF:
2027 case OP_TELL:
2028 case OP_GETSOCKNAME:
2029 case OP_GETPEERNAME:
2030 case OP_READLINK:
2031 case OP_TELLDIR:
2032 case OP_GETPPID:
2033 case OP_GETPGRP:
2034 case OP_GETPRIORITY:
2035 case OP_TIME:
2036 case OP_TMS:
2037 case OP_LOCALTIME:
2038 case OP_GMTIME:
2039 case OP_GHBYNAME:
2040 case OP_GHBYADDR:
2041 case OP_GHOSTENT:
2042 case OP_GNBYNAME:
2043 case OP_GNBYADDR:
2044 case OP_GNETENT:
2045 case OP_GPBYNAME:
2046 case OP_GPBYNUMBER:
2047 case OP_GPROTOENT:
2048 case OP_GSBYNAME:
2049 case OP_GSBYPORT:
2050 case OP_GSERVENT:
2051 case OP_GPWNAM:
2052 case OP_GPWUID:
2053 case OP_GGRNAM:
2054 case OP_GGRGID:
2055 case OP_GETLOGIN:
2056 case OP_PROTOTYPE:
2057 case OP_RUNCV:
2058 func_ops:
2059 useless = OP_DESC(o);
2060 break;
2061
2062 case OP_GVSV:
2063 case OP_PADSV:
2064 case OP_PADAV:
2065 case OP_PADHV:
2066 case OP_PADANY:
2067 case OP_AELEM:
2068 case OP_AELEMFAST:
2069 case OP_AELEMFAST_LEX:
2070 case OP_ASLICE:
2071 case OP_HELEM:
2072 case OP_HSLICE:
2073 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
2074 /* Otherwise it's "Useless use of grep iterator" */
2075 useless = OP_DESC(o);
2076 break;
2077
2078 case OP_SPLIT:
2079 if (!(o->op_private & OPpSPLIT_ASSIGN))
2080 useless = OP_DESC(o);
2081 break;
2082
2083 case OP_NOT:
2084 kid = cUNOPo->op_first;
2085 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2086 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2087 goto func_ops;
2088 }
2089 useless = "negative pattern binding (!~)";
2090 break;
2091
2092 case OP_SUBST:
2093 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2094 useless = "non-destructive substitution (s///r)";
2095 break;
2096
2097 case OP_TRANSR:
2098 useless = "non-destructive transliteration (tr///r)";
2099 break;
2100
2101 case OP_RV2GV:
2102 case OP_RV2SV:
2103 case OP_RV2AV:
2104 case OP_RV2HV:
2105 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2106 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2107 useless = "a variable";
2108 break;
2109
2110 case OP_CONST:
2111 sv = cSVOPo_sv;
2112 if (cSVOPo->op_private & OPpCONST_STRICT)
2113 no_bareword_allowed(o);
2114 else {
2115 if (ckWARN(WARN_VOID)) {
2116 NV nv;
2117 /* don't warn on optimised away booleans, eg
2118 * use constant Foo, 5; Foo || print; */
2119 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2120 useless = NULL;
2121 /* the constants 0 and 1 are permitted as they are
2122 conventionally used as dummies in constructs like
2123 1 while some_condition_with_side_effects; */
2124 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2125 useless = NULL;
2126 else if (SvPOK(sv)) {
2127 SV * const dsv = newSVpvs("");
2128 useless_sv
2129 = Perl_newSVpvf(aTHX_
2130 "a constant (%s)",
2131 pv_pretty(dsv, SvPVX_const(sv),
2132 SvCUR(sv), 32, NULL, NULL,
2133 PERL_PV_PRETTY_DUMP
2134 | PERL_PV_ESCAPE_NOCLEAR
2135 | PERL_PV_ESCAPE_UNI_DETECT));
2136 SvREFCNT_dec_NN(dsv);
2137 }
2138 else if (SvOK(sv)) {
2139 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2140 }
2141 else
2142 useless = "a constant (undef)";
2143 }
2144 }
2145 op_null(o); /* don't execute or even remember it */
2146 break;
2147
2148 case OP_POSTINC:
2149 OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */
2150 break;
2151
2152 case OP_POSTDEC:
2153 OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */
2154 break;
2155
2156 case OP_I_POSTINC:
2157 OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */
2158 break;
2159
2160 case OP_I_POSTDEC:
2161 OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */
2162 break;
2163
2164 case OP_SASSIGN: {
2165 OP *rv2gv;
2166 UNOP *refgen, *rv2cv;
2167 LISTOP *exlist;
2168
2169 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2170 break;
2171
2172 rv2gv = ((BINOP *)o)->op_last;
2173 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2174 break;
2175
2176 refgen = (UNOP *)((BINOP *)o)->op_first;
2177
2178 if (!refgen || (refgen->op_type != OP_REFGEN
2179 && refgen->op_type != OP_SREFGEN))
2180 break;
2181
2182 exlist = (LISTOP *)refgen->op_first;
2183 if (!exlist || exlist->op_type != OP_NULL
2184 || exlist->op_targ != OP_LIST)
2185 break;
2186
2187 if (exlist->op_first->op_type != OP_PUSHMARK
2188 && exlist->op_first != exlist->op_last)
2189 break;
2190
2191 rv2cv = (UNOP*)exlist->op_last;
2192
2193 if (rv2cv->op_type != OP_RV2CV)
2194 break;
2195
2196 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2197 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2198 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2199
2200 o->op_private |= OPpASSIGN_CV_TO_GV;
2201 rv2gv->op_private |= OPpDONT_INIT_GV;
2202 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2203
2204 break;
2205 }
2206
2207 case OP_AASSIGN: {
2208 inplace_aassign(o);
2209 break;
2210 }
2211
2212 case OP_OR:
2213 case OP_AND:
2214 kid = cLOGOPo->op_first;
2215 if (kid->op_type == OP_NOT
2216 && (kid->op_flags & OPf_KIDS)) {
2217 if (o->op_type == OP_AND) {
2218 OpTYPE_set(o, OP_OR);
2219 } else {
2220 OpTYPE_set(o, OP_AND);
2221 }
2222 op_null(kid);
2223 }
2224 /* FALLTHROUGH */
2225
2226 case OP_DOR:
2227 case OP_COND_EXPR:
2228 case OP_ENTERGIVEN:
2229 case OP_ENTERWHEN:
2230 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2231 if (!(kid->op_flags & OPf_KIDS))
2232 scalarvoid(kid);
2233 else
2234 DEFER_OP(kid);
2235 break;
2236
2237 case OP_NULL:
2238 if (o->op_flags & OPf_STACKED)
2239 break;
2240 /* FALLTHROUGH */
2241 case OP_NEXTSTATE:
2242 case OP_DBSTATE:
2243 case OP_ENTERTRY:
2244 case OP_ENTER:
2245 if (!(o->op_flags & OPf_KIDS))
2246 break;
2247 /* FALLTHROUGH */
2248 case OP_SCOPE:
2249 case OP_LEAVE:
2250 case OP_LEAVETRY:
2251 case OP_LEAVELOOP:
2252 case OP_LINESEQ:
2253 case OP_LEAVEGIVEN:
2254 case OP_LEAVEWHEN:
2255 kids:
2256 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2257 if (!(kid->op_flags & OPf_KIDS))
2258 scalarvoid(kid);
2259 else
2260 DEFER_OP(kid);
2261 break;
2262 case OP_LIST:
2263 /* If the first kid after pushmark is something that the padrange
2264 optimisation would reject, then null the list and the pushmark.
2265 */
2266 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2267 && ( !(kid = OpSIBLING(kid))
2268 || ( kid->op_type != OP_PADSV
2269 && kid->op_type != OP_PADAV
2270 && kid->op_type != OP_PADHV)
2271 || kid->op_private & ~OPpLVAL_INTRO
2272 || !(kid = OpSIBLING(kid))
2273 || ( kid->op_type != OP_PADSV
2274 && kid->op_type != OP_PADAV
2275 && kid->op_type != OP_PADHV)
2276 || kid->op_private & ~OPpLVAL_INTRO)
2277 ) {
2278 op_null(cUNOPo->op_first); /* NULL the pushmark */
2279 op_null(o); /* NULL the list */
2280 }
2281 goto kids;
2282 case OP_ENTEREVAL:
2283 scalarkids(o);
2284 break;
2285 case OP_SCALAR:
2286 scalar(o);
2287 break;
2288 }
2289
2290 if (useless_sv) {
2291 /* mortalise it, in case warnings are fatal. */
2292 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2293 "Useless use of %" SVf " in void context",
2294 SVfARG(sv_2mortal(useless_sv)));
2295 }
2296 else if (useless) {
2297 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2298 "Useless use of %s in void context",
2299 useless);
2300 }
2301 } while ( (o = POP_DEFERRED_OP()) );
2302
2303 DEFER_OP_CLEANUP;
2304
2305 return arg;
2306 }
2307
2308 static OP *
S_listkids(pTHX_ OP * o)2309 S_listkids(pTHX_ OP *o)
2310 {
2311 if (o && o->op_flags & OPf_KIDS) {
2312 OP *kid;
2313 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2314 list(kid);
2315 }
2316 return o;
2317 }
2318
2319 OP *
Perl_list(pTHX_ OP * o)2320 Perl_list(pTHX_ OP *o)
2321 {
2322 OP *kid;
2323
2324 /* assumes no premature commitment */
2325 if (!o || (o->op_flags & OPf_WANT)
2326 || (PL_parser && PL_parser->error_count)
2327 || o->op_type == OP_RETURN)
2328 {
2329 return o;
2330 }
2331
2332 if ((o->op_private & OPpTARGET_MY)
2333 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2334 {
2335 return o; /* As if inside SASSIGN */
2336 }
2337
2338 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2339
2340 switch (o->op_type) {
2341 case OP_FLOP:
2342 list(cBINOPo->op_first);
2343 break;
2344 case OP_REPEAT:
2345 if (o->op_private & OPpREPEAT_DOLIST
2346 && !(o->op_flags & OPf_STACKED))
2347 {
2348 list(cBINOPo->op_first);
2349 kid = cBINOPo->op_last;
2350 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2351 && SvIVX(kSVOP_sv) == 1)
2352 {
2353 op_null(o); /* repeat */
2354 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2355 /* const (rhs): */
2356 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2357 }
2358 }
2359 break;
2360 case OP_OR:
2361 case OP_AND:
2362 case OP_COND_EXPR:
2363 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2364 list(kid);
2365 break;
2366 default:
2367 case OP_MATCH:
2368 case OP_QR:
2369 case OP_SUBST:
2370 case OP_NULL:
2371 if (!(o->op_flags & OPf_KIDS))
2372 break;
2373 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2374 list(cBINOPo->op_first);
2375 return gen_constant_list(o);
2376 }
2377 listkids(o);
2378 break;
2379 case OP_LIST:
2380 listkids(o);
2381 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2382 op_null(cUNOPo->op_first); /* NULL the pushmark */
2383 op_null(o); /* NULL the list */
2384 }
2385 break;
2386 case OP_LEAVE:
2387 case OP_LEAVETRY:
2388 kid = cLISTOPo->op_first;
2389 list(kid);
2390 kid = OpSIBLING(kid);
2391 do_kids:
2392 while (kid) {
2393 OP *sib = OpSIBLING(kid);
2394 if (sib && kid->op_type != OP_LEAVEWHEN)
2395 scalarvoid(kid);
2396 else
2397 list(kid);
2398 kid = sib;
2399 }
2400 PL_curcop = &PL_compiling;
2401 break;
2402 case OP_SCOPE:
2403 case OP_LINESEQ:
2404 kid = cLISTOPo->op_first;
2405 goto do_kids;
2406 }
2407 return o;
2408 }
2409
2410 static OP *
S_scalarseq(pTHX_ OP * o)2411 S_scalarseq(pTHX_ OP *o)
2412 {
2413 if (o) {
2414 const OPCODE type = o->op_type;
2415
2416 if (type == OP_LINESEQ || type == OP_SCOPE ||
2417 type == OP_LEAVE || type == OP_LEAVETRY)
2418 {
2419 OP *kid, *sib;
2420 for (kid = cLISTOPo->op_first; kid; kid = sib) {
2421 if ((sib = OpSIBLING(kid))
2422 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2423 || ( sib->op_targ != OP_NEXTSTATE
2424 && sib->op_targ != OP_DBSTATE )))
2425 {
2426 scalarvoid(kid);
2427 }
2428 }
2429 PL_curcop = &PL_compiling;
2430 }
2431 o->op_flags &= ~OPf_PARENS;
2432 if (PL_hints & HINT_BLOCK_SCOPE)
2433 o->op_flags |= OPf_PARENS;
2434 }
2435 else
2436 o = newOP(OP_STUB, 0);
2437 return o;
2438 }
2439
2440 STATIC OP *
S_modkids(pTHX_ OP * o,I32 type)2441 S_modkids(pTHX_ OP *o, I32 type)
2442 {
2443 if (o && o->op_flags & OPf_KIDS) {
2444 OP *kid;
2445 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2446 op_lvalue(kid, type);
2447 }
2448 return o;
2449 }
2450
2451
2452 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2453 * const fields. Also, convert CONST keys to HEK-in-SVs.
2454 * rop is the op that retrieves the hash;
2455 * key_op is the first key
2456 * real if false, only check (and possibly croak); don't update op
2457 */
2458
2459 STATIC void
S_check_hash_fields_and_hekify(pTHX_ UNOP * rop,SVOP * key_op,int real)2460 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real)
2461 {
2462 PADNAME *lexname;
2463 GV **fields;
2464 bool check_fields;
2465
2466 /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2467 if (rop) {
2468 if (rop->op_first->op_type == OP_PADSV)
2469 /* @$hash{qw(keys here)} */
2470 rop = (UNOP*)rop->op_first;
2471 else {
2472 /* @{$hash}{qw(keys here)} */
2473 if (rop->op_first->op_type == OP_SCOPE
2474 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2475 {
2476 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2477 }
2478 else
2479 rop = NULL;
2480 }
2481 }
2482
2483 lexname = NULL; /* just to silence compiler warnings */
2484 fields = NULL; /* just to silence compiler warnings */
2485
2486 check_fields =
2487 rop
2488 && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2489 SvPAD_TYPED(lexname))
2490 && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2491 && isGV(*fields) && GvHV(*fields);
2492
2493 for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2494 SV **svp, *sv;
2495 if (key_op->op_type != OP_CONST)
2496 continue;
2497 svp = cSVOPx_svp(key_op);
2498
2499 /* make sure it's not a bareword under strict subs */
2500 if (key_op->op_private & OPpCONST_BARE &&
2501 key_op->op_private & OPpCONST_STRICT)
2502 {
2503 no_bareword_allowed((OP*)key_op);
2504 }
2505
2506 /* Make the CONST have a shared SV */
2507 if ( !SvIsCOW_shared_hash(sv = *svp)
2508 && SvTYPE(sv) < SVt_PVMG
2509 && SvOK(sv)
2510 && !SvROK(sv)
2511 && real)
2512 {
2513 SSize_t keylen;
2514 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2515 SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2516 SvREFCNT_dec_NN(sv);
2517 *svp = nsv;
2518 }
2519
2520 if ( check_fields
2521 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2522 {
2523 Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2524 "in variable %" PNf " of type %" HEKf,
2525 SVfARG(*svp), PNfARG(lexname),
2526 HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2527 }
2528 }
2529 }
2530
2531 /* info returned by S_sprintf_is_multiconcatable() */
2532
2533 struct sprintf_ismc_info {
2534 SSize_t nargs; /* num of args to sprintf (not including the format) */
2535 char *start; /* start of raw format string */
2536 char *end; /* bytes after end of raw format string */
2537 STRLEN total_len; /* total length (in bytes) of format string, not
2538 including '%s' and half of '%%' */
2539 STRLEN variant; /* number of bytes by which total_len_p would grow
2540 if upgraded to utf8 */
2541 bool utf8; /* whether the format is utf8 */
2542 };
2543
2544
2545 /* is the OP_SPRINTF o suitable for converting into a multiconcat op?
2546 * i.e. its format argument is a const string with only '%s' and '%%'
2547 * formats, and the number of args is known, e.g.
2548 * sprintf "a=%s f=%s", $a[0], scalar(f());
2549 * but not
2550 * sprintf "i=%d a=%s f=%s", $i, @a, f();
2551 *
2552 * If successful, the sprintf_ismc_info struct pointed to by info will be
2553 * populated.
2554 */
2555
2556 STATIC bool
S_sprintf_is_multiconcatable(pTHX_ OP * o,struct sprintf_ismc_info * info)2557 S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info)
2558 {
2559 OP *pm, *constop, *kid;
2560 SV *sv;
2561 char *s, *e, *p;
2562 SSize_t nargs, nformats;
2563 STRLEN cur, total_len, variant;
2564 bool utf8;
2565
2566 /* if sprintf's behaviour changes, die here so that someone
2567 * can decide whether to enhance this function or skip optimising
2568 * under those new circumstances */
2569 assert(!(o->op_flags & OPf_STACKED));
2570 assert(!(PL_opargs[OP_SPRINTF] & OA_TARGLEX));
2571 assert(!(o->op_private & ~OPpARG4_MASK));
2572
2573 pm = cUNOPo->op_first;
2574 if (pm->op_type != OP_PUSHMARK) /* weird coreargs stuff */
2575 return FALSE;
2576 constop = OpSIBLING(pm);
2577 if (!constop || constop->op_type != OP_CONST)
2578 return FALSE;
2579 sv = cSVOPx_sv(constop);
2580 if (SvMAGICAL(sv) || !SvPOK(sv))
2581 return FALSE;
2582
2583 s = SvPV(sv, cur);
2584 e = s + cur;
2585
2586 /* Scan format for %% and %s and work out how many %s there are.
2587 * Abandon if other format types are found.
2588 */
2589
2590 nformats = 0;
2591 total_len = 0;
2592 variant = 0;
2593
2594 for (p = s; p < e; p++) {
2595 if (*p != '%') {
2596 total_len++;
2597 if (!UTF8_IS_INVARIANT(*p))
2598 variant++;
2599 continue;
2600 }
2601 p++;
2602 if (p >= e)
2603 return FALSE; /* lone % at end gives "Invalid conversion" */
2604 if (*p == '%')
2605 total_len++;
2606 else if (*p == 's')
2607 nformats++;
2608 else
2609 return FALSE;
2610 }
2611
2612 if (!nformats || nformats > PERL_MULTICONCAT_MAXARG)
2613 return FALSE;
2614
2615 utf8 = cBOOL(SvUTF8(sv));
2616 if (utf8)
2617 variant = 0;
2618
2619 /* scan args; they must all be in scalar cxt */
2620
2621 nargs = 0;
2622 kid = OpSIBLING(constop);
2623
2624 while (kid) {
2625 if ((kid->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
2626 return FALSE;
2627 nargs++;
2628 kid = OpSIBLING(kid);
2629 }
2630
2631 if (nargs != nformats)
2632 return FALSE; /* e.g. sprintf("%s%s", $a); */
2633
2634
2635 info->nargs = nargs;
2636 info->start = s;
2637 info->end = e;
2638 info->total_len = total_len;
2639 info->variant = variant;
2640 info->utf8 = utf8;
2641
2642 return TRUE;
2643 }
2644
2645
2646
2647 /* S_maybe_multiconcat():
2648 *
2649 * given an OP_STRINGIFY, OP_SASSIGN, OP_CONCAT or OP_SPRINTF op, possibly
2650 * convert it (and its children) into an OP_MULTICONCAT. See the code
2651 * comments just before pp_multiconcat() for the full details of what
2652 * OP_MULTICONCAT supports.
2653 *
2654 * Basically we're looking for an optree with a chain of OP_CONCATS down
2655 * the LHS (or an OP_SPRINTF), with possibly an OP_SASSIGN, and/or
2656 * OP_STRINGIFY, and/or OP_CONCAT acting as '.=' at its head, e.g.
2657 *
2658 * $x = "$a$b-$c"
2659 *
2660 * looks like
2661 *
2662 * SASSIGN
2663 * |
2664 * STRINGIFY -- PADSV[$x]
2665 * |
2666 * |
2667 * ex-PUSHMARK -- CONCAT/S
2668 * |
2669 * CONCAT/S -- PADSV[$d]
2670 * |
2671 * CONCAT -- CONST["-"]
2672 * |
2673 * PADSV[$a] -- PADSV[$b]
2674 *
2675 * Note that at this stage the OP_SASSIGN may have already been optimised
2676 * away with OPpTARGET_MY set on the OP_STRINGIFY or OP_CONCAT.
2677 */
2678
2679 STATIC void
S_maybe_multiconcat(pTHX_ OP * o)2680 S_maybe_multiconcat(pTHX_ OP *o)
2681 {
2682 dVAR;
2683 OP *lastkidop; /* the right-most of any kids unshifted onto o */
2684 OP *topop; /* the top-most op in the concat tree (often equals o,
2685 unless there are assign/stringify ops above it */
2686 OP *parentop; /* the parent op of topop (or itself if no parent) */
2687 OP *targmyop; /* the op (if any) with the OPpTARGET_MY flag */
2688 OP *targetop; /* the op corresponding to target=... or target.=... */
2689 OP *stringop; /* the OP_STRINGIFY op, if any */
2690 OP *nextop; /* used for recreating the op_next chain without consts */
2691 OP *kid; /* general-purpose op pointer */
2692 UNOP_AUX_item *aux;
2693 UNOP_AUX_item *lenp;
2694 char *const_str, *p;
2695 struct sprintf_ismc_info sprintf_info;
2696
2697 /* store info about each arg in args[];
2698 * toparg is the highest used slot; argp is a general
2699 * pointer to args[] slots */
2700 struct {
2701 void *p; /* initially points to const sv (or null for op);
2702 later, set to SvPV(constsv), with ... */
2703 STRLEN len; /* ... len set to SvPV(..., len) */
2704 } *argp, *toparg, args[PERL_MULTICONCAT_MAXARG*2 + 1];
2705
2706 SSize_t nargs = 0;
2707 SSize_t nconst = 0;
2708 SSize_t nadjconst = 0; /* adjacent consts - may be demoted to args */
2709 STRLEN variant;
2710 bool utf8 = FALSE;
2711 bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
2712 the last-processed arg will the LHS of one,
2713 as args are processed in reverse order */
2714 U8 stacked_last = 0; /* whether the last seen concat op was STACKED */
2715 STRLEN total_len = 0; /* sum of the lengths of the const segments */
2716 U8 flags = 0; /* what will become the op_flags and ... */
2717 U8 private_flags = 0; /* ... op_private of the multiconcat op */
2718 bool is_sprintf = FALSE; /* we're optimising an sprintf */
2719 bool is_targable = FALSE; /* targetop is an OPpTARGET_MY candidate */
2720 bool prev_was_const = FALSE; /* previous arg was a const */
2721
2722 /* -----------------------------------------------------------------
2723 * Phase 1:
2724 *
2725 * Examine the optree non-destructively to determine whether it's
2726 * suitable to be converted into an OP_MULTICONCAT. Accumulate
2727 * information about the optree in args[].
2728 */
2729
2730 argp = args;
2731 targmyop = NULL;
2732 targetop = NULL;
2733 stringop = NULL;
2734 topop = o;
2735 parentop = o;
2736
2737 assert( o->op_type == OP_SASSIGN
2738 || o->op_type == OP_CONCAT
2739 || o->op_type == OP_SPRINTF
2740 || o->op_type == OP_STRINGIFY);
2741
2742 Zero(&sprintf_info, 1, struct sprintf_ismc_info);
2743
2744 /* first see if, at the top of the tree, there is an assign,
2745 * append and/or stringify */
2746
2747 if (topop->op_type == OP_SASSIGN) {
2748 /* expr = ..... */
2749 if (o->op_ppaddr != PL_ppaddr[OP_SASSIGN])
2750 return;
2751 if (o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV))
2752 return;
2753 assert(!(o->op_private & ~OPpARG2_MASK)); /* barf on unknown flags */
2754
2755 parentop = topop;
2756 topop = cBINOPo->op_first;
2757 targetop = OpSIBLING(topop);
2758 if (!targetop) /* probably some sort of syntax error */
2759 return;
2760 }
2761 else if ( topop->op_type == OP_CONCAT
2762 && (topop->op_flags & OPf_STACKED)
2763 && (!(topop->op_private & OPpCONCAT_NESTED))
2764 )
2765 {
2766 /* expr .= ..... */
2767
2768 /* OPpTARGET_MY shouldn't be able to be set here. If it is,
2769 * decide what to do about it */
2770 assert(!(o->op_private & OPpTARGET_MY));
2771
2772 /* barf on unknown flags */
2773 assert(!(o->op_private & ~(OPpARG2_MASK|OPpTARGET_MY)));
2774 private_flags |= OPpMULTICONCAT_APPEND;
2775 targetop = cBINOPo->op_first;
2776 parentop = topop;
2777 topop = OpSIBLING(targetop);
2778
2779 /* $x .= <FOO> gets optimised to rcatline instead */
2780 if (topop->op_type == OP_READLINE)
2781 return;
2782 }
2783
2784 if (targetop) {
2785 /* Can targetop (the LHS) if it's a padsv, be be optimised
2786 * away and use OPpTARGET_MY instead?
2787 */
2788 if ( (targetop->op_type == OP_PADSV)
2789 && !(targetop->op_private & OPpDEREF)
2790 && !(targetop->op_private & OPpPAD_STATE)
2791 /* we don't support 'my $x .= ...' */
2792 && ( o->op_type == OP_SASSIGN
2793 || !(targetop->op_private & OPpLVAL_INTRO))
2794 )
2795 is_targable = TRUE;
2796 }
2797
2798 if (topop->op_type == OP_STRINGIFY) {
2799 if (topop->op_ppaddr != PL_ppaddr[OP_STRINGIFY])
2800 return;
2801 stringop = topop;
2802
2803 /* barf on unknown flags */
2804 assert(!(o->op_private & ~(OPpARG4_MASK|OPpTARGET_MY)));
2805
2806 if ((topop->op_private & OPpTARGET_MY)) {
2807 if (o->op_type == OP_SASSIGN)
2808 return; /* can't have two assigns */
2809 targmyop = topop;
2810 }
2811
2812 private_flags |= OPpMULTICONCAT_STRINGIFY;
2813 parentop = topop;
2814 topop = cBINOPx(topop)->op_first;
2815 assert(OP_TYPE_IS_OR_WAS_NN(topop, OP_PUSHMARK));
2816 topop = OpSIBLING(topop);
2817 }
2818
2819 if (topop->op_type == OP_SPRINTF) {
2820 if (topop->op_ppaddr != PL_ppaddr[OP_SPRINTF])
2821 return;
2822 if (S_sprintf_is_multiconcatable(aTHX_ topop, &sprintf_info)) {
2823 nargs = sprintf_info.nargs;
2824 total_len = sprintf_info.total_len;
2825 variant = sprintf_info.variant;
2826 utf8 = sprintf_info.utf8;
2827 is_sprintf = TRUE;
2828 private_flags |= OPpMULTICONCAT_FAKE;
2829 toparg = argp;
2830 /* we have an sprintf op rather than a concat optree.
2831 * Skip most of the code below which is associated with
2832 * processing that optree. We also skip phase 2, determining
2833 * whether its cost effective to optimise, since for sprintf,
2834 * multiconcat is *always* faster */
2835 goto create_aux;
2836 }
2837 /* note that even if the sprintf itself isn't multiconcatable,
2838 * the expression as a whole may be, e.g. in
2839 * $x .= sprintf("%d",...)
2840 * the sprintf op will be left as-is, but the concat/S op may
2841 * be upgraded to multiconcat
2842 */
2843 }
2844 else if (topop->op_type == OP_CONCAT) {
2845 if (topop->op_ppaddr != PL_ppaddr[OP_CONCAT])
2846 return;
2847
2848 if ((topop->op_private & OPpTARGET_MY)) {
2849 if (o->op_type == OP_SASSIGN || targmyop)
2850 return; /* can't have two assigns */
2851 targmyop = topop;
2852 }
2853 }
2854
2855 /* Is it safe to convert a sassign/stringify/concat op into
2856 * a multiconcat? */
2857 assert((PL_opargs[OP_SASSIGN] & OA_CLASS_MASK) == OA_BINOP);
2858 assert((PL_opargs[OP_CONCAT] & OA_CLASS_MASK) == OA_BINOP);
2859 assert((PL_opargs[OP_STRINGIFY] & OA_CLASS_MASK) == OA_LISTOP);
2860 assert((PL_opargs[OP_SPRINTF] & OA_CLASS_MASK) == OA_LISTOP);
2861 STATIC_ASSERT_STMT( STRUCT_OFFSET(BINOP, op_last)
2862 == STRUCT_OFFSET(UNOP_AUX, op_aux));
2863 STATIC_ASSERT_STMT( STRUCT_OFFSET(LISTOP, op_last)
2864 == STRUCT_OFFSET(UNOP_AUX, op_aux));
2865
2866 /* Now scan the down the tree looking for a series of
2867 * CONCAT/OPf_STACKED ops on the LHS (with the last one not
2868 * stacked). For example this tree:
2869 *
2870 * |
2871 * CONCAT/STACKED
2872 * |
2873 * CONCAT/STACKED -- EXPR5
2874 * |
2875 * CONCAT/STACKED -- EXPR4
2876 * |
2877 * CONCAT -- EXPR3
2878 * |
2879 * EXPR1 -- EXPR2
2880 *
2881 * corresponds to an expression like
2882 *
2883 * (EXPR1 . EXPR2 . EXPR3 . EXPR4 . EXPR5)
2884 *
2885 * Record info about each EXPR in args[]: in particular, whether it is
2886 * a stringifiable OP_CONST and if so what the const sv is.
2887 *
2888 * The reason why the last concat can't be STACKED is the difference
2889 * between
2890 *
2891 * ((($a .= $a) .= $a) .= $a) .= $a
2892 *
2893 * and
2894 * $a . $a . $a . $a . $a
2895 *
2896 * The main difference between the optrees for those two constructs
2897 * is the presence of the last STACKED. As well as modifying $a,
2898 * the former sees the changed $a between each concat, so if $s is
2899 * initially 'a', the first returns 'a' x 16, while the latter returns
2900 * 'a' x 5. And pp_multiconcat can't handle that kind of thing.
2901 */
2902
2903 kid = topop;
2904
2905 for (;;) {
2906 OP *argop;
2907 SV *sv;
2908 bool last = FALSE;
2909
2910 if ( kid->op_type == OP_CONCAT
2911 && !kid_is_last
2912 ) {
2913 OP *k1, *k2;
2914 k1 = cUNOPx(kid)->op_first;
2915 k2 = OpSIBLING(k1);
2916 /* shouldn't happen except maybe after compile err? */
2917 if (!k2)
2918 return;
2919
2920 /* avoid turning (A . B . ($lex = C) ...) into (A . B . C ...) */
2921 if (kid->op_private & OPpTARGET_MY)
2922 kid_is_last = TRUE;
2923
2924 stacked_last = (kid->op_flags & OPf_STACKED);
2925 if (!stacked_last)
2926 kid_is_last = TRUE;
2927
2928 kid = k1;
2929 argop = k2;
2930 }
2931 else {
2932 argop = kid;
2933 last = TRUE;
2934 }
2935
2936 if ( nargs + nadjconst > PERL_MULTICONCAT_MAXARG - 2
2937 || (argp - args + 1) > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
2938 {
2939 /* At least two spare slots are needed to decompose both
2940 * concat args. If there are no slots left, continue to
2941 * examine the rest of the optree, but don't push new values
2942 * on args[]. If the optree as a whole is legal for conversion
2943 * (in particular that the last concat isn't STACKED), then
2944 * the first PERL_MULTICONCAT_MAXARG elements of the optree
2945 * can be converted into an OP_MULTICONCAT now, with the first
2946 * child of that op being the remainder of the optree -
2947 * which may itself later be converted to a multiconcat op
2948 * too.
2949 */
2950 if (last) {
2951 /* the last arg is the rest of the optree */
2952 argp++->p = NULL;
2953 nargs++;
2954 }
2955 }
2956 else if ( argop->op_type == OP_CONST
2957 && ((sv = cSVOPx_sv(argop)))
2958 /* defer stringification until runtime of 'constant'
2959 * things that might stringify variantly, e.g. the radix
2960 * point of NVs, or overloaded RVs */
2961 && (SvPOK(sv) || SvIOK(sv))
2962 && (!SvGMAGICAL(sv))
2963 ) {
2964 argp++->p = sv;
2965 utf8 |= cBOOL(SvUTF8(sv));
2966 nconst++;
2967 if (prev_was_const)
2968 /* this const may be demoted back to a plain arg later;
2969 * make sure we have enough arg slots left */
2970 nadjconst++;
2971 prev_was_const = !prev_was_const;
2972 }
2973 else {
2974 argp++->p = NULL;
2975 nargs++;
2976 prev_was_const = FALSE;
2977 }
2978
2979 if (last)
2980 break;
2981 }
2982
2983 toparg = argp - 1;
2984
2985 if (stacked_last)
2986 return; /* we don't support ((A.=B).=C)...) */
2987
2988 /* look for two adjacent consts and don't fold them together:
2989 * $o . "a" . "b"
2990 * should do
2991 * $o->concat("a")->concat("b")
2992 * rather than
2993 * $o->concat("ab")
2994 * (but $o .= "a" . "b" should still fold)
2995 */
2996 {
2997 bool seen_nonconst = FALSE;
2998 for (argp = toparg; argp >= args; argp--) {
2999 if (argp->p == NULL) {
3000 seen_nonconst = TRUE;
3001 continue;
3002 }
3003 if (!seen_nonconst)
3004 continue;
3005 if (argp[1].p) {
3006 /* both previous and current arg were constants;
3007 * leave the current OP_CONST as-is */
3008 argp->p = NULL;
3009 nconst--;
3010 nargs++;
3011 }
3012 }
3013 }
3014
3015 /* -----------------------------------------------------------------
3016 * Phase 2:
3017 *
3018 * At this point we have determined that the optree *can* be converted
3019 * into a multiconcat. Having gathered all the evidence, we now decide
3020 * whether it *should*.
3021 */
3022
3023
3024 /* we need at least one concat action, e.g.:
3025 *
3026 * Y . Z
3027 * X = Y . Z
3028 * X .= Y
3029 *
3030 * otherwise we could be doing something like $x = "foo", which
3031 * if treated as as a concat, would fail to COW.
3032 */
3033 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2)
3034 return;
3035
3036 /* Benchmarking seems to indicate that we gain if:
3037 * * we optimise at least two actions into a single multiconcat
3038 * (e.g concat+concat, sassign+concat);
3039 * * or if we can eliminate at least 1 OP_CONST;
3040 * * or if we can eliminate a padsv via OPpTARGET_MY
3041 */
3042
3043 if (
3044 /* eliminated at least one OP_CONST */
3045 nconst >= 1
3046 /* eliminated an OP_SASSIGN */
3047 || o->op_type == OP_SASSIGN
3048 /* eliminated an OP_PADSV */
3049 || (!targmyop && is_targable)
3050 )
3051 /* definitely a net gain to optimise */
3052 goto optimise;
3053
3054 /* ... if not, what else? */
3055
3056 /* special-case '$lex1 = expr . $lex1' (where expr isn't lex1):
3057 * multiconcat is faster (due to not creating a temporary copy of
3058 * $lex1), whereas for a general $lex1 = $lex2 . $lex3, concat is
3059 * faster.
3060 */
3061 if ( nconst == 0
3062 && nargs == 2
3063 && targmyop
3064 && topop->op_type == OP_CONCAT
3065 ) {
3066 PADOFFSET t = targmyop->op_targ;
3067 OP *k1 = cBINOPx(topop)->op_first;
3068 OP *k2 = cBINOPx(topop)->op_last;
3069 if ( k2->op_type == OP_PADSV
3070 && k2->op_targ == t
3071 && ( k1->op_type != OP_PADSV
3072 || k1->op_targ != t)
3073 )
3074 goto optimise;
3075 }
3076
3077 /* need at least two concats */
3078 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 3)
3079 return;
3080
3081
3082
3083 /* -----------------------------------------------------------------
3084 * Phase 3:
3085 *
3086 * At this point the optree has been verified as ok to be optimised
3087 * into an OP_MULTICONCAT. Now start changing things.
3088 */
3089
3090 optimise:
3091
3092 /* stringify all const args and determine utf8ness */
3093
3094 variant = 0;
3095 for (argp = args; argp <= toparg; argp++) {
3096 SV *sv = (SV*)argp->p;
3097 if (!sv)
3098 continue; /* not a const op */
3099 if (utf8 && !SvUTF8(sv))
3100 sv_utf8_upgrade_nomg(sv);
3101 argp->p = SvPV_nomg(sv, argp->len);
3102 total_len += argp->len;
3103
3104 /* see if any strings would grow if converted to utf8 */
3105 if (!utf8) {
3106 variant += variant_under_utf8_count((U8 *) argp->p,
3107 (U8 *) argp->p + argp->len);
3108 }
3109 }
3110
3111 /* create and populate aux struct */
3112
3113 create_aux:
3114
3115 aux = (UNOP_AUX_item*)PerlMemShared_malloc(
3116 sizeof(UNOP_AUX_item)
3117 * (
3118 PERL_MULTICONCAT_HEADER_SIZE
3119 + ((nargs + 1) * (variant ? 2 : 1))
3120 )
3121 );
3122 const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1);
3123
3124 /* Extract all the non-const expressions from the concat tree then
3125 * dispose of the old tree, e.g. convert the tree from this:
3126 *
3127 * o => SASSIGN
3128 * |
3129 * STRINGIFY -- TARGET
3130 * |
3131 * ex-PUSHMARK -- CONCAT
3132 * |
3133 * CONCAT -- EXPR5
3134 * |
3135 * CONCAT -- EXPR4
3136 * |
3137 * CONCAT -- EXPR3
3138 * |
3139 * EXPR1 -- EXPR2
3140 *
3141 *
3142 * to:
3143 *
3144 * o => MULTICONCAT
3145 * |
3146 * ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET
3147 *
3148 * except that if EXPRi is an OP_CONST, it's discarded.
3149 *
3150 * During the conversion process, EXPR ops are stripped from the tree
3151 * and unshifted onto o. Finally, any of o's remaining original
3152 * childen are discarded and o is converted into an OP_MULTICONCAT.
3153 *
3154 * In this middle of this, o may contain both: unshifted args on the
3155 * left, and some remaining original args on the right. lastkidop
3156 * is set to point to the right-most unshifted arg to delineate
3157 * between the two sets.
3158 */
3159
3160
3161 if (is_sprintf) {
3162 /* create a copy of the format with the %'s removed, and record
3163 * the sizes of the const string segments in the aux struct */
3164 char *q, *oldq;
3165 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3166
3167 p = sprintf_info.start;
3168 q = const_str;
3169 oldq = q;
3170 for (; p < sprintf_info.end; p++) {
3171 if (*p == '%') {
3172 p++;
3173 if (*p != '%') {
3174 (lenp++)->ssize = q - oldq;
3175 oldq = q;
3176 continue;
3177 }
3178 }
3179 *q++ = *p;
3180 }
3181 lenp->ssize = q - oldq;
3182 assert((STRLEN)(q - const_str) == total_len);
3183
3184 /* Attach all the args (i.e. the kids of the sprintf) to o (which
3185 * may or may not be topop) The pushmark and const ops need to be
3186 * kept in case they're an op_next entry point.
3187 */
3188 lastkidop = cLISTOPx(topop)->op_last;
3189 kid = cUNOPx(topop)->op_first; /* pushmark */
3190 op_null(kid);
3191 op_null(OpSIBLING(kid)); /* const */
3192 if (o != topop) {
3193 kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */
3194 op_sibling_splice(o, NULL, 0, kid); /* and attach to o */
3195 lastkidop->op_next = o;
3196 }
3197 }
3198 else {
3199 p = const_str;
3200 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3201
3202 lenp->ssize = -1;
3203
3204 /* Concatenate all const strings into const_str.
3205 * Note that args[] contains the RHS args in reverse order, so
3206 * we scan args[] from top to bottom to get constant strings
3207 * in L-R order
3208 */
3209 for (argp = toparg; argp >= args; argp--) {
3210 if (!argp->p)
3211 /* not a const op */
3212 (++lenp)->ssize = -1;
3213 else {
3214 STRLEN l = argp->len;
3215 Copy(argp->p, p, l, char);
3216 p += l;
3217 if (lenp->ssize == -1)
3218 lenp->ssize = l;
3219 else
3220 lenp->ssize += l;
3221 }
3222 }
3223
3224 kid = topop;
3225 nextop = o;
3226 lastkidop = NULL;
3227
3228 for (argp = args; argp <= toparg; argp++) {
3229 /* only keep non-const args, except keep the first-in-next-chain
3230 * arg no matter what it is (but nulled if OP_CONST), because it
3231 * may be the entry point to this subtree from the previous
3232 * op_next.
3233 */
3234 bool last = (argp == toparg);
3235 OP *prev;
3236
3237 /* set prev to the sibling *before* the arg to be cut out,
3238 * e.g. when cutting EXPR:
3239 *
3240 * |
3241 * kid= CONCAT
3242 * |
3243 * prev= CONCAT -- EXPR
3244 * |
3245 */
3246 if (argp == args && kid->op_type != OP_CONCAT) {
3247 /* in e.g. '$x .= f(1)' there's no RHS concat tree
3248 * so the expression to be cut isn't kid->op_last but
3249 * kid itself */
3250 OP *o1, *o2;
3251 /* find the op before kid */
3252 o1 = NULL;
3253 o2 = cUNOPx(parentop)->op_first;
3254 while (o2 && o2 != kid) {
3255 o1 = o2;
3256 o2 = OpSIBLING(o2);
3257 }
3258 assert(o2 == kid);
3259 prev = o1;
3260 kid = parentop;
3261 }
3262 else if (kid == o && lastkidop)
3263 prev = last ? lastkidop : OpSIBLING(lastkidop);
3264 else
3265 prev = last ? NULL : cUNOPx(kid)->op_first;
3266
3267 if (!argp->p || last) {
3268 /* cut RH op */
3269 OP *aop = op_sibling_splice(kid, prev, 1, NULL);
3270 /* and unshift to front of o */
3271 op_sibling_splice(o, NULL, 0, aop);
3272 /* record the right-most op added to o: later we will
3273 * free anything to the right of it */
3274 if (!lastkidop)
3275 lastkidop = aop;
3276 aop->op_next = nextop;
3277 if (last) {
3278 if (argp->p)
3279 /* null the const at start of op_next chain */
3280 op_null(aop);
3281 }
3282 else if (prev)
3283 nextop = prev->op_next;
3284 }
3285
3286 /* the last two arguments are both attached to the same concat op */
3287 if (argp < toparg - 1)
3288 kid = prev;
3289 }
3290 }
3291
3292 /* Populate the aux struct */
3293
3294 aux[PERL_MULTICONCAT_IX_NARGS].ssize = nargs;
3295 aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv = utf8 ? NULL : const_str;
3296 aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ? 0 : total_len;
3297 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = const_str;
3298 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = total_len;
3299
3300 /* if variant > 0, calculate a variant const string and lengths where
3301 * the utf8 version of the string will take 'variant' more bytes than
3302 * the plain one. */
3303
3304 if (variant) {
3305 char *p = const_str;
3306 STRLEN ulen = total_len + variant;
3307 UNOP_AUX_item *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3308 UNOP_AUX_item *ulens = lens + (nargs + 1);
3309 char *up = (char*)PerlMemShared_malloc(ulen);
3310 SSize_t n;
3311
3312 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = up;
3313 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen;
3314
3315 for (n = 0; n < (nargs + 1); n++) {
3316 SSize_t i;
3317 char * orig_up = up;
3318 for (i = (lens++)->ssize; i > 0; i--) {
3319 U8 c = *p++;
3320 append_utf8_from_native_byte(c, (U8**)&up);
3321 }
3322 (ulens++)->ssize = (i < 0) ? i : up - orig_up;
3323 }
3324 }
3325
3326 if (stringop) {
3327 /* if there was a top(ish)-level OP_STRINGIFY, we need to keep
3328 * that op's first child - an ex-PUSHMARK - because the op_next of
3329 * the previous op may point to it (i.e. it's the entry point for
3330 * the o optree)
3331 */
3332 OP *pmop =
3333 (stringop == o)
3334 ? op_sibling_splice(o, lastkidop, 1, NULL)
3335 : op_sibling_splice(stringop, NULL, 1, NULL);
3336 assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK));
3337 op_sibling_splice(o, NULL, 0, pmop);
3338 if (!lastkidop)
3339 lastkidop = pmop;
3340 }
3341
3342 /* Optimise
3343 * target = A.B.C...
3344 * target .= A.B.C...
3345 */
3346
3347 if (targetop) {
3348 assert(!targmyop);
3349
3350 if (o->op_type == OP_SASSIGN) {
3351 /* Move the target subtree from being the last of o's children
3352 * to being the last of o's preserved children.
3353 * Note the difference between 'target = ...' and 'target .= ...':
3354 * for the former, target is executed last; for the latter,
3355 * first.
3356 */
3357 kid = OpSIBLING(lastkidop);
3358 op_sibling_splice(o, kid, 1, NULL); /* cut target op */
3359 op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */
3360 lastkidop->op_next = kid->op_next;
3361 lastkidop = targetop;
3362 }
3363 else {
3364 /* Move the target subtree from being the first of o's
3365 * original children to being the first of *all* o's children.
3366 */
3367 if (lastkidop) {
3368 op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */
3369 op_sibling_splice(o, NULL, 0, targetop); /* and paste*/
3370 }
3371 else {
3372 /* if the RHS of .= doesn't contain a concat (e.g.
3373 * $x .= "foo"), it gets missed by the "strip ops from the
3374 * tree and add to o" loop earlier */
3375 assert(topop->op_type != OP_CONCAT);
3376 if (stringop) {
3377 /* in e.g. $x .= "$y", move the $y expression
3378 * from being a child of OP_STRINGIFY to being the
3379 * second child of the OP_CONCAT
3380 */
3381 assert(cUNOPx(stringop)->op_first == topop);
3382 op_sibling_splice(stringop, NULL, 1, NULL);
3383 op_sibling_splice(o, cUNOPo->op_first, 0, topop);
3384 }
3385 assert(topop == OpSIBLING(cBINOPo->op_first));
3386 if (toparg->p)
3387 op_null(topop);
3388 lastkidop = topop;
3389 }
3390 }
3391
3392 if (is_targable) {
3393 /* optimise
3394 * my $lex = A.B.C...
3395 * $lex = A.B.C...
3396 * $lex .= A.B.C...
3397 * The original padsv op is kept but nulled in case it's the
3398 * entry point for the optree (which it will be for
3399 * '$lex .= ... '
3400 */
3401 private_flags |= OPpTARGET_MY;
3402 private_flags |= (targetop->op_private & OPpLVAL_INTRO);
3403 o->op_targ = targetop->op_targ;
3404 targetop->op_targ = 0;
3405 op_null(targetop);
3406 }
3407 else
3408 flags |= OPf_STACKED;
3409 }
3410 else if (targmyop) {
3411 private_flags |= OPpTARGET_MY;
3412 if (o != targmyop) {
3413 o->op_targ = targmyop->op_targ;
3414 targmyop->op_targ = 0;
3415 }
3416 }
3417
3418 /* detach the emaciated husk of the sprintf/concat optree and free it */
3419 for (;;) {
3420 kid = op_sibling_splice(o, lastkidop, 1, NULL);
3421 if (!kid)
3422 break;
3423 op_free(kid);
3424 }
3425
3426 /* and convert o into a multiconcat */
3427
3428 o->op_flags = (flags|OPf_KIDS|stacked_last
3429 |(o->op_flags & (OPf_WANT|OPf_PARENS)));
3430 o->op_private = private_flags;
3431 o->op_type = OP_MULTICONCAT;
3432 o->op_ppaddr = PL_ppaddr[OP_MULTICONCAT];
3433 cUNOP_AUXo->op_aux = aux;
3434 }
3435
3436
3437 /* do all the final processing on an optree (e.g. running the peephole
3438 * optimiser on it), then attach it to cv (if cv is non-null)
3439 */
3440
3441 static void
S_process_optree(pTHX_ CV * cv,OP * optree,OP * start)3442 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
3443 {
3444 OP **startp;
3445
3446 /* XXX for some reason, evals, require and main optrees are
3447 * never attached to their CV; instead they just hang off
3448 * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
3449 * and get manually freed when appropriate */
3450 if (cv)
3451 startp = &CvSTART(cv);
3452 else
3453 startp = PL_in_eval? &PL_eval_start : &PL_main_start;
3454
3455 *startp = start;
3456 optree->op_private |= OPpREFCOUNTED;
3457 OpREFCNT_set(optree, 1);
3458 optimize_optree(optree);
3459 CALL_PEEP(*startp);
3460 finalize_optree(optree);
3461 S_prune_chain_head(startp);
3462
3463 if (cv) {
3464 /* now that optimizer has done its work, adjust pad values */
3465 pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
3466 : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
3467 }
3468 }
3469
3470
3471 /*
3472 =for apidoc optimize_optree
3473
3474 This function applies some optimisations to the optree in top-down order.
3475 It is called before the peephole optimizer, which processes ops in
3476 execution order. Note that finalize_optree() also does a top-down scan,
3477 but is called *after* the peephole optimizer.
3478
3479 =cut
3480 */
3481
3482 void
Perl_optimize_optree(pTHX_ OP * o)3483 Perl_optimize_optree(pTHX_ OP* o)
3484 {
3485 PERL_ARGS_ASSERT_OPTIMIZE_OPTREE;
3486
3487 ENTER;
3488 SAVEVPTR(PL_curcop);
3489
3490 optimize_op(o);
3491
3492 LEAVE;
3493 }
3494
3495
3496 /* helper for optimize_optree() which optimises on op then recurses
3497 * to optimise any children.
3498 */
3499
3500 STATIC void
S_optimize_op(pTHX_ OP * o)3501 S_optimize_op(pTHX_ OP* o)
3502 {
3503 dDEFER_OP;
3504
3505 PERL_ARGS_ASSERT_OPTIMIZE_OP;
3506 do {
3507 assert(o->op_type != OP_FREED);
3508
3509 switch (o->op_type) {
3510 case OP_NEXTSTATE:
3511 case OP_DBSTATE:
3512 PL_curcop = ((COP*)o); /* for warnings */
3513 break;
3514
3515
3516 case OP_CONCAT:
3517 case OP_SASSIGN:
3518 case OP_STRINGIFY:
3519 case OP_SPRINTF:
3520 S_maybe_multiconcat(aTHX_ o);
3521 break;
3522
3523 case OP_SUBST:
3524 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3525 DEFER_OP(cPMOPo->op_pmreplrootu.op_pmreplroot);
3526 break;
3527
3528 default:
3529 break;
3530 }
3531
3532 if (o->op_flags & OPf_KIDS) {
3533 OP *kid;
3534 IV child_count = 0;
3535 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3536 DEFER_OP(kid);
3537 ++child_count;
3538 }
3539 DEFER_REVERSE(child_count);
3540 }
3541 } while ( ( o = POP_DEFERRED_OP() ) );
3542
3543 DEFER_OP_CLEANUP;
3544 }
3545
3546
3547 /*
3548 =for apidoc finalize_optree
3549
3550 This function finalizes the optree. Should be called directly after
3551 the complete optree is built. It does some additional
3552 checking which can't be done in the normal C<ck_>xxx functions and makes
3553 the tree thread-safe.
3554
3555 =cut
3556 */
3557 void
Perl_finalize_optree(pTHX_ OP * o)3558 Perl_finalize_optree(pTHX_ OP* o)
3559 {
3560 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
3561
3562 ENTER;
3563 SAVEVPTR(PL_curcop);
3564
3565 finalize_op(o);
3566
3567 LEAVE;
3568 }
3569
3570 #ifdef USE_ITHREADS
3571 /* Relocate sv to the pad for thread safety.
3572 * Despite being a "constant", the SV is written to,
3573 * for reference counts, sv_upgrade() etc. */
3574 PERL_STATIC_INLINE void
S_op_relocate_sv(pTHX_ SV ** svp,PADOFFSET * targp)3575 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
3576 {
3577 PADOFFSET ix;
3578 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
3579 if (!*svp) return;
3580 ix = pad_alloc(OP_CONST, SVf_READONLY);
3581 SvREFCNT_dec(PAD_SVl(ix));
3582 PAD_SETSV(ix, *svp);
3583 /* XXX I don't know how this isn't readonly already. */
3584 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
3585 *svp = NULL;
3586 *targp = ix;
3587 }
3588 #endif
3589
3590 /*
3591 =for apidoc s|OP*|traverse_op_tree|OP* top|OP* o
3592
3593 Return the next op in a depth-first traversal of the op tree,
3594 returning NULL when the traversal is complete.
3595
3596 The initial call must supply the root of the tree as both top and o.
3597
3598 For now it's static, but it may be exposed to the API in the future.
3599
3600 =cut
3601 */
3602
3603 STATIC OP*
S_traverse_op_tree(pTHX_ OP * top,OP * o)3604 S_traverse_op_tree(pTHX_ OP *top, OP *o) {
3605 OP *sib;
3606
3607 PERL_ARGS_ASSERT_TRAVERSE_OP_TREE;
3608
3609 if ((o->op_flags & OPf_KIDS) && cUNOPo->op_first) {
3610 return cUNOPo->op_first;
3611 }
3612 else if ((sib = OpSIBLING(o))) {
3613 return sib;
3614 }
3615 else {
3616 OP *parent = o->op_sibparent;
3617 assert(!(o->op_moresib));
3618 while (parent && parent != top) {
3619 OP *sib = OpSIBLING(parent);
3620 if (sib)
3621 return sib;
3622 parent = parent->op_sibparent;
3623 }
3624
3625 return NULL;
3626 }
3627 }
3628
3629 STATIC void
S_finalize_op(pTHX_ OP * o)3630 S_finalize_op(pTHX_ OP* o)
3631 {
3632 OP * const top = o;
3633 PERL_ARGS_ASSERT_FINALIZE_OP;
3634
3635 do {
3636 assert(o->op_type != OP_FREED);
3637
3638 switch (o->op_type) {
3639 case OP_NEXTSTATE:
3640 case OP_DBSTATE:
3641 PL_curcop = ((COP*)o); /* for warnings */
3642 break;
3643 case OP_EXEC:
3644 if (OpHAS_SIBLING(o)) {
3645 OP *sib = OpSIBLING(o);
3646 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
3647 && ckWARN(WARN_EXEC)
3648 && OpHAS_SIBLING(sib))
3649 {
3650 const OPCODE type = OpSIBLING(sib)->op_type;
3651 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
3652 const line_t oldline = CopLINE(PL_curcop);
3653 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
3654 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3655 "Statement unlikely to be reached");
3656 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3657 "\t(Maybe you meant system() when you said exec()?)\n");
3658 CopLINE_set(PL_curcop, oldline);
3659 }
3660 }
3661 }
3662 break;
3663
3664 case OP_GV:
3665 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
3666 GV * const gv = cGVOPo_gv;
3667 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
3668 /* XXX could check prototype here instead of just carping */
3669 SV * const sv = sv_newmortal();
3670 gv_efullname3(sv, gv, NULL);
3671 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3672 "%" SVf "() called too early to check prototype",
3673 SVfARG(sv));
3674 }
3675 }
3676 break;
3677
3678 case OP_CONST:
3679 if (cSVOPo->op_private & OPpCONST_STRICT)
3680 no_bareword_allowed(o);
3681 #ifdef USE_ITHREADS
3682 /* FALLTHROUGH */
3683 case OP_HINTSEVAL:
3684 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
3685 #endif
3686 break;
3687
3688 #ifdef USE_ITHREADS
3689 /* Relocate all the METHOP's SVs to the pad for thread safety. */
3690 case OP_METHOD_NAMED:
3691 case OP_METHOD_SUPER:
3692 case OP_METHOD_REDIR:
3693 case OP_METHOD_REDIR_SUPER:
3694 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
3695 break;
3696 #endif
3697
3698 case OP_HELEM: {
3699 UNOP *rop;
3700 SVOP *key_op;
3701 OP *kid;
3702
3703 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
3704 break;
3705
3706 rop = (UNOP*)((BINOP*)o)->op_first;
3707
3708 goto check_keys;
3709
3710 case OP_HSLICE:
3711 S_scalar_slice_warning(aTHX_ o);
3712 /* FALLTHROUGH */
3713
3714 case OP_KVHSLICE:
3715 kid = OpSIBLING(cLISTOPo->op_first);
3716 if (/* I bet there's always a pushmark... */
3717 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
3718 && OP_TYPE_ISNT_NN(kid, OP_CONST))
3719 {
3720 break;
3721 }
3722
3723 key_op = (SVOP*)(kid->op_type == OP_CONST
3724 ? kid
3725 : OpSIBLING(kLISTOP->op_first));
3726
3727 rop = (UNOP*)((LISTOP*)o)->op_last;
3728
3729 check_keys:
3730 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
3731 rop = NULL;
3732 S_check_hash_fields_and_hekify(aTHX_ rop, key_op, 1);
3733 break;
3734 }
3735 case OP_NULL:
3736 if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
3737 break;
3738 /* FALLTHROUGH */
3739 case OP_ASLICE:
3740 S_scalar_slice_warning(aTHX_ o);
3741 break;
3742
3743 case OP_SUBST: {
3744 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3745 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3746 break;
3747 }
3748 default:
3749 break;
3750 }
3751
3752 #ifdef DEBUGGING
3753 if (o->op_flags & OPf_KIDS) {
3754 OP *kid;
3755
3756 /* check that op_last points to the last sibling, and that
3757 * the last op_sibling/op_sibparent field points back to the
3758 * parent, and that the only ops with KIDS are those which are
3759 * entitled to them */
3760 U32 type = o->op_type;
3761 U32 family;
3762 bool has_last;
3763
3764 if (type == OP_NULL) {
3765 type = o->op_targ;
3766 /* ck_glob creates a null UNOP with ex-type GLOB
3767 * (which is a list op. So pretend it wasn't a listop */
3768 if (type == OP_GLOB)
3769 type = OP_NULL;
3770 }
3771 family = PL_opargs[type] & OA_CLASS_MASK;
3772
3773 has_last = ( family == OA_BINOP
3774 || family == OA_LISTOP
3775 || family == OA_PMOP
3776 || family == OA_LOOP
3777 );
3778 assert( has_last /* has op_first and op_last, or ...
3779 ... has (or may have) op_first: */
3780 || family == OA_UNOP
3781 || family == OA_UNOP_AUX
3782 || family == OA_LOGOP
3783 || family == OA_BASEOP_OR_UNOP
3784 || family == OA_FILESTATOP
3785 || family == OA_LOOPEXOP
3786 || family == OA_METHOP
3787 || type == OP_CUSTOM
3788 || type == OP_NULL /* new_logop does this */
3789 );
3790
3791 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3792 if (!OpHAS_SIBLING(kid)) {
3793 if (has_last)
3794 assert(kid == cLISTOPo->op_last);
3795 assert(kid->op_sibparent == o);
3796 }
3797 }
3798 }
3799 #endif
3800 } while (( o = traverse_op_tree(top, o)) != NULL);
3801 }
3802
3803 /*
3804 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
3805
3806 Propagate lvalue ("modifiable") context to an op and its children.
3807 C<type> represents the context type, roughly based on the type of op that
3808 would do the modifying, although C<local()> is represented by C<OP_NULL>,
3809 because it has no op type of its own (it is signalled by a flag on
3810 the lvalue op).
3811
3812 This function detects things that can't be modified, such as C<$x+1>, and
3813 generates errors for them. For example, C<$x+1 = 2> would cause it to be
3814 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
3815
3816 It also flags things that need to behave specially in an lvalue context,
3817 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3818
3819 =cut
3820 */
3821
3822 static void
S_mark_padname_lvalue(pTHX_ PADNAME * pn)3823 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
3824 {
3825 CV *cv = PL_compcv;
3826 PadnameLVALUE_on(pn);
3827 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
3828 cv = CvOUTSIDE(cv);
3829 /* RT #127786: cv can be NULL due to an eval within the DB package
3830 * called from an anon sub - anon subs don't have CvOUTSIDE() set
3831 * unless they contain an eval, but calling eval within DB
3832 * pretends the eval was done in the caller's scope.
3833 */
3834 if (!cv)
3835 break;
3836 assert(CvPADLIST(cv));
3837 pn =
3838 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
3839 assert(PadnameLEN(pn));
3840 PadnameLVALUE_on(pn);
3841 }
3842 }
3843
3844 static bool
S_vivifies(const OPCODE type)3845 S_vivifies(const OPCODE type)
3846 {
3847 switch(type) {
3848 case OP_RV2AV: case OP_ASLICE:
3849 case OP_RV2HV: case OP_KVASLICE:
3850 case OP_RV2SV: case OP_HSLICE:
3851 case OP_AELEMFAST: case OP_KVHSLICE:
3852 case OP_HELEM:
3853 case OP_AELEM:
3854 return 1;
3855 }
3856 return 0;
3857 }
3858
3859 static void
S_lvref(pTHX_ OP * o,I32 type)3860 S_lvref(pTHX_ OP *o, I32 type)
3861 {
3862 dVAR;
3863 OP *kid;
3864 switch (o->op_type) {
3865 case OP_COND_EXPR:
3866 for (kid = OpSIBLING(cUNOPo->op_first); kid;
3867 kid = OpSIBLING(kid))
3868 S_lvref(aTHX_ kid, type);
3869 /* FALLTHROUGH */
3870 case OP_PUSHMARK:
3871 return;
3872 case OP_RV2AV:
3873 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
3874 o->op_flags |= OPf_STACKED;
3875 if (o->op_flags & OPf_PARENS) {
3876 if (o->op_private & OPpLVAL_INTRO) {
3877 yyerror(Perl_form(aTHX_ "Can't modify reference to "
3878 "localized parenthesized array in list assignment"));
3879 return;
3880 }
3881 slurpy:
3882 OpTYPE_set(o, OP_LVAVREF);
3883 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
3884 o->op_flags |= OPf_MOD|OPf_REF;
3885 return;
3886 }
3887 o->op_private |= OPpLVREF_AV;
3888 goto checkgv;
3889 case OP_RV2CV:
3890 kid = cUNOPo->op_first;
3891 if (kid->op_type == OP_NULL)
3892 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
3893 ->op_first;
3894 o->op_private = OPpLVREF_CV;
3895 if (kid->op_type == OP_GV)
3896 o->op_flags |= OPf_STACKED;
3897 else if (kid->op_type == OP_PADCV) {
3898 o->op_targ = kid->op_targ;
3899 kid->op_targ = 0;
3900 op_free(cUNOPo->op_first);
3901 cUNOPo->op_first = NULL;
3902 o->op_flags &=~ OPf_KIDS;
3903 }
3904 else goto badref;
3905 break;
3906 case OP_RV2HV:
3907 if (o->op_flags & OPf_PARENS) {
3908 parenhash:
3909 yyerror(Perl_form(aTHX_ "Can't modify reference to "
3910 "parenthesized hash in list assignment"));
3911 return;
3912 }
3913 o->op_private |= OPpLVREF_HV;
3914 /* FALLTHROUGH */
3915 case OP_RV2SV:
3916 checkgv:
3917 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
3918 o->op_flags |= OPf_STACKED;
3919 break;
3920 case OP_PADHV:
3921 if (o->op_flags & OPf_PARENS) goto parenhash;
3922 o->op_private |= OPpLVREF_HV;
3923 /* FALLTHROUGH */
3924 case OP_PADSV:
3925 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
3926 break;
3927 case OP_PADAV:
3928 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
3929 if (o->op_flags & OPf_PARENS) goto slurpy;
3930 o->op_private |= OPpLVREF_AV;
3931 break;
3932 case OP_AELEM:
3933 case OP_HELEM:
3934 o->op_private |= OPpLVREF_ELEM;
3935 o->op_flags |= OPf_STACKED;
3936 break;
3937 case OP_ASLICE:
3938 case OP_HSLICE:
3939 OpTYPE_set(o, OP_LVREFSLICE);
3940 o->op_private &= OPpLVAL_INTRO;
3941 return;
3942 case OP_NULL:
3943 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
3944 goto badref;
3945 else if (!(o->op_flags & OPf_KIDS))
3946 return;
3947 if (o->op_targ != OP_LIST) {
3948 S_lvref(aTHX_ cBINOPo->op_first, type);
3949 return;
3950 }
3951 /* FALLTHROUGH */
3952 case OP_LIST:
3953 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
3954 assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
3955 S_lvref(aTHX_ kid, type);
3956 }
3957 return;
3958 case OP_STUB:
3959 if (o->op_flags & OPf_PARENS)
3960 return;
3961 /* FALLTHROUGH */
3962 default:
3963 badref:
3964 /* diag_listed_as: Can't modify reference to %s in %s assignment */
3965 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
3966 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
3967 ? "do block"
3968 : OP_DESC(o),
3969 PL_op_desc[type]));
3970 return;
3971 }
3972 OpTYPE_set(o, OP_LVREF);
3973 o->op_private &=
3974 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
3975 if (type == OP_ENTERLOOP)
3976 o->op_private |= OPpLVREF_ITER;
3977 }
3978
3979 PERL_STATIC_INLINE bool
S_potential_mod_type(I32 type)3980 S_potential_mod_type(I32 type)
3981 {
3982 /* Types that only potentially result in modification. */
3983 return type == OP_GREPSTART || type == OP_ENTERSUB
3984 || type == OP_REFGEN || type == OP_LEAVESUBLV;
3985 }
3986
3987 OP *
Perl_op_lvalue_flags(pTHX_ OP * o,I32 type,U32 flags)3988 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
3989 {
3990 dVAR;
3991 OP *kid;
3992 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
3993 int localize = -1;
3994
3995 if (!o || (PL_parser && PL_parser->error_count))
3996 return o;
3997
3998 if ((o->op_private & OPpTARGET_MY)
3999 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
4000 {
4001 return o;
4002 }
4003
4004 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
4005
4006 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
4007
4008 switch (o->op_type) {
4009 case OP_UNDEF:
4010 PL_modcount++;
4011 return o;
4012 case OP_STUB:
4013 if ((o->op_flags & OPf_PARENS))
4014 break;
4015 goto nomod;
4016 case OP_ENTERSUB:
4017 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
4018 !(o->op_flags & OPf_STACKED)) {
4019 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
4020 assert(cUNOPo->op_first->op_type == OP_NULL);
4021 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
4022 break;
4023 }
4024 else { /* lvalue subroutine call */
4025 o->op_private |= OPpLVAL_INTRO;
4026 PL_modcount = RETURN_UNLIMITED_NUMBER;
4027 if (S_potential_mod_type(type)) {
4028 o->op_private |= OPpENTERSUB_INARGS;
4029 break;
4030 }
4031 else { /* Compile-time error message: */
4032 OP *kid = cUNOPo->op_first;
4033 CV *cv;
4034 GV *gv;
4035 SV *namesv;
4036
4037 if (kid->op_type != OP_PUSHMARK) {
4038 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
4039 Perl_croak(aTHX_
4040 "panic: unexpected lvalue entersub "
4041 "args: type/targ %ld:%" UVuf,
4042 (long)kid->op_type, (UV)kid->op_targ);
4043 kid = kLISTOP->op_first;
4044 }
4045 while (OpHAS_SIBLING(kid))
4046 kid = OpSIBLING(kid);
4047 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
4048 break; /* Postpone until runtime */
4049 }
4050
4051 kid = kUNOP->op_first;
4052 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
4053 kid = kUNOP->op_first;
4054 if (kid->op_type == OP_NULL)
4055 Perl_croak(aTHX_
4056 "Unexpected constant lvalue entersub "
4057 "entry via type/targ %ld:%" UVuf,
4058 (long)kid->op_type, (UV)kid->op_targ);
4059 if (kid->op_type != OP_GV) {
4060 break;
4061 }
4062
4063 gv = kGVOP_gv;
4064 cv = isGV(gv)
4065 ? GvCV(gv)
4066 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
4067 ? MUTABLE_CV(SvRV(gv))
4068 : NULL;
4069 if (!cv)
4070 break;
4071 if (CvLVALUE(cv))
4072 break;
4073 if (flags & OP_LVALUE_NO_CROAK)
4074 return NULL;
4075
4076 namesv = cv_name(cv, NULL, 0);
4077 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
4078 "subroutine call of &%" SVf " in %s",
4079 SVfARG(namesv), PL_op_desc[type]),
4080 SvUTF8(namesv));
4081 return o;
4082 }
4083 }
4084 /* FALLTHROUGH */
4085 default:
4086 nomod:
4087 if (flags & OP_LVALUE_NO_CROAK) return NULL;
4088 /* grep, foreach, subcalls, refgen */
4089 if (S_potential_mod_type(type))
4090 break;
4091 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
4092 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
4093 ? "do block"
4094 : OP_DESC(o)),
4095 type ? PL_op_desc[type] : "local"));
4096 return o;
4097
4098 case OP_PREINC:
4099 case OP_PREDEC:
4100 case OP_POW:
4101 case OP_MULTIPLY:
4102 case OP_DIVIDE:
4103 case OP_MODULO:
4104 case OP_ADD:
4105 case OP_SUBTRACT:
4106 case OP_CONCAT:
4107 case OP_LEFT_SHIFT:
4108 case OP_RIGHT_SHIFT:
4109 case OP_BIT_AND:
4110 case OP_BIT_XOR:
4111 case OP_BIT_OR:
4112 case OP_I_MULTIPLY:
4113 case OP_I_DIVIDE:
4114 case OP_I_MODULO:
4115 case OP_I_ADD:
4116 case OP_I_SUBTRACT:
4117 if (!(o->op_flags & OPf_STACKED))
4118 goto nomod;
4119 PL_modcount++;
4120 break;
4121
4122 case OP_REPEAT:
4123 if (o->op_flags & OPf_STACKED) {
4124 PL_modcount++;
4125 break;
4126 }
4127 if (!(o->op_private & OPpREPEAT_DOLIST))
4128 goto nomod;
4129 else {
4130 const I32 mods = PL_modcount;
4131 modkids(cBINOPo->op_first, type);
4132 if (type != OP_AASSIGN)
4133 goto nomod;
4134 kid = cBINOPo->op_last;
4135 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
4136 const IV iv = SvIV(kSVOP_sv);
4137 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
4138 PL_modcount =
4139 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
4140 }
4141 else
4142 PL_modcount = RETURN_UNLIMITED_NUMBER;
4143 }
4144 break;
4145
4146 case OP_COND_EXPR:
4147 localize = 1;
4148 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4149 op_lvalue(kid, type);
4150 break;
4151
4152 case OP_RV2AV:
4153 case OP_RV2HV:
4154 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
4155 PL_modcount = RETURN_UNLIMITED_NUMBER;
4156 /* Treat \(@foo) like ordinary list, but still mark it as modi-
4157 fiable since some contexts need to know. */
4158 o->op_flags |= OPf_MOD;
4159 return o;
4160 }
4161 /* FALLTHROUGH */
4162 case OP_RV2GV:
4163 if (scalar_mod_type(o, type))
4164 goto nomod;
4165 ref(cUNOPo->op_first, o->op_type);
4166 /* FALLTHROUGH */
4167 case OP_ASLICE:
4168 case OP_HSLICE:
4169 localize = 1;
4170 /* FALLTHROUGH */
4171 case OP_AASSIGN:
4172 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
4173 if (type == OP_LEAVESUBLV && (
4174 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
4175 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4176 ))
4177 o->op_private |= OPpMAYBE_LVSUB;
4178 /* FALLTHROUGH */
4179 case OP_NEXTSTATE:
4180 case OP_DBSTATE:
4181 PL_modcount = RETURN_UNLIMITED_NUMBER;
4182 break;
4183 case OP_KVHSLICE:
4184 case OP_KVASLICE:
4185 case OP_AKEYS:
4186 if (type == OP_LEAVESUBLV)
4187 o->op_private |= OPpMAYBE_LVSUB;
4188 goto nomod;
4189 case OP_AVHVSWITCH:
4190 if (type == OP_LEAVESUBLV
4191 && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
4192 o->op_private |= OPpMAYBE_LVSUB;
4193 goto nomod;
4194 case OP_AV2ARYLEN:
4195 PL_hints |= HINT_BLOCK_SCOPE;
4196 if (type == OP_LEAVESUBLV)
4197 o->op_private |= OPpMAYBE_LVSUB;
4198 PL_modcount++;
4199 break;
4200 case OP_RV2SV:
4201 ref(cUNOPo->op_first, o->op_type);
4202 localize = 1;
4203 /* FALLTHROUGH */
4204 case OP_GV:
4205 PL_hints |= HINT_BLOCK_SCOPE;
4206 /* FALLTHROUGH */
4207 case OP_SASSIGN:
4208 case OP_ANDASSIGN:
4209 case OP_ORASSIGN:
4210 case OP_DORASSIGN:
4211 PL_modcount++;
4212 break;
4213
4214 case OP_AELEMFAST:
4215 case OP_AELEMFAST_LEX:
4216 localize = -1;
4217 PL_modcount++;
4218 break;
4219
4220 case OP_PADAV:
4221 case OP_PADHV:
4222 PL_modcount = RETURN_UNLIMITED_NUMBER;
4223 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
4224 {
4225 /* Treat \(@foo) like ordinary list, but still mark it as modi-
4226 fiable since some contexts need to know. */
4227 o->op_flags |= OPf_MOD;
4228 return o;
4229 }
4230 if (scalar_mod_type(o, type))
4231 goto nomod;
4232 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4233 && type == OP_LEAVESUBLV)
4234 o->op_private |= OPpMAYBE_LVSUB;
4235 /* FALLTHROUGH */
4236 case OP_PADSV:
4237 PL_modcount++;
4238 if (!type) /* local() */
4239 Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
4240 PNfARG(PAD_COMPNAME(o->op_targ)));
4241 if (!(o->op_private & OPpLVAL_INTRO)
4242 || ( type != OP_SASSIGN && type != OP_AASSIGN
4243 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
4244 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
4245 break;
4246
4247 case OP_PUSHMARK:
4248 localize = 0;
4249 break;
4250
4251 case OP_KEYS:
4252 if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
4253 goto nomod;
4254 goto lvalue_func;
4255 case OP_SUBSTR:
4256 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
4257 goto nomod;
4258 /* FALLTHROUGH */
4259 case OP_POS:
4260 case OP_VEC:
4261 lvalue_func:
4262 if (type == OP_LEAVESUBLV)
4263 o->op_private |= OPpMAYBE_LVSUB;
4264 if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
4265 /* substr and vec */
4266 /* If this op is in merely potential (non-fatal) modifiable
4267 context, then apply OP_ENTERSUB context to
4268 the kid op (to avoid croaking). Other-
4269 wise pass this op’s own type so the correct op is mentioned
4270 in error messages. */
4271 op_lvalue(OpSIBLING(cBINOPo->op_first),
4272 S_potential_mod_type(type)
4273 ? (I32)OP_ENTERSUB
4274 : o->op_type);
4275 }
4276 break;
4277
4278 case OP_AELEM:
4279 case OP_HELEM:
4280 ref(cBINOPo->op_first, o->op_type);
4281 if (type == OP_ENTERSUB &&
4282 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
4283 o->op_private |= OPpLVAL_DEFER;
4284 if (type == OP_LEAVESUBLV)
4285 o->op_private |= OPpMAYBE_LVSUB;
4286 localize = 1;
4287 PL_modcount++;
4288 break;
4289
4290 case OP_LEAVE:
4291 case OP_LEAVELOOP:
4292 o->op_private |= OPpLVALUE;
4293 /* FALLTHROUGH */
4294 case OP_SCOPE:
4295 case OP_ENTER:
4296 case OP_LINESEQ:
4297 localize = 0;
4298 if (o->op_flags & OPf_KIDS)
4299 op_lvalue(cLISTOPo->op_last, type);
4300 break;
4301
4302 case OP_NULL:
4303 localize = 0;
4304 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
4305 goto nomod;
4306 else if (!(o->op_flags & OPf_KIDS))
4307 break;
4308
4309 if (o->op_targ != OP_LIST) {
4310 OP *sib = OpSIBLING(cLISTOPo->op_first);
4311 /* OP_TRANS and OP_TRANSR with argument have a weird optree
4312 * that looks like
4313 *
4314 * null
4315 * arg
4316 * trans
4317 *
4318 * compared with things like OP_MATCH which have the argument
4319 * as a child:
4320 *
4321 * match
4322 * arg
4323 *
4324 * so handle specially to correctly get "Can't modify" croaks etc
4325 */
4326
4327 if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
4328 {
4329 /* this should trigger a "Can't modify transliteration" err */
4330 op_lvalue(sib, type);
4331 }
4332 op_lvalue(cBINOPo->op_first, type);
4333 break;
4334 }
4335 /* FALLTHROUGH */
4336 case OP_LIST:
4337 localize = 0;
4338 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4339 /* elements might be in void context because the list is
4340 in scalar context or because they are attribute sub calls */
4341 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
4342 op_lvalue(kid, type);
4343 break;
4344
4345 case OP_COREARGS:
4346 return o;
4347
4348 case OP_AND:
4349 case OP_OR:
4350 if (type == OP_LEAVESUBLV
4351 || !S_vivifies(cLOGOPo->op_first->op_type))
4352 op_lvalue(cLOGOPo->op_first, type);
4353 if (type == OP_LEAVESUBLV
4354 || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
4355 op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
4356 goto nomod;
4357
4358 case OP_SREFGEN:
4359 if (type == OP_NULL) { /* local */
4360 local_refgen:
4361 if (!FEATURE_MYREF_IS_ENABLED)
4362 Perl_croak(aTHX_ "The experimental declared_refs "
4363 "feature is not enabled");
4364 Perl_ck_warner_d(aTHX_
4365 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4366 "Declaring references is experimental");
4367 op_lvalue(cUNOPo->op_first, OP_NULL);
4368 return o;
4369 }
4370 if (type != OP_AASSIGN && type != OP_SASSIGN
4371 && type != OP_ENTERLOOP)
4372 goto nomod;
4373 /* Don’t bother applying lvalue context to the ex-list. */
4374 kid = cUNOPx(cUNOPo->op_first)->op_first;
4375 assert (!OpHAS_SIBLING(kid));
4376 goto kid_2lvref;
4377 case OP_REFGEN:
4378 if (type == OP_NULL) /* local */
4379 goto local_refgen;
4380 if (type != OP_AASSIGN) goto nomod;
4381 kid = cUNOPo->op_first;
4382 kid_2lvref:
4383 {
4384 const U8 ec = PL_parser ? PL_parser->error_count : 0;
4385 S_lvref(aTHX_ kid, type);
4386 if (!PL_parser || PL_parser->error_count == ec) {
4387 if (!FEATURE_REFALIASING_IS_ENABLED)
4388 Perl_croak(aTHX_
4389 "Experimental aliasing via reference not enabled");
4390 Perl_ck_warner_d(aTHX_
4391 packWARN(WARN_EXPERIMENTAL__REFALIASING),
4392 "Aliasing via reference is experimental");
4393 }
4394 }
4395 if (o->op_type == OP_REFGEN)
4396 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
4397 op_null(o);
4398 return o;
4399
4400 case OP_SPLIT:
4401 if ((o->op_private & OPpSPLIT_ASSIGN)) {
4402 /* This is actually @array = split. */
4403 PL_modcount = RETURN_UNLIMITED_NUMBER;
4404 break;
4405 }
4406 goto nomod;
4407
4408 case OP_SCALAR:
4409 op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
4410 goto nomod;
4411 }
4412
4413 /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
4414 their argument is a filehandle; thus \stat(".") should not set
4415 it. AMS 20011102 */
4416 if (type == OP_REFGEN &&
4417 PL_check[o->op_type] == Perl_ck_ftst)
4418 return o;
4419
4420 if (type != OP_LEAVESUBLV)
4421 o->op_flags |= OPf_MOD;
4422
4423 if (type == OP_AASSIGN || type == OP_SASSIGN)
4424 o->op_flags |= OPf_SPECIAL
4425 |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
4426 else if (!type) { /* local() */
4427 switch (localize) {
4428 case 1:
4429 o->op_private |= OPpLVAL_INTRO;
4430 o->op_flags &= ~OPf_SPECIAL;
4431 PL_hints |= HINT_BLOCK_SCOPE;
4432 break;
4433 case 0:
4434 break;
4435 case -1:
4436 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
4437 "Useless localization of %s", OP_DESC(o));
4438 }
4439 }
4440 else if (type != OP_GREPSTART && type != OP_ENTERSUB
4441 && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
4442 o->op_flags |= OPf_REF;
4443 return o;
4444 }
4445
4446 STATIC bool
S_scalar_mod_type(const OP * o,I32 type)4447 S_scalar_mod_type(const OP *o, I32 type)
4448 {
4449 switch (type) {
4450 case OP_POS:
4451 case OP_SASSIGN:
4452 if (o && o->op_type == OP_RV2GV)
4453 return FALSE;
4454 /* FALLTHROUGH */
4455 case OP_PREINC:
4456 case OP_PREDEC:
4457 case OP_POSTINC:
4458 case OP_POSTDEC:
4459 case OP_I_PREINC:
4460 case OP_I_PREDEC:
4461 case OP_I_POSTINC:
4462 case OP_I_POSTDEC:
4463 case OP_POW:
4464 case OP_MULTIPLY:
4465 case OP_DIVIDE:
4466 case OP_MODULO:
4467 case OP_REPEAT:
4468 case OP_ADD:
4469 case OP_SUBTRACT:
4470 case OP_I_MULTIPLY:
4471 case OP_I_DIVIDE:
4472 case OP_I_MODULO:
4473 case OP_I_ADD:
4474 case OP_I_SUBTRACT:
4475 case OP_LEFT_SHIFT:
4476 case OP_RIGHT_SHIFT:
4477 case OP_BIT_AND:
4478 case OP_BIT_XOR:
4479 case OP_BIT_OR:
4480 case OP_NBIT_AND:
4481 case OP_NBIT_XOR:
4482 case OP_NBIT_OR:
4483 case OP_SBIT_AND:
4484 case OP_SBIT_XOR:
4485 case OP_SBIT_OR:
4486 case OP_CONCAT:
4487 case OP_SUBST:
4488 case OP_TRANS:
4489 case OP_TRANSR:
4490 case OP_READ:
4491 case OP_SYSREAD:
4492 case OP_RECV:
4493 case OP_ANDASSIGN:
4494 case OP_ORASSIGN:
4495 case OP_DORASSIGN:
4496 case OP_VEC:
4497 case OP_SUBSTR:
4498 return TRUE;
4499 default:
4500 return FALSE;
4501 }
4502 }
4503
4504 STATIC bool
S_is_handle_constructor(const OP * o,I32 numargs)4505 S_is_handle_constructor(const OP *o, I32 numargs)
4506 {
4507 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
4508
4509 switch (o->op_type) {
4510 case OP_PIPE_OP:
4511 case OP_SOCKPAIR:
4512 if (numargs == 2)
4513 return TRUE;
4514 /* FALLTHROUGH */
4515 case OP_SYSOPEN:
4516 case OP_OPEN:
4517 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
4518 case OP_SOCKET:
4519 case OP_OPEN_DIR:
4520 case OP_ACCEPT:
4521 if (numargs == 1)
4522 return TRUE;
4523 /* FALLTHROUGH */
4524 default:
4525 return FALSE;
4526 }
4527 }
4528
4529 static OP *
S_refkids(pTHX_ OP * o,I32 type)4530 S_refkids(pTHX_ OP *o, I32 type)
4531 {
4532 if (o && o->op_flags & OPf_KIDS) {
4533 OP *kid;
4534 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4535 ref(kid, type);
4536 }
4537 return o;
4538 }
4539
4540 OP *
Perl_doref(pTHX_ OP * o,I32 type,bool set_op_ref)4541 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
4542 {
4543 dVAR;
4544 OP *kid;
4545
4546 PERL_ARGS_ASSERT_DOREF;
4547
4548 if (PL_parser && PL_parser->error_count)
4549 return o;
4550
4551 switch (o->op_type) {
4552 case OP_ENTERSUB:
4553 if ((type == OP_EXISTS || type == OP_DEFINED) &&
4554 !(o->op_flags & OPf_STACKED)) {
4555 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
4556 assert(cUNOPo->op_first->op_type == OP_NULL);
4557 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
4558 o->op_flags |= OPf_SPECIAL;
4559 }
4560 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
4561 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4562 : type == OP_RV2HV ? OPpDEREF_HV
4563 : OPpDEREF_SV);
4564 o->op_flags |= OPf_MOD;
4565 }
4566
4567 break;
4568
4569 case OP_COND_EXPR:
4570 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4571 doref(kid, type, set_op_ref);
4572 break;
4573 case OP_RV2SV:
4574 if (type == OP_DEFINED)
4575 o->op_flags |= OPf_SPECIAL; /* don't create GV */
4576 doref(cUNOPo->op_first, o->op_type, set_op_ref);
4577 /* FALLTHROUGH */
4578 case OP_PADSV:
4579 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4580 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4581 : type == OP_RV2HV ? OPpDEREF_HV
4582 : OPpDEREF_SV);
4583 o->op_flags |= OPf_MOD;
4584 }
4585 break;
4586
4587 case OP_RV2AV:
4588 case OP_RV2HV:
4589 if (set_op_ref)
4590 o->op_flags |= OPf_REF;
4591 /* FALLTHROUGH */
4592 case OP_RV2GV:
4593 if (type == OP_DEFINED)
4594 o->op_flags |= OPf_SPECIAL; /* don't create GV */
4595 doref(cUNOPo->op_first, o->op_type, set_op_ref);
4596 break;
4597
4598 case OP_PADAV:
4599 case OP_PADHV:
4600 if (set_op_ref)
4601 o->op_flags |= OPf_REF;
4602 break;
4603
4604 case OP_SCALAR:
4605 case OP_NULL:
4606 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
4607 break;
4608 doref(cBINOPo->op_first, type, set_op_ref);
4609 break;
4610 case OP_AELEM:
4611 case OP_HELEM:
4612 doref(cBINOPo->op_first, o->op_type, set_op_ref);
4613 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4614 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4615 : type == OP_RV2HV ? OPpDEREF_HV
4616 : OPpDEREF_SV);
4617 o->op_flags |= OPf_MOD;
4618 }
4619 break;
4620
4621 case OP_SCOPE:
4622 case OP_LEAVE:
4623 set_op_ref = FALSE;
4624 /* FALLTHROUGH */
4625 case OP_ENTER:
4626 case OP_LIST:
4627 if (!(o->op_flags & OPf_KIDS))
4628 break;
4629 doref(cLISTOPo->op_last, type, set_op_ref);
4630 break;
4631 default:
4632 break;
4633 }
4634 return scalar(o);
4635
4636 }
4637
4638 STATIC OP *
S_dup_attrlist(pTHX_ OP * o)4639 S_dup_attrlist(pTHX_ OP *o)
4640 {
4641 OP *rop;
4642
4643 PERL_ARGS_ASSERT_DUP_ATTRLIST;
4644
4645 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
4646 * where the first kid is OP_PUSHMARK and the remaining ones
4647 * are OP_CONST. We need to push the OP_CONST values.
4648 */
4649 if (o->op_type == OP_CONST)
4650 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
4651 else {
4652 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
4653 rop = NULL;
4654 for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
4655 if (o->op_type == OP_CONST)
4656 rop = op_append_elem(OP_LIST, rop,
4657 newSVOP(OP_CONST, o->op_flags,
4658 SvREFCNT_inc_NN(cSVOPo->op_sv)));
4659 }
4660 }
4661 return rop;
4662 }
4663
4664 STATIC void
S_apply_attrs(pTHX_ HV * stash,SV * target,OP * attrs)4665 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
4666 {
4667 PERL_ARGS_ASSERT_APPLY_ATTRS;
4668 {
4669 SV * const stashsv = newSVhek(HvNAME_HEK(stash));
4670
4671 /* fake up C<use attributes $pkg,$rv,@attrs> */
4672
4673 #define ATTRSMODULE "attributes"
4674 #define ATTRSMODULE_PM "attributes.pm"
4675
4676 Perl_load_module(
4677 aTHX_ PERL_LOADMOD_IMPORT_OPS,
4678 newSVpvs(ATTRSMODULE),
4679 NULL,
4680 op_prepend_elem(OP_LIST,
4681 newSVOP(OP_CONST, 0, stashsv),
4682 op_prepend_elem(OP_LIST,
4683 newSVOP(OP_CONST, 0,
4684 newRV(target)),
4685 dup_attrlist(attrs))));
4686 }
4687 }
4688
4689 STATIC void
S_apply_attrs_my(pTHX_ HV * stash,OP * target,OP * attrs,OP ** imopsp)4690 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
4691 {
4692 OP *pack, *imop, *arg;
4693 SV *meth, *stashsv, **svp;
4694
4695 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
4696
4697 if (!attrs)
4698 return;
4699
4700 assert(target->op_type == OP_PADSV ||
4701 target->op_type == OP_PADHV ||
4702 target->op_type == OP_PADAV);
4703
4704 /* Ensure that attributes.pm is loaded. */
4705 /* Don't force the C<use> if we don't need it. */
4706 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
4707 if (svp && *svp != &PL_sv_undef)
4708 NOOP; /* already in %INC */
4709 else
4710 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
4711 newSVpvs(ATTRSMODULE), NULL);
4712
4713 /* Need package name for method call. */
4714 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
4715
4716 /* Build up the real arg-list. */
4717 stashsv = newSVhek(HvNAME_HEK(stash));
4718
4719 arg = newOP(OP_PADSV, 0);
4720 arg->op_targ = target->op_targ;
4721 arg = op_prepend_elem(OP_LIST,
4722 newSVOP(OP_CONST, 0, stashsv),
4723 op_prepend_elem(OP_LIST,
4724 newUNOP(OP_REFGEN, 0,
4725 arg),
4726 dup_attrlist(attrs)));
4727
4728 /* Fake up a method call to import */
4729 meth = newSVpvs_share("import");
4730 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
4731 op_append_elem(OP_LIST,
4732 op_prepend_elem(OP_LIST, pack, arg),
4733 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
4734
4735 /* Combine the ops. */
4736 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
4737 }
4738
4739 /*
4740 =notfor apidoc apply_attrs_string
4741
4742 Attempts to apply a list of attributes specified by the C<attrstr> and
4743 C<len> arguments to the subroutine identified by the C<cv> argument which
4744 is expected to be associated with the package identified by the C<stashpv>
4745 argument (see L<attributes>). It gets this wrong, though, in that it
4746 does not correctly identify the boundaries of the individual attribute
4747 specifications within C<attrstr>. This is not really intended for the
4748 public API, but has to be listed here for systems such as AIX which
4749 need an explicit export list for symbols. (It's called from XS code
4750 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
4751 to respect attribute syntax properly would be welcome.
4752
4753 =cut
4754 */
4755
4756 void
Perl_apply_attrs_string(pTHX_ const char * stashpv,CV * cv,const char * attrstr,STRLEN len)4757 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
4758 const char *attrstr, STRLEN len)
4759 {
4760 OP *attrs = NULL;
4761
4762 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
4763
4764 if (!len) {
4765 len = strlen(attrstr);
4766 }
4767
4768 while (len) {
4769 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
4770 if (len) {
4771 const char * const sstr = attrstr;
4772 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
4773 attrs = op_append_elem(OP_LIST, attrs,
4774 newSVOP(OP_CONST, 0,
4775 newSVpvn(sstr, attrstr-sstr)));
4776 }
4777 }
4778
4779 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
4780 newSVpvs(ATTRSMODULE),
4781 NULL, op_prepend_elem(OP_LIST,
4782 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
4783 op_prepend_elem(OP_LIST,
4784 newSVOP(OP_CONST, 0,
4785 newRV(MUTABLE_SV(cv))),
4786 attrs)));
4787 }
4788
4789 STATIC void
S_move_proto_attr(pTHX_ OP ** proto,OP ** attrs,const GV * name,bool curstash)4790 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
4791 bool curstash)
4792 {
4793 OP *new_proto = NULL;
4794 STRLEN pvlen;
4795 char *pv;
4796 OP *o;
4797
4798 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
4799
4800 if (!*attrs)
4801 return;
4802
4803 o = *attrs;
4804 if (o->op_type == OP_CONST) {
4805 pv = SvPV(cSVOPo_sv, pvlen);
4806 if (memBEGINs(pv, pvlen, "prototype(")) {
4807 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
4808 SV ** const tmpo = cSVOPx_svp(o);
4809 SvREFCNT_dec(cSVOPo_sv);
4810 *tmpo = tmpsv;
4811 new_proto = o;
4812 *attrs = NULL;
4813 }
4814 } else if (o->op_type == OP_LIST) {
4815 OP * lasto;
4816 assert(o->op_flags & OPf_KIDS);
4817 lasto = cLISTOPo->op_first;
4818 assert(lasto->op_type == OP_PUSHMARK);
4819 for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
4820 if (o->op_type == OP_CONST) {
4821 pv = SvPV(cSVOPo_sv, pvlen);
4822 if (memBEGINs(pv, pvlen, "prototype(")) {
4823 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
4824 SV ** const tmpo = cSVOPx_svp(o);
4825 SvREFCNT_dec(cSVOPo_sv);
4826 *tmpo = tmpsv;
4827 if (new_proto && ckWARN(WARN_MISC)) {
4828 STRLEN new_len;
4829 const char * newp = SvPV(cSVOPo_sv, new_len);
4830 Perl_warner(aTHX_ packWARN(WARN_MISC),
4831 "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
4832 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
4833 op_free(new_proto);
4834 }
4835 else if (new_proto)
4836 op_free(new_proto);
4837 new_proto = o;
4838 /* excise new_proto from the list */
4839 op_sibling_splice(*attrs, lasto, 1, NULL);
4840 o = lasto;
4841 continue;
4842 }
4843 }
4844 lasto = o;
4845 }
4846 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
4847 would get pulled in with no real need */
4848 if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
4849 op_free(*attrs);
4850 *attrs = NULL;
4851 }
4852 }
4853
4854 if (new_proto) {
4855 SV *svname;
4856 if (isGV(name)) {
4857 svname = sv_newmortal();
4858 gv_efullname3(svname, name, NULL);
4859 }
4860 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
4861 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
4862 else
4863 svname = (SV *)name;
4864 if (ckWARN(WARN_ILLEGALPROTO))
4865 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
4866 curstash);
4867 if (*proto && ckWARN(WARN_PROTOTYPE)) {
4868 STRLEN old_len, new_len;
4869 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
4870 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
4871
4872 if (curstash && svname == (SV *)name
4873 && !memchr(SvPVX(svname), ':', SvCUR(svname))) {
4874 svname = sv_2mortal(newSVsv(PL_curstname));
4875 sv_catpvs(svname, "::");
4876 sv_catsv(svname, (SV *)name);
4877 }
4878
4879 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
4880 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
4881 " in %" SVf,
4882 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
4883 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
4884 SVfARG(svname));
4885 }
4886 if (*proto)
4887 op_free(*proto);
4888 *proto = new_proto;
4889 }
4890 }
4891
4892 static void
S_cant_declare(pTHX_ OP * o)4893 S_cant_declare(pTHX_ OP *o)
4894 {
4895 if (o->op_type == OP_NULL
4896 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
4897 o = cUNOPo->op_first;
4898 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
4899 o->op_type == OP_NULL
4900 && o->op_flags & OPf_SPECIAL
4901 ? "do block"
4902 : OP_DESC(o),
4903 PL_parser->in_my == KEY_our ? "our" :
4904 PL_parser->in_my == KEY_state ? "state" :
4905 "my"));
4906 }
4907
4908 STATIC OP *
S_my_kid(pTHX_ OP * o,OP * attrs,OP ** imopsp)4909 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
4910 {
4911 I32 type;
4912 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
4913
4914 PERL_ARGS_ASSERT_MY_KID;
4915
4916 if (!o || (PL_parser && PL_parser->error_count))
4917 return o;
4918
4919 type = o->op_type;
4920
4921 if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
4922 OP *kid;
4923 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4924 my_kid(kid, attrs, imopsp);
4925 return o;
4926 } else if (type == OP_UNDEF || type == OP_STUB) {
4927 return o;
4928 } else if (type == OP_RV2SV || /* "our" declaration */
4929 type == OP_RV2AV ||
4930 type == OP_RV2HV) {
4931 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
4932 S_cant_declare(aTHX_ o);
4933 } else if (attrs) {
4934 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
4935 assert(PL_parser);
4936 PL_parser->in_my = FALSE;
4937 PL_parser->in_my_stash = NULL;
4938 apply_attrs(GvSTASH(gv),
4939 (type == OP_RV2SV ? GvSVn(gv) :
4940 type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
4941 type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
4942 attrs);
4943 }
4944 o->op_private |= OPpOUR_INTRO;
4945 return o;
4946 }
4947 else if (type == OP_REFGEN || type == OP_SREFGEN) {
4948 if (!FEATURE_MYREF_IS_ENABLED)
4949 Perl_croak(aTHX_ "The experimental declared_refs "
4950 "feature is not enabled");
4951 Perl_ck_warner_d(aTHX_
4952 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4953 "Declaring references is experimental");
4954 /* Kid is a nulled OP_LIST, handled above. */
4955 my_kid(cUNOPo->op_first, attrs, imopsp);
4956 return o;
4957 }
4958 else if (type != OP_PADSV &&
4959 type != OP_PADAV &&
4960 type != OP_PADHV &&
4961 type != OP_PUSHMARK)
4962 {
4963 S_cant_declare(aTHX_ o);
4964 return o;
4965 }
4966 else if (attrs && type != OP_PUSHMARK) {
4967 HV *stash;
4968
4969 assert(PL_parser);
4970 PL_parser->in_my = FALSE;
4971 PL_parser->in_my_stash = NULL;
4972
4973 /* check for C<my Dog $spot> when deciding package */
4974 stash = PAD_COMPNAME_TYPE(o->op_targ);
4975 if (!stash)
4976 stash = PL_curstash;
4977 apply_attrs_my(stash, o, attrs, imopsp);
4978 }
4979 o->op_flags |= OPf_MOD;
4980 o->op_private |= OPpLVAL_INTRO;
4981 if (stately)
4982 o->op_private |= OPpPAD_STATE;
4983 return o;
4984 }
4985
4986 OP *
Perl_my_attrs(pTHX_ OP * o,OP * attrs)4987 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
4988 {
4989 OP *rops;
4990 int maybe_scalar = 0;
4991
4992 PERL_ARGS_ASSERT_MY_ATTRS;
4993
4994 /* [perl #17376]: this appears to be premature, and results in code such as
4995 C< our(%x); > executing in list mode rather than void mode */
4996 #if 0
4997 if (o->op_flags & OPf_PARENS)
4998 list(o);
4999 else
5000 maybe_scalar = 1;
5001 #else
5002 maybe_scalar = 1;
5003 #endif
5004 if (attrs)
5005 SAVEFREEOP(attrs);
5006 rops = NULL;
5007 o = my_kid(o, attrs, &rops);
5008 if (rops) {
5009 if (maybe_scalar && o->op_type == OP_PADSV) {
5010 o = scalar(op_append_list(OP_LIST, rops, o));
5011 o->op_private |= OPpLVAL_INTRO;
5012 }
5013 else {
5014 /* The listop in rops might have a pushmark at the beginning,
5015 which will mess up list assignment. */
5016 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
5017 if (rops->op_type == OP_LIST &&
5018 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
5019 {
5020 OP * const pushmark = lrops->op_first;
5021 /* excise pushmark */
5022 op_sibling_splice(rops, NULL, 1, NULL);
5023 op_free(pushmark);
5024 }
5025 o = op_append_list(OP_LIST, o, rops);
5026 }
5027 }
5028 PL_parser->in_my = FALSE;
5029 PL_parser->in_my_stash = NULL;
5030 return o;
5031 }
5032
5033 OP *
Perl_sawparens(pTHX_ OP * o)5034 Perl_sawparens(pTHX_ OP *o)
5035 {
5036 PERL_UNUSED_CONTEXT;
5037 if (o)
5038 o->op_flags |= OPf_PARENS;
5039 return o;
5040 }
5041
5042 OP *
Perl_bind_match(pTHX_ I32 type,OP * left,OP * right)5043 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
5044 {
5045 OP *o;
5046 bool ismatchop = 0;
5047 const OPCODE ltype = left->op_type;
5048 const OPCODE rtype = right->op_type;
5049
5050 PERL_ARGS_ASSERT_BIND_MATCH;
5051
5052 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
5053 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
5054 {
5055 const char * const desc
5056 = PL_op_desc[(
5057 rtype == OP_SUBST || rtype == OP_TRANS
5058 || rtype == OP_TRANSR
5059 )
5060 ? (int)rtype : OP_MATCH];
5061 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
5062 SV * const name =
5063 S_op_varname(aTHX_ left);
5064 if (name)
5065 Perl_warner(aTHX_ packWARN(WARN_MISC),
5066 "Applying %s to %" SVf " will act on scalar(%" SVf ")",
5067 desc, SVfARG(name), SVfARG(name));
5068 else {
5069 const char * const sample = (isary
5070 ? "@array" : "%hash");
5071 Perl_warner(aTHX_ packWARN(WARN_MISC),
5072 "Applying %s to %s will act on scalar(%s)",
5073 desc, sample, sample);
5074 }
5075 }
5076
5077 if (rtype == OP_CONST &&
5078 cSVOPx(right)->op_private & OPpCONST_BARE &&
5079 cSVOPx(right)->op_private & OPpCONST_STRICT)
5080 {
5081 no_bareword_allowed(right);
5082 }
5083
5084 /* !~ doesn't make sense with /r, so error on it for now */
5085 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
5086 type == OP_NOT)
5087 /* diag_listed_as: Using !~ with %s doesn't make sense */
5088 yyerror("Using !~ with s///r doesn't make sense");
5089 if (rtype == OP_TRANSR && type == OP_NOT)
5090 /* diag_listed_as: Using !~ with %s doesn't make sense */
5091 yyerror("Using !~ with tr///r doesn't make sense");
5092
5093 ismatchop = (rtype == OP_MATCH ||
5094 rtype == OP_SUBST ||
5095 rtype == OP_TRANS || rtype == OP_TRANSR)
5096 && !(right->op_flags & OPf_SPECIAL);
5097 if (ismatchop && right->op_private & OPpTARGET_MY) {
5098 right->op_targ = 0;
5099 right->op_private &= ~OPpTARGET_MY;
5100 }
5101 if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
5102 if (left->op_type == OP_PADSV
5103 && !(left->op_private & OPpLVAL_INTRO))
5104 {
5105 right->op_targ = left->op_targ;
5106 op_free(left);
5107 o = right;
5108 }
5109 else {
5110 right->op_flags |= OPf_STACKED;
5111 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
5112 ! (rtype == OP_TRANS &&
5113 right->op_private & OPpTRANS_IDENTICAL) &&
5114 ! (rtype == OP_SUBST &&
5115 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
5116 left = op_lvalue(left, rtype);
5117 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
5118 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
5119 else
5120 o = op_prepend_elem(rtype, scalar(left), right);
5121 }
5122 if (type == OP_NOT)
5123 return newUNOP(OP_NOT, 0, scalar(o));
5124 return o;
5125 }
5126 else
5127 return bind_match(type, left,
5128 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
5129 }
5130
5131 OP *
Perl_invert(pTHX_ OP * o)5132 Perl_invert(pTHX_ OP *o)
5133 {
5134 if (!o)
5135 return NULL;
5136 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
5137 }
5138
5139 /*
5140 =for apidoc Amx|OP *|op_scope|OP *o
5141
5142 Wraps up an op tree with some additional ops so that at runtime a dynamic
5143 scope will be created. The original ops run in the new dynamic scope,
5144 and then, provided that they exit normally, the scope will be unwound.
5145 The additional ops used to create and unwind the dynamic scope will
5146 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
5147 instead if the ops are simple enough to not need the full dynamic scope
5148 structure.
5149
5150 =cut
5151 */
5152
5153 OP *
Perl_op_scope(pTHX_ OP * o)5154 Perl_op_scope(pTHX_ OP *o)
5155 {
5156 dVAR;
5157 if (o) {
5158 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
5159 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
5160 OpTYPE_set(o, OP_LEAVE);
5161 }
5162 else if (o->op_type == OP_LINESEQ) {
5163 OP *kid;
5164 OpTYPE_set(o, OP_SCOPE);
5165 kid = ((LISTOP*)o)->op_first;
5166 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
5167 op_null(kid);
5168
5169 /* The following deals with things like 'do {1 for 1}' */
5170 kid = OpSIBLING(kid);
5171 if (kid &&
5172 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
5173 op_null(kid);
5174 }
5175 }
5176 else
5177 o = newLISTOP(OP_SCOPE, 0, o, NULL);
5178 }
5179 return o;
5180 }
5181
5182 OP *
Perl_op_unscope(pTHX_ OP * o)5183 Perl_op_unscope(pTHX_ OP *o)
5184 {
5185 if (o && o->op_type == OP_LINESEQ) {
5186 OP *kid = cLISTOPo->op_first;
5187 for(; kid; kid = OpSIBLING(kid))
5188 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
5189 op_null(kid);
5190 }
5191 return o;
5192 }
5193
5194 /*
5195 =for apidoc Am|int|block_start|int full
5196
5197 Handles compile-time scope entry.
5198 Arranges for hints to be restored on block
5199 exit and also handles pad sequence numbers to make lexical variables scope
5200 right. Returns a savestack index for use with C<block_end>.
5201
5202 =cut
5203 */
5204
5205 int
Perl_block_start(pTHX_ int full)5206 Perl_block_start(pTHX_ int full)
5207 {
5208 const int retval = PL_savestack_ix;
5209
5210 PL_compiling.cop_seq = PL_cop_seqmax;
5211 COP_SEQMAX_INC;
5212 pad_block_start(full);
5213 SAVEHINTS();
5214 PL_hints &= ~HINT_BLOCK_SCOPE;
5215 SAVECOMPILEWARNINGS();
5216 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
5217 SAVEI32(PL_compiling.cop_seq);
5218 PL_compiling.cop_seq = 0;
5219
5220 CALL_BLOCK_HOOKS(bhk_start, full);
5221
5222 return retval;
5223 }
5224
5225 /*
5226 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
5227
5228 Handles compile-time scope exit. C<floor>
5229 is the savestack index returned by
5230 C<block_start>, and C<seq> is the body of the block. Returns the block,
5231 possibly modified.
5232
5233 =cut
5234 */
5235
5236 OP*
Perl_block_end(pTHX_ I32 floor,OP * seq)5237 Perl_block_end(pTHX_ I32 floor, OP *seq)
5238 {
5239 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
5240 OP* retval = scalarseq(seq);
5241 OP *o;
5242
5243 /* XXX Is the null PL_parser check necessary here? */
5244 assert(PL_parser); /* Let’s find out under debugging builds. */
5245 if (PL_parser && PL_parser->parsed_sub) {
5246 o = newSTATEOP(0, NULL, NULL);
5247 op_null(o);
5248 retval = op_append_elem(OP_LINESEQ, retval, o);
5249 }
5250
5251 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
5252
5253 LEAVE_SCOPE(floor);
5254 if (needblockscope)
5255 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
5256 o = pad_leavemy();
5257
5258 if (o) {
5259 /* pad_leavemy has created a sequence of introcv ops for all my
5260 subs declared in the block. We have to replicate that list with
5261 clonecv ops, to deal with this situation:
5262
5263 sub {
5264 my sub s1;
5265 my sub s2;
5266 sub s1 { state sub foo { \&s2 } }
5267 }->()
5268
5269 Originally, I was going to have introcv clone the CV and turn
5270 off the stale flag. Since &s1 is declared before &s2, the
5271 introcv op for &s1 is executed (on sub entry) before the one for
5272 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
5273 cloned, since it is a state sub) closes over &s2 and expects
5274 to see it in its outer CV’s pad. If the introcv op clones &s1,
5275 then &s2 is still marked stale. Since &s1 is not active, and
5276 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
5277 ble will not stay shared’ warning. Because it is the same stub
5278 that will be used when the introcv op for &s2 is executed, clos-
5279 ing over it is safe. Hence, we have to turn off the stale flag
5280 on all lexical subs in the block before we clone any of them.
5281 Hence, having introcv clone the sub cannot work. So we create a
5282 list of ops like this:
5283
5284 lineseq
5285 |
5286 +-- introcv
5287 |
5288 +-- introcv
5289 |
5290 +-- introcv
5291 |
5292 .
5293 .
5294 .
5295 |
5296 +-- clonecv
5297 |
5298 +-- clonecv
5299 |
5300 +-- clonecv
5301 |
5302 .
5303 .
5304 .
5305 */
5306 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
5307 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
5308 for (;; kid = OpSIBLING(kid)) {
5309 OP *newkid = newOP(OP_CLONECV, 0);
5310 newkid->op_targ = kid->op_targ;
5311 o = op_append_elem(OP_LINESEQ, o, newkid);
5312 if (kid == last) break;
5313 }
5314 retval = op_prepend_elem(OP_LINESEQ, o, retval);
5315 }
5316
5317 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
5318
5319 return retval;
5320 }
5321
5322 /*
5323 =head1 Compile-time scope hooks
5324
5325 =for apidoc Aox||blockhook_register
5326
5327 Register a set of hooks to be called when the Perl lexical scope changes
5328 at compile time. See L<perlguts/"Compile-time scope hooks">.
5329
5330 =cut
5331 */
5332
5333 void
Perl_blockhook_register(pTHX_ BHK * hk)5334 Perl_blockhook_register(pTHX_ BHK *hk)
5335 {
5336 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
5337
5338 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
5339 }
5340
5341 void
Perl_newPROG(pTHX_ OP * o)5342 Perl_newPROG(pTHX_ OP *o)
5343 {
5344 OP *start;
5345
5346 PERL_ARGS_ASSERT_NEWPROG;
5347
5348 if (PL_in_eval) {
5349 PERL_CONTEXT *cx;
5350 I32 i;
5351 if (PL_eval_root)
5352 return;
5353 PL_eval_root = newUNOP(OP_LEAVEEVAL,
5354 ((PL_in_eval & EVAL_KEEPERR)
5355 ? OPf_SPECIAL : 0), o);
5356
5357 cx = CX_CUR();
5358 assert(CxTYPE(cx) == CXt_EVAL);
5359
5360 if ((cx->blk_gimme & G_WANT) == G_VOID)
5361 scalarvoid(PL_eval_root);
5362 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
5363 list(PL_eval_root);
5364 else
5365 scalar(PL_eval_root);
5366
5367 start = op_linklist(PL_eval_root);
5368 PL_eval_root->op_next = 0;
5369 i = PL_savestack_ix;
5370 SAVEFREEOP(o);
5371 ENTER;
5372 S_process_optree(aTHX_ NULL, PL_eval_root, start);
5373 LEAVE;
5374 PL_savestack_ix = i;
5375 }
5376 else {
5377 if (o->op_type == OP_STUB) {
5378 /* This block is entered if nothing is compiled for the main
5379 program. This will be the case for an genuinely empty main
5380 program, or one which only has BEGIN blocks etc, so already
5381 run and freed.
5382
5383 Historically (5.000) the guard above was !o. However, commit
5384 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
5385 c71fccf11fde0068, changed perly.y so that newPROG() is now
5386 called with the output of block_end(), which returns a new
5387 OP_STUB for the case of an empty optree. ByteLoader (and
5388 maybe other things) also take this path, because they set up
5389 PL_main_start and PL_main_root directly, without generating an
5390 optree.
5391
5392 If the parsing the main program aborts (due to parse errors,
5393 or due to BEGIN or similar calling exit), then newPROG()
5394 isn't even called, and hence this code path and its cleanups
5395 are skipped. This shouldn't make a make a difference:
5396 * a non-zero return from perl_parse is a failure, and
5397 perl_destruct() should be called immediately.
5398 * however, if exit(0) is called during the parse, then
5399 perl_parse() returns 0, and perl_run() is called. As
5400 PL_main_start will be NULL, perl_run() will return
5401 promptly, and the exit code will remain 0.
5402 */
5403
5404 PL_comppad_name = 0;
5405 PL_compcv = 0;
5406 S_op_destroy(aTHX_ o);
5407 return;
5408 }
5409 PL_main_root = op_scope(sawparens(scalarvoid(o)));
5410 PL_curcop = &PL_compiling;
5411 start = LINKLIST(PL_main_root);
5412 PL_main_root->op_next = 0;
5413 S_process_optree(aTHX_ NULL, PL_main_root, start);
5414 if (!PL_parser->error_count)
5415 /* on error, leave CV slabbed so that ops left lying around
5416 * will eb cleaned up. Else unslab */
5417 cv_forget_slab(PL_compcv);
5418 PL_compcv = 0;
5419
5420 /* Register with debugger */
5421 if (PERLDB_INTER) {
5422 CV * const cv = get_cvs("DB::postponed", 0);
5423 if (cv) {
5424 dSP;
5425 PUSHMARK(SP);
5426 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
5427 PUTBACK;
5428 call_sv(MUTABLE_SV(cv), G_DISCARD);
5429 }
5430 }
5431 }
5432 }
5433
5434 OP *
Perl_localize(pTHX_ OP * o,I32 lex)5435 Perl_localize(pTHX_ OP *o, I32 lex)
5436 {
5437 PERL_ARGS_ASSERT_LOCALIZE;
5438
5439 if (o->op_flags & OPf_PARENS)
5440 /* [perl #17376]: this appears to be premature, and results in code such as
5441 C< our(%x); > executing in list mode rather than void mode */
5442 #if 0
5443 list(o);
5444 #else
5445 NOOP;
5446 #endif
5447 else {
5448 if ( PL_parser->bufptr > PL_parser->oldbufptr
5449 && PL_parser->bufptr[-1] == ','
5450 && ckWARN(WARN_PARENTHESIS))
5451 {
5452 char *s = PL_parser->bufptr;
5453 bool sigil = FALSE;
5454
5455 /* some heuristics to detect a potential error */
5456 while (*s && (strchr(", \t\n", *s)))
5457 s++;
5458
5459 while (1) {
5460 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
5461 && *++s
5462 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
5463 s++;
5464 sigil = TRUE;
5465 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
5466 s++;
5467 while (*s && (strchr(", \t\n", *s)))
5468 s++;
5469 }
5470 else
5471 break;
5472 }
5473 if (sigil && (*s == ';' || *s == '=')) {
5474 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
5475 "Parentheses missing around \"%s\" list",
5476 lex
5477 ? (PL_parser->in_my == KEY_our
5478 ? "our"
5479 : PL_parser->in_my == KEY_state
5480 ? "state"
5481 : "my")
5482 : "local");
5483 }
5484 }
5485 }
5486 if (lex)
5487 o = my(o);
5488 else
5489 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
5490 PL_parser->in_my = FALSE;
5491 PL_parser->in_my_stash = NULL;
5492 return o;
5493 }
5494
5495 OP *
Perl_jmaybe(pTHX_ OP * o)5496 Perl_jmaybe(pTHX_ OP *o)
5497 {
5498 PERL_ARGS_ASSERT_JMAYBE;
5499
5500 if (o->op_type == OP_LIST) {
5501 OP * const o2
5502 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
5503 o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
5504 }
5505 return o;
5506 }
5507
5508 PERL_STATIC_INLINE OP *
S_op_std_init(pTHX_ OP * o)5509 S_op_std_init(pTHX_ OP *o)
5510 {
5511 I32 type = o->op_type;
5512
5513 PERL_ARGS_ASSERT_OP_STD_INIT;
5514
5515 if (PL_opargs[type] & OA_RETSCALAR)
5516 scalar(o);
5517 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
5518 o->op_targ = pad_alloc(type, SVs_PADTMP);
5519
5520 return o;
5521 }
5522
5523 PERL_STATIC_INLINE OP *
S_op_integerize(pTHX_ OP * o)5524 S_op_integerize(pTHX_ OP *o)
5525 {
5526 I32 type = o->op_type;
5527
5528 PERL_ARGS_ASSERT_OP_INTEGERIZE;
5529
5530 /* integerize op. */
5531 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
5532 {
5533 dVAR;
5534 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
5535 }
5536
5537 if (type == OP_NEGATE)
5538 /* XXX might want a ck_negate() for this */
5539 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
5540
5541 return o;
5542 }
5543
5544 /* This function exists solely to provide a scope to limit
5545 setjmp/longjmp() messing with auto variables.
5546 */
5547 PERL_STATIC_INLINE int
S_fold_constants_eval(pTHX)5548 S_fold_constants_eval(pTHX) {
5549 int ret = 0;
5550 dJMPENV;
5551
5552 JMPENV_PUSH(ret);
5553
5554 if (ret == 0) {
5555 CALLRUNOPS(aTHX);
5556 }
5557
5558 JMPENV_POP;
5559
5560 return ret;
5561 }
5562
5563 static OP *
S_fold_constants(pTHX_ OP * const o)5564 S_fold_constants(pTHX_ OP *const o)
5565 {
5566 dVAR;
5567 OP *curop;
5568 OP *newop;
5569 I32 type = o->op_type;
5570 bool is_stringify;
5571 SV *sv = NULL;
5572 int ret = 0;
5573 OP *old_next;
5574 SV * const oldwarnhook = PL_warnhook;
5575 SV * const olddiehook = PL_diehook;
5576 COP not_compiling;
5577 U8 oldwarn = PL_dowarn;
5578 I32 old_cxix;
5579
5580 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
5581
5582 if (!(PL_opargs[type] & OA_FOLDCONST))
5583 goto nope;
5584
5585 switch (type) {
5586 case OP_UCFIRST:
5587 case OP_LCFIRST:
5588 case OP_UC:
5589 case OP_LC:
5590 case OP_FC:
5591 #ifdef USE_LOCALE_CTYPE
5592 if (IN_LC_COMPILETIME(LC_CTYPE))
5593 goto nope;
5594 #endif
5595 break;
5596 case OP_SLT:
5597 case OP_SGT:
5598 case OP_SLE:
5599 case OP_SGE:
5600 case OP_SCMP:
5601 #ifdef USE_LOCALE_COLLATE
5602 if (IN_LC_COMPILETIME(LC_COLLATE))
5603 goto nope;
5604 #endif
5605 break;
5606 case OP_SPRINTF:
5607 /* XXX what about the numeric ops? */
5608 #ifdef USE_LOCALE_NUMERIC
5609 if (IN_LC_COMPILETIME(LC_NUMERIC))
5610 goto nope;
5611 #endif
5612 break;
5613 case OP_PACK:
5614 if (!OpHAS_SIBLING(cLISTOPo->op_first)
5615 || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
5616 goto nope;
5617 {
5618 SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
5619 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
5620 {
5621 const char *s = SvPVX_const(sv);
5622 while (s < SvEND(sv)) {
5623 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
5624 s++;
5625 }
5626 }
5627 }
5628 break;
5629 case OP_REPEAT:
5630 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
5631 break;
5632 case OP_SREFGEN:
5633 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
5634 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
5635 goto nope;
5636 }
5637
5638 if (PL_parser && PL_parser->error_count)
5639 goto nope; /* Don't try to run w/ errors */
5640
5641 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
5642 switch (curop->op_type) {
5643 case OP_CONST:
5644 if ( (curop->op_private & OPpCONST_BARE)
5645 && (curop->op_private & OPpCONST_STRICT)) {
5646 no_bareword_allowed(curop);
5647 goto nope;
5648 }
5649 /* FALLTHROUGH */
5650 case OP_LIST:
5651 case OP_SCALAR:
5652 case OP_NULL:
5653 case OP_PUSHMARK:
5654 /* Foldable; move to next op in list */
5655 break;
5656
5657 default:
5658 /* No other op types are considered foldable */
5659 goto nope;
5660 }
5661 }
5662
5663 curop = LINKLIST(o);
5664 old_next = o->op_next;
5665 o->op_next = 0;
5666 PL_op = curop;
5667
5668 old_cxix = cxstack_ix;
5669 create_eval_scope(NULL, G_FAKINGEVAL);
5670
5671 /* Verify that we don't need to save it: */
5672 assert(PL_curcop == &PL_compiling);
5673 StructCopy(&PL_compiling, ¬_compiling, COP);
5674 PL_curcop = ¬_compiling;
5675 /* The above ensures that we run with all the correct hints of the
5676 currently compiling COP, but that IN_PERL_RUNTIME is true. */
5677 assert(IN_PERL_RUNTIME);
5678 PL_warnhook = PERL_WARNHOOK_FATAL;
5679 PL_diehook = NULL;
5680
5681 /* Effective $^W=1. */
5682 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5683 PL_dowarn |= G_WARN_ON;
5684
5685 ret = S_fold_constants_eval(aTHX);
5686
5687 switch (ret) {
5688 case 0:
5689 sv = *(PL_stack_sp--);
5690 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
5691 pad_swipe(o->op_targ, FALSE);
5692 }
5693 else if (SvTEMP(sv)) { /* grab mortal temp? */
5694 SvREFCNT_inc_simple_void(sv);
5695 SvTEMP_off(sv);
5696 }
5697 else { assert(SvIMMORTAL(sv)); }
5698 break;
5699 case 3:
5700 /* Something tried to die. Abandon constant folding. */
5701 /* Pretend the error never happened. */
5702 CLEAR_ERRSV();
5703 o->op_next = old_next;
5704 break;
5705 default:
5706 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
5707 PL_warnhook = oldwarnhook;
5708 PL_diehook = olddiehook;
5709 /* XXX note that this croak may fail as we've already blown away
5710 * the stack - eg any nested evals */
5711 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
5712 }
5713 PL_dowarn = oldwarn;
5714 PL_warnhook = oldwarnhook;
5715 PL_diehook = olddiehook;
5716 PL_curcop = &PL_compiling;
5717
5718 /* if we croaked, depending on how we croaked the eval scope
5719 * may or may not have already been popped */
5720 if (cxstack_ix > old_cxix) {
5721 assert(cxstack_ix == old_cxix + 1);
5722 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5723 delete_eval_scope();
5724 }
5725 if (ret)
5726 goto nope;
5727
5728 /* OP_STRINGIFY and constant folding are used to implement qq.
5729 Here the constant folding is an implementation detail that we
5730 want to hide. If the stringify op is itself already marked
5731 folded, however, then it is actually a folded join. */
5732 is_stringify = type == OP_STRINGIFY && !o->op_folded;
5733 op_free(o);
5734 assert(sv);
5735 if (is_stringify)
5736 SvPADTMP_off(sv);
5737 else if (!SvIMMORTAL(sv)) {
5738 SvPADTMP_on(sv);
5739 SvREADONLY_on(sv);
5740 }
5741 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
5742 if (!is_stringify) newop->op_folded = 1;
5743 return newop;
5744
5745 nope:
5746 return o;
5747 }
5748
5749 static OP *
S_gen_constant_list(pTHX_ OP * o)5750 S_gen_constant_list(pTHX_ OP *o)
5751 {
5752 dVAR;
5753 OP *curop, *old_next;
5754 SV * const oldwarnhook = PL_warnhook;
5755 SV * const olddiehook = PL_diehook;
5756 COP *old_curcop;
5757 U8 oldwarn = PL_dowarn;
5758 SV **svp;
5759 AV *av;
5760 I32 old_cxix;
5761 COP not_compiling;
5762 int ret = 0;
5763 dJMPENV;
5764 bool op_was_null;
5765
5766 list(o);
5767 if (PL_parser && PL_parser->error_count)
5768 return o; /* Don't attempt to run with errors */
5769
5770 curop = LINKLIST(o);
5771 old_next = o->op_next;
5772 o->op_next = 0;
5773 op_was_null = o->op_type == OP_NULL;
5774 if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
5775 o->op_type = OP_CUSTOM;
5776 CALL_PEEP(curop);
5777 if (op_was_null)
5778 o->op_type = OP_NULL;
5779 S_prune_chain_head(&curop);
5780 PL_op = curop;
5781
5782 old_cxix = cxstack_ix;
5783 create_eval_scope(NULL, G_FAKINGEVAL);
5784
5785 old_curcop = PL_curcop;
5786 StructCopy(old_curcop, ¬_compiling, COP);
5787 PL_curcop = ¬_compiling;
5788 /* The above ensures that we run with all the correct hints of the
5789 current COP, but that IN_PERL_RUNTIME is true. */
5790 assert(IN_PERL_RUNTIME);
5791 PL_warnhook = PERL_WARNHOOK_FATAL;
5792 PL_diehook = NULL;
5793 JMPENV_PUSH(ret);
5794
5795 /* Effective $^W=1. */
5796 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5797 PL_dowarn |= G_WARN_ON;
5798
5799 switch (ret) {
5800 case 0:
5801 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
5802 PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
5803 #endif
5804 Perl_pp_pushmark(aTHX);
5805 CALLRUNOPS(aTHX);
5806 PL_op = curop;
5807 assert (!(curop->op_flags & OPf_SPECIAL));
5808 assert(curop->op_type == OP_RANGE);
5809 Perl_pp_anonlist(aTHX);
5810 break;
5811 case 3:
5812 CLEAR_ERRSV();
5813 o->op_next = old_next;
5814 break;
5815 default:
5816 JMPENV_POP;
5817 PL_warnhook = oldwarnhook;
5818 PL_diehook = olddiehook;
5819 Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
5820 ret);
5821 }
5822
5823 JMPENV_POP;
5824 PL_dowarn = oldwarn;
5825 PL_warnhook = oldwarnhook;
5826 PL_diehook = olddiehook;
5827 PL_curcop = old_curcop;
5828
5829 if (cxstack_ix > old_cxix) {
5830 assert(cxstack_ix == old_cxix + 1);
5831 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5832 delete_eval_scope();
5833 }
5834 if (ret)
5835 return o;
5836
5837 OpTYPE_set(o, OP_RV2AV);
5838 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
5839 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
5840 o->op_opt = 0; /* needs to be revisited in rpeep() */
5841 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
5842
5843 /* replace subtree with an OP_CONST */
5844 curop = ((UNOP*)o)->op_first;
5845 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
5846 op_free(curop);
5847
5848 if (AvFILLp(av) != -1)
5849 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
5850 {
5851 SvPADTMP_on(*svp);
5852 SvREADONLY_on(*svp);
5853 }
5854 LINKLIST(o);
5855 return list(o);
5856 }
5857
5858 /*
5859 =head1 Optree Manipulation Functions
5860 */
5861
5862 /* List constructors */
5863
5864 /*
5865 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
5866
5867 Append an item to the list of ops contained directly within a list-type
5868 op, returning the lengthened list. C<first> is the list-type op,
5869 and C<last> is the op to append to the list. C<optype> specifies the
5870 intended opcode for the list. If C<first> is not already a list of the
5871 right type, it will be upgraded into one. If either C<first> or C<last>
5872 is null, the other is returned unchanged.
5873
5874 =cut
5875 */
5876
5877 OP *
Perl_op_append_elem(pTHX_ I32 type,OP * first,OP * last)5878 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
5879 {
5880 if (!first)
5881 return last;
5882
5883 if (!last)
5884 return first;
5885
5886 if (first->op_type != (unsigned)type
5887 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
5888 {
5889 return newLISTOP(type, 0, first, last);
5890 }
5891
5892 op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
5893 first->op_flags |= OPf_KIDS;
5894 return first;
5895 }
5896
5897 /*
5898 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
5899
5900 Concatenate the lists of ops contained directly within two list-type ops,
5901 returning the combined list. C<first> and C<last> are the list-type ops
5902 to concatenate. C<optype> specifies the intended opcode for the list.
5903 If either C<first> or C<last> is not already a list of the right type,
5904 it will be upgraded into one. If either C<first> or C<last> is null,
5905 the other is returned unchanged.
5906
5907 =cut
5908 */
5909
5910 OP *
Perl_op_append_list(pTHX_ I32 type,OP * first,OP * last)5911 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
5912 {
5913 if (!first)
5914 return last;
5915
5916 if (!last)
5917 return first;
5918
5919 if (first->op_type != (unsigned)type)
5920 return op_prepend_elem(type, first, last);
5921
5922 if (last->op_type != (unsigned)type)
5923 return op_append_elem(type, first, last);
5924
5925 OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
5926 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
5927 OpLASTSIB_set(((LISTOP*)first)->op_last, first);
5928 first->op_flags |= (last->op_flags & OPf_KIDS);
5929
5930 S_op_destroy(aTHX_ last);
5931
5932 return first;
5933 }
5934
5935 /*
5936 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
5937
5938 Prepend an item to the list of ops contained directly within a list-type
5939 op, returning the lengthened list. C<first> is the op to prepend to the
5940 list, and C<last> is the list-type op. C<optype> specifies the intended
5941 opcode for the list. If C<last> is not already a list of the right type,
5942 it will be upgraded into one. If either C<first> or C<last> is null,
5943 the other is returned unchanged.
5944
5945 =cut
5946 */
5947
5948 OP *
Perl_op_prepend_elem(pTHX_ I32 type,OP * first,OP * last)5949 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
5950 {
5951 if (!first)
5952 return last;
5953
5954 if (!last)
5955 return first;
5956
5957 if (last->op_type == (unsigned)type) {
5958 if (type == OP_LIST) { /* already a PUSHMARK there */
5959 /* insert 'first' after pushmark */
5960 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
5961 if (!(first->op_flags & OPf_PARENS))
5962 last->op_flags &= ~OPf_PARENS;
5963 }
5964 else
5965 op_sibling_splice(last, NULL, 0, first);
5966 last->op_flags |= OPf_KIDS;
5967 return last;
5968 }
5969
5970 return newLISTOP(type, 0, first, last);
5971 }
5972
5973 /*
5974 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
5975
5976 Converts C<o> into a list op if it is not one already, and then converts it
5977 into the specified C<type>, calling its check function, allocating a target if
5978 it needs one, and folding constants.
5979
5980 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
5981 C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
5982 C<op_convert_list> to make it the right type.
5983
5984 =cut
5985 */
5986
5987 OP *
Perl_op_convert_list(pTHX_ I32 type,I32 flags,OP * o)5988 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
5989 {
5990 dVAR;
5991 if (type < 0) type = -type, flags |= OPf_SPECIAL;
5992 if (!o || o->op_type != OP_LIST)
5993 o = force_list(o, 0);
5994 else
5995 {
5996 o->op_flags &= ~OPf_WANT;
5997 o->op_private &= ~OPpLVAL_INTRO;
5998 }
5999
6000 if (!(PL_opargs[type] & OA_MARK))
6001 op_null(cLISTOPo->op_first);
6002 else {
6003 OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
6004 if (kid2 && kid2->op_type == OP_COREARGS) {
6005 op_null(cLISTOPo->op_first);
6006 kid2->op_private |= OPpCOREARGS_PUSHMARK;
6007 }
6008 }
6009
6010 if (type != OP_SPLIT)
6011 /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
6012 * ck_split() create a real PMOP and leave the op's type as listop
6013 * for now. Otherwise op_free() etc will crash.
6014 */
6015 OpTYPE_set(o, type);
6016
6017 o->op_flags |= flags;
6018 if (flags & OPf_FOLDED)
6019 o->op_folded = 1;
6020
6021 o = CHECKOP(type, o);
6022 if (o->op_type != (unsigned)type)
6023 return o;
6024
6025 return fold_constants(op_integerize(op_std_init(o)));
6026 }
6027
6028 /* Constructors */
6029
6030
6031 /*
6032 =head1 Optree construction
6033
6034 =for apidoc Am|OP *|newNULLLIST
6035
6036 Constructs, checks, and returns a new C<stub> op, which represents an
6037 empty list expression.
6038
6039 =cut
6040 */
6041
6042 OP *
Perl_newNULLLIST(pTHX)6043 Perl_newNULLLIST(pTHX)
6044 {
6045 return newOP(OP_STUB, 0);
6046 }
6047
6048 /* promote o and any siblings to be a list if its not already; i.e.
6049 *
6050 * o - A - B
6051 *
6052 * becomes
6053 *
6054 * list
6055 * |
6056 * pushmark - o - A - B
6057 *
6058 * If nullit it true, the list op is nulled.
6059 */
6060
6061 static OP *
S_force_list(pTHX_ OP * o,bool nullit)6062 S_force_list(pTHX_ OP *o, bool nullit)
6063 {
6064 if (!o || o->op_type != OP_LIST) {
6065 OP *rest = NULL;
6066 if (o) {
6067 /* manually detach any siblings then add them back later */
6068 rest = OpSIBLING(o);
6069 OpLASTSIB_set(o, NULL);
6070 }
6071 o = newLISTOP(OP_LIST, 0, o, NULL);
6072 if (rest)
6073 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
6074 }
6075 if (nullit)
6076 op_null(o);
6077 return o;
6078 }
6079
6080 /*
6081 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
6082
6083 Constructs, checks, and returns an op of any list type. C<type> is
6084 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
6085 C<OPf_KIDS> will be set automatically if required. C<first> and C<last>
6086 supply up to two ops to be direct children of the list op; they are
6087 consumed by this function and become part of the constructed op tree.
6088
6089 For most list operators, the check function expects all the kid ops to be
6090 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
6091 appropriate. What you want to do in that case is create an op of type
6092 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
6093 See L</op_convert_list> for more information.
6094
6095
6096 =cut
6097 */
6098
6099 OP *
Perl_newLISTOP(pTHX_ I32 type,I32 flags,OP * first,OP * last)6100 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6101 {
6102 dVAR;
6103 LISTOP *listop;
6104 /* Note that allocating an OP_PUSHMARK can die under Safe.pm if
6105 * pushmark is banned. So do it now while existing ops are in a
6106 * consistent state, in case they suddenly get freed */
6107 OP* const pushop = type == OP_LIST ? newOP(OP_PUSHMARK, 0) : NULL;
6108
6109 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
6110 || type == OP_CUSTOM);
6111
6112 NewOp(1101, listop, 1, LISTOP);
6113 OpTYPE_set(listop, type);
6114 if (first || last)
6115 flags |= OPf_KIDS;
6116 listop->op_flags = (U8)flags;
6117
6118 if (!last && first)
6119 last = first;
6120 else if (!first && last)
6121 first = last;
6122 else if (first)
6123 OpMORESIB_set(first, last);
6124 listop->op_first = first;
6125 listop->op_last = last;
6126
6127 if (pushop) {
6128 OpMORESIB_set(pushop, first);
6129 listop->op_first = pushop;
6130 listop->op_flags |= OPf_KIDS;
6131 if (!last)
6132 listop->op_last = pushop;
6133 }
6134 if (listop->op_last)
6135 OpLASTSIB_set(listop->op_last, (OP*)listop);
6136
6137 return CHECKOP(type, listop);
6138 }
6139
6140 /*
6141 =for apidoc Am|OP *|newOP|I32 type|I32 flags
6142
6143 Constructs, checks, and returns an op of any base type (any type that
6144 has no extra fields). C<type> is the opcode. C<flags> gives the
6145 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
6146 of C<op_private>.
6147
6148 =cut
6149 */
6150
6151 OP *
Perl_newOP(pTHX_ I32 type,I32 flags)6152 Perl_newOP(pTHX_ I32 type, I32 flags)
6153 {
6154 dVAR;
6155 OP *o;
6156
6157 if (type == -OP_ENTEREVAL) {
6158 type = OP_ENTEREVAL;
6159 flags |= OPpEVAL_BYTES<<8;
6160 }
6161
6162 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
6163 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6164 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6165 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6166
6167 NewOp(1101, o, 1, OP);
6168 OpTYPE_set(o, type);
6169 o->op_flags = (U8)flags;
6170
6171 o->op_next = o;
6172 o->op_private = (U8)(0 | (flags >> 8));
6173 if (PL_opargs[type] & OA_RETSCALAR)
6174 scalar(o);
6175 if (PL_opargs[type] & OA_TARGET)
6176 o->op_targ = pad_alloc(type, SVs_PADTMP);
6177 return CHECKOP(type, o);
6178 }
6179
6180 /*
6181 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
6182
6183 Constructs, checks, and returns an op of any unary type. C<type> is
6184 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
6185 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
6186 bits, the eight bits of C<op_private>, except that the bit with value 1
6187 is automatically set. C<first> supplies an optional op to be the direct
6188 child of the unary op; it is consumed by this function and become part
6189 of the constructed op tree.
6190
6191 =cut
6192 */
6193
6194 OP *
Perl_newUNOP(pTHX_ I32 type,I32 flags,OP * first)6195 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
6196 {
6197 dVAR;
6198 UNOP *unop;
6199
6200 if (type == -OP_ENTEREVAL) {
6201 type = OP_ENTEREVAL;
6202 flags |= OPpEVAL_BYTES<<8;
6203 }
6204
6205 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
6206 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6207 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6208 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
6209 || type == OP_SASSIGN
6210 || type == OP_ENTERTRY
6211 || type == OP_CUSTOM
6212 || type == OP_NULL );
6213
6214 if (!first)
6215 first = newOP(OP_STUB, 0);
6216 if (PL_opargs[type] & OA_MARK)
6217 first = force_list(first, 1);
6218
6219 NewOp(1101, unop, 1, UNOP);
6220 OpTYPE_set(unop, type);
6221 unop->op_first = first;
6222 unop->op_flags = (U8)(flags | OPf_KIDS);
6223 unop->op_private = (U8)(1 | (flags >> 8));
6224
6225 if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
6226 OpLASTSIB_set(first, (OP*)unop);
6227
6228 unop = (UNOP*) CHECKOP(type, unop);
6229 if (unop->op_next)
6230 return (OP*)unop;
6231
6232 return fold_constants(op_integerize(op_std_init((OP *) unop)));
6233 }
6234
6235 /*
6236 =for apidoc newUNOP_AUX
6237
6238 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
6239 initialised to C<aux>
6240
6241 =cut
6242 */
6243
6244 OP *
Perl_newUNOP_AUX(pTHX_ I32 type,I32 flags,OP * first,UNOP_AUX_item * aux)6245 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
6246 {
6247 dVAR;
6248 UNOP_AUX *unop;
6249
6250 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
6251 || type == OP_CUSTOM);
6252
6253 NewOp(1101, unop, 1, UNOP_AUX);
6254 unop->op_type = (OPCODE)type;
6255 unop->op_ppaddr = PL_ppaddr[type];
6256 unop->op_first = first;
6257 unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
6258 unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
6259 unop->op_aux = aux;
6260
6261 if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
6262 OpLASTSIB_set(first, (OP*)unop);
6263
6264 unop = (UNOP_AUX*) CHECKOP(type, unop);
6265
6266 return op_std_init((OP *) unop);
6267 }
6268
6269 /*
6270 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
6271
6272 Constructs, checks, and returns an op of method type with a method name
6273 evaluated at runtime. C<type> is the opcode. C<flags> gives the eight
6274 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
6275 and, shifted up eight bits, the eight bits of C<op_private>, except that
6276 the bit with value 1 is automatically set. C<dynamic_meth> supplies an
6277 op which evaluates method name; it is consumed by this function and
6278 become part of the constructed op tree.
6279 Supported optypes: C<OP_METHOD>.
6280
6281 =cut
6282 */
6283
6284 static OP*
S_newMETHOP_internal(pTHX_ I32 type,I32 flags,OP * dynamic_meth,SV * const_meth)6285 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
6286 dVAR;
6287 METHOP *methop;
6288
6289 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
6290 || type == OP_CUSTOM);
6291
6292 NewOp(1101, methop, 1, METHOP);
6293 if (dynamic_meth) {
6294 if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
6295 methop->op_flags = (U8)(flags | OPf_KIDS);
6296 methop->op_u.op_first = dynamic_meth;
6297 methop->op_private = (U8)(1 | (flags >> 8));
6298
6299 if (!OpHAS_SIBLING(dynamic_meth))
6300 OpLASTSIB_set(dynamic_meth, (OP*)methop);
6301 }
6302 else {
6303 assert(const_meth);
6304 methop->op_flags = (U8)(flags & ~OPf_KIDS);
6305 methop->op_u.op_meth_sv = const_meth;
6306 methop->op_private = (U8)(0 | (flags >> 8));
6307 methop->op_next = (OP*)methop;
6308 }
6309
6310 #ifdef USE_ITHREADS
6311 methop->op_rclass_targ = 0;
6312 #else
6313 methop->op_rclass_sv = NULL;
6314 #endif
6315
6316 OpTYPE_set(methop, type);
6317 return CHECKOP(type, methop);
6318 }
6319
6320 OP *
Perl_newMETHOP(pTHX_ I32 type,I32 flags,OP * dynamic_meth)6321 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
6322 PERL_ARGS_ASSERT_NEWMETHOP;
6323 return newMETHOP_internal(type, flags, dynamic_meth, NULL);
6324 }
6325
6326 /*
6327 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
6328
6329 Constructs, checks, and returns an op of method type with a constant
6330 method name. C<type> is the opcode. C<flags> gives the eight bits of
6331 C<op_flags>, and, shifted up eight bits, the eight bits of
6332 C<op_private>. C<const_meth> supplies a constant method name;
6333 it must be a shared COW string.
6334 Supported optypes: C<OP_METHOD_NAMED>.
6335
6336 =cut
6337 */
6338
6339 OP *
Perl_newMETHOP_named(pTHX_ I32 type,I32 flags,SV * const_meth)6340 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
6341 PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
6342 return newMETHOP_internal(type, flags, NULL, const_meth);
6343 }
6344
6345 /*
6346 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
6347
6348 Constructs, checks, and returns an op of any binary type. C<type>
6349 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
6350 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6351 the eight bits of C<op_private>, except that the bit with value 1 or
6352 2 is automatically set as required. C<first> and C<last> supply up to
6353 two ops to be the direct children of the binary op; they are consumed
6354 by this function and become part of the constructed op tree.
6355
6356 =cut
6357 */
6358
6359 OP *
Perl_newBINOP(pTHX_ I32 type,I32 flags,OP * first,OP * last)6360 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6361 {
6362 dVAR;
6363 BINOP *binop;
6364
6365 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
6366 || type == OP_NULL || type == OP_CUSTOM);
6367
6368 NewOp(1101, binop, 1, BINOP);
6369
6370 if (!first)
6371 first = newOP(OP_NULL, 0);
6372
6373 OpTYPE_set(binop, type);
6374 binop->op_first = first;
6375 binop->op_flags = (U8)(flags | OPf_KIDS);
6376 if (!last) {
6377 last = first;
6378 binop->op_private = (U8)(1 | (flags >> 8));
6379 }
6380 else {
6381 binop->op_private = (U8)(2 | (flags >> 8));
6382 OpMORESIB_set(first, last);
6383 }
6384
6385 if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
6386 OpLASTSIB_set(last, (OP*)binop);
6387
6388 binop->op_last = OpSIBLING(binop->op_first);
6389 if (binop->op_last)
6390 OpLASTSIB_set(binop->op_last, (OP*)binop);
6391
6392 binop = (BINOP*)CHECKOP(type, binop);
6393 if (binop->op_next || binop->op_type != (OPCODE)type)
6394 return (OP*)binop;
6395
6396 return fold_constants(op_integerize(op_std_init((OP *)binop)));
6397 }
6398
6399 /* Helper function for S_pmtrans(): comparison function to sort an array
6400 * of codepoint range pairs. Sorts by start point, or if equal, by end
6401 * point */
6402
6403 static int uvcompare(const void *a, const void *b)
6404 __attribute__nonnull__(1)
6405 __attribute__nonnull__(2)
6406 __attribute__pure__;
uvcompare(const void * a,const void * b)6407 static int uvcompare(const void *a, const void *b)
6408 {
6409 if (*((const UV *)a) < (*(const UV *)b))
6410 return -1;
6411 if (*((const UV *)a) > (*(const UV *)b))
6412 return 1;
6413 if (*((const UV *)a+1) < (*(const UV *)b+1))
6414 return -1;
6415 if (*((const UV *)a+1) > (*(const UV *)b+1))
6416 return 1;
6417 return 0;
6418 }
6419
6420 /* Given an OP_TRANS / OP_TRANSR op o, plus OP_CONST ops expr and repl
6421 * containing the search and replacement strings, assemble into
6422 * a translation table attached as o->op_pv.
6423 * Free expr and repl.
6424 * It expects the toker to have already set the
6425 * OPpTRANS_COMPLEMENT
6426 * OPpTRANS_SQUASH
6427 * OPpTRANS_DELETE
6428 * flags as appropriate; this function may add
6429 * OPpTRANS_FROM_UTF
6430 * OPpTRANS_TO_UTF
6431 * OPpTRANS_IDENTICAL
6432 * OPpTRANS_GROWS
6433 * flags
6434 */
6435
6436 static OP *
S_pmtrans(pTHX_ OP * o,OP * expr,OP * repl)6437 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
6438 {
6439 SV * const tstr = ((SVOP*)expr)->op_sv;
6440 SV * const rstr = ((SVOP*)repl)->op_sv;
6441 STRLEN tlen;
6442 STRLEN rlen;
6443 const U8 *t = (U8*)SvPV_const(tstr, tlen);
6444 const U8 *r = (U8*)SvPV_const(rstr, rlen);
6445 Size_t i, j;
6446 bool grows = FALSE;
6447 OPtrans_map *tbl;
6448 SSize_t struct_size; /* malloced size of table struct */
6449
6450 const bool complement = cBOOL(o->op_private & OPpTRANS_COMPLEMENT);
6451 const bool squash = cBOOL(o->op_private & OPpTRANS_SQUASH);
6452 const bool del = cBOOL(o->op_private & OPpTRANS_DELETE);
6453 SV* swash;
6454
6455 PERL_ARGS_ASSERT_PMTRANS;
6456
6457 PL_hints |= HINT_BLOCK_SCOPE;
6458
6459 if (SvUTF8(tstr))
6460 o->op_private |= OPpTRANS_FROM_UTF;
6461
6462 if (SvUTF8(rstr))
6463 o->op_private |= OPpTRANS_TO_UTF;
6464
6465 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
6466
6467 /* for utf8 translations, op_sv will be set to point to a swash
6468 * containing codepoint ranges. This is done by first assembling
6469 * a textual representation of the ranges in listsv then compiling
6470 * it using swash_init(). For more details of the textual format,
6471 * see L<perlunicode.pod/"User-Defined Character Properties"> .
6472 */
6473
6474 SV* const listsv = newSVpvs("# comment\n");
6475 SV* transv = NULL;
6476 const U8* tend = t + tlen;
6477 const U8* rend = r + rlen;
6478 STRLEN ulen;
6479 UV tfirst = 1;
6480 UV tlast = 0;
6481 IV tdiff;
6482 STRLEN tcount = 0;
6483 UV rfirst = 1;
6484 UV rlast = 0;
6485 IV rdiff;
6486 STRLEN rcount = 0;
6487 IV diff;
6488 I32 none = 0;
6489 U32 max = 0;
6490 I32 bits;
6491 I32 havefinal = 0;
6492 U32 final = 0;
6493 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
6494 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
6495 U8* tsave = NULL;
6496 U8* rsave = NULL;
6497 const U32 flags = UTF8_ALLOW_DEFAULT;
6498
6499 if (!from_utf) {
6500 STRLEN len = tlen;
6501 t = tsave = bytes_to_utf8(t, &len);
6502 tend = t + len;
6503 }
6504 if (!to_utf && rlen) {
6505 STRLEN len = rlen;
6506 r = rsave = bytes_to_utf8(r, &len);
6507 rend = r + len;
6508 }
6509
6510 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
6511 * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
6512 * odd. */
6513
6514 if (complement) {
6515 /* utf8 and /c:
6516 * replace t/tlen/tend with a version that has the ranges
6517 * complemented
6518 */
6519 U8 tmpbuf[UTF8_MAXBYTES+1];
6520 UV *cp;
6521 UV nextmin = 0;
6522 Newx(cp, 2*tlen, UV);
6523 i = 0;
6524 transv = newSVpvs("");
6525
6526 /* convert search string into array of (start,end) range
6527 * codepoint pairs stored in cp[]. Most "ranges" will start
6528 * and end at the same char */
6529 while (t < tend) {
6530 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6531 t += ulen;
6532 /* the toker converts X-Y into (X, ILLEGAL_UTF8_BYTE, Y) */
6533 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
6534 t++;
6535 cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6536 t += ulen;
6537 }
6538 else {
6539 cp[2*i+1] = cp[2*i];
6540 }
6541 i++;
6542 }
6543
6544 /* sort the ranges */
6545 qsort(cp, i, 2*sizeof(UV), uvcompare);
6546
6547 /* Create a utf8 string containing the complement of the
6548 * codepoint ranges. For example if cp[] contains [A,B], [C,D],
6549 * then transv will contain the equivalent of:
6550 * join '', map chr, 0, ILLEGAL_UTF8_BYTE, A - 1,
6551 * B + 1, ILLEGAL_UTF8_BYTE, C - 1,
6552 * D + 1, ILLEGAL_UTF8_BYTE, 0x7fffffff;
6553 * A range of a single char skips the ILLEGAL_UTF8_BYTE and
6554 * end cp.
6555 */
6556 for (j = 0; j < i; j++) {
6557 UV val = cp[2*j];
6558 diff = val - nextmin;
6559 if (diff > 0) {
6560 t = uvchr_to_utf8(tmpbuf,nextmin);
6561 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6562 if (diff > 1) {
6563 U8 range_mark = ILLEGAL_UTF8_BYTE;
6564 t = uvchr_to_utf8(tmpbuf, val - 1);
6565 sv_catpvn(transv, (char *)&range_mark, 1);
6566 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6567 }
6568 }
6569 val = cp[2*j+1];
6570 if (val >= nextmin)
6571 nextmin = val + 1;
6572 }
6573
6574 t = uvchr_to_utf8(tmpbuf,nextmin);
6575 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6576 {
6577 U8 range_mark = ILLEGAL_UTF8_BYTE;
6578 sv_catpvn(transv, (char *)&range_mark, 1);
6579 }
6580 t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
6581 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6582 t = (const U8*)SvPVX_const(transv);
6583 tlen = SvCUR(transv);
6584 tend = t + tlen;
6585 Safefree(cp);
6586 }
6587 else if (!rlen && !del) {
6588 r = t; rlen = tlen; rend = tend;
6589 }
6590
6591 if (!squash) {
6592 if ((!rlen && !del) || t == r ||
6593 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
6594 {
6595 o->op_private |= OPpTRANS_IDENTICAL;
6596 }
6597 }
6598
6599 /* extract char ranges from t and r and append them to listsv */
6600
6601 while (t < tend || tfirst <= tlast) {
6602 /* see if we need more "t" chars */
6603 if (tfirst > tlast) {
6604 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6605 t += ulen;
6606 if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
6607 t++;
6608 tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6609 t += ulen;
6610 }
6611 else
6612 tlast = tfirst;
6613 }
6614
6615 /* now see if we need more "r" chars */
6616 if (rfirst > rlast) {
6617 if (r < rend) {
6618 rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6619 r += ulen;
6620 if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
6621 r++;
6622 rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6623 r += ulen;
6624 }
6625 else
6626 rlast = rfirst;
6627 }
6628 else {
6629 if (!havefinal++)
6630 final = rlast;
6631 rfirst = rlast = 0xffffffff;
6632 }
6633 }
6634
6635 /* now see which range will peter out first, if either. */
6636 tdiff = tlast - tfirst;
6637 rdiff = rlast - rfirst;
6638 tcount += tdiff + 1;
6639 rcount += rdiff + 1;
6640
6641 if (tdiff <= rdiff)
6642 diff = tdiff;
6643 else
6644 diff = rdiff;
6645
6646 if (rfirst == 0xffffffff) {
6647 diff = tdiff; /* oops, pretend rdiff is infinite */
6648 if (diff > 0)
6649 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
6650 (long)tfirst, (long)tlast);
6651 else
6652 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
6653 }
6654 else {
6655 if (diff > 0)
6656 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
6657 (long)tfirst, (long)(tfirst + diff),
6658 (long)rfirst);
6659 else
6660 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
6661 (long)tfirst, (long)rfirst);
6662
6663 if (rfirst + diff > max)
6664 max = rfirst + diff;
6665 if (!grows)
6666 grows = (tfirst < rfirst &&
6667 UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
6668 rfirst += diff + 1;
6669 }
6670 tfirst += diff + 1;
6671 }
6672
6673 /* compile listsv into a swash and attach to o */
6674
6675 none = ++max;
6676 if (del)
6677 ++max;
6678
6679 if (max > 0xffff)
6680 bits = 32;
6681 else if (max > 0xff)
6682 bits = 16;
6683 else
6684 bits = 8;
6685
6686 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
6687 #ifdef USE_ITHREADS
6688 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
6689 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
6690 PAD_SETSV(cPADOPo->op_padix, swash);
6691 SvPADTMP_on(swash);
6692 SvREADONLY_on(swash);
6693 #else
6694 cSVOPo->op_sv = swash;
6695 #endif
6696 SvREFCNT_dec(listsv);
6697 SvREFCNT_dec(transv);
6698
6699 if (!del && havefinal && rlen)
6700 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
6701 newSVuv((UV)final), 0);
6702
6703 Safefree(tsave);
6704 Safefree(rsave);
6705
6706 tlen = tcount;
6707 rlen = rcount;
6708 if (r < rend)
6709 rlen++;
6710 else if (rlast == 0xffffffff)
6711 rlen = 0;
6712
6713 goto warnins;
6714 }
6715
6716 /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
6717 * table. Entries with the value -1 indicate chars not to be
6718 * translated, while -2 indicates a search char without a
6719 * corresponding replacement char under /d.
6720 *
6721 * Normally, the table has 256 slots. However, in the presence of
6722 * /c, the search charlist has an implicit \x{100}-\x{7fffffff}
6723 * added, and if there are enough replacement chars to start pairing
6724 * with the \x{100},... search chars, then a larger (> 256) table
6725 * is allocated.
6726 *
6727 * In addition, regardless of whether under /c, an extra slot at the
6728 * end is used to store the final repeating char, or -3 under an empty
6729 * replacement list, or -2 under /d; which makes the runtime code
6730 * easier.
6731 *
6732 * The toker will have already expanded char ranges in t and r.
6733 */
6734
6735 /* Initially allocate 257-slot table: 256 for basic (non /c) usage,
6736 * plus final slot for repeat/-2/-3. Later we realloc if excess > * 0.
6737 * The OPtrans_map struct already contains one slot; hence the -1.
6738 */
6739 struct_size = sizeof(OPtrans_map) + (256 - 1 + 1)*sizeof(short);
6740 tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
6741 tbl->size = 256;
6742 cPVOPo->op_pv = (char*)tbl;
6743
6744 if (complement) {
6745 Size_t excess;
6746
6747 /* in this branch, j is a count of 'consumed' (i.e. paired off
6748 * with a search char) replacement chars (so j <= rlen always)
6749 */
6750 for (i = 0; i < tlen; i++)
6751 tbl->map[t[i]] = -1;
6752
6753 for (i = 0, j = 0; i < 256; i++) {
6754 if (!tbl->map[i]) {
6755 if (j == rlen) {
6756 if (del)
6757 tbl->map[i] = -2;
6758 else if (rlen)
6759 tbl->map[i] = r[j-1];
6760 else
6761 tbl->map[i] = (short)i;
6762 }
6763 else {
6764 tbl->map[i] = r[j++];
6765 }
6766 if ( tbl->map[i] >= 0
6767 && UVCHR_IS_INVARIANT((UV)i)
6768 && !UVCHR_IS_INVARIANT((UV)(tbl->map[i]))
6769 )
6770 grows = TRUE;
6771 }
6772 }
6773
6774 ASSUME(j <= rlen);
6775 excess = rlen - j;
6776
6777 if (excess) {
6778 /* More replacement chars than search chars:
6779 * store excess replacement chars at end of main table.
6780 */
6781
6782 struct_size += excess;
6783 tbl = (OPtrans_map*)PerlMemShared_realloc(tbl,
6784 struct_size + excess * sizeof(short));
6785 tbl->size += excess;
6786 cPVOPo->op_pv = (char*)tbl;
6787
6788 for (i = 0; i < excess; i++)
6789 tbl->map[i + 256] = r[j+i];
6790 }
6791 else {
6792 /* no more replacement chars than search chars */
6793 if (!rlen && !del && !squash)
6794 o->op_private |= OPpTRANS_IDENTICAL;
6795 }
6796
6797 tbl->map[tbl->size] = del ? -2 : rlen ? r[rlen - 1] : -3;
6798 }
6799 else {
6800 if (!rlen && !del) {
6801 r = t; rlen = tlen;
6802 if (!squash)
6803 o->op_private |= OPpTRANS_IDENTICAL;
6804 }
6805 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
6806 o->op_private |= OPpTRANS_IDENTICAL;
6807 }
6808
6809 for (i = 0; i < 256; i++)
6810 tbl->map[i] = -1;
6811 for (i = 0, j = 0; i < tlen; i++,j++) {
6812 if (j >= rlen) {
6813 if (del) {
6814 if (tbl->map[t[i]] == -1)
6815 tbl->map[t[i]] = -2;
6816 continue;
6817 }
6818 --j;
6819 }
6820 if (tbl->map[t[i]] == -1) {
6821 if ( UVCHR_IS_INVARIANT(t[i])
6822 && ! UVCHR_IS_INVARIANT(r[j]))
6823 grows = TRUE;
6824 tbl->map[t[i]] = r[j];
6825 }
6826 }
6827 tbl->map[tbl->size] = del ? -1 : rlen ? -1 : -3;
6828 }
6829
6830 /* both non-utf8 and utf8 code paths end up here */
6831
6832 warnins:
6833 if(del && rlen == tlen) {
6834 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
6835 } else if(rlen > tlen && !complement) {
6836 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
6837 }
6838
6839 if (grows)
6840 o->op_private |= OPpTRANS_GROWS;
6841 op_free(expr);
6842 op_free(repl);
6843
6844 return o;
6845 }
6846
6847
6848 /*
6849 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
6850
6851 Constructs, checks, and returns an op of any pattern matching type.
6852 C<type> is the opcode. C<flags> gives the eight bits of C<op_flags>
6853 and, shifted up eight bits, the eight bits of C<op_private>.
6854
6855 =cut
6856 */
6857
6858 OP *
Perl_newPMOP(pTHX_ I32 type,I32 flags)6859 Perl_newPMOP(pTHX_ I32 type, I32 flags)
6860 {
6861 dVAR;
6862 PMOP *pmop;
6863
6864 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
6865 || type == OP_CUSTOM);
6866
6867 NewOp(1101, pmop, 1, PMOP);
6868 OpTYPE_set(pmop, type);
6869 pmop->op_flags = (U8)flags;
6870 pmop->op_private = (U8)(0 | (flags >> 8));
6871 if (PL_opargs[type] & OA_RETSCALAR)
6872 scalar((OP *)pmop);
6873
6874 if (PL_hints & HINT_RE_TAINT)
6875 pmop->op_pmflags |= PMf_RETAINT;
6876 #ifdef USE_LOCALE_CTYPE
6877 if (IN_LC_COMPILETIME(LC_CTYPE)) {
6878 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
6879 }
6880 else
6881 #endif
6882 if (IN_UNI_8_BIT) {
6883 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
6884 }
6885 if (PL_hints & HINT_RE_FLAGS) {
6886 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6887 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
6888 );
6889 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
6890 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6891 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
6892 );
6893 if (reflags && SvOK(reflags)) {
6894 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
6895 }
6896 }
6897
6898
6899 #ifdef USE_ITHREADS
6900 assert(SvPOK(PL_regex_pad[0]));
6901 if (SvCUR(PL_regex_pad[0])) {
6902 /* Pop off the "packed" IV from the end. */
6903 SV *const repointer_list = PL_regex_pad[0];
6904 const char *p = SvEND(repointer_list) - sizeof(IV);
6905 const IV offset = *((IV*)p);
6906
6907 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
6908
6909 SvEND_set(repointer_list, p);
6910
6911 pmop->op_pmoffset = offset;
6912 /* This slot should be free, so assert this: */
6913 assert(PL_regex_pad[offset] == &PL_sv_undef);
6914 } else {
6915 SV * const repointer = &PL_sv_undef;
6916 av_push(PL_regex_padav, repointer);
6917 pmop->op_pmoffset = av_tindex(PL_regex_padav);
6918 PL_regex_pad = AvARRAY(PL_regex_padav);
6919 }
6920 #endif
6921
6922 return CHECKOP(type, pmop);
6923 }
6924
6925 static void
S_set_haseval(pTHX)6926 S_set_haseval(pTHX)
6927 {
6928 PADOFFSET i = 1;
6929 PL_cv_has_eval = 1;
6930 /* Any pad names in scope are potentially lvalues. */
6931 for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
6932 PADNAME *pn = PAD_COMPNAME_SV(i);
6933 if (!pn || !PadnameLEN(pn))
6934 continue;
6935 if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
6936 S_mark_padname_lvalue(aTHX_ pn);
6937 }
6938 }
6939
6940 /* Given some sort of match op o, and an expression expr containing a
6941 * pattern, either compile expr into a regex and attach it to o (if it's
6942 * constant), or convert expr into a runtime regcomp op sequence (if it's
6943 * not)
6944 *
6945 * Flags currently has 2 bits of meaning:
6946 * 1: isreg indicates that the pattern is part of a regex construct, eg
6947 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
6948 * split "pattern", which aren't. In the former case, expr will be a list
6949 * if the pattern contains more than one term (eg /a$b/).
6950 * 2: The pattern is for a split.
6951 *
6952 * When the pattern has been compiled within a new anon CV (for
6953 * qr/(?{...})/ ), then floor indicates the savestack level just before
6954 * the new sub was created
6955 */
6956
6957 OP *
Perl_pmruntime(pTHX_ OP * o,OP * expr,OP * repl,UV flags,I32 floor)6958 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
6959 {
6960 PMOP *pm;
6961 LOGOP *rcop;
6962 I32 repl_has_vars = 0;
6963 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
6964 bool is_compiletime;
6965 bool has_code;
6966 bool isreg = cBOOL(flags & 1);
6967 bool is_split = cBOOL(flags & 2);
6968
6969 PERL_ARGS_ASSERT_PMRUNTIME;
6970
6971 if (is_trans) {
6972 return pmtrans(o, expr, repl);
6973 }
6974
6975 /* find whether we have any runtime or code elements;
6976 * at the same time, temporarily set the op_next of each DO block;
6977 * then when we LINKLIST, this will cause the DO blocks to be excluded
6978 * from the op_next chain (and from having LINKLIST recursively
6979 * applied to them). We fix up the DOs specially later */
6980
6981 is_compiletime = 1;
6982 has_code = 0;
6983 if (expr->op_type == OP_LIST) {
6984 OP *o;
6985 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6986 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
6987 has_code = 1;
6988 assert(!o->op_next);
6989 if (UNLIKELY(!OpHAS_SIBLING(o))) {
6990 assert(PL_parser && PL_parser->error_count);
6991 /* This can happen with qr/ (?{(^{})/. Just fake up
6992 the op we were expecting to see, to avoid crashing
6993 elsewhere. */
6994 op_sibling_splice(expr, o, 0,
6995 newSVOP(OP_CONST, 0, &PL_sv_no));
6996 }
6997 o->op_next = OpSIBLING(o);
6998 }
6999 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
7000 is_compiletime = 0;
7001 }
7002 }
7003 else if (expr->op_type != OP_CONST)
7004 is_compiletime = 0;
7005
7006 LINKLIST(expr);
7007
7008 /* fix up DO blocks; treat each one as a separate little sub;
7009 * also, mark any arrays as LIST/REF */
7010
7011 if (expr->op_type == OP_LIST) {
7012 OP *o;
7013 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
7014
7015 if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
7016 assert( !(o->op_flags & OPf_WANT));
7017 /* push the array rather than its contents. The regex
7018 * engine will retrieve and join the elements later */
7019 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
7020 continue;
7021 }
7022
7023 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
7024 continue;
7025 o->op_next = NULL; /* undo temporary hack from above */
7026 scalar(o);
7027 LINKLIST(o);
7028 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
7029 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
7030 /* skip ENTER */
7031 assert(leaveop->op_first->op_type == OP_ENTER);
7032 assert(OpHAS_SIBLING(leaveop->op_first));
7033 o->op_next = OpSIBLING(leaveop->op_first);
7034 /* skip leave */
7035 assert(leaveop->op_flags & OPf_KIDS);
7036 assert(leaveop->op_last->op_next == (OP*)leaveop);
7037 leaveop->op_next = NULL; /* stop on last op */
7038 op_null((OP*)leaveop);
7039 }
7040 else {
7041 /* skip SCOPE */
7042 OP *scope = cLISTOPo->op_first;
7043 assert(scope->op_type == OP_SCOPE);
7044 assert(scope->op_flags & OPf_KIDS);
7045 scope->op_next = NULL; /* stop on last op */
7046 op_null(scope);
7047 }
7048
7049 /* XXX optimize_optree() must be called on o before
7050 * CALL_PEEP(), as currently S_maybe_multiconcat() can't
7051 * currently cope with a peephole-optimised optree.
7052 * Calling optimize_optree() here ensures that condition
7053 * is met, but may mean optimize_optree() is applied
7054 * to the same optree later (where hopefully it won't do any
7055 * harm as it can't convert an op to multiconcat if it's
7056 * already been converted */
7057 optimize_optree(o);
7058
7059 /* have to peep the DOs individually as we've removed it from
7060 * the op_next chain */
7061 CALL_PEEP(o);
7062 S_prune_chain_head(&(o->op_next));
7063 if (is_compiletime)
7064 /* runtime finalizes as part of finalizing whole tree */
7065 finalize_optree(o);
7066 }
7067 }
7068 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
7069 assert( !(expr->op_flags & OPf_WANT));
7070 /* push the array rather than its contents. The regex
7071 * engine will retrieve and join the elements later */
7072 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
7073 }
7074
7075 PL_hints |= HINT_BLOCK_SCOPE;
7076 pm = (PMOP*)o;
7077 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
7078
7079 if (is_compiletime) {
7080 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
7081 regexp_engine const *eng = current_re_engine();
7082
7083 if (is_split) {
7084 /* make engine handle split ' ' specially */
7085 pm->op_pmflags |= PMf_SPLIT;
7086 rx_flags |= RXf_SPLIT;
7087 }
7088
7089 if (!has_code || !eng->op_comp) {
7090 /* compile-time simple constant pattern */
7091
7092 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
7093 /* whoops! we guessed that a qr// had a code block, but we
7094 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
7095 * that isn't required now. Note that we have to be pretty
7096 * confident that nothing used that CV's pad while the
7097 * regex was parsed, except maybe op targets for \Q etc.
7098 * If there were any op targets, though, they should have
7099 * been stolen by constant folding.
7100 */
7101 #ifdef DEBUGGING
7102 SSize_t i = 0;
7103 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
7104 while (++i <= AvFILLp(PL_comppad)) {
7105 # ifdef USE_PAD_RESET
7106 /* under USE_PAD_RESET, pad swipe replaces a swiped
7107 * folded constant with a fresh padtmp */
7108 assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
7109 # else
7110 assert(!PL_curpad[i]);
7111 # endif
7112 }
7113 #endif
7114 /* This LEAVE_SCOPE will restore PL_compcv to point to the
7115 * outer CV (the one whose slab holds the pm op). The
7116 * inner CV (which holds expr) will be freed later, once
7117 * all the entries on the parse stack have been popped on
7118 * return from this function. Which is why its safe to
7119 * call op_free(expr) below.
7120 */
7121 LEAVE_SCOPE(floor);
7122 pm->op_pmflags &= ~PMf_HAS_CV;
7123 }
7124
7125 /* Skip compiling if parser found an error for this pattern */
7126 if (pm->op_pmflags & PMf_HAS_ERROR) {
7127 return o;
7128 }
7129
7130 PM_SETRE(pm,
7131 eng->op_comp
7132 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7133 rx_flags, pm->op_pmflags)
7134 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7135 rx_flags, pm->op_pmflags)
7136 );
7137 op_free(expr);
7138 }
7139 else {
7140 /* compile-time pattern that includes literal code blocks */
7141
7142 REGEXP* re;
7143
7144 /* Skip compiling if parser found an error for this pattern */
7145 if (pm->op_pmflags & PMf_HAS_ERROR) {
7146 return o;
7147 }
7148
7149 re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7150 rx_flags,
7151 (pm->op_pmflags |
7152 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
7153 );
7154 PM_SETRE(pm, re);
7155 if (pm->op_pmflags & PMf_HAS_CV) {
7156 CV *cv;
7157 /* this QR op (and the anon sub we embed it in) is never
7158 * actually executed. It's just a placeholder where we can
7159 * squirrel away expr in op_code_list without the peephole
7160 * optimiser etc processing it for a second time */
7161 OP *qr = newPMOP(OP_QR, 0);
7162 ((PMOP*)qr)->op_code_list = expr;
7163
7164 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
7165 SvREFCNT_inc_simple_void(PL_compcv);
7166 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
7167 ReANY(re)->qr_anoncv = cv;
7168
7169 /* attach the anon CV to the pad so that
7170 * pad_fixup_inner_anons() can find it */
7171 (void)pad_add_anon(cv, o->op_type);
7172 SvREFCNT_inc_simple_void(cv);
7173 }
7174 else {
7175 pm->op_code_list = expr;
7176 }
7177 }
7178 }
7179 else {
7180 /* runtime pattern: build chain of regcomp etc ops */
7181 bool reglist;
7182 PADOFFSET cv_targ = 0;
7183
7184 reglist = isreg && expr->op_type == OP_LIST;
7185 if (reglist)
7186 op_null(expr);
7187
7188 if (has_code) {
7189 pm->op_code_list = expr;
7190 /* don't free op_code_list; its ops are embedded elsewhere too */
7191 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
7192 }
7193
7194 if (is_split)
7195 /* make engine handle split ' ' specially */
7196 pm->op_pmflags |= PMf_SPLIT;
7197
7198 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
7199 * to allow its op_next to be pointed past the regcomp and
7200 * preceding stacking ops;
7201 * OP_REGCRESET is there to reset taint before executing the
7202 * stacking ops */
7203 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
7204 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
7205
7206 if (pm->op_pmflags & PMf_HAS_CV) {
7207 /* we have a runtime qr with literal code. This means
7208 * that the qr// has been wrapped in a new CV, which
7209 * means that runtime consts, vars etc will have been compiled
7210 * against a new pad. So... we need to execute those ops
7211 * within the environment of the new CV. So wrap them in a call
7212 * to a new anon sub. i.e. for
7213 *
7214 * qr/a$b(?{...})/,
7215 *
7216 * we build an anon sub that looks like
7217 *
7218 * sub { "a", $b, '(?{...})' }
7219 *
7220 * and call it, passing the returned list to regcomp.
7221 * Or to put it another way, the list of ops that get executed
7222 * are:
7223 *
7224 * normal PMf_HAS_CV
7225 * ------ -------------------
7226 * pushmark (for regcomp)
7227 * pushmark (for entersub)
7228 * anoncode
7229 * srefgen
7230 * entersub
7231 * regcreset regcreset
7232 * pushmark pushmark
7233 * const("a") const("a")
7234 * gvsv(b) gvsv(b)
7235 * const("(?{...})") const("(?{...})")
7236 * leavesub
7237 * regcomp regcomp
7238 */
7239
7240 SvREFCNT_inc_simple_void(PL_compcv);
7241 CvLVALUE_on(PL_compcv);
7242 /* these lines are just an unrolled newANONATTRSUB */
7243 expr = newSVOP(OP_ANONCODE, 0,
7244 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
7245 cv_targ = expr->op_targ;
7246 expr = newUNOP(OP_REFGEN, 0, expr);
7247
7248 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
7249 }
7250
7251 rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
7252 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
7253 | (reglist ? OPf_STACKED : 0);
7254 rcop->op_targ = cv_targ;
7255
7256 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
7257 if (PL_hints & HINT_RE_EVAL)
7258 S_set_haseval(aTHX);
7259
7260 /* establish postfix order */
7261 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
7262 LINKLIST(expr);
7263 rcop->op_next = expr;
7264 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
7265 }
7266 else {
7267 rcop->op_next = LINKLIST(expr);
7268 expr->op_next = (OP*)rcop;
7269 }
7270
7271 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
7272 }
7273
7274 if (repl) {
7275 OP *curop = repl;
7276 bool konst;
7277 /* If we are looking at s//.../e with a single statement, get past
7278 the implicit do{}. */
7279 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
7280 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
7281 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
7282 {
7283 OP *sib;
7284 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
7285 if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
7286 && !OpHAS_SIBLING(sib))
7287 curop = sib;
7288 }
7289 if (curop->op_type == OP_CONST)
7290 konst = TRUE;
7291 else if (( (curop->op_type == OP_RV2SV ||
7292 curop->op_type == OP_RV2AV ||
7293 curop->op_type == OP_RV2HV ||
7294 curop->op_type == OP_RV2GV)
7295 && cUNOPx(curop)->op_first
7296 && cUNOPx(curop)->op_first->op_type == OP_GV )
7297 || curop->op_type == OP_PADSV
7298 || curop->op_type == OP_PADAV
7299 || curop->op_type == OP_PADHV
7300 || curop->op_type == OP_PADANY) {
7301 repl_has_vars = 1;
7302 konst = TRUE;
7303 }
7304 else konst = FALSE;
7305 if (konst
7306 && !(repl_has_vars
7307 && (!PM_GETRE(pm)
7308 || !RX_PRELEN(PM_GETRE(pm))
7309 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
7310 {
7311 pm->op_pmflags |= PMf_CONST; /* const for long enough */
7312 op_prepend_elem(o->op_type, scalar(repl), o);
7313 }
7314 else {
7315 rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
7316 rcop->op_private = 1;
7317
7318 /* establish postfix order */
7319 rcop->op_next = LINKLIST(repl);
7320 repl->op_next = (OP*)rcop;
7321
7322 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
7323 assert(!(pm->op_pmflags & PMf_ONCE));
7324 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
7325 rcop->op_next = 0;
7326 }
7327 }
7328
7329 return (OP*)pm;
7330 }
7331
7332 /*
7333 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
7334
7335 Constructs, checks, and returns an op of any type that involves an
7336 embedded SV. C<type> is the opcode. C<flags> gives the eight bits
7337 of C<op_flags>. C<sv> gives the SV to embed in the op; this function
7338 takes ownership of one reference to it.
7339
7340 =cut
7341 */
7342
7343 OP *
Perl_newSVOP(pTHX_ I32 type,I32 flags,SV * sv)7344 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
7345 {
7346 dVAR;
7347 SVOP *svop;
7348
7349 PERL_ARGS_ASSERT_NEWSVOP;
7350
7351 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7352 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7353 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7354 || type == OP_CUSTOM);
7355
7356 NewOp(1101, svop, 1, SVOP);
7357 OpTYPE_set(svop, type);
7358 svop->op_sv = sv;
7359 svop->op_next = (OP*)svop;
7360 svop->op_flags = (U8)flags;
7361 svop->op_private = (U8)(0 | (flags >> 8));
7362 if (PL_opargs[type] & OA_RETSCALAR)
7363 scalar((OP*)svop);
7364 if (PL_opargs[type] & OA_TARGET)
7365 svop->op_targ = pad_alloc(type, SVs_PADTMP);
7366 return CHECKOP(type, svop);
7367 }
7368
7369 /*
7370 =for apidoc Am|OP *|newDEFSVOP|
7371
7372 Constructs and returns an op to access C<$_>.
7373
7374 =cut
7375 */
7376
7377 OP *
Perl_newDEFSVOP(pTHX)7378 Perl_newDEFSVOP(pTHX)
7379 {
7380 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
7381 }
7382
7383 #ifdef USE_ITHREADS
7384
7385 /*
7386 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
7387
7388 Constructs, checks, and returns an op of any type that involves a
7389 reference to a pad element. C<type> is the opcode. C<flags> gives the
7390 eight bits of C<op_flags>. A pad slot is automatically allocated, and
7391 is populated with C<sv>; this function takes ownership of one reference
7392 to it.
7393
7394 This function only exists if Perl has been compiled to use ithreads.
7395
7396 =cut
7397 */
7398
7399 OP *
Perl_newPADOP(pTHX_ I32 type,I32 flags,SV * sv)7400 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
7401 {
7402 dVAR;
7403 PADOP *padop;
7404
7405 PERL_ARGS_ASSERT_NEWPADOP;
7406
7407 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7408 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7409 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7410 || type == OP_CUSTOM);
7411
7412 NewOp(1101, padop, 1, PADOP);
7413 OpTYPE_set(padop, type);
7414 padop->op_padix =
7415 pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
7416 SvREFCNT_dec(PAD_SVl(padop->op_padix));
7417 PAD_SETSV(padop->op_padix, sv);
7418 assert(sv);
7419 padop->op_next = (OP*)padop;
7420 padop->op_flags = (U8)flags;
7421 if (PL_opargs[type] & OA_RETSCALAR)
7422 scalar((OP*)padop);
7423 if (PL_opargs[type] & OA_TARGET)
7424 padop->op_targ = pad_alloc(type, SVs_PADTMP);
7425 return CHECKOP(type, padop);
7426 }
7427
7428 #endif /* USE_ITHREADS */
7429
7430 /*
7431 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
7432
7433 Constructs, checks, and returns an op of any type that involves an
7434 embedded reference to a GV. C<type> is the opcode. C<flags> gives the
7435 eight bits of C<op_flags>. C<gv> identifies the GV that the op should
7436 reference; calling this function does not transfer ownership of any
7437 reference to it.
7438
7439 =cut
7440 */
7441
7442 OP *
Perl_newGVOP(pTHX_ I32 type,I32 flags,GV * gv)7443 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
7444 {
7445 PERL_ARGS_ASSERT_NEWGVOP;
7446
7447 #ifdef USE_ITHREADS
7448 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7449 #else
7450 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7451 #endif
7452 }
7453
7454 /*
7455 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
7456
7457 Constructs, checks, and returns an op of any type that involves an
7458 embedded C-level pointer (PV). C<type> is the opcode. C<flags> gives
7459 the eight bits of C<op_flags>. C<pv> supplies the C-level pointer.
7460 Depending on the op type, the memory referenced by C<pv> may be freed
7461 when the op is destroyed. If the op is of a freeing type, C<pv> must
7462 have been allocated using C<PerlMemShared_malloc>.
7463
7464 =cut
7465 */
7466
7467 OP *
Perl_newPVOP(pTHX_ I32 type,I32 flags,char * pv)7468 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
7469 {
7470 dVAR;
7471 const bool utf8 = cBOOL(flags & SVf_UTF8);
7472 PVOP *pvop;
7473
7474 flags &= ~SVf_UTF8;
7475
7476 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7477 || type == OP_RUNCV || type == OP_CUSTOM
7478 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
7479
7480 NewOp(1101, pvop, 1, PVOP);
7481 OpTYPE_set(pvop, type);
7482 pvop->op_pv = pv;
7483 pvop->op_next = (OP*)pvop;
7484 pvop->op_flags = (U8)flags;
7485 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
7486 if (PL_opargs[type] & OA_RETSCALAR)
7487 scalar((OP*)pvop);
7488 if (PL_opargs[type] & OA_TARGET)
7489 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
7490 return CHECKOP(type, pvop);
7491 }
7492
7493 void
Perl_package(pTHX_ OP * o)7494 Perl_package(pTHX_ OP *o)
7495 {
7496 SV *const sv = cSVOPo->op_sv;
7497
7498 PERL_ARGS_ASSERT_PACKAGE;
7499
7500 SAVEGENERICSV(PL_curstash);
7501 save_item(PL_curstname);
7502
7503 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
7504
7505 sv_setsv(PL_curstname, sv);
7506
7507 PL_hints |= HINT_BLOCK_SCOPE;
7508 PL_parser->copline = NOLINE;
7509
7510 op_free(o);
7511 }
7512
7513 void
Perl_package_version(pTHX_ OP * v)7514 Perl_package_version( pTHX_ OP *v )
7515 {
7516 U32 savehints = PL_hints;
7517 PERL_ARGS_ASSERT_PACKAGE_VERSION;
7518 PL_hints &= ~HINT_STRICT_VARS;
7519 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
7520 PL_hints = savehints;
7521 op_free(v);
7522 }
7523
7524 void
Perl_utilize(pTHX_ int aver,I32 floor,OP * version,OP * idop,OP * arg)7525 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
7526 {
7527 OP *pack;
7528 OP *imop;
7529 OP *veop;
7530 SV *use_version = NULL;
7531
7532 PERL_ARGS_ASSERT_UTILIZE;
7533
7534 if (idop->op_type != OP_CONST)
7535 Perl_croak(aTHX_ "Module name must be constant");
7536
7537 veop = NULL;
7538
7539 if (version) {
7540 SV * const vesv = ((SVOP*)version)->op_sv;
7541
7542 if (!arg && !SvNIOKp(vesv)) {
7543 arg = version;
7544 }
7545 else {
7546 OP *pack;
7547 SV *meth;
7548
7549 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
7550 Perl_croak(aTHX_ "Version number must be a constant number");
7551
7552 /* Make copy of idop so we don't free it twice */
7553 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7554
7555 /* Fake up a method call to VERSION */
7556 meth = newSVpvs_share("VERSION");
7557 veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7558 op_append_elem(OP_LIST,
7559 op_prepend_elem(OP_LIST, pack, version),
7560 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
7561 }
7562 }
7563
7564 /* Fake up an import/unimport */
7565 if (arg && arg->op_type == OP_STUB) {
7566 imop = arg; /* no import on explicit () */
7567 }
7568 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
7569 imop = NULL; /* use 5.0; */
7570 if (aver)
7571 use_version = ((SVOP*)idop)->op_sv;
7572 else
7573 idop->op_private |= OPpCONST_NOVER;
7574 }
7575 else {
7576 SV *meth;
7577
7578 /* Make copy of idop so we don't free it twice */
7579 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7580
7581 /* Fake up a method call to import/unimport */
7582 meth = aver
7583 ? newSVpvs_share("import") : newSVpvs_share("unimport");
7584 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7585 op_append_elem(OP_LIST,
7586 op_prepend_elem(OP_LIST, pack, arg),
7587 newMETHOP_named(OP_METHOD_NAMED, 0, meth)
7588 ));
7589 }
7590
7591 /* Fake up the BEGIN {}, which does its thing immediately. */
7592 newATTRSUB(floor,
7593 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
7594 NULL,
7595 NULL,
7596 op_append_elem(OP_LINESEQ,
7597 op_append_elem(OP_LINESEQ,
7598 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
7599 newSTATEOP(0, NULL, veop)),
7600 newSTATEOP(0, NULL, imop) ));
7601
7602 if (use_version) {
7603 /* Enable the
7604 * feature bundle that corresponds to the required version. */
7605 use_version = sv_2mortal(new_version(use_version));
7606 S_enable_feature_bundle(aTHX_ use_version);
7607
7608 /* If a version >= 5.11.0 is requested, strictures are on by default! */
7609 if (vcmp(use_version,
7610 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
7611 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7612 PL_hints |= HINT_STRICT_REFS;
7613 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7614 PL_hints |= HINT_STRICT_SUBS;
7615 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7616 PL_hints |= HINT_STRICT_VARS;
7617 }
7618 /* otherwise they are off */
7619 else {
7620 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7621 PL_hints &= ~HINT_STRICT_REFS;
7622 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7623 PL_hints &= ~HINT_STRICT_SUBS;
7624 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7625 PL_hints &= ~HINT_STRICT_VARS;
7626 }
7627 }
7628
7629 /* The "did you use incorrect case?" warning used to be here.
7630 * The problem is that on case-insensitive filesystems one
7631 * might get false positives for "use" (and "require"):
7632 * "use Strict" or "require CARP" will work. This causes
7633 * portability problems for the script: in case-strict
7634 * filesystems the script will stop working.
7635 *
7636 * The "incorrect case" warning checked whether "use Foo"
7637 * imported "Foo" to your namespace, but that is wrong, too:
7638 * there is no requirement nor promise in the language that
7639 * a Foo.pm should or would contain anything in package "Foo".
7640 *
7641 * There is very little Configure-wise that can be done, either:
7642 * the case-sensitivity of the build filesystem of Perl does not
7643 * help in guessing the case-sensitivity of the runtime environment.
7644 */
7645
7646 PL_hints |= HINT_BLOCK_SCOPE;
7647 PL_parser->copline = NOLINE;
7648 COP_SEQMAX_INC; /* Purely for B::*'s benefit */
7649 }
7650
7651 /*
7652 =head1 Embedding Functions
7653
7654 =for apidoc load_module
7655
7656 Loads the module whose name is pointed to by the string part of C<name>.
7657 Note that the actual module name, not its filename, should be given.
7658 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
7659 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
7660 trailing arguments can be used to specify arguments to the module's C<import()>
7661 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
7662 on the flags. The flags argument is a bitwise-ORed collection of any of
7663 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
7664 (or 0 for no flags).
7665
7666 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
7667 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
7668 the trailing optional arguments may be omitted entirely. Otherwise, if
7669 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
7670 exactly one C<OP*>, containing the op tree that produces the relevant import
7671 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
7672 will be used as import arguments; and the list must be terminated with C<(SV*)
7673 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
7674 set, the trailing C<NULL> pointer is needed even if no import arguments are
7675 desired. The reference count for each specified C<SV*> argument is
7676 decremented. In addition, the C<name> argument is modified.
7677
7678 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
7679 than C<use>.
7680
7681 =cut */
7682
7683 void
Perl_load_module(pTHX_ U32 flags,SV * name,SV * ver,...)7684 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
7685 {
7686 va_list args;
7687
7688 PERL_ARGS_ASSERT_LOAD_MODULE;
7689
7690 va_start(args, ver);
7691 vload_module(flags, name, ver, &args);
7692 va_end(args);
7693 }
7694
7695 #ifdef PERL_IMPLICIT_CONTEXT
7696 void
Perl_load_module_nocontext(U32 flags,SV * name,SV * ver,...)7697 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
7698 {
7699 dTHX;
7700 va_list args;
7701 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
7702 va_start(args, ver);
7703 vload_module(flags, name, ver, &args);
7704 va_end(args);
7705 }
7706 #endif
7707
7708 void
Perl_vload_module(pTHX_ U32 flags,SV * name,SV * ver,va_list * args)7709 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
7710 {
7711 OP *veop, *imop;
7712 OP * modname;
7713 I32 floor;
7714
7715 PERL_ARGS_ASSERT_VLOAD_MODULE;
7716
7717 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
7718 * that it has a PL_parser to play with while doing that, and also
7719 * that it doesn't mess with any existing parser, by creating a tmp
7720 * new parser with lex_start(). This won't actually be used for much,
7721 * since pp_require() will create another parser for the real work.
7722 * The ENTER/LEAVE pair protect callers from any side effects of use.
7723 *
7724 * start_subparse() creates a new PL_compcv. This means that any ops
7725 * allocated below will be allocated from that CV's op slab, and so
7726 * will be automatically freed if the utilise() fails
7727 */
7728
7729 ENTER;
7730 SAVEVPTR(PL_curcop);
7731 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
7732 floor = start_subparse(FALSE, 0);
7733
7734 modname = newSVOP(OP_CONST, 0, name);
7735 modname->op_private |= OPpCONST_BARE;
7736 if (ver) {
7737 veop = newSVOP(OP_CONST, 0, ver);
7738 }
7739 else
7740 veop = NULL;
7741 if (flags & PERL_LOADMOD_NOIMPORT) {
7742 imop = sawparens(newNULLLIST());
7743 }
7744 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
7745 imop = va_arg(*args, OP*);
7746 }
7747 else {
7748 SV *sv;
7749 imop = NULL;
7750 sv = va_arg(*args, SV*);
7751 while (sv) {
7752 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
7753 sv = va_arg(*args, SV*);
7754 }
7755 }
7756
7757 utilize(!(flags & PERL_LOADMOD_DENY), floor, veop, modname, imop);
7758 LEAVE;
7759 }
7760
7761 PERL_STATIC_INLINE OP *
S_new_entersubop(pTHX_ GV * gv,OP * arg)7762 S_new_entersubop(pTHX_ GV *gv, OP *arg)
7763 {
7764 return newUNOP(OP_ENTERSUB, OPf_STACKED,
7765 newLISTOP(OP_LIST, 0, arg,
7766 newUNOP(OP_RV2CV, 0,
7767 newGVOP(OP_GV, 0, gv))));
7768 }
7769
7770 OP *
Perl_dofile(pTHX_ OP * term,I32 force_builtin)7771 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
7772 {
7773 OP *doop;
7774 GV *gv;
7775
7776 PERL_ARGS_ASSERT_DOFILE;
7777
7778 if (!force_builtin && (gv = gv_override("do", 2))) {
7779 doop = S_new_entersubop(aTHX_ gv, term);
7780 }
7781 else {
7782 doop = newUNOP(OP_DOFILE, 0, scalar(term));
7783 }
7784 return doop;
7785 }
7786
7787 /*
7788 =head1 Optree construction
7789
7790 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
7791
7792 Constructs, checks, and returns an C<lslice> (list slice) op. C<flags>
7793 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
7794 be set automatically, and, shifted up eight bits, the eight bits of
7795 C<op_private>, except that the bit with value 1 or 2 is automatically
7796 set as required. C<listval> and C<subscript> supply the parameters of
7797 the slice; they are consumed by this function and become part of the
7798 constructed op tree.
7799
7800 =cut
7801 */
7802
7803 OP *
Perl_newSLICEOP(pTHX_ I32 flags,OP * subscript,OP * listval)7804 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
7805 {
7806 return newBINOP(OP_LSLICE, flags,
7807 list(force_list(subscript, 1)),
7808 list(force_list(listval, 1)) );
7809 }
7810
7811 #define ASSIGN_LIST 1
7812 #define ASSIGN_REF 2
7813
7814 STATIC I32
S_assignment_type(pTHX_ const OP * o)7815 S_assignment_type(pTHX_ const OP *o)
7816 {
7817 unsigned type;
7818 U8 flags;
7819 U8 ret;
7820
7821 if (!o)
7822 return TRUE;
7823
7824 if (o->op_type == OP_SREFGEN)
7825 {
7826 OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
7827 type = kid->op_type;
7828 flags = o->op_flags | kid->op_flags;
7829 if (!(flags & OPf_PARENS)
7830 && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
7831 kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
7832 return ASSIGN_REF;
7833 ret = ASSIGN_REF;
7834 } else {
7835 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
7836 o = cUNOPo->op_first;
7837 flags = o->op_flags;
7838 type = o->op_type;
7839 ret = 0;
7840 }
7841
7842 if (type == OP_COND_EXPR) {
7843 OP * const sib = OpSIBLING(cLOGOPo->op_first);
7844 const I32 t = assignment_type(sib);
7845 const I32 f = assignment_type(OpSIBLING(sib));
7846
7847 if (t == ASSIGN_LIST && f == ASSIGN_LIST)
7848 return ASSIGN_LIST;
7849 if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
7850 yyerror("Assignment to both a list and a scalar");
7851 return FALSE;
7852 }
7853
7854 if (type == OP_LIST &&
7855 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
7856 o->op_private & OPpLVAL_INTRO)
7857 return ret;
7858
7859 if (type == OP_LIST || flags & OPf_PARENS ||
7860 type == OP_RV2AV || type == OP_RV2HV ||
7861 type == OP_ASLICE || type == OP_HSLICE ||
7862 type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
7863 return TRUE;
7864
7865 if (type == OP_PADAV || type == OP_PADHV)
7866 return TRUE;
7867
7868 if (type == OP_RV2SV)
7869 return ret;
7870
7871 return ret;
7872 }
7873
7874 static OP *
S_newONCEOP(pTHX_ OP * initop,OP * padop)7875 S_newONCEOP(pTHX_ OP *initop, OP *padop)
7876 {
7877 dVAR;
7878 const PADOFFSET target = padop->op_targ;
7879 OP *const other = newOP(OP_PADSV,
7880 padop->op_flags
7881 | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
7882 OP *const first = newOP(OP_NULL, 0);
7883 OP *const nullop = newCONDOP(0, first, initop, other);
7884 /* XXX targlex disabled for now; see ticket #124160
7885 newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
7886 */
7887 OP *const condop = first->op_next;
7888
7889 OpTYPE_set(condop, OP_ONCE);
7890 other->op_targ = target;
7891 nullop->op_flags |= OPf_WANT_SCALAR;
7892
7893 /* Store the initializedness of state vars in a separate
7894 pad entry. */
7895 condop->op_targ =
7896 pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
7897 /* hijacking PADSTALE for uninitialized state variables */
7898 SvPADSTALE_on(PAD_SVl(condop->op_targ));
7899
7900 return nullop;
7901 }
7902
7903 /*
7904 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
7905
7906 Constructs, checks, and returns an assignment op. C<left> and C<right>
7907 supply the parameters of the assignment; they are consumed by this
7908 function and become part of the constructed op tree.
7909
7910 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
7911 a suitable conditional optree is constructed. If C<optype> is the opcode
7912 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
7913 performs the binary operation and assigns the result to the left argument.
7914 Either way, if C<optype> is non-zero then C<flags> has no effect.
7915
7916 If C<optype> is zero, then a plain scalar or list assignment is
7917 constructed. Which type of assignment it is is automatically determined.
7918 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
7919 will be set automatically, and, shifted up eight bits, the eight bits
7920 of C<op_private>, except that the bit with value 1 or 2 is automatically
7921 set as required.
7922
7923 =cut
7924 */
7925
7926 OP *
Perl_newASSIGNOP(pTHX_ I32 flags,OP * left,I32 optype,OP * right)7927 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
7928 {
7929 OP *o;
7930 I32 assign_type;
7931
7932 if (optype) {
7933 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
7934 right = scalar(right);
7935 return newLOGOP(optype, 0,
7936 op_lvalue(scalar(left), optype),
7937 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
7938 }
7939 else {
7940 return newBINOP(optype, OPf_STACKED,
7941 op_lvalue(scalar(left), optype), scalar(right));
7942 }
7943 }
7944
7945 if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
7946 OP *state_var_op = NULL;
7947 static const char no_list_state[] = "Initialization of state variables"
7948 " in list currently forbidden";
7949 OP *curop;
7950
7951 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
7952 left->op_private &= ~ OPpSLICEWARNING;
7953
7954 PL_modcount = 0;
7955 left = op_lvalue(left, OP_AASSIGN);
7956 curop = list(force_list(left, 1));
7957 o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
7958 o->op_private = (U8)(0 | (flags >> 8));
7959
7960 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
7961 {
7962 OP *lop = ((LISTOP*)left)->op_first, *vop, *eop;
7963 if (!(left->op_flags & OPf_PARENS) &&
7964 lop->op_type == OP_PUSHMARK &&
7965 (vop = OpSIBLING(lop)) &&
7966 (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
7967 !(vop->op_flags & OPf_PARENS) &&
7968 (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
7969 (OPpLVAL_INTRO|OPpPAD_STATE) &&
7970 (eop = OpSIBLING(vop)) &&
7971 eop->op_type == OP_ENTERSUB &&
7972 !OpHAS_SIBLING(eop)) {
7973 state_var_op = vop;
7974 } else {
7975 while (lop) {
7976 if ((lop->op_type == OP_PADSV ||
7977 lop->op_type == OP_PADAV ||
7978 lop->op_type == OP_PADHV ||
7979 lop->op_type == OP_PADANY)
7980 && (lop->op_private & OPpPAD_STATE)
7981 )
7982 yyerror(no_list_state);
7983 lop = OpSIBLING(lop);
7984 }
7985 }
7986 }
7987 else if ( (left->op_private & OPpLVAL_INTRO)
7988 && (left->op_private & OPpPAD_STATE)
7989 && ( left->op_type == OP_PADSV
7990 || left->op_type == OP_PADAV
7991 || left->op_type == OP_PADHV
7992 || left->op_type == OP_PADANY)
7993 ) {
7994 /* All single variable list context state assignments, hence
7995 state ($a) = ...
7996 (state $a) = ...
7997 state @a = ...
7998 state (@a) = ...
7999 (state @a) = ...
8000 state %a = ...
8001 state (%a) = ...
8002 (state %a) = ...
8003 */
8004 if (left->op_flags & OPf_PARENS)
8005 yyerror(no_list_state);
8006 else
8007 state_var_op = left;
8008 }
8009
8010 /* optimise @a = split(...) into:
8011 * @{expr}: split(..., @{expr}) (where @a is not flattened)
8012 * @a, my @a, local @a: split(...) (where @a is attached to
8013 * the split op itself)
8014 */
8015
8016 if ( right
8017 && right->op_type == OP_SPLIT
8018 /* don't do twice, e.g. @b = (@a = split) */
8019 && !(right->op_private & OPpSPLIT_ASSIGN))
8020 {
8021 OP *gvop = NULL;
8022
8023 if ( ( left->op_type == OP_RV2AV
8024 && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
8025 || left->op_type == OP_PADAV)
8026 {
8027 /* @pkg or @lex or local @pkg' or 'my @lex' */
8028 OP *tmpop;
8029 if (gvop) {
8030 #ifdef USE_ITHREADS
8031 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
8032 = cPADOPx(gvop)->op_padix;
8033 cPADOPx(gvop)->op_padix = 0; /* steal it */
8034 #else
8035 ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
8036 = MUTABLE_GV(cSVOPx(gvop)->op_sv);
8037 cSVOPx(gvop)->op_sv = NULL; /* steal it */
8038 #endif
8039 right->op_private |=
8040 left->op_private & OPpOUR_INTRO;
8041 }
8042 else {
8043 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
8044 left->op_targ = 0; /* steal it */
8045 right->op_private |= OPpSPLIT_LEX;
8046 }
8047 right->op_private |= left->op_private & OPpLVAL_INTRO;
8048
8049 detach_split:
8050 tmpop = cUNOPo->op_first; /* to list (nulled) */
8051 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
8052 assert(OpSIBLING(tmpop) == right);
8053 assert(!OpHAS_SIBLING(right));
8054 /* detach the split subtreee from the o tree,
8055 * then free the residual o tree */
8056 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
8057 op_free(o); /* blow off assign */
8058 right->op_private |= OPpSPLIT_ASSIGN;
8059 right->op_flags &= ~OPf_WANT;
8060 /* "I don't know and I don't care." */
8061 return right;
8062 }
8063 else if (left->op_type == OP_RV2AV) {
8064 /* @{expr} */
8065
8066 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
8067 assert(OpSIBLING(pushop) == left);
8068 /* Detach the array ... */
8069 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
8070 /* ... and attach it to the split. */
8071 op_sibling_splice(right, cLISTOPx(right)->op_last,
8072 0, left);
8073 right->op_flags |= OPf_STACKED;
8074 /* Detach split and expunge aassign as above. */
8075 goto detach_split;
8076 }
8077 else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
8078 ((LISTOP*)right)->op_last->op_type == OP_CONST)
8079 {
8080 /* convert split(...,0) to split(..., PL_modcount+1) */
8081 SV ** const svp =
8082 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
8083 SV * const sv = *svp;
8084 if (SvIOK(sv) && SvIVX(sv) == 0)
8085 {
8086 if (right->op_private & OPpSPLIT_IMPLIM) {
8087 /* our own SV, created in ck_split */
8088 SvREADONLY_off(sv);
8089 sv_setiv(sv, PL_modcount+1);
8090 }
8091 else {
8092 /* SV may belong to someone else */
8093 SvREFCNT_dec(sv);
8094 *svp = newSViv(PL_modcount+1);
8095 }
8096 }
8097 }
8098 }
8099
8100 if (state_var_op)
8101 o = S_newONCEOP(aTHX_ o, state_var_op);
8102 return o;
8103 }
8104 if (assign_type == ASSIGN_REF)
8105 return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
8106 if (!right)
8107 right = newOP(OP_UNDEF, 0);
8108 if (right->op_type == OP_READLINE) {
8109 right->op_flags |= OPf_STACKED;
8110 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
8111 scalar(right));
8112 }
8113 else {
8114 o = newBINOP(OP_SASSIGN, flags,
8115 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
8116 }
8117 return o;
8118 }
8119
8120 /*
8121 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
8122
8123 Constructs a state op (COP). The state op is normally a C<nextstate> op,
8124 but will be a C<dbstate> op if debugging is enabled for currently-compiled
8125 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
8126 If C<label> is non-null, it supplies the name of a label to attach to
8127 the state op; this function takes ownership of the memory pointed at by
8128 C<label>, and will free it. C<flags> gives the eight bits of C<op_flags>
8129 for the state op.
8130
8131 If C<o> is null, the state op is returned. Otherwise the state op is
8132 combined with C<o> into a C<lineseq> list op, which is returned. C<o>
8133 is consumed by this function and becomes part of the returned op tree.
8134
8135 =cut
8136 */
8137
8138 OP *
Perl_newSTATEOP(pTHX_ I32 flags,char * label,OP * o)8139 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
8140 {
8141 dVAR;
8142 const U32 seq = intro_my();
8143 const U32 utf8 = flags & SVf_UTF8;
8144 COP *cop;
8145
8146 PL_parser->parsed_sub = 0;
8147
8148 flags &= ~SVf_UTF8;
8149
8150 NewOp(1101, cop, 1, COP);
8151 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8152 OpTYPE_set(cop, OP_DBSTATE);
8153 }
8154 else {
8155 OpTYPE_set(cop, OP_NEXTSTATE);
8156 }
8157 cop->op_flags = (U8)flags;
8158 CopHINTS_set(cop, PL_hints);
8159 #ifdef VMS
8160 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
8161 #endif
8162 cop->op_next = (OP*)cop;
8163
8164 cop->cop_seq = seq;
8165 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8166 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
8167 if (label) {
8168 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
8169
8170 PL_hints |= HINT_BLOCK_SCOPE;
8171 /* It seems that we need to defer freeing this pointer, as other parts
8172 of the grammar end up wanting to copy it after this op has been
8173 created. */
8174 SAVEFREEPV(label);
8175 }
8176
8177 if (PL_parser->preambling != NOLINE) {
8178 CopLINE_set(cop, PL_parser->preambling);
8179 PL_parser->copline = NOLINE;
8180 }
8181 else if (PL_parser->copline == NOLINE)
8182 CopLINE_set(cop, CopLINE(PL_curcop));
8183 else {
8184 CopLINE_set(cop, PL_parser->copline);
8185 PL_parser->copline = NOLINE;
8186 }
8187 #ifdef USE_ITHREADS
8188 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
8189 #else
8190 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
8191 #endif
8192 CopSTASH_set(cop, PL_curstash);
8193
8194 if (cop->op_type == OP_DBSTATE) {
8195 /* this line can have a breakpoint - store the cop in IV */
8196 AV *av = CopFILEAVx(PL_curcop);
8197 if (av) {
8198 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
8199 if (svp && *svp != &PL_sv_undef ) {
8200 (void)SvIOK_on(*svp);
8201 SvIV_set(*svp, PTR2IV(cop));
8202 }
8203 }
8204 }
8205
8206 if (flags & OPf_SPECIAL)
8207 op_null((OP*)cop);
8208 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
8209 }
8210
8211 /*
8212 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
8213
8214 Constructs, checks, and returns a logical (flow control) op. C<type>
8215 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
8216 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
8217 the eight bits of C<op_private>, except that the bit with value 1 is
8218 automatically set. C<first> supplies the expression controlling the
8219 flow, and C<other> supplies the side (alternate) chain of ops; they are
8220 consumed by this function and become part of the constructed op tree.
8221
8222 =cut
8223 */
8224
8225 OP *
Perl_newLOGOP(pTHX_ I32 type,I32 flags,OP * first,OP * other)8226 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
8227 {
8228 PERL_ARGS_ASSERT_NEWLOGOP;
8229
8230 return new_logop(type, flags, &first, &other);
8231 }
8232
8233 STATIC OP *
S_search_const(pTHX_ OP * o)8234 S_search_const(pTHX_ OP *o)
8235 {
8236 PERL_ARGS_ASSERT_SEARCH_CONST;
8237
8238 switch (o->op_type) {
8239 case OP_CONST:
8240 return o;
8241 case OP_NULL:
8242 if (o->op_flags & OPf_KIDS)
8243 return search_const(cUNOPo->op_first);
8244 break;
8245 case OP_LEAVE:
8246 case OP_SCOPE:
8247 case OP_LINESEQ:
8248 {
8249 OP *kid;
8250 if (!(o->op_flags & OPf_KIDS))
8251 return NULL;
8252 kid = cLISTOPo->op_first;
8253 do {
8254 switch (kid->op_type) {
8255 case OP_ENTER:
8256 case OP_NULL:
8257 case OP_NEXTSTATE:
8258 kid = OpSIBLING(kid);
8259 break;
8260 default:
8261 if (kid != cLISTOPo->op_last)
8262 return NULL;
8263 goto last;
8264 }
8265 } while (kid);
8266 if (!kid)
8267 kid = cLISTOPo->op_last;
8268 last:
8269 return search_const(kid);
8270 }
8271 }
8272
8273 return NULL;
8274 }
8275
8276 STATIC OP *
S_new_logop(pTHX_ I32 type,I32 flags,OP ** firstp,OP ** otherp)8277 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
8278 {
8279 dVAR;
8280 LOGOP *logop;
8281 OP *o;
8282 OP *first;
8283 OP *other;
8284 OP *cstop = NULL;
8285 int prepend_not = 0;
8286
8287 PERL_ARGS_ASSERT_NEW_LOGOP;
8288
8289 first = *firstp;
8290 other = *otherp;
8291
8292 /* [perl #59802]: Warn about things like "return $a or $b", which
8293 is parsed as "(return $a) or $b" rather than "return ($a or
8294 $b)". NB: This also applies to xor, which is why we do it
8295 here.
8296 */
8297 switch (first->op_type) {
8298 case OP_NEXT:
8299 case OP_LAST:
8300 case OP_REDO:
8301 /* XXX: Perhaps we should emit a stronger warning for these.
8302 Even with the high-precedence operator they don't seem to do
8303 anything sensible.
8304
8305 But until we do, fall through here.
8306 */
8307 case OP_RETURN:
8308 case OP_EXIT:
8309 case OP_DIE:
8310 case OP_GOTO:
8311 /* XXX: Currently we allow people to "shoot themselves in the
8312 foot" by explicitly writing "(return $a) or $b".
8313
8314 Warn unless we are looking at the result from folding or if
8315 the programmer explicitly grouped the operators like this.
8316 The former can occur with e.g.
8317
8318 use constant FEATURE => ( $] >= ... );
8319 sub { not FEATURE and return or do_stuff(); }
8320 */
8321 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
8322 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8323 "Possible precedence issue with control flow operator");
8324 /* XXX: Should we optimze this to "return $a;" (i.e. remove
8325 the "or $b" part)?
8326 */
8327 break;
8328 }
8329
8330 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
8331 return newBINOP(type, flags, scalar(first), scalar(other));
8332
8333 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
8334 || type == OP_CUSTOM);
8335
8336 scalarboolean(first);
8337
8338 /* search for a constant op that could let us fold the test */
8339 if ((cstop = search_const(first))) {
8340 if (cstop->op_private & OPpCONST_STRICT)
8341 no_bareword_allowed(cstop);
8342 else if ((cstop->op_private & OPpCONST_BARE))
8343 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
8344 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
8345 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
8346 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
8347 /* Elide the (constant) lhs, since it can't affect the outcome */
8348 *firstp = NULL;
8349 if (other->op_type == OP_CONST)
8350 other->op_private |= OPpCONST_SHORTCIRCUIT;
8351 op_free(first);
8352 if (other->op_type == OP_LEAVE)
8353 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
8354 else if (other->op_type == OP_MATCH
8355 || other->op_type == OP_SUBST
8356 || other->op_type == OP_TRANSR
8357 || other->op_type == OP_TRANS)
8358 /* Mark the op as being unbindable with =~ */
8359 other->op_flags |= OPf_SPECIAL;
8360
8361 other->op_folded = 1;
8362 return other;
8363 }
8364 else {
8365 /* Elide the rhs, since the outcome is entirely determined by
8366 * the (constant) lhs */
8367
8368 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
8369 const OP *o2 = other;
8370 if ( ! (o2->op_type == OP_LIST
8371 && (( o2 = cUNOPx(o2)->op_first))
8372 && o2->op_type == OP_PUSHMARK
8373 && (( o2 = OpSIBLING(o2))) )
8374 )
8375 o2 = other;
8376 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
8377 || o2->op_type == OP_PADHV)
8378 && o2->op_private & OPpLVAL_INTRO
8379 && !(o2->op_private & OPpPAD_STATE))
8380 {
8381 Perl_croak(aTHX_ "This use of my() in false conditional is "
8382 "no longer allowed");
8383 }
8384
8385 *otherp = NULL;
8386 if (cstop->op_type == OP_CONST)
8387 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
8388 op_free(other);
8389 return first;
8390 }
8391 }
8392 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
8393 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
8394 {
8395 const OP * const k1 = ((UNOP*)first)->op_first;
8396 const OP * const k2 = OpSIBLING(k1);
8397 OPCODE warnop = 0;
8398 switch (first->op_type)
8399 {
8400 case OP_NULL:
8401 if (k2 && k2->op_type == OP_READLINE
8402 && (k2->op_flags & OPf_STACKED)
8403 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8404 {
8405 warnop = k2->op_type;
8406 }
8407 break;
8408
8409 case OP_SASSIGN:
8410 if (k1->op_type == OP_READDIR
8411 || k1->op_type == OP_GLOB
8412 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8413 || k1->op_type == OP_EACH
8414 || k1->op_type == OP_AEACH)
8415 {
8416 warnop = ((k1->op_type == OP_NULL)
8417 ? (OPCODE)k1->op_targ : k1->op_type);
8418 }
8419 break;
8420 }
8421 if (warnop) {
8422 const line_t oldline = CopLINE(PL_curcop);
8423 /* This ensures that warnings are reported at the first line
8424 of the construction, not the last. */
8425 CopLINE_set(PL_curcop, PL_parser->copline);
8426 Perl_warner(aTHX_ packWARN(WARN_MISC),
8427 "Value of %s%s can be \"0\"; test with defined()",
8428 PL_op_desc[warnop],
8429 ((warnop == OP_READLINE || warnop == OP_GLOB)
8430 ? " construct" : "() operator"));
8431 CopLINE_set(PL_curcop, oldline);
8432 }
8433 }
8434
8435 /* optimize AND and OR ops that have NOTs as children */
8436 if (first->op_type == OP_NOT
8437 && (first->op_flags & OPf_KIDS)
8438 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
8439 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
8440 ) {
8441 if (type == OP_AND || type == OP_OR) {
8442 if (type == OP_AND)
8443 type = OP_OR;
8444 else
8445 type = OP_AND;
8446 op_null(first);
8447 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
8448 op_null(other);
8449 prepend_not = 1; /* prepend a NOT op later */
8450 }
8451 }
8452 }
8453
8454 logop = alloc_LOGOP(type, first, LINKLIST(other));
8455 logop->op_flags |= (U8)flags;
8456 logop->op_private = (U8)(1 | (flags >> 8));
8457
8458 /* establish postfix order */
8459 logop->op_next = LINKLIST(first);
8460 first->op_next = (OP*)logop;
8461 assert(!OpHAS_SIBLING(first));
8462 op_sibling_splice((OP*)logop, first, 0, other);
8463
8464 CHECKOP(type,logop);
8465
8466 o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
8467 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
8468 (OP*)logop);
8469 other->op_next = o;
8470
8471 return o;
8472 }
8473
8474 /*
8475 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
8476
8477 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
8478 op. C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
8479 will be set automatically, and, shifted up eight bits, the eight bits of
8480 C<op_private>, except that the bit with value 1 is automatically set.
8481 C<first> supplies the expression selecting between the two branches,
8482 and C<trueop> and C<falseop> supply the branches; they are consumed by
8483 this function and become part of the constructed op tree.
8484
8485 =cut
8486 */
8487
8488 OP *
Perl_newCONDOP(pTHX_ I32 flags,OP * first,OP * trueop,OP * falseop)8489 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
8490 {
8491 dVAR;
8492 LOGOP *logop;
8493 OP *start;
8494 OP *o;
8495 OP *cstop;
8496
8497 PERL_ARGS_ASSERT_NEWCONDOP;
8498
8499 if (!falseop)
8500 return newLOGOP(OP_AND, 0, first, trueop);
8501 if (!trueop)
8502 return newLOGOP(OP_OR, 0, first, falseop);
8503
8504 scalarboolean(first);
8505 if ((cstop = search_const(first))) {
8506 /* Left or right arm of the conditional? */
8507 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
8508 OP *live = left ? trueop : falseop;
8509 OP *const dead = left ? falseop : trueop;
8510 if (cstop->op_private & OPpCONST_BARE &&
8511 cstop->op_private & OPpCONST_STRICT) {
8512 no_bareword_allowed(cstop);
8513 }
8514 op_free(first);
8515 op_free(dead);
8516 if (live->op_type == OP_LEAVE)
8517 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
8518 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
8519 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
8520 /* Mark the op as being unbindable with =~ */
8521 live->op_flags |= OPf_SPECIAL;
8522 live->op_folded = 1;
8523 return live;
8524 }
8525 logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
8526 logop->op_flags |= (U8)flags;
8527 logop->op_private = (U8)(1 | (flags >> 8));
8528 logop->op_next = LINKLIST(falseop);
8529
8530 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
8531 logop);
8532
8533 /* establish postfix order */
8534 start = LINKLIST(first);
8535 first->op_next = (OP*)logop;
8536
8537 /* make first, trueop, falseop siblings */
8538 op_sibling_splice((OP*)logop, first, 0, trueop);
8539 op_sibling_splice((OP*)logop, trueop, 0, falseop);
8540
8541 o = newUNOP(OP_NULL, 0, (OP*)logop);
8542
8543 trueop->op_next = falseop->op_next = o;
8544
8545 o->op_next = start;
8546 return o;
8547 }
8548
8549 /*
8550 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
8551
8552 Constructs and returns a C<range> op, with subordinate C<flip> and
8553 C<flop> ops. C<flags> gives the eight bits of C<op_flags> for the
8554 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
8555 for both the C<flip> and C<range> ops, except that the bit with value
8556 1 is automatically set. C<left> and C<right> supply the expressions
8557 controlling the endpoints of the range; they are consumed by this function
8558 and become part of the constructed op tree.
8559
8560 =cut
8561 */
8562
8563 OP *
Perl_newRANGE(pTHX_ I32 flags,OP * left,OP * right)8564 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
8565 {
8566 LOGOP *range;
8567 OP *flip;
8568 OP *flop;
8569 OP *leftstart;
8570 OP *o;
8571
8572 PERL_ARGS_ASSERT_NEWRANGE;
8573
8574 range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
8575 range->op_flags = OPf_KIDS;
8576 leftstart = LINKLIST(left);
8577 range->op_private = (U8)(1 | (flags >> 8));
8578
8579 /* make left and right siblings */
8580 op_sibling_splice((OP*)range, left, 0, right);
8581
8582 range->op_next = (OP*)range;
8583 flip = newUNOP(OP_FLIP, flags, (OP*)range);
8584 flop = newUNOP(OP_FLOP, 0, flip);
8585 o = newUNOP(OP_NULL, 0, flop);
8586 LINKLIST(flop);
8587 range->op_next = leftstart;
8588
8589 left->op_next = flip;
8590 right->op_next = flop;
8591
8592 range->op_targ =
8593 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
8594 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
8595 flip->op_targ =
8596 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
8597 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
8598 SvPADTMP_on(PAD_SV(flip->op_targ));
8599
8600 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8601 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8602
8603 /* check barewords before they might be optimized aways */
8604 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
8605 no_bareword_allowed(left);
8606 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
8607 no_bareword_allowed(right);
8608
8609 flip->op_next = o;
8610 if (!flip->op_private || !flop->op_private)
8611 LINKLIST(o); /* blow off optimizer unless constant */
8612
8613 return o;
8614 }
8615
8616 /*
8617 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
8618
8619 Constructs, checks, and returns an op tree expressing a loop. This is
8620 only a loop in the control flow through the op tree; it does not have
8621 the heavyweight loop structure that allows exiting the loop by C<last>
8622 and suchlike. C<flags> gives the eight bits of C<op_flags> for the
8623 top-level op, except that some bits will be set automatically as required.
8624 C<expr> supplies the expression controlling loop iteration, and C<block>
8625 supplies the body of the loop; they are consumed by this function and
8626 become part of the constructed op tree. C<debuggable> is currently
8627 unused and should always be 1.
8628
8629 =cut
8630 */
8631
8632 OP *
Perl_newLOOPOP(pTHX_ I32 flags,I32 debuggable,OP * expr,OP * block)8633 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
8634 {
8635 OP* listop;
8636 OP* o;
8637 const bool once = block && block->op_flags & OPf_SPECIAL &&
8638 block->op_type == OP_NULL;
8639
8640 PERL_UNUSED_ARG(debuggable);
8641
8642 if (expr) {
8643 if (once && (
8644 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
8645 || ( expr->op_type == OP_NOT
8646 && cUNOPx(expr)->op_first->op_type == OP_CONST
8647 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
8648 )
8649 ))
8650 /* Return the block now, so that S_new_logop does not try to
8651 fold it away. */
8652 {
8653 op_free(expr);
8654 return block; /* do {} while 0 does once */
8655 }
8656
8657 if (expr->op_type == OP_READLINE
8658 || expr->op_type == OP_READDIR
8659 || expr->op_type == OP_GLOB
8660 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8661 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8662 expr = newUNOP(OP_DEFINED, 0,
8663 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8664 } else if (expr->op_flags & OPf_KIDS) {
8665 const OP * const k1 = ((UNOP*)expr)->op_first;
8666 const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
8667 switch (expr->op_type) {
8668 case OP_NULL:
8669 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8670 && (k2->op_flags & OPf_STACKED)
8671 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8672 expr = newUNOP(OP_DEFINED, 0, expr);
8673 break;
8674
8675 case OP_SASSIGN:
8676 if (k1 && (k1->op_type == OP_READDIR
8677 || k1->op_type == OP_GLOB
8678 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8679 || k1->op_type == OP_EACH
8680 || k1->op_type == OP_AEACH))
8681 expr = newUNOP(OP_DEFINED, 0, expr);
8682 break;
8683 }
8684 }
8685 }
8686
8687 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
8688 * op, in listop. This is wrong. [perl #27024] */
8689 if (!block)
8690 block = newOP(OP_NULL, 0);
8691 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
8692 o = new_logop(OP_AND, 0, &expr, &listop);
8693
8694 if (once) {
8695 ASSUME(listop);
8696 }
8697
8698 if (listop)
8699 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
8700
8701 if (once && o != listop)
8702 {
8703 assert(cUNOPo->op_first->op_type == OP_AND
8704 || cUNOPo->op_first->op_type == OP_OR);
8705 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
8706 }
8707
8708 if (o == listop)
8709 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
8710
8711 o->op_flags |= flags;
8712 o = op_scope(o);
8713 o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
8714 return o;
8715 }
8716
8717 /*
8718 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
8719
8720 Constructs, checks, and returns an op tree expressing a C<while> loop.
8721 This is a heavyweight loop, with structure that allows exiting the loop
8722 by C<last> and suchlike.
8723
8724 C<loop> is an optional preconstructed C<enterloop> op to use in the
8725 loop; if it is null then a suitable op will be constructed automatically.
8726 C<expr> supplies the loop's controlling expression. C<block> supplies the
8727 main body of the loop, and C<cont> optionally supplies a C<continue> block
8728 that operates as a second half of the body. All of these optree inputs
8729 are consumed by this function and become part of the constructed op tree.
8730
8731 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8732 op and, shifted up eight bits, the eight bits of C<op_private> for
8733 the C<leaveloop> op, except that (in both cases) some bits will be set
8734 automatically. C<debuggable> is currently unused and should always be 1.
8735 C<has_my> can be supplied as true to force the
8736 loop body to be enclosed in its own scope.
8737
8738 =cut
8739 */
8740
8741 OP *
Perl_newWHILEOP(pTHX_ I32 flags,I32 debuggable,LOOP * loop,OP * expr,OP * block,OP * cont,I32 has_my)8742 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
8743 OP *expr, OP *block, OP *cont, I32 has_my)
8744 {
8745 dVAR;
8746 OP *redo;
8747 OP *next = NULL;
8748 OP *listop;
8749 OP *o;
8750 U8 loopflags = 0;
8751
8752 PERL_UNUSED_ARG(debuggable);
8753
8754 if (expr) {
8755 if (expr->op_type == OP_READLINE
8756 || expr->op_type == OP_READDIR
8757 || expr->op_type == OP_GLOB
8758 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8759 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8760 expr = newUNOP(OP_DEFINED, 0,
8761 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8762 } else if (expr->op_flags & OPf_KIDS) {
8763 const OP * const k1 = ((UNOP*)expr)->op_first;
8764 const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
8765 switch (expr->op_type) {
8766 case OP_NULL:
8767 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8768 && (k2->op_flags & OPf_STACKED)
8769 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8770 expr = newUNOP(OP_DEFINED, 0, expr);
8771 break;
8772
8773 case OP_SASSIGN:
8774 if (k1 && (k1->op_type == OP_READDIR
8775 || k1->op_type == OP_GLOB
8776 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8777 || k1->op_type == OP_EACH
8778 || k1->op_type == OP_AEACH))
8779 expr = newUNOP(OP_DEFINED, 0, expr);
8780 break;
8781 }
8782 }
8783 }
8784
8785 if (!block)
8786 block = newOP(OP_NULL, 0);
8787 else if (cont || has_my) {
8788 block = op_scope(block);
8789 }
8790
8791 if (cont) {
8792 next = LINKLIST(cont);
8793 }
8794 if (expr) {
8795 OP * const unstack = newOP(OP_UNSTACK, 0);
8796 if (!next)
8797 next = unstack;
8798 cont = op_append_elem(OP_LINESEQ, cont, unstack);
8799 }
8800
8801 assert(block);
8802 listop = op_append_list(OP_LINESEQ, block, cont);
8803 assert(listop);
8804 redo = LINKLIST(listop);
8805
8806 if (expr) {
8807 scalar(listop);
8808 o = new_logop(OP_AND, 0, &expr, &listop);
8809 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
8810 op_free((OP*)loop);
8811 return expr; /* listop already freed by new_logop */
8812 }
8813 if (listop)
8814 ((LISTOP*)listop)->op_last->op_next =
8815 (o == listop ? redo : LINKLIST(o));
8816 }
8817 else
8818 o = listop;
8819
8820 if (!loop) {
8821 NewOp(1101,loop,1,LOOP);
8822 OpTYPE_set(loop, OP_ENTERLOOP);
8823 loop->op_private = 0;
8824 loop->op_next = (OP*)loop;
8825 }
8826
8827 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
8828
8829 loop->op_redoop = redo;
8830 loop->op_lastop = o;
8831 o->op_private |= loopflags;
8832
8833 if (next)
8834 loop->op_nextop = next;
8835 else
8836 loop->op_nextop = o;
8837
8838 o->op_flags |= flags;
8839 o->op_private |= (flags >> 8);
8840 return o;
8841 }
8842
8843 /*
8844 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
8845
8846 Constructs, checks, and returns an op tree expressing a C<foreach>
8847 loop (iteration through a list of values). This is a heavyweight loop,
8848 with structure that allows exiting the loop by C<last> and suchlike.
8849
8850 C<sv> optionally supplies the variable that will be aliased to each
8851 item in turn; if null, it defaults to C<$_>.
8852 C<expr> supplies the list of values to iterate over. C<block> supplies
8853 the main body of the loop, and C<cont> optionally supplies a C<continue>
8854 block that operates as a second half of the body. All of these optree
8855 inputs are consumed by this function and become part of the constructed
8856 op tree.
8857
8858 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8859 op and, shifted up eight bits, the eight bits of C<op_private> for
8860 the C<leaveloop> op, except that (in both cases) some bits will be set
8861 automatically.
8862
8863 =cut
8864 */
8865
8866 OP *
Perl_newFOROP(pTHX_ I32 flags,OP * sv,OP * expr,OP * block,OP * cont)8867 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
8868 {
8869 dVAR;
8870 LOOP *loop;
8871 OP *wop;
8872 PADOFFSET padoff = 0;
8873 I32 iterflags = 0;
8874 I32 iterpflags = 0;
8875
8876 PERL_ARGS_ASSERT_NEWFOROP;
8877
8878 if (sv) {
8879 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
8880 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
8881 OpTYPE_set(sv, OP_RV2GV);
8882
8883 /* The op_type check is needed to prevent a possible segfault
8884 * if the loop variable is undeclared and 'strict vars' is in
8885 * effect. This is illegal but is nonetheless parsed, so we
8886 * may reach this point with an OP_CONST where we're expecting
8887 * an OP_GV.
8888 */
8889 if (cUNOPx(sv)->op_first->op_type == OP_GV
8890 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
8891 iterpflags |= OPpITER_DEF;
8892 }
8893 else if (sv->op_type == OP_PADSV) { /* private variable */
8894 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
8895 padoff = sv->op_targ;
8896 sv->op_targ = 0;
8897 op_free(sv);
8898 sv = NULL;
8899 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
8900 }
8901 else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
8902 NOOP;
8903 else
8904 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
8905 if (padoff) {
8906 PADNAME * const pn = PAD_COMPNAME(padoff);
8907 const char * const name = PadnamePV(pn);
8908
8909 if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
8910 iterpflags |= OPpITER_DEF;
8911 }
8912 }
8913 else {
8914 sv = newGVOP(OP_GV, 0, PL_defgv);
8915 iterpflags |= OPpITER_DEF;
8916 }
8917
8918 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
8919 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
8920 iterflags |= OPf_STACKED;
8921 }
8922 else if (expr->op_type == OP_NULL &&
8923 (expr->op_flags & OPf_KIDS) &&
8924 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
8925 {
8926 /* Basically turn for($x..$y) into the same as for($x,$y), but we
8927 * set the STACKED flag to indicate that these values are to be
8928 * treated as min/max values by 'pp_enteriter'.
8929 */
8930 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
8931 LOGOP* const range = (LOGOP*) flip->op_first;
8932 OP* const left = range->op_first;
8933 OP* const right = OpSIBLING(left);
8934 LISTOP* listop;
8935
8936 range->op_flags &= ~OPf_KIDS;
8937 /* detach range's children */
8938 op_sibling_splice((OP*)range, NULL, -1, NULL);
8939
8940 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
8941 listop->op_first->op_next = range->op_next;
8942 left->op_next = range->op_other;
8943 right->op_next = (OP*)listop;
8944 listop->op_next = listop->op_first;
8945
8946 op_free(expr);
8947 expr = (OP*)(listop);
8948 op_null(expr);
8949 iterflags |= OPf_STACKED;
8950 }
8951 else {
8952 expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
8953 }
8954
8955 loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
8956 op_append_elem(OP_LIST, list(expr),
8957 scalar(sv)));
8958 assert(!loop->op_next);
8959 /* for my $x () sets OPpLVAL_INTRO;
8960 * for our $x () sets OPpOUR_INTRO */
8961 loop->op_private = (U8)iterpflags;
8962 if (loop->op_slabbed
8963 && DIFF(loop, OpSLOT(loop)->opslot_next)
8964 < SIZE_TO_PSIZE(sizeof(LOOP)))
8965 {
8966 LOOP *tmp;
8967 NewOp(1234,tmp,1,LOOP);
8968 Copy(loop,tmp,1,LISTOP);
8969 assert(loop->op_last->op_sibparent == (OP*)loop);
8970 OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
8971 S_op_destroy(aTHX_ (OP*)loop);
8972 loop = tmp;
8973 }
8974 else if (!loop->op_slabbed)
8975 {
8976 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
8977 OpLASTSIB_set(loop->op_last, (OP*)loop);
8978 }
8979 loop->op_targ = padoff;
8980 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
8981 return wop;
8982 }
8983
8984 /*
8985 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
8986
8987 Constructs, checks, and returns a loop-exiting op (such as C<goto>
8988 or C<last>). C<type> is the opcode. C<label> supplies the parameter
8989 determining the target of the op; it is consumed by this function and
8990 becomes part of the constructed op tree.
8991
8992 =cut
8993 */
8994
8995 OP*
Perl_newLOOPEX(pTHX_ I32 type,OP * label)8996 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8997 {
8998 OP *o = NULL;
8999
9000 PERL_ARGS_ASSERT_NEWLOOPEX;
9001
9002 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
9003 || type == OP_CUSTOM);
9004
9005 if (type != OP_GOTO) {
9006 /* "last()" means "last" */
9007 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
9008 o = newOP(type, OPf_SPECIAL);
9009 }
9010 }
9011 else {
9012 /* Check whether it's going to be a goto &function */
9013 if (label->op_type == OP_ENTERSUB
9014 && !(label->op_flags & OPf_STACKED))
9015 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
9016 }
9017
9018 /* Check for a constant argument */
9019 if (label->op_type == OP_CONST) {
9020 SV * const sv = ((SVOP *)label)->op_sv;
9021 STRLEN l;
9022 const char *s = SvPV_const(sv,l);
9023 if (l == strlen(s)) {
9024 o = newPVOP(type,
9025 SvUTF8(((SVOP*)label)->op_sv),
9026 savesharedpv(
9027 SvPV_nolen_const(((SVOP*)label)->op_sv)));
9028 }
9029 }
9030
9031 /* If we have already created an op, we do not need the label. */
9032 if (o)
9033 op_free(label);
9034 else o = newUNOP(type, OPf_STACKED, label);
9035
9036 PL_hints |= HINT_BLOCK_SCOPE;
9037 return o;
9038 }
9039
9040 /* if the condition is a literal array or hash
9041 (or @{ ... } etc), make a reference to it.
9042 */
9043 STATIC OP *
S_ref_array_or_hash(pTHX_ OP * cond)9044 S_ref_array_or_hash(pTHX_ OP *cond)
9045 {
9046 if (cond
9047 && (cond->op_type == OP_RV2AV
9048 || cond->op_type == OP_PADAV
9049 || cond->op_type == OP_RV2HV
9050 || cond->op_type == OP_PADHV))
9051
9052 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
9053
9054 else if(cond
9055 && (cond->op_type == OP_ASLICE
9056 || cond->op_type == OP_KVASLICE
9057 || cond->op_type == OP_HSLICE
9058 || cond->op_type == OP_KVHSLICE)) {
9059
9060 /* anonlist now needs a list from this op, was previously used in
9061 * scalar context */
9062 cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
9063 cond->op_flags |= OPf_WANT_LIST;
9064
9065 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
9066 }
9067
9068 else
9069 return cond;
9070 }
9071
9072 /* These construct the optree fragments representing given()
9073 and when() blocks.
9074
9075 entergiven and enterwhen are LOGOPs; the op_other pointer
9076 points up to the associated leave op. We need this so we
9077 can put it in the context and make break/continue work.
9078 (Also, of course, pp_enterwhen will jump straight to
9079 op_other if the match fails.)
9080 */
9081
9082 STATIC OP *
S_newGIVWHENOP(pTHX_ OP * cond,OP * block,I32 enter_opcode,I32 leave_opcode,PADOFFSET entertarg)9083 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
9084 I32 enter_opcode, I32 leave_opcode,
9085 PADOFFSET entertarg)
9086 {
9087 dVAR;
9088 LOGOP *enterop;
9089 OP *o;
9090
9091 PERL_ARGS_ASSERT_NEWGIVWHENOP;
9092 PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
9093
9094 enterop = alloc_LOGOP(enter_opcode, block, NULL);
9095 enterop->op_targ = 0;
9096 enterop->op_private = 0;
9097
9098 o = newUNOP(leave_opcode, 0, (OP *) enterop);
9099
9100 if (cond) {
9101 /* prepend cond if we have one */
9102 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
9103
9104 o->op_next = LINKLIST(cond);
9105 cond->op_next = (OP *) enterop;
9106 }
9107 else {
9108 /* This is a default {} block */
9109 enterop->op_flags |= OPf_SPECIAL;
9110 o ->op_flags |= OPf_SPECIAL;
9111
9112 o->op_next = (OP *) enterop;
9113 }
9114
9115 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
9116 entergiven and enterwhen both
9117 use ck_null() */
9118
9119 enterop->op_next = LINKLIST(block);
9120 block->op_next = enterop->op_other = o;
9121
9122 return o;
9123 }
9124
9125 /* Does this look like a boolean operation? For these purposes
9126 a boolean operation is:
9127 - a subroutine call [*]
9128 - a logical connective
9129 - a comparison operator
9130 - a filetest operator, with the exception of -s -M -A -C
9131 - defined(), exists() or eof()
9132 - /$re/ or $foo =~ /$re/
9133
9134 [*] possibly surprising
9135 */
9136 STATIC bool
S_looks_like_bool(pTHX_ const OP * o)9137 S_looks_like_bool(pTHX_ const OP *o)
9138 {
9139 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
9140
9141 switch(o->op_type) {
9142 case OP_OR:
9143 case OP_DOR:
9144 return looks_like_bool(cLOGOPo->op_first);
9145
9146 case OP_AND:
9147 {
9148 OP* sibl = OpSIBLING(cLOGOPo->op_first);
9149 ASSUME(sibl);
9150 return (
9151 looks_like_bool(cLOGOPo->op_first)
9152 && looks_like_bool(sibl));
9153 }
9154
9155 case OP_NULL:
9156 case OP_SCALAR:
9157 return (
9158 o->op_flags & OPf_KIDS
9159 && looks_like_bool(cUNOPo->op_first));
9160
9161 case OP_ENTERSUB:
9162
9163 case OP_NOT: case OP_XOR:
9164
9165 case OP_EQ: case OP_NE: case OP_LT:
9166 case OP_GT: case OP_LE: case OP_GE:
9167
9168 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
9169 case OP_I_GT: case OP_I_LE: case OP_I_GE:
9170
9171 case OP_SEQ: case OP_SNE: case OP_SLT:
9172 case OP_SGT: case OP_SLE: case OP_SGE:
9173
9174 case OP_SMARTMATCH:
9175
9176 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
9177 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
9178 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
9179 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
9180 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
9181 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
9182 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
9183 case OP_FTTEXT: case OP_FTBINARY:
9184
9185 case OP_DEFINED: case OP_EXISTS:
9186 case OP_MATCH: case OP_EOF:
9187
9188 case OP_FLOP:
9189
9190 return TRUE;
9191
9192 case OP_INDEX:
9193 case OP_RINDEX:
9194 /* optimised-away (index() != -1) or similar comparison */
9195 if (o->op_private & OPpTRUEBOOL)
9196 return TRUE;
9197 return FALSE;
9198
9199 case OP_CONST:
9200 /* Detect comparisons that have been optimized away */
9201 if (cSVOPo->op_sv == &PL_sv_yes
9202 || cSVOPo->op_sv == &PL_sv_no)
9203
9204 return TRUE;
9205 else
9206 return FALSE;
9207 /* FALLTHROUGH */
9208 default:
9209 return FALSE;
9210 }
9211 }
9212
9213 /*
9214 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
9215
9216 Constructs, checks, and returns an op tree expressing a C<given> block.
9217 C<cond> supplies the expression to whose value C<$_> will be locally
9218 aliased, and C<block> supplies the body of the C<given> construct; they
9219 are consumed by this function and become part of the constructed op tree.
9220 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
9221
9222 =cut
9223 */
9224
9225 OP *
Perl_newGIVENOP(pTHX_ OP * cond,OP * block,PADOFFSET defsv_off)9226 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
9227 {
9228 PERL_ARGS_ASSERT_NEWGIVENOP;
9229 PERL_UNUSED_ARG(defsv_off);
9230
9231 assert(!defsv_off);
9232 return newGIVWHENOP(
9233 ref_array_or_hash(cond),
9234 block,
9235 OP_ENTERGIVEN, OP_LEAVEGIVEN,
9236 0);
9237 }
9238
9239 /*
9240 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
9241
9242 Constructs, checks, and returns an op tree expressing a C<when> block.
9243 C<cond> supplies the test expression, and C<block> supplies the block
9244 that will be executed if the test evaluates to true; they are consumed
9245 by this function and become part of the constructed op tree. C<cond>
9246 will be interpreted DWIMically, often as a comparison against C<$_>,
9247 and may be null to generate a C<default> block.
9248
9249 =cut
9250 */
9251
9252 OP *
Perl_newWHENOP(pTHX_ OP * cond,OP * block)9253 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
9254 {
9255 const bool cond_llb = (!cond || looks_like_bool(cond));
9256 OP *cond_op;
9257
9258 PERL_ARGS_ASSERT_NEWWHENOP;
9259
9260 if (cond_llb)
9261 cond_op = cond;
9262 else {
9263 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
9264 newDEFSVOP(),
9265 scalar(ref_array_or_hash(cond)));
9266 }
9267
9268 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
9269 }
9270
9271 /* must not conflict with SVf_UTF8 */
9272 #define CV_CKPROTO_CURSTASH 0x1
9273
9274 void
Perl_cv_ckproto_len_flags(pTHX_ const CV * cv,const GV * gv,const char * p,const STRLEN len,const U32 flags)9275 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
9276 const STRLEN len, const U32 flags)
9277 {
9278 SV *name = NULL, *msg;
9279 const char * cvp = SvROK(cv)
9280 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
9281 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
9282 : ""
9283 : CvPROTO(cv);
9284 STRLEN clen = CvPROTOLEN(cv), plen = len;
9285
9286 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
9287
9288 if (p == NULL && cvp == NULL)
9289 return;
9290
9291 if (!ckWARN_d(WARN_PROTOTYPE))
9292 return;
9293
9294 if (p && cvp) {
9295 p = S_strip_spaces(aTHX_ p, &plen);
9296 cvp = S_strip_spaces(aTHX_ cvp, &clen);
9297 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
9298 if (plen == clen && memEQ(cvp, p, plen))
9299 return;
9300 } else {
9301 if (flags & SVf_UTF8) {
9302 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
9303 return;
9304 }
9305 else {
9306 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
9307 return;
9308 }
9309 }
9310 }
9311
9312 msg = sv_newmortal();
9313
9314 if (gv)
9315 {
9316 if (isGV(gv))
9317 gv_efullname3(name = sv_newmortal(), gv, NULL);
9318 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
9319 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
9320 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
9321 name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
9322 sv_catpvs(name, "::");
9323 if (SvROK(gv)) {
9324 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
9325 assert (CvNAMED(SvRV_const(gv)));
9326 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
9327 }
9328 else sv_catsv(name, (SV *)gv);
9329 }
9330 else name = (SV *)gv;
9331 }
9332 sv_setpvs(msg, "Prototype mismatch:");
9333 if (name)
9334 Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
9335 if (cvp)
9336 Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
9337 UTF8fARG(SvUTF8(cv),clen,cvp)
9338 );
9339 else
9340 sv_catpvs(msg, ": none");
9341 sv_catpvs(msg, " vs ");
9342 if (p)
9343 Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
9344 else
9345 sv_catpvs(msg, "none");
9346 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
9347 }
9348
9349 static void const_sv_xsub(pTHX_ CV* cv);
9350 static void const_av_xsub(pTHX_ CV* cv);
9351
9352 /*
9353
9354 =head1 Optree Manipulation Functions
9355
9356 =for apidoc cv_const_sv
9357
9358 If C<cv> is a constant sub eligible for inlining, returns the constant
9359 value returned by the sub. Otherwise, returns C<NULL>.
9360
9361 Constant subs can be created with C<newCONSTSUB> or as described in
9362 L<perlsub/"Constant Functions">.
9363
9364 =cut
9365 */
9366 SV *
Perl_cv_const_sv(const CV * const cv)9367 Perl_cv_const_sv(const CV *const cv)
9368 {
9369 SV *sv;
9370 if (!cv)
9371 return NULL;
9372 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
9373 return NULL;
9374 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9375 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
9376 return sv;
9377 }
9378
9379 SV *
Perl_cv_const_sv_or_av(const CV * const cv)9380 Perl_cv_const_sv_or_av(const CV * const cv)
9381 {
9382 if (!cv)
9383 return NULL;
9384 if (SvROK(cv)) return SvRV((SV *)cv);
9385 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
9386 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9387 }
9388
9389 /* op_const_sv: examine an optree to determine whether it's in-lineable.
9390 * Can be called in 2 ways:
9391 *
9392 * !allow_lex
9393 * look for a single OP_CONST with attached value: return the value
9394 *
9395 * allow_lex && !CvCONST(cv);
9396 *
9397 * examine the clone prototype, and if contains only a single
9398 * OP_CONST, return the value; or if it contains a single PADSV ref-
9399 * erencing an outer lexical, turn on CvCONST to indicate the CV is
9400 * a candidate for "constizing" at clone time, and return NULL.
9401 */
9402
9403 static SV *
S_op_const_sv(pTHX_ const OP * o,CV * cv,bool allow_lex)9404 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
9405 {
9406 SV *sv = NULL;
9407 bool padsv = FALSE;
9408
9409 assert(o);
9410 assert(cv);
9411
9412 for (; o; o = o->op_next) {
9413 const OPCODE type = o->op_type;
9414
9415 if (type == OP_NEXTSTATE || type == OP_LINESEQ
9416 || type == OP_NULL
9417 || type == OP_PUSHMARK)
9418 continue;
9419 if (type == OP_DBSTATE)
9420 continue;
9421 if (type == OP_LEAVESUB)
9422 break;
9423 if (sv)
9424 return NULL;
9425 if (type == OP_CONST && cSVOPo->op_sv)
9426 sv = cSVOPo->op_sv;
9427 else if (type == OP_UNDEF && !o->op_private) {
9428 sv = newSV(0);
9429 SAVEFREESV(sv);
9430 }
9431 else if (allow_lex && type == OP_PADSV) {
9432 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
9433 {
9434 sv = &PL_sv_undef; /* an arbitrary non-null value */
9435 padsv = TRUE;
9436 }
9437 else
9438 return NULL;
9439 }
9440 else {
9441 return NULL;
9442 }
9443 }
9444 if (padsv) {
9445 CvCONST_on(cv);
9446 return NULL;
9447 }
9448 return sv;
9449 }
9450
9451 static void
S_already_defined(pTHX_ CV * const cv,OP * const block,OP * const o,PADNAME * const name,SV ** const const_svp)9452 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
9453 PADNAME * const name, SV ** const const_svp)
9454 {
9455 assert (cv);
9456 assert (o || name);
9457 assert (const_svp);
9458 if (!block) {
9459 if (CvFLAGS(PL_compcv)) {
9460 /* might have had built-in attrs applied */
9461 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
9462 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
9463 && ckWARN(WARN_MISC))
9464 {
9465 /* protect against fatal warnings leaking compcv */
9466 SAVEFREESV(PL_compcv);
9467 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
9468 SvREFCNT_inc_simple_void_NN(PL_compcv);
9469 }
9470 CvFLAGS(cv) |=
9471 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
9472 & ~(CVf_LVALUE * pureperl));
9473 }
9474 return;
9475 }
9476
9477 /* redundant check for speed: */
9478 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
9479 const line_t oldline = CopLINE(PL_curcop);
9480 SV *namesv = o
9481 ? cSVOPo->op_sv
9482 : sv_2mortal(newSVpvn_utf8(
9483 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
9484 ));
9485 if (PL_parser && PL_parser->copline != NOLINE)
9486 /* This ensures that warnings are reported at the first
9487 line of a redefinition, not the last. */
9488 CopLINE_set(PL_curcop, PL_parser->copline);
9489 /* protect against fatal warnings leaking compcv */
9490 SAVEFREESV(PL_compcv);
9491 report_redefined_cv(namesv, cv, const_svp);
9492 SvREFCNT_inc_simple_void_NN(PL_compcv);
9493 CopLINE_set(PL_curcop, oldline);
9494 }
9495 SAVEFREESV(cv);
9496 return;
9497 }
9498
9499 CV *
Perl_newMYSUB(pTHX_ I32 floor,OP * o,OP * proto,OP * attrs,OP * block)9500 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
9501 {
9502 CV **spot;
9503 SV **svspot;
9504 const char *ps;
9505 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9506 U32 ps_utf8 = 0;
9507 CV *cv = NULL;
9508 CV *compcv = PL_compcv;
9509 SV *const_sv;
9510 PADNAME *name;
9511 PADOFFSET pax = o->op_targ;
9512 CV *outcv = CvOUTSIDE(PL_compcv);
9513 CV *clonee = NULL;
9514 HEK *hek = NULL;
9515 bool reusable = FALSE;
9516 OP *start = NULL;
9517 #ifdef PERL_DEBUG_READONLY_OPS
9518 OPSLAB *slab = NULL;
9519 #endif
9520
9521 PERL_ARGS_ASSERT_NEWMYSUB;
9522
9523 PL_hints |= HINT_BLOCK_SCOPE;
9524
9525 /* Find the pad slot for storing the new sub.
9526 We cannot use PL_comppad, as it is the pad owned by the new sub. We
9527 need to look in CvOUTSIDE and find the pad belonging to the enclos-
9528 ing sub. And then we need to dig deeper if this is a lexical from
9529 outside, as in:
9530 my sub foo; sub { sub foo { } }
9531 */
9532 redo:
9533 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
9534 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
9535 pax = PARENT_PAD_INDEX(name);
9536 outcv = CvOUTSIDE(outcv);
9537 assert(outcv);
9538 goto redo;
9539 }
9540 svspot =
9541 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
9542 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
9543 spot = (CV **)svspot;
9544
9545 if (!(PL_parser && PL_parser->error_count))
9546 move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
9547
9548 if (proto) {
9549 assert(proto->op_type == OP_CONST);
9550 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
9551 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
9552 }
9553 else
9554 ps = NULL;
9555
9556 if (proto)
9557 SAVEFREEOP(proto);
9558 if (attrs)
9559 SAVEFREEOP(attrs);
9560
9561 if (PL_parser && PL_parser->error_count) {
9562 op_free(block);
9563 SvREFCNT_dec(PL_compcv);
9564 PL_compcv = 0;
9565 goto done;
9566 }
9567
9568 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9569 cv = *spot;
9570 svspot = (SV **)(spot = &clonee);
9571 }
9572 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
9573 cv = *spot;
9574 else {
9575 assert (SvTYPE(*spot) == SVt_PVCV);
9576 if (CvNAMED(*spot))
9577 hek = CvNAME_HEK(*spot);
9578 else {
9579 dVAR;
9580 U32 hash;
9581 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9582 CvNAME_HEK_set(*spot, hek =
9583 share_hek(
9584 PadnamePV(name)+1,
9585 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9586 hash
9587 )
9588 );
9589 CvLEXICAL_on(*spot);
9590 }
9591 cv = PadnamePROTOCV(name);
9592 svspot = (SV **)(spot = &PadnamePROTOCV(name));
9593 }
9594
9595 if (block) {
9596 /* This makes sub {}; work as expected. */
9597 if (block->op_type == OP_STUB) {
9598 const line_t l = PL_parser->copline;
9599 op_free(block);
9600 block = newSTATEOP(0, NULL, 0);
9601 PL_parser->copline = l;
9602 }
9603 block = CvLVALUE(compcv)
9604 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
9605 ? newUNOP(OP_LEAVESUBLV, 0,
9606 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
9607 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
9608 start = LINKLIST(block);
9609 block->op_next = 0;
9610 if (ps && !*ps && !attrs && !CvLVALUE(compcv))
9611 const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
9612 else
9613 const_sv = NULL;
9614 }
9615 else
9616 const_sv = NULL;
9617
9618 if (cv) {
9619 const bool exists = CvROOT(cv) || CvXSUB(cv);
9620
9621 /* if the subroutine doesn't exist and wasn't pre-declared
9622 * with a prototype, assume it will be AUTOLOADed,
9623 * skipping the prototype check
9624 */
9625 if (exists || SvPOK(cv))
9626 cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
9627 ps_utf8);
9628 /* already defined? */
9629 if (exists) {
9630 S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
9631 if (block)
9632 cv = NULL;
9633 else {
9634 if (attrs)
9635 goto attrs;
9636 /* just a "sub foo;" when &foo is already defined */
9637 SAVEFREESV(compcv);
9638 goto done;
9639 }
9640 }
9641 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9642 cv = NULL;
9643 reusable = TRUE;
9644 }
9645 }
9646
9647 if (const_sv) {
9648 SvREFCNT_inc_simple_void_NN(const_sv);
9649 SvFLAGS(const_sv) |= SVs_PADTMP;
9650 if (cv) {
9651 assert(!CvROOT(cv) && !CvCONST(cv));
9652 cv_forget_slab(cv);
9653 }
9654 else {
9655 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9656 CvFILE_set_from_cop(cv, PL_curcop);
9657 CvSTASH_set(cv, PL_curstash);
9658 *spot = cv;
9659 }
9660 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
9661 CvXSUBANY(cv).any_ptr = const_sv;
9662 CvXSUB(cv) = const_sv_xsub;
9663 CvCONST_on(cv);
9664 CvISXSUB_on(cv);
9665 PoisonPADLIST(cv);
9666 CvFLAGS(cv) |= CvMETHOD(compcv);
9667 op_free(block);
9668 SvREFCNT_dec(compcv);
9669 PL_compcv = NULL;
9670 goto setname;
9671 }
9672
9673 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
9674 determine whether this sub definition is in the same scope as its
9675 declaration. If this sub definition is inside an inner named pack-
9676 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
9677 the package sub. So check PadnameOUTER(name) too.
9678 */
9679 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
9680 assert(!CvWEAKOUTSIDE(compcv));
9681 SvREFCNT_dec(CvOUTSIDE(compcv));
9682 CvWEAKOUTSIDE_on(compcv);
9683 }
9684 /* XXX else do we have a circular reference? */
9685
9686 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
9687 /* transfer PL_compcv to cv */
9688 if (block) {
9689 bool free_file = CvFILE(cv) && CvDYNFILE(cv);
9690 cv_flags_t preserved_flags =
9691 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
9692 PADLIST *const temp_padl = CvPADLIST(cv);
9693 CV *const temp_cv = CvOUTSIDE(cv);
9694 const cv_flags_t other_flags =
9695 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
9696 OP * const cvstart = CvSTART(cv);
9697
9698 SvPOK_off(cv);
9699 CvFLAGS(cv) =
9700 CvFLAGS(compcv) | preserved_flags;
9701 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
9702 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
9703 CvPADLIST_set(cv, CvPADLIST(compcv));
9704 CvOUTSIDE(compcv) = temp_cv;
9705 CvPADLIST_set(compcv, temp_padl);
9706 CvSTART(cv) = CvSTART(compcv);
9707 CvSTART(compcv) = cvstart;
9708 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
9709 CvFLAGS(compcv) |= other_flags;
9710
9711 if (free_file) {
9712 Safefree(CvFILE(cv));
9713 CvFILE(cv) = NULL;
9714 }
9715
9716 /* inner references to compcv must be fixed up ... */
9717 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
9718 if (PERLDB_INTER)/* Advice debugger on the new sub. */
9719 ++PL_sub_generation;
9720 }
9721 else {
9722 /* Might have had built-in attributes applied -- propagate them. */
9723 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
9724 }
9725 /* ... before we throw it away */
9726 SvREFCNT_dec(compcv);
9727 PL_compcv = compcv = cv;
9728 }
9729 else {
9730 cv = compcv;
9731 *spot = cv;
9732 }
9733
9734 setname:
9735 CvLEXICAL_on(cv);
9736 if (!CvNAME_HEK(cv)) {
9737 if (hek) (void)share_hek_hek(hek);
9738 else {
9739 dVAR;
9740 U32 hash;
9741 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9742 hek = share_hek(PadnamePV(name)+1,
9743 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9744 hash);
9745 }
9746 CvNAME_HEK_set(cv, hek);
9747 }
9748
9749 if (const_sv)
9750 goto clone;
9751
9752 if (CvFILE(cv) && CvDYNFILE(cv))
9753 Safefree(CvFILE(cv));
9754 CvFILE_set_from_cop(cv, PL_curcop);
9755 CvSTASH_set(cv, PL_curstash);
9756
9757 if (ps) {
9758 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
9759 if (ps_utf8)
9760 SvUTF8_on(MUTABLE_SV(cv));
9761 }
9762
9763 if (block) {
9764 /* If we assign an optree to a PVCV, then we've defined a
9765 * subroutine that the debugger could be able to set a breakpoint
9766 * in, so signal to pp_entereval that it should not throw away any
9767 * saved lines at scope exit. */
9768
9769 PL_breakable_sub_gen++;
9770 CvROOT(cv) = block;
9771 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
9772 itself has a refcount. */
9773 CvSLABBED_off(cv);
9774 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
9775 #ifdef PERL_DEBUG_READONLY_OPS
9776 slab = (OPSLAB *)CvSTART(cv);
9777 #endif
9778 S_process_optree(aTHX_ cv, block, start);
9779 }
9780
9781 attrs:
9782 if (attrs) {
9783 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
9784 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
9785 }
9786
9787 if (block) {
9788 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
9789 SV * const tmpstr = sv_newmortal();
9790 GV * const db_postponed = gv_fetchpvs("DB::postponed",
9791 GV_ADDMULTI, SVt_PVHV);
9792 HV *hv;
9793 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
9794 CopFILE(PL_curcop),
9795 (long)PL_subline,
9796 (long)CopLINE(PL_curcop));
9797 if (HvNAME_HEK(PL_curstash)) {
9798 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
9799 sv_catpvs(tmpstr, "::");
9800 }
9801 else
9802 sv_setpvs(tmpstr, "__ANON__::");
9803
9804 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
9805 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
9806 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
9807 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
9808 hv = GvHVn(db_postponed);
9809 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
9810 CV * const pcv = GvCV(db_postponed);
9811 if (pcv) {
9812 dSP;
9813 PUSHMARK(SP);
9814 XPUSHs(tmpstr);
9815 PUTBACK;
9816 call_sv(MUTABLE_SV(pcv), G_DISCARD);
9817 }
9818 }
9819 }
9820 }
9821
9822 clone:
9823 if (clonee) {
9824 assert(CvDEPTH(outcv));
9825 spot = (CV **)
9826 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
9827 if (reusable)
9828 cv_clone_into(clonee, *spot);
9829 else *spot = cv_clone(clonee);
9830 SvREFCNT_dec_NN(clonee);
9831 cv = *spot;
9832 }
9833
9834 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
9835 PADOFFSET depth = CvDEPTH(outcv);
9836 while (--depth) {
9837 SV *oldcv;
9838 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
9839 oldcv = *svspot;
9840 *svspot = SvREFCNT_inc_simple_NN(cv);
9841 SvREFCNT_dec(oldcv);
9842 }
9843 }
9844
9845 done:
9846 if (PL_parser)
9847 PL_parser->copline = NOLINE;
9848 LEAVE_SCOPE(floor);
9849 #ifdef PERL_DEBUG_READONLY_OPS
9850 if (slab)
9851 Slab_to_ro(slab);
9852 #endif
9853 op_free(o);
9854 return cv;
9855 }
9856
9857 /*
9858 =for apidoc m|CV *|newATTRSUB_x|I32 floor|OP *o|OP *proto|OP *attrs|OP *block|bool o_is_gv
9859
9860 Construct a Perl subroutine, also performing some surrounding jobs.
9861
9862 This function is expected to be called in a Perl compilation context,
9863 and some aspects of the subroutine are taken from global variables
9864 associated with compilation. In particular, C<PL_compcv> represents
9865 the subroutine that is currently being compiled. It must be non-null
9866 when this function is called, and some aspects of the subroutine being
9867 constructed are taken from it. The constructed subroutine may actually
9868 be a reuse of the C<PL_compcv> object, but will not necessarily be so.
9869
9870 If C<block> is null then the subroutine will have no body, and for the
9871 time being it will be an error to call it. This represents a forward
9872 subroutine declaration such as S<C<sub foo ($$);>>. If C<block> is
9873 non-null then it provides the Perl code of the subroutine body, which
9874 will be executed when the subroutine is called. This body includes
9875 any argument unwrapping code resulting from a subroutine signature or
9876 similar. The pad use of the code must correspond to the pad attached
9877 to C<PL_compcv>. The code is not expected to include a C<leavesub> or
9878 C<leavesublv> op; this function will add such an op. C<block> is consumed
9879 by this function and will become part of the constructed subroutine.
9880
9881 C<proto> specifies the subroutine's prototype, unless one is supplied
9882 as an attribute (see below). If C<proto> is null, then the subroutine
9883 will not have a prototype. If C<proto> is non-null, it must point to a
9884 C<const> op whose value is a string, and the subroutine will have that
9885 string as its prototype. If a prototype is supplied as an attribute, the
9886 attribute takes precedence over C<proto>, but in that case C<proto> should
9887 preferably be null. In any case, C<proto> is consumed by this function.
9888
9889 C<attrs> supplies attributes to be applied the subroutine. A handful of
9890 attributes take effect by built-in means, being applied to C<PL_compcv>
9891 immediately when seen. Other attributes are collected up and attached
9892 to the subroutine by this route. C<attrs> may be null to supply no
9893 attributes, or point to a C<const> op for a single attribute, or point
9894 to a C<list> op whose children apart from the C<pushmark> are C<const>
9895 ops for one or more attributes. Each C<const> op must be a string,
9896 giving the attribute name optionally followed by parenthesised arguments,
9897 in the manner in which attributes appear in Perl source. The attributes
9898 will be applied to the sub by this function. C<attrs> is consumed by
9899 this function.
9900
9901 If C<o_is_gv> is false and C<o> is null, then the subroutine will
9902 be anonymous. If C<o_is_gv> is false and C<o> is non-null, then C<o>
9903 must point to a C<const> op, which will be consumed by this function,
9904 and its string value supplies a name for the subroutine. The name may
9905 be qualified or unqualified, and if it is unqualified then a default
9906 stash will be selected in some manner. If C<o_is_gv> is true, then C<o>
9907 doesn't point to an C<OP> at all, but is instead a cast pointer to a C<GV>
9908 by which the subroutine will be named.
9909
9910 If there is already a subroutine of the specified name, then the new
9911 sub will either replace the existing one in the glob or be merged with
9912 the existing one. A warning may be generated about redefinition.
9913
9914 If the subroutine has one of a few special names, such as C<BEGIN> or
9915 C<END>, then it will be claimed by the appropriate queue for automatic
9916 running of phase-related subroutines. In this case the relevant glob will
9917 be left not containing any subroutine, even if it did contain one before.
9918 In the case of C<BEGIN>, the subroutine will be executed and the reference
9919 to it disposed of before this function returns.
9920
9921 The function returns a pointer to the constructed subroutine. If the sub
9922 is anonymous then ownership of one counted reference to the subroutine
9923 is transferred to the caller. If the sub is named then the caller does
9924 not get ownership of a reference. In most such cases, where the sub
9925 has a non-phase name, the sub will be alive at the point it is returned
9926 by virtue of being contained in the glob that names it. A phase-named
9927 subroutine will usually be alive by virtue of the reference owned by the
9928 phase's automatic run queue. But a C<BEGIN> subroutine, having already
9929 been executed, will quite likely have been destroyed already by the
9930 time this function returns, making it erroneous for the caller to make
9931 any use of the returned pointer. It is the caller's responsibility to
9932 ensure that it knows which of these situations applies.
9933
9934 =cut
9935 */
9936
9937 /* _x = extended */
9938 CV *
Perl_newATTRSUB_x(pTHX_ I32 floor,OP * o,OP * proto,OP * attrs,OP * block,bool o_is_gv)9939 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
9940 OP *block, bool o_is_gv)
9941 {
9942 GV *gv;
9943 const char *ps;
9944 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9945 U32 ps_utf8 = 0;
9946 CV *cv = NULL; /* the previous CV with this name, if any */
9947 SV *const_sv;
9948 const bool ec = PL_parser && PL_parser->error_count;
9949 /* If the subroutine has no body, no attributes, and no builtin attributes
9950 then it's just a sub declaration, and we may be able to get away with
9951 storing with a placeholder scalar in the symbol table, rather than a
9952 full CV. If anything is present then it will take a full CV to
9953 store it. */
9954 const I32 gv_fetch_flags
9955 = ec ? GV_NOADD_NOINIT :
9956 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
9957 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
9958 STRLEN namlen = 0;
9959 const char * const name =
9960 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
9961 bool has_name;
9962 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
9963 bool evanescent = FALSE;
9964 OP *start = NULL;
9965 #ifdef PERL_DEBUG_READONLY_OPS
9966 OPSLAB *slab = NULL;
9967 #endif
9968
9969 if (o_is_gv) {
9970 gv = (GV*)o;
9971 o = NULL;
9972 has_name = TRUE;
9973 } else if (name) {
9974 /* Try to optimise and avoid creating a GV. Instead, the CV’s name
9975 hek and CvSTASH pointer together can imply the GV. If the name
9976 contains a package name, then GvSTASH(CvGV(cv)) may differ from
9977 CvSTASH, so forego the optimisation if we find any.
9978 Also, we may be called from load_module at run time, so
9979 PL_curstash (which sets CvSTASH) may not point to the stash the
9980 sub is stored in. */
9981 /* XXX This optimization is currently disabled for packages other
9982 than main, since there was too much CPAN breakage. */
9983 const I32 flags =
9984 ec ? GV_NOADD_NOINIT
9985 : (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
9986 || PL_curstash != PL_defstash
9987 || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
9988 ? gv_fetch_flags
9989 : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
9990 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
9991 has_name = TRUE;
9992 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
9993 SV * const sv = sv_newmortal();
9994 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
9995 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
9996 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
9997 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
9998 has_name = TRUE;
9999 } else if (PL_curstash) {
10000 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
10001 has_name = FALSE;
10002 } else {
10003 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
10004 has_name = FALSE;
10005 }
10006
10007 if (!ec) {
10008 if (isGV(gv)) {
10009 move_proto_attr(&proto, &attrs, gv, 0);
10010 } else {
10011 assert(cSVOPo);
10012 move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
10013 }
10014 }
10015
10016 if (proto) {
10017 assert(proto->op_type == OP_CONST);
10018 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
10019 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
10020 }
10021 else
10022 ps = NULL;
10023
10024 if (o)
10025 SAVEFREEOP(o);
10026 if (proto)
10027 SAVEFREEOP(proto);
10028 if (attrs)
10029 SAVEFREEOP(attrs);
10030
10031 if (ec) {
10032 op_free(block);
10033
10034 if (name)
10035 SvREFCNT_dec(PL_compcv);
10036 else
10037 cv = PL_compcv;
10038
10039 PL_compcv = 0;
10040 if (name && block) {
10041 const char *s = (char *) my_memrchr(name, ':', namlen);
10042 s = s ? s+1 : name;
10043 if (strEQ(s, "BEGIN")) {
10044 if (PL_in_eval & EVAL_KEEPERR)
10045 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
10046 else {
10047 SV * const errsv = ERRSV;
10048 /* force display of errors found but not reported */
10049 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
10050 Perl_croak_nocontext("%" SVf, SVfARG(errsv));
10051 }
10052 }
10053 }
10054 goto done;
10055 }
10056
10057 if (!block && SvTYPE(gv) != SVt_PVGV) {
10058 /* If we are not defining a new sub and the existing one is not a
10059 full GV + CV... */
10060 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
10061 /* We are applying attributes to an existing sub, so we need it
10062 upgraded if it is a constant. */
10063 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
10064 gv_init_pvn(gv, PL_curstash, name, namlen,
10065 SVf_UTF8 * name_is_utf8);
10066 }
10067 else { /* Maybe prototype now, and had at maximum
10068 a prototype or const/sub ref before. */
10069 if (SvTYPE(gv) > SVt_NULL) {
10070 cv_ckproto_len_flags((const CV *)gv,
10071 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10072 ps_len, ps_utf8);
10073 }
10074
10075 if (!SvROK(gv)) {
10076 if (ps) {
10077 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
10078 if (ps_utf8)
10079 SvUTF8_on(MUTABLE_SV(gv));
10080 }
10081 else
10082 sv_setiv(MUTABLE_SV(gv), -1);
10083 }
10084
10085 SvREFCNT_dec(PL_compcv);
10086 cv = PL_compcv = NULL;
10087 goto done;
10088 }
10089 }
10090
10091 cv = (!name || (isGV(gv) && GvCVGEN(gv)))
10092 ? NULL
10093 : isGV(gv)
10094 ? GvCV(gv)
10095 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
10096 ? (CV *)SvRV(gv)
10097 : NULL;
10098
10099 if (block) {
10100 assert(PL_parser);
10101 /* This makes sub {}; work as expected. */
10102 if (block->op_type == OP_STUB) {
10103 const line_t l = PL_parser->copline;
10104 op_free(block);
10105 block = newSTATEOP(0, NULL, 0);
10106 PL_parser->copline = l;
10107 }
10108 block = CvLVALUE(PL_compcv)
10109 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
10110 && (!isGV(gv) || !GvASSUMECV(gv)))
10111 ? newUNOP(OP_LEAVESUBLV, 0,
10112 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
10113 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
10114 start = LINKLIST(block);
10115 block->op_next = 0;
10116 if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
10117 const_sv =
10118 S_op_const_sv(aTHX_ start, PL_compcv,
10119 cBOOL(CvCLONE(PL_compcv)));
10120 else
10121 const_sv = NULL;
10122 }
10123 else
10124 const_sv = NULL;
10125
10126 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
10127 cv_ckproto_len_flags((const CV *)gv,
10128 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10129 ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
10130 if (SvROK(gv)) {
10131 /* All the other code for sub redefinition warnings expects the
10132 clobbered sub to be a CV. Instead of making all those code
10133 paths more complex, just inline the RV version here. */
10134 const line_t oldline = CopLINE(PL_curcop);
10135 assert(IN_PERL_COMPILETIME);
10136 if (PL_parser && PL_parser->copline != NOLINE)
10137 /* This ensures that warnings are reported at the first
10138 line of a redefinition, not the last. */
10139 CopLINE_set(PL_curcop, PL_parser->copline);
10140 /* protect against fatal warnings leaking compcv */
10141 SAVEFREESV(PL_compcv);
10142
10143 if (ckWARN(WARN_REDEFINE)
10144 || ( ckWARN_d(WARN_REDEFINE)
10145 && ( !const_sv || SvRV(gv) == const_sv
10146 || sv_cmp(SvRV(gv), const_sv) ))) {
10147 assert(cSVOPo);
10148 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10149 "Constant subroutine %" SVf " redefined",
10150 SVfARG(cSVOPo->op_sv));
10151 }
10152
10153 SvREFCNT_inc_simple_void_NN(PL_compcv);
10154 CopLINE_set(PL_curcop, oldline);
10155 SvREFCNT_dec(SvRV(gv));
10156 }
10157 }
10158
10159 if (cv) {
10160 const bool exists = CvROOT(cv) || CvXSUB(cv);
10161
10162 /* if the subroutine doesn't exist and wasn't pre-declared
10163 * with a prototype, assume it will be AUTOLOADed,
10164 * skipping the prototype check
10165 */
10166 if (exists || SvPOK(cv))
10167 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
10168 /* already defined (or promised)? */
10169 if (exists || (isGV(gv) && GvASSUMECV(gv))) {
10170 S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
10171 if (block)
10172 cv = NULL;
10173 else {
10174 if (attrs)
10175 goto attrs;
10176 /* just a "sub foo;" when &foo is already defined */
10177 SAVEFREESV(PL_compcv);
10178 goto done;
10179 }
10180 }
10181 }
10182
10183 if (const_sv) {
10184 SvREFCNT_inc_simple_void_NN(const_sv);
10185 SvFLAGS(const_sv) |= SVs_PADTMP;
10186 if (cv) {
10187 assert(!CvROOT(cv) && !CvCONST(cv));
10188 cv_forget_slab(cv);
10189 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
10190 CvXSUBANY(cv).any_ptr = const_sv;
10191 CvXSUB(cv) = const_sv_xsub;
10192 CvCONST_on(cv);
10193 CvISXSUB_on(cv);
10194 PoisonPADLIST(cv);
10195 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
10196 }
10197 else {
10198 if (isGV(gv) || CvMETHOD(PL_compcv)) {
10199 if (name && isGV(gv))
10200 GvCV_set(gv, NULL);
10201 cv = newCONSTSUB_flags(
10202 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
10203 const_sv
10204 );
10205 assert(cv);
10206 assert(SvREFCNT((SV*)cv) != 0);
10207 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
10208 }
10209 else {
10210 if (!SvROK(gv)) {
10211 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10212 prepare_SV_for_RV((SV *)gv);
10213 SvOK_off((SV *)gv);
10214 SvROK_on(gv);
10215 }
10216 SvRV_set(gv, const_sv);
10217 }
10218 }
10219 op_free(block);
10220 SvREFCNT_dec(PL_compcv);
10221 PL_compcv = NULL;
10222 goto done;
10223 }
10224
10225 /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
10226 if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
10227 cv = NULL;
10228
10229 if (cv) { /* must reuse cv if autoloaded */
10230 /* transfer PL_compcv to cv */
10231 if (block) {
10232 bool free_file = CvFILE(cv) && CvDYNFILE(cv);
10233 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
10234 PADLIST *const temp_av = CvPADLIST(cv);
10235 CV *const temp_cv = CvOUTSIDE(cv);
10236 const cv_flags_t other_flags =
10237 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
10238 OP * const cvstart = CvSTART(cv);
10239
10240 if (isGV(gv)) {
10241 CvGV_set(cv,gv);
10242 assert(!CvCVGV_RC(cv));
10243 assert(CvGV(cv) == gv);
10244 }
10245 else {
10246 dVAR;
10247 U32 hash;
10248 PERL_HASH(hash, name, namlen);
10249 CvNAME_HEK_set(cv,
10250 share_hek(name,
10251 name_is_utf8
10252 ? -(SSize_t)namlen
10253 : (SSize_t)namlen,
10254 hash));
10255 }
10256
10257 SvPOK_off(cv);
10258 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
10259 | CvNAMED(cv);
10260 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
10261 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
10262 CvPADLIST_set(cv,CvPADLIST(PL_compcv));
10263 CvOUTSIDE(PL_compcv) = temp_cv;
10264 CvPADLIST_set(PL_compcv, temp_av);
10265 CvSTART(cv) = CvSTART(PL_compcv);
10266 CvSTART(PL_compcv) = cvstart;
10267 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10268 CvFLAGS(PL_compcv) |= other_flags;
10269
10270 if (free_file) {
10271 Safefree(CvFILE(cv));
10272 }
10273 CvFILE_set_from_cop(cv, PL_curcop);
10274 CvSTASH_set(cv, PL_curstash);
10275
10276 /* inner references to PL_compcv must be fixed up ... */
10277 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
10278 if (PERLDB_INTER)/* Advice debugger on the new sub. */
10279 ++PL_sub_generation;
10280 }
10281 else {
10282 /* Might have had built-in attributes applied -- propagate them. */
10283 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
10284 }
10285 /* ... before we throw it away */
10286 SvREFCNT_dec(PL_compcv);
10287 PL_compcv = cv;
10288 }
10289 else {
10290 cv = PL_compcv;
10291 if (name && isGV(gv)) {
10292 GvCV_set(gv, cv);
10293 GvCVGEN(gv) = 0;
10294 if (HvENAME_HEK(GvSTASH(gv)))
10295 /* sub Foo::bar { (shift)+1 } */
10296 gv_method_changed(gv);
10297 }
10298 else if (name) {
10299 if (!SvROK(gv)) {
10300 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10301 prepare_SV_for_RV((SV *)gv);
10302 SvOK_off((SV *)gv);
10303 SvROK_on(gv);
10304 }
10305 SvRV_set(gv, (SV *)cv);
10306 if (HvENAME_HEK(PL_curstash))
10307 mro_method_changed_in(PL_curstash);
10308 }
10309 }
10310 assert(cv);
10311 assert(SvREFCNT((SV*)cv) != 0);
10312
10313 if (!CvHASGV(cv)) {
10314 if (isGV(gv))
10315 CvGV_set(cv, gv);
10316 else {
10317 dVAR;
10318 U32 hash;
10319 PERL_HASH(hash, name, namlen);
10320 CvNAME_HEK_set(cv, share_hek(name,
10321 name_is_utf8
10322 ? -(SSize_t)namlen
10323 : (SSize_t)namlen,
10324 hash));
10325 }
10326 CvFILE_set_from_cop(cv, PL_curcop);
10327 CvSTASH_set(cv, PL_curstash);
10328 }
10329
10330 if (ps) {
10331 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
10332 if ( ps_utf8 )
10333 SvUTF8_on(MUTABLE_SV(cv));
10334 }
10335
10336 if (block) {
10337 /* If we assign an optree to a PVCV, then we've defined a
10338 * subroutine that the debugger could be able to set a breakpoint
10339 * in, so signal to pp_entereval that it should not throw away any
10340 * saved lines at scope exit. */
10341
10342 PL_breakable_sub_gen++;
10343 CvROOT(cv) = block;
10344 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
10345 itself has a refcount. */
10346 CvSLABBED_off(cv);
10347 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
10348 #ifdef PERL_DEBUG_READONLY_OPS
10349 slab = (OPSLAB *)CvSTART(cv);
10350 #endif
10351 S_process_optree(aTHX_ cv, block, start);
10352 }
10353
10354 attrs:
10355 if (attrs) {
10356 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
10357 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
10358 ? GvSTASH(CvGV(cv))
10359 : PL_curstash;
10360 if (!name)
10361 SAVEFREESV(cv);
10362 apply_attrs(stash, MUTABLE_SV(cv), attrs);
10363 if (!name)
10364 SvREFCNT_inc_simple_void_NN(cv);
10365 }
10366
10367 if (block && has_name) {
10368 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
10369 SV * const tmpstr = cv_name(cv,NULL,0);
10370 GV * const db_postponed = gv_fetchpvs("DB::postponed",
10371 GV_ADDMULTI, SVt_PVHV);
10372 HV *hv;
10373 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
10374 CopFILE(PL_curcop),
10375 (long)PL_subline,
10376 (long)CopLINE(PL_curcop));
10377 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
10378 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
10379 hv = GvHVn(db_postponed);
10380 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
10381 CV * const pcv = GvCV(db_postponed);
10382 if (pcv) {
10383 dSP;
10384 PUSHMARK(SP);
10385 XPUSHs(tmpstr);
10386 PUTBACK;
10387 call_sv(MUTABLE_SV(pcv), G_DISCARD);
10388 }
10389 }
10390 }
10391
10392 if (name) {
10393 if (PL_parser && PL_parser->error_count)
10394 clear_special_blocks(name, gv, cv);
10395 else
10396 evanescent =
10397 process_special_blocks(floor, name, gv, cv);
10398 }
10399 }
10400 assert(cv);
10401
10402 done:
10403 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10404 if (PL_parser)
10405 PL_parser->copline = NOLINE;
10406 LEAVE_SCOPE(floor);
10407
10408 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10409 if (!evanescent) {
10410 #ifdef PERL_DEBUG_READONLY_OPS
10411 if (slab)
10412 Slab_to_ro(slab);
10413 #endif
10414 if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
10415 pad_add_weakref(cv);
10416 }
10417 return cv;
10418 }
10419
10420 STATIC void
S_clear_special_blocks(pTHX_ const char * const fullname,GV * const gv,CV * const cv)10421 S_clear_special_blocks(pTHX_ const char *const fullname,
10422 GV *const gv, CV *const cv) {
10423 const char *colon;
10424 const char *name;
10425
10426 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
10427
10428 colon = strrchr(fullname,':');
10429 name = colon ? colon + 1 : fullname;
10430
10431 if ((*name == 'B' && strEQ(name, "BEGIN"))
10432 || (*name == 'E' && strEQ(name, "END"))
10433 || (*name == 'U' && strEQ(name, "UNITCHECK"))
10434 || (*name == 'C' && strEQ(name, "CHECK"))
10435 || (*name == 'I' && strEQ(name, "INIT"))) {
10436 if (!isGV(gv)) {
10437 (void)CvGV(cv);
10438 assert(isGV(gv));
10439 }
10440 GvCV_set(gv, NULL);
10441 SvREFCNT_dec_NN(MUTABLE_SV(cv));
10442 }
10443 }
10444
10445 /* Returns true if the sub has been freed. */
10446 STATIC bool
S_process_special_blocks(pTHX_ I32 floor,const char * const fullname,GV * const gv,CV * const cv)10447 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
10448 GV *const gv,
10449 CV *const cv)
10450 {
10451 const char *const colon = strrchr(fullname,':');
10452 const char *const name = colon ? colon + 1 : fullname;
10453
10454 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
10455
10456 if (*name == 'B') {
10457 if (strEQ(name, "BEGIN")) {
10458 const I32 oldscope = PL_scopestack_ix;
10459 dSP;
10460 (void)CvGV(cv);
10461 if (floor) LEAVE_SCOPE(floor);
10462 ENTER;
10463 PUSHSTACKi(PERLSI_REQUIRE);
10464 SAVECOPFILE(&PL_compiling);
10465 SAVECOPLINE(&PL_compiling);
10466 SAVEVPTR(PL_curcop);
10467
10468 DEBUG_x( dump_sub(gv) );
10469 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
10470 GvCV_set(gv,0); /* cv has been hijacked */
10471 call_list(oldscope, PL_beginav);
10472
10473 POPSTACK;
10474 LEAVE;
10475 return !PL_savebegin;
10476 }
10477 else
10478 return FALSE;
10479 } else {
10480 if (*name == 'E') {
10481 if strEQ(name, "END") {
10482 DEBUG_x( dump_sub(gv) );
10483 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
10484 } else
10485 return FALSE;
10486 } else if (*name == 'U') {
10487 if (strEQ(name, "UNITCHECK")) {
10488 /* It's never too late to run a unitcheck block */
10489 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
10490 }
10491 else
10492 return FALSE;
10493 } else if (*name == 'C') {
10494 if (strEQ(name, "CHECK")) {
10495 if (PL_main_start)
10496 /* diag_listed_as: Too late to run %s block */
10497 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10498 "Too late to run CHECK block");
10499 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
10500 }
10501 else
10502 return FALSE;
10503 } else if (*name == 'I') {
10504 if (strEQ(name, "INIT")) {
10505 if (PL_main_start)
10506 /* diag_listed_as: Too late to run %s block */
10507 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10508 "Too late to run INIT block");
10509 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
10510 }
10511 else
10512 return FALSE;
10513 } else
10514 return FALSE;
10515 DEBUG_x( dump_sub(gv) );
10516 (void)CvGV(cv);
10517 GvCV_set(gv,0); /* cv has been hijacked */
10518 return FALSE;
10519 }
10520 }
10521
10522 /*
10523 =for apidoc Am|CV *|newCONSTSUB|HV *stash|const char *name|SV *sv
10524
10525 Behaves like L</newCONSTSUB_flags>, except that C<name> is nul-terminated
10526 rather than of counted length, and no flags are set. (This means that
10527 C<name> is always interpreted as Latin-1.)
10528
10529 =cut
10530 */
10531
10532 CV *
Perl_newCONSTSUB(pTHX_ HV * stash,const char * name,SV * sv)10533 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
10534 {
10535 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
10536 }
10537
10538 /*
10539 =for apidoc Am|CV *|newCONSTSUB_flags|HV *stash|const char *name|STRLEN len|U32 flags|SV *sv
10540
10541 Construct a constant subroutine, also performing some surrounding
10542 jobs. A scalar constant-valued subroutine is eligible for inlining
10543 at compile-time, and in Perl code can be created by S<C<sub FOO () {
10544 123 }>>. Other kinds of constant subroutine have other treatment.
10545
10546 The subroutine will have an empty prototype and will ignore any arguments
10547 when called. Its constant behaviour is determined by C<sv>. If C<sv>
10548 is null, the subroutine will yield an empty list. If C<sv> points to a
10549 scalar, the subroutine will always yield that scalar. If C<sv> points
10550 to an array, the subroutine will always yield a list of the elements of
10551 that array in list context, or the number of elements in the array in
10552 scalar context. This function takes ownership of one counted reference
10553 to the scalar or array, and will arrange for the object to live as long
10554 as the subroutine does. If C<sv> points to a scalar then the inlining
10555 assumes that the value of the scalar will never change, so the caller
10556 must ensure that the scalar is not subsequently written to. If C<sv>
10557 points to an array then no such assumption is made, so it is ostensibly
10558 safe to mutate the array or its elements, but whether this is really
10559 supported has not been determined.
10560
10561 The subroutine will have C<CvFILE> set according to C<PL_curcop>.
10562 Other aspects of the subroutine will be left in their default state.
10563 The caller is free to mutate the subroutine beyond its initial state
10564 after this function has returned.
10565
10566 If C<name> is null then the subroutine will be anonymous, with its
10567 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
10568 subroutine will be named accordingly, referenced by the appropriate glob.
10569 C<name> is a string of length C<len> bytes giving a sigilless symbol
10570 name, in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1
10571 otherwise. The name may be either qualified or unqualified. If the
10572 name is unqualified then it defaults to being in the stash specified by
10573 C<stash> if that is non-null, or to C<PL_curstash> if C<stash> is null.
10574 The symbol is always added to the stash if necessary, with C<GV_ADDMULTI>
10575 semantics.
10576
10577 C<flags> should not have bits set other than C<SVf_UTF8>.
10578
10579 If there is already a subroutine of the specified name, then the new sub
10580 will replace the existing one in the glob. A warning may be generated
10581 about the redefinition.
10582
10583 If the subroutine has one of a few special names, such as C<BEGIN> or
10584 C<END>, then it will be claimed by the appropriate queue for automatic
10585 running of phase-related subroutines. In this case the relevant glob will
10586 be left not containing any subroutine, even if it did contain one before.
10587 Execution of the subroutine will likely be a no-op, unless C<sv> was
10588 a tied array or the caller modified the subroutine in some interesting
10589 way before it was executed. In the case of C<BEGIN>, the treatment is
10590 buggy: the sub will be executed when only half built, and may be deleted
10591 prematurely, possibly causing a crash.
10592
10593 The function returns a pointer to the constructed subroutine. If the sub
10594 is anonymous then ownership of one counted reference to the subroutine
10595 is transferred to the caller. If the sub is named then the caller does
10596 not get ownership of a reference. In most such cases, where the sub
10597 has a non-phase name, the sub will be alive at the point it is returned
10598 by virtue of being contained in the glob that names it. A phase-named
10599 subroutine will usually be alive by virtue of the reference owned by
10600 the phase's automatic run queue. A C<BEGIN> subroutine may have been
10601 destroyed already by the time this function returns, but currently bugs
10602 occur in that case before the caller gets control. It is the caller's
10603 responsibility to ensure that it knows which of these situations applies.
10604
10605 =cut
10606 */
10607
10608 CV *
Perl_newCONSTSUB_flags(pTHX_ HV * stash,const char * name,STRLEN len,U32 flags,SV * sv)10609 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
10610 U32 flags, SV *sv)
10611 {
10612 CV* cv;
10613 const char *const file = CopFILE(PL_curcop);
10614
10615 ENTER;
10616
10617 if (IN_PERL_RUNTIME) {
10618 /* at runtime, it's not safe to manipulate PL_curcop: it may be
10619 * an op shared between threads. Use a non-shared COP for our
10620 * dirty work */
10621 SAVEVPTR(PL_curcop);
10622 SAVECOMPILEWARNINGS();
10623 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
10624 PL_curcop = &PL_compiling;
10625 }
10626 SAVECOPLINE(PL_curcop);
10627 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
10628
10629 SAVEHINTS();
10630 PL_hints &= ~HINT_BLOCK_SCOPE;
10631
10632 if (stash) {
10633 SAVEGENERICSV(PL_curstash);
10634 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
10635 }
10636
10637 /* Protect sv against leakage caused by fatal warnings. */
10638 if (sv) SAVEFREESV(sv);
10639
10640 /* file becomes the CvFILE. For an XS, it's usually static storage,
10641 and so doesn't get free()d. (It's expected to be from the C pre-
10642 processor __FILE__ directive). But we need a dynamically allocated one,
10643 and we need it to get freed. */
10644 cv = newXS_len_flags(name, len,
10645 sv && SvTYPE(sv) == SVt_PVAV
10646 ? const_av_xsub
10647 : const_sv_xsub,
10648 file ? file : "", "",
10649 &sv, XS_DYNAMIC_FILENAME | flags);
10650 assert(cv);
10651 assert(SvREFCNT((SV*)cv) != 0);
10652 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
10653 CvCONST_on(cv);
10654
10655 LEAVE;
10656
10657 return cv;
10658 }
10659
10660 /*
10661 =for apidoc U||newXS
10662
10663 Used by C<xsubpp> to hook up XSUBs as Perl subs. C<filename> needs to be
10664 static storage, as it is used directly as CvFILE(), without a copy being made.
10665
10666 =cut
10667 */
10668
10669 CV *
Perl_newXS(pTHX_ const char * name,XSUBADDR_t subaddr,const char * filename)10670 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
10671 {
10672 PERL_ARGS_ASSERT_NEWXS;
10673 return newXS_len_flags(
10674 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
10675 );
10676 }
10677
10678 CV *
Perl_newXS_flags(pTHX_ const char * name,XSUBADDR_t subaddr,const char * const filename,const char * const proto,U32 flags)10679 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
10680 const char *const filename, const char *const proto,
10681 U32 flags)
10682 {
10683 PERL_ARGS_ASSERT_NEWXS_FLAGS;
10684 return newXS_len_flags(
10685 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
10686 );
10687 }
10688
10689 CV *
Perl_newXS_deffile(pTHX_ const char * name,XSUBADDR_t subaddr)10690 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
10691 {
10692 PERL_ARGS_ASSERT_NEWXS_DEFFILE;
10693 return newXS_len_flags(
10694 name, strlen(name), subaddr, NULL, NULL, NULL, 0
10695 );
10696 }
10697
10698 /*
10699 =for apidoc m|CV *|newXS_len_flags|const char *name|STRLEN len|XSUBADDR_t subaddr|const char *const filename|const char *const proto|SV **const_svp|U32 flags
10700
10701 Construct an XS subroutine, also performing some surrounding jobs.
10702
10703 The subroutine will have the entry point C<subaddr>. It will have
10704 the prototype specified by the nul-terminated string C<proto>, or
10705 no prototype if C<proto> is null. The prototype string is copied;
10706 the caller can mutate the supplied string afterwards. If C<filename>
10707 is non-null, it must be a nul-terminated filename, and the subroutine
10708 will have its C<CvFILE> set accordingly. By default C<CvFILE> is set to
10709 point directly to the supplied string, which must be static. If C<flags>
10710 has the C<XS_DYNAMIC_FILENAME> bit set, then a copy of the string will
10711 be taken instead.
10712
10713 Other aspects of the subroutine will be left in their default state.
10714 If anything else needs to be done to the subroutine for it to function
10715 correctly, it is the caller's responsibility to do that after this
10716 function has constructed it. However, beware of the subroutine
10717 potentially being destroyed before this function returns, as described
10718 below.
10719
10720 If C<name> is null then the subroutine will be anonymous, with its
10721 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
10722 subroutine will be named accordingly, referenced by the appropriate glob.
10723 C<name> is a string of length C<len> bytes giving a sigilless symbol name,
10724 in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 otherwise.
10725 The name may be either qualified or unqualified, with the stash defaulting
10726 in the same manner as for C<gv_fetchpvn_flags>. C<flags> may contain
10727 flag bits understood by C<gv_fetchpvn_flags> with the same meaning as
10728 they have there, such as C<GV_ADDWARN>. The symbol is always added to
10729 the stash if necessary, with C<GV_ADDMULTI> semantics.
10730
10731 If there is already a subroutine of the specified name, then the new sub
10732 will replace the existing one in the glob. A warning may be generated
10733 about the redefinition. If the old subroutine was C<CvCONST> then the
10734 decision about whether to warn is influenced by an expectation about
10735 whether the new subroutine will become a constant of similar value.
10736 That expectation is determined by C<const_svp>. (Note that the call to
10737 this function doesn't make the new subroutine C<CvCONST> in any case;
10738 that is left to the caller.) If C<const_svp> is null then it indicates
10739 that the new subroutine will not become a constant. If C<const_svp>
10740 is non-null then it indicates that the new subroutine will become a
10741 constant, and it points to an C<SV*> that provides the constant value
10742 that the subroutine will have.
10743
10744 If the subroutine has one of a few special names, such as C<BEGIN> or
10745 C<END>, then it will be claimed by the appropriate queue for automatic
10746 running of phase-related subroutines. In this case the relevant glob will
10747 be left not containing any subroutine, even if it did contain one before.
10748 In the case of C<BEGIN>, the subroutine will be executed and the reference
10749 to it disposed of before this function returns, and also before its
10750 prototype is set. If a C<BEGIN> subroutine would not be sufficiently
10751 constructed by this function to be ready for execution then the caller
10752 must prevent this happening by giving the subroutine a different name.
10753
10754 The function returns a pointer to the constructed subroutine. If the sub
10755 is anonymous then ownership of one counted reference to the subroutine
10756 is transferred to the caller. If the sub is named then the caller does
10757 not get ownership of a reference. In most such cases, where the sub
10758 has a non-phase name, the sub will be alive at the point it is returned
10759 by virtue of being contained in the glob that names it. A phase-named
10760 subroutine will usually be alive by virtue of the reference owned by the
10761 phase's automatic run queue. But a C<BEGIN> subroutine, having already
10762 been executed, will quite likely have been destroyed already by the
10763 time this function returns, making it erroneous for the caller to make
10764 any use of the returned pointer. It is the caller's responsibility to
10765 ensure that it knows which of these situations applies.
10766
10767 =cut
10768 */
10769
10770 CV *
Perl_newXS_len_flags(pTHX_ const char * name,STRLEN len,XSUBADDR_t subaddr,const char * const filename,const char * const proto,SV ** const_svp,U32 flags)10771 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
10772 XSUBADDR_t subaddr, const char *const filename,
10773 const char *const proto, SV **const_svp,
10774 U32 flags)
10775 {
10776 CV *cv;
10777 bool interleave = FALSE;
10778 bool evanescent = FALSE;
10779
10780 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
10781
10782 {
10783 GV * const gv = gv_fetchpvn(
10784 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
10785 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
10786 sizeof("__ANON__::__ANON__") - 1,
10787 GV_ADDMULTI | flags, SVt_PVCV);
10788
10789 if ((cv = (name ? GvCV(gv) : NULL))) {
10790 if (GvCVGEN(gv)) {
10791 /* just a cached method */
10792 SvREFCNT_dec(cv);
10793 cv = NULL;
10794 }
10795 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
10796 /* already defined (or promised) */
10797 /* Redundant check that allows us to avoid creating an SV
10798 most of the time: */
10799 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
10800 report_redefined_cv(newSVpvn_flags(
10801 name,len,(flags&SVf_UTF8)|SVs_TEMP
10802 ),
10803 cv, const_svp);
10804 }
10805 interleave = TRUE;
10806 ENTER;
10807 SAVEFREESV(cv);
10808 cv = NULL;
10809 }
10810 }
10811
10812 if (cv) /* must reuse cv if autoloaded */
10813 cv_undef(cv);
10814 else {
10815 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10816 if (name) {
10817 GvCV_set(gv,cv);
10818 GvCVGEN(gv) = 0;
10819 if (HvENAME_HEK(GvSTASH(gv)))
10820 gv_method_changed(gv); /* newXS */
10821 }
10822 }
10823 assert(cv);
10824 assert(SvREFCNT((SV*)cv) != 0);
10825
10826 CvGV_set(cv, gv);
10827 if(filename) {
10828 /* XSUBs can't be perl lang/perl5db.pl debugged
10829 if (PERLDB_LINE_OR_SAVESRC)
10830 (void)gv_fetchfile(filename); */
10831 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
10832 if (flags & XS_DYNAMIC_FILENAME) {
10833 CvDYNFILE_on(cv);
10834 CvFILE(cv) = savepv(filename);
10835 } else {
10836 /* NOTE: not copied, as it is expected to be an external constant string */
10837 CvFILE(cv) = (char *)filename;
10838 }
10839 } else {
10840 assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
10841 CvFILE(cv) = (char*)PL_xsubfilename;
10842 }
10843 CvISXSUB_on(cv);
10844 CvXSUB(cv) = subaddr;
10845 #ifndef PERL_IMPLICIT_CONTEXT
10846 CvHSCXT(cv) = &PL_stack_sp;
10847 #else
10848 PoisonPADLIST(cv);
10849 #endif
10850
10851 if (name)
10852 evanescent = process_special_blocks(0, name, gv, cv);
10853 else
10854 CvANON_on(cv);
10855 } /* <- not a conditional branch */
10856
10857 assert(cv);
10858 assert(evanescent || SvREFCNT((SV*)cv) != 0);
10859
10860 if (!evanescent) sv_setpv(MUTABLE_SV(cv), proto);
10861 if (interleave) LEAVE;
10862 assert(evanescent || SvREFCNT((SV*)cv) != 0);
10863 return cv;
10864 }
10865
10866 /* Add a stub CV to a typeglob.
10867 * This is the implementation of a forward declaration, 'sub foo';'
10868 */
10869
10870 CV *
Perl_newSTUB(pTHX_ GV * gv,bool fake)10871 Perl_newSTUB(pTHX_ GV *gv, bool fake)
10872 {
10873 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10874 GV *cvgv;
10875 PERL_ARGS_ASSERT_NEWSTUB;
10876 assert(!GvCVu(gv));
10877 GvCV_set(gv, cv);
10878 GvCVGEN(gv) = 0;
10879 if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
10880 gv_method_changed(gv);
10881 if (SvFAKE(gv)) {
10882 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
10883 SvFAKE_off(cvgv);
10884 }
10885 else cvgv = gv;
10886 CvGV_set(cv, cvgv);
10887 CvFILE_set_from_cop(cv, PL_curcop);
10888 CvSTASH_set(cv, PL_curstash);
10889 GvMULTI_on(gv);
10890 return cv;
10891 }
10892
10893 void
Perl_newFORM(pTHX_ I32 floor,OP * o,OP * block)10894 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
10895 {
10896 CV *cv;
10897 GV *gv;
10898 OP *root;
10899 OP *start;
10900
10901 if (PL_parser && PL_parser->error_count) {
10902 op_free(block);
10903 goto finish;
10904 }
10905
10906 gv = o
10907 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
10908 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
10909
10910 GvMULTI_on(gv);
10911 if ((cv = GvFORM(gv))) {
10912 if (ckWARN(WARN_REDEFINE)) {
10913 const line_t oldline = CopLINE(PL_curcop);
10914 if (PL_parser && PL_parser->copline != NOLINE)
10915 CopLINE_set(PL_curcop, PL_parser->copline);
10916 if (o) {
10917 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10918 "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
10919 } else {
10920 /* diag_listed_as: Format %s redefined */
10921 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10922 "Format STDOUT redefined");
10923 }
10924 CopLINE_set(PL_curcop, oldline);
10925 }
10926 SvREFCNT_dec(cv);
10927 }
10928 cv = PL_compcv;
10929 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
10930 CvGV_set(cv, gv);
10931 CvFILE_set_from_cop(cv, PL_curcop);
10932
10933
10934 root = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
10935 CvROOT(cv) = root;
10936 start = LINKLIST(root);
10937 root->op_next = 0;
10938 S_process_optree(aTHX_ cv, root, start);
10939 cv_forget_slab(cv);
10940
10941 finish:
10942 op_free(o);
10943 if (PL_parser)
10944 PL_parser->copline = NOLINE;
10945 LEAVE_SCOPE(floor);
10946 PL_compiling.cop_seq = 0;
10947 }
10948
10949 OP *
Perl_newANONLIST(pTHX_ OP * o)10950 Perl_newANONLIST(pTHX_ OP *o)
10951 {
10952 return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
10953 }
10954
10955 OP *
Perl_newANONHASH(pTHX_ OP * o)10956 Perl_newANONHASH(pTHX_ OP *o)
10957 {
10958 return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
10959 }
10960
10961 OP *
Perl_newANONSUB(pTHX_ I32 floor,OP * proto,OP * block)10962 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
10963 {
10964 return newANONATTRSUB(floor, proto, NULL, block);
10965 }
10966
10967 OP *
Perl_newANONATTRSUB(pTHX_ I32 floor,OP * proto,OP * attrs,OP * block)10968 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
10969 {
10970 SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
10971 OP * anoncode =
10972 newSVOP(OP_ANONCODE, 0,
10973 cv);
10974 if (CvANONCONST(cv))
10975 anoncode = newUNOP(OP_ANONCONST, 0,
10976 op_convert_list(OP_ENTERSUB,
10977 OPf_STACKED|OPf_WANT_SCALAR,
10978 anoncode));
10979 return newUNOP(OP_REFGEN, 0, anoncode);
10980 }
10981
10982 OP *
Perl_oopsAV(pTHX_ OP * o)10983 Perl_oopsAV(pTHX_ OP *o)
10984 {
10985 dVAR;
10986
10987 PERL_ARGS_ASSERT_OOPSAV;
10988
10989 switch (o->op_type) {
10990 case OP_PADSV:
10991 case OP_PADHV:
10992 OpTYPE_set(o, OP_PADAV);
10993 return ref(o, OP_RV2AV);
10994
10995 case OP_RV2SV:
10996 case OP_RV2HV:
10997 OpTYPE_set(o, OP_RV2AV);
10998 ref(o, OP_RV2AV);
10999 break;
11000
11001 default:
11002 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
11003 break;
11004 }
11005 return o;
11006 }
11007
11008 OP *
Perl_oopsHV(pTHX_ OP * o)11009 Perl_oopsHV(pTHX_ OP *o)
11010 {
11011 dVAR;
11012
11013 PERL_ARGS_ASSERT_OOPSHV;
11014
11015 switch (o->op_type) {
11016 case OP_PADSV:
11017 case OP_PADAV:
11018 OpTYPE_set(o, OP_PADHV);
11019 return ref(o, OP_RV2HV);
11020
11021 case OP_RV2SV:
11022 case OP_RV2AV:
11023 OpTYPE_set(o, OP_RV2HV);
11024 /* rv2hv steals the bottom bit for its own uses */
11025 o->op_private &= ~OPpARG1_MASK;
11026 ref(o, OP_RV2HV);
11027 break;
11028
11029 default:
11030 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
11031 break;
11032 }
11033 return o;
11034 }
11035
11036 OP *
Perl_newAVREF(pTHX_ OP * o)11037 Perl_newAVREF(pTHX_ OP *o)
11038 {
11039 dVAR;
11040
11041 PERL_ARGS_ASSERT_NEWAVREF;
11042
11043 if (o->op_type == OP_PADANY) {
11044 OpTYPE_set(o, OP_PADAV);
11045 return o;
11046 }
11047 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
11048 Perl_croak(aTHX_ "Can't use an array as a reference");
11049 }
11050 return newUNOP(OP_RV2AV, 0, scalar(o));
11051 }
11052
11053 OP *
Perl_newGVREF(pTHX_ I32 type,OP * o)11054 Perl_newGVREF(pTHX_ I32 type, OP *o)
11055 {
11056 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
11057 return newUNOP(OP_NULL, 0, o);
11058 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
11059 }
11060
11061 OP *
Perl_newHVREF(pTHX_ OP * o)11062 Perl_newHVREF(pTHX_ OP *o)
11063 {
11064 dVAR;
11065
11066 PERL_ARGS_ASSERT_NEWHVREF;
11067
11068 if (o->op_type == OP_PADANY) {
11069 OpTYPE_set(o, OP_PADHV);
11070 return o;
11071 }
11072 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
11073 Perl_croak(aTHX_ "Can't use a hash as a reference");
11074 }
11075 return newUNOP(OP_RV2HV, 0, scalar(o));
11076 }
11077
11078 OP *
Perl_newCVREF(pTHX_ I32 flags,OP * o)11079 Perl_newCVREF(pTHX_ I32 flags, OP *o)
11080 {
11081 if (o->op_type == OP_PADANY) {
11082 dVAR;
11083 OpTYPE_set(o, OP_PADCV);
11084 }
11085 return newUNOP(OP_RV2CV, flags, scalar(o));
11086 }
11087
11088 OP *
Perl_newSVREF(pTHX_ OP * o)11089 Perl_newSVREF(pTHX_ OP *o)
11090 {
11091 dVAR;
11092
11093 PERL_ARGS_ASSERT_NEWSVREF;
11094
11095 if (o->op_type == OP_PADANY) {
11096 OpTYPE_set(o, OP_PADSV);
11097 scalar(o);
11098 return o;
11099 }
11100 return newUNOP(OP_RV2SV, 0, scalar(o));
11101 }
11102
11103 /* Check routines. See the comments at the top of this file for details
11104 * on when these are called */
11105
11106 OP *
Perl_ck_anoncode(pTHX_ OP * o)11107 Perl_ck_anoncode(pTHX_ OP *o)
11108 {
11109 PERL_ARGS_ASSERT_CK_ANONCODE;
11110
11111 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
11112 cSVOPo->op_sv = NULL;
11113 return o;
11114 }
11115
11116 static void
S_io_hints(pTHX_ OP * o)11117 S_io_hints(pTHX_ OP *o)
11118 {
11119 #if O_BINARY != 0 || O_TEXT != 0
11120 HV * const table =
11121 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
11122 if (table) {
11123 SV **svp = hv_fetchs(table, "open_IN", FALSE);
11124 if (svp && *svp) {
11125 STRLEN len = 0;
11126 const char *d = SvPV_const(*svp, len);
11127 const I32 mode = mode_from_discipline(d, len);
11128 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11129 # if O_BINARY != 0
11130 if (mode & O_BINARY)
11131 o->op_private |= OPpOPEN_IN_RAW;
11132 # endif
11133 # if O_TEXT != 0
11134 if (mode & O_TEXT)
11135 o->op_private |= OPpOPEN_IN_CRLF;
11136 # endif
11137 }
11138
11139 svp = hv_fetchs(table, "open_OUT", FALSE);
11140 if (svp && *svp) {
11141 STRLEN len = 0;
11142 const char *d = SvPV_const(*svp, len);
11143 const I32 mode = mode_from_discipline(d, len);
11144 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11145 # if O_BINARY != 0
11146 if (mode & O_BINARY)
11147 o->op_private |= OPpOPEN_OUT_RAW;
11148 # endif
11149 # if O_TEXT != 0
11150 if (mode & O_TEXT)
11151 o->op_private |= OPpOPEN_OUT_CRLF;
11152 # endif
11153 }
11154 }
11155 #else
11156 PERL_UNUSED_CONTEXT;
11157 PERL_UNUSED_ARG(o);
11158 #endif
11159 }
11160
11161 OP *
Perl_ck_backtick(pTHX_ OP * o)11162 Perl_ck_backtick(pTHX_ OP *o)
11163 {
11164 GV *gv;
11165 OP *newop = NULL;
11166 OP *sibl;
11167 PERL_ARGS_ASSERT_CK_BACKTICK;
11168 o = ck_fun(o);
11169 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
11170 if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
11171 && (gv = gv_override("readpipe",8)))
11172 {
11173 /* detach rest of siblings from o and its first child */
11174 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11175 newop = S_new_entersubop(aTHX_ gv, sibl);
11176 }
11177 else if (!(o->op_flags & OPf_KIDS))
11178 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
11179 if (newop) {
11180 op_free(o);
11181 return newop;
11182 }
11183 S_io_hints(aTHX_ o);
11184 return o;
11185 }
11186
11187 OP *
Perl_ck_bitop(pTHX_ OP * o)11188 Perl_ck_bitop(pTHX_ OP *o)
11189 {
11190 PERL_ARGS_ASSERT_CK_BITOP;
11191
11192 o->op_private = (U8)(PL_hints & HINT_INTEGER);
11193
11194 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
11195 && OP_IS_INFIX_BIT(o->op_type))
11196 {
11197 const OP * const left = cBINOPo->op_first;
11198 const OP * const right = OpSIBLING(left);
11199 if ((OP_IS_NUMCOMPARE(left->op_type) &&
11200 (left->op_flags & OPf_PARENS) == 0) ||
11201 (OP_IS_NUMCOMPARE(right->op_type) &&
11202 (right->op_flags & OPf_PARENS) == 0))
11203 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
11204 "Possible precedence problem on bitwise %s operator",
11205 o->op_type == OP_BIT_OR
11206 ||o->op_type == OP_NBIT_OR ? "|"
11207 : o->op_type == OP_BIT_AND
11208 ||o->op_type == OP_NBIT_AND ? "&"
11209 : o->op_type == OP_BIT_XOR
11210 ||o->op_type == OP_NBIT_XOR ? "^"
11211 : o->op_type == OP_SBIT_OR ? "|."
11212 : o->op_type == OP_SBIT_AND ? "&." : "^."
11213 );
11214 }
11215 return o;
11216 }
11217
11218 PERL_STATIC_INLINE bool
is_dollar_bracket(pTHX_ const OP * const o)11219 is_dollar_bracket(pTHX_ const OP * const o)
11220 {
11221 const OP *kid;
11222 PERL_UNUSED_CONTEXT;
11223 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
11224 && (kid = cUNOPx(o)->op_first)
11225 && kid->op_type == OP_GV
11226 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
11227 }
11228
11229 /* for lt, gt, le, ge, eq, ne and their i_ variants */
11230
11231 OP *
Perl_ck_cmp(pTHX_ OP * o)11232 Perl_ck_cmp(pTHX_ OP *o)
11233 {
11234 bool is_eq;
11235 bool neg;
11236 bool reverse;
11237 bool iv0;
11238 OP *indexop, *constop, *start;
11239 SV *sv;
11240 IV iv;
11241
11242 PERL_ARGS_ASSERT_CK_CMP;
11243
11244 is_eq = ( o->op_type == OP_EQ
11245 || o->op_type == OP_NE
11246 || o->op_type == OP_I_EQ
11247 || o->op_type == OP_I_NE);
11248
11249 if (!is_eq && ckWARN(WARN_SYNTAX)) {
11250 const OP *kid = cUNOPo->op_first;
11251 if (kid &&
11252 (
11253 ( is_dollar_bracket(aTHX_ kid)
11254 && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
11255 )
11256 || ( kid->op_type == OP_CONST
11257 && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
11258 )
11259 )
11260 )
11261 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11262 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
11263 }
11264
11265 /* convert (index(...) == -1) and variations into
11266 * (r)index/BOOL(,NEG)
11267 */
11268
11269 reverse = FALSE;
11270
11271 indexop = cUNOPo->op_first;
11272 constop = OpSIBLING(indexop);
11273 start = NULL;
11274 if (indexop->op_type == OP_CONST) {
11275 constop = indexop;
11276 indexop = OpSIBLING(constop);
11277 start = constop;
11278 reverse = TRUE;
11279 }
11280
11281 if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
11282 return o;
11283
11284 /* ($lex = index(....)) == -1 */
11285 if (indexop->op_private & OPpTARGET_MY)
11286 return o;
11287
11288 if (constop->op_type != OP_CONST)
11289 return o;
11290
11291 sv = cSVOPx_sv(constop);
11292 if (!(sv && SvIOK_notUV(sv)))
11293 return o;
11294
11295 iv = SvIVX(sv);
11296 if (iv != -1 && iv != 0)
11297 return o;
11298 iv0 = (iv == 0);
11299
11300 if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
11301 if (!(iv0 ^ reverse))
11302 return o;
11303 neg = iv0;
11304 }
11305 else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
11306 if (iv0 ^ reverse)
11307 return o;
11308 neg = !iv0;
11309 }
11310 else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
11311 if (!(iv0 ^ reverse))
11312 return o;
11313 neg = !iv0;
11314 }
11315 else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
11316 if (iv0 ^ reverse)
11317 return o;
11318 neg = iv0;
11319 }
11320 else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
11321 if (iv0)
11322 return o;
11323 neg = TRUE;
11324 }
11325 else {
11326 assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
11327 if (iv0)
11328 return o;
11329 neg = FALSE;
11330 }
11331
11332 indexop->op_flags &= ~OPf_PARENS;
11333 indexop->op_flags |= (o->op_flags & OPf_PARENS);
11334 indexop->op_private |= OPpTRUEBOOL;
11335 if (neg)
11336 indexop->op_private |= OPpINDEX_BOOLNEG;
11337 /* cut out the index op and free the eq,const ops */
11338 (void)op_sibling_splice(o, start, 1, NULL);
11339 op_free(o);
11340
11341 return indexop;
11342 }
11343
11344
11345 OP *
Perl_ck_concat(pTHX_ OP * o)11346 Perl_ck_concat(pTHX_ OP *o)
11347 {
11348 const OP * const kid = cUNOPo->op_first;
11349
11350 PERL_ARGS_ASSERT_CK_CONCAT;
11351 PERL_UNUSED_CONTEXT;
11352
11353 /* reuse the padtmp returned by the concat child */
11354 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
11355 !(kUNOP->op_first->op_flags & OPf_MOD))
11356 {
11357 o->op_flags |= OPf_STACKED;
11358 o->op_private |= OPpCONCAT_NESTED;
11359 }
11360 return o;
11361 }
11362
11363 OP *
Perl_ck_spair(pTHX_ OP * o)11364 Perl_ck_spair(pTHX_ OP *o)
11365 {
11366 dVAR;
11367
11368 PERL_ARGS_ASSERT_CK_SPAIR;
11369
11370 if (o->op_flags & OPf_KIDS) {
11371 OP* newop;
11372 OP* kid;
11373 OP* kidkid;
11374 const OPCODE type = o->op_type;
11375 o = modkids(ck_fun(o), type);
11376 kid = cUNOPo->op_first;
11377 kidkid = kUNOP->op_first;
11378 newop = OpSIBLING(kidkid);
11379 if (newop) {
11380 const OPCODE type = newop->op_type;
11381 if (OpHAS_SIBLING(newop))
11382 return o;
11383 if (o->op_type == OP_REFGEN
11384 && ( type == OP_RV2CV
11385 || ( !(newop->op_flags & OPf_PARENS)
11386 && ( type == OP_RV2AV || type == OP_PADAV
11387 || type == OP_RV2HV || type == OP_PADHV))))
11388 NOOP; /* OK (allow srefgen for \@a and \%h) */
11389 else if (OP_GIMME(newop,0) != G_SCALAR)
11390 return o;
11391 }
11392 /* excise first sibling */
11393 op_sibling_splice(kid, NULL, 1, NULL);
11394 op_free(kidkid);
11395 }
11396 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
11397 * and OP_CHOMP into OP_SCHOMP */
11398 o->op_ppaddr = PL_ppaddr[++o->op_type];
11399 return ck_fun(o);
11400 }
11401
11402 OP *
Perl_ck_delete(pTHX_ OP * o)11403 Perl_ck_delete(pTHX_ OP *o)
11404 {
11405 PERL_ARGS_ASSERT_CK_DELETE;
11406
11407 o = ck_fun(o);
11408 o->op_private = 0;
11409 if (o->op_flags & OPf_KIDS) {
11410 OP * const kid = cUNOPo->op_first;
11411 switch (kid->op_type) {
11412 case OP_ASLICE:
11413 o->op_flags |= OPf_SPECIAL;
11414 /* FALLTHROUGH */
11415 case OP_HSLICE:
11416 o->op_private |= OPpSLICE;
11417 break;
11418 case OP_AELEM:
11419 o->op_flags |= OPf_SPECIAL;
11420 /* FALLTHROUGH */
11421 case OP_HELEM:
11422 break;
11423 case OP_KVASLICE:
11424 o->op_flags |= OPf_SPECIAL;
11425 /* FALLTHROUGH */
11426 case OP_KVHSLICE:
11427 o->op_private |= OPpKVSLICE;
11428 break;
11429 default:
11430 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
11431 "element or slice");
11432 }
11433 if (kid->op_private & OPpLVAL_INTRO)
11434 o->op_private |= OPpLVAL_INTRO;
11435 op_null(kid);
11436 }
11437 return o;
11438 }
11439
11440 OP *
Perl_ck_eof(pTHX_ OP * o)11441 Perl_ck_eof(pTHX_ OP *o)
11442 {
11443 PERL_ARGS_ASSERT_CK_EOF;
11444
11445 if (o->op_flags & OPf_KIDS) {
11446 OP *kid;
11447 if (cLISTOPo->op_first->op_type == OP_STUB) {
11448 OP * const newop
11449 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
11450 op_free(o);
11451 o = newop;
11452 }
11453 o = ck_fun(o);
11454 kid = cLISTOPo->op_first;
11455 if (kid->op_type == OP_RV2GV)
11456 kid->op_private |= OPpALLOW_FAKE;
11457 }
11458 return o;
11459 }
11460
11461
11462 OP *
Perl_ck_eval(pTHX_ OP * o)11463 Perl_ck_eval(pTHX_ OP *o)
11464 {
11465 dVAR;
11466
11467 PERL_ARGS_ASSERT_CK_EVAL;
11468
11469 PL_hints |= HINT_BLOCK_SCOPE;
11470 if (o->op_flags & OPf_KIDS) {
11471 SVOP * const kid = (SVOP*)cUNOPo->op_first;
11472 assert(kid);
11473
11474 if (o->op_type == OP_ENTERTRY) {
11475 LOGOP *enter;
11476
11477 /* cut whole sibling chain free from o */
11478 op_sibling_splice(o, NULL, -1, NULL);
11479 op_free(o);
11480
11481 enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
11482
11483 /* establish postfix order */
11484 enter->op_next = (OP*)enter;
11485
11486 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
11487 OpTYPE_set(o, OP_LEAVETRY);
11488 enter->op_other = o;
11489 return o;
11490 }
11491 else {
11492 scalar((OP*)kid);
11493 S_set_haseval(aTHX);
11494 }
11495 }
11496 else {
11497 const U8 priv = o->op_private;
11498 op_free(o);
11499 /* the newUNOP will recursively call ck_eval(), which will handle
11500 * all the stuff at the end of this function, like adding
11501 * OP_HINTSEVAL
11502 */
11503 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
11504 }
11505 o->op_targ = (PADOFFSET)PL_hints;
11506 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
11507 if ((PL_hints & HINT_LOCALIZE_HH) != 0
11508 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
11509 /* Store a copy of %^H that pp_entereval can pick up. */
11510 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
11511 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
11512 /* append hhop to only child */
11513 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
11514
11515 o->op_private |= OPpEVAL_HAS_HH;
11516 }
11517 if (!(o->op_private & OPpEVAL_BYTES)
11518 && FEATURE_UNIEVAL_IS_ENABLED)
11519 o->op_private |= OPpEVAL_UNICODE;
11520 return o;
11521 }
11522
11523 OP *
Perl_ck_exec(pTHX_ OP * o)11524 Perl_ck_exec(pTHX_ OP *o)
11525 {
11526 PERL_ARGS_ASSERT_CK_EXEC;
11527
11528 if (o->op_flags & OPf_STACKED) {
11529 OP *kid;
11530 o = ck_fun(o);
11531 kid = OpSIBLING(cUNOPo->op_first);
11532 if (kid->op_type == OP_RV2GV)
11533 op_null(kid);
11534 }
11535 else
11536 o = listkids(o);
11537 return o;
11538 }
11539
11540 OP *
Perl_ck_exists(pTHX_ OP * o)11541 Perl_ck_exists(pTHX_ OP *o)
11542 {
11543 PERL_ARGS_ASSERT_CK_EXISTS;
11544
11545 o = ck_fun(o);
11546 if (o->op_flags & OPf_KIDS) {
11547 OP * const kid = cUNOPo->op_first;
11548 if (kid->op_type == OP_ENTERSUB) {
11549 (void) ref(kid, o->op_type);
11550 if (kid->op_type != OP_RV2CV
11551 && !(PL_parser && PL_parser->error_count))
11552 Perl_croak(aTHX_
11553 "exists argument is not a subroutine name");
11554 o->op_private |= OPpEXISTS_SUB;
11555 }
11556 else if (kid->op_type == OP_AELEM)
11557 o->op_flags |= OPf_SPECIAL;
11558 else if (kid->op_type != OP_HELEM)
11559 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
11560 "element or a subroutine");
11561 op_null(kid);
11562 }
11563 return o;
11564 }
11565
11566 OP *
Perl_ck_rvconst(pTHX_ OP * o)11567 Perl_ck_rvconst(pTHX_ OP *o)
11568 {
11569 dVAR;
11570 SVOP * const kid = (SVOP*)cUNOPo->op_first;
11571
11572 PERL_ARGS_ASSERT_CK_RVCONST;
11573
11574 if (o->op_type == OP_RV2HV)
11575 /* rv2hv steals the bottom bit for its own uses */
11576 o->op_private &= ~OPpARG1_MASK;
11577
11578 o->op_private |= (PL_hints & HINT_STRICT_REFS);
11579
11580 if (kid->op_type == OP_CONST) {
11581 int iscv;
11582 GV *gv;
11583 SV * const kidsv = kid->op_sv;
11584
11585 /* Is it a constant from cv_const_sv()? */
11586 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
11587 return o;
11588 }
11589 if (SvTYPE(kidsv) == SVt_PVAV) return o;
11590 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
11591 const char *badthing;
11592 switch (o->op_type) {
11593 case OP_RV2SV:
11594 badthing = "a SCALAR";
11595 break;
11596 case OP_RV2AV:
11597 badthing = "an ARRAY";
11598 break;
11599 case OP_RV2HV:
11600 badthing = "a HASH";
11601 break;
11602 default:
11603 badthing = NULL;
11604 break;
11605 }
11606 if (badthing)
11607 Perl_croak(aTHX_
11608 "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
11609 SVfARG(kidsv), badthing);
11610 }
11611 /*
11612 * This is a little tricky. We only want to add the symbol if we
11613 * didn't add it in the lexer. Otherwise we get duplicate strict
11614 * warnings. But if we didn't add it in the lexer, we must at
11615 * least pretend like we wanted to add it even if it existed before,
11616 * or we get possible typo warnings. OPpCONST_ENTERED says
11617 * whether the lexer already added THIS instance of this symbol.
11618 */
11619 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
11620 gv = gv_fetchsv(kidsv,
11621 o->op_type == OP_RV2CV
11622 && o->op_private & OPpMAY_RETURN_CONSTANT
11623 ? GV_NOEXPAND
11624 : iscv | !(kid->op_private & OPpCONST_ENTERED),
11625 iscv
11626 ? SVt_PVCV
11627 : o->op_type == OP_RV2SV
11628 ? SVt_PV
11629 : o->op_type == OP_RV2AV
11630 ? SVt_PVAV
11631 : o->op_type == OP_RV2HV
11632 ? SVt_PVHV
11633 : SVt_PVGV);
11634 if (gv) {
11635 if (!isGV(gv)) {
11636 assert(iscv);
11637 assert(SvROK(gv));
11638 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
11639 && SvTYPE(SvRV(gv)) != SVt_PVCV)
11640 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
11641 }
11642 OpTYPE_set(kid, OP_GV);
11643 SvREFCNT_dec(kid->op_sv);
11644 #ifdef USE_ITHREADS
11645 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
11646 STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
11647 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
11648 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
11649 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
11650 #else
11651 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
11652 #endif
11653 kid->op_private = 0;
11654 /* FAKE globs in the symbol table cause weird bugs (#77810) */
11655 SvFAKE_off(gv);
11656 }
11657 }
11658 return o;
11659 }
11660
11661 OP *
Perl_ck_ftst(pTHX_ OP * o)11662 Perl_ck_ftst(pTHX_ OP *o)
11663 {
11664 dVAR;
11665 const I32 type = o->op_type;
11666
11667 PERL_ARGS_ASSERT_CK_FTST;
11668
11669 if (o->op_flags & OPf_REF) {
11670 NOOP;
11671 }
11672 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
11673 SVOP * const kid = (SVOP*)cUNOPo->op_first;
11674 const OPCODE kidtype = kid->op_type;
11675
11676 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
11677 && !kid->op_folded) {
11678 OP * const newop = newGVOP(type, OPf_REF,
11679 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
11680 op_free(o);
11681 return newop;
11682 }
11683
11684 if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
11685 SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
11686 if (name) {
11687 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
11688 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
11689 array_passed_to_stat, name);
11690 }
11691 else {
11692 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
11693 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
11694 }
11695 }
11696 scalar((OP *) kid);
11697 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
11698 o->op_private |= OPpFT_ACCESS;
11699 if (type != OP_STAT && type != OP_LSTAT
11700 && PL_check[kidtype] == Perl_ck_ftst
11701 && kidtype != OP_STAT && kidtype != OP_LSTAT
11702 ) {
11703 o->op_private |= OPpFT_STACKED;
11704 kid->op_private |= OPpFT_STACKING;
11705 if (kidtype == OP_FTTTY && (
11706 !(kid->op_private & OPpFT_STACKED)
11707 || kid->op_private & OPpFT_AFTER_t
11708 ))
11709 o->op_private |= OPpFT_AFTER_t;
11710 }
11711 }
11712 else {
11713 op_free(o);
11714 if (type == OP_FTTTY)
11715 o = newGVOP(type, OPf_REF, PL_stdingv);
11716 else
11717 o = newUNOP(type, 0, newDEFSVOP());
11718 }
11719 return o;
11720 }
11721
11722 OP *
Perl_ck_fun(pTHX_ OP * o)11723 Perl_ck_fun(pTHX_ OP *o)
11724 {
11725 const int type = o->op_type;
11726 I32 oa = PL_opargs[type] >> OASHIFT;
11727
11728 PERL_ARGS_ASSERT_CK_FUN;
11729
11730 if (o->op_flags & OPf_STACKED) {
11731 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
11732 oa &= ~OA_OPTIONAL;
11733 else
11734 return no_fh_allowed(o);
11735 }
11736
11737 if (o->op_flags & OPf_KIDS) {
11738 OP *prev_kid = NULL;
11739 OP *kid = cLISTOPo->op_first;
11740 I32 numargs = 0;
11741 bool seen_optional = FALSE;
11742
11743 if (kid->op_type == OP_PUSHMARK ||
11744 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
11745 {
11746 prev_kid = kid;
11747 kid = OpSIBLING(kid);
11748 }
11749 if (kid && kid->op_type == OP_COREARGS) {
11750 bool optional = FALSE;
11751 while (oa) {
11752 numargs++;
11753 if (oa & OA_OPTIONAL) optional = TRUE;
11754 oa = oa >> 4;
11755 }
11756 if (optional) o->op_private |= numargs;
11757 return o;
11758 }
11759
11760 while (oa) {
11761 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
11762 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
11763 kid = newDEFSVOP();
11764 /* append kid to chain */
11765 op_sibling_splice(o, prev_kid, 0, kid);
11766 }
11767 seen_optional = TRUE;
11768 }
11769 if (!kid) break;
11770
11771 numargs++;
11772 switch (oa & 7) {
11773 case OA_SCALAR:
11774 /* list seen where single (scalar) arg expected? */
11775 if (numargs == 1 && !(oa >> 4)
11776 && kid->op_type == OP_LIST && type != OP_SCALAR)
11777 {
11778 return too_many_arguments_pv(o,PL_op_desc[type], 0);
11779 }
11780 if (type != OP_DELETE) scalar(kid);
11781 break;
11782 case OA_LIST:
11783 if (oa < 16) {
11784 kid = 0;
11785 continue;
11786 }
11787 else
11788 list(kid);
11789 break;
11790 case OA_AVREF:
11791 if ((type == OP_PUSH || type == OP_UNSHIFT)
11792 && !OpHAS_SIBLING(kid))
11793 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11794 "Useless use of %s with no values",
11795 PL_op_desc[type]);
11796
11797 if (kid->op_type == OP_CONST
11798 && ( !SvROK(cSVOPx_sv(kid))
11799 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
11800 )
11801 bad_type_pv(numargs, "array", o, kid);
11802 else if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV
11803 || kid->op_type == OP_RV2GV) {
11804 bad_type_pv(1, "array", o, kid);
11805 }
11806 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
11807 yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
11808 PL_op_desc[type]), 0);
11809 }
11810 else {
11811 op_lvalue(kid, type);
11812 }
11813 break;
11814 case OA_HVREF:
11815 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
11816 bad_type_pv(numargs, "hash", o, kid);
11817 op_lvalue(kid, type);
11818 break;
11819 case OA_CVREF:
11820 {
11821 /* replace kid with newop in chain */
11822 OP * const newop =
11823 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
11824 newop->op_next = newop;
11825 kid = newop;
11826 }
11827 break;
11828 case OA_FILEREF:
11829 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
11830 if (kid->op_type == OP_CONST &&
11831 (kid->op_private & OPpCONST_BARE))
11832 {
11833 OP * const newop = newGVOP(OP_GV, 0,
11834 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
11835 /* replace kid with newop in chain */
11836 op_sibling_splice(o, prev_kid, 1, newop);
11837 op_free(kid);
11838 kid = newop;
11839 }
11840 else if (kid->op_type == OP_READLINE) {
11841 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
11842 bad_type_pv(numargs, "HANDLE", o, kid);
11843 }
11844 else {
11845 I32 flags = OPf_SPECIAL;
11846 I32 priv = 0;
11847 PADOFFSET targ = 0;
11848
11849 /* is this op a FH constructor? */
11850 if (is_handle_constructor(o,numargs)) {
11851 const char *name = NULL;
11852 STRLEN len = 0;
11853 U32 name_utf8 = 0;
11854 bool want_dollar = TRUE;
11855
11856 flags = 0;
11857 /* Set a flag to tell rv2gv to vivify
11858 * need to "prove" flag does not mean something
11859 * else already - NI-S 1999/05/07
11860 */
11861 priv = OPpDEREF;
11862 if (kid->op_type == OP_PADSV) {
11863 PADNAME * const pn
11864 = PAD_COMPNAME_SV(kid->op_targ);
11865 name = PadnamePV (pn);
11866 len = PadnameLEN(pn);
11867 name_utf8 = PadnameUTF8(pn);
11868 }
11869 else if (kid->op_type == OP_RV2SV
11870 && kUNOP->op_first->op_type == OP_GV)
11871 {
11872 GV * const gv = cGVOPx_gv(kUNOP->op_first);
11873 name = GvNAME(gv);
11874 len = GvNAMELEN(gv);
11875 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
11876 }
11877 else if (kid->op_type == OP_AELEM
11878 || kid->op_type == OP_HELEM)
11879 {
11880 OP *firstop;
11881 OP *op = ((BINOP*)kid)->op_first;
11882 name = NULL;
11883 if (op) {
11884 SV *tmpstr = NULL;
11885 const char * const a =
11886 kid->op_type == OP_AELEM ?
11887 "[]" : "{}";
11888 if (((op->op_type == OP_RV2AV) ||
11889 (op->op_type == OP_RV2HV)) &&
11890 (firstop = ((UNOP*)op)->op_first) &&
11891 (firstop->op_type == OP_GV)) {
11892 /* packagevar $a[] or $h{} */
11893 GV * const gv = cGVOPx_gv(firstop);
11894 if (gv)
11895 tmpstr =
11896 Perl_newSVpvf(aTHX_
11897 "%s%c...%c",
11898 GvNAME(gv),
11899 a[0], a[1]);
11900 }
11901 else if (op->op_type == OP_PADAV
11902 || op->op_type == OP_PADHV) {
11903 /* lexicalvar $a[] or $h{} */
11904 const char * const padname =
11905 PAD_COMPNAME_PV(op->op_targ);
11906 if (padname)
11907 tmpstr =
11908 Perl_newSVpvf(aTHX_
11909 "%s%c...%c",
11910 padname + 1,
11911 a[0], a[1]);
11912 }
11913 if (tmpstr) {
11914 name = SvPV_const(tmpstr, len);
11915 name_utf8 = SvUTF8(tmpstr);
11916 sv_2mortal(tmpstr);
11917 }
11918 }
11919 if (!name) {
11920 name = "__ANONIO__";
11921 len = 10;
11922 want_dollar = FALSE;
11923 }
11924 op_lvalue(kid, type);
11925 }
11926 if (name) {
11927 SV *namesv;
11928 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
11929 namesv = PAD_SVl(targ);
11930 if (want_dollar && *name != '$')
11931 sv_setpvs(namesv, "$");
11932 else
11933 SvPVCLEAR(namesv);
11934 sv_catpvn(namesv, name, len);
11935 if ( name_utf8 ) SvUTF8_on(namesv);
11936 }
11937 }
11938 scalar(kid);
11939 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
11940 OP_RV2GV, flags);
11941 kid->op_targ = targ;
11942 kid->op_private |= priv;
11943 }
11944 }
11945 scalar(kid);
11946 break;
11947 case OA_SCALARREF:
11948 if ((type == OP_UNDEF || type == OP_POS)
11949 && numargs == 1 && !(oa >> 4)
11950 && kid->op_type == OP_LIST)
11951 return too_many_arguments_pv(o,PL_op_desc[type], 0);
11952 op_lvalue(scalar(kid), type);
11953 break;
11954 }
11955 oa >>= 4;
11956 prev_kid = kid;
11957 kid = OpSIBLING(kid);
11958 }
11959 /* FIXME - should the numargs or-ing move after the too many
11960 * arguments check? */
11961 o->op_private |= numargs;
11962 if (kid)
11963 return too_many_arguments_pv(o,OP_DESC(o), 0);
11964 listkids(o);
11965 }
11966 else if (PL_opargs[type] & OA_DEFGV) {
11967 /* Ordering of these two is important to keep f_map.t passing. */
11968 op_free(o);
11969 return newUNOP(type, 0, newDEFSVOP());
11970 }
11971
11972 if (oa) {
11973 while (oa & OA_OPTIONAL)
11974 oa >>= 4;
11975 if (oa && oa != OA_LIST)
11976 return too_few_arguments_pv(o,OP_DESC(o), 0);
11977 }
11978 return o;
11979 }
11980
11981 OP *
Perl_ck_glob(pTHX_ OP * o)11982 Perl_ck_glob(pTHX_ OP *o)
11983 {
11984 GV *gv;
11985
11986 PERL_ARGS_ASSERT_CK_GLOB;
11987
11988 o = ck_fun(o);
11989 if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
11990 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
11991
11992 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
11993 {
11994 /* convert
11995 * glob
11996 * \ null - const(wildcard)
11997 * into
11998 * null
11999 * \ enter
12000 * \ list
12001 * \ mark - glob - rv2cv
12002 * | \ gv(CORE::GLOBAL::glob)
12003 * |
12004 * \ null - const(wildcard)
12005 */
12006 o->op_flags |= OPf_SPECIAL;
12007 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
12008 o = S_new_entersubop(aTHX_ gv, o);
12009 o = newUNOP(OP_NULL, 0, o);
12010 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
12011 return o;
12012 }
12013 else o->op_flags &= ~OPf_SPECIAL;
12014 #if !defined(PERL_EXTERNAL_GLOB)
12015 if (!PL_globhook) {
12016 ENTER;
12017 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
12018 newSVpvs("File::Glob"), NULL, NULL, NULL);
12019 LEAVE;
12020 }
12021 #endif /* !PERL_EXTERNAL_GLOB */
12022 gv = (GV *)newSV(0);
12023 gv_init(gv, 0, "", 0, 0);
12024 gv_IOadd(gv);
12025 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
12026 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
12027 scalarkids(o);
12028 return o;
12029 }
12030
12031 OP *
Perl_ck_grep(pTHX_ OP * o)12032 Perl_ck_grep(pTHX_ OP *o)
12033 {
12034 LOGOP *gwop;
12035 OP *kid;
12036 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
12037
12038 PERL_ARGS_ASSERT_CK_GREP;
12039
12040 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
12041
12042 if (o->op_flags & OPf_STACKED) {
12043 kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
12044 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
12045 return no_fh_allowed(o);
12046 o->op_flags &= ~OPf_STACKED;
12047 }
12048 kid = OpSIBLING(cLISTOPo->op_first);
12049 if (type == OP_MAPWHILE)
12050 list(kid);
12051 else
12052 scalar(kid);
12053 o = ck_fun(o);
12054 if (PL_parser && PL_parser->error_count)
12055 return o;
12056 kid = OpSIBLING(cLISTOPo->op_first);
12057 if (kid->op_type != OP_NULL)
12058 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
12059 kid = kUNOP->op_first;
12060
12061 gwop = alloc_LOGOP(type, o, LINKLIST(kid));
12062 kid->op_next = (OP*)gwop;
12063 o->op_private = gwop->op_private = 0;
12064 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
12065
12066 kid = OpSIBLING(cLISTOPo->op_first);
12067 for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
12068 op_lvalue(kid, OP_GREPSTART);
12069
12070 return (OP*)gwop;
12071 }
12072
12073 OP *
Perl_ck_index(pTHX_ OP * o)12074 Perl_ck_index(pTHX_ OP *o)
12075 {
12076 PERL_ARGS_ASSERT_CK_INDEX;
12077
12078 if (o->op_flags & OPf_KIDS) {
12079 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12080 if (kid)
12081 kid = OpSIBLING(kid); /* get past "big" */
12082 if (kid && kid->op_type == OP_CONST) {
12083 const bool save_taint = TAINT_get;
12084 SV *sv = kSVOP->op_sv;
12085 if ( (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
12086 && SvOK(sv) && !SvROK(sv))
12087 {
12088 sv = newSV(0);
12089 sv_copypv(sv, kSVOP->op_sv);
12090 SvREFCNT_dec_NN(kSVOP->op_sv);
12091 kSVOP->op_sv = sv;
12092 }
12093 if (SvOK(sv)) fbm_compile(sv, 0);
12094 TAINT_set(save_taint);
12095 #ifdef NO_TAINT_SUPPORT
12096 PERL_UNUSED_VAR(save_taint);
12097 #endif
12098 }
12099 }
12100 return ck_fun(o);
12101 }
12102
12103 OP *
Perl_ck_lfun(pTHX_ OP * o)12104 Perl_ck_lfun(pTHX_ OP *o)
12105 {
12106 const OPCODE type = o->op_type;
12107
12108 PERL_ARGS_ASSERT_CK_LFUN;
12109
12110 return modkids(ck_fun(o), type);
12111 }
12112
12113 OP *
Perl_ck_defined(pTHX_ OP * o)12114 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
12115 {
12116 PERL_ARGS_ASSERT_CK_DEFINED;
12117
12118 if ((o->op_flags & OPf_KIDS)) {
12119 switch (cUNOPo->op_first->op_type) {
12120 case OP_RV2AV:
12121 case OP_PADAV:
12122 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
12123 " (Maybe you should just omit the defined()?)");
12124 NOT_REACHED; /* NOTREACHED */
12125 break;
12126 case OP_RV2HV:
12127 case OP_PADHV:
12128 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
12129 " (Maybe you should just omit the defined()?)");
12130 NOT_REACHED; /* NOTREACHED */
12131 break;
12132 default:
12133 /* no warning */
12134 break;
12135 }
12136 }
12137 return ck_rfun(o);
12138 }
12139
12140 OP *
Perl_ck_readline(pTHX_ OP * o)12141 Perl_ck_readline(pTHX_ OP *o)
12142 {
12143 PERL_ARGS_ASSERT_CK_READLINE;
12144
12145 if (o->op_flags & OPf_KIDS) {
12146 OP *kid = cLISTOPo->op_first;
12147 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
12148 scalar(kid);
12149 }
12150 else {
12151 OP * const newop
12152 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
12153 op_free(o);
12154 return newop;
12155 }
12156 return o;
12157 }
12158
12159 OP *
Perl_ck_rfun(pTHX_ OP * o)12160 Perl_ck_rfun(pTHX_ OP *o)
12161 {
12162 const OPCODE type = o->op_type;
12163
12164 PERL_ARGS_ASSERT_CK_RFUN;
12165
12166 return refkids(ck_fun(o), type);
12167 }
12168
12169 OP *
Perl_ck_listiob(pTHX_ OP * o)12170 Perl_ck_listiob(pTHX_ OP *o)
12171 {
12172 OP *kid;
12173
12174 PERL_ARGS_ASSERT_CK_LISTIOB;
12175
12176 kid = cLISTOPo->op_first;
12177 if (!kid) {
12178 o = force_list(o, 1);
12179 kid = cLISTOPo->op_first;
12180 }
12181 if (kid->op_type == OP_PUSHMARK)
12182 kid = OpSIBLING(kid);
12183 if (kid && o->op_flags & OPf_STACKED)
12184 kid = OpSIBLING(kid);
12185 else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */
12186 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
12187 && !kid->op_folded) {
12188 o->op_flags |= OPf_STACKED; /* make it a filehandle */
12189 scalar(kid);
12190 /* replace old const op with new OP_RV2GV parent */
12191 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
12192 OP_RV2GV, OPf_REF);
12193 kid = OpSIBLING(kid);
12194 }
12195 }
12196
12197 if (!kid)
12198 op_append_elem(o->op_type, o, newDEFSVOP());
12199
12200 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
12201 return listkids(o);
12202 }
12203
12204 OP *
Perl_ck_smartmatch(pTHX_ OP * o)12205 Perl_ck_smartmatch(pTHX_ OP *o)
12206 {
12207 dVAR;
12208 PERL_ARGS_ASSERT_CK_SMARTMATCH;
12209 if (0 == (o->op_flags & OPf_SPECIAL)) {
12210 OP *first = cBINOPo->op_first;
12211 OP *second = OpSIBLING(first);
12212
12213 /* Implicitly take a reference to an array or hash */
12214
12215 /* remove the original two siblings, then add back the
12216 * (possibly different) first and second sibs.
12217 */
12218 op_sibling_splice(o, NULL, 1, NULL);
12219 op_sibling_splice(o, NULL, 1, NULL);
12220 first = ref_array_or_hash(first);
12221 second = ref_array_or_hash(second);
12222 op_sibling_splice(o, NULL, 0, second);
12223 op_sibling_splice(o, NULL, 0, first);
12224
12225 /* Implicitly take a reference to a regular expression */
12226 if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
12227 OpTYPE_set(first, OP_QR);
12228 }
12229 if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
12230 OpTYPE_set(second, OP_QR);
12231 }
12232 }
12233
12234 return o;
12235 }
12236
12237
12238 static OP *
S_maybe_targlex(pTHX_ OP * o)12239 S_maybe_targlex(pTHX_ OP *o)
12240 {
12241 OP * const kid = cLISTOPo->op_first;
12242 /* has a disposable target? */
12243 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
12244 && !(kid->op_flags & OPf_STACKED)
12245 /* Cannot steal the second time! */
12246 && !(kid->op_private & OPpTARGET_MY)
12247 )
12248 {
12249 OP * const kkid = OpSIBLING(kid);
12250
12251 /* Can just relocate the target. */
12252 if (kkid && kkid->op_type == OP_PADSV
12253 && (!(kkid->op_private & OPpLVAL_INTRO)
12254 || kkid->op_private & OPpPAD_STATE))
12255 {
12256 kid->op_targ = kkid->op_targ;
12257 kkid->op_targ = 0;
12258 /* Now we do not need PADSV and SASSIGN.
12259 * Detach kid and free the rest. */
12260 op_sibling_splice(o, NULL, 1, NULL);
12261 op_free(o);
12262 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
12263 return kid;
12264 }
12265 }
12266 return o;
12267 }
12268
12269 OP *
Perl_ck_sassign(pTHX_ OP * o)12270 Perl_ck_sassign(pTHX_ OP *o)
12271 {
12272 dVAR;
12273 OP * const kid = cBINOPo->op_first;
12274
12275 PERL_ARGS_ASSERT_CK_SASSIGN;
12276
12277 if (OpHAS_SIBLING(kid)) {
12278 OP *kkid = OpSIBLING(kid);
12279 /* For state variable assignment with attributes, kkid is a list op
12280 whose op_last is a padsv. */
12281 if ((kkid->op_type == OP_PADSV ||
12282 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
12283 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
12284 )
12285 )
12286 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
12287 == (OPpLVAL_INTRO|OPpPAD_STATE)) {
12288 return S_newONCEOP(aTHX_ o, kkid);
12289 }
12290 }
12291 return S_maybe_targlex(aTHX_ o);
12292 }
12293
12294
12295 OP *
Perl_ck_match(pTHX_ OP * o)12296 Perl_ck_match(pTHX_ OP *o)
12297 {
12298 PERL_UNUSED_CONTEXT;
12299 PERL_ARGS_ASSERT_CK_MATCH;
12300
12301 return o;
12302 }
12303
12304 OP *
Perl_ck_method(pTHX_ OP * o)12305 Perl_ck_method(pTHX_ OP *o)
12306 {
12307 SV *sv, *methsv, *rclass;
12308 const char* method;
12309 char* compatptr;
12310 int utf8;
12311 STRLEN len, nsplit = 0, i;
12312 OP* new_op;
12313 OP * const kid = cUNOPo->op_first;
12314
12315 PERL_ARGS_ASSERT_CK_METHOD;
12316 if (kid->op_type != OP_CONST) return o;
12317
12318 sv = kSVOP->op_sv;
12319
12320 /* replace ' with :: */
12321 while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
12322 SvEND(sv) - SvPVX(sv) )))
12323 {
12324 *compatptr = ':';
12325 sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
12326 }
12327
12328 method = SvPVX_const(sv);
12329 len = SvCUR(sv);
12330 utf8 = SvUTF8(sv) ? -1 : 1;
12331
12332 for (i = len - 1; i > 0; --i) if (method[i] == ':') {
12333 nsplit = i+1;
12334 break;
12335 }
12336
12337 methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
12338
12339 if (!nsplit) { /* $proto->method() */
12340 op_free(o);
12341 return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
12342 }
12343
12344 if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
12345 op_free(o);
12346 return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
12347 }
12348
12349 /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
12350 if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
12351 rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
12352 new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
12353 } else {
12354 rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
12355 new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
12356 }
12357 #ifdef USE_ITHREADS
12358 op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
12359 #else
12360 cMETHOPx(new_op)->op_rclass_sv = rclass;
12361 #endif
12362 op_free(o);
12363 return new_op;
12364 }
12365
12366 OP *
Perl_ck_null(pTHX_ OP * o)12367 Perl_ck_null(pTHX_ OP *o)
12368 {
12369 PERL_ARGS_ASSERT_CK_NULL;
12370 PERL_UNUSED_CONTEXT;
12371 return o;
12372 }
12373
12374 OP *
Perl_ck_open(pTHX_ OP * o)12375 Perl_ck_open(pTHX_ OP *o)
12376 {
12377 PERL_ARGS_ASSERT_CK_OPEN;
12378
12379 S_io_hints(aTHX_ o);
12380 {
12381 /* In case of three-arg dup open remove strictness
12382 * from the last arg if it is a bareword. */
12383 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
12384 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
12385 OP *oa;
12386 const char *mode;
12387
12388 if ((last->op_type == OP_CONST) && /* The bareword. */
12389 (last->op_private & OPpCONST_BARE) &&
12390 (last->op_private & OPpCONST_STRICT) &&
12391 (oa = OpSIBLING(first)) && /* The fh. */
12392 (oa = OpSIBLING(oa)) && /* The mode. */
12393 (oa->op_type == OP_CONST) &&
12394 SvPOK(((SVOP*)oa)->op_sv) &&
12395 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
12396 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
12397 (last == OpSIBLING(oa))) /* The bareword. */
12398 last->op_private &= ~OPpCONST_STRICT;
12399 }
12400 return ck_fun(o);
12401 }
12402
12403 OP *
Perl_ck_prototype(pTHX_ OP * o)12404 Perl_ck_prototype(pTHX_ OP *o)
12405 {
12406 PERL_ARGS_ASSERT_CK_PROTOTYPE;
12407 if (!(o->op_flags & OPf_KIDS)) {
12408 op_free(o);
12409 return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
12410 }
12411 return o;
12412 }
12413
12414 OP *
Perl_ck_refassign(pTHX_ OP * o)12415 Perl_ck_refassign(pTHX_ OP *o)
12416 {
12417 OP * const right = cLISTOPo->op_first;
12418 OP * const left = OpSIBLING(right);
12419 OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
12420 bool stacked = 0;
12421
12422 PERL_ARGS_ASSERT_CK_REFASSIGN;
12423 assert (left);
12424 assert (left->op_type == OP_SREFGEN);
12425
12426 o->op_private = 0;
12427 /* we use OPpPAD_STATE in refassign to mean either of those things,
12428 * and the code assumes the two flags occupy the same bit position
12429 * in the various ops below */
12430 assert(OPpPAD_STATE == OPpOUR_INTRO);
12431
12432 switch (varop->op_type) {
12433 case OP_PADAV:
12434 o->op_private |= OPpLVREF_AV;
12435 goto settarg;
12436 case OP_PADHV:
12437 o->op_private |= OPpLVREF_HV;
12438 /* FALLTHROUGH */
12439 case OP_PADSV:
12440 settarg:
12441 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
12442 o->op_targ = varop->op_targ;
12443 varop->op_targ = 0;
12444 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
12445 break;
12446
12447 case OP_RV2AV:
12448 o->op_private |= OPpLVREF_AV;
12449 goto checkgv;
12450 NOT_REACHED; /* NOTREACHED */
12451 case OP_RV2HV:
12452 o->op_private |= OPpLVREF_HV;
12453 /* FALLTHROUGH */
12454 case OP_RV2SV:
12455 checkgv:
12456 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
12457 if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
12458 detach_and_stack:
12459 /* Point varop to its GV kid, detached. */
12460 varop = op_sibling_splice(varop, NULL, -1, NULL);
12461 stacked = TRUE;
12462 break;
12463 case OP_RV2CV: {
12464 OP * const kidparent =
12465 OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
12466 OP * const kid = cUNOPx(kidparent)->op_first;
12467 o->op_private |= OPpLVREF_CV;
12468 if (kid->op_type == OP_GV) {
12469 varop = kidparent;
12470 goto detach_and_stack;
12471 }
12472 if (kid->op_type != OP_PADCV) goto bad;
12473 o->op_targ = kid->op_targ;
12474 kid->op_targ = 0;
12475 break;
12476 }
12477 case OP_AELEM:
12478 case OP_HELEM:
12479 o->op_private |= (varop->op_private & OPpLVAL_INTRO);
12480 o->op_private |= OPpLVREF_ELEM;
12481 op_null(varop);
12482 stacked = TRUE;
12483 /* Detach varop. */
12484 op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
12485 break;
12486 default:
12487 bad:
12488 /* diag_listed_as: Can't modify reference to %s in %s assignment */
12489 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
12490 "assignment",
12491 OP_DESC(varop)));
12492 return o;
12493 }
12494 if (!FEATURE_REFALIASING_IS_ENABLED)
12495 Perl_croak(aTHX_
12496 "Experimental aliasing via reference not enabled");
12497 Perl_ck_warner_d(aTHX_
12498 packWARN(WARN_EXPERIMENTAL__REFALIASING),
12499 "Aliasing via reference is experimental");
12500 if (stacked) {
12501 o->op_flags |= OPf_STACKED;
12502 op_sibling_splice(o, right, 1, varop);
12503 }
12504 else {
12505 o->op_flags &=~ OPf_STACKED;
12506 op_sibling_splice(o, right, 1, NULL);
12507 }
12508 op_free(left);
12509 return o;
12510 }
12511
12512 OP *
Perl_ck_repeat(pTHX_ OP * o)12513 Perl_ck_repeat(pTHX_ OP *o)
12514 {
12515 PERL_ARGS_ASSERT_CK_REPEAT;
12516
12517 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
12518 OP* kids;
12519 o->op_private |= OPpREPEAT_DOLIST;
12520 kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
12521 kids = force_list(kids, 1); /* promote it to a list */
12522 op_sibling_splice(o, NULL, 0, kids); /* and add back */
12523 }
12524 else
12525 scalar(o);
12526 return o;
12527 }
12528
12529 OP *
Perl_ck_require(pTHX_ OP * o)12530 Perl_ck_require(pTHX_ OP *o)
12531 {
12532 GV* gv;
12533
12534 PERL_ARGS_ASSERT_CK_REQUIRE;
12535
12536 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
12537 SVOP * const kid = (SVOP*)cUNOPo->op_first;
12538 U32 hash;
12539 char *s;
12540 STRLEN len;
12541 if (kid->op_type == OP_CONST) {
12542 SV * const sv = kid->op_sv;
12543 U32 const was_readonly = SvREADONLY(sv);
12544 if (kid->op_private & OPpCONST_BARE) {
12545 dVAR;
12546 const char *end;
12547 HEK *hek;
12548
12549 if (was_readonly) {
12550 SvREADONLY_off(sv);
12551 }
12552 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
12553
12554 s = SvPVX(sv);
12555 len = SvCUR(sv);
12556 end = s + len;
12557 /* treat ::foo::bar as foo::bar */
12558 if (len >= 2 && s[0] == ':' && s[1] == ':')
12559 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
12560 if (s == end)
12561 DIE(aTHX_ "Bareword in require maps to empty filename");
12562
12563 for (; s < end; s++) {
12564 if (*s == ':' && s[1] == ':') {
12565 *s = '/';
12566 Move(s+2, s+1, end - s - 1, char);
12567 --end;
12568 }
12569 }
12570 SvEND_set(sv, end);
12571 sv_catpvs(sv, ".pm");
12572 PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
12573 hek = share_hek(SvPVX(sv),
12574 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
12575 hash);
12576 sv_sethek(sv, hek);
12577 unshare_hek(hek);
12578 SvFLAGS(sv) |= was_readonly;
12579 }
12580 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
12581 && !SvVOK(sv)) {
12582 s = SvPV(sv, len);
12583 if (SvREFCNT(sv) > 1) {
12584 kid->op_sv = newSVpvn_share(
12585 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
12586 SvREFCNT_dec_NN(sv);
12587 }
12588 else {
12589 dVAR;
12590 HEK *hek;
12591 if (was_readonly) SvREADONLY_off(sv);
12592 PERL_HASH(hash, s, len);
12593 hek = share_hek(s,
12594 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
12595 hash);
12596 sv_sethek(sv, hek);
12597 unshare_hek(hek);
12598 SvFLAGS(sv) |= was_readonly;
12599 }
12600 }
12601 }
12602 }
12603
12604 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
12605 /* handle override, if any */
12606 && (gv = gv_override("require", 7))) {
12607 OP *kid, *newop;
12608 if (o->op_flags & OPf_KIDS) {
12609 kid = cUNOPo->op_first;
12610 op_sibling_splice(o, NULL, -1, NULL);
12611 }
12612 else {
12613 kid = newDEFSVOP();
12614 }
12615 op_free(o);
12616 newop = S_new_entersubop(aTHX_ gv, kid);
12617 return newop;
12618 }
12619
12620 return ck_fun(o);
12621 }
12622
12623 OP *
Perl_ck_return(pTHX_ OP * o)12624 Perl_ck_return(pTHX_ OP *o)
12625 {
12626 OP *kid;
12627
12628 PERL_ARGS_ASSERT_CK_RETURN;
12629
12630 kid = OpSIBLING(cLISTOPo->op_first);
12631 if (PL_compcv && CvLVALUE(PL_compcv)) {
12632 for (; kid; kid = OpSIBLING(kid))
12633 op_lvalue(kid, OP_LEAVESUBLV);
12634 }
12635
12636 return o;
12637 }
12638
12639 OP *
Perl_ck_select(pTHX_ OP * o)12640 Perl_ck_select(pTHX_ OP *o)
12641 {
12642 dVAR;
12643 OP* kid;
12644
12645 PERL_ARGS_ASSERT_CK_SELECT;
12646
12647 if (o->op_flags & OPf_KIDS) {
12648 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12649 if (kid && OpHAS_SIBLING(kid)) {
12650 OpTYPE_set(o, OP_SSELECT);
12651 o = ck_fun(o);
12652 return fold_constants(op_integerize(op_std_init(o)));
12653 }
12654 }
12655 o = ck_fun(o);
12656 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12657 if (kid && kid->op_type == OP_RV2GV)
12658 kid->op_private &= ~HINT_STRICT_REFS;
12659 return o;
12660 }
12661
12662 OP *
Perl_ck_shift(pTHX_ OP * o)12663 Perl_ck_shift(pTHX_ OP *o)
12664 {
12665 const I32 type = o->op_type;
12666
12667 PERL_ARGS_ASSERT_CK_SHIFT;
12668
12669 if (!(o->op_flags & OPf_KIDS)) {
12670 OP *argop;
12671
12672 if (!CvUNIQUE(PL_compcv)) {
12673 o->op_flags |= OPf_SPECIAL;
12674 return o;
12675 }
12676
12677 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
12678 op_free(o);
12679 return newUNOP(type, 0, scalar(argop));
12680 }
12681 return scalar(ck_fun(o));
12682 }
12683
12684 OP *
Perl_ck_sort(pTHX_ OP * o)12685 Perl_ck_sort(pTHX_ OP *o)
12686 {
12687 OP *firstkid;
12688 OP *kid;
12689 HV * const hinthv =
12690 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
12691 U8 stacked;
12692
12693 PERL_ARGS_ASSERT_CK_SORT;
12694
12695 if (hinthv) {
12696 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
12697 if (svp) {
12698 const I32 sorthints = (I32)SvIV(*svp);
12699 if ((sorthints & HINT_SORT_STABLE) != 0)
12700 o->op_private |= OPpSORT_STABLE;
12701 if ((sorthints & HINT_SORT_UNSTABLE) != 0)
12702 o->op_private |= OPpSORT_UNSTABLE;
12703 }
12704 }
12705
12706 if (o->op_flags & OPf_STACKED)
12707 simplify_sort(o);
12708 firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12709
12710 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
12711 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
12712
12713 /* if the first arg is a code block, process it and mark sort as
12714 * OPf_SPECIAL */
12715 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
12716 LINKLIST(kid);
12717 if (kid->op_type == OP_LEAVE)
12718 op_null(kid); /* wipe out leave */
12719 /* Prevent execution from escaping out of the sort block. */
12720 kid->op_next = 0;
12721
12722 /* provide scalar context for comparison function/block */
12723 kid = scalar(firstkid);
12724 kid->op_next = kid;
12725 o->op_flags |= OPf_SPECIAL;
12726 }
12727 else if (kid->op_type == OP_CONST
12728 && kid->op_private & OPpCONST_BARE) {
12729 char tmpbuf[256];
12730 STRLEN len;
12731 PADOFFSET off;
12732 const char * const name = SvPV(kSVOP_sv, len);
12733 *tmpbuf = '&';
12734 assert (len < 256);
12735 Copy(name, tmpbuf+1, len, char);
12736 off = pad_findmy_pvn(tmpbuf, len+1, 0);
12737 if (off != NOT_IN_PAD) {
12738 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
12739 SV * const fq =
12740 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
12741 sv_catpvs(fq, "::");
12742 sv_catsv(fq, kSVOP_sv);
12743 SvREFCNT_dec_NN(kSVOP_sv);
12744 kSVOP->op_sv = fq;
12745 }
12746 else {
12747 OP * const padop = newOP(OP_PADCV, 0);
12748 padop->op_targ = off;
12749 /* replace the const op with the pad op */
12750 op_sibling_splice(firstkid, NULL, 1, padop);
12751 op_free(kid);
12752 }
12753 }
12754 }
12755
12756 firstkid = OpSIBLING(firstkid);
12757 }
12758
12759 for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
12760 /* provide list context for arguments */
12761 list(kid);
12762 if (stacked)
12763 op_lvalue(kid, OP_GREPSTART);
12764 }
12765
12766 return o;
12767 }
12768
12769 /* for sort { X } ..., where X is one of
12770 * $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
12771 * elide the second child of the sort (the one containing X),
12772 * and set these flags as appropriate
12773 OPpSORT_NUMERIC;
12774 OPpSORT_INTEGER;
12775 OPpSORT_DESCEND;
12776 * Also, check and warn on lexical $a, $b.
12777 */
12778
12779 STATIC void
S_simplify_sort(pTHX_ OP * o)12780 S_simplify_sort(pTHX_ OP *o)
12781 {
12782 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12783 OP *k;
12784 int descending;
12785 GV *gv;
12786 const char *gvname;
12787 bool have_scopeop;
12788
12789 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
12790
12791 kid = kUNOP->op_first; /* get past null */
12792 if (!(have_scopeop = kid->op_type == OP_SCOPE)
12793 && kid->op_type != OP_LEAVE)
12794 return;
12795 kid = kLISTOP->op_last; /* get past scope */
12796 switch(kid->op_type) {
12797 case OP_NCMP:
12798 case OP_I_NCMP:
12799 case OP_SCMP:
12800 if (!have_scopeop) goto padkids;
12801 break;
12802 default:
12803 return;
12804 }
12805 k = kid; /* remember this node*/
12806 if (kBINOP->op_first->op_type != OP_RV2SV
12807 || kBINOP->op_last ->op_type != OP_RV2SV)
12808 {
12809 /*
12810 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
12811 then used in a comparison. This catches most, but not
12812 all cases. For instance, it catches
12813 sort { my($a); $a <=> $b }
12814 but not
12815 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
12816 (although why you'd do that is anyone's guess).
12817 */
12818
12819 padkids:
12820 if (!ckWARN(WARN_SYNTAX)) return;
12821 kid = kBINOP->op_first;
12822 do {
12823 if (kid->op_type == OP_PADSV) {
12824 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
12825 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
12826 && ( PadnamePV(name)[1] == 'a'
12827 || PadnamePV(name)[1] == 'b' ))
12828 /* diag_listed_as: "my %s" used in sort comparison */
12829 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12830 "\"%s %s\" used in sort comparison",
12831 PadnameIsSTATE(name)
12832 ? "state"
12833 : "my",
12834 PadnamePV(name));
12835 }
12836 } while ((kid = OpSIBLING(kid)));
12837 return;
12838 }
12839 kid = kBINOP->op_first; /* get past cmp */
12840 if (kUNOP->op_first->op_type != OP_GV)
12841 return;
12842 kid = kUNOP->op_first; /* get past rv2sv */
12843 gv = kGVOP_gv;
12844 if (GvSTASH(gv) != PL_curstash)
12845 return;
12846 gvname = GvNAME(gv);
12847 if (*gvname == 'a' && gvname[1] == '\0')
12848 descending = 0;
12849 else if (*gvname == 'b' && gvname[1] == '\0')
12850 descending = 1;
12851 else
12852 return;
12853
12854 kid = k; /* back to cmp */
12855 /* already checked above that it is rv2sv */
12856 kid = kBINOP->op_last; /* down to 2nd arg */
12857 if (kUNOP->op_first->op_type != OP_GV)
12858 return;
12859 kid = kUNOP->op_first; /* get past rv2sv */
12860 gv = kGVOP_gv;
12861 if (GvSTASH(gv) != PL_curstash)
12862 return;
12863 gvname = GvNAME(gv);
12864 if ( descending
12865 ? !(*gvname == 'a' && gvname[1] == '\0')
12866 : !(*gvname == 'b' && gvname[1] == '\0'))
12867 return;
12868 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
12869 if (descending)
12870 o->op_private |= OPpSORT_DESCEND;
12871 if (k->op_type == OP_NCMP)
12872 o->op_private |= OPpSORT_NUMERIC;
12873 if (k->op_type == OP_I_NCMP)
12874 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
12875 kid = OpSIBLING(cLISTOPo->op_first);
12876 /* cut out and delete old block (second sibling) */
12877 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
12878 op_free(kid);
12879 }
12880
12881 OP *
Perl_ck_split(pTHX_ OP * o)12882 Perl_ck_split(pTHX_ OP *o)
12883 {
12884 dVAR;
12885 OP *kid;
12886 OP *sibs;
12887
12888 PERL_ARGS_ASSERT_CK_SPLIT;
12889
12890 assert(o->op_type == OP_LIST);
12891
12892 if (o->op_flags & OPf_STACKED)
12893 return no_fh_allowed(o);
12894
12895 kid = cLISTOPo->op_first;
12896 /* delete leading NULL node, then add a CONST if no other nodes */
12897 assert(kid->op_type == OP_NULL);
12898 op_sibling_splice(o, NULL, 1,
12899 OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
12900 op_free(kid);
12901 kid = cLISTOPo->op_first;
12902
12903 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
12904 /* remove match expression, and replace with new optree with
12905 * a match op at its head */
12906 op_sibling_splice(o, NULL, 1, NULL);
12907 /* pmruntime will handle split " " behavior with flag==2 */
12908 kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
12909 op_sibling_splice(o, NULL, 0, kid);
12910 }
12911
12912 assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
12913
12914 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
12915 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
12916 "Use of /g modifier is meaningless in split");
12917 }
12918
12919 /* eliminate the split op, and move the match op (plus any children)
12920 * into its place, then convert the match op into a split op. i.e.
12921 *
12922 * SPLIT MATCH SPLIT(ex-MATCH)
12923 * | | |
12924 * MATCH - A - B - C => R - A - B - C => R - A - B - C
12925 * | | |
12926 * R X - Y X - Y
12927 * |
12928 * X - Y
12929 *
12930 * (R, if it exists, will be a regcomp op)
12931 */
12932
12933 op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
12934 sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
12935 op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
12936 OpTYPE_set(kid, OP_SPLIT);
12937 kid->op_flags = (o->op_flags | (kid->op_flags & OPf_KIDS));
12938 kid->op_private = o->op_private;
12939 op_free(o);
12940 o = kid;
12941 kid = sibs; /* kid is now the string arg of the split */
12942
12943 if (!kid) {
12944 kid = newDEFSVOP();
12945 op_append_elem(OP_SPLIT, o, kid);
12946 }
12947 scalar(kid);
12948
12949 kid = OpSIBLING(kid);
12950 if (!kid) {
12951 kid = newSVOP(OP_CONST, 0, newSViv(0));
12952 op_append_elem(OP_SPLIT, o, kid);
12953 o->op_private |= OPpSPLIT_IMPLIM;
12954 }
12955 scalar(kid);
12956
12957 if (OpHAS_SIBLING(kid))
12958 return too_many_arguments_pv(o,OP_DESC(o), 0);
12959
12960 return o;
12961 }
12962
12963 OP *
Perl_ck_stringify(pTHX_ OP * o)12964 Perl_ck_stringify(pTHX_ OP *o)
12965 {
12966 OP * const kid = OpSIBLING(cUNOPo->op_first);
12967 PERL_ARGS_ASSERT_CK_STRINGIFY;
12968 if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
12969 || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
12970 || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
12971 && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
12972 {
12973 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
12974 op_free(o);
12975 return kid;
12976 }
12977 return ck_fun(o);
12978 }
12979
12980 OP *
Perl_ck_join(pTHX_ OP * o)12981 Perl_ck_join(pTHX_ OP *o)
12982 {
12983 OP * const kid = OpSIBLING(cLISTOPo->op_first);
12984
12985 PERL_ARGS_ASSERT_CK_JOIN;
12986
12987 if (kid && kid->op_type == OP_MATCH) {
12988 if (ckWARN(WARN_SYNTAX)) {
12989 const REGEXP *re = PM_GETRE(kPMOP);
12990 const SV *msg = re
12991 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
12992 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
12993 : newSVpvs_flags( "STRING", SVs_TEMP );
12994 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12995 "/%" SVf "/ should probably be written as \"%" SVf "\"",
12996 SVfARG(msg), SVfARG(msg));
12997 }
12998 }
12999 if (kid
13000 && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
13001 || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
13002 || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
13003 && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
13004 {
13005 const OP * const bairn = OpSIBLING(kid); /* the list */
13006 if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
13007 && OP_GIMME(bairn,0) == G_SCALAR)
13008 {
13009 OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
13010 op_sibling_splice(o, kid, 1, NULL));
13011 op_free(o);
13012 return ret;
13013 }
13014 }
13015
13016 return ck_fun(o);
13017 }
13018
13019 /*
13020 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
13021
13022 Examines an op, which is expected to identify a subroutine at runtime,
13023 and attempts to determine at compile time which subroutine it identifies.
13024 This is normally used during Perl compilation to determine whether
13025 a prototype can be applied to a function call. C<cvop> is the op
13026 being considered, normally an C<rv2cv> op. A pointer to the identified
13027 subroutine is returned, if it could be determined statically, and a null
13028 pointer is returned if it was not possible to determine statically.
13029
13030 Currently, the subroutine can be identified statically if the RV that the
13031 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
13032 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
13033 suitable if the constant value must be an RV pointing to a CV. Details of
13034 this process may change in future versions of Perl. If the C<rv2cv> op
13035 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
13036 the subroutine statically: this flag is used to suppress compile-time
13037 magic on a subroutine call, forcing it to use default runtime behaviour.
13038
13039 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
13040 of a GV reference is modified. If a GV was examined and its CV slot was
13041 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
13042 If the op is not optimised away, and the CV slot is later populated with
13043 a subroutine having a prototype, that flag eventually triggers the warning
13044 "called too early to check prototype".
13045
13046 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
13047 of returning a pointer to the subroutine it returns a pointer to the
13048 GV giving the most appropriate name for the subroutine in this context.
13049 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
13050 (C<CvANON>) subroutine that is referenced through a GV it will be the
13051 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
13052 A null pointer is returned as usual if there is no statically-determinable
13053 subroutine.
13054
13055 =cut
13056 */
13057
13058 /* shared by toke.c:yylex */
13059 CV *
Perl_find_lexical_cv(pTHX_ PADOFFSET off)13060 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
13061 {
13062 PADNAME *name = PAD_COMPNAME(off);
13063 CV *compcv = PL_compcv;
13064 while (PadnameOUTER(name)) {
13065 assert(PARENT_PAD_INDEX(name));
13066 compcv = CvOUTSIDE(compcv);
13067 name = PadlistNAMESARRAY(CvPADLIST(compcv))
13068 [off = PARENT_PAD_INDEX(name)];
13069 }
13070 assert(!PadnameIsOUR(name));
13071 if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
13072 return PadnamePROTOCV(name);
13073 }
13074 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
13075 }
13076
13077 CV *
Perl_rv2cv_op_cv(pTHX_ OP * cvop,U32 flags)13078 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
13079 {
13080 OP *rvop;
13081 CV *cv;
13082 GV *gv;
13083 PERL_ARGS_ASSERT_RV2CV_OP_CV;
13084 if (flags & ~RV2CVOPCV_FLAG_MASK)
13085 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
13086 if (cvop->op_type != OP_RV2CV)
13087 return NULL;
13088 if (cvop->op_private & OPpENTERSUB_AMPER)
13089 return NULL;
13090 if (!(cvop->op_flags & OPf_KIDS))
13091 return NULL;
13092 rvop = cUNOPx(cvop)->op_first;
13093 switch (rvop->op_type) {
13094 case OP_GV: {
13095 gv = cGVOPx_gv(rvop);
13096 if (!isGV(gv)) {
13097 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
13098 cv = MUTABLE_CV(SvRV(gv));
13099 gv = NULL;
13100 break;
13101 }
13102 if (flags & RV2CVOPCV_RETURN_STUB)
13103 return (CV *)gv;
13104 else return NULL;
13105 }
13106 cv = GvCVu(gv);
13107 if (!cv) {
13108 if (flags & RV2CVOPCV_MARK_EARLY)
13109 rvop->op_private |= OPpEARLY_CV;
13110 return NULL;
13111 }
13112 } break;
13113 case OP_CONST: {
13114 SV *rv = cSVOPx_sv(rvop);
13115 if (!SvROK(rv))
13116 return NULL;
13117 cv = (CV*)SvRV(rv);
13118 gv = NULL;
13119 } break;
13120 case OP_PADCV: {
13121 cv = find_lexical_cv(rvop->op_targ);
13122 gv = NULL;
13123 } break;
13124 default: {
13125 return NULL;
13126 } NOT_REACHED; /* NOTREACHED */
13127 }
13128 if (SvTYPE((SV*)cv) != SVt_PVCV)
13129 return NULL;
13130 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
13131 if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
13132 gv = CvGV(cv);
13133 return (CV*)gv;
13134 }
13135 else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
13136 if (CvLEXICAL(cv) || CvNAMED(cv))
13137 return NULL;
13138 if (!CvANON(cv) || !gv)
13139 gv = CvGV(cv);
13140 return (CV*)gv;
13141
13142 } else {
13143 return cv;
13144 }
13145 }
13146
13147 /*
13148 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
13149
13150 Performs the default fixup of the arguments part of an C<entersub>
13151 op tree. This consists of applying list context to each of the
13152 argument ops. This is the standard treatment used on a call marked
13153 with C<&>, or a method call, or a call through a subroutine reference,
13154 or any other call where the callee can't be identified at compile time,
13155 or a call where the callee has no prototype.
13156
13157 =cut
13158 */
13159
13160 OP *
Perl_ck_entersub_args_list(pTHX_ OP * entersubop)13161 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
13162 {
13163 OP *aop;
13164
13165 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
13166
13167 aop = cUNOPx(entersubop)->op_first;
13168 if (!OpHAS_SIBLING(aop))
13169 aop = cUNOPx(aop)->op_first;
13170 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
13171 /* skip the extra attributes->import() call implicitly added in
13172 * something like foo(my $x : bar)
13173 */
13174 if ( aop->op_type == OP_ENTERSUB
13175 && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
13176 )
13177 continue;
13178 list(aop);
13179 op_lvalue(aop, OP_ENTERSUB);
13180 }
13181 return entersubop;
13182 }
13183
13184 /*
13185 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
13186
13187 Performs the fixup of the arguments part of an C<entersub> op tree
13188 based on a subroutine prototype. This makes various modifications to
13189 the argument ops, from applying context up to inserting C<refgen> ops,
13190 and checking the number and syntactic types of arguments, as directed by
13191 the prototype. This is the standard treatment used on a subroutine call,
13192 not marked with C<&>, where the callee can be identified at compile time
13193 and has a prototype.
13194
13195 C<protosv> supplies the subroutine prototype to be applied to the call.
13196 It may be a normal defined scalar, of which the string value will be used.
13197 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13198 that has been cast to C<SV*>) which has a prototype. The prototype
13199 supplied, in whichever form, does not need to match the actual callee
13200 referenced by the op tree.
13201
13202 If the argument ops disagree with the prototype, for example by having
13203 an unacceptable number of arguments, a valid op tree is returned anyway.
13204 The error is reflected in the parser state, normally resulting in a single
13205 exception at the top level of parsing which covers all the compilation
13206 errors that occurred. In the error message, the callee is referred to
13207 by the name defined by the C<namegv> parameter.
13208
13209 =cut
13210 */
13211
13212 OP *
Perl_ck_entersub_args_proto(pTHX_ OP * entersubop,GV * namegv,SV * protosv)13213 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13214 {
13215 STRLEN proto_len;
13216 const char *proto, *proto_end;
13217 OP *aop, *prev, *cvop, *parent;
13218 int optional = 0;
13219 I32 arg = 0;
13220 I32 contextclass = 0;
13221 const char *e = NULL;
13222 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
13223 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
13224 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
13225 "flags=%lx", (unsigned long) SvFLAGS(protosv));
13226 if (SvTYPE(protosv) == SVt_PVCV)
13227 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
13228 else proto = SvPV(protosv, proto_len);
13229 proto = S_strip_spaces(aTHX_ proto, &proto_len);
13230 proto_end = proto + proto_len;
13231 parent = entersubop;
13232 aop = cUNOPx(entersubop)->op_first;
13233 if (!OpHAS_SIBLING(aop)) {
13234 parent = aop;
13235 aop = cUNOPx(aop)->op_first;
13236 }
13237 prev = aop;
13238 aop = OpSIBLING(aop);
13239 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13240 while (aop != cvop) {
13241 OP* o3 = aop;
13242
13243 if (proto >= proto_end)
13244 {
13245 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13246 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13247 SVfARG(namesv)), SvUTF8(namesv));
13248 return entersubop;
13249 }
13250
13251 switch (*proto) {
13252 case ';':
13253 optional = 1;
13254 proto++;
13255 continue;
13256 case '_':
13257 /* _ must be at the end */
13258 if (proto[1] && !strchr(";@%", proto[1]))
13259 goto oops;
13260 /* FALLTHROUGH */
13261 case '$':
13262 proto++;
13263 arg++;
13264 scalar(aop);
13265 break;
13266 case '%':
13267 case '@':
13268 list(aop);
13269 arg++;
13270 break;
13271 case '&':
13272 proto++;
13273 arg++;
13274 if ( o3->op_type != OP_UNDEF
13275 && (o3->op_type != OP_SREFGEN
13276 || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13277 != OP_ANONCODE
13278 && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13279 != OP_RV2CV)))
13280 bad_type_gv(arg, namegv, o3,
13281 arg == 1 ? "block or sub {}" : "sub {}");
13282 break;
13283 case '*':
13284 /* '*' allows any scalar type, including bareword */
13285 proto++;
13286 arg++;
13287 if (o3->op_type == OP_RV2GV)
13288 goto wrapref; /* autoconvert GLOB -> GLOBref */
13289 else if (o3->op_type == OP_CONST)
13290 o3->op_private &= ~OPpCONST_STRICT;
13291 scalar(aop);
13292 break;
13293 case '+':
13294 proto++;
13295 arg++;
13296 if (o3->op_type == OP_RV2AV ||
13297 o3->op_type == OP_PADAV ||
13298 o3->op_type == OP_RV2HV ||
13299 o3->op_type == OP_PADHV
13300 ) {
13301 goto wrapref;
13302 }
13303 scalar(aop);
13304 break;
13305 case '[': case ']':
13306 goto oops;
13307
13308 case '\\':
13309 proto++;
13310 arg++;
13311 again:
13312 switch (*proto++) {
13313 case '[':
13314 if (contextclass++ == 0) {
13315 e = (char *) memchr(proto, ']', proto_end - proto);
13316 if (!e || e == proto)
13317 goto oops;
13318 }
13319 else
13320 goto oops;
13321 goto again;
13322
13323 case ']':
13324 if (contextclass) {
13325 const char *p = proto;
13326 const char *const end = proto;
13327 contextclass = 0;
13328 while (*--p != '[')
13329 /* \[$] accepts any scalar lvalue */
13330 if (*p == '$'
13331 && Perl_op_lvalue_flags(aTHX_
13332 scalar(o3),
13333 OP_READ, /* not entersub */
13334 OP_LVALUE_NO_CROAK
13335 )) goto wrapref;
13336 bad_type_gv(arg, namegv, o3,
13337 Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
13338 } else
13339 goto oops;
13340 break;
13341 case '*':
13342 if (o3->op_type == OP_RV2GV)
13343 goto wrapref;
13344 if (!contextclass)
13345 bad_type_gv(arg, namegv, o3, "symbol");
13346 break;
13347 case '&':
13348 if (o3->op_type == OP_ENTERSUB
13349 && !(o3->op_flags & OPf_STACKED))
13350 goto wrapref;
13351 if (!contextclass)
13352 bad_type_gv(arg, namegv, o3, "subroutine");
13353 break;
13354 case '$':
13355 if (o3->op_type == OP_RV2SV ||
13356 o3->op_type == OP_PADSV ||
13357 o3->op_type == OP_HELEM ||
13358 o3->op_type == OP_AELEM)
13359 goto wrapref;
13360 if (!contextclass) {
13361 /* \$ accepts any scalar lvalue */
13362 if (Perl_op_lvalue_flags(aTHX_
13363 scalar(o3),
13364 OP_READ, /* not entersub */
13365 OP_LVALUE_NO_CROAK
13366 )) goto wrapref;
13367 bad_type_gv(arg, namegv, o3, "scalar");
13368 }
13369 break;
13370 case '@':
13371 if (o3->op_type == OP_RV2AV ||
13372 o3->op_type == OP_PADAV)
13373 {
13374 o3->op_flags &=~ OPf_PARENS;
13375 goto wrapref;
13376 }
13377 if (!contextclass)
13378 bad_type_gv(arg, namegv, o3, "array");
13379 break;
13380 case '%':
13381 if (o3->op_type == OP_RV2HV ||
13382 o3->op_type == OP_PADHV)
13383 {
13384 o3->op_flags &=~ OPf_PARENS;
13385 goto wrapref;
13386 }
13387 if (!contextclass)
13388 bad_type_gv(arg, namegv, o3, "hash");
13389 break;
13390 wrapref:
13391 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
13392 OP_REFGEN, 0);
13393 if (contextclass && e) {
13394 proto = e + 1;
13395 contextclass = 0;
13396 }
13397 break;
13398 default: goto oops;
13399 }
13400 if (contextclass)
13401 goto again;
13402 break;
13403 case ' ':
13404 proto++;
13405 continue;
13406 default:
13407 oops: {
13408 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
13409 SVfARG(cv_name((CV *)namegv, NULL, 0)),
13410 SVfARG(protosv));
13411 }
13412 }
13413
13414 op_lvalue(aop, OP_ENTERSUB);
13415 prev = aop;
13416 aop = OpSIBLING(aop);
13417 }
13418 if (aop == cvop && *proto == '_') {
13419 /* generate an access to $_ */
13420 op_sibling_splice(parent, prev, 0, newDEFSVOP());
13421 }
13422 if (!optional && proto_end > proto &&
13423 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
13424 {
13425 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13426 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
13427 SVfARG(namesv)), SvUTF8(namesv));
13428 }
13429 return entersubop;
13430 }
13431
13432 /*
13433 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
13434
13435 Performs the fixup of the arguments part of an C<entersub> op tree either
13436 based on a subroutine prototype or using default list-context processing.
13437 This is the standard treatment used on a subroutine call, not marked
13438 with C<&>, where the callee can be identified at compile time.
13439
13440 C<protosv> supplies the subroutine prototype to be applied to the call,
13441 or indicates that there is no prototype. It may be a normal scalar,
13442 in which case if it is defined then the string value will be used
13443 as a prototype, and if it is undefined then there is no prototype.
13444 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13445 that has been cast to C<SV*>), of which the prototype will be used if it
13446 has one. The prototype (or lack thereof) supplied, in whichever form,
13447 does not need to match the actual callee referenced by the op tree.
13448
13449 If the argument ops disagree with the prototype, for example by having
13450 an unacceptable number of arguments, a valid op tree is returned anyway.
13451 The error is reflected in the parser state, normally resulting in a single
13452 exception at the top level of parsing which covers all the compilation
13453 errors that occurred. In the error message, the callee is referred to
13454 by the name defined by the C<namegv> parameter.
13455
13456 =cut
13457 */
13458
13459 OP *
Perl_ck_entersub_args_proto_or_list(pTHX_ OP * entersubop,GV * namegv,SV * protosv)13460 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
13461 GV *namegv, SV *protosv)
13462 {
13463 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
13464 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
13465 return ck_entersub_args_proto(entersubop, namegv, protosv);
13466 else
13467 return ck_entersub_args_list(entersubop);
13468 }
13469
13470 OP *
Perl_ck_entersub_args_core(pTHX_ OP * entersubop,GV * namegv,SV * protosv)13471 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13472 {
13473 IV cvflags = SvIVX(protosv);
13474 int opnum = cvflags & 0xffff;
13475 OP *aop = cUNOPx(entersubop)->op_first;
13476
13477 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
13478
13479 if (!opnum) {
13480 OP *cvop;
13481 if (!OpHAS_SIBLING(aop))
13482 aop = cUNOPx(aop)->op_first;
13483 aop = OpSIBLING(aop);
13484 for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13485 if (aop != cvop) {
13486 SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13487 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13488 SVfARG(namesv)), SvUTF8(namesv));
13489 }
13490
13491 op_free(entersubop);
13492 switch(cvflags >> 16) {
13493 case 'F': return newSVOP(OP_CONST, 0,
13494 newSVpv(CopFILE(PL_curcop),0));
13495 case 'L': return newSVOP(
13496 OP_CONST, 0,
13497 Perl_newSVpvf(aTHX_
13498 "%" IVdf, (IV)CopLINE(PL_curcop)
13499 )
13500 );
13501 case 'P': return newSVOP(OP_CONST, 0,
13502 (PL_curstash
13503 ? newSVhek(HvNAME_HEK(PL_curstash))
13504 : &PL_sv_undef
13505 )
13506 );
13507 }
13508 NOT_REACHED; /* NOTREACHED */
13509 }
13510 else {
13511 OP *prev, *cvop, *first, *parent;
13512 U32 flags = 0;
13513
13514 parent = entersubop;
13515 if (!OpHAS_SIBLING(aop)) {
13516 parent = aop;
13517 aop = cUNOPx(aop)->op_first;
13518 }
13519
13520 first = prev = aop;
13521 aop = OpSIBLING(aop);
13522 /* find last sibling */
13523 for (cvop = aop;
13524 OpHAS_SIBLING(cvop);
13525 prev = cvop, cvop = OpSIBLING(cvop))
13526 ;
13527 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
13528 /* Usually, OPf_SPECIAL on an op with no args means that it had
13529 * parens, but these have their own meaning for that flag: */
13530 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
13531 && opnum != OP_DELETE && opnum != OP_EXISTS)
13532 flags |= OPf_SPECIAL;
13533 /* excise cvop from end of sibling chain */
13534 op_sibling_splice(parent, prev, 1, NULL);
13535 op_free(cvop);
13536 if (aop == cvop) aop = NULL;
13537
13538 /* detach remaining siblings from the first sibling, then
13539 * dispose of original optree */
13540
13541 if (aop)
13542 op_sibling_splice(parent, first, -1, NULL);
13543 op_free(entersubop);
13544
13545 if (cvflags == (OP_ENTEREVAL | (1<<16)))
13546 flags |= OPpEVAL_BYTES <<8;
13547
13548 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
13549 case OA_UNOP:
13550 case OA_BASEOP_OR_UNOP:
13551 case OA_FILESTATOP:
13552 if (!aop)
13553 return newOP(opnum,flags); /* zero args */
13554 if (aop == prev)
13555 return newUNOP(opnum,flags,aop); /* one arg */
13556 /* too many args */
13557 /* FALLTHROUGH */
13558 case OA_BASEOP:
13559 if (aop) {
13560 SV *namesv;
13561 OP *nextop;
13562
13563 namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13564 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13565 SVfARG(namesv)), SvUTF8(namesv));
13566 while (aop) {
13567 nextop = OpSIBLING(aop);
13568 op_free(aop);
13569 aop = nextop;
13570 }
13571
13572 }
13573 return opnum == OP_RUNCV
13574 ? newPVOP(OP_RUNCV,0,NULL)
13575 : newOP(opnum,0);
13576 default:
13577 return op_convert_list(opnum,0,aop);
13578 }
13579 }
13580 NOT_REACHED; /* NOTREACHED */
13581 return entersubop;
13582 }
13583
13584 /*
13585 =for apidoc Am|void|cv_get_call_checker_flags|CV *cv|U32 gflags|Perl_call_checker *ckfun_p|SV **ckobj_p|U32 *ckflags_p
13586
13587 Retrieves the function that will be used to fix up a call to C<cv>.
13588 Specifically, the function is applied to an C<entersub> op tree for a
13589 subroutine call, not marked with C<&>, where the callee can be identified
13590 at compile time as C<cv>.
13591
13592 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
13593 for it is returned in C<*ckobj_p>, and control flags are returned in
13594 C<*ckflags_p>. The function is intended to be called in this manner:
13595
13596 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
13597
13598 In this call, C<entersubop> is a pointer to the C<entersub> op,
13599 which may be replaced by the check function, and C<namegv> supplies
13600 the name that should be used by the check function to refer
13601 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13602 It is permitted to apply the check function in non-standard situations,
13603 such as to a call to a different subroutine or to a method call.
13604
13605 C<namegv> may not actually be a GV. If the C<CALL_CHECKER_REQUIRE_GV>
13606 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
13607 instead, anything that can be used as the first argument to L</cv_name>.
13608 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
13609 check function requires C<namegv> to be a genuine GV.
13610
13611 By default, the check function is
13612 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
13613 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
13614 flag is clear. This implements standard prototype processing. It can
13615 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
13616
13617 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
13618 indicates that the caller only knows about the genuine GV version of
13619 C<namegv>, and accordingly the corresponding bit will always be set in
13620 C<*ckflags_p>, regardless of the check function's recorded requirements.
13621 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
13622 indicates the caller knows about the possibility of passing something
13623 other than a GV as C<namegv>, and accordingly the corresponding bit may
13624 be either set or clear in C<*ckflags_p>, indicating the check function's
13625 recorded requirements.
13626
13627 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
13628 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
13629 (for which see above). All other bits should be clear.
13630
13631 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
13632
13633 The original form of L</cv_get_call_checker_flags>, which does not return
13634 checker flags. When using a checker function returned by this function,
13635 it is only safe to call it with a genuine GV as its C<namegv> argument.
13636
13637 =cut
13638 */
13639
13640 void
Perl_cv_get_call_checker_flags(pTHX_ CV * cv,U32 gflags,Perl_call_checker * ckfun_p,SV ** ckobj_p,U32 * ckflags_p)13641 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
13642 Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
13643 {
13644 MAGIC *callmg;
13645 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
13646 PERL_UNUSED_CONTEXT;
13647 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
13648 if (callmg) {
13649 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
13650 *ckobj_p = callmg->mg_obj;
13651 *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
13652 } else {
13653 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
13654 *ckobj_p = (SV*)cv;
13655 *ckflags_p = gflags & MGf_REQUIRE_GV;
13656 }
13657 }
13658
13659 void
Perl_cv_get_call_checker(pTHX_ CV * cv,Perl_call_checker * ckfun_p,SV ** ckobj_p)13660 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
13661 {
13662 U32 ckflags;
13663 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
13664 PERL_UNUSED_CONTEXT;
13665 cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
13666 &ckflags);
13667 }
13668
13669 /*
13670 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 ckflags
13671
13672 Sets the function that will be used to fix up a call to C<cv>.
13673 Specifically, the function is applied to an C<entersub> op tree for a
13674 subroutine call, not marked with C<&>, where the callee can be identified
13675 at compile time as C<cv>.
13676
13677 The C-level function pointer is supplied in C<ckfun>, an SV argument for
13678 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
13679 The function should be defined like this:
13680
13681 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
13682
13683 It is intended to be called in this manner:
13684
13685 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
13686
13687 In this call, C<entersubop> is a pointer to the C<entersub> op,
13688 which may be replaced by the check function, and C<namegv> supplies
13689 the name that should be used by the check function to refer
13690 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13691 It is permitted to apply the check function in non-standard situations,
13692 such as to a call to a different subroutine or to a method call.
13693
13694 C<namegv> may not actually be a GV. For efficiency, perl may pass a
13695 CV or other SV instead. Whatever is passed can be used as the first
13696 argument to L</cv_name>. You can force perl to pass a GV by including
13697 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
13698
13699 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
13700 bit currently has a defined meaning (for which see above). All other
13701 bits should be clear.
13702
13703 The current setting for a particular CV can be retrieved by
13704 L</cv_get_call_checker_flags>.
13705
13706 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
13707
13708 The original form of L</cv_set_call_checker_flags>, which passes it the
13709 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility. The effect
13710 of that flag setting is that the check function is guaranteed to get a
13711 genuine GV as its C<namegv> argument.
13712
13713 =cut
13714 */
13715
13716 void
Perl_cv_set_call_checker(pTHX_ CV * cv,Perl_call_checker ckfun,SV * ckobj)13717 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
13718 {
13719 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
13720 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
13721 }
13722
13723 void
Perl_cv_set_call_checker_flags(pTHX_ CV * cv,Perl_call_checker ckfun,SV * ckobj,U32 ckflags)13724 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
13725 SV *ckobj, U32 ckflags)
13726 {
13727 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
13728 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
13729 if (SvMAGICAL((SV*)cv))
13730 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
13731 } else {
13732 MAGIC *callmg;
13733 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
13734 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
13735 assert(callmg);
13736 if (callmg->mg_flags & MGf_REFCOUNTED) {
13737 SvREFCNT_dec(callmg->mg_obj);
13738 callmg->mg_flags &= ~MGf_REFCOUNTED;
13739 }
13740 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
13741 callmg->mg_obj = ckobj;
13742 if (ckobj != (SV*)cv) {
13743 SvREFCNT_inc_simple_void_NN(ckobj);
13744 callmg->mg_flags |= MGf_REFCOUNTED;
13745 }
13746 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
13747 | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
13748 }
13749 }
13750
13751 static void
S_entersub_alloc_targ(pTHX_ OP * const o)13752 S_entersub_alloc_targ(pTHX_ OP * const o)
13753 {
13754 o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
13755 o->op_private |= OPpENTERSUB_HASTARG;
13756 }
13757
13758 OP *
Perl_ck_subr(pTHX_ OP * o)13759 Perl_ck_subr(pTHX_ OP *o)
13760 {
13761 OP *aop, *cvop;
13762 CV *cv;
13763 GV *namegv;
13764 SV **const_class = NULL;
13765
13766 PERL_ARGS_ASSERT_CK_SUBR;
13767
13768 aop = cUNOPx(o)->op_first;
13769 if (!OpHAS_SIBLING(aop))
13770 aop = cUNOPx(aop)->op_first;
13771 aop = OpSIBLING(aop);
13772 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13773 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
13774 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
13775
13776 o->op_private &= ~1;
13777 o->op_private |= (PL_hints & HINT_STRICT_REFS);
13778 if (PERLDB_SUB && PL_curstash != PL_debstash)
13779 o->op_private |= OPpENTERSUB_DB;
13780 switch (cvop->op_type) {
13781 case OP_RV2CV:
13782 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
13783 op_null(cvop);
13784 break;
13785 case OP_METHOD:
13786 case OP_METHOD_NAMED:
13787 case OP_METHOD_SUPER:
13788 case OP_METHOD_REDIR:
13789 case OP_METHOD_REDIR_SUPER:
13790 o->op_flags |= OPf_REF;
13791 if (aop->op_type == OP_CONST) {
13792 aop->op_private &= ~OPpCONST_STRICT;
13793 const_class = &cSVOPx(aop)->op_sv;
13794 }
13795 else if (aop->op_type == OP_LIST) {
13796 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
13797 if (sib && sib->op_type == OP_CONST) {
13798 sib->op_private &= ~OPpCONST_STRICT;
13799 const_class = &cSVOPx(sib)->op_sv;
13800 }
13801 }
13802 /* make class name a shared cow string to speedup method calls */
13803 /* constant string might be replaced with object, f.e. bigint */
13804 if (const_class && SvPOK(*const_class)) {
13805 STRLEN len;
13806 const char* str = SvPV(*const_class, len);
13807 if (len) {
13808 SV* const shared = newSVpvn_share(
13809 str, SvUTF8(*const_class)
13810 ? -(SSize_t)len : (SSize_t)len,
13811 0
13812 );
13813 if (SvREADONLY(*const_class))
13814 SvREADONLY_on(shared);
13815 SvREFCNT_dec(*const_class);
13816 *const_class = shared;
13817 }
13818 }
13819 break;
13820 }
13821
13822 if (!cv) {
13823 S_entersub_alloc_targ(aTHX_ o);
13824 return ck_entersub_args_list(o);
13825 } else {
13826 Perl_call_checker ckfun;
13827 SV *ckobj;
13828 U32 ckflags;
13829 cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
13830 if (CvISXSUB(cv) || !CvROOT(cv))
13831 S_entersub_alloc_targ(aTHX_ o);
13832 if (!namegv) {
13833 /* The original call checker API guarantees that a GV will be
13834 be provided with the right name. So, if the old API was
13835 used (or the REQUIRE_GV flag was passed), we have to reify
13836 the CV’s GV, unless this is an anonymous sub. This is not
13837 ideal for lexical subs, as its stringification will include
13838 the package. But it is the best we can do. */
13839 if (ckflags & CALL_CHECKER_REQUIRE_GV) {
13840 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
13841 namegv = CvGV(cv);
13842 }
13843 else namegv = MUTABLE_GV(cv);
13844 /* After a syntax error in a lexical sub, the cv that
13845 rv2cv_op_cv returns may be a nameless stub. */
13846 if (!namegv) return ck_entersub_args_list(o);
13847
13848 }
13849 return ckfun(aTHX_ o, namegv, ckobj);
13850 }
13851 }
13852
13853 OP *
Perl_ck_svconst(pTHX_ OP * o)13854 Perl_ck_svconst(pTHX_ OP *o)
13855 {
13856 SV * const sv = cSVOPo->op_sv;
13857 PERL_ARGS_ASSERT_CK_SVCONST;
13858 PERL_UNUSED_CONTEXT;
13859 #ifdef PERL_COPY_ON_WRITE
13860 /* Since the read-only flag may be used to protect a string buffer, we
13861 cannot do copy-on-write with existing read-only scalars that are not
13862 already copy-on-write scalars. To allow $_ = "hello" to do COW with
13863 that constant, mark the constant as COWable here, if it is not
13864 already read-only. */
13865 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
13866 SvIsCOW_on(sv);
13867 CowREFCNT(sv) = 0;
13868 # ifdef PERL_DEBUG_READONLY_COW
13869 sv_buf_to_ro(sv);
13870 # endif
13871 }
13872 #endif
13873 SvREADONLY_on(sv);
13874 return o;
13875 }
13876
13877 OP *
Perl_ck_trunc(pTHX_ OP * o)13878 Perl_ck_trunc(pTHX_ OP *o)
13879 {
13880 PERL_ARGS_ASSERT_CK_TRUNC;
13881
13882 if (o->op_flags & OPf_KIDS) {
13883 SVOP *kid = (SVOP*)cUNOPo->op_first;
13884
13885 if (kid->op_type == OP_NULL)
13886 kid = (SVOP*)OpSIBLING(kid);
13887 if (kid && kid->op_type == OP_CONST &&
13888 (kid->op_private & OPpCONST_BARE) &&
13889 !kid->op_folded)
13890 {
13891 o->op_flags |= OPf_SPECIAL;
13892 kid->op_private &= ~OPpCONST_STRICT;
13893 }
13894 }
13895 return ck_fun(o);
13896 }
13897
13898 OP *
Perl_ck_substr(pTHX_ OP * o)13899 Perl_ck_substr(pTHX_ OP *o)
13900 {
13901 PERL_ARGS_ASSERT_CK_SUBSTR;
13902
13903 o = ck_fun(o);
13904 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
13905 OP *kid = cLISTOPo->op_first;
13906
13907 if (kid->op_type == OP_NULL)
13908 kid = OpSIBLING(kid);
13909 if (kid)
13910 /* Historically, substr(delete $foo{bar},...) has been allowed
13911 with 4-arg substr. Keep it working by applying entersub
13912 lvalue context. */
13913 op_lvalue(kid, OP_ENTERSUB);
13914
13915 }
13916 return o;
13917 }
13918
13919 OP *
Perl_ck_tell(pTHX_ OP * o)13920 Perl_ck_tell(pTHX_ OP *o)
13921 {
13922 PERL_ARGS_ASSERT_CK_TELL;
13923 o = ck_fun(o);
13924 if (o->op_flags & OPf_KIDS) {
13925 OP *kid = cLISTOPo->op_first;
13926 if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
13927 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
13928 }
13929 return o;
13930 }
13931
13932 OP *
Perl_ck_each(pTHX_ OP * o)13933 Perl_ck_each(pTHX_ OP *o)
13934 {
13935 dVAR;
13936 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
13937 const unsigned orig_type = o->op_type;
13938
13939 PERL_ARGS_ASSERT_CK_EACH;
13940
13941 if (kid) {
13942 switch (kid->op_type) {
13943 case OP_PADHV:
13944 case OP_RV2HV:
13945 break;
13946 case OP_PADAV:
13947 case OP_RV2AV:
13948 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
13949 : orig_type == OP_KEYS ? OP_AKEYS
13950 : OP_AVALUES);
13951 break;
13952 case OP_CONST:
13953 if (kid->op_private == OPpCONST_BARE
13954 || !SvROK(cSVOPx_sv(kid))
13955 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
13956 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
13957 )
13958 goto bad;
13959 /* FALLTHROUGH */
13960 default:
13961 qerror(Perl_mess(aTHX_
13962 "Experimental %s on scalar is now forbidden",
13963 PL_op_desc[orig_type]));
13964 bad:
13965 bad_type_pv(1, "hash or array", o, kid);
13966 return o;
13967 }
13968 }
13969 return ck_fun(o);
13970 }
13971
13972 OP *
Perl_ck_length(pTHX_ OP * o)13973 Perl_ck_length(pTHX_ OP *o)
13974 {
13975 PERL_ARGS_ASSERT_CK_LENGTH;
13976
13977 o = ck_fun(o);
13978
13979 if (ckWARN(WARN_SYNTAX)) {
13980 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
13981
13982 if (kid) {
13983 SV *name = NULL;
13984 const bool hash = kid->op_type == OP_PADHV
13985 || kid->op_type == OP_RV2HV;
13986 switch (kid->op_type) {
13987 case OP_PADHV:
13988 case OP_PADAV:
13989 case OP_RV2HV:
13990 case OP_RV2AV:
13991 name = S_op_varname(aTHX_ kid);
13992 break;
13993 default:
13994 return o;
13995 }
13996 if (name)
13997 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13998 "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
13999 ")\"?)",
14000 SVfARG(name), hash ? "keys " : "", SVfARG(name)
14001 );
14002 else if (hash)
14003 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
14004 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14005 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
14006 else
14007 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
14008 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14009 "length() used on @array (did you mean \"scalar(@array)\"?)");
14010 }
14011 }
14012
14013 return o;
14014 }
14015
14016
14017
14018 /*
14019 ---------------------------------------------------------
14020
14021 Common vars in list assignment
14022
14023 There now follows some enums and static functions for detecting
14024 common variables in list assignments. Here is a little essay I wrote
14025 for myself when trying to get my head around this. DAPM.
14026
14027 ----
14028
14029 First some random observations:
14030
14031 * If a lexical var is an alias of something else, e.g.
14032 for my $x ($lex, $pkg, $a[0]) {...}
14033 then the act of aliasing will increase the reference count of the SV
14034
14035 * If a package var is an alias of something else, it may still have a
14036 reference count of 1, depending on how the alias was created, e.g.
14037 in *a = *b, $a may have a refcount of 1 since the GP is shared
14038 with a single GvSV pointer to the SV. So If it's an alias of another
14039 package var, then RC may be 1; if it's an alias of another scalar, e.g.
14040 a lexical var or an array element, then it will have RC > 1.
14041
14042 * There are many ways to create a package alias; ultimately, XS code
14043 may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
14044 run-time tracing mechanisms are unlikely to be able to catch all cases.
14045
14046 * When the LHS is all my declarations, the same vars can't appear directly
14047 on the RHS, but they can indirectly via closures, aliasing and lvalue
14048 subs. But those techniques all involve an increase in the lexical
14049 scalar's ref count.
14050
14051 * When the LHS is all lexical vars (but not necessarily my declarations),
14052 it is possible for the same lexicals to appear directly on the RHS, and
14053 without an increased ref count, since the stack isn't refcounted.
14054 This case can be detected at compile time by scanning for common lex
14055 vars with PL_generation.
14056
14057 * lvalue subs defeat common var detection, but they do at least
14058 return vars with a temporary ref count increment. Also, you can't
14059 tell at compile time whether a sub call is lvalue.
14060
14061
14062 So...
14063
14064 A: There are a few circumstances where there definitely can't be any
14065 commonality:
14066
14067 LHS empty: () = (...);
14068 RHS empty: (....) = ();
14069 RHS contains only constants or other 'can't possibly be shared'
14070 elements (e.g. ops that return PADTMPs): (...) = (1,2, length)
14071 i.e. they only contain ops not marked as dangerous, whose children
14072 are also not dangerous;
14073 LHS ditto;
14074 LHS contains a single scalar element: e.g. ($x) = (....); because
14075 after $x has been modified, it won't be used again on the RHS;
14076 RHS contains a single element with no aggregate on LHS: e.g.
14077 ($a,$b,$c) = ($x); again, once $a has been modified, its value
14078 won't be used again.
14079
14080 B: If LHS are all 'my' lexical var declarations (or safe ops, which
14081 we can ignore):
14082
14083 my ($a, $b, @c) = ...;
14084
14085 Due to closure and goto tricks, these vars may already have content.
14086 For the same reason, an element on the RHS may be a lexical or package
14087 alias of one of the vars on the left, or share common elements, for
14088 example:
14089
14090 my ($x,$y) = f(); # $x and $y on both sides
14091 sub f : lvalue { ($x,$y) = (1,2); $y, $x }
14092
14093 and
14094
14095 my $ra = f();
14096 my @a = @$ra; # elements of @a on both sides
14097 sub f { @a = 1..4; \@a }
14098
14099
14100 First, just consider scalar vars on LHS:
14101
14102 RHS is safe only if (A), or in addition,
14103 * contains only lexical *scalar* vars, where neither side's
14104 lexicals have been flagged as aliases
14105
14106 If RHS is not safe, then it's always legal to check LHS vars for
14107 RC==1, since the only RHS aliases will always be associated
14108 with an RC bump.
14109
14110 Note that in particular, RHS is not safe if:
14111
14112 * it contains package scalar vars; e.g.:
14113
14114 f();
14115 my ($x, $y) = (2, $x_alias);
14116 sub f { $x = 1; *x_alias = \$x; }
14117
14118 * It contains other general elements, such as flattened or
14119 * spliced or single array or hash elements, e.g.
14120
14121 f();
14122 my ($x,$y) = @a; # or $a[0] or @a{@b} etc
14123
14124 sub f {
14125 ($x, $y) = (1,2);
14126 use feature 'refaliasing';
14127 \($a[0], $a[1]) = \($y,$x);
14128 }
14129
14130 It doesn't matter if the array/hash is lexical or package.
14131
14132 * it contains a function call that happens to be an lvalue
14133 sub which returns one or more of the above, e.g.
14134
14135 f();
14136 my ($x,$y) = f();
14137
14138 sub f : lvalue {
14139 ($x, $y) = (1,2);
14140 *x1 = \$x;
14141 $y, $x1;
14142 }
14143
14144 (so a sub call on the RHS should be treated the same
14145 as having a package var on the RHS).
14146
14147 * any other "dangerous" thing, such an op or built-in that
14148 returns one of the above, e.g. pp_preinc
14149
14150
14151 If RHS is not safe, what we can do however is at compile time flag
14152 that the LHS are all my declarations, and at run time check whether
14153 all the LHS have RC == 1, and if so skip the full scan.
14154
14155 Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
14156
14157 Here the issue is whether there can be elements of @a on the RHS
14158 which will get prematurely freed when @a is cleared prior to
14159 assignment. This is only a problem if the aliasing mechanism
14160 is one which doesn't increase the refcount - only if RC == 1
14161 will the RHS element be prematurely freed.
14162
14163 Because the array/hash is being INTROed, it or its elements
14164 can't directly appear on the RHS:
14165
14166 my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
14167
14168 but can indirectly, e.g.:
14169
14170 my $r = f();
14171 my (@a) = @$r;
14172 sub f { @a = 1..3; \@a }
14173
14174 So if the RHS isn't safe as defined by (A), we must always
14175 mortalise and bump the ref count of any remaining RHS elements
14176 when assigning to a non-empty LHS aggregate.
14177
14178 Lexical scalars on the RHS aren't safe if they've been involved in
14179 aliasing, e.g.
14180
14181 use feature 'refaliasing';
14182
14183 f();
14184 \(my $lex) = \$pkg;
14185 my @a = ($lex,3); # equivalent to ($a[0],3)
14186
14187 sub f {
14188 @a = (1,2);
14189 \$pkg = \$a[0];
14190 }
14191
14192 Similarly with lexical arrays and hashes on the RHS:
14193
14194 f();
14195 my @b;
14196 my @a = (@b);
14197
14198 sub f {
14199 @a = (1,2);
14200 \$b[0] = \$a[1];
14201 \$b[1] = \$a[0];
14202 }
14203
14204
14205
14206 C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
14207 my $a; ($a, my $b) = (....);
14208
14209 The difference between (B) and (C) is that it is now physically
14210 possible for the LHS vars to appear on the RHS too, where they
14211 are not reference counted; but in this case, the compile-time
14212 PL_generation sweep will detect such common vars.
14213
14214 So the rules for (C) differ from (B) in that if common vars are
14215 detected, the runtime "test RC==1" optimisation can no longer be used,
14216 and a full mark and sweep is required
14217
14218 D: As (C), but in addition the LHS may contain package vars.
14219
14220 Since package vars can be aliased without a corresponding refcount
14221 increase, all bets are off. It's only safe if (A). E.g.
14222
14223 my ($x, $y) = (1,2);
14224
14225 for $x_alias ($x) {
14226 ($x_alias, $y) = (3, $x); # whoops
14227 }
14228
14229 Ditto for LHS aggregate package vars.
14230
14231 E: Any other dangerous ops on LHS, e.g.
14232 (f(), $a[0], @$r) = (...);
14233
14234 this is similar to (E) in that all bets are off. In addition, it's
14235 impossible to determine at compile time whether the LHS
14236 contains a scalar or an aggregate, e.g.
14237
14238 sub f : lvalue { @a }
14239 (f()) = 1..3;
14240
14241 * ---------------------------------------------------------
14242 */
14243
14244
14245 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
14246 * that at least one of the things flagged was seen.
14247 */
14248
14249 enum {
14250 AAS_MY_SCALAR = 0x001, /* my $scalar */
14251 AAS_MY_AGG = 0x002, /* aggregate: my @array or my %hash */
14252 AAS_LEX_SCALAR = 0x004, /* $lexical */
14253 AAS_LEX_AGG = 0x008, /* @lexical or %lexical aggregate */
14254 AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
14255 AAS_PKG_SCALAR = 0x020, /* $scalar (where $scalar is pkg var) */
14256 AAS_PKG_AGG = 0x040, /* package @array or %hash aggregate */
14257 AAS_DANGEROUS = 0x080, /* an op (other than the above)
14258 that's flagged OA_DANGEROUS */
14259 AAS_SAFE_SCALAR = 0x100, /* produces at least one scalar SV that's
14260 not in any of the categories above */
14261 AAS_DEFAV = 0x200 /* contains just a single '@_' on RHS */
14262 };
14263
14264
14265
14266 /* helper function for S_aassign_scan().
14267 * check a PAD-related op for commonality and/or set its generation number.
14268 * Returns a boolean indicating whether its shared */
14269
14270 static bool
S_aassign_padcheck(pTHX_ OP * o,bool rhs)14271 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
14272 {
14273 if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
14274 /* lexical used in aliasing */
14275 return TRUE;
14276
14277 if (rhs)
14278 return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
14279 else
14280 PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
14281
14282 return FALSE;
14283 }
14284
14285
14286 /*
14287 Helper function for OPpASSIGN_COMMON* detection in rpeep().
14288 It scans the left or right hand subtree of the aassign op, and returns a
14289 set of flags indicating what sorts of things it found there.
14290 'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
14291 set PL_generation on lexical vars; if the latter, we see if
14292 PL_generation matches.
14293 'top' indicates whether we're recursing or at the top level.
14294 'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
14295 This fn will increment it by the number seen. It's not intended to
14296 be an accurate count (especially as many ops can push a variable
14297 number of SVs onto the stack); rather it's used as to test whether there
14298 can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
14299 */
14300
14301 static int
S_aassign_scan(pTHX_ OP * o,bool rhs,bool top,int * scalars_p)14302 S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
14303 {
14304 int flags = 0;
14305 bool kid_top = FALSE;
14306
14307 /* first, look for a solitary @_ on the RHS */
14308 if ( rhs
14309 && top
14310 && (o->op_flags & OPf_KIDS)
14311 && OP_TYPE_IS_OR_WAS(o, OP_LIST)
14312 ) {
14313 OP *kid = cUNOPo->op_first;
14314 if ( ( kid->op_type == OP_PUSHMARK
14315 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
14316 && ((kid = OpSIBLING(kid)))
14317 && !OpHAS_SIBLING(kid)
14318 && kid->op_type == OP_RV2AV
14319 && !(kid->op_flags & OPf_REF)
14320 && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
14321 && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
14322 && ((kid = cUNOPx(kid)->op_first))
14323 && kid->op_type == OP_GV
14324 && cGVOPx_gv(kid) == PL_defgv
14325 )
14326 flags |= AAS_DEFAV;
14327 }
14328
14329 switch (o->op_type) {
14330 case OP_GVSV:
14331 (*scalars_p)++;
14332 return AAS_PKG_SCALAR;
14333
14334 case OP_PADAV:
14335 case OP_PADHV:
14336 (*scalars_p) += 2;
14337 /* if !top, could be e.g. @a[0,1] */
14338 if (top && (o->op_flags & OPf_REF))
14339 return (o->op_private & OPpLVAL_INTRO)
14340 ? AAS_MY_AGG : AAS_LEX_AGG;
14341 return AAS_DANGEROUS;
14342
14343 case OP_PADSV:
14344 {
14345 int comm = S_aassign_padcheck(aTHX_ o, rhs)
14346 ? AAS_LEX_SCALAR_COMM : 0;
14347 (*scalars_p)++;
14348 return (o->op_private & OPpLVAL_INTRO)
14349 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
14350 }
14351
14352 case OP_RV2AV:
14353 case OP_RV2HV:
14354 (*scalars_p) += 2;
14355 if (cUNOPx(o)->op_first->op_type != OP_GV)
14356 return AAS_DANGEROUS; /* @{expr}, %{expr} */
14357 /* @pkg, %pkg */
14358 /* if !top, could be e.g. @a[0,1] */
14359 if (top && (o->op_flags & OPf_REF))
14360 return AAS_PKG_AGG;
14361 return AAS_DANGEROUS;
14362
14363 case OP_RV2SV:
14364 (*scalars_p)++;
14365 if (cUNOPx(o)->op_first->op_type != OP_GV) {
14366 (*scalars_p) += 2;
14367 return AAS_DANGEROUS; /* ${expr} */
14368 }
14369 return AAS_PKG_SCALAR; /* $pkg */
14370
14371 case OP_SPLIT:
14372 if (o->op_private & OPpSPLIT_ASSIGN) {
14373 /* the assign in @a = split() has been optimised away
14374 * and the @a attached directly to the split op
14375 * Treat the array as appearing on the RHS, i.e.
14376 * ... = (@a = split)
14377 * is treated like
14378 * ... = @a;
14379 */
14380
14381 if (o->op_flags & OPf_STACKED)
14382 /* @{expr} = split() - the array expression is tacked
14383 * on as an extra child to split - process kid */
14384 return S_aassign_scan(aTHX_ cLISTOPo->op_last, rhs,
14385 top, scalars_p);
14386
14387 /* ... else array is directly attached to split op */
14388 (*scalars_p) += 2;
14389 if (PL_op->op_private & OPpSPLIT_LEX)
14390 return (o->op_private & OPpLVAL_INTRO)
14391 ? AAS_MY_AGG : AAS_LEX_AGG;
14392 else
14393 return AAS_PKG_AGG;
14394 }
14395 (*scalars_p)++;
14396 /* other args of split can't be returned */
14397 return AAS_SAFE_SCALAR;
14398
14399 case OP_UNDEF:
14400 /* undef counts as a scalar on the RHS:
14401 * (undef, $x) = ...; # only 1 scalar on LHS: always safe
14402 * ($x, $y) = (undef, $x); # 2 scalars on RHS: unsafe
14403 */
14404 if (rhs)
14405 (*scalars_p)++;
14406 flags = AAS_SAFE_SCALAR;
14407 break;
14408
14409 case OP_PUSHMARK:
14410 case OP_STUB:
14411 /* these are all no-ops; they don't push a potentially common SV
14412 * onto the stack, so they are neither AAS_DANGEROUS nor
14413 * AAS_SAFE_SCALAR */
14414 return 0;
14415
14416 case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
14417 break;
14418
14419 case OP_NULL:
14420 case OP_LIST:
14421 /* these do nothing but may have children; but their children
14422 * should also be treated as top-level */
14423 kid_top = top;
14424 break;
14425
14426 default:
14427 if (PL_opargs[o->op_type] & OA_DANGEROUS) {
14428 (*scalars_p) += 2;
14429 flags = AAS_DANGEROUS;
14430 break;
14431 }
14432
14433 if ( (PL_opargs[o->op_type] & OA_TARGLEX)
14434 && (o->op_private & OPpTARGET_MY))
14435 {
14436 (*scalars_p)++;
14437 return S_aassign_padcheck(aTHX_ o, rhs)
14438 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
14439 }
14440
14441 /* if its an unrecognised, non-dangerous op, assume that it
14442 * it the cause of at least one safe scalar */
14443 (*scalars_p)++;
14444 flags = AAS_SAFE_SCALAR;
14445 break;
14446 }
14447
14448 /* XXX this assumes that all other ops are "transparent" - i.e. that
14449 * they can return some of their children. While this true for e.g.
14450 * sort and grep, it's not true for e.g. map. We really need a
14451 * 'transparent' flag added to regen/opcodes
14452 */
14453 if (o->op_flags & OPf_KIDS) {
14454 OP *kid;
14455 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
14456 flags |= S_aassign_scan(aTHX_ kid, rhs, kid_top, scalars_p);
14457 }
14458 return flags;
14459 }
14460
14461
14462 /* Check for in place reverse and sort assignments like "@a = reverse @a"
14463 and modify the optree to make them work inplace */
14464
14465 STATIC void
S_inplace_aassign(pTHX_ OP * o)14466 S_inplace_aassign(pTHX_ OP *o) {
14467
14468 OP *modop, *modop_pushmark;
14469 OP *oright;
14470 OP *oleft, *oleft_pushmark;
14471
14472 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
14473
14474 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
14475
14476 assert(cUNOPo->op_first->op_type == OP_NULL);
14477 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
14478 assert(modop_pushmark->op_type == OP_PUSHMARK);
14479 modop = OpSIBLING(modop_pushmark);
14480
14481 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
14482 return;
14483
14484 /* no other operation except sort/reverse */
14485 if (OpHAS_SIBLING(modop))
14486 return;
14487
14488 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
14489 if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
14490
14491 if (modop->op_flags & OPf_STACKED) {
14492 /* skip sort subroutine/block */
14493 assert(oright->op_type == OP_NULL);
14494 oright = OpSIBLING(oright);
14495 }
14496
14497 assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
14498 oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
14499 assert(oleft_pushmark->op_type == OP_PUSHMARK);
14500 oleft = OpSIBLING(oleft_pushmark);
14501
14502 /* Check the lhs is an array */
14503 if (!oleft ||
14504 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
14505 || OpHAS_SIBLING(oleft)
14506 || (oleft->op_private & OPpLVAL_INTRO)
14507 )
14508 return;
14509
14510 /* Only one thing on the rhs */
14511 if (OpHAS_SIBLING(oright))
14512 return;
14513
14514 /* check the array is the same on both sides */
14515 if (oleft->op_type == OP_RV2AV) {
14516 if (oright->op_type != OP_RV2AV
14517 || !cUNOPx(oright)->op_first
14518 || cUNOPx(oright)->op_first->op_type != OP_GV
14519 || cUNOPx(oleft )->op_first->op_type != OP_GV
14520 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
14521 cGVOPx_gv(cUNOPx(oright)->op_first)
14522 )
14523 return;
14524 }
14525 else if (oright->op_type != OP_PADAV
14526 || oright->op_targ != oleft->op_targ
14527 )
14528 return;
14529
14530 /* This actually is an inplace assignment */
14531
14532 modop->op_private |= OPpSORT_INPLACE;
14533
14534 /* transfer MODishness etc from LHS arg to RHS arg */
14535 oright->op_flags = oleft->op_flags;
14536
14537 /* remove the aassign op and the lhs */
14538 op_null(o);
14539 op_null(oleft_pushmark);
14540 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
14541 op_null(cUNOPx(oleft)->op_first);
14542 op_null(oleft);
14543 }
14544
14545
14546
14547 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
14548 * that potentially represent a series of one or more aggregate derefs
14549 * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
14550 * the whole chain to a single OP_MULTIDEREF op (maybe with a few
14551 * additional ops left in too).
14552 *
14553 * The caller will have already verified that the first few ops in the
14554 * chain following 'start' indicate a multideref candidate, and will have
14555 * set 'orig_o' to the point further on in the chain where the first index
14556 * expression (if any) begins. 'orig_action' specifies what type of
14557 * beginning has already been determined by the ops between start..orig_o
14558 * (e.g. $lex_ary[], $pkg_ary->{}, expr->[], etc).
14559 *
14560 * 'hints' contains any hints flags that need adding (currently just
14561 * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
14562 */
14563
14564 STATIC void
S_maybe_multideref(pTHX_ OP * start,OP * orig_o,UV orig_action,U8 hints)14565 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
14566 {
14567 dVAR;
14568 int pass;
14569 UNOP_AUX_item *arg_buf = NULL;
14570 bool reset_start_targ = FALSE; /* start->op_targ needs zeroing */
14571 int index_skip = -1; /* don't output index arg on this action */
14572
14573 /* similar to regex compiling, do two passes; the first pass
14574 * determines whether the op chain is convertible and calculates the
14575 * buffer size; the second pass populates the buffer and makes any
14576 * changes necessary to ops (such as moving consts to the pad on
14577 * threaded builds).
14578 *
14579 * NB: for things like Coverity, note that both passes take the same
14580 * path through the logic tree (except for 'if (pass)' bits), since
14581 * both passes are following the same op_next chain; and in
14582 * particular, if it would return early on the second pass, it would
14583 * already have returned early on the first pass.
14584 */
14585 for (pass = 0; pass < 2; pass++) {
14586 OP *o = orig_o;
14587 UV action = orig_action;
14588 OP *first_elem_op = NULL; /* first seen aelem/helem */
14589 OP *top_op = NULL; /* highest [ah]elem/exists/del/rv2[ah]v */
14590 int action_count = 0; /* number of actions seen so far */
14591 int action_ix = 0; /* action_count % (actions per IV) */
14592 bool next_is_hash = FALSE; /* is the next lookup to be a hash? */
14593 bool is_last = FALSE; /* no more derefs to follow */
14594 bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
14595 UNOP_AUX_item *arg = arg_buf;
14596 UNOP_AUX_item *action_ptr = arg_buf;
14597
14598 if (pass)
14599 action_ptr->uv = 0;
14600 arg++;
14601
14602 switch (action) {
14603 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
14604 case MDEREF_HV_gvhv_helem:
14605 next_is_hash = TRUE;
14606 /* FALLTHROUGH */
14607 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
14608 case MDEREF_AV_gvav_aelem:
14609 if (pass) {
14610 #ifdef USE_ITHREADS
14611 arg->pad_offset = cPADOPx(start)->op_padix;
14612 /* stop it being swiped when nulled */
14613 cPADOPx(start)->op_padix = 0;
14614 #else
14615 arg->sv = cSVOPx(start)->op_sv;
14616 cSVOPx(start)->op_sv = NULL;
14617 #endif
14618 }
14619 arg++;
14620 break;
14621
14622 case MDEREF_HV_padhv_helem:
14623 case MDEREF_HV_padsv_vivify_rv2hv_helem:
14624 next_is_hash = TRUE;
14625 /* FALLTHROUGH */
14626 case MDEREF_AV_padav_aelem:
14627 case MDEREF_AV_padsv_vivify_rv2av_aelem:
14628 if (pass) {
14629 arg->pad_offset = start->op_targ;
14630 /* we skip setting op_targ = 0 for now, since the intact
14631 * OP_PADXV is needed by S_check_hash_fields_and_hekify */
14632 reset_start_targ = TRUE;
14633 }
14634 arg++;
14635 break;
14636
14637 case MDEREF_HV_pop_rv2hv_helem:
14638 next_is_hash = TRUE;
14639 /* FALLTHROUGH */
14640 case MDEREF_AV_pop_rv2av_aelem:
14641 break;
14642
14643 default:
14644 NOT_REACHED; /* NOTREACHED */
14645 return;
14646 }
14647
14648 while (!is_last) {
14649 /* look for another (rv2av/hv; get index;
14650 * aelem/helem/exists/delele) sequence */
14651
14652 OP *kid;
14653 bool is_deref;
14654 bool ok;
14655 UV index_type = MDEREF_INDEX_none;
14656
14657 if (action_count) {
14658 /* if this is not the first lookup, consume the rv2av/hv */
14659
14660 /* for N levels of aggregate lookup, we normally expect
14661 * that the first N-1 [ah]elem ops will be flagged as
14662 * /DEREF (so they autovivifiy if necessary), and the last
14663 * lookup op not to be.
14664 * For other things (like @{$h{k1}{k2}}) extra scope or
14665 * leave ops can appear, so abandon the effort in that
14666 * case */
14667 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
14668 return;
14669
14670 /* rv2av or rv2hv sKR/1 */
14671
14672 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14673 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14674 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
14675 return;
14676
14677 /* at this point, we wouldn't expect any of these
14678 * possible private flags:
14679 * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
14680 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
14681 */
14682 ASSUME(!(o->op_private &
14683 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
14684
14685 hints = (o->op_private & OPpHINT_STRICT_REFS);
14686
14687 /* make sure the type of the previous /DEREF matches the
14688 * type of the next lookup */
14689 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
14690 top_op = o;
14691
14692 action = next_is_hash
14693 ? MDEREF_HV_vivify_rv2hv_helem
14694 : MDEREF_AV_vivify_rv2av_aelem;
14695 o = o->op_next;
14696 }
14697
14698 /* if this is the second pass, and we're at the depth where
14699 * previously we encountered a non-simple index expression,
14700 * stop processing the index at this point */
14701 if (action_count != index_skip) {
14702
14703 /* look for one or more simple ops that return an array
14704 * index or hash key */
14705
14706 switch (o->op_type) {
14707 case OP_PADSV:
14708 /* it may be a lexical var index */
14709 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
14710 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14711 ASSUME(!(o->op_private &
14712 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
14713
14714 if ( OP_GIMME(o,0) == G_SCALAR
14715 && !(o->op_flags & (OPf_REF|OPf_MOD))
14716 && o->op_private == 0)
14717 {
14718 if (pass)
14719 arg->pad_offset = o->op_targ;
14720 arg++;
14721 index_type = MDEREF_INDEX_padsv;
14722 o = o->op_next;
14723 }
14724 break;
14725
14726 case OP_CONST:
14727 if (next_is_hash) {
14728 /* it's a constant hash index */
14729 if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
14730 /* "use constant foo => FOO; $h{+foo}" for
14731 * some weird FOO, can leave you with constants
14732 * that aren't simple strings. It's not worth
14733 * the extra hassle for those edge cases */
14734 break;
14735
14736 {
14737 UNOP *rop = NULL;
14738 OP * helem_op = o->op_next;
14739
14740 ASSUME( helem_op->op_type == OP_HELEM
14741 || helem_op->op_type == OP_NULL
14742 || pass == 0);
14743 if (helem_op->op_type == OP_HELEM) {
14744 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
14745 if ( helem_op->op_private & OPpLVAL_INTRO
14746 || rop->op_type != OP_RV2HV
14747 )
14748 rop = NULL;
14749 }
14750 /* on first pass just check; on second pass
14751 * hekify */
14752 S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo,
14753 pass);
14754 }
14755
14756 if (pass) {
14757 #ifdef USE_ITHREADS
14758 /* Relocate sv to the pad for thread safety */
14759 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
14760 arg->pad_offset = o->op_targ;
14761 o->op_targ = 0;
14762 #else
14763 arg->sv = cSVOPx_sv(o);
14764 #endif
14765 }
14766 }
14767 else {
14768 /* it's a constant array index */
14769 IV iv;
14770 SV *ix_sv = cSVOPo->op_sv;
14771 if (!SvIOK(ix_sv))
14772 break;
14773 iv = SvIV(ix_sv);
14774
14775 if ( action_count == 0
14776 && iv >= -128
14777 && iv <= 127
14778 && ( action == MDEREF_AV_padav_aelem
14779 || action == MDEREF_AV_gvav_aelem)
14780 )
14781 maybe_aelemfast = TRUE;
14782
14783 if (pass) {
14784 arg->iv = iv;
14785 SvREFCNT_dec_NN(cSVOPo->op_sv);
14786 }
14787 }
14788 if (pass)
14789 /* we've taken ownership of the SV */
14790 cSVOPo->op_sv = NULL;
14791 arg++;
14792 index_type = MDEREF_INDEX_const;
14793 o = o->op_next;
14794 break;
14795
14796 case OP_GV:
14797 /* it may be a package var index */
14798
14799 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_SPECIAL)));
14800 ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
14801 if ( (o->op_flags & ~(OPf_PARENS|OPf_SPECIAL)) != OPf_WANT_SCALAR
14802 || o->op_private != 0
14803 )
14804 break;
14805
14806 kid = o->op_next;
14807 if (kid->op_type != OP_RV2SV)
14808 break;
14809
14810 ASSUME(!(kid->op_flags &
14811 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
14812 |OPf_SPECIAL|OPf_PARENS)));
14813 ASSUME(!(kid->op_private &
14814 ~(OPpARG1_MASK
14815 |OPpHINT_STRICT_REFS|OPpOUR_INTRO
14816 |OPpDEREF|OPpLVAL_INTRO)));
14817 if( (kid->op_flags &~ OPf_PARENS)
14818 != (OPf_WANT_SCALAR|OPf_KIDS)
14819 || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
14820 )
14821 break;
14822
14823 if (pass) {
14824 #ifdef USE_ITHREADS
14825 arg->pad_offset = cPADOPx(o)->op_padix;
14826 /* stop it being swiped when nulled */
14827 cPADOPx(o)->op_padix = 0;
14828 #else
14829 arg->sv = cSVOPx(o)->op_sv;
14830 cSVOPo->op_sv = NULL;
14831 #endif
14832 }
14833 arg++;
14834 index_type = MDEREF_INDEX_gvsv;
14835 o = kid->op_next;
14836 break;
14837
14838 } /* switch */
14839 } /* action_count != index_skip */
14840
14841 action |= index_type;
14842
14843
14844 /* at this point we have either:
14845 * * detected what looks like a simple index expression,
14846 * and expect the next op to be an [ah]elem, or
14847 * an nulled [ah]elem followed by a delete or exists;
14848 * * found a more complex expression, so something other
14849 * than the above follows.
14850 */
14851
14852 /* possibly an optimised away [ah]elem (where op_next is
14853 * exists or delete) */
14854 if (o->op_type == OP_NULL)
14855 o = o->op_next;
14856
14857 /* at this point we're looking for an OP_AELEM, OP_HELEM,
14858 * OP_EXISTS or OP_DELETE */
14859
14860 /* if a custom array/hash access checker is in scope,
14861 * abandon optimisation attempt */
14862 if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
14863 && PL_check[o->op_type] != Perl_ck_null)
14864 return;
14865 /* similarly for customised exists and delete */
14866 if ( (o->op_type == OP_EXISTS)
14867 && PL_check[o->op_type] != Perl_ck_exists)
14868 return;
14869 if ( (o->op_type == OP_DELETE)
14870 && PL_check[o->op_type] != Perl_ck_delete)
14871 return;
14872
14873 if ( o->op_type != OP_AELEM
14874 || (o->op_private &
14875 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
14876 )
14877 maybe_aelemfast = FALSE;
14878
14879 /* look for aelem/helem/exists/delete. If it's not the last elem
14880 * lookup, it *must* have OPpDEREF_AV/HV, but not many other
14881 * flags; if it's the last, then it mustn't have
14882 * OPpDEREF_AV/HV, but may have lots of other flags, like
14883 * OPpLVAL_INTRO etc
14884 */
14885
14886 if ( index_type == MDEREF_INDEX_none
14887 || ( o->op_type != OP_AELEM && o->op_type != OP_HELEM
14888 && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
14889 )
14890 ok = FALSE;
14891 else {
14892 /* we have aelem/helem/exists/delete with valid simple index */
14893
14894 is_deref = (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
14895 && ( (o->op_private & OPpDEREF) == OPpDEREF_AV
14896 || (o->op_private & OPpDEREF) == OPpDEREF_HV);
14897
14898 /* This doesn't make much sense but is legal:
14899 * @{ local $x[0][0] } = 1
14900 * Since scope exit will undo the autovivification,
14901 * don't bother in the first place. The OP_LEAVE
14902 * assertion is in case there are other cases of both
14903 * OPpLVAL_INTRO and OPpDEREF which don't include a scope
14904 * exit that would undo the local - in which case this
14905 * block of code would need rethinking.
14906 */
14907 if (is_deref && (o->op_private & OPpLVAL_INTRO)) {
14908 #ifdef DEBUGGING
14909 OP *n = o->op_next;
14910 while (n && ( n->op_type == OP_NULL
14911 || n->op_type == OP_LIST
14912 || n->op_type == OP_SCALAR))
14913 n = n->op_next;
14914 assert(n && n->op_type == OP_LEAVE);
14915 #endif
14916 o->op_private &= ~OPpDEREF;
14917 is_deref = FALSE;
14918 }
14919
14920 if (is_deref) {
14921 ASSUME(!(o->op_flags &
14922 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
14923 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
14924
14925 ok = (o->op_flags &~ OPf_PARENS)
14926 == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
14927 && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
14928 }
14929 else if (o->op_type == OP_EXISTS) {
14930 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14931 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14932 ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
14933 ok = !(o->op_private & ~OPpARG1_MASK);
14934 }
14935 else if (o->op_type == OP_DELETE) {
14936 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14937 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14938 ASSUME(!(o->op_private &
14939 ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
14940 /* don't handle slices or 'local delete'; the latter
14941 * is fairly rare, and has a complex runtime */
14942 ok = !(o->op_private & ~OPpARG1_MASK);
14943 if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
14944 /* skip handling run-tome error */
14945 ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
14946 }
14947 else {
14948 ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
14949 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
14950 |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
14951 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
14952 |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
14953 ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
14954 }
14955 }
14956
14957 if (ok) {
14958 if (!first_elem_op)
14959 first_elem_op = o;
14960 top_op = o;
14961 if (is_deref) {
14962 next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
14963 o = o->op_next;
14964 }
14965 else {
14966 is_last = TRUE;
14967 action |= MDEREF_FLAG_last;
14968 }
14969 }
14970 else {
14971 /* at this point we have something that started
14972 * promisingly enough (with rv2av or whatever), but failed
14973 * to find a simple index followed by an
14974 * aelem/helem/exists/delete. If this is the first action,
14975 * give up; but if we've already seen at least one
14976 * aelem/helem, then keep them and add a new action with
14977 * MDEREF_INDEX_none, which causes it to do the vivify
14978 * from the end of the previous lookup, and do the deref,
14979 * but stop at that point. So $a[0][expr] will do one
14980 * av_fetch, vivify and deref, then continue executing at
14981 * expr */
14982 if (!action_count)
14983 return;
14984 is_last = TRUE;
14985 index_skip = action_count;
14986 action |= MDEREF_FLAG_last;
14987 if (index_type != MDEREF_INDEX_none)
14988 arg--;
14989 }
14990
14991 if (pass)
14992 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
14993 action_ix++;
14994 action_count++;
14995 /* if there's no space for the next action, create a new slot
14996 * for it *before* we start adding args for that action */
14997 if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
14998 action_ptr = arg;
14999 if (pass)
15000 arg->uv = 0;
15001 arg++;
15002 action_ix = 0;
15003 }
15004 } /* while !is_last */
15005
15006 /* success! */
15007
15008 if (pass) {
15009 OP *mderef;
15010 OP *p, *q;
15011
15012 mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
15013 if (index_skip == -1) {
15014 mderef->op_flags = o->op_flags
15015 & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
15016 if (o->op_type == OP_EXISTS)
15017 mderef->op_private = OPpMULTIDEREF_EXISTS;
15018 else if (o->op_type == OP_DELETE)
15019 mderef->op_private = OPpMULTIDEREF_DELETE;
15020 else
15021 mderef->op_private = o->op_private
15022 & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
15023 }
15024 /* accumulate strictness from every level (although I don't think
15025 * they can actually vary) */
15026 mderef->op_private |= hints;
15027
15028 /* integrate the new multideref op into the optree and the
15029 * op_next chain.
15030 *
15031 * In general an op like aelem or helem has two child
15032 * sub-trees: the aggregate expression (a_expr) and the
15033 * index expression (i_expr):
15034 *
15035 * aelem
15036 * |
15037 * a_expr - i_expr
15038 *
15039 * The a_expr returns an AV or HV, while the i-expr returns an
15040 * index. In general a multideref replaces most or all of a
15041 * multi-level tree, e.g.
15042 *
15043 * exists
15044 * |
15045 * ex-aelem
15046 * |
15047 * rv2av - i_expr1
15048 * |
15049 * helem
15050 * |
15051 * rv2hv - i_expr2
15052 * |
15053 * aelem
15054 * |
15055 * a_expr - i_expr3
15056 *
15057 * With multideref, all the i_exprs will be simple vars or
15058 * constants, except that i_expr1 may be arbitrary in the case
15059 * of MDEREF_INDEX_none.
15060 *
15061 * The bottom-most a_expr will be either:
15062 * 1) a simple var (so padXv or gv+rv2Xv);
15063 * 2) a simple scalar var dereferenced (e.g. $r->[0]):
15064 * so a simple var with an extra rv2Xv;
15065 * 3) or an arbitrary expression.
15066 *
15067 * 'start', the first op in the execution chain, will point to
15068 * 1),2): the padXv or gv op;
15069 * 3): the rv2Xv which forms the last op in the a_expr
15070 * execution chain, and the top-most op in the a_expr
15071 * subtree.
15072 *
15073 * For all cases, the 'start' node is no longer required,
15074 * but we can't free it since one or more external nodes
15075 * may point to it. E.g. consider
15076 * $h{foo} = $a ? $b : $c
15077 * Here, both the op_next and op_other branches of the
15078 * cond_expr point to the gv[*h] of the hash expression, so
15079 * we can't free the 'start' op.
15080 *
15081 * For expr->[...], we need to save the subtree containing the
15082 * expression; for the other cases, we just need to save the
15083 * start node.
15084 * So in all cases, we null the start op and keep it around by
15085 * making it the child of the multideref op; for the expr->
15086 * case, the expr will be a subtree of the start node.
15087 *
15088 * So in the simple 1,2 case the optree above changes to
15089 *
15090 * ex-exists
15091 * |
15092 * multideref
15093 * |
15094 * ex-gv (or ex-padxv)
15095 *
15096 * with the op_next chain being
15097 *
15098 * -> ex-gv -> multideref -> op-following-ex-exists ->
15099 *
15100 * In the 3 case, we have
15101 *
15102 * ex-exists
15103 * |
15104 * multideref
15105 * |
15106 * ex-rv2xv
15107 * |
15108 * rest-of-a_expr
15109 * subtree
15110 *
15111 * and
15112 *
15113 * -> rest-of-a_expr subtree ->
15114 * ex-rv2xv -> multideref -> op-following-ex-exists ->
15115 *
15116 *
15117 * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
15118 * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
15119 * multideref attached as the child, e.g.
15120 *
15121 * exists
15122 * |
15123 * ex-aelem
15124 * |
15125 * ex-rv2av - i_expr1
15126 * |
15127 * multideref
15128 * |
15129 * ex-whatever
15130 *
15131 */
15132
15133 /* if we free this op, don't free the pad entry */
15134 if (reset_start_targ)
15135 start->op_targ = 0;
15136
15137
15138 /* Cut the bit we need to save out of the tree and attach to
15139 * the multideref op, then free the rest of the tree */
15140
15141 /* find parent of node to be detached (for use by splice) */
15142 p = first_elem_op;
15143 if ( orig_action == MDEREF_AV_pop_rv2av_aelem
15144 || orig_action == MDEREF_HV_pop_rv2hv_helem)
15145 {
15146 /* there is an arbitrary expression preceding us, e.g.
15147 * expr->[..]? so we need to save the 'expr' subtree */
15148 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
15149 p = cUNOPx(p)->op_first;
15150 ASSUME( start->op_type == OP_RV2AV
15151 || start->op_type == OP_RV2HV);
15152 }
15153 else {
15154 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
15155 * above for exists/delete. */
15156 while ( (p->op_flags & OPf_KIDS)
15157 && cUNOPx(p)->op_first != start
15158 )
15159 p = cUNOPx(p)->op_first;
15160 }
15161 ASSUME(cUNOPx(p)->op_first == start);
15162
15163 /* detach from main tree, and re-attach under the multideref */
15164 op_sibling_splice(mderef, NULL, 0,
15165 op_sibling_splice(p, NULL, 1, NULL));
15166 op_null(start);
15167
15168 start->op_next = mderef;
15169
15170 mderef->op_next = index_skip == -1 ? o->op_next : o;
15171
15172 /* excise and free the original tree, and replace with
15173 * the multideref op */
15174 p = op_sibling_splice(top_op, NULL, -1, mderef);
15175 while (p) {
15176 q = OpSIBLING(p);
15177 op_free(p);
15178 p = q;
15179 }
15180 op_null(top_op);
15181 }
15182 else {
15183 Size_t size = arg - arg_buf;
15184
15185 if (maybe_aelemfast && action_count == 1)
15186 return;
15187
15188 arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
15189 sizeof(UNOP_AUX_item) * (size + 1));
15190 /* for dumping etc: store the length in a hidden first slot;
15191 * we set the op_aux pointer to the second slot */
15192 arg_buf->uv = size;
15193 arg_buf++;
15194 }
15195 } /* for (pass = ...) */
15196 }
15197
15198 /* See if the ops following o are such that o will always be executed in
15199 * boolean context: that is, the SV which o pushes onto the stack will
15200 * only ever be consumed by later ops via SvTRUE(sv) or similar.
15201 * If so, set a suitable private flag on o. Normally this will be
15202 * bool_flag; but see below why maybe_flag is needed too.
15203 *
15204 * Typically the two flags you pass will be the generic OPpTRUEBOOL and
15205 * OPpMAYBE_TRUEBOOL, buts it's possible that for some ops those bits may
15206 * already be taken, so you'll have to give that op two different flags.
15207 *
15208 * More explanation of 'maybe_flag' and 'safe_and' parameters.
15209 * The binary logical ops &&, ||, // (plus 'if' and 'unless' which use
15210 * those underlying ops) short-circuit, which means that rather than
15211 * necessarily returning a truth value, they may return the LH argument,
15212 * which may not be boolean. For example in $x = (keys %h || -1), keys
15213 * should return a key count rather than a boolean, even though its
15214 * sort-of being used in boolean context.
15215 *
15216 * So we only consider such logical ops to provide boolean context to
15217 * their LH argument if they themselves are in void or boolean context.
15218 * However, sometimes the context isn't known until run-time. In this
15219 * case the op is marked with the maybe_flag flag it.
15220 *
15221 * Consider the following.
15222 *
15223 * sub f { ....; if (%h) { .... } }
15224 *
15225 * This is actually compiled as
15226 *
15227 * sub f { ....; %h && do { .... } }
15228 *
15229 * Here we won't know until runtime whether the final statement (and hence
15230 * the &&) is in void context and so is safe to return a boolean value.
15231 * So mark o with maybe_flag rather than the bool_flag.
15232 * Note that there is cost associated with determining context at runtime
15233 * (e.g. a call to block_gimme()), so it may not be worth setting (at
15234 * compile time) and testing (at runtime) maybe_flag if the scalar verses
15235 * boolean costs savings are marginal.
15236 *
15237 * However, we can do slightly better with && (compared to || and //):
15238 * this op only returns its LH argument when that argument is false. In
15239 * this case, as long as the op promises to return a false value which is
15240 * valid in both boolean and scalar contexts, we can mark an op consumed
15241 * by && with bool_flag rather than maybe_flag.
15242 * For example as long as pp_padhv and pp_rv2hv return &PL_sv_zero rather
15243 * than &PL_sv_no for a false result in boolean context, then it's safe. An
15244 * op which promises to handle this case is indicated by setting safe_and
15245 * to true.
15246 */
15247
15248 static void
S_check_for_bool_cxt(OP * o,bool safe_and,U8 bool_flag,U8 maybe_flag)15249 S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag)
15250 {
15251 OP *lop;
15252 U8 flag = 0;
15253
15254 assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR);
15255
15256 /* OPpTARGET_MY and boolean context probably don't mix well.
15257 * If someone finds a valid use case, maybe add an extra flag to this
15258 * function which indicates its safe to do so for this op? */
15259 assert(!( (PL_opargs[o->op_type] & OA_TARGLEX)
15260 && (o->op_private & OPpTARGET_MY)));
15261
15262 lop = o->op_next;
15263
15264 while (lop) {
15265 switch (lop->op_type) {
15266 case OP_NULL:
15267 case OP_SCALAR:
15268 break;
15269
15270 /* these two consume the stack argument in the scalar case,
15271 * and treat it as a boolean in the non linenumber case */
15272 case OP_FLIP:
15273 case OP_FLOP:
15274 if ( ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST)
15275 || (lop->op_private & OPpFLIP_LINENUM))
15276 {
15277 lop = NULL;
15278 break;
15279 }
15280 /* FALLTHROUGH */
15281 /* these never leave the original value on the stack */
15282 case OP_NOT:
15283 case OP_XOR:
15284 case OP_COND_EXPR:
15285 case OP_GREPWHILE:
15286 flag = bool_flag;
15287 lop = NULL;
15288 break;
15289
15290 /* OR DOR and AND evaluate their arg as a boolean, but then may
15291 * leave the original scalar value on the stack when following the
15292 * op_next route. If not in void context, we need to ensure
15293 * that whatever follows consumes the arg only in boolean context
15294 * too.
15295 */
15296 case OP_AND:
15297 if (safe_and) {
15298 flag = bool_flag;
15299 lop = NULL;
15300 break;
15301 }
15302 /* FALLTHROUGH */
15303 case OP_OR:
15304 case OP_DOR:
15305 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
15306 flag = bool_flag;
15307 lop = NULL;
15308 }
15309 else if (!(lop->op_flags & OPf_WANT)) {
15310 /* unknown context - decide at runtime */
15311 flag = maybe_flag;
15312 lop = NULL;
15313 }
15314 break;
15315
15316 default:
15317 lop = NULL;
15318 break;
15319 }
15320
15321 if (lop)
15322 lop = lop->op_next;
15323 }
15324
15325 o->op_private |= flag;
15326 }
15327
15328
15329
15330 /* mechanism for deferring recursion in rpeep() */
15331
15332 #define MAX_DEFERRED 4
15333
15334 #define DEFER(o) \
15335 STMT_START { \
15336 if (defer_ix == (MAX_DEFERRED-1)) { \
15337 OP **defer = defer_queue[defer_base]; \
15338 CALL_RPEEP(*defer); \
15339 S_prune_chain_head(defer); \
15340 defer_base = (defer_base + 1) % MAX_DEFERRED; \
15341 defer_ix--; \
15342 } \
15343 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
15344 } STMT_END
15345
15346 #define IS_AND_OP(o) (o->op_type == OP_AND)
15347 #define IS_OR_OP(o) (o->op_type == OP_OR)
15348
15349
15350 /* A peephole optimizer. We visit the ops in the order they're to execute.
15351 * See the comments at the top of this file for more details about when
15352 * peep() is called */
15353
15354 void
Perl_rpeep(pTHX_ OP * o)15355 Perl_rpeep(pTHX_ OP *o)
15356 {
15357 dVAR;
15358 OP* oldop = NULL;
15359 OP* oldoldop = NULL;
15360 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
15361 int defer_base = 0;
15362 int defer_ix = -1;
15363
15364 if (!o || o->op_opt)
15365 return;
15366
15367 assert(o->op_type != OP_FREED);
15368
15369 ENTER;
15370 SAVEOP();
15371 SAVEVPTR(PL_curcop);
15372 for (;; o = o->op_next) {
15373 if (o && o->op_opt)
15374 o = NULL;
15375 if (!o) {
15376 while (defer_ix >= 0) {
15377 OP **defer =
15378 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
15379 CALL_RPEEP(*defer);
15380 S_prune_chain_head(defer);
15381 }
15382 break;
15383 }
15384
15385 redo:
15386
15387 /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
15388 assert(!oldoldop || oldoldop->op_next == oldop);
15389 assert(!oldop || oldop->op_next == o);
15390
15391 /* By default, this op has now been optimised. A couple of cases below
15392 clear this again. */
15393 o->op_opt = 1;
15394 PL_op = o;
15395
15396 /* look for a series of 1 or more aggregate derefs, e.g.
15397 * $a[1]{foo}[$i]{$k}
15398 * and replace with a single OP_MULTIDEREF op.
15399 * Each index must be either a const, or a simple variable,
15400 *
15401 * First, look for likely combinations of starting ops,
15402 * corresponding to (global and lexical variants of)
15403 * $a[...] $h{...}
15404 * $r->[...] $r->{...}
15405 * (preceding expression)->[...]
15406 * (preceding expression)->{...}
15407 * and if so, call maybe_multideref() to do a full inspection
15408 * of the op chain and if appropriate, replace with an
15409 * OP_MULTIDEREF
15410 */
15411 {
15412 UV action;
15413 OP *o2 = o;
15414 U8 hints = 0;
15415
15416 switch (o2->op_type) {
15417 case OP_GV:
15418 /* $pkg[..] : gv[*pkg]
15419 * $pkg->[...]: gv[*pkg]; rv2sv sKM/DREFAV */
15420
15421 /* Fail if there are new op flag combinations that we're
15422 * not aware of, rather than:
15423 * * silently failing to optimise, or
15424 * * silently optimising the flag away.
15425 * If this ASSUME starts failing, examine what new flag
15426 * has been added to the op, and decide whether the
15427 * optimisation should still occur with that flag, then
15428 * update the code accordingly. This applies to all the
15429 * other ASSUMEs in the block of code too.
15430 */
15431 ASSUME(!(o2->op_flags &
15432 ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
15433 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
15434
15435 o2 = o2->op_next;
15436
15437 if (o2->op_type == OP_RV2AV) {
15438 action = MDEREF_AV_gvav_aelem;
15439 goto do_deref;
15440 }
15441
15442 if (o2->op_type == OP_RV2HV) {
15443 action = MDEREF_HV_gvhv_helem;
15444 goto do_deref;
15445 }
15446
15447 if (o2->op_type != OP_RV2SV)
15448 break;
15449
15450 /* at this point we've seen gv,rv2sv, so the only valid
15451 * construct left is $pkg->[] or $pkg->{} */
15452
15453 ASSUME(!(o2->op_flags & OPf_STACKED));
15454 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15455 != (OPf_WANT_SCALAR|OPf_MOD))
15456 break;
15457
15458 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
15459 |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
15460 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
15461 break;
15462 if ( (o2->op_private & OPpDEREF) != OPpDEREF_AV
15463 && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
15464 break;
15465
15466 o2 = o2->op_next;
15467 if (o2->op_type == OP_RV2AV) {
15468 action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
15469 goto do_deref;
15470 }
15471 if (o2->op_type == OP_RV2HV) {
15472 action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
15473 goto do_deref;
15474 }
15475 break;
15476
15477 case OP_PADSV:
15478 /* $lex->[...]: padsv[$lex] sM/DREFAV */
15479
15480 ASSUME(!(o2->op_flags &
15481 ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
15482 if ((o2->op_flags &
15483 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15484 != (OPf_WANT_SCALAR|OPf_MOD))
15485 break;
15486
15487 ASSUME(!(o2->op_private &
15488 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
15489 /* skip if state or intro, or not a deref */
15490 if ( o2->op_private != OPpDEREF_AV
15491 && o2->op_private != OPpDEREF_HV)
15492 break;
15493
15494 o2 = o2->op_next;
15495 if (o2->op_type == OP_RV2AV) {
15496 action = MDEREF_AV_padsv_vivify_rv2av_aelem;
15497 goto do_deref;
15498 }
15499 if (o2->op_type == OP_RV2HV) {
15500 action = MDEREF_HV_padsv_vivify_rv2hv_helem;
15501 goto do_deref;
15502 }
15503 break;
15504
15505 case OP_PADAV:
15506 case OP_PADHV:
15507 /* $lex[..]: padav[@lex:1,2] sR *
15508 * or $lex{..}: padhv[%lex:1,2] sR */
15509 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
15510 OPf_REF|OPf_SPECIAL)));
15511 if ((o2->op_flags &
15512 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15513 != (OPf_WANT_SCALAR|OPf_REF))
15514 break;
15515 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
15516 break;
15517 /* OPf_PARENS isn't currently used in this case;
15518 * if that changes, let us know! */
15519 ASSUME(!(o2->op_flags & OPf_PARENS));
15520
15521 /* at this point, we wouldn't expect any of the remaining
15522 * possible private flags:
15523 * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
15524 * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
15525 *
15526 * OPpSLICEWARNING shouldn't affect runtime
15527 */
15528 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
15529
15530 action = o2->op_type == OP_PADAV
15531 ? MDEREF_AV_padav_aelem
15532 : MDEREF_HV_padhv_helem;
15533 o2 = o2->op_next;
15534 S_maybe_multideref(aTHX_ o, o2, action, 0);
15535 break;
15536
15537
15538 case OP_RV2AV:
15539 case OP_RV2HV:
15540 action = o2->op_type == OP_RV2AV
15541 ? MDEREF_AV_pop_rv2av_aelem
15542 : MDEREF_HV_pop_rv2hv_helem;
15543 /* FALLTHROUGH */
15544 do_deref:
15545 /* (expr)->[...]: rv2av sKR/1;
15546 * (expr)->{...}: rv2hv sKR/1; */
15547
15548 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
15549
15550 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
15551 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
15552 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
15553 break;
15554
15555 /* at this point, we wouldn't expect any of these
15556 * possible private flags:
15557 * OPpMAYBE_LVSUB, OPpLVAL_INTRO
15558 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
15559 */
15560 ASSUME(!(o2->op_private &
15561 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
15562 |OPpOUR_INTRO)));
15563 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
15564
15565 o2 = o2->op_next;
15566
15567 S_maybe_multideref(aTHX_ o, o2, action, hints);
15568 break;
15569
15570 default:
15571 break;
15572 }
15573 }
15574
15575
15576 switch (o->op_type) {
15577 case OP_DBSTATE:
15578 PL_curcop = ((COP*)o); /* for warnings */
15579 break;
15580 case OP_NEXTSTATE:
15581 PL_curcop = ((COP*)o); /* for warnings */
15582
15583 /* Optimise a "return ..." at the end of a sub to just be "...".
15584 * This saves 2 ops. Before:
15585 * 1 <;> nextstate(main 1 -e:1) v ->2
15586 * 4 <@> return K ->5
15587 * 2 <0> pushmark s ->3
15588 * - <1> ex-rv2sv sK/1 ->4
15589 * 3 <#> gvsv[*cat] s ->4
15590 *
15591 * After:
15592 * - <@> return K ->-
15593 * - <0> pushmark s ->2
15594 * - <1> ex-rv2sv sK/1 ->-
15595 * 2 <$> gvsv(*cat) s ->3
15596 */
15597 {
15598 OP *next = o->op_next;
15599 OP *sibling = OpSIBLING(o);
15600 if ( OP_TYPE_IS(next, OP_PUSHMARK)
15601 && OP_TYPE_IS(sibling, OP_RETURN)
15602 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
15603 && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
15604 ||OP_TYPE_IS(sibling->op_next->op_next,
15605 OP_LEAVESUBLV))
15606 && cUNOPx(sibling)->op_first == next
15607 && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
15608 && next->op_next
15609 ) {
15610 /* Look through the PUSHMARK's siblings for one that
15611 * points to the RETURN */
15612 OP *top = OpSIBLING(next);
15613 while (top && top->op_next) {
15614 if (top->op_next == sibling) {
15615 top->op_next = sibling->op_next;
15616 o->op_next = next->op_next;
15617 break;
15618 }
15619 top = OpSIBLING(top);
15620 }
15621 }
15622 }
15623
15624 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
15625 *
15626 * This latter form is then suitable for conversion into padrange
15627 * later on. Convert:
15628 *
15629 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
15630 *
15631 * into:
15632 *
15633 * nextstate1 -> listop -> nextstate3
15634 * / \
15635 * pushmark -> padop1 -> padop2
15636 */
15637 if (o->op_next && (
15638 o->op_next->op_type == OP_PADSV
15639 || o->op_next->op_type == OP_PADAV
15640 || o->op_next->op_type == OP_PADHV
15641 )
15642 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
15643 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
15644 && o->op_next->op_next->op_next && (
15645 o->op_next->op_next->op_next->op_type == OP_PADSV
15646 || o->op_next->op_next->op_next->op_type == OP_PADAV
15647 || o->op_next->op_next->op_next->op_type == OP_PADHV
15648 )
15649 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
15650 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
15651 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
15652 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
15653 ) {
15654 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
15655
15656 pad1 = o->op_next;
15657 ns2 = pad1->op_next;
15658 pad2 = ns2->op_next;
15659 ns3 = pad2->op_next;
15660
15661 /* we assume here that the op_next chain is the same as
15662 * the op_sibling chain */
15663 assert(OpSIBLING(o) == pad1);
15664 assert(OpSIBLING(pad1) == ns2);
15665 assert(OpSIBLING(ns2) == pad2);
15666 assert(OpSIBLING(pad2) == ns3);
15667
15668 /* excise and delete ns2 */
15669 op_sibling_splice(NULL, pad1, 1, NULL);
15670 op_free(ns2);
15671
15672 /* excise pad1 and pad2 */
15673 op_sibling_splice(NULL, o, 2, NULL);
15674
15675 /* create new listop, with children consisting of:
15676 * a new pushmark, pad1, pad2. */
15677 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
15678 newop->op_flags |= OPf_PARENS;
15679 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
15680
15681 /* insert newop between o and ns3 */
15682 op_sibling_splice(NULL, o, 0, newop);
15683
15684 /*fixup op_next chain */
15685 newpm = cUNOPx(newop)->op_first; /* pushmark */
15686 o ->op_next = newpm;
15687 newpm->op_next = pad1;
15688 pad1 ->op_next = pad2;
15689 pad2 ->op_next = newop; /* listop */
15690 newop->op_next = ns3;
15691
15692 /* Ensure pushmark has this flag if padops do */
15693 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
15694 newpm->op_flags |= OPf_MOD;
15695 }
15696
15697 break;
15698 }
15699
15700 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
15701 to carry two labels. For now, take the easier option, and skip
15702 this optimisation if the first NEXTSTATE has a label. */
15703 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
15704 OP *nextop = o->op_next;
15705 while (nextop && nextop->op_type == OP_NULL)
15706 nextop = nextop->op_next;
15707
15708 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
15709 op_null(o);
15710 if (oldop)
15711 oldop->op_next = nextop;
15712 o = nextop;
15713 /* Skip (old)oldop assignment since the current oldop's
15714 op_next already points to the next op. */
15715 goto redo;
15716 }
15717 }
15718 break;
15719
15720 case OP_CONCAT:
15721 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
15722 if (o->op_next->op_private & OPpTARGET_MY) {
15723 if (o->op_flags & OPf_STACKED) /* chained concats */
15724 break; /* ignore_optimization */
15725 else {
15726 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
15727 o->op_targ = o->op_next->op_targ;
15728 o->op_next->op_targ = 0;
15729 o->op_private |= OPpTARGET_MY;
15730 }
15731 }
15732 op_null(o->op_next);
15733 }
15734 break;
15735 case OP_STUB:
15736 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
15737 break; /* Scalar stub must produce undef. List stub is noop */
15738 }
15739 goto nothin;
15740 case OP_NULL:
15741 if (o->op_targ == OP_NEXTSTATE
15742 || o->op_targ == OP_DBSTATE)
15743 {
15744 PL_curcop = ((COP*)o);
15745 }
15746 /* XXX: We avoid setting op_seq here to prevent later calls
15747 to rpeep() from mistakenly concluding that optimisation
15748 has already occurred. This doesn't fix the real problem,
15749 though (See 20010220.007 (#5874)). AMS 20010719 */
15750 /* op_seq functionality is now replaced by op_opt */
15751 o->op_opt = 0;
15752 /* FALLTHROUGH */
15753 case OP_SCALAR:
15754 case OP_LINESEQ:
15755 case OP_SCOPE:
15756 nothin:
15757 if (oldop) {
15758 oldop->op_next = o->op_next;
15759 o->op_opt = 0;
15760 continue;
15761 }
15762 break;
15763
15764 case OP_PUSHMARK:
15765
15766 /* Given
15767 5 repeat/DOLIST
15768 3 ex-list
15769 1 pushmark
15770 2 scalar or const
15771 4 const[0]
15772 convert repeat into a stub with no kids.
15773 */
15774 if (o->op_next->op_type == OP_CONST
15775 || ( o->op_next->op_type == OP_PADSV
15776 && !(o->op_next->op_private & OPpLVAL_INTRO))
15777 || ( o->op_next->op_type == OP_GV
15778 && o->op_next->op_next->op_type == OP_RV2SV
15779 && !(o->op_next->op_next->op_private
15780 & (OPpLVAL_INTRO|OPpOUR_INTRO))))
15781 {
15782 const OP *kid = o->op_next->op_next;
15783 if (o->op_next->op_type == OP_GV)
15784 kid = kid->op_next;
15785 /* kid is now the ex-list. */
15786 if (kid->op_type == OP_NULL
15787 && (kid = kid->op_next)->op_type == OP_CONST
15788 /* kid is now the repeat count. */
15789 && kid->op_next->op_type == OP_REPEAT
15790 && kid->op_next->op_private & OPpREPEAT_DOLIST
15791 && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
15792 && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
15793 && oldop)
15794 {
15795 o = kid->op_next; /* repeat */
15796 oldop->op_next = o;
15797 op_free(cBINOPo->op_first);
15798 op_free(cBINOPo->op_last );
15799 o->op_flags &=~ OPf_KIDS;
15800 /* stub is a baseop; repeat is a binop */
15801 STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
15802 OpTYPE_set(o, OP_STUB);
15803 o->op_private = 0;
15804 break;
15805 }
15806 }
15807
15808 /* Convert a series of PAD ops for my vars plus support into a
15809 * single padrange op. Basically
15810 *
15811 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
15812 *
15813 * becomes, depending on circumstances, one of
15814 *
15815 * padrange ----------------------------------> (list) -> rest
15816 * padrange --------------------------------------------> rest
15817 *
15818 * where all the pad indexes are sequential and of the same type
15819 * (INTRO or not).
15820 * We convert the pushmark into a padrange op, then skip
15821 * any other pad ops, and possibly some trailing ops.
15822 * Note that we don't null() the skipped ops, to make it
15823 * easier for Deparse to undo this optimisation (and none of
15824 * the skipped ops are holding any resourses). It also makes
15825 * it easier for find_uninit_var(), as it can just ignore
15826 * padrange, and examine the original pad ops.
15827 */
15828 {
15829 OP *p;
15830 OP *followop = NULL; /* the op that will follow the padrange op */
15831 U8 count = 0;
15832 U8 intro = 0;
15833 PADOFFSET base = 0; /* init only to stop compiler whining */
15834 bool gvoid = 0; /* init only to stop compiler whining */
15835 bool defav = 0; /* seen (...) = @_ */
15836 bool reuse = 0; /* reuse an existing padrange op */
15837
15838 /* look for a pushmark -> gv[_] -> rv2av */
15839
15840 {
15841 OP *rv2av, *q;
15842 p = o->op_next;
15843 if ( p->op_type == OP_GV
15844 && cGVOPx_gv(p) == PL_defgv
15845 && (rv2av = p->op_next)
15846 && rv2av->op_type == OP_RV2AV
15847 && !(rv2av->op_flags & OPf_REF)
15848 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
15849 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
15850 ) {
15851 q = rv2av->op_next;
15852 if (q->op_type == OP_NULL)
15853 q = q->op_next;
15854 if (q->op_type == OP_PUSHMARK) {
15855 defav = 1;
15856 p = q;
15857 }
15858 }
15859 }
15860 if (!defav) {
15861 p = o;
15862 }
15863
15864 /* scan for PAD ops */
15865
15866 for (p = p->op_next; p; p = p->op_next) {
15867 if (p->op_type == OP_NULL)
15868 continue;
15869
15870 if (( p->op_type != OP_PADSV
15871 && p->op_type != OP_PADAV
15872 && p->op_type != OP_PADHV
15873 )
15874 /* any private flag other than INTRO? e.g. STATE */
15875 || (p->op_private & ~OPpLVAL_INTRO)
15876 )
15877 break;
15878
15879 /* let $a[N] potentially be optimised into AELEMFAST_LEX
15880 * instead */
15881 if ( p->op_type == OP_PADAV
15882 && p->op_next
15883 && p->op_next->op_type == OP_CONST
15884 && p->op_next->op_next
15885 && p->op_next->op_next->op_type == OP_AELEM
15886 )
15887 break;
15888
15889 /* for 1st padop, note what type it is and the range
15890 * start; for the others, check that it's the same type
15891 * and that the targs are contiguous */
15892 if (count == 0) {
15893 intro = (p->op_private & OPpLVAL_INTRO);
15894 base = p->op_targ;
15895 gvoid = OP_GIMME(p,0) == G_VOID;
15896 }
15897 else {
15898 if ((p->op_private & OPpLVAL_INTRO) != intro)
15899 break;
15900 /* Note that you'd normally expect targs to be
15901 * contiguous in my($a,$b,$c), but that's not the case
15902 * when external modules start doing things, e.g.
15903 * Function::Parameters */
15904 if (p->op_targ != base + count)
15905 break;
15906 assert(p->op_targ == base + count);
15907 /* Either all the padops or none of the padops should
15908 be in void context. Since we only do the optimisa-
15909 tion for av/hv when the aggregate itself is pushed
15910 on to the stack (one item), there is no need to dis-
15911 tinguish list from scalar context. */
15912 if (gvoid != (OP_GIMME(p,0) == G_VOID))
15913 break;
15914 }
15915
15916 /* for AV, HV, only when we're not flattening */
15917 if ( p->op_type != OP_PADSV
15918 && !gvoid
15919 && !(p->op_flags & OPf_REF)
15920 )
15921 break;
15922
15923 if (count >= OPpPADRANGE_COUNTMASK)
15924 break;
15925
15926 /* there's a biggest base we can fit into a
15927 * SAVEt_CLEARPADRANGE in pp_padrange.
15928 * (The sizeof() stuff will be constant-folded, and is
15929 * intended to avoid getting "comparison is always false"
15930 * compiler warnings. See the comments above
15931 * MEM_WRAP_CHECK for more explanation on why we do this
15932 * in a weird way to avoid compiler warnings.)
15933 */
15934 if ( intro
15935 && (8*sizeof(base) >
15936 8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
15937 ? (Size_t)base
15938 : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
15939 ) >
15940 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
15941 )
15942 break;
15943
15944 /* Success! We've got another valid pad op to optimise away */
15945 count++;
15946 followop = p->op_next;
15947 }
15948
15949 if (count < 1 || (count == 1 && !defav))
15950 break;
15951
15952 /* pp_padrange in specifically compile-time void context
15953 * skips pushing a mark and lexicals; in all other contexts
15954 * (including unknown till runtime) it pushes a mark and the
15955 * lexicals. We must be very careful then, that the ops we
15956 * optimise away would have exactly the same effect as the
15957 * padrange.
15958 * In particular in void context, we can only optimise to
15959 * a padrange if we see the complete sequence
15960 * pushmark, pad*v, ...., list
15961 * which has the net effect of leaving the markstack as it
15962 * was. Not pushing onto the stack (whereas padsv does touch
15963 * the stack) makes no difference in void context.
15964 */
15965 assert(followop);
15966 if (gvoid) {
15967 if (followop->op_type == OP_LIST
15968 && OP_GIMME(followop,0) == G_VOID
15969 )
15970 {
15971 followop = followop->op_next; /* skip OP_LIST */
15972
15973 /* consolidate two successive my(...);'s */
15974
15975 if ( oldoldop
15976 && oldoldop->op_type == OP_PADRANGE
15977 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
15978 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
15979 && !(oldoldop->op_flags & OPf_SPECIAL)
15980 ) {
15981 U8 old_count;
15982 assert(oldoldop->op_next == oldop);
15983 assert( oldop->op_type == OP_NEXTSTATE
15984 || oldop->op_type == OP_DBSTATE);
15985 assert(oldop->op_next == o);
15986
15987 old_count
15988 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
15989
15990 /* Do not assume pad offsets for $c and $d are con-
15991 tiguous in
15992 my ($a,$b,$c);
15993 my ($d,$e,$f);
15994 */
15995 if ( oldoldop->op_targ + old_count == base
15996 && old_count < OPpPADRANGE_COUNTMASK - count) {
15997 base = oldoldop->op_targ;
15998 count += old_count;
15999 reuse = 1;
16000 }
16001 }
16002
16003 /* if there's any immediately following singleton
16004 * my var's; then swallow them and the associated
16005 * nextstates; i.e.
16006 * my ($a,$b); my $c; my $d;
16007 * is treated as
16008 * my ($a,$b,$c,$d);
16009 */
16010
16011 while ( ((p = followop->op_next))
16012 && ( p->op_type == OP_PADSV
16013 || p->op_type == OP_PADAV
16014 || p->op_type == OP_PADHV)
16015 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
16016 && (p->op_private & OPpLVAL_INTRO) == intro
16017 && !(p->op_private & ~OPpLVAL_INTRO)
16018 && p->op_next
16019 && ( p->op_next->op_type == OP_NEXTSTATE
16020 || p->op_next->op_type == OP_DBSTATE)
16021 && count < OPpPADRANGE_COUNTMASK
16022 && base + count == p->op_targ
16023 ) {
16024 count++;
16025 followop = p->op_next;
16026 }
16027 }
16028 else
16029 break;
16030 }
16031
16032 if (reuse) {
16033 assert(oldoldop->op_type == OP_PADRANGE);
16034 oldoldop->op_next = followop;
16035 oldoldop->op_private = (intro | count);
16036 o = oldoldop;
16037 oldop = NULL;
16038 oldoldop = NULL;
16039 }
16040 else {
16041 /* Convert the pushmark into a padrange.
16042 * To make Deparse easier, we guarantee that a padrange was
16043 * *always* formerly a pushmark */
16044 assert(o->op_type == OP_PUSHMARK);
16045 o->op_next = followop;
16046 OpTYPE_set(o, OP_PADRANGE);
16047 o->op_targ = base;
16048 /* bit 7: INTRO; bit 6..0: count */
16049 o->op_private = (intro | count);
16050 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
16051 | gvoid * OPf_WANT_VOID
16052 | (defav ? OPf_SPECIAL : 0));
16053 }
16054 break;
16055 }
16056
16057 case OP_RV2AV:
16058 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16059 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16060 break;
16061
16062 case OP_RV2HV:
16063 case OP_PADHV:
16064 /*'keys %h' in void or scalar context: skip the OP_KEYS
16065 * and perform the functionality directly in the RV2HV/PADHV
16066 * op
16067 */
16068 if (o->op_flags & OPf_REF) {
16069 OP *k = o->op_next;
16070 U8 want = (k->op_flags & OPf_WANT);
16071 if ( k
16072 && k->op_type == OP_KEYS
16073 && ( want == OPf_WANT_VOID
16074 || want == OPf_WANT_SCALAR)
16075 && !(k->op_private & OPpMAYBE_LVSUB)
16076 && !(k->op_flags & OPf_MOD)
16077 ) {
16078 o->op_next = k->op_next;
16079 o->op_flags &= ~(OPf_REF|OPf_WANT);
16080 o->op_flags |= want;
16081 o->op_private |= (o->op_type == OP_PADHV ?
16082 OPpPADHV_ISKEYS : OPpRV2HV_ISKEYS);
16083 /* for keys(%lex), hold onto the OP_KEYS's targ
16084 * since padhv doesn't have its own targ to return
16085 * an int with */
16086 if (!(o->op_type ==OP_PADHV && want == OPf_WANT_SCALAR))
16087 op_null(k);
16088 }
16089 }
16090
16091 /* see if %h is used in boolean context */
16092 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16093 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
16094
16095
16096 if (o->op_type != OP_PADHV)
16097 break;
16098 /* FALLTHROUGH */
16099 case OP_PADAV:
16100 if ( o->op_type == OP_PADAV
16101 && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
16102 )
16103 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16104 /* FALLTHROUGH */
16105 case OP_PADSV:
16106 /* Skip over state($x) in void context. */
16107 if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
16108 && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
16109 {
16110 oldop->op_next = o->op_next;
16111 goto redo_nextstate;
16112 }
16113 if (o->op_type != OP_PADAV)
16114 break;
16115 /* FALLTHROUGH */
16116 case OP_GV:
16117 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
16118 OP* const pop = (o->op_type == OP_PADAV) ?
16119 o->op_next : o->op_next->op_next;
16120 IV i;
16121 if (pop && pop->op_type == OP_CONST &&
16122 ((PL_op = pop->op_next)) &&
16123 pop->op_next->op_type == OP_AELEM &&
16124 !(pop->op_next->op_private &
16125 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
16126 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
16127 {
16128 GV *gv;
16129 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
16130 no_bareword_allowed(pop);
16131 if (o->op_type == OP_GV)
16132 op_null(o->op_next);
16133 op_null(pop->op_next);
16134 op_null(pop);
16135 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
16136 o->op_next = pop->op_next->op_next;
16137 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
16138 o->op_private = (U8)i;
16139 if (o->op_type == OP_GV) {
16140 gv = cGVOPo_gv;
16141 GvAVn(gv);
16142 o->op_type = OP_AELEMFAST;
16143 }
16144 else
16145 o->op_type = OP_AELEMFAST_LEX;
16146 }
16147 if (o->op_type != OP_GV)
16148 break;
16149 }
16150
16151 /* Remove $foo from the op_next chain in void context. */
16152 if (oldop
16153 && ( o->op_next->op_type == OP_RV2SV
16154 || o->op_next->op_type == OP_RV2AV
16155 || o->op_next->op_type == OP_RV2HV )
16156 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
16157 && !(o->op_next->op_private & OPpLVAL_INTRO))
16158 {
16159 oldop->op_next = o->op_next->op_next;
16160 /* Reprocess the previous op if it is a nextstate, to
16161 allow double-nextstate optimisation. */
16162 redo_nextstate:
16163 if (oldop->op_type == OP_NEXTSTATE) {
16164 oldop->op_opt = 0;
16165 o = oldop;
16166 oldop = oldoldop;
16167 oldoldop = NULL;
16168 goto redo;
16169 }
16170 o = oldop->op_next;
16171 goto redo;
16172 }
16173 else if (o->op_next->op_type == OP_RV2SV) {
16174 if (!(o->op_next->op_private & OPpDEREF)) {
16175 op_null(o->op_next);
16176 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
16177 | OPpOUR_INTRO);
16178 o->op_next = o->op_next->op_next;
16179 OpTYPE_set(o, OP_GVSV);
16180 }
16181 }
16182 else if (o->op_next->op_type == OP_READLINE
16183 && o->op_next->op_next->op_type == OP_CONCAT
16184 && (o->op_next->op_next->op_flags & OPf_STACKED))
16185 {
16186 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
16187 OpTYPE_set(o, OP_RCATLINE);
16188 o->op_flags |= OPf_STACKED;
16189 op_null(o->op_next->op_next);
16190 op_null(o->op_next);
16191 }
16192
16193 break;
16194
16195 case OP_NOT:
16196 break;
16197
16198 case OP_AND:
16199 case OP_OR:
16200 case OP_DOR:
16201 while (cLOGOP->op_other->op_type == OP_NULL)
16202 cLOGOP->op_other = cLOGOP->op_other->op_next;
16203 while (o->op_next && ( o->op_type == o->op_next->op_type
16204 || o->op_next->op_type == OP_NULL))
16205 o->op_next = o->op_next->op_next;
16206
16207 /* If we're an OR and our next is an AND in void context, we'll
16208 follow its op_other on short circuit, same for reverse.
16209 We can't do this with OP_DOR since if it's true, its return
16210 value is the underlying value which must be evaluated
16211 by the next op. */
16212 if (o->op_next &&
16213 (
16214 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
16215 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
16216 )
16217 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
16218 ) {
16219 o->op_next = ((LOGOP*)o->op_next)->op_other;
16220 }
16221 DEFER(cLOGOP->op_other);
16222 o->op_opt = 1;
16223 break;
16224
16225 case OP_GREPWHILE:
16226 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16227 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16228 /* FALLTHROUGH */
16229 case OP_COND_EXPR:
16230 case OP_MAPWHILE:
16231 case OP_ANDASSIGN:
16232 case OP_ORASSIGN:
16233 case OP_DORASSIGN:
16234 case OP_RANGE:
16235 case OP_ONCE:
16236 case OP_ARGDEFELEM:
16237 while (cLOGOP->op_other->op_type == OP_NULL)
16238 cLOGOP->op_other = cLOGOP->op_other->op_next;
16239 DEFER(cLOGOP->op_other);
16240 break;
16241
16242 case OP_ENTERLOOP:
16243 case OP_ENTERITER:
16244 while (cLOOP->op_redoop->op_type == OP_NULL)
16245 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
16246 while (cLOOP->op_nextop->op_type == OP_NULL)
16247 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
16248 while (cLOOP->op_lastop->op_type == OP_NULL)
16249 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
16250 /* a while(1) loop doesn't have an op_next that escapes the
16251 * loop, so we have to explicitly follow the op_lastop to
16252 * process the rest of the code */
16253 DEFER(cLOOP->op_lastop);
16254 break;
16255
16256 case OP_ENTERTRY:
16257 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
16258 DEFER(cLOGOPo->op_other);
16259 break;
16260
16261 case OP_SUBST:
16262 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16263 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16264 assert(!(cPMOP->op_pmflags & PMf_ONCE));
16265 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
16266 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
16267 cPMOP->op_pmstashstartu.op_pmreplstart
16268 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
16269 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
16270 break;
16271
16272 case OP_SORT: {
16273 OP *oright;
16274
16275 if (o->op_flags & OPf_SPECIAL) {
16276 /* first arg is a code block */
16277 OP * const nullop = OpSIBLING(cLISTOP->op_first);
16278 OP * kid = cUNOPx(nullop)->op_first;
16279
16280 assert(nullop->op_type == OP_NULL);
16281 assert(kid->op_type == OP_SCOPE
16282 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
16283 /* since OP_SORT doesn't have a handy op_other-style
16284 * field that can point directly to the start of the code
16285 * block, store it in the otherwise-unused op_next field
16286 * of the top-level OP_NULL. This will be quicker at
16287 * run-time, and it will also allow us to remove leading
16288 * OP_NULLs by just messing with op_nexts without
16289 * altering the basic op_first/op_sibling layout. */
16290 kid = kLISTOP->op_first;
16291 assert(
16292 (kid->op_type == OP_NULL
16293 && ( kid->op_targ == OP_NEXTSTATE
16294 || kid->op_targ == OP_DBSTATE ))
16295 || kid->op_type == OP_STUB
16296 || kid->op_type == OP_ENTER
16297 || (PL_parser && PL_parser->error_count));
16298 nullop->op_next = kid->op_next;
16299 DEFER(nullop->op_next);
16300 }
16301
16302 /* check that RHS of sort is a single plain array */
16303 oright = cUNOPo->op_first;
16304 if (!oright || oright->op_type != OP_PUSHMARK)
16305 break;
16306
16307 if (o->op_private & OPpSORT_INPLACE)
16308 break;
16309
16310 /* reverse sort ... can be optimised. */
16311 if (!OpHAS_SIBLING(cUNOPo)) {
16312 /* Nothing follows us on the list. */
16313 OP * const reverse = o->op_next;
16314
16315 if (reverse->op_type == OP_REVERSE &&
16316 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
16317 OP * const pushmark = cUNOPx(reverse)->op_first;
16318 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
16319 && (OpSIBLING(cUNOPx(pushmark)) == o)) {
16320 /* reverse -> pushmark -> sort */
16321 o->op_private |= OPpSORT_REVERSE;
16322 op_null(reverse);
16323 pushmark->op_next = oright->op_next;
16324 op_null(oright);
16325 }
16326 }
16327 }
16328
16329 break;
16330 }
16331
16332 case OP_REVERSE: {
16333 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
16334 OP *gvop = NULL;
16335 LISTOP *enter, *exlist;
16336
16337 if (o->op_private & OPpSORT_INPLACE)
16338 break;
16339
16340 enter = (LISTOP *) o->op_next;
16341 if (!enter)
16342 break;
16343 if (enter->op_type == OP_NULL) {
16344 enter = (LISTOP *) enter->op_next;
16345 if (!enter)
16346 break;
16347 }
16348 /* for $a (...) will have OP_GV then OP_RV2GV here.
16349 for (...) just has an OP_GV. */
16350 if (enter->op_type == OP_GV) {
16351 gvop = (OP *) enter;
16352 enter = (LISTOP *) enter->op_next;
16353 if (!enter)
16354 break;
16355 if (enter->op_type == OP_RV2GV) {
16356 enter = (LISTOP *) enter->op_next;
16357 if (!enter)
16358 break;
16359 }
16360 }
16361
16362 if (enter->op_type != OP_ENTERITER)
16363 break;
16364
16365 iter = enter->op_next;
16366 if (!iter || iter->op_type != OP_ITER)
16367 break;
16368
16369 expushmark = enter->op_first;
16370 if (!expushmark || expushmark->op_type != OP_NULL
16371 || expushmark->op_targ != OP_PUSHMARK)
16372 break;
16373
16374 exlist = (LISTOP *) OpSIBLING(expushmark);
16375 if (!exlist || exlist->op_type != OP_NULL
16376 || exlist->op_targ != OP_LIST)
16377 break;
16378
16379 if (exlist->op_last != o) {
16380 /* Mmm. Was expecting to point back to this op. */
16381 break;
16382 }
16383 theirmark = exlist->op_first;
16384 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
16385 break;
16386
16387 if (OpSIBLING(theirmark) != o) {
16388 /* There's something between the mark and the reverse, eg
16389 for (1, reverse (...))
16390 so no go. */
16391 break;
16392 }
16393
16394 ourmark = ((LISTOP *)o)->op_first;
16395 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
16396 break;
16397
16398 ourlast = ((LISTOP *)o)->op_last;
16399 if (!ourlast || ourlast->op_next != o)
16400 break;
16401
16402 rv2av = OpSIBLING(ourmark);
16403 if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
16404 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
16405 /* We're just reversing a single array. */
16406 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
16407 enter->op_flags |= OPf_STACKED;
16408 }
16409
16410 /* We don't have control over who points to theirmark, so sacrifice
16411 ours. */
16412 theirmark->op_next = ourmark->op_next;
16413 theirmark->op_flags = ourmark->op_flags;
16414 ourlast->op_next = gvop ? gvop : (OP *) enter;
16415 op_null(ourmark);
16416 op_null(o);
16417 enter->op_private |= OPpITER_REVERSED;
16418 iter->op_private |= OPpITER_REVERSED;
16419
16420 oldoldop = NULL;
16421 oldop = ourlast;
16422 o = oldop->op_next;
16423 goto redo;
16424 NOT_REACHED; /* NOTREACHED */
16425 break;
16426 }
16427
16428 case OP_QR:
16429 case OP_MATCH:
16430 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
16431 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
16432 }
16433 break;
16434
16435 case OP_RUNCV:
16436 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
16437 && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
16438 {
16439 SV *sv;
16440 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
16441 else {
16442 sv = newRV((SV *)PL_compcv);
16443 sv_rvweaken(sv);
16444 SvREADONLY_on(sv);
16445 }
16446 OpTYPE_set(o, OP_CONST);
16447 o->op_flags |= OPf_SPECIAL;
16448 cSVOPo->op_sv = sv;
16449 }
16450 break;
16451
16452 case OP_SASSIGN:
16453 if (OP_GIMME(o,0) == G_VOID
16454 || ( o->op_next->op_type == OP_LINESEQ
16455 && ( o->op_next->op_next->op_type == OP_LEAVESUB
16456 || ( o->op_next->op_next->op_type == OP_RETURN
16457 && !CvLVALUE(PL_compcv)))))
16458 {
16459 OP *right = cBINOP->op_first;
16460 if (right) {
16461 /* sassign
16462 * RIGHT
16463 * substr
16464 * pushmark
16465 * arg1
16466 * arg2
16467 * ...
16468 * becomes
16469 *
16470 * ex-sassign
16471 * substr
16472 * pushmark
16473 * RIGHT
16474 * arg1
16475 * arg2
16476 * ...
16477 */
16478 OP *left = OpSIBLING(right);
16479 if (left->op_type == OP_SUBSTR
16480 && (left->op_private & 7) < 4) {
16481 op_null(o);
16482 /* cut out right */
16483 op_sibling_splice(o, NULL, 1, NULL);
16484 /* and insert it as second child of OP_SUBSTR */
16485 op_sibling_splice(left, cBINOPx(left)->op_first, 0,
16486 right);
16487 left->op_private |= OPpSUBSTR_REPL_FIRST;
16488 left->op_flags =
16489 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
16490 }
16491 }
16492 }
16493 break;
16494
16495 case OP_AASSIGN: {
16496 int l, r, lr, lscalars, rscalars;
16497
16498 /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
16499 Note that we do this now rather than in newASSIGNOP(),
16500 since only by now are aliased lexicals flagged as such
16501
16502 See the essay "Common vars in list assignment" above for
16503 the full details of the rationale behind all the conditions
16504 below.
16505
16506 PL_generation sorcery:
16507 To detect whether there are common vars, the global var
16508 PL_generation is incremented for each assign op we scan.
16509 Then we run through all the lexical variables on the LHS,
16510 of the assignment, setting a spare slot in each of them to
16511 PL_generation. Then we scan the RHS, and if any lexicals
16512 already have that value, we know we've got commonality.
16513 Also, if the generation number is already set to
16514 PERL_INT_MAX, then the variable is involved in aliasing, so
16515 we also have potential commonality in that case.
16516 */
16517
16518 PL_generation++;
16519 /* scan LHS */
16520 lscalars = 0;
16521 l = S_aassign_scan(aTHX_ cLISTOPo->op_last, FALSE, 1, &lscalars);
16522 /* scan RHS */
16523 rscalars = 0;
16524 r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, 1, &rscalars);
16525 lr = (l|r);
16526
16527
16528 /* After looking for things which are *always* safe, this main
16529 * if/else chain selects primarily based on the type of the
16530 * LHS, gradually working its way down from the more dangerous
16531 * to the more restrictive and thus safer cases */
16532
16533 if ( !l /* () = ....; */
16534 || !r /* .... = (); */
16535 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
16536 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
16537 || (lscalars < 2) /* ($x, undef) = ... */
16538 ) {
16539 NOOP; /* always safe */
16540 }
16541 else if (l & AAS_DANGEROUS) {
16542 /* always dangerous */
16543 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16544 o->op_private |= OPpASSIGN_COMMON_AGG;
16545 }
16546 else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
16547 /* package vars are always dangerous - too many
16548 * aliasing possibilities */
16549 if (l & AAS_PKG_SCALAR)
16550 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16551 if (l & AAS_PKG_AGG)
16552 o->op_private |= OPpASSIGN_COMMON_AGG;
16553 }
16554 else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
16555 |AAS_LEX_SCALAR|AAS_LEX_AGG))
16556 {
16557 /* LHS contains only lexicals and safe ops */
16558
16559 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
16560 o->op_private |= OPpASSIGN_COMMON_AGG;
16561
16562 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
16563 if (lr & AAS_LEX_SCALAR_COMM)
16564 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16565 else if ( !(l & AAS_LEX_SCALAR)
16566 && (r & AAS_DEFAV))
16567 {
16568 /* falsely mark
16569 * my (...) = @_
16570 * as scalar-safe for performance reasons.
16571 * (it will still have been marked _AGG if necessary */
16572 NOOP;
16573 }
16574 else if (r & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
16575 /* if there are only lexicals on the LHS and no
16576 * common ones on the RHS, then we assume that the
16577 * only way those lexicals could also get
16578 * on the RHS is via some sort of dereffing or
16579 * closure, e.g.
16580 * $r = \$lex;
16581 * ($lex, $x) = (1, $$r)
16582 * and in this case we assume the var must have
16583 * a bumped ref count. So if its ref count is 1,
16584 * it must only be on the LHS.
16585 */
16586 o->op_private |= OPpASSIGN_COMMON_RC1;
16587 }
16588 }
16589
16590 /* ... = ($x)
16591 * may have to handle aggregate on LHS, but we can't
16592 * have common scalars. */
16593 if (rscalars < 2)
16594 o->op_private &=
16595 ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
16596
16597 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16598 S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0);
16599 break;
16600 }
16601
16602 case OP_REF:
16603 /* see if ref() is used in boolean context */
16604 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16605 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
16606 break;
16607
16608 case OP_LENGTH:
16609 /* see if the op is used in known boolean context,
16610 * but not if OA_TARGLEX optimisation is enabled */
16611 if ( (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
16612 && !(o->op_private & OPpTARGET_MY)
16613 )
16614 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16615 break;
16616
16617 case OP_POS:
16618 /* see if the op is used in known boolean context */
16619 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16620 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16621 break;
16622
16623 case OP_CUSTOM: {
16624 Perl_cpeep_t cpeep =
16625 XopENTRYCUSTOM(o, xop_peep);
16626 if (cpeep)
16627 cpeep(aTHX_ o, oldop);
16628 break;
16629 }
16630
16631 }
16632 /* did we just null the current op? If so, re-process it to handle
16633 * eliding "empty" ops from the chain */
16634 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
16635 o->op_opt = 0;
16636 o = oldop;
16637 }
16638 else {
16639 oldoldop = oldop;
16640 oldop = o;
16641 }
16642 }
16643 LEAVE;
16644 }
16645
16646 void
Perl_peep(pTHX_ OP * o)16647 Perl_peep(pTHX_ OP *o)
16648 {
16649 CALL_RPEEP(o);
16650 }
16651
16652 /*
16653 =head1 Custom Operators
16654
16655 =for apidoc Ao||custom_op_xop
16656 Return the XOP structure for a given custom op. This macro should be
16657 considered internal to C<OP_NAME> and the other access macros: use them instead.
16658 This macro does call a function. Prior
16659 to 5.19.6, this was implemented as a
16660 function.
16661
16662 =cut
16663 */
16664
16665
16666 /* use PERL_MAGIC_ext to call a function to free the xop structure when
16667 * freeing PL_custom_ops */
16668
16669 static int
custom_op_register_free(pTHX_ SV * sv,MAGIC * mg)16670 custom_op_register_free(pTHX_ SV *sv, MAGIC *mg)
16671 {
16672 XOP *xop;
16673
16674 PERL_UNUSED_ARG(mg);
16675 xop = INT2PTR(XOP *, SvIV(sv));
16676 Safefree(xop->xop_name);
16677 Safefree(xop->xop_desc);
16678 Safefree(xop);
16679 return 0;
16680 }
16681
16682
16683 static const MGVTBL custom_op_register_vtbl = {
16684 0, /* get */
16685 0, /* set */
16686 0, /* len */
16687 0, /* clear */
16688 custom_op_register_free, /* free */
16689 0, /* copy */
16690 0, /* dup */
16691 #ifdef MGf_LOCAL
16692 0, /* local */
16693 #endif
16694 };
16695
16696
16697 XOPRETANY
Perl_custom_op_get_field(pTHX_ const OP * o,const xop_flags_enum field)16698 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
16699 {
16700 SV *keysv;
16701 HE *he = NULL;
16702 XOP *xop;
16703
16704 static const XOP xop_null = { 0, 0, 0, 0, 0 };
16705
16706 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
16707 assert(o->op_type == OP_CUSTOM);
16708
16709 /* This is wrong. It assumes a function pointer can be cast to IV,
16710 * which isn't guaranteed, but this is what the old custom OP code
16711 * did. In principle it should be safer to Copy the bytes of the
16712 * pointer into a PV: since the new interface is hidden behind
16713 * functions, this can be changed later if necessary. */
16714 /* Change custom_op_xop if this ever happens */
16715 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
16716
16717 if (PL_custom_ops)
16718 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
16719
16720 /* See if the op isn't registered, but its name *is* registered.
16721 * That implies someone is using the pre-5.14 API,where only name and
16722 * description could be registered. If so, fake up a real
16723 * registration.
16724 * We only check for an existing name, and assume no one will have
16725 * just registered a desc */
16726 if (!he && PL_custom_op_names &&
16727 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
16728 ) {
16729 const char *pv;
16730 STRLEN l;
16731
16732 /* XXX does all this need to be shared mem? */
16733 Newxz(xop, 1, XOP);
16734 pv = SvPV(HeVAL(he), l);
16735 XopENTRY_set(xop, xop_name, savepvn(pv, l));
16736 if (PL_custom_op_descs &&
16737 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
16738 ) {
16739 pv = SvPV(HeVAL(he), l);
16740 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
16741 }
16742 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
16743 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
16744 /* add magic to the SV so that the xop struct (pointed to by
16745 * SvIV(sv)) is freed. Normally a static xop is registered, but
16746 * for this backcompat hack, we've alloced one */
16747 (void)sv_magicext(HeVAL(he), NULL, PERL_MAGIC_ext,
16748 &custom_op_register_vtbl, NULL, 0);
16749
16750 }
16751 else {
16752 if (!he)
16753 xop = (XOP *)&xop_null;
16754 else
16755 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
16756 }
16757 {
16758 XOPRETANY any;
16759 if(field == XOPe_xop_ptr) {
16760 any.xop_ptr = xop;
16761 } else {
16762 const U32 flags = XopFLAGS(xop);
16763 if(flags & field) {
16764 switch(field) {
16765 case XOPe_xop_name:
16766 any.xop_name = xop->xop_name;
16767 break;
16768 case XOPe_xop_desc:
16769 any.xop_desc = xop->xop_desc;
16770 break;
16771 case XOPe_xop_class:
16772 any.xop_class = xop->xop_class;
16773 break;
16774 case XOPe_xop_peep:
16775 any.xop_peep = xop->xop_peep;
16776 break;
16777 default:
16778 NOT_REACHED; /* NOTREACHED */
16779 break;
16780 }
16781 } else {
16782 switch(field) {
16783 case XOPe_xop_name:
16784 any.xop_name = XOPd_xop_name;
16785 break;
16786 case XOPe_xop_desc:
16787 any.xop_desc = XOPd_xop_desc;
16788 break;
16789 case XOPe_xop_class:
16790 any.xop_class = XOPd_xop_class;
16791 break;
16792 case XOPe_xop_peep:
16793 any.xop_peep = XOPd_xop_peep;
16794 break;
16795 default:
16796 NOT_REACHED; /* NOTREACHED */
16797 break;
16798 }
16799 }
16800 }
16801 /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
16802 * op.c: In function 'Perl_custom_op_get_field':
16803 * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
16804 * This is because on those platforms (with -DEBUGGING) NOT_REACHED
16805 * expands to assert(0), which expands to ((0) ? (void)0 :
16806 * __assert(...)), and gcc doesn't know that __assert can never return. */
16807 return any;
16808 }
16809 }
16810
16811 /*
16812 =for apidoc Ao||custom_op_register
16813 Register a custom op. See L<perlguts/"Custom Operators">.
16814
16815 =cut
16816 */
16817
16818 void
Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr,const XOP * xop)16819 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
16820 {
16821 SV *keysv;
16822
16823 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
16824
16825 /* see the comment in custom_op_xop */
16826 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
16827
16828 if (!PL_custom_ops)
16829 PL_custom_ops = newHV();
16830
16831 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
16832 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
16833 }
16834
16835 /*
16836
16837 =for apidoc core_prototype
16838
16839 This function assigns the prototype of the named core function to C<sv>, or
16840 to a new mortal SV if C<sv> is C<NULL>. It returns the modified C<sv>, or
16841 C<NULL> if the core function has no prototype. C<code> is a code as returned
16842 by C<keyword()>. It must not be equal to 0.
16843
16844 =cut
16845 */
16846
16847 SV *
Perl_core_prototype(pTHX_ SV * sv,const char * name,const int code,int * const opnum)16848 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
16849 int * const opnum)
16850 {
16851 int i = 0, n = 0, seen_question = 0, defgv = 0;
16852 I32 oa;
16853 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
16854 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
16855 bool nullret = FALSE;
16856
16857 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
16858
16859 assert (code);
16860
16861 if (!sv) sv = sv_newmortal();
16862
16863 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
16864
16865 switch (code < 0 ? -code : code) {
16866 case KEY_and : case KEY_chop: case KEY_chomp:
16867 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
16868 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
16869 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
16870 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
16871 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
16872 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
16873 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
16874 case KEY_x : case KEY_xor :
16875 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
16876 case KEY_glob: retsetpvs("_;", OP_GLOB);
16877 case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
16878 case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
16879 case KEY_each: retsetpvs("\\[%@]", OP_EACH);
16880 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
16881 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
16882 retsetpvs("", 0);
16883 case KEY_evalbytes:
16884 name = "entereval"; break;
16885 case KEY_readpipe:
16886 name = "backtick";
16887 }
16888
16889 #undef retsetpvs
16890
16891 findopnum:
16892 while (i < MAXO) { /* The slow way. */
16893 if (strEQ(name, PL_op_name[i])
16894 || strEQ(name, PL_op_desc[i]))
16895 {
16896 if (nullret) { assert(opnum); *opnum = i; return NULL; }
16897 goto found;
16898 }
16899 i++;
16900 }
16901 return NULL;
16902 found:
16903 defgv = PL_opargs[i] & OA_DEFGV;
16904 oa = PL_opargs[i] >> OASHIFT;
16905 while (oa) {
16906 if (oa & OA_OPTIONAL && !seen_question && (
16907 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
16908 )) {
16909 seen_question = 1;
16910 str[n++] = ';';
16911 }
16912 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
16913 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
16914 /* But globs are already references (kinda) */
16915 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
16916 ) {
16917 str[n++] = '\\';
16918 }
16919 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
16920 && !scalar_mod_type(NULL, i)) {
16921 str[n++] = '[';
16922 str[n++] = '$';
16923 str[n++] = '@';
16924 str[n++] = '%';
16925 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
16926 str[n++] = '*';
16927 str[n++] = ']';
16928 }
16929 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
16930 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
16931 str[n-1] = '_'; defgv = 0;
16932 }
16933 oa = oa >> 4;
16934 }
16935 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
16936 str[n++] = '\0';
16937 sv_setpvn(sv, str, n - 1);
16938 if (opnum) *opnum = i;
16939 return sv;
16940 }
16941
16942 OP *
Perl_coresub_op(pTHX_ SV * const coreargssv,const int code,const int opnum)16943 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
16944 const int opnum)
16945 {
16946 OP * const argop = (opnum == OP_SELECT && code) ? NULL :
16947 newSVOP(OP_COREARGS,0,coreargssv);
16948 OP *o;
16949
16950 PERL_ARGS_ASSERT_CORESUB_OP;
16951
16952 switch(opnum) {
16953 case 0:
16954 return op_append_elem(OP_LINESEQ,
16955 argop,
16956 newSLICEOP(0,
16957 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
16958 newOP(OP_CALLER,0)
16959 )
16960 );
16961 case OP_EACH:
16962 case OP_KEYS:
16963 case OP_VALUES:
16964 o = newUNOP(OP_AVHVSWITCH,0,argop);
16965 o->op_private = opnum-OP_EACH;
16966 return o;
16967 case OP_SELECT: /* which represents OP_SSELECT as well */
16968 if (code)
16969 return newCONDOP(
16970 0,
16971 newBINOP(OP_GT, 0,
16972 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
16973 newSVOP(OP_CONST, 0, newSVuv(1))
16974 ),
16975 coresub_op(newSVuv((UV)OP_SSELECT), 0,
16976 OP_SSELECT),
16977 coresub_op(coreargssv, 0, OP_SELECT)
16978 );
16979 /* FALLTHROUGH */
16980 default:
16981 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
16982 case OA_BASEOP:
16983 return op_append_elem(
16984 OP_LINESEQ, argop,
16985 newOP(opnum,
16986 opnum == OP_WANTARRAY || opnum == OP_RUNCV
16987 ? OPpOFFBYONE << 8 : 0)
16988 );
16989 case OA_BASEOP_OR_UNOP:
16990 if (opnum == OP_ENTEREVAL) {
16991 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
16992 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
16993 }
16994 else o = newUNOP(opnum,0,argop);
16995 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
16996 else {
16997 onearg:
16998 if (is_handle_constructor(o, 1))
16999 argop->op_private |= OPpCOREARGS_DEREF1;
17000 if (scalar_mod_type(NULL, opnum))
17001 argop->op_private |= OPpCOREARGS_SCALARMOD;
17002 }
17003 return o;
17004 default:
17005 o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
17006 if (is_handle_constructor(o, 2))
17007 argop->op_private |= OPpCOREARGS_DEREF2;
17008 if (opnum == OP_SUBSTR) {
17009 o->op_private |= OPpMAYBE_LVSUB;
17010 return o;
17011 }
17012 else goto onearg;
17013 }
17014 }
17015 }
17016
17017 void
Perl_report_redefined_cv(pTHX_ const SV * name,const CV * old_cv,SV * const * new_const_svp)17018 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
17019 SV * const *new_const_svp)
17020 {
17021 const char *hvname;
17022 bool is_const = !!CvCONST(old_cv);
17023 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
17024
17025 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
17026
17027 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
17028 return;
17029 /* They are 2 constant subroutines generated from
17030 the same constant. This probably means that
17031 they are really the "same" proxy subroutine
17032 instantiated in 2 places. Most likely this is
17033 when a constant is exported twice. Don't warn.
17034 */
17035 if (
17036 (ckWARN(WARN_REDEFINE)
17037 && !(
17038 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
17039 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
17040 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
17041 strEQ(hvname, "autouse"))
17042 )
17043 )
17044 || (is_const
17045 && ckWARN_d(WARN_REDEFINE)
17046 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
17047 )
17048 )
17049 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
17050 is_const
17051 ? "Constant subroutine %" SVf " redefined"
17052 : "Subroutine %" SVf " redefined",
17053 SVfARG(name));
17054 }
17055
17056 /*
17057 =head1 Hook manipulation
17058
17059 These functions provide convenient and thread-safe means of manipulating
17060 hook variables.
17061
17062 =cut
17063 */
17064
17065 /*
17066 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
17067
17068 Puts a C function into the chain of check functions for a specified op
17069 type. This is the preferred way to manipulate the L</PL_check> array.
17070 C<opcode> specifies which type of op is to be affected. C<new_checker>
17071 is a pointer to the C function that is to be added to that opcode's
17072 check chain, and C<old_checker_p> points to the storage location where a
17073 pointer to the next function in the chain will be stored. The value of
17074 C<new_checker> is written into the L</PL_check> array, while the value
17075 previously stored there is written to C<*old_checker_p>.
17076
17077 L</PL_check> is global to an entire process, and a module wishing to
17078 hook op checking may find itself invoked more than once per process,
17079 typically in different threads. To handle that situation, this function
17080 is idempotent. The location C<*old_checker_p> must initially (once
17081 per process) contain a null pointer. A C variable of static duration
17082 (declared at file scope, typically also marked C<static> to give
17083 it internal linkage) will be implicitly initialised appropriately,
17084 if it does not have an explicit initialiser. This function will only
17085 actually modify the check chain if it finds C<*old_checker_p> to be null.
17086 This function is also thread safe on the small scale. It uses appropriate
17087 locking to avoid race conditions in accessing L</PL_check>.
17088
17089 When this function is called, the function referenced by C<new_checker>
17090 must be ready to be called, except for C<*old_checker_p> being unfilled.
17091 In a threading situation, C<new_checker> may be called immediately,
17092 even before this function has returned. C<*old_checker_p> will always
17093 be appropriately set before C<new_checker> is called. If C<new_checker>
17094 decides not to do anything special with an op that it is given (which
17095 is the usual case for most uses of op check hooking), it must chain the
17096 check function referenced by C<*old_checker_p>.
17097
17098 Taken all together, XS code to hook an op checker should typically look
17099 something like this:
17100
17101 static Perl_check_t nxck_frob;
17102 static OP *myck_frob(pTHX_ OP *op) {
17103 ...
17104 op = nxck_frob(aTHX_ op);
17105 ...
17106 return op;
17107 }
17108 BOOT:
17109 wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
17110
17111 If you want to influence compilation of calls to a specific subroutine,
17112 then use L</cv_set_call_checker_flags> rather than hooking checking of
17113 all C<entersub> ops.
17114
17115 =cut
17116 */
17117
17118 void
Perl_wrap_op_checker(pTHX_ Optype opcode,Perl_check_t new_checker,Perl_check_t * old_checker_p)17119 Perl_wrap_op_checker(pTHX_ Optype opcode,
17120 Perl_check_t new_checker, Perl_check_t *old_checker_p)
17121 {
17122 dVAR;
17123
17124 PERL_UNUSED_CONTEXT;
17125 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
17126 if (*old_checker_p) return;
17127 OP_CHECK_MUTEX_LOCK;
17128 if (!*old_checker_p) {
17129 *old_checker_p = PL_check[opcode];
17130 PL_check[opcode] = new_checker;
17131 }
17132 OP_CHECK_MUTEX_UNLOCK;
17133 }
17134
17135 #include "XSUB.h"
17136
17137 /* Efficient sub that returns a constant scalar value. */
17138 static void
const_sv_xsub(pTHX_ CV * cv)17139 const_sv_xsub(pTHX_ CV* cv)
17140 {
17141 dXSARGS;
17142 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
17143 PERL_UNUSED_ARG(items);
17144 if (!sv) {
17145 XSRETURN(0);
17146 }
17147 EXTEND(sp, 1);
17148 ST(0) = sv;
17149 XSRETURN(1);
17150 }
17151
17152 static void
const_av_xsub(pTHX_ CV * cv)17153 const_av_xsub(pTHX_ CV* cv)
17154 {
17155 dXSARGS;
17156 AV * const av = MUTABLE_AV(XSANY.any_ptr);
17157 SP -= items;
17158 assert(av);
17159 #ifndef DEBUGGING
17160 if (!av) {
17161 XSRETURN(0);
17162 }
17163 #endif
17164 if (SvRMAGICAL(av))
17165 Perl_croak(aTHX_ "Magical list constants are not supported");
17166 if (GIMME_V != G_ARRAY) {
17167 EXTEND(SP, 1);
17168 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
17169 XSRETURN(1);
17170 }
17171 EXTEND(SP, AvFILLp(av)+1);
17172 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
17173 XSRETURN(AvFILLp(av)+1);
17174 }
17175
17176 /* Copy an existing cop->cop_warnings field.
17177 * If it's one of the standard addresses, just re-use the address.
17178 * This is the e implementation for the DUP_WARNINGS() macro
17179 */
17180
17181 STRLEN*
Perl_dup_warnings(pTHX_ STRLEN * warnings)17182 Perl_dup_warnings(pTHX_ STRLEN* warnings)
17183 {
17184 Size_t size;
17185 STRLEN *new_warnings;
17186
17187 if (warnings == NULL || specialWARN(warnings))
17188 return warnings;
17189
17190 size = sizeof(*warnings) + *warnings;
17191
17192 new_warnings = (STRLEN*)PerlMemShared_malloc(size);
17193 Copy(warnings, new_warnings, size, char);
17194 return new_warnings;
17195 }
17196
17197 /*
17198 * ex: set ts=8 sts=4 sw=4 et:
17199 */
17200