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 #include "invlist_inline.h"
168
169 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
170 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
171 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
172
173 static const char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar";
174
175 /* remove any leading "empty" ops from the op_next chain whose first
176 * node's address is stored in op_p. Store the updated address of the
177 * first node in op_p.
178 */
179
180 STATIC void
S_prune_chain_head(OP ** op_p)181 S_prune_chain_head(OP** op_p)
182 {
183 while (*op_p
184 && ( (*op_p)->op_type == OP_NULL
185 || (*op_p)->op_type == OP_SCOPE
186 || (*op_p)->op_type == OP_SCALAR
187 || (*op_p)->op_type == OP_LINESEQ)
188 )
189 *op_p = (*op_p)->op_next;
190 }
191
192
193 /* See the explanatory comments above struct opslab in op.h. */
194
195 #ifdef PERL_DEBUG_READONLY_OPS
196 # define PERL_SLAB_SIZE 128
197 # define PERL_MAX_SLAB_SIZE 4096
198 # include <sys/mman.h>
199 #endif
200
201 #ifndef PERL_SLAB_SIZE
202 # define PERL_SLAB_SIZE 64
203 #endif
204 #ifndef PERL_MAX_SLAB_SIZE
205 # define PERL_MAX_SLAB_SIZE 2048
206 #endif
207
208 /* rounds up to nearest pointer */
209 #define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
210 #define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
211
212 /* requires double parens and aTHX_ */
213 #define DEBUG_S_warn(args) \
214 DEBUG_S( \
215 PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
216 )
217
218
219 /* malloc a new op slab (suitable for attaching to PL_compcv).
220 * sz is in units of pointers */
221
222 static OPSLAB *
S_new_slab(pTHX_ OPSLAB * head,size_t sz)223 S_new_slab(pTHX_ OPSLAB *head, size_t sz)
224 {
225 OPSLAB *slab;
226
227 /* opslot_offset is only U16 */
228 assert(sz < U16_MAX);
229
230 #ifdef PERL_DEBUG_READONLY_OPS
231 slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
232 PROT_READ|PROT_WRITE,
233 MAP_ANON|MAP_PRIVATE, -1, 0);
234 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
235 (unsigned long) sz, slab));
236 if (slab == MAP_FAILED) {
237 perror("mmap failed");
238 abort();
239 }
240 #else
241 slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
242 #endif
243 slab->opslab_size = (U16)sz;
244
245 #ifndef WIN32
246 /* The context is unused in non-Windows */
247 PERL_UNUSED_CONTEXT;
248 #endif
249 slab->opslab_free_space = sz - DIFF(slab, &slab->opslab_slots);
250 slab->opslab_head = head ? head : slab;
251 DEBUG_S_warn((aTHX_ "allocated new op slab sz 0x%x, %p, head slab %p",
252 (unsigned int)slab->opslab_size, (void*)slab,
253 (void*)(slab->opslab_head)));
254 return slab;
255 }
256
257 /* opslot_size includes the size of the slot header, and an op can't be smaller than BASEOP */
258 #define OPSLOT_SIZE_BASE (SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
259 #define OPSLOT_SIZE_TO_INDEX(sz) ((sz) - OPSLOT_SIZE_BASE)
260
261 #define link_freed_op(slab, o) S_link_freed_op(aTHX_ slab, o)
262 static void
S_link_freed_op(pTHX_ OPSLAB * slab,OP * o)263 S_link_freed_op(pTHX_ OPSLAB *slab, OP *o) {
264 U16 sz = OpSLOT(o)->opslot_size;
265 U16 index = OPSLOT_SIZE_TO_INDEX(sz);
266
267 assert(sz >= OPSLOT_SIZE_BASE);
268 /* make sure the array is large enough to include ops this large */
269 if (!slab->opslab_freed) {
270 /* we don't have a free list array yet, make a new one */
271 slab->opslab_freed_size = index+1;
272 slab->opslab_freed = (OP**)PerlMemShared_calloc((slab->opslab_freed_size), sizeof(OP*));
273
274 if (!slab->opslab_freed)
275 croak_no_mem();
276 }
277 else if (index >= slab->opslab_freed_size) {
278 /* It's probably not worth doing exponential expansion here, the number of op sizes
279 is small.
280 */
281 /* We already have a list that isn't large enough, expand it */
282 size_t newsize = index+1;
283 OP **p = (OP **)PerlMemShared_realloc(slab->opslab_freed, newsize * sizeof(OP*));
284
285 if (!p)
286 croak_no_mem();
287
288 Zero(p+slab->opslab_freed_size, newsize - slab->opslab_freed_size, OP *);
289
290 slab->opslab_freed = p;
291 slab->opslab_freed_size = newsize;
292 }
293
294 o->op_next = slab->opslab_freed[index];
295 slab->opslab_freed[index] = o;
296 }
297
298 /* Returns a sz-sized block of memory (suitable for holding an op) from
299 * a free slot in the chain of op slabs attached to PL_compcv.
300 * Allocates a new slab if necessary.
301 * if PL_compcv isn't compiling, malloc() instead.
302 */
303
304 void *
Perl_Slab_Alloc(pTHX_ size_t sz)305 Perl_Slab_Alloc(pTHX_ size_t sz)
306 {
307 OPSLAB *head_slab; /* first slab in the chain */
308 OPSLAB *slab2;
309 OPSLOT *slot;
310 OP *o;
311 size_t opsz;
312
313 /* We only allocate ops from the slab during subroutine compilation.
314 We find the slab via PL_compcv, hence that must be non-NULL. It could
315 also be pointing to a subroutine which is now fully set up (CvROOT()
316 pointing to the top of the optree for that sub), or a subroutine
317 which isn't using the slab allocator. If our sanity checks aren't met,
318 don't use a slab, but allocate the OP directly from the heap. */
319 if (!PL_compcv || CvROOT(PL_compcv)
320 || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
321 {
322 o = (OP*)PerlMemShared_calloc(1, sz);
323 goto gotit;
324 }
325
326 /* While the subroutine is under construction, the slabs are accessed via
327 CvSTART(), to avoid needing to expand PVCV by one pointer for something
328 unneeded at runtime. Once a subroutine is constructed, the slabs are
329 accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
330 allocated yet. See the commit message for 8be227ab5eaa23f2 for more
331 details. */
332 if (!CvSTART(PL_compcv)) {
333 CvSTART(PL_compcv) =
334 (OP *)(head_slab = S_new_slab(aTHX_ NULL, PERL_SLAB_SIZE));
335 CvSLABBED_on(PL_compcv);
336 head_slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
337 }
338 else ++(head_slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
339
340 opsz = SIZE_TO_PSIZE(sz);
341 sz = opsz + OPSLOT_HEADER_P;
342
343 /* The head slab for each CV maintains a free list of OPs. In particular, constant folding
344 will free up OPs, so it makes sense to re-use them where possible. A
345 freed up slot is used in preference to a new allocation. */
346 if (head_slab->opslab_freed &&
347 OPSLOT_SIZE_TO_INDEX(sz) < head_slab->opslab_freed_size) {
348 U16 base_index;
349
350 /* look for a large enough size with any freed ops */
351 for (base_index = OPSLOT_SIZE_TO_INDEX(sz);
352 base_index < head_slab->opslab_freed_size && !head_slab->opslab_freed[base_index];
353 ++base_index) {
354 }
355
356 if (base_index < head_slab->opslab_freed_size) {
357 /* found a freed op */
358 o = head_slab->opslab_freed[base_index];
359
360 DEBUG_S_warn((aTHX_ "realloced op at %p, slab %p, head slab %p",
361 (void*)o,
362 (I32**)OpSLOT(o) - OpSLOT(o)->opslot_offset,
363 (void*)head_slab));
364 head_slab->opslab_freed[base_index] = o->op_next;
365 Zero(o, opsz, I32 *);
366 o->op_slabbed = 1;
367 goto gotit;
368 }
369 }
370
371 #define INIT_OPSLOT(s) \
372 slot->opslot_offset = DIFF(slab2, slot) ; \
373 slot->opslot_size = s; \
374 slab2->opslab_free_space -= s; \
375 o = &slot->opslot_op; \
376 o->op_slabbed = 1
377
378 /* The partially-filled slab is next in the chain. */
379 slab2 = head_slab->opslab_next ? head_slab->opslab_next : head_slab;
380 if (slab2->opslab_free_space < sz) {
381 /* Remaining space is too small. */
382 /* If we can fit a BASEOP, add it to the free chain, so as not
383 to waste it. */
384 if (slab2->opslab_free_space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
385 slot = &slab2->opslab_slots;
386 INIT_OPSLOT(slab2->opslab_free_space);
387 o->op_type = OP_FREED;
388 link_freed_op(head_slab, o);
389 }
390
391 /* Create a new slab. Make this one twice as big. */
392 slab2 = S_new_slab(aTHX_ head_slab,
393 slab2->opslab_size > PERL_MAX_SLAB_SIZE / 2
394 ? PERL_MAX_SLAB_SIZE
395 : slab2->opslab_size * 2);
396 slab2->opslab_next = head_slab->opslab_next;
397 head_slab->opslab_next = slab2;
398 }
399 assert(slab2->opslab_size >= sz);
400
401 /* Create a new op slot */
402 slot = (OPSLOT *)
403 ((I32 **)&slab2->opslab_slots
404 + slab2->opslab_free_space - sz);
405 assert(slot >= &slab2->opslab_slots);
406 INIT_OPSLOT(sz);
407 DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p, head slab %p",
408 (void*)o, (void*)slab2, (void*)head_slab));
409
410 gotit:
411 /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
412 assert(!o->op_moresib);
413 assert(!o->op_sibparent);
414
415 return (void *)o;
416 }
417
418 #undef INIT_OPSLOT
419
420 #ifdef PERL_DEBUG_READONLY_OPS
421 void
Perl_Slab_to_ro(pTHX_ OPSLAB * slab)422 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
423 {
424 PERL_ARGS_ASSERT_SLAB_TO_RO;
425
426 if (slab->opslab_readonly) return;
427 slab->opslab_readonly = 1;
428 for (; slab; slab = slab->opslab_next) {
429 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
430 (unsigned long) slab->opslab_size, slab));*/
431 if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
432 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
433 (unsigned long)slab->opslab_size, errno);
434 }
435 }
436
437 void
Perl_Slab_to_rw(pTHX_ OPSLAB * const slab)438 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
439 {
440 OPSLAB *slab2;
441
442 PERL_ARGS_ASSERT_SLAB_TO_RW;
443
444 if (!slab->opslab_readonly) return;
445 slab2 = slab;
446 for (; slab2; slab2 = slab2->opslab_next) {
447 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
448 (unsigned long) size, slab2));*/
449 if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
450 PROT_READ|PROT_WRITE)) {
451 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
452 (unsigned long)slab2->opslab_size, errno);
453 }
454 }
455 slab->opslab_readonly = 0;
456 }
457
458 #else
459 # define Slab_to_rw(op) NOOP
460 #endif
461
462 /* This cannot possibly be right, but it was copied from the old slab
463 allocator, to which it was originally added, without explanation, in
464 commit 083fcd5. */
465 #ifdef NETWARE
466 # define PerlMemShared PerlMem
467 #endif
468
469 /* make freed ops die if they're inadvertently executed */
470 #ifdef DEBUGGING
471 static OP *
S_pp_freed(pTHX)472 S_pp_freed(pTHX)
473 {
474 DIE(aTHX_ "panic: freed op 0x%p called\n", PL_op);
475 }
476 #endif
477
478
479 /* Return the block of memory used by an op to the free list of
480 * the OP slab associated with that op.
481 */
482
483 void
Perl_Slab_Free(pTHX_ void * op)484 Perl_Slab_Free(pTHX_ void *op)
485 {
486 OP * const o = (OP *)op;
487 OPSLAB *slab;
488
489 PERL_ARGS_ASSERT_SLAB_FREE;
490
491 #ifdef DEBUGGING
492 o->op_ppaddr = S_pp_freed;
493 #endif
494
495 if (!o->op_slabbed) {
496 if (!o->op_static)
497 PerlMemShared_free(op);
498 return;
499 }
500
501 slab = OpSLAB(o);
502 /* If this op is already freed, our refcount will get screwy. */
503 assert(o->op_type != OP_FREED);
504 o->op_type = OP_FREED;
505 link_freed_op(slab, o);
506 DEBUG_S_warn((aTHX_ "freeing op at %p, slab %p, head slab %p",
507 (void*)o,
508 (I32**)OpSLOT(o) - OpSLOT(o)->opslot_offset,
509 (void*)slab));
510 OpslabREFCNT_dec_padok(slab);
511 }
512
513 void
Perl_opslab_free_nopad(pTHX_ OPSLAB * slab)514 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
515 {
516 const bool havepad = !!PL_comppad;
517 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
518 if (havepad) {
519 ENTER;
520 PAD_SAVE_SETNULLPAD();
521 }
522 opslab_free(slab);
523 if (havepad) LEAVE;
524 }
525
526 /* Free a chain of OP slabs. Should only be called after all ops contained
527 * in it have been freed. At this point, its reference count should be 1,
528 * because OpslabREFCNT_dec() skips doing rc-- when it detects that rc == 1,
529 * and just directly calls opslab_free().
530 * (Note that the reference count which PL_compcv held on the slab should
531 * have been removed once compilation of the sub was complete).
532 *
533 *
534 */
535
536 void
Perl_opslab_free(pTHX_ OPSLAB * slab)537 Perl_opslab_free(pTHX_ OPSLAB *slab)
538 {
539 OPSLAB *slab2;
540 PERL_ARGS_ASSERT_OPSLAB_FREE;
541 PERL_UNUSED_CONTEXT;
542 DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
543 assert(slab->opslab_refcnt == 1);
544 PerlMemShared_free(slab->opslab_freed);
545 do {
546 slab2 = slab->opslab_next;
547 #ifdef DEBUGGING
548 slab->opslab_refcnt = ~(size_t)0;
549 #endif
550 #ifdef PERL_DEBUG_READONLY_OPS
551 DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
552 (void*)slab));
553 if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
554 perror("munmap failed");
555 abort();
556 }
557 #else
558 PerlMemShared_free(slab);
559 #endif
560 slab = slab2;
561 } while (slab);
562 }
563
564 /* like opslab_free(), but first calls op_free() on any ops in the slab
565 * not marked as OP_FREED
566 */
567
568 void
Perl_opslab_force_free(pTHX_ OPSLAB * slab)569 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
570 {
571 OPSLAB *slab2;
572 #ifdef DEBUGGING
573 size_t savestack_count = 0;
574 #endif
575 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
576 slab2 = slab;
577 do {
578 OPSLOT *slot = (OPSLOT*)
579 ((I32**)&slab2->opslab_slots + slab2->opslab_free_space);
580 OPSLOT *end = (OPSLOT*)
581 ((I32**)slab2 + slab2->opslab_size);
582 for (; slot < end;
583 slot = (OPSLOT*) ((I32**)slot + slot->opslot_size) )
584 {
585 if (slot->opslot_op.op_type != OP_FREED
586 && !(slot->opslot_op.op_savefree
587 #ifdef DEBUGGING
588 && ++savestack_count
589 #endif
590 )
591 ) {
592 assert(slot->opslot_op.op_slabbed);
593 op_free(&slot->opslot_op);
594 if (slab->opslab_refcnt == 1) goto free;
595 }
596 }
597 } while ((slab2 = slab2->opslab_next));
598 /* > 1 because the CV still holds a reference count. */
599 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
600 #ifdef DEBUGGING
601 assert(savestack_count == slab->opslab_refcnt-1);
602 #endif
603 /* Remove the CV’s reference count. */
604 slab->opslab_refcnt--;
605 return;
606 }
607 free:
608 opslab_free(slab);
609 }
610
611 #ifdef PERL_DEBUG_READONLY_OPS
612 OP *
Perl_op_refcnt_inc(pTHX_ OP * o)613 Perl_op_refcnt_inc(pTHX_ OP *o)
614 {
615 if(o) {
616 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
617 if (slab && slab->opslab_readonly) {
618 Slab_to_rw(slab);
619 ++o->op_targ;
620 Slab_to_ro(slab);
621 } else {
622 ++o->op_targ;
623 }
624 }
625 return o;
626
627 }
628
629 PADOFFSET
Perl_op_refcnt_dec(pTHX_ OP * o)630 Perl_op_refcnt_dec(pTHX_ OP *o)
631 {
632 PADOFFSET result;
633 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
634
635 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
636
637 if (slab && slab->opslab_readonly) {
638 Slab_to_rw(slab);
639 result = --o->op_targ;
640 Slab_to_ro(slab);
641 } else {
642 result = --o->op_targ;
643 }
644 return result;
645 }
646 #endif
647 /*
648 * In the following definition, the ", (OP*)0" is just to make the compiler
649 * think the expression is of the right type: croak actually does a Siglongjmp.
650 */
651 #define CHECKOP(type,o) \
652 ((PL_op_mask && PL_op_mask[type]) \
653 ? ( op_free((OP*)o), \
654 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
655 (OP*)0 ) \
656 : PL_check[type](aTHX_ (OP*)o))
657
658 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
659
660 #define OpTYPE_set(o,type) \
661 STMT_START { \
662 o->op_type = (OPCODE)type; \
663 o->op_ppaddr = PL_ppaddr[type]; \
664 } STMT_END
665
666 STATIC OP *
S_no_fh_allowed(pTHX_ OP * o)667 S_no_fh_allowed(pTHX_ OP *o)
668 {
669 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
670
671 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
672 OP_DESC(o)));
673 return o;
674 }
675
676 STATIC OP *
S_too_few_arguments_pv(pTHX_ OP * o,const char * name,U32 flags)677 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
678 {
679 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
680 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
681 return o;
682 }
683
684 STATIC OP *
S_too_many_arguments_pv(pTHX_ OP * o,const char * name,U32 flags)685 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
686 {
687 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
688
689 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
690 return o;
691 }
692
693 STATIC void
S_bad_type_pv(pTHX_ I32 n,const char * t,const OP * o,const OP * kid)694 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
695 {
696 PERL_ARGS_ASSERT_BAD_TYPE_PV;
697
698 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
699 (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
700 }
701
702 STATIC void
S_bad_type_gv(pTHX_ I32 n,GV * gv,const OP * kid,const char * t)703 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
704 {
705 SV * const namesv = cv_name((CV *)gv, NULL, 0);
706 PERL_ARGS_ASSERT_BAD_TYPE_GV;
707
708 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)",
709 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
710 }
711
712 STATIC void
S_no_bareword_allowed(pTHX_ OP * o)713 S_no_bareword_allowed(pTHX_ OP *o)
714 {
715 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
716
717 qerror(Perl_mess(aTHX_
718 "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use",
719 SVfARG(cSVOPo_sv)));
720 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
721 }
722
723 /* "register" allocation */
724
725 PADOFFSET
Perl_allocmy(pTHX_ const char * const name,const STRLEN len,const U32 flags)726 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
727 {
728 PADOFFSET off;
729 const bool is_our = (PL_parser->in_my == KEY_our);
730
731 PERL_ARGS_ASSERT_ALLOCMY;
732
733 if (flags & ~SVf_UTF8)
734 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
735 (UV)flags);
736
737 /* complain about "my $<special_var>" etc etc */
738 if ( len
739 && !( is_our
740 || isALPHA(name[1])
741 || ( (flags & SVf_UTF8)
742 && isIDFIRST_utf8_safe((U8 *)name+1, name + len))
743 || (name[1] == '_' && len > 2)))
744 {
745 const char * const type =
746 PL_parser->in_my == KEY_sigvar ? "subroutine signature" :
747 PL_parser->in_my == KEY_state ? "\"state\"" : "\"my\"";
748
749 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
750 && isASCII(name[1])
751 && (!isPRINT(name[1]) || memCHRs("\t\n\r\f", name[1]))) {
752 /* diag_listed_as: Can't use global %s in %s */
753 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in %s",
754 name[0], toCTRL(name[1]),
755 (int)(len - 2), name + 2,
756 type));
757 } else {
758 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in %s",
759 (int) len, name,
760 type), flags & SVf_UTF8);
761 }
762 }
763
764 /* allocate a spare slot and store the name in that slot */
765
766 off = pad_add_name_pvn(name, len,
767 (is_our ? padadd_OUR :
768 PL_parser->in_my == KEY_state ? padadd_STATE : 0),
769 PL_parser->in_my_stash,
770 (is_our
771 /* $_ is always in main::, even with our */
772 ? (PL_curstash && !memEQs(name,len,"$_")
773 ? PL_curstash
774 : PL_defstash)
775 : NULL
776 )
777 );
778 /* anon sub prototypes contains state vars should always be cloned,
779 * otherwise the state var would be shared between anon subs */
780
781 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
782 CvCLONE_on(PL_compcv);
783
784 return off;
785 }
786
787 /*
788 =head1 Optree Manipulation Functions
789
790 =for apidoc alloccopstash
791
792 Available only under threaded builds, this function allocates an entry in
793 C<PL_stashpad> for the stash passed to it.
794
795 =cut
796 */
797
798 #ifdef USE_ITHREADS
799 PADOFFSET
Perl_alloccopstash(pTHX_ HV * hv)800 Perl_alloccopstash(pTHX_ HV *hv)
801 {
802 PADOFFSET off = 0, o = 1;
803 bool found_slot = FALSE;
804
805 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
806
807 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
808
809 for (; o < PL_stashpadmax; ++o) {
810 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
811 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
812 found_slot = TRUE, off = o;
813 }
814 if (!found_slot) {
815 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
816 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
817 off = PL_stashpadmax;
818 PL_stashpadmax += 10;
819 }
820
821 PL_stashpad[PL_stashpadix = off] = hv;
822 return off;
823 }
824 #endif
825
826 /* free the body of an op without examining its contents.
827 * Always use this rather than FreeOp directly */
828
829 static void
S_op_destroy(pTHX_ OP * o)830 S_op_destroy(pTHX_ OP *o)
831 {
832 FreeOp(o);
833 }
834
835 /* Destructor */
836
837 /*
838 =for apidoc op_free
839
840 Free an op and its children. Only use this when an op is no longer linked
841 to from any optree.
842
843 =cut
844 */
845
846 void
Perl_op_free(pTHX_ OP * o)847 Perl_op_free(pTHX_ OP *o)
848 {
849 dVAR;
850 OPCODE type;
851 OP *top_op = o;
852 OP *next_op = o;
853 bool went_up = FALSE; /* whether we reached the current node by
854 following the parent pointer from a child, and
855 so have already seen this node */
856
857 if (!o || o->op_type == OP_FREED)
858 return;
859
860 if (o->op_private & OPpREFCOUNTED) {
861 /* if base of tree is refcounted, just decrement */
862 switch (o->op_type) {
863 case OP_LEAVESUB:
864 case OP_LEAVESUBLV:
865 case OP_LEAVEEVAL:
866 case OP_LEAVE:
867 case OP_SCOPE:
868 case OP_LEAVEWRITE:
869 {
870 PADOFFSET refcnt;
871 OP_REFCNT_LOCK;
872 refcnt = OpREFCNT_dec(o);
873 OP_REFCNT_UNLOCK;
874 if (refcnt) {
875 /* Need to find and remove any pattern match ops from
876 * the list we maintain for reset(). */
877 find_and_forget_pmops(o);
878 return;
879 }
880 }
881 break;
882 default:
883 break;
884 }
885 }
886
887 while (next_op) {
888 o = next_op;
889
890 /* free child ops before ourself, (then free ourself "on the
891 * way back up") */
892
893 if (!went_up && o->op_flags & OPf_KIDS) {
894 next_op = cUNOPo->op_first;
895 continue;
896 }
897
898 /* find the next node to visit, *then* free the current node
899 * (can't rely on o->op_* fields being valid after o has been
900 * freed) */
901
902 /* The next node to visit will be either the sibling, or the
903 * parent if no siblings left, or NULL if we've worked our way
904 * back up to the top node in the tree */
905 next_op = (o == top_op) ? NULL : o->op_sibparent;
906 went_up = cBOOL(!OpHAS_SIBLING(o)); /* parents are already visited */
907
908 /* Now process the current node */
909
910 /* Though ops may be freed twice, freeing the op after its slab is a
911 big no-no. */
912 assert(!o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
913 /* During the forced freeing of ops after compilation failure, kidops
914 may be freed before their parents. */
915 if (!o || o->op_type == OP_FREED)
916 continue;
917
918 type = o->op_type;
919
920 /* an op should only ever acquire op_private flags that we know about.
921 * If this fails, you may need to fix something in regen/op_private.
922 * Don't bother testing if:
923 * * the op_ppaddr doesn't match the op; someone may have
924 * overridden the op and be doing strange things with it;
925 * * we've errored, as op flags are often left in an
926 * inconsistent state then. Note that an error when
927 * compiling the main program leaves PL_parser NULL, so
928 * we can't spot faults in the main code, only
929 * evaled/required code */
930 #ifdef DEBUGGING
931 if ( o->op_ppaddr == PL_ppaddr[type]
932 && PL_parser
933 && !PL_parser->error_count)
934 {
935 assert(!(o->op_private & ~PL_op_private_valid[type]));
936 }
937 #endif
938
939
940 /* Call the op_free hook if it has been set. Do it now so that it's called
941 * at the right time for refcounted ops, but still before all of the kids
942 * are freed. */
943 CALL_OPFREEHOOK(o);
944
945 if (type == OP_NULL)
946 type = (OPCODE)o->op_targ;
947
948 if (o->op_slabbed)
949 Slab_to_rw(OpSLAB(o));
950
951 /* COP* is not cleared by op_clear() so that we may track line
952 * numbers etc even after null() */
953 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
954 cop_free((COP*)o);
955 }
956
957 op_clear(o);
958 FreeOp(o);
959 if (PL_op == o)
960 PL_op = NULL;
961 }
962 }
963
964
965 /* S_op_clear_gv(): free a GV attached to an OP */
966
967 STATIC
968 #ifdef USE_ITHREADS
S_op_clear_gv(pTHX_ OP * o,PADOFFSET * ixp)969 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
970 #else
971 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
972 #endif
973 {
974
975 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
976 || o->op_type == OP_MULTIDEREF)
977 #ifdef USE_ITHREADS
978 && PL_curpad
979 ? ((GV*)PAD_SVl(*ixp)) : NULL;
980 #else
981 ? (GV*)(*svp) : NULL;
982 #endif
983 /* It's possible during global destruction that the GV is freed
984 before the optree. Whilst the SvREFCNT_inc is happy to bump from
985 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
986 will trigger an assertion failure, because the entry to sv_clear
987 checks that the scalar is not already freed. A check of for
988 !SvIS_FREED(gv) turns out to be invalid, because during global
989 destruction the reference count can be forced down to zero
990 (with SVf_BREAK set). In which case raising to 1 and then
991 dropping to 0 triggers cleanup before it should happen. I
992 *think* that this might actually be a general, systematic,
993 weakness of the whole idea of SVf_BREAK, in that code *is*
994 allowed to raise and lower references during global destruction,
995 so any *valid* code that happens to do this during global
996 destruction might well trigger premature cleanup. */
997 bool still_valid = gv && SvREFCNT(gv);
998
999 if (still_valid)
1000 SvREFCNT_inc_simple_void(gv);
1001 #ifdef USE_ITHREADS
1002 if (*ixp > 0) {
1003 pad_swipe(*ixp, TRUE);
1004 *ixp = 0;
1005 }
1006 #else
1007 SvREFCNT_dec(*svp);
1008 *svp = NULL;
1009 #endif
1010 if (still_valid) {
1011 int try_downgrade = SvREFCNT(gv) == 2;
1012 SvREFCNT_dec_NN(gv);
1013 if (try_downgrade)
1014 gv_try_downgrade(gv);
1015 }
1016 }
1017
1018
1019 void
Perl_op_clear(pTHX_ OP * o)1020 Perl_op_clear(pTHX_ OP *o)
1021 {
1022
1023 dVAR;
1024
1025 PERL_ARGS_ASSERT_OP_CLEAR;
1026
1027 switch (o->op_type) {
1028 case OP_NULL: /* Was holding old type, if any. */
1029 /* FALLTHROUGH */
1030 case OP_ENTERTRY:
1031 case OP_ENTEREVAL: /* Was holding hints. */
1032 case OP_ARGDEFELEM: /* Was holding signature index. */
1033 o->op_targ = 0;
1034 break;
1035 default:
1036 if (!(o->op_flags & OPf_REF) || !OP_IS_STAT(o->op_type))
1037 break;
1038 /* FALLTHROUGH */
1039 case OP_GVSV:
1040 case OP_GV:
1041 case OP_AELEMFAST:
1042 #ifdef USE_ITHREADS
1043 S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
1044 #else
1045 S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
1046 #endif
1047 break;
1048 case OP_METHOD_REDIR:
1049 case OP_METHOD_REDIR_SUPER:
1050 #ifdef USE_ITHREADS
1051 if (cMETHOPx(o)->op_rclass_targ) {
1052 pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
1053 cMETHOPx(o)->op_rclass_targ = 0;
1054 }
1055 #else
1056 SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
1057 cMETHOPx(o)->op_rclass_sv = NULL;
1058 #endif
1059 /* FALLTHROUGH */
1060 case OP_METHOD_NAMED:
1061 case OP_METHOD_SUPER:
1062 SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
1063 cMETHOPx(o)->op_u.op_meth_sv = NULL;
1064 #ifdef USE_ITHREADS
1065 if (o->op_targ) {
1066 pad_swipe(o->op_targ, 1);
1067 o->op_targ = 0;
1068 }
1069 #endif
1070 break;
1071 case OP_CONST:
1072 case OP_HINTSEVAL:
1073 SvREFCNT_dec(cSVOPo->op_sv);
1074 cSVOPo->op_sv = NULL;
1075 #ifdef USE_ITHREADS
1076 /** Bug #15654
1077 Even if op_clear does a pad_free for the target of the op,
1078 pad_free doesn't actually remove the sv that exists in the pad;
1079 instead it lives on. This results in that it could be reused as
1080 a target later on when the pad was reallocated.
1081 **/
1082 if(o->op_targ) {
1083 pad_swipe(o->op_targ,1);
1084 o->op_targ = 0;
1085 }
1086 #endif
1087 break;
1088 case OP_DUMP:
1089 case OP_GOTO:
1090 case OP_NEXT:
1091 case OP_LAST:
1092 case OP_REDO:
1093 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1094 break;
1095 /* FALLTHROUGH */
1096 case OP_TRANS:
1097 case OP_TRANSR:
1098 if ( (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
1099 && (o->op_private & OPpTRANS_USE_SVOP))
1100 {
1101 #ifdef USE_ITHREADS
1102 if (cPADOPo->op_padix > 0) {
1103 pad_swipe(cPADOPo->op_padix, TRUE);
1104 cPADOPo->op_padix = 0;
1105 }
1106 #else
1107 SvREFCNT_dec(cSVOPo->op_sv);
1108 cSVOPo->op_sv = NULL;
1109 #endif
1110 }
1111 else {
1112 PerlMemShared_free(cPVOPo->op_pv);
1113 cPVOPo->op_pv = NULL;
1114 }
1115 break;
1116 case OP_SUBST:
1117 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1118 goto clear_pmop;
1119
1120 case OP_SPLIT:
1121 if ( (o->op_private & OPpSPLIT_ASSIGN) /* @array = split */
1122 && !(o->op_flags & OPf_STACKED)) /* @{expr} = split */
1123 {
1124 if (o->op_private & OPpSPLIT_LEX)
1125 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1126 else
1127 #ifdef USE_ITHREADS
1128 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1129 #else
1130 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1131 #endif
1132 }
1133 /* FALLTHROUGH */
1134 case OP_MATCH:
1135 case OP_QR:
1136 clear_pmop:
1137 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1138 op_free(cPMOPo->op_code_list);
1139 cPMOPo->op_code_list = NULL;
1140 forget_pmop(cPMOPo);
1141 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1142 /* we use the same protection as the "SAFE" version of the PM_ macros
1143 * here since sv_clean_all might release some PMOPs
1144 * after PL_regex_padav has been cleared
1145 * and the clearing of PL_regex_padav needs to
1146 * happen before sv_clean_all
1147 */
1148 #ifdef USE_ITHREADS
1149 if(PL_regex_pad) { /* We could be in destruction */
1150 const IV offset = (cPMOPo)->op_pmoffset;
1151 ReREFCNT_dec(PM_GETRE(cPMOPo));
1152 PL_regex_pad[offset] = &PL_sv_undef;
1153 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1154 sizeof(offset));
1155 }
1156 #else
1157 ReREFCNT_dec(PM_GETRE(cPMOPo));
1158 PM_SETRE(cPMOPo, NULL);
1159 #endif
1160
1161 break;
1162
1163 case OP_ARGCHECK:
1164 PerlMemShared_free(cUNOP_AUXo->op_aux);
1165 break;
1166
1167 case OP_MULTICONCAT:
1168 {
1169 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
1170 /* aux[PERL_MULTICONCAT_IX_PLAIN_PV] and/or
1171 * aux[PERL_MULTICONCAT_IX_UTF8_PV] point to plain and/or
1172 * utf8 shared strings */
1173 char *p1 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
1174 char *p2 = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
1175 if (p1)
1176 PerlMemShared_free(p1);
1177 if (p2 && p1 != p2)
1178 PerlMemShared_free(p2);
1179 PerlMemShared_free(aux);
1180 }
1181 break;
1182
1183 case OP_MULTIDEREF:
1184 {
1185 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1186 UV actions = items->uv;
1187 bool last = 0;
1188 bool is_hash = FALSE;
1189
1190 while (!last) {
1191 switch (actions & MDEREF_ACTION_MASK) {
1192
1193 case MDEREF_reload:
1194 actions = (++items)->uv;
1195 continue;
1196
1197 case MDEREF_HV_padhv_helem:
1198 is_hash = TRUE;
1199 /* FALLTHROUGH */
1200 case MDEREF_AV_padav_aelem:
1201 pad_free((++items)->pad_offset);
1202 goto do_elem;
1203
1204 case MDEREF_HV_gvhv_helem:
1205 is_hash = TRUE;
1206 /* FALLTHROUGH */
1207 case MDEREF_AV_gvav_aelem:
1208 #ifdef USE_ITHREADS
1209 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1210 #else
1211 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1212 #endif
1213 goto do_elem;
1214
1215 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1216 is_hash = TRUE;
1217 /* FALLTHROUGH */
1218 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1219 #ifdef USE_ITHREADS
1220 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1221 #else
1222 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1223 #endif
1224 goto do_vivify_rv2xv_elem;
1225
1226 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1227 is_hash = TRUE;
1228 /* FALLTHROUGH */
1229 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1230 pad_free((++items)->pad_offset);
1231 goto do_vivify_rv2xv_elem;
1232
1233 case MDEREF_HV_pop_rv2hv_helem:
1234 case MDEREF_HV_vivify_rv2hv_helem:
1235 is_hash = TRUE;
1236 /* FALLTHROUGH */
1237 do_vivify_rv2xv_elem:
1238 case MDEREF_AV_pop_rv2av_aelem:
1239 case MDEREF_AV_vivify_rv2av_aelem:
1240 do_elem:
1241 switch (actions & MDEREF_INDEX_MASK) {
1242 case MDEREF_INDEX_none:
1243 last = 1;
1244 break;
1245 case MDEREF_INDEX_const:
1246 if (is_hash) {
1247 #ifdef USE_ITHREADS
1248 /* see RT #15654 */
1249 pad_swipe((++items)->pad_offset, 1);
1250 #else
1251 SvREFCNT_dec((++items)->sv);
1252 #endif
1253 }
1254 else
1255 items++;
1256 break;
1257 case MDEREF_INDEX_padsv:
1258 pad_free((++items)->pad_offset);
1259 break;
1260 case MDEREF_INDEX_gvsv:
1261 #ifdef USE_ITHREADS
1262 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1263 #else
1264 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1265 #endif
1266 break;
1267 }
1268
1269 if (actions & MDEREF_FLAG_last)
1270 last = 1;
1271 is_hash = FALSE;
1272
1273 break;
1274
1275 default:
1276 assert(0);
1277 last = 1;
1278 break;
1279
1280 } /* switch */
1281
1282 actions >>= MDEREF_SHIFT;
1283 } /* while */
1284
1285 /* start of malloc is at op_aux[-1], where the length is
1286 * stored */
1287 PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1288 }
1289 break;
1290 }
1291
1292 if (o->op_targ > 0) {
1293 pad_free(o->op_targ);
1294 o->op_targ = 0;
1295 }
1296 }
1297
1298 STATIC void
S_cop_free(pTHX_ COP * cop)1299 S_cop_free(pTHX_ COP* cop)
1300 {
1301 PERL_ARGS_ASSERT_COP_FREE;
1302
1303 CopFILE_free(cop);
1304 if (! specialWARN(cop->cop_warnings))
1305 PerlMemShared_free(cop->cop_warnings);
1306 cophh_free(CopHINTHASH_get(cop));
1307 if (PL_curcop == cop)
1308 PL_curcop = NULL;
1309 }
1310
1311 STATIC void
S_forget_pmop(pTHX_ PMOP * const o)1312 S_forget_pmop(pTHX_ PMOP *const o)
1313 {
1314 HV * const pmstash = PmopSTASH(o);
1315
1316 PERL_ARGS_ASSERT_FORGET_PMOP;
1317
1318 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1319 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1320 if (mg) {
1321 PMOP **const array = (PMOP**) mg->mg_ptr;
1322 U32 count = mg->mg_len / sizeof(PMOP**);
1323 U32 i = count;
1324
1325 while (i--) {
1326 if (array[i] == o) {
1327 /* Found it. Move the entry at the end to overwrite it. */
1328 array[i] = array[--count];
1329 mg->mg_len = count * sizeof(PMOP**);
1330 /* Could realloc smaller at this point always, but probably
1331 not worth it. Probably worth free()ing if we're the
1332 last. */
1333 if(!count) {
1334 Safefree(mg->mg_ptr);
1335 mg->mg_ptr = NULL;
1336 }
1337 break;
1338 }
1339 }
1340 }
1341 }
1342 if (PL_curpm == o)
1343 PL_curpm = NULL;
1344 }
1345
1346
1347 STATIC void
S_find_and_forget_pmops(pTHX_ OP * o)1348 S_find_and_forget_pmops(pTHX_ OP *o)
1349 {
1350 OP* top_op = o;
1351
1352 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1353
1354 while (1) {
1355 switch (o->op_type) {
1356 case OP_SUBST:
1357 case OP_SPLIT:
1358 case OP_MATCH:
1359 case OP_QR:
1360 forget_pmop((PMOP*)o);
1361 }
1362
1363 if (o->op_flags & OPf_KIDS) {
1364 o = cUNOPo->op_first;
1365 continue;
1366 }
1367
1368 while (1) {
1369 if (o == top_op)
1370 return; /* at top; no parents/siblings to try */
1371 if (OpHAS_SIBLING(o)) {
1372 o = o->op_sibparent; /* process next sibling */
1373 break;
1374 }
1375 o = o->op_sibparent; /*try parent's next sibling */
1376 }
1377 }
1378 }
1379
1380
1381 /*
1382 =for apidoc op_null
1383
1384 Neutralizes an op when it is no longer needed, but is still linked to from
1385 other ops.
1386
1387 =cut
1388 */
1389
1390 void
Perl_op_null(pTHX_ OP * o)1391 Perl_op_null(pTHX_ OP *o)
1392 {
1393 dVAR;
1394
1395 PERL_ARGS_ASSERT_OP_NULL;
1396
1397 if (o->op_type == OP_NULL)
1398 return;
1399 op_clear(o);
1400 o->op_targ = o->op_type;
1401 OpTYPE_set(o, OP_NULL);
1402 }
1403
1404 void
Perl_op_refcnt_lock(pTHX)1405 Perl_op_refcnt_lock(pTHX)
1406 PERL_TSA_ACQUIRE(PL_op_mutex)
1407 {
1408 #ifdef USE_ITHREADS
1409 dVAR;
1410 #endif
1411 PERL_UNUSED_CONTEXT;
1412 OP_REFCNT_LOCK;
1413 }
1414
1415 void
Perl_op_refcnt_unlock(pTHX)1416 Perl_op_refcnt_unlock(pTHX)
1417 PERL_TSA_RELEASE(PL_op_mutex)
1418 {
1419 #ifdef USE_ITHREADS
1420 dVAR;
1421 #endif
1422 PERL_UNUSED_CONTEXT;
1423 OP_REFCNT_UNLOCK;
1424 }
1425
1426
1427 /*
1428 =for apidoc op_sibling_splice
1429
1430 A general function for editing the structure of an existing chain of
1431 op_sibling nodes. By analogy with the perl-level C<splice()> function, allows
1432 you to delete zero or more sequential nodes, replacing them with zero or
1433 more different nodes. Performs the necessary op_first/op_last
1434 housekeeping on the parent node and op_sibling manipulation on the
1435 children. The last deleted node will be marked as the last node by
1436 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1437
1438 Note that op_next is not manipulated, and nodes are not freed; that is the
1439 responsibility of the caller. It also won't create a new list op for an
1440 empty list etc; use higher-level functions like op_append_elem() for that.
1441
1442 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1443 the splicing doesn't affect the first or last op in the chain.
1444
1445 C<start> is the node preceding the first node to be spliced. Node(s)
1446 following it will be deleted, and ops will be inserted after it. If it is
1447 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1448 beginning.
1449
1450 C<del_count> is the number of nodes to delete. If zero, no nodes are deleted.
1451 If -1 or greater than or equal to the number of remaining kids, all
1452 remaining kids are deleted.
1453
1454 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1455 If C<NULL>, no nodes are inserted.
1456
1457 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1458 deleted.
1459
1460 For example:
1461
1462 action before after returns
1463 ------ ----- ----- -------
1464
1465 P P
1466 splice(P, A, 2, X-Y-Z) | | B-C
1467 A-B-C-D A-X-Y-Z-D
1468
1469 P P
1470 splice(P, NULL, 1, X-Y) | | A
1471 A-B-C-D X-Y-B-C-D
1472
1473 P P
1474 splice(P, NULL, 3, NULL) | | A-B-C
1475 A-B-C-D D
1476
1477 P P
1478 splice(P, B, 0, X-Y) | | NULL
1479 A-B-C-D A-B-X-Y-C-D
1480
1481
1482 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1483 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1484
1485 =cut
1486 */
1487
1488 OP *
Perl_op_sibling_splice(OP * parent,OP * start,int del_count,OP * insert)1489 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1490 {
1491 OP *first;
1492 OP *rest;
1493 OP *last_del = NULL;
1494 OP *last_ins = NULL;
1495
1496 if (start)
1497 first = OpSIBLING(start);
1498 else if (!parent)
1499 goto no_parent;
1500 else
1501 first = cLISTOPx(parent)->op_first;
1502
1503 assert(del_count >= -1);
1504
1505 if (del_count && first) {
1506 last_del = first;
1507 while (--del_count && OpHAS_SIBLING(last_del))
1508 last_del = OpSIBLING(last_del);
1509 rest = OpSIBLING(last_del);
1510 OpLASTSIB_set(last_del, NULL);
1511 }
1512 else
1513 rest = first;
1514
1515 if (insert) {
1516 last_ins = insert;
1517 while (OpHAS_SIBLING(last_ins))
1518 last_ins = OpSIBLING(last_ins);
1519 OpMAYBESIB_set(last_ins, rest, NULL);
1520 }
1521 else
1522 insert = rest;
1523
1524 if (start) {
1525 OpMAYBESIB_set(start, insert, NULL);
1526 }
1527 else {
1528 assert(parent);
1529 cLISTOPx(parent)->op_first = insert;
1530 if (insert)
1531 parent->op_flags |= OPf_KIDS;
1532 else
1533 parent->op_flags &= ~OPf_KIDS;
1534 }
1535
1536 if (!rest) {
1537 /* update op_last etc */
1538 U32 type;
1539 OP *lastop;
1540
1541 if (!parent)
1542 goto no_parent;
1543
1544 /* ought to use OP_CLASS(parent) here, but that can't handle
1545 * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1546 * either */
1547 type = parent->op_type;
1548 if (type == OP_CUSTOM) {
1549 dTHX;
1550 type = XopENTRYCUSTOM(parent, xop_class);
1551 }
1552 else {
1553 if (type == OP_NULL)
1554 type = parent->op_targ;
1555 type = PL_opargs[type] & OA_CLASS_MASK;
1556 }
1557
1558 lastop = last_ins ? last_ins : start ? start : NULL;
1559 if ( type == OA_BINOP
1560 || type == OA_LISTOP
1561 || type == OA_PMOP
1562 || type == OA_LOOP
1563 )
1564 cLISTOPx(parent)->op_last = lastop;
1565
1566 if (lastop)
1567 OpLASTSIB_set(lastop, parent);
1568 }
1569 return last_del ? first : NULL;
1570
1571 no_parent:
1572 Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1573 }
1574
1575 /*
1576 =for apidoc op_parent
1577
1578 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1579
1580 =cut
1581 */
1582
1583 OP *
Perl_op_parent(OP * o)1584 Perl_op_parent(OP *o)
1585 {
1586 PERL_ARGS_ASSERT_OP_PARENT;
1587 while (OpHAS_SIBLING(o))
1588 o = OpSIBLING(o);
1589 return o->op_sibparent;
1590 }
1591
1592 /* replace the sibling following start with a new UNOP, which becomes
1593 * the parent of the original sibling; e.g.
1594 *
1595 * op_sibling_newUNOP(P, A, unop-args...)
1596 *
1597 * P P
1598 * | becomes |
1599 * A-B-C A-U-C
1600 * |
1601 * B
1602 *
1603 * where U is the new UNOP.
1604 *
1605 * parent and start args are the same as for op_sibling_splice();
1606 * type and flags args are as newUNOP().
1607 *
1608 * Returns the new UNOP.
1609 */
1610
1611 STATIC OP *
S_op_sibling_newUNOP(pTHX_ OP * parent,OP * start,I32 type,I32 flags)1612 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1613 {
1614 OP *kid, *newop;
1615
1616 kid = op_sibling_splice(parent, start, 1, NULL);
1617 newop = newUNOP(type, flags, kid);
1618 op_sibling_splice(parent, start, 0, newop);
1619 return newop;
1620 }
1621
1622
1623 /* lowest-level newLOGOP-style function - just allocates and populates
1624 * the struct. Higher-level stuff should be done by S_new_logop() /
1625 * newLOGOP(). This function exists mainly to avoid op_first assignment
1626 * being spread throughout this file.
1627 */
1628
1629 LOGOP *
Perl_alloc_LOGOP(pTHX_ I32 type,OP * first,OP * other)1630 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1631 {
1632 dVAR;
1633 LOGOP *logop;
1634 OP *kid = first;
1635 NewOp(1101, logop, 1, LOGOP);
1636 OpTYPE_set(logop, type);
1637 logop->op_first = first;
1638 logop->op_other = other;
1639 if (first)
1640 logop->op_flags = OPf_KIDS;
1641 while (kid && OpHAS_SIBLING(kid))
1642 kid = OpSIBLING(kid);
1643 if (kid)
1644 OpLASTSIB_set(kid, (OP*)logop);
1645 return logop;
1646 }
1647
1648
1649 /* Contextualizers */
1650
1651 /*
1652 =for apidoc op_contextualize
1653
1654 Applies a syntactic context to an op tree representing an expression.
1655 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1656 or C<G_VOID> to specify the context to apply. The modified op tree
1657 is returned.
1658
1659 =cut
1660 */
1661
1662 OP *
Perl_op_contextualize(pTHX_ OP * o,I32 context)1663 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1664 {
1665 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1666 switch (context) {
1667 case G_SCALAR: return scalar(o);
1668 case G_ARRAY: return list(o);
1669 case G_VOID: return scalarvoid(o);
1670 default:
1671 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1672 (long) context);
1673 }
1674 }
1675
1676 /*
1677
1678 =for apidoc op_linklist
1679 This function is the implementation of the L</LINKLIST> macro. It should
1680 not be called directly.
1681
1682 =cut
1683 */
1684
1685
1686 OP *
Perl_op_linklist(pTHX_ OP * o)1687 Perl_op_linklist(pTHX_ OP *o)
1688 {
1689
1690 OP **prevp;
1691 OP *kid;
1692 OP * top_op = o;
1693
1694 PERL_ARGS_ASSERT_OP_LINKLIST;
1695
1696 while (1) {
1697 /* Descend down the tree looking for any unprocessed subtrees to
1698 * do first */
1699 if (!o->op_next) {
1700 if (o->op_flags & OPf_KIDS) {
1701 o = cUNOPo->op_first;
1702 continue;
1703 }
1704 o->op_next = o; /* leaf node; link to self initially */
1705 }
1706
1707 /* if we're at the top level, there either weren't any children
1708 * to process, or we've worked our way back to the top. */
1709 if (o == top_op)
1710 return o->op_next;
1711
1712 /* o is now processed. Next, process any sibling subtrees */
1713
1714 if (OpHAS_SIBLING(o)) {
1715 o = OpSIBLING(o);
1716 continue;
1717 }
1718
1719 /* Done all the subtrees at this level. Go back up a level and
1720 * link the parent in with all its (processed) children.
1721 */
1722
1723 o = o->op_sibparent;
1724 assert(!o->op_next);
1725 prevp = &(o->op_next);
1726 kid = (o->op_flags & OPf_KIDS) ? cUNOPo->op_first : NULL;
1727 while (kid) {
1728 *prevp = kid->op_next;
1729 prevp = &(kid->op_next);
1730 kid = OpSIBLING(kid);
1731 }
1732 *prevp = o;
1733 }
1734 }
1735
1736
1737 static OP *
S_scalarkids(pTHX_ OP * o)1738 S_scalarkids(pTHX_ OP *o)
1739 {
1740 if (o && o->op_flags & OPf_KIDS) {
1741 OP *kid;
1742 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1743 scalar(kid);
1744 }
1745 return o;
1746 }
1747
1748 STATIC OP *
S_scalarboolean(pTHX_ OP * o)1749 S_scalarboolean(pTHX_ OP *o)
1750 {
1751 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1752
1753 if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1754 !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1755 (o->op_type == OP_NOT && cUNOPo->op_first->op_type == OP_SASSIGN &&
1756 cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1757 !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1758 if (ckWARN(WARN_SYNTAX)) {
1759 const line_t oldline = CopLINE(PL_curcop);
1760
1761 if (PL_parser && PL_parser->copline != NOLINE) {
1762 /* This ensures that warnings are reported at the first line
1763 of the conditional, not the last. */
1764 CopLINE_set(PL_curcop, PL_parser->copline);
1765 }
1766 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1767 CopLINE_set(PL_curcop, oldline);
1768 }
1769 }
1770 return scalar(o);
1771 }
1772
1773 static SV *
S_op_varname_subscript(pTHX_ const OP * o,int subscript_type)1774 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1775 {
1776 assert(o);
1777 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1778 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1779 {
1780 const char funny = o->op_type == OP_PADAV
1781 || o->op_type == OP_RV2AV ? '@' : '%';
1782 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1783 GV *gv;
1784 if (cUNOPo->op_first->op_type != OP_GV
1785 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1786 return NULL;
1787 return varname(gv, funny, 0, NULL, 0, subscript_type);
1788 }
1789 return
1790 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1791 }
1792 }
1793
1794 static SV *
S_op_varname(pTHX_ const OP * o)1795 S_op_varname(pTHX_ const OP *o)
1796 {
1797 return S_op_varname_subscript(aTHX_ o, 1);
1798 }
1799
1800 static void
S_op_pretty(pTHX_ const OP * o,SV ** retsv,const char ** retpv)1801 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1802 { /* or not so pretty :-) */
1803 if (o->op_type == OP_CONST) {
1804 *retsv = cSVOPo_sv;
1805 if (SvPOK(*retsv)) {
1806 SV *sv = *retsv;
1807 *retsv = sv_newmortal();
1808 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1809 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1810 }
1811 else if (!SvOK(*retsv))
1812 *retpv = "undef";
1813 }
1814 else *retpv = "...";
1815 }
1816
1817 static void
S_scalar_slice_warning(pTHX_ const OP * o)1818 S_scalar_slice_warning(pTHX_ const OP *o)
1819 {
1820 OP *kid;
1821 const bool h = o->op_type == OP_HSLICE
1822 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
1823 const char lbrack =
1824 h ? '{' : '[';
1825 const char rbrack =
1826 h ? '}' : ']';
1827 SV *name;
1828 SV *keysv = NULL; /* just to silence compiler warnings */
1829 const char *key = NULL;
1830
1831 if (!(o->op_private & OPpSLICEWARNING))
1832 return;
1833 if (PL_parser && PL_parser->error_count)
1834 /* This warning can be nonsensical when there is a syntax error. */
1835 return;
1836
1837 kid = cLISTOPo->op_first;
1838 kid = OpSIBLING(kid); /* get past pushmark */
1839 /* weed out false positives: any ops that can return lists */
1840 switch (kid->op_type) {
1841 case OP_BACKTICK:
1842 case OP_GLOB:
1843 case OP_READLINE:
1844 case OP_MATCH:
1845 case OP_RV2AV:
1846 case OP_EACH:
1847 case OP_VALUES:
1848 case OP_KEYS:
1849 case OP_SPLIT:
1850 case OP_LIST:
1851 case OP_SORT:
1852 case OP_REVERSE:
1853 case OP_ENTERSUB:
1854 case OP_CALLER:
1855 case OP_LSTAT:
1856 case OP_STAT:
1857 case OP_READDIR:
1858 case OP_SYSTEM:
1859 case OP_TMS:
1860 case OP_LOCALTIME:
1861 case OP_GMTIME:
1862 case OP_ENTEREVAL:
1863 return;
1864 }
1865
1866 /* Don't warn if we have a nulled list either. */
1867 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1868 return;
1869
1870 assert(OpSIBLING(kid));
1871 name = S_op_varname(aTHX_ OpSIBLING(kid));
1872 if (!name) /* XS module fiddling with the op tree */
1873 return;
1874 S_op_pretty(aTHX_ kid, &keysv, &key);
1875 assert(SvPOK(name));
1876 sv_chop(name,SvPVX(name)+1);
1877 if (key)
1878 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1879 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1880 "Scalar value @%" SVf "%c%s%c better written as $%" SVf
1881 "%c%s%c",
1882 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1883 lbrack, key, rbrack);
1884 else
1885 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1886 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1887 "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1888 SVf "%c%" SVf "%c",
1889 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1890 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1891 }
1892
1893
1894
1895 /* apply scalar context to the o subtree */
1896
1897 OP *
Perl_scalar(pTHX_ OP * o)1898 Perl_scalar(pTHX_ OP *o)
1899 {
1900 OP * top_op = o;
1901
1902 while (1) {
1903 OP *next_kid = NULL; /* what op (if any) to process next */
1904 OP *kid;
1905
1906 /* assumes no premature commitment */
1907 if (!o || (PL_parser && PL_parser->error_count)
1908 || (o->op_flags & OPf_WANT)
1909 || o->op_type == OP_RETURN)
1910 {
1911 goto do_next;
1912 }
1913
1914 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1915
1916 switch (o->op_type) {
1917 case OP_REPEAT:
1918 scalar(cBINOPo->op_first);
1919 /* convert what initially looked like a list repeat into a
1920 * scalar repeat, e.g. $s = (1) x $n
1921 */
1922 if (o->op_private & OPpREPEAT_DOLIST) {
1923 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1924 assert(kid->op_type == OP_PUSHMARK);
1925 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1926 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1927 o->op_private &=~ OPpREPEAT_DOLIST;
1928 }
1929 }
1930 break;
1931
1932 case OP_OR:
1933 case OP_AND:
1934 case OP_COND_EXPR:
1935 /* impose scalar context on everything except the condition */
1936 next_kid = OpSIBLING(cUNOPo->op_first);
1937 break;
1938
1939 default:
1940 if (o->op_flags & OPf_KIDS)
1941 next_kid = cUNOPo->op_first; /* do all kids */
1942 break;
1943
1944 /* the children of these ops are usually a list of statements,
1945 * except the leaves, whose first child is a corresponding enter
1946 */
1947 case OP_SCOPE:
1948 case OP_LINESEQ:
1949 case OP_LIST:
1950 kid = cLISTOPo->op_first;
1951 goto do_kids;
1952 case OP_LEAVE:
1953 case OP_LEAVETRY:
1954 kid = cLISTOPo->op_first;
1955 scalar(kid);
1956 kid = OpSIBLING(kid);
1957 do_kids:
1958 while (kid) {
1959 OP *sib = OpSIBLING(kid);
1960 /* Apply void context to all kids except the last, which
1961 * is scalar (ignoring a trailing ex-nextstate in determining
1962 * if it's the last kid). E.g.
1963 * $scalar = do { void; void; scalar }
1964 * Except that 'when's are always scalar, e.g.
1965 * $scalar = do { given(..) {
1966 * when (..) { scalar }
1967 * when (..) { scalar }
1968 * ...
1969 * }}
1970 */
1971 if (!sib
1972 || ( !OpHAS_SIBLING(sib)
1973 && sib->op_type == OP_NULL
1974 && ( sib->op_targ == OP_NEXTSTATE
1975 || sib->op_targ == OP_DBSTATE )
1976 )
1977 )
1978 {
1979 /* tail call optimise calling scalar() on the last kid */
1980 next_kid = kid;
1981 goto do_next;
1982 }
1983 else if (kid->op_type == OP_LEAVEWHEN)
1984 scalar(kid);
1985 else
1986 scalarvoid(kid);
1987 kid = sib;
1988 }
1989 NOT_REACHED; /* NOTREACHED */
1990 break;
1991
1992 case OP_SORT:
1993 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1994 break;
1995
1996 case OP_KVHSLICE:
1997 case OP_KVASLICE:
1998 {
1999 /* Warn about scalar context */
2000 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
2001 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
2002 SV *name;
2003 SV *keysv;
2004 const char *key = NULL;
2005
2006 /* This warning can be nonsensical when there is a syntax error. */
2007 if (PL_parser && PL_parser->error_count)
2008 break;
2009
2010 if (!ckWARN(WARN_SYNTAX)) break;
2011
2012 kid = cLISTOPo->op_first;
2013 kid = OpSIBLING(kid); /* get past pushmark */
2014 assert(OpSIBLING(kid));
2015 name = S_op_varname(aTHX_ OpSIBLING(kid));
2016 if (!name) /* XS module fiddling with the op tree */
2017 break;
2018 S_op_pretty(aTHX_ kid, &keysv, &key);
2019 assert(SvPOK(name));
2020 sv_chop(name,SvPVX(name)+1);
2021 if (key)
2022 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
2023 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
2024 "%%%" SVf "%c%s%c in scalar context better written "
2025 "as $%" SVf "%c%s%c",
2026 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
2027 lbrack, key, rbrack);
2028 else
2029 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
2030 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
2031 "%%%" SVf "%c%" SVf "%c in scalar context better "
2032 "written as $%" SVf "%c%" SVf "%c",
2033 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
2034 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
2035 }
2036 } /* switch */
2037
2038 /* If next_kid is set, someone in the code above wanted us to process
2039 * that kid and all its remaining siblings. Otherwise, work our way
2040 * back up the tree */
2041 do_next:
2042 while (!next_kid) {
2043 if (o == top_op)
2044 return top_op; /* at top; no parents/siblings to try */
2045 if (OpHAS_SIBLING(o))
2046 next_kid = o->op_sibparent;
2047 else {
2048 o = o->op_sibparent; /*try parent's next sibling */
2049 switch (o->op_type) {
2050 case OP_SCOPE:
2051 case OP_LINESEQ:
2052 case OP_LIST:
2053 case OP_LEAVE:
2054 case OP_LEAVETRY:
2055 /* should really restore PL_curcop to its old value, but
2056 * setting it to PL_compiling is better than do nothing */
2057 PL_curcop = &PL_compiling;
2058 }
2059 }
2060 }
2061 o = next_kid;
2062 } /* while */
2063 }
2064
2065
2066 /* apply void context to the optree arg */
2067
2068 OP *
Perl_scalarvoid(pTHX_ OP * arg)2069 Perl_scalarvoid(pTHX_ OP *arg)
2070 {
2071 dVAR;
2072 OP *kid;
2073 SV* sv;
2074 OP *o = arg;
2075
2076 PERL_ARGS_ASSERT_SCALARVOID;
2077
2078 while (1) {
2079 U8 want;
2080 SV *useless_sv = NULL;
2081 const char* useless = NULL;
2082 OP * next_kid = NULL;
2083
2084 if (o->op_type == OP_NEXTSTATE
2085 || o->op_type == OP_DBSTATE
2086 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
2087 || o->op_targ == OP_DBSTATE)))
2088 PL_curcop = (COP*)o; /* for warning below */
2089
2090 /* assumes no premature commitment */
2091 want = o->op_flags & OPf_WANT;
2092 if ((want && want != OPf_WANT_SCALAR)
2093 || (PL_parser && PL_parser->error_count)
2094 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
2095 {
2096 goto get_next_op;
2097 }
2098
2099 if ((o->op_private & OPpTARGET_MY)
2100 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2101 {
2102 /* newASSIGNOP has already applied scalar context, which we
2103 leave, as if this op is inside SASSIGN. */
2104 goto get_next_op;
2105 }
2106
2107 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
2108
2109 switch (o->op_type) {
2110 default:
2111 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
2112 break;
2113 /* FALLTHROUGH */
2114 case OP_REPEAT:
2115 if (o->op_flags & OPf_STACKED)
2116 break;
2117 if (o->op_type == OP_REPEAT)
2118 scalar(cBINOPo->op_first);
2119 goto func_ops;
2120 case OP_CONCAT:
2121 if ((o->op_flags & OPf_STACKED) &&
2122 !(o->op_private & OPpCONCAT_NESTED))
2123 break;
2124 goto func_ops;
2125 case OP_SUBSTR:
2126 if (o->op_private == 4)
2127 break;
2128 /* FALLTHROUGH */
2129 case OP_WANTARRAY:
2130 case OP_GV:
2131 case OP_SMARTMATCH:
2132 case OP_AV2ARYLEN:
2133 case OP_REF:
2134 case OP_REFGEN:
2135 case OP_SREFGEN:
2136 case OP_DEFINED:
2137 case OP_HEX:
2138 case OP_OCT:
2139 case OP_LENGTH:
2140 case OP_VEC:
2141 case OP_INDEX:
2142 case OP_RINDEX:
2143 case OP_SPRINTF:
2144 case OP_KVASLICE:
2145 case OP_KVHSLICE:
2146 case OP_UNPACK:
2147 case OP_PACK:
2148 case OP_JOIN:
2149 case OP_LSLICE:
2150 case OP_ANONLIST:
2151 case OP_ANONHASH:
2152 case OP_SORT:
2153 case OP_REVERSE:
2154 case OP_RANGE:
2155 case OP_FLIP:
2156 case OP_FLOP:
2157 case OP_CALLER:
2158 case OP_FILENO:
2159 case OP_EOF:
2160 case OP_TELL:
2161 case OP_GETSOCKNAME:
2162 case OP_GETPEERNAME:
2163 case OP_READLINK:
2164 case OP_TELLDIR:
2165 case OP_GETPPID:
2166 case OP_GETPGRP:
2167 case OP_GETPRIORITY:
2168 case OP_TIME:
2169 case OP_TMS:
2170 case OP_LOCALTIME:
2171 case OP_GMTIME:
2172 case OP_GHBYNAME:
2173 case OP_GHBYADDR:
2174 case OP_GHOSTENT:
2175 case OP_GNBYNAME:
2176 case OP_GNBYADDR:
2177 case OP_GNETENT:
2178 case OP_GPBYNAME:
2179 case OP_GPBYNUMBER:
2180 case OP_GPROTOENT:
2181 case OP_GSBYNAME:
2182 case OP_GSBYPORT:
2183 case OP_GSERVENT:
2184 case OP_GPWNAM:
2185 case OP_GPWUID:
2186 case OP_GGRNAM:
2187 case OP_GGRGID:
2188 case OP_GETLOGIN:
2189 case OP_PROTOTYPE:
2190 case OP_RUNCV:
2191 func_ops:
2192 useless = OP_DESC(o);
2193 break;
2194
2195 case OP_GVSV:
2196 case OP_PADSV:
2197 case OP_PADAV:
2198 case OP_PADHV:
2199 case OP_PADANY:
2200 case OP_AELEM:
2201 case OP_AELEMFAST:
2202 case OP_AELEMFAST_LEX:
2203 case OP_ASLICE:
2204 case OP_HELEM:
2205 case OP_HSLICE:
2206 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
2207 /* Otherwise it's "Useless use of grep iterator" */
2208 useless = OP_DESC(o);
2209 break;
2210
2211 case OP_SPLIT:
2212 if (!(o->op_private & OPpSPLIT_ASSIGN))
2213 useless = OP_DESC(o);
2214 break;
2215
2216 case OP_NOT:
2217 kid = cUNOPo->op_first;
2218 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2219 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2220 goto func_ops;
2221 }
2222 useless = "negative pattern binding (!~)";
2223 break;
2224
2225 case OP_SUBST:
2226 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2227 useless = "non-destructive substitution (s///r)";
2228 break;
2229
2230 case OP_TRANSR:
2231 useless = "non-destructive transliteration (tr///r)";
2232 break;
2233
2234 case OP_RV2GV:
2235 case OP_RV2SV:
2236 case OP_RV2AV:
2237 case OP_RV2HV:
2238 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2239 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2240 useless = "a variable";
2241 break;
2242
2243 case OP_CONST:
2244 sv = cSVOPo_sv;
2245 if (cSVOPo->op_private & OPpCONST_STRICT)
2246 no_bareword_allowed(o);
2247 else {
2248 if (ckWARN(WARN_VOID)) {
2249 NV nv;
2250 /* don't warn on optimised away booleans, eg
2251 * use constant Foo, 5; Foo || print; */
2252 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2253 useless = NULL;
2254 /* the constants 0 and 1 are permitted as they are
2255 conventionally used as dummies in constructs like
2256 1 while some_condition_with_side_effects; */
2257 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2258 useless = NULL;
2259 else if (SvPOK(sv)) {
2260 SV * const dsv = newSVpvs("");
2261 useless_sv
2262 = Perl_newSVpvf(aTHX_
2263 "a constant (%s)",
2264 pv_pretty(dsv, SvPVX_const(sv),
2265 SvCUR(sv), 32, NULL, NULL,
2266 PERL_PV_PRETTY_DUMP
2267 | PERL_PV_ESCAPE_NOCLEAR
2268 | PERL_PV_ESCAPE_UNI_DETECT));
2269 SvREFCNT_dec_NN(dsv);
2270 }
2271 else if (SvOK(sv)) {
2272 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2273 }
2274 else
2275 useless = "a constant (undef)";
2276 }
2277 }
2278 op_null(o); /* don't execute or even remember it */
2279 break;
2280
2281 case OP_POSTINC:
2282 OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */
2283 break;
2284
2285 case OP_POSTDEC:
2286 OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */
2287 break;
2288
2289 case OP_I_POSTINC:
2290 OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */
2291 break;
2292
2293 case OP_I_POSTDEC:
2294 OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */
2295 break;
2296
2297 case OP_SASSIGN: {
2298 OP *rv2gv;
2299 UNOP *refgen, *rv2cv;
2300 LISTOP *exlist;
2301
2302 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2303 break;
2304
2305 rv2gv = ((BINOP *)o)->op_last;
2306 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2307 break;
2308
2309 refgen = (UNOP *)((BINOP *)o)->op_first;
2310
2311 if (!refgen || (refgen->op_type != OP_REFGEN
2312 && refgen->op_type != OP_SREFGEN))
2313 break;
2314
2315 exlist = (LISTOP *)refgen->op_first;
2316 if (!exlist || exlist->op_type != OP_NULL
2317 || exlist->op_targ != OP_LIST)
2318 break;
2319
2320 if (exlist->op_first->op_type != OP_PUSHMARK
2321 && exlist->op_first != exlist->op_last)
2322 break;
2323
2324 rv2cv = (UNOP*)exlist->op_last;
2325
2326 if (rv2cv->op_type != OP_RV2CV)
2327 break;
2328
2329 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2330 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2331 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2332
2333 o->op_private |= OPpASSIGN_CV_TO_GV;
2334 rv2gv->op_private |= OPpDONT_INIT_GV;
2335 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2336
2337 break;
2338 }
2339
2340 case OP_AASSIGN: {
2341 inplace_aassign(o);
2342 break;
2343 }
2344
2345 case OP_OR:
2346 case OP_AND:
2347 kid = cLOGOPo->op_first;
2348 if (kid->op_type == OP_NOT
2349 && (kid->op_flags & OPf_KIDS)) {
2350 if (o->op_type == OP_AND) {
2351 OpTYPE_set(o, OP_OR);
2352 } else {
2353 OpTYPE_set(o, OP_AND);
2354 }
2355 op_null(kid);
2356 }
2357 /* FALLTHROUGH */
2358
2359 case OP_DOR:
2360 case OP_COND_EXPR:
2361 case OP_ENTERGIVEN:
2362 case OP_ENTERWHEN:
2363 next_kid = OpSIBLING(cUNOPo->op_first);
2364 break;
2365
2366 case OP_NULL:
2367 if (o->op_flags & OPf_STACKED)
2368 break;
2369 /* FALLTHROUGH */
2370 case OP_NEXTSTATE:
2371 case OP_DBSTATE:
2372 case OP_ENTERTRY:
2373 case OP_ENTER:
2374 if (!(o->op_flags & OPf_KIDS))
2375 break;
2376 /* FALLTHROUGH */
2377 case OP_SCOPE:
2378 case OP_LEAVE:
2379 case OP_LEAVETRY:
2380 case OP_LEAVELOOP:
2381 case OP_LINESEQ:
2382 case OP_LEAVEGIVEN:
2383 case OP_LEAVEWHEN:
2384 kids:
2385 next_kid = cLISTOPo->op_first;
2386 break;
2387 case OP_LIST:
2388 /* If the first kid after pushmark is something that the padrange
2389 optimisation would reject, then null the list and the pushmark.
2390 */
2391 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2392 && ( !(kid = OpSIBLING(kid))
2393 || ( kid->op_type != OP_PADSV
2394 && kid->op_type != OP_PADAV
2395 && kid->op_type != OP_PADHV)
2396 || kid->op_private & ~OPpLVAL_INTRO
2397 || !(kid = OpSIBLING(kid))
2398 || ( kid->op_type != OP_PADSV
2399 && kid->op_type != OP_PADAV
2400 && kid->op_type != OP_PADHV)
2401 || kid->op_private & ~OPpLVAL_INTRO)
2402 ) {
2403 op_null(cUNOPo->op_first); /* NULL the pushmark */
2404 op_null(o); /* NULL the list */
2405 }
2406 goto kids;
2407 case OP_ENTEREVAL:
2408 scalarkids(o);
2409 break;
2410 case OP_SCALAR:
2411 scalar(o);
2412 break;
2413 }
2414
2415 if (useless_sv) {
2416 /* mortalise it, in case warnings are fatal. */
2417 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2418 "Useless use of %" SVf " in void context",
2419 SVfARG(sv_2mortal(useless_sv)));
2420 }
2421 else if (useless) {
2422 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2423 "Useless use of %s in void context",
2424 useless);
2425 }
2426
2427 get_next_op:
2428 /* if a kid hasn't been nominated to process, continue with the
2429 * next sibling, or if no siblings left, go back to the parent's
2430 * siblings and so on
2431 */
2432 while (!next_kid) {
2433 if (o == arg)
2434 return arg; /* at top; no parents/siblings to try */
2435 if (OpHAS_SIBLING(o))
2436 next_kid = o->op_sibparent;
2437 else
2438 o = o->op_sibparent; /*try parent's next sibling */
2439 }
2440 o = next_kid;
2441 }
2442
2443 return arg;
2444 }
2445
2446
2447 static OP *
S_listkids(pTHX_ OP * o)2448 S_listkids(pTHX_ OP *o)
2449 {
2450 if (o && o->op_flags & OPf_KIDS) {
2451 OP *kid;
2452 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2453 list(kid);
2454 }
2455 return o;
2456 }
2457
2458
2459 /* apply list context to the o subtree */
2460
2461 OP *
Perl_list(pTHX_ OP * o)2462 Perl_list(pTHX_ OP *o)
2463 {
2464 OP * top_op = o;
2465
2466 while (1) {
2467 OP *next_kid = NULL; /* what op (if any) to process next */
2468
2469 OP *kid;
2470
2471 /* assumes no premature commitment */
2472 if (!o || (o->op_flags & OPf_WANT)
2473 || (PL_parser && PL_parser->error_count)
2474 || o->op_type == OP_RETURN)
2475 {
2476 goto do_next;
2477 }
2478
2479 if ((o->op_private & OPpTARGET_MY)
2480 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2481 {
2482 goto do_next; /* As if inside SASSIGN */
2483 }
2484
2485 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2486
2487 switch (o->op_type) {
2488 case OP_REPEAT:
2489 if (o->op_private & OPpREPEAT_DOLIST
2490 && !(o->op_flags & OPf_STACKED))
2491 {
2492 list(cBINOPo->op_first);
2493 kid = cBINOPo->op_last;
2494 /* optimise away (.....) x 1 */
2495 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2496 && SvIVX(kSVOP_sv) == 1)
2497 {
2498 op_null(o); /* repeat */
2499 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2500 /* const (rhs): */
2501 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2502 }
2503 }
2504 break;
2505
2506 case OP_OR:
2507 case OP_AND:
2508 case OP_COND_EXPR:
2509 /* impose list context on everything except the condition */
2510 next_kid = OpSIBLING(cUNOPo->op_first);
2511 break;
2512
2513 default:
2514 if (!(o->op_flags & OPf_KIDS))
2515 break;
2516 /* possibly flatten 1..10 into a constant array */
2517 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2518 list(cBINOPo->op_first);
2519 gen_constant_list(o);
2520 goto do_next;
2521 }
2522 next_kid = cUNOPo->op_first; /* do all kids */
2523 break;
2524
2525 case OP_LIST:
2526 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2527 op_null(cUNOPo->op_first); /* NULL the pushmark */
2528 op_null(o); /* NULL the list */
2529 }
2530 if (o->op_flags & OPf_KIDS)
2531 next_kid = cUNOPo->op_first; /* do all kids */
2532 break;
2533
2534 /* the children of these ops are usually a list of statements,
2535 * except the leaves, whose first child is a corresponding enter
2536 */
2537 case OP_SCOPE:
2538 case OP_LINESEQ:
2539 kid = cLISTOPo->op_first;
2540 goto do_kids;
2541 case OP_LEAVE:
2542 case OP_LEAVETRY:
2543 kid = cLISTOPo->op_first;
2544 list(kid);
2545 kid = OpSIBLING(kid);
2546 do_kids:
2547 while (kid) {
2548 OP *sib = OpSIBLING(kid);
2549 /* Apply void context to all kids except the last, which
2550 * is list. E.g.
2551 * @a = do { void; void; list }
2552 * Except that 'when's are always list context, e.g.
2553 * @a = do { given(..) {
2554 * when (..) { list }
2555 * when (..) { list }
2556 * ...
2557 * }}
2558 */
2559 if (!sib) {
2560 /* tail call optimise calling list() on the last kid */
2561 next_kid = kid;
2562 goto do_next;
2563 }
2564 else if (kid->op_type == OP_LEAVEWHEN)
2565 list(kid);
2566 else
2567 scalarvoid(kid);
2568 kid = sib;
2569 }
2570 NOT_REACHED; /* NOTREACHED */
2571 break;
2572
2573 }
2574
2575 /* If next_kid is set, someone in the code above wanted us to process
2576 * that kid and all its remaining siblings. Otherwise, work our way
2577 * back up the tree */
2578 do_next:
2579 while (!next_kid) {
2580 if (o == top_op)
2581 return top_op; /* at top; no parents/siblings to try */
2582 if (OpHAS_SIBLING(o))
2583 next_kid = o->op_sibparent;
2584 else {
2585 o = o->op_sibparent; /*try parent's next sibling */
2586 switch (o->op_type) {
2587 case OP_SCOPE:
2588 case OP_LINESEQ:
2589 case OP_LIST:
2590 case OP_LEAVE:
2591 case OP_LEAVETRY:
2592 /* should really restore PL_curcop to its old value, but
2593 * setting it to PL_compiling is better than do nothing */
2594 PL_curcop = &PL_compiling;
2595 }
2596 }
2597
2598
2599 }
2600 o = next_kid;
2601 } /* while */
2602 }
2603
2604
2605 static OP *
S_scalarseq(pTHX_ OP * o)2606 S_scalarseq(pTHX_ OP *o)
2607 {
2608 if (o) {
2609 const OPCODE type = o->op_type;
2610
2611 if (type == OP_LINESEQ || type == OP_SCOPE ||
2612 type == OP_LEAVE || type == OP_LEAVETRY)
2613 {
2614 OP *kid, *sib;
2615 for (kid = cLISTOPo->op_first; kid; kid = sib) {
2616 if ((sib = OpSIBLING(kid))
2617 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2618 || ( sib->op_targ != OP_NEXTSTATE
2619 && sib->op_targ != OP_DBSTATE )))
2620 {
2621 scalarvoid(kid);
2622 }
2623 }
2624 PL_curcop = &PL_compiling;
2625 }
2626 o->op_flags &= ~OPf_PARENS;
2627 if (PL_hints & HINT_BLOCK_SCOPE)
2628 o->op_flags |= OPf_PARENS;
2629 }
2630 else
2631 o = newOP(OP_STUB, 0);
2632 return o;
2633 }
2634
2635 STATIC OP *
S_modkids(pTHX_ OP * o,I32 type)2636 S_modkids(pTHX_ OP *o, I32 type)
2637 {
2638 if (o && o->op_flags & OPf_KIDS) {
2639 OP *kid;
2640 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2641 op_lvalue(kid, type);
2642 }
2643 return o;
2644 }
2645
2646
2647 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2648 * const fields. Also, convert CONST keys to HEK-in-SVs.
2649 * rop is the op that retrieves the hash;
2650 * key_op is the first key
2651 * real if false, only check (and possibly croak); don't update op
2652 */
2653
2654 STATIC void
S_check_hash_fields_and_hekify(pTHX_ UNOP * rop,SVOP * key_op,int real)2655 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real)
2656 {
2657 PADNAME *lexname;
2658 GV **fields;
2659 bool check_fields;
2660
2661 /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2662 if (rop) {
2663 if (rop->op_first->op_type == OP_PADSV)
2664 /* @$hash{qw(keys here)} */
2665 rop = (UNOP*)rop->op_first;
2666 else {
2667 /* @{$hash}{qw(keys here)} */
2668 if (rop->op_first->op_type == OP_SCOPE
2669 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2670 {
2671 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2672 }
2673 else
2674 rop = NULL;
2675 }
2676 }
2677
2678 lexname = NULL; /* just to silence compiler warnings */
2679 fields = NULL; /* just to silence compiler warnings */
2680
2681 check_fields =
2682 rop
2683 && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2684 SvPAD_TYPED(lexname))
2685 && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2686 && isGV(*fields) && GvHV(*fields);
2687
2688 for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2689 SV **svp, *sv;
2690 if (key_op->op_type != OP_CONST)
2691 continue;
2692 svp = cSVOPx_svp(key_op);
2693
2694 /* make sure it's not a bareword under strict subs */
2695 if (key_op->op_private & OPpCONST_BARE &&
2696 key_op->op_private & OPpCONST_STRICT)
2697 {
2698 no_bareword_allowed((OP*)key_op);
2699 }
2700
2701 /* Make the CONST have a shared SV */
2702 if ( !SvIsCOW_shared_hash(sv = *svp)
2703 && SvTYPE(sv) < SVt_PVMG
2704 && SvOK(sv)
2705 && !SvROK(sv)
2706 && real)
2707 {
2708 SSize_t keylen;
2709 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2710 SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2711 SvREFCNT_dec_NN(sv);
2712 *svp = nsv;
2713 }
2714
2715 if ( check_fields
2716 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2717 {
2718 Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2719 "in variable %" PNf " of type %" HEKf,
2720 SVfARG(*svp), PNfARG(lexname),
2721 HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2722 }
2723 }
2724 }
2725
2726 /* info returned by S_sprintf_is_multiconcatable() */
2727
2728 struct sprintf_ismc_info {
2729 SSize_t nargs; /* num of args to sprintf (not including the format) */
2730 char *start; /* start of raw format string */
2731 char *end; /* bytes after end of raw format string */
2732 STRLEN total_len; /* total length (in bytes) of format string, not
2733 including '%s' and half of '%%' */
2734 STRLEN variant; /* number of bytes by which total_len_p would grow
2735 if upgraded to utf8 */
2736 bool utf8; /* whether the format is utf8 */
2737 };
2738
2739
2740 /* is the OP_SPRINTF o suitable for converting into a multiconcat op?
2741 * i.e. its format argument is a const string with only '%s' and '%%'
2742 * formats, and the number of args is known, e.g.
2743 * sprintf "a=%s f=%s", $a[0], scalar(f());
2744 * but not
2745 * sprintf "i=%d a=%s f=%s", $i, @a, f();
2746 *
2747 * If successful, the sprintf_ismc_info struct pointed to by info will be
2748 * populated.
2749 */
2750
2751 STATIC bool
S_sprintf_is_multiconcatable(pTHX_ OP * o,struct sprintf_ismc_info * info)2752 S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info)
2753 {
2754 OP *pm, *constop, *kid;
2755 SV *sv;
2756 char *s, *e, *p;
2757 SSize_t nargs, nformats;
2758 STRLEN cur, total_len, variant;
2759 bool utf8;
2760
2761 /* if sprintf's behaviour changes, die here so that someone
2762 * can decide whether to enhance this function or skip optimising
2763 * under those new circumstances */
2764 assert(!(o->op_flags & OPf_STACKED));
2765 assert(!(PL_opargs[OP_SPRINTF] & OA_TARGLEX));
2766 assert(!(o->op_private & ~OPpARG4_MASK));
2767
2768 pm = cUNOPo->op_first;
2769 if (pm->op_type != OP_PUSHMARK) /* weird coreargs stuff */
2770 return FALSE;
2771 constop = OpSIBLING(pm);
2772 if (!constop || constop->op_type != OP_CONST)
2773 return FALSE;
2774 sv = cSVOPx_sv(constop);
2775 if (SvMAGICAL(sv) || !SvPOK(sv))
2776 return FALSE;
2777
2778 s = SvPV(sv, cur);
2779 e = s + cur;
2780
2781 /* Scan format for %% and %s and work out how many %s there are.
2782 * Abandon if other format types are found.
2783 */
2784
2785 nformats = 0;
2786 total_len = 0;
2787 variant = 0;
2788
2789 for (p = s; p < e; p++) {
2790 if (*p != '%') {
2791 total_len++;
2792 if (!UTF8_IS_INVARIANT(*p))
2793 variant++;
2794 continue;
2795 }
2796 p++;
2797 if (p >= e)
2798 return FALSE; /* lone % at end gives "Invalid conversion" */
2799 if (*p == '%')
2800 total_len++;
2801 else if (*p == 's')
2802 nformats++;
2803 else
2804 return FALSE;
2805 }
2806
2807 if (!nformats || nformats > PERL_MULTICONCAT_MAXARG)
2808 return FALSE;
2809
2810 utf8 = cBOOL(SvUTF8(sv));
2811 if (utf8)
2812 variant = 0;
2813
2814 /* scan args; they must all be in scalar cxt */
2815
2816 nargs = 0;
2817 kid = OpSIBLING(constop);
2818
2819 while (kid) {
2820 if ((kid->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
2821 return FALSE;
2822 nargs++;
2823 kid = OpSIBLING(kid);
2824 }
2825
2826 if (nargs != nformats)
2827 return FALSE; /* e.g. sprintf("%s%s", $a); */
2828
2829
2830 info->nargs = nargs;
2831 info->start = s;
2832 info->end = e;
2833 info->total_len = total_len;
2834 info->variant = variant;
2835 info->utf8 = utf8;
2836
2837 return TRUE;
2838 }
2839
2840
2841
2842 /* S_maybe_multiconcat():
2843 *
2844 * given an OP_STRINGIFY, OP_SASSIGN, OP_CONCAT or OP_SPRINTF op, possibly
2845 * convert it (and its children) into an OP_MULTICONCAT. See the code
2846 * comments just before pp_multiconcat() for the full details of what
2847 * OP_MULTICONCAT supports.
2848 *
2849 * Basically we're looking for an optree with a chain of OP_CONCATS down
2850 * the LHS (or an OP_SPRINTF), with possibly an OP_SASSIGN, and/or
2851 * OP_STRINGIFY, and/or OP_CONCAT acting as '.=' at its head, e.g.
2852 *
2853 * $x = "$a$b-$c"
2854 *
2855 * looks like
2856 *
2857 * SASSIGN
2858 * |
2859 * STRINGIFY -- PADSV[$x]
2860 * |
2861 * |
2862 * ex-PUSHMARK -- CONCAT/S
2863 * |
2864 * CONCAT/S -- PADSV[$d]
2865 * |
2866 * CONCAT -- CONST["-"]
2867 * |
2868 * PADSV[$a] -- PADSV[$b]
2869 *
2870 * Note that at this stage the OP_SASSIGN may have already been optimised
2871 * away with OPpTARGET_MY set on the OP_STRINGIFY or OP_CONCAT.
2872 */
2873
2874 STATIC void
S_maybe_multiconcat(pTHX_ OP * o)2875 S_maybe_multiconcat(pTHX_ OP *o)
2876 {
2877 dVAR;
2878 OP *lastkidop; /* the right-most of any kids unshifted onto o */
2879 OP *topop; /* the top-most op in the concat tree (often equals o,
2880 unless there are assign/stringify ops above it */
2881 OP *parentop; /* the parent op of topop (or itself if no parent) */
2882 OP *targmyop; /* the op (if any) with the OPpTARGET_MY flag */
2883 OP *targetop; /* the op corresponding to target=... or target.=... */
2884 OP *stringop; /* the OP_STRINGIFY op, if any */
2885 OP *nextop; /* used for recreating the op_next chain without consts */
2886 OP *kid; /* general-purpose op pointer */
2887 UNOP_AUX_item *aux;
2888 UNOP_AUX_item *lenp;
2889 char *const_str, *p;
2890 struct sprintf_ismc_info sprintf_info;
2891
2892 /* store info about each arg in args[];
2893 * toparg is the highest used slot; argp is a general
2894 * pointer to args[] slots */
2895 struct {
2896 void *p; /* initially points to const sv (or null for op);
2897 later, set to SvPV(constsv), with ... */
2898 STRLEN len; /* ... len set to SvPV(..., len) */
2899 } *argp, *toparg, args[PERL_MULTICONCAT_MAXARG*2 + 1];
2900
2901 SSize_t nargs = 0;
2902 SSize_t nconst = 0;
2903 SSize_t nadjconst = 0; /* adjacent consts - may be demoted to args */
2904 STRLEN variant;
2905 bool utf8 = FALSE;
2906 bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
2907 the last-processed arg will the LHS of one,
2908 as args are processed in reverse order */
2909 U8 stacked_last = 0; /* whether the last seen concat op was STACKED */
2910 STRLEN total_len = 0; /* sum of the lengths of the const segments */
2911 U8 flags = 0; /* what will become the op_flags and ... */
2912 U8 private_flags = 0; /* ... op_private of the multiconcat op */
2913 bool is_sprintf = FALSE; /* we're optimising an sprintf */
2914 bool is_targable = FALSE; /* targetop is an OPpTARGET_MY candidate */
2915 bool prev_was_const = FALSE; /* previous arg was a const */
2916
2917 /* -----------------------------------------------------------------
2918 * Phase 1:
2919 *
2920 * Examine the optree non-destructively to determine whether it's
2921 * suitable to be converted into an OP_MULTICONCAT. Accumulate
2922 * information about the optree in args[].
2923 */
2924
2925 argp = args;
2926 targmyop = NULL;
2927 targetop = NULL;
2928 stringop = NULL;
2929 topop = o;
2930 parentop = o;
2931
2932 assert( o->op_type == OP_SASSIGN
2933 || o->op_type == OP_CONCAT
2934 || o->op_type == OP_SPRINTF
2935 || o->op_type == OP_STRINGIFY);
2936
2937 Zero(&sprintf_info, 1, struct sprintf_ismc_info);
2938
2939 /* first see if, at the top of the tree, there is an assign,
2940 * append and/or stringify */
2941
2942 if (topop->op_type == OP_SASSIGN) {
2943 /* expr = ..... */
2944 if (o->op_ppaddr != PL_ppaddr[OP_SASSIGN])
2945 return;
2946 if (o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV))
2947 return;
2948 assert(!(o->op_private & ~OPpARG2_MASK)); /* barf on unknown flags */
2949
2950 parentop = topop;
2951 topop = cBINOPo->op_first;
2952 targetop = OpSIBLING(topop);
2953 if (!targetop) /* probably some sort of syntax error */
2954 return;
2955
2956 /* don't optimise away assign in 'local $foo = ....' */
2957 if ( (targetop->op_private & OPpLVAL_INTRO)
2958 /* these are the common ops which do 'local', but
2959 * not all */
2960 && ( targetop->op_type == OP_GVSV
2961 || targetop->op_type == OP_RV2SV
2962 || targetop->op_type == OP_AELEM
2963 || targetop->op_type == OP_HELEM
2964 )
2965 )
2966 return;
2967 }
2968 else if ( topop->op_type == OP_CONCAT
2969 && (topop->op_flags & OPf_STACKED)
2970 && (!(topop->op_private & OPpCONCAT_NESTED))
2971 )
2972 {
2973 /* expr .= ..... */
2974
2975 /* OPpTARGET_MY shouldn't be able to be set here. If it is,
2976 * decide what to do about it */
2977 assert(!(o->op_private & OPpTARGET_MY));
2978
2979 /* barf on unknown flags */
2980 assert(!(o->op_private & ~(OPpARG2_MASK|OPpTARGET_MY)));
2981 private_flags |= OPpMULTICONCAT_APPEND;
2982 targetop = cBINOPo->op_first;
2983 parentop = topop;
2984 topop = OpSIBLING(targetop);
2985
2986 /* $x .= <FOO> gets optimised to rcatline instead */
2987 if (topop->op_type == OP_READLINE)
2988 return;
2989 }
2990
2991 if (targetop) {
2992 /* Can targetop (the LHS) if it's a padsv, be optimised
2993 * away and use OPpTARGET_MY instead?
2994 */
2995 if ( (targetop->op_type == OP_PADSV)
2996 && !(targetop->op_private & OPpDEREF)
2997 && !(targetop->op_private & OPpPAD_STATE)
2998 /* we don't support 'my $x .= ...' */
2999 && ( o->op_type == OP_SASSIGN
3000 || !(targetop->op_private & OPpLVAL_INTRO))
3001 )
3002 is_targable = TRUE;
3003 }
3004
3005 if (topop->op_type == OP_STRINGIFY) {
3006 if (topop->op_ppaddr != PL_ppaddr[OP_STRINGIFY])
3007 return;
3008 stringop = topop;
3009
3010 /* barf on unknown flags */
3011 assert(!(o->op_private & ~(OPpARG4_MASK|OPpTARGET_MY)));
3012
3013 if ((topop->op_private & OPpTARGET_MY)) {
3014 if (o->op_type == OP_SASSIGN)
3015 return; /* can't have two assigns */
3016 targmyop = topop;
3017 }
3018
3019 private_flags |= OPpMULTICONCAT_STRINGIFY;
3020 parentop = topop;
3021 topop = cBINOPx(topop)->op_first;
3022 assert(OP_TYPE_IS_OR_WAS_NN(topop, OP_PUSHMARK));
3023 topop = OpSIBLING(topop);
3024 }
3025
3026 if (topop->op_type == OP_SPRINTF) {
3027 if (topop->op_ppaddr != PL_ppaddr[OP_SPRINTF])
3028 return;
3029 if (S_sprintf_is_multiconcatable(aTHX_ topop, &sprintf_info)) {
3030 nargs = sprintf_info.nargs;
3031 total_len = sprintf_info.total_len;
3032 variant = sprintf_info.variant;
3033 utf8 = sprintf_info.utf8;
3034 is_sprintf = TRUE;
3035 private_flags |= OPpMULTICONCAT_FAKE;
3036 toparg = argp;
3037 /* we have an sprintf op rather than a concat optree.
3038 * Skip most of the code below which is associated with
3039 * processing that optree. We also skip phase 2, determining
3040 * whether its cost effective to optimise, since for sprintf,
3041 * multiconcat is *always* faster */
3042 goto create_aux;
3043 }
3044 /* note that even if the sprintf itself isn't multiconcatable,
3045 * the expression as a whole may be, e.g. in
3046 * $x .= sprintf("%d",...)
3047 * the sprintf op will be left as-is, but the concat/S op may
3048 * be upgraded to multiconcat
3049 */
3050 }
3051 else if (topop->op_type == OP_CONCAT) {
3052 if (topop->op_ppaddr != PL_ppaddr[OP_CONCAT])
3053 return;
3054
3055 if ((topop->op_private & OPpTARGET_MY)) {
3056 if (o->op_type == OP_SASSIGN || targmyop)
3057 return; /* can't have two assigns */
3058 targmyop = topop;
3059 }
3060 }
3061
3062 /* Is it safe to convert a sassign/stringify/concat op into
3063 * a multiconcat? */
3064 assert((PL_opargs[OP_SASSIGN] & OA_CLASS_MASK) == OA_BINOP);
3065 assert((PL_opargs[OP_CONCAT] & OA_CLASS_MASK) == OA_BINOP);
3066 assert((PL_opargs[OP_STRINGIFY] & OA_CLASS_MASK) == OA_LISTOP);
3067 assert((PL_opargs[OP_SPRINTF] & OA_CLASS_MASK) == OA_LISTOP);
3068 STATIC_ASSERT_STMT( STRUCT_OFFSET(BINOP, op_last)
3069 == STRUCT_OFFSET(UNOP_AUX, op_aux));
3070 STATIC_ASSERT_STMT( STRUCT_OFFSET(LISTOP, op_last)
3071 == STRUCT_OFFSET(UNOP_AUX, op_aux));
3072
3073 /* Now scan the down the tree looking for a series of
3074 * CONCAT/OPf_STACKED ops on the LHS (with the last one not
3075 * stacked). For example this tree:
3076 *
3077 * |
3078 * CONCAT/STACKED
3079 * |
3080 * CONCAT/STACKED -- EXPR5
3081 * |
3082 * CONCAT/STACKED -- EXPR4
3083 * |
3084 * CONCAT -- EXPR3
3085 * |
3086 * EXPR1 -- EXPR2
3087 *
3088 * corresponds to an expression like
3089 *
3090 * (EXPR1 . EXPR2 . EXPR3 . EXPR4 . EXPR5)
3091 *
3092 * Record info about each EXPR in args[]: in particular, whether it is
3093 * a stringifiable OP_CONST and if so what the const sv is.
3094 *
3095 * The reason why the last concat can't be STACKED is the difference
3096 * between
3097 *
3098 * ((($a .= $a) .= $a) .= $a) .= $a
3099 *
3100 * and
3101 * $a . $a . $a . $a . $a
3102 *
3103 * The main difference between the optrees for those two constructs
3104 * is the presence of the last STACKED. As well as modifying $a,
3105 * the former sees the changed $a between each concat, so if $s is
3106 * initially 'a', the first returns 'a' x 16, while the latter returns
3107 * 'a' x 5. And pp_multiconcat can't handle that kind of thing.
3108 */
3109
3110 kid = topop;
3111
3112 for (;;) {
3113 OP *argop;
3114 SV *sv;
3115 bool last = FALSE;
3116
3117 if ( kid->op_type == OP_CONCAT
3118 && !kid_is_last
3119 ) {
3120 OP *k1, *k2;
3121 k1 = cUNOPx(kid)->op_first;
3122 k2 = OpSIBLING(k1);
3123 /* shouldn't happen except maybe after compile err? */
3124 if (!k2)
3125 return;
3126
3127 /* avoid turning (A . B . ($lex = C) ...) into (A . B . C ...) */
3128 if (kid->op_private & OPpTARGET_MY)
3129 kid_is_last = TRUE;
3130
3131 stacked_last = (kid->op_flags & OPf_STACKED);
3132 if (!stacked_last)
3133 kid_is_last = TRUE;
3134
3135 kid = k1;
3136 argop = k2;
3137 }
3138 else {
3139 argop = kid;
3140 last = TRUE;
3141 }
3142
3143 if ( nargs + nadjconst > PERL_MULTICONCAT_MAXARG - 2
3144 || (argp - args + 1) > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
3145 {
3146 /* At least two spare slots are needed to decompose both
3147 * concat args. If there are no slots left, continue to
3148 * examine the rest of the optree, but don't push new values
3149 * on args[]. If the optree as a whole is legal for conversion
3150 * (in particular that the last concat isn't STACKED), then
3151 * the first PERL_MULTICONCAT_MAXARG elements of the optree
3152 * can be converted into an OP_MULTICONCAT now, with the first
3153 * child of that op being the remainder of the optree -
3154 * which may itself later be converted to a multiconcat op
3155 * too.
3156 */
3157 if (last) {
3158 /* the last arg is the rest of the optree */
3159 argp++->p = NULL;
3160 nargs++;
3161 }
3162 }
3163 else if ( argop->op_type == OP_CONST
3164 && ((sv = cSVOPx_sv(argop)))
3165 /* defer stringification until runtime of 'constant'
3166 * things that might stringify variantly, e.g. the radix
3167 * point of NVs, or overloaded RVs */
3168 && (SvPOK(sv) || SvIOK(sv))
3169 && (!SvGMAGICAL(sv))
3170 ) {
3171 if (argop->op_private & OPpCONST_STRICT)
3172 no_bareword_allowed(argop);
3173 argp++->p = sv;
3174 utf8 |= cBOOL(SvUTF8(sv));
3175 nconst++;
3176 if (prev_was_const)
3177 /* this const may be demoted back to a plain arg later;
3178 * make sure we have enough arg slots left */
3179 nadjconst++;
3180 prev_was_const = !prev_was_const;
3181 }
3182 else {
3183 argp++->p = NULL;
3184 nargs++;
3185 prev_was_const = FALSE;
3186 }
3187
3188 if (last)
3189 break;
3190 }
3191
3192 toparg = argp - 1;
3193
3194 if (stacked_last)
3195 return; /* we don't support ((A.=B).=C)...) */
3196
3197 /* look for two adjacent consts and don't fold them together:
3198 * $o . "a" . "b"
3199 * should do
3200 * $o->concat("a")->concat("b")
3201 * rather than
3202 * $o->concat("ab")
3203 * (but $o .= "a" . "b" should still fold)
3204 */
3205 {
3206 bool seen_nonconst = FALSE;
3207 for (argp = toparg; argp >= args; argp--) {
3208 if (argp->p == NULL) {
3209 seen_nonconst = TRUE;
3210 continue;
3211 }
3212 if (!seen_nonconst)
3213 continue;
3214 if (argp[1].p) {
3215 /* both previous and current arg were constants;
3216 * leave the current OP_CONST as-is */
3217 argp->p = NULL;
3218 nconst--;
3219 nargs++;
3220 }
3221 }
3222 }
3223
3224 /* -----------------------------------------------------------------
3225 * Phase 2:
3226 *
3227 * At this point we have determined that the optree *can* be converted
3228 * into a multiconcat. Having gathered all the evidence, we now decide
3229 * whether it *should*.
3230 */
3231
3232
3233 /* we need at least one concat action, e.g.:
3234 *
3235 * Y . Z
3236 * X = Y . Z
3237 * X .= Y
3238 *
3239 * otherwise we could be doing something like $x = "foo", which
3240 * if treated as a concat, would fail to COW.
3241 */
3242 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2)
3243 return;
3244
3245 /* Benchmarking seems to indicate that we gain if:
3246 * * we optimise at least two actions into a single multiconcat
3247 * (e.g concat+concat, sassign+concat);
3248 * * or if we can eliminate at least 1 OP_CONST;
3249 * * or if we can eliminate a padsv via OPpTARGET_MY
3250 */
3251
3252 if (
3253 /* eliminated at least one OP_CONST */
3254 nconst >= 1
3255 /* eliminated an OP_SASSIGN */
3256 || o->op_type == OP_SASSIGN
3257 /* eliminated an OP_PADSV */
3258 || (!targmyop && is_targable)
3259 )
3260 /* definitely a net gain to optimise */
3261 goto optimise;
3262
3263 /* ... if not, what else? */
3264
3265 /* special-case '$lex1 = expr . $lex1' (where expr isn't lex1):
3266 * multiconcat is faster (due to not creating a temporary copy of
3267 * $lex1), whereas for a general $lex1 = $lex2 . $lex3, concat is
3268 * faster.
3269 */
3270 if ( nconst == 0
3271 && nargs == 2
3272 && targmyop
3273 && topop->op_type == OP_CONCAT
3274 ) {
3275 PADOFFSET t = targmyop->op_targ;
3276 OP *k1 = cBINOPx(topop)->op_first;
3277 OP *k2 = cBINOPx(topop)->op_last;
3278 if ( k2->op_type == OP_PADSV
3279 && k2->op_targ == t
3280 && ( k1->op_type != OP_PADSV
3281 || k1->op_targ != t)
3282 )
3283 goto optimise;
3284 }
3285
3286 /* need at least two concats */
3287 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 3)
3288 return;
3289
3290
3291
3292 /* -----------------------------------------------------------------
3293 * Phase 3:
3294 *
3295 * At this point the optree has been verified as ok to be optimised
3296 * into an OP_MULTICONCAT. Now start changing things.
3297 */
3298
3299 optimise:
3300
3301 /* stringify all const args and determine utf8ness */
3302
3303 variant = 0;
3304 for (argp = args; argp <= toparg; argp++) {
3305 SV *sv = (SV*)argp->p;
3306 if (!sv)
3307 continue; /* not a const op */
3308 if (utf8 && !SvUTF8(sv))
3309 sv_utf8_upgrade_nomg(sv);
3310 argp->p = SvPV_nomg(sv, argp->len);
3311 total_len += argp->len;
3312
3313 /* see if any strings would grow if converted to utf8 */
3314 if (!utf8) {
3315 variant += variant_under_utf8_count((U8 *) argp->p,
3316 (U8 *) argp->p + argp->len);
3317 }
3318 }
3319
3320 /* create and populate aux struct */
3321
3322 create_aux:
3323
3324 aux = (UNOP_AUX_item*)PerlMemShared_malloc(
3325 sizeof(UNOP_AUX_item)
3326 * (
3327 PERL_MULTICONCAT_HEADER_SIZE
3328 + ((nargs + 1) * (variant ? 2 : 1))
3329 )
3330 );
3331 const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1);
3332
3333 /* Extract all the non-const expressions from the concat tree then
3334 * dispose of the old tree, e.g. convert the tree from this:
3335 *
3336 * o => SASSIGN
3337 * |
3338 * STRINGIFY -- TARGET
3339 * |
3340 * ex-PUSHMARK -- CONCAT
3341 * |
3342 * CONCAT -- EXPR5
3343 * |
3344 * CONCAT -- EXPR4
3345 * |
3346 * CONCAT -- EXPR3
3347 * |
3348 * EXPR1 -- EXPR2
3349 *
3350 *
3351 * to:
3352 *
3353 * o => MULTICONCAT
3354 * |
3355 * ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET
3356 *
3357 * except that if EXPRi is an OP_CONST, it's discarded.
3358 *
3359 * During the conversion process, EXPR ops are stripped from the tree
3360 * and unshifted onto o. Finally, any of o's remaining original
3361 * childen are discarded and o is converted into an OP_MULTICONCAT.
3362 *
3363 * In this middle of this, o may contain both: unshifted args on the
3364 * left, and some remaining original args on the right. lastkidop
3365 * is set to point to the right-most unshifted arg to delineate
3366 * between the two sets.
3367 */
3368
3369
3370 if (is_sprintf) {
3371 /* create a copy of the format with the %'s removed, and record
3372 * the sizes of the const string segments in the aux struct */
3373 char *q, *oldq;
3374 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3375
3376 p = sprintf_info.start;
3377 q = const_str;
3378 oldq = q;
3379 for (; p < sprintf_info.end; p++) {
3380 if (*p == '%') {
3381 p++;
3382 if (*p != '%') {
3383 (lenp++)->ssize = q - oldq;
3384 oldq = q;
3385 continue;
3386 }
3387 }
3388 *q++ = *p;
3389 }
3390 lenp->ssize = q - oldq;
3391 assert((STRLEN)(q - const_str) == total_len);
3392
3393 /* Attach all the args (i.e. the kids of the sprintf) to o (which
3394 * may or may not be topop) The pushmark and const ops need to be
3395 * kept in case they're an op_next entry point.
3396 */
3397 lastkidop = cLISTOPx(topop)->op_last;
3398 kid = cUNOPx(topop)->op_first; /* pushmark */
3399 op_null(kid);
3400 op_null(OpSIBLING(kid)); /* const */
3401 if (o != topop) {
3402 kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */
3403 op_sibling_splice(o, NULL, 0, kid); /* and attach to o */
3404 lastkidop->op_next = o;
3405 }
3406 }
3407 else {
3408 p = const_str;
3409 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3410
3411 lenp->ssize = -1;
3412
3413 /* Concatenate all const strings into const_str.
3414 * Note that args[] contains the RHS args in reverse order, so
3415 * we scan args[] from top to bottom to get constant strings
3416 * in L-R order
3417 */
3418 for (argp = toparg; argp >= args; argp--) {
3419 if (!argp->p)
3420 /* not a const op */
3421 (++lenp)->ssize = -1;
3422 else {
3423 STRLEN l = argp->len;
3424 Copy(argp->p, p, l, char);
3425 p += l;
3426 if (lenp->ssize == -1)
3427 lenp->ssize = l;
3428 else
3429 lenp->ssize += l;
3430 }
3431 }
3432
3433 kid = topop;
3434 nextop = o;
3435 lastkidop = NULL;
3436
3437 for (argp = args; argp <= toparg; argp++) {
3438 /* only keep non-const args, except keep the first-in-next-chain
3439 * arg no matter what it is (but nulled if OP_CONST), because it
3440 * may be the entry point to this subtree from the previous
3441 * op_next.
3442 */
3443 bool last = (argp == toparg);
3444 OP *prev;
3445
3446 /* set prev to the sibling *before* the arg to be cut out,
3447 * e.g. when cutting EXPR:
3448 *
3449 * |
3450 * kid= CONCAT
3451 * |
3452 * prev= CONCAT -- EXPR
3453 * |
3454 */
3455 if (argp == args && kid->op_type != OP_CONCAT) {
3456 /* in e.g. '$x .= f(1)' there's no RHS concat tree
3457 * so the expression to be cut isn't kid->op_last but
3458 * kid itself */
3459 OP *o1, *o2;
3460 /* find the op before kid */
3461 o1 = NULL;
3462 o2 = cUNOPx(parentop)->op_first;
3463 while (o2 && o2 != kid) {
3464 o1 = o2;
3465 o2 = OpSIBLING(o2);
3466 }
3467 assert(o2 == kid);
3468 prev = o1;
3469 kid = parentop;
3470 }
3471 else if (kid == o && lastkidop)
3472 prev = last ? lastkidop : OpSIBLING(lastkidop);
3473 else
3474 prev = last ? NULL : cUNOPx(kid)->op_first;
3475
3476 if (!argp->p || last) {
3477 /* cut RH op */
3478 OP *aop = op_sibling_splice(kid, prev, 1, NULL);
3479 /* and unshift to front of o */
3480 op_sibling_splice(o, NULL, 0, aop);
3481 /* record the right-most op added to o: later we will
3482 * free anything to the right of it */
3483 if (!lastkidop)
3484 lastkidop = aop;
3485 aop->op_next = nextop;
3486 if (last) {
3487 if (argp->p)
3488 /* null the const at start of op_next chain */
3489 op_null(aop);
3490 }
3491 else if (prev)
3492 nextop = prev->op_next;
3493 }
3494
3495 /* the last two arguments are both attached to the same concat op */
3496 if (argp < toparg - 1)
3497 kid = prev;
3498 }
3499 }
3500
3501 /* Populate the aux struct */
3502
3503 aux[PERL_MULTICONCAT_IX_NARGS].ssize = nargs;
3504 aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv = utf8 ? NULL : const_str;
3505 aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ? 0 : total_len;
3506 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = const_str;
3507 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = total_len;
3508
3509 /* if variant > 0, calculate a variant const string and lengths where
3510 * the utf8 version of the string will take 'variant' more bytes than
3511 * the plain one. */
3512
3513 if (variant) {
3514 char *p = const_str;
3515 STRLEN ulen = total_len + variant;
3516 UNOP_AUX_item *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3517 UNOP_AUX_item *ulens = lens + (nargs + 1);
3518 char *up = (char*)PerlMemShared_malloc(ulen);
3519 SSize_t n;
3520
3521 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = up;
3522 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen;
3523
3524 for (n = 0; n < (nargs + 1); n++) {
3525 SSize_t i;
3526 char * orig_up = up;
3527 for (i = (lens++)->ssize; i > 0; i--) {
3528 U8 c = *p++;
3529 append_utf8_from_native_byte(c, (U8**)&up);
3530 }
3531 (ulens++)->ssize = (i < 0) ? i : up - orig_up;
3532 }
3533 }
3534
3535 if (stringop) {
3536 /* if there was a top(ish)-level OP_STRINGIFY, we need to keep
3537 * that op's first child - an ex-PUSHMARK - because the op_next of
3538 * the previous op may point to it (i.e. it's the entry point for
3539 * the o optree)
3540 */
3541 OP *pmop =
3542 (stringop == o)
3543 ? op_sibling_splice(o, lastkidop, 1, NULL)
3544 : op_sibling_splice(stringop, NULL, 1, NULL);
3545 assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK));
3546 op_sibling_splice(o, NULL, 0, pmop);
3547 if (!lastkidop)
3548 lastkidop = pmop;
3549 }
3550
3551 /* Optimise
3552 * target = A.B.C...
3553 * target .= A.B.C...
3554 */
3555
3556 if (targetop) {
3557 assert(!targmyop);
3558
3559 if (o->op_type == OP_SASSIGN) {
3560 /* Move the target subtree from being the last of o's children
3561 * to being the last of o's preserved children.
3562 * Note the difference between 'target = ...' and 'target .= ...':
3563 * for the former, target is executed last; for the latter,
3564 * first.
3565 */
3566 kid = OpSIBLING(lastkidop);
3567 op_sibling_splice(o, kid, 1, NULL); /* cut target op */
3568 op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */
3569 lastkidop->op_next = kid->op_next;
3570 lastkidop = targetop;
3571 }
3572 else {
3573 /* Move the target subtree from being the first of o's
3574 * original children to being the first of *all* o's children.
3575 */
3576 if (lastkidop) {
3577 op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */
3578 op_sibling_splice(o, NULL, 0, targetop); /* and paste*/
3579 }
3580 else {
3581 /* if the RHS of .= doesn't contain a concat (e.g.
3582 * $x .= "foo"), it gets missed by the "strip ops from the
3583 * tree and add to o" loop earlier */
3584 assert(topop->op_type != OP_CONCAT);
3585 if (stringop) {
3586 /* in e.g. $x .= "$y", move the $y expression
3587 * from being a child of OP_STRINGIFY to being the
3588 * second child of the OP_CONCAT
3589 */
3590 assert(cUNOPx(stringop)->op_first == topop);
3591 op_sibling_splice(stringop, NULL, 1, NULL);
3592 op_sibling_splice(o, cUNOPo->op_first, 0, topop);
3593 }
3594 assert(topop == OpSIBLING(cBINOPo->op_first));
3595 if (toparg->p)
3596 op_null(topop);
3597 lastkidop = topop;
3598 }
3599 }
3600
3601 if (is_targable) {
3602 /* optimise
3603 * my $lex = A.B.C...
3604 * $lex = A.B.C...
3605 * $lex .= A.B.C...
3606 * The original padsv op is kept but nulled in case it's the
3607 * entry point for the optree (which it will be for
3608 * '$lex .= ... '
3609 */
3610 private_flags |= OPpTARGET_MY;
3611 private_flags |= (targetop->op_private & OPpLVAL_INTRO);
3612 o->op_targ = targetop->op_targ;
3613 targetop->op_targ = 0;
3614 op_null(targetop);
3615 }
3616 else
3617 flags |= OPf_STACKED;
3618 }
3619 else if (targmyop) {
3620 private_flags |= OPpTARGET_MY;
3621 if (o != targmyop) {
3622 o->op_targ = targmyop->op_targ;
3623 targmyop->op_targ = 0;
3624 }
3625 }
3626
3627 /* detach the emaciated husk of the sprintf/concat optree and free it */
3628 for (;;) {
3629 kid = op_sibling_splice(o, lastkidop, 1, NULL);
3630 if (!kid)
3631 break;
3632 op_free(kid);
3633 }
3634
3635 /* and convert o into a multiconcat */
3636
3637 o->op_flags = (flags|OPf_KIDS|stacked_last
3638 |(o->op_flags & (OPf_WANT|OPf_PARENS)));
3639 o->op_private = private_flags;
3640 o->op_type = OP_MULTICONCAT;
3641 o->op_ppaddr = PL_ppaddr[OP_MULTICONCAT];
3642 cUNOP_AUXo->op_aux = aux;
3643 }
3644
3645
3646 /* do all the final processing on an optree (e.g. running the peephole
3647 * optimiser on it), then attach it to cv (if cv is non-null)
3648 */
3649
3650 static void
S_process_optree(pTHX_ CV * cv,OP * optree,OP * start)3651 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
3652 {
3653 OP **startp;
3654
3655 /* XXX for some reason, evals, require and main optrees are
3656 * never attached to their CV; instead they just hang off
3657 * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
3658 * and get manually freed when appropriate */
3659 if (cv)
3660 startp = &CvSTART(cv);
3661 else
3662 startp = PL_in_eval? &PL_eval_start : &PL_main_start;
3663
3664 *startp = start;
3665 optree->op_private |= OPpREFCOUNTED;
3666 OpREFCNT_set(optree, 1);
3667 optimize_optree(optree);
3668 CALL_PEEP(*startp);
3669 finalize_optree(optree);
3670 S_prune_chain_head(startp);
3671
3672 if (cv) {
3673 /* now that optimizer has done its work, adjust pad values */
3674 pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
3675 : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
3676 }
3677 }
3678
3679
3680 /*
3681 =for apidoc optimize_optree
3682
3683 This function applies some optimisations to the optree in top-down order.
3684 It is called before the peephole optimizer, which processes ops in
3685 execution order. Note that finalize_optree() also does a top-down scan,
3686 but is called *after* the peephole optimizer.
3687
3688 =cut
3689 */
3690
3691 void
Perl_optimize_optree(pTHX_ OP * o)3692 Perl_optimize_optree(pTHX_ OP* o)
3693 {
3694 PERL_ARGS_ASSERT_OPTIMIZE_OPTREE;
3695
3696 ENTER;
3697 SAVEVPTR(PL_curcop);
3698
3699 optimize_op(o);
3700
3701 LEAVE;
3702 }
3703
3704
3705 /* helper for optimize_optree() which optimises one op then recurses
3706 * to optimise any children.
3707 */
3708
3709 STATIC void
S_optimize_op(pTHX_ OP * o)3710 S_optimize_op(pTHX_ OP* o)
3711 {
3712 OP *top_op = o;
3713
3714 PERL_ARGS_ASSERT_OPTIMIZE_OP;
3715
3716 while (1) {
3717 OP * next_kid = NULL;
3718
3719 assert(o->op_type != OP_FREED);
3720
3721 switch (o->op_type) {
3722 case OP_NEXTSTATE:
3723 case OP_DBSTATE:
3724 PL_curcop = ((COP*)o); /* for warnings */
3725 break;
3726
3727
3728 case OP_CONCAT:
3729 case OP_SASSIGN:
3730 case OP_STRINGIFY:
3731 case OP_SPRINTF:
3732 S_maybe_multiconcat(aTHX_ o);
3733 break;
3734
3735 case OP_SUBST:
3736 if (cPMOPo->op_pmreplrootu.op_pmreplroot) {
3737 /* we can't assume that op_pmreplroot->op_sibparent == o
3738 * and that it is thus possible to walk back up the tree
3739 * past op_pmreplroot. So, although we try to avoid
3740 * recursing through op trees, do it here. After all,
3741 * there are unlikely to be many nested s///e's within
3742 * the replacement part of a s///e.
3743 */
3744 optimize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3745 }
3746 break;
3747
3748 default:
3749 break;
3750 }
3751
3752 if (o->op_flags & OPf_KIDS)
3753 next_kid = cUNOPo->op_first;
3754
3755 /* if a kid hasn't been nominated to process, continue with the
3756 * next sibling, or if no siblings left, go back to the parent's
3757 * siblings and so on
3758 */
3759 while (!next_kid) {
3760 if (o == top_op)
3761 return; /* at top; no parents/siblings to try */
3762 if (OpHAS_SIBLING(o))
3763 next_kid = o->op_sibparent;
3764 else
3765 o = o->op_sibparent; /*try parent's next sibling */
3766 }
3767
3768 /* this label not yet used. Goto here if any code above sets
3769 * next-kid
3770 get_next_op:
3771 */
3772 o = next_kid;
3773 }
3774 }
3775
3776
3777 /*
3778 =for apidoc finalize_optree
3779
3780 This function finalizes the optree. Should be called directly after
3781 the complete optree is built. It does some additional
3782 checking which can't be done in the normal C<ck_>xxx functions and makes
3783 the tree thread-safe.
3784
3785 =cut
3786 */
3787 void
Perl_finalize_optree(pTHX_ OP * o)3788 Perl_finalize_optree(pTHX_ OP* o)
3789 {
3790 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
3791
3792 ENTER;
3793 SAVEVPTR(PL_curcop);
3794
3795 finalize_op(o);
3796
3797 LEAVE;
3798 }
3799
3800 #ifdef USE_ITHREADS
3801 /* Relocate sv to the pad for thread safety.
3802 * Despite being a "constant", the SV is written to,
3803 * for reference counts, sv_upgrade() etc. */
3804 PERL_STATIC_INLINE void
S_op_relocate_sv(pTHX_ SV ** svp,PADOFFSET * targp)3805 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
3806 {
3807 PADOFFSET ix;
3808 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
3809 if (!*svp) return;
3810 ix = pad_alloc(OP_CONST, SVf_READONLY);
3811 SvREFCNT_dec(PAD_SVl(ix));
3812 PAD_SETSV(ix, *svp);
3813 /* XXX I don't know how this isn't readonly already. */
3814 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
3815 *svp = NULL;
3816 *targp = ix;
3817 }
3818 #endif
3819
3820 /*
3821 =for apidoc traverse_op_tree
3822
3823 Return the next op in a depth-first traversal of the op tree,
3824 returning NULL when the traversal is complete.
3825
3826 The initial call must supply the root of the tree as both top and o.
3827
3828 For now it's static, but it may be exposed to the API in the future.
3829
3830 =cut
3831 */
3832
3833 STATIC OP*
S_traverse_op_tree(pTHX_ OP * top,OP * o)3834 S_traverse_op_tree(pTHX_ OP *top, OP *o) {
3835 OP *sib;
3836
3837 PERL_ARGS_ASSERT_TRAVERSE_OP_TREE;
3838
3839 if ((o->op_flags & OPf_KIDS) && cUNOPo->op_first) {
3840 return cUNOPo->op_first;
3841 }
3842 else if ((sib = OpSIBLING(o))) {
3843 return sib;
3844 }
3845 else {
3846 OP *parent = o->op_sibparent;
3847 assert(!(o->op_moresib));
3848 while (parent && parent != top) {
3849 OP *sib = OpSIBLING(parent);
3850 if (sib)
3851 return sib;
3852 parent = parent->op_sibparent;
3853 }
3854
3855 return NULL;
3856 }
3857 }
3858
3859 STATIC void
S_finalize_op(pTHX_ OP * o)3860 S_finalize_op(pTHX_ OP* o)
3861 {
3862 OP * const top = o;
3863 PERL_ARGS_ASSERT_FINALIZE_OP;
3864
3865 do {
3866 assert(o->op_type != OP_FREED);
3867
3868 switch (o->op_type) {
3869 case OP_NEXTSTATE:
3870 case OP_DBSTATE:
3871 PL_curcop = ((COP*)o); /* for warnings */
3872 break;
3873 case OP_EXEC:
3874 if (OpHAS_SIBLING(o)) {
3875 OP *sib = OpSIBLING(o);
3876 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
3877 && ckWARN(WARN_EXEC)
3878 && OpHAS_SIBLING(sib))
3879 {
3880 const OPCODE type = OpSIBLING(sib)->op_type;
3881 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
3882 const line_t oldline = CopLINE(PL_curcop);
3883 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
3884 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3885 "Statement unlikely to be reached");
3886 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3887 "\t(Maybe you meant system() when you said exec()?)\n");
3888 CopLINE_set(PL_curcop, oldline);
3889 }
3890 }
3891 }
3892 break;
3893
3894 case OP_GV:
3895 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
3896 GV * const gv = cGVOPo_gv;
3897 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
3898 /* XXX could check prototype here instead of just carping */
3899 SV * const sv = sv_newmortal();
3900 gv_efullname3(sv, gv, NULL);
3901 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3902 "%" SVf "() called too early to check prototype",
3903 SVfARG(sv));
3904 }
3905 }
3906 break;
3907
3908 case OP_CONST:
3909 if (cSVOPo->op_private & OPpCONST_STRICT)
3910 no_bareword_allowed(o);
3911 #ifdef USE_ITHREADS
3912 /* FALLTHROUGH */
3913 case OP_HINTSEVAL:
3914 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
3915 #endif
3916 break;
3917
3918 #ifdef USE_ITHREADS
3919 /* Relocate all the METHOP's SVs to the pad for thread safety. */
3920 case OP_METHOD_NAMED:
3921 case OP_METHOD_SUPER:
3922 case OP_METHOD_REDIR:
3923 case OP_METHOD_REDIR_SUPER:
3924 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
3925 break;
3926 #endif
3927
3928 case OP_HELEM: {
3929 UNOP *rop;
3930 SVOP *key_op;
3931 OP *kid;
3932
3933 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
3934 break;
3935
3936 rop = (UNOP*)((BINOP*)o)->op_first;
3937
3938 goto check_keys;
3939
3940 case OP_HSLICE:
3941 S_scalar_slice_warning(aTHX_ o);
3942 /* FALLTHROUGH */
3943
3944 case OP_KVHSLICE:
3945 kid = OpSIBLING(cLISTOPo->op_first);
3946 if (/* I bet there's always a pushmark... */
3947 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
3948 && OP_TYPE_ISNT_NN(kid, OP_CONST))
3949 {
3950 break;
3951 }
3952
3953 key_op = (SVOP*)(kid->op_type == OP_CONST
3954 ? kid
3955 : OpSIBLING(kLISTOP->op_first));
3956
3957 rop = (UNOP*)((LISTOP*)o)->op_last;
3958
3959 check_keys:
3960 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
3961 rop = NULL;
3962 S_check_hash_fields_and_hekify(aTHX_ rop, key_op, 1);
3963 break;
3964 }
3965 case OP_NULL:
3966 if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
3967 break;
3968 /* FALLTHROUGH */
3969 case OP_ASLICE:
3970 S_scalar_slice_warning(aTHX_ o);
3971 break;
3972
3973 case OP_SUBST: {
3974 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3975 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3976 break;
3977 }
3978 default:
3979 break;
3980 }
3981
3982 #ifdef DEBUGGING
3983 if (o->op_flags & OPf_KIDS) {
3984 OP *kid;
3985
3986 /* check that op_last points to the last sibling, and that
3987 * the last op_sibling/op_sibparent field points back to the
3988 * parent, and that the only ops with KIDS are those which are
3989 * entitled to them */
3990 U32 type = o->op_type;
3991 U32 family;
3992 bool has_last;
3993
3994 if (type == OP_NULL) {
3995 type = o->op_targ;
3996 /* ck_glob creates a null UNOP with ex-type GLOB
3997 * (which is a list op. So pretend it wasn't a listop */
3998 if (type == OP_GLOB)
3999 type = OP_NULL;
4000 }
4001 family = PL_opargs[type] & OA_CLASS_MASK;
4002
4003 has_last = ( family == OA_BINOP
4004 || family == OA_LISTOP
4005 || family == OA_PMOP
4006 || family == OA_LOOP
4007 );
4008 assert( has_last /* has op_first and op_last, or ...
4009 ... has (or may have) op_first: */
4010 || family == OA_UNOP
4011 || family == OA_UNOP_AUX
4012 || family == OA_LOGOP
4013 || family == OA_BASEOP_OR_UNOP
4014 || family == OA_FILESTATOP
4015 || family == OA_LOOPEXOP
4016 || family == OA_METHOP
4017 || type == OP_CUSTOM
4018 || type == OP_NULL /* new_logop does this */
4019 );
4020
4021 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
4022 if (!OpHAS_SIBLING(kid)) {
4023 if (has_last)
4024 assert(kid == cLISTOPo->op_last);
4025 assert(kid->op_sibparent == o);
4026 }
4027 }
4028 }
4029 #endif
4030 } while (( o = traverse_op_tree(top, o)) != NULL);
4031 }
4032
4033 static void
S_mark_padname_lvalue(pTHX_ PADNAME * pn)4034 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
4035 {
4036 CV *cv = PL_compcv;
4037 PadnameLVALUE_on(pn);
4038 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
4039 cv = CvOUTSIDE(cv);
4040 /* RT #127786: cv can be NULL due to an eval within the DB package
4041 * called from an anon sub - anon subs don't have CvOUTSIDE() set
4042 * unless they contain an eval, but calling eval within DB
4043 * pretends the eval was done in the caller's scope.
4044 */
4045 if (!cv)
4046 break;
4047 assert(CvPADLIST(cv));
4048 pn =
4049 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
4050 assert(PadnameLEN(pn));
4051 PadnameLVALUE_on(pn);
4052 }
4053 }
4054
4055 static bool
S_vivifies(const OPCODE type)4056 S_vivifies(const OPCODE type)
4057 {
4058 switch(type) {
4059 case OP_RV2AV: case OP_ASLICE:
4060 case OP_RV2HV: case OP_KVASLICE:
4061 case OP_RV2SV: case OP_HSLICE:
4062 case OP_AELEMFAST: case OP_KVHSLICE:
4063 case OP_HELEM:
4064 case OP_AELEM:
4065 return 1;
4066 }
4067 return 0;
4068 }
4069
4070
4071 /* apply lvalue reference (aliasing) context to the optree o.
4072 * E.g. in
4073 * \($x,$y) = (...)
4074 * o would be the list ($x,$y) and type would be OP_AASSIGN.
4075 * It may descend and apply this to children too, for example in
4076 * \( $cond ? $x, $y) = (...)
4077 */
4078
4079 static void
S_lvref(pTHX_ OP * o,I32 type)4080 S_lvref(pTHX_ OP *o, I32 type)
4081 {
4082 dVAR;
4083 OP *kid;
4084 OP * top_op = o;
4085
4086 while (1) {
4087 switch (o->op_type) {
4088 case OP_COND_EXPR:
4089 o = OpSIBLING(cUNOPo->op_first);
4090 continue;
4091
4092 case OP_PUSHMARK:
4093 goto do_next;
4094
4095 case OP_RV2AV:
4096 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
4097 o->op_flags |= OPf_STACKED;
4098 if (o->op_flags & OPf_PARENS) {
4099 if (o->op_private & OPpLVAL_INTRO) {
4100 yyerror(Perl_form(aTHX_ "Can't modify reference to "
4101 "localized parenthesized array in list assignment"));
4102 goto do_next;
4103 }
4104 slurpy:
4105 OpTYPE_set(o, OP_LVAVREF);
4106 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
4107 o->op_flags |= OPf_MOD|OPf_REF;
4108 goto do_next;
4109 }
4110 o->op_private |= OPpLVREF_AV;
4111 goto checkgv;
4112
4113 case OP_RV2CV:
4114 kid = cUNOPo->op_first;
4115 if (kid->op_type == OP_NULL)
4116 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
4117 ->op_first;
4118 o->op_private = OPpLVREF_CV;
4119 if (kid->op_type == OP_GV)
4120 o->op_flags |= OPf_STACKED;
4121 else if (kid->op_type == OP_PADCV) {
4122 o->op_targ = kid->op_targ;
4123 kid->op_targ = 0;
4124 op_free(cUNOPo->op_first);
4125 cUNOPo->op_first = NULL;
4126 o->op_flags &=~ OPf_KIDS;
4127 }
4128 else goto badref;
4129 break;
4130
4131 case OP_RV2HV:
4132 if (o->op_flags & OPf_PARENS) {
4133 parenhash:
4134 yyerror(Perl_form(aTHX_ "Can't modify reference to "
4135 "parenthesized hash in list assignment"));
4136 goto do_next;
4137 }
4138 o->op_private |= OPpLVREF_HV;
4139 /* FALLTHROUGH */
4140 case OP_RV2SV:
4141 checkgv:
4142 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
4143 o->op_flags |= OPf_STACKED;
4144 break;
4145
4146 case OP_PADHV:
4147 if (o->op_flags & OPf_PARENS) goto parenhash;
4148 o->op_private |= OPpLVREF_HV;
4149 /* FALLTHROUGH */
4150 case OP_PADSV:
4151 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
4152 break;
4153
4154 case OP_PADAV:
4155 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
4156 if (o->op_flags & OPf_PARENS) goto slurpy;
4157 o->op_private |= OPpLVREF_AV;
4158 break;
4159
4160 case OP_AELEM:
4161 case OP_HELEM:
4162 o->op_private |= OPpLVREF_ELEM;
4163 o->op_flags |= OPf_STACKED;
4164 break;
4165
4166 case OP_ASLICE:
4167 case OP_HSLICE:
4168 OpTYPE_set(o, OP_LVREFSLICE);
4169 o->op_private &= OPpLVAL_INTRO;
4170 goto do_next;
4171
4172 case OP_NULL:
4173 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
4174 goto badref;
4175 else if (!(o->op_flags & OPf_KIDS))
4176 goto do_next;
4177
4178 /* the code formerly only recursed into the first child of
4179 * a non ex-list OP_NULL. if we ever encounter such a null op with
4180 * more than one child, need to decide whether its ok to process
4181 * *all* its kids or not */
4182 assert(o->op_targ == OP_LIST
4183 || !(OpHAS_SIBLING(cBINOPo->op_first)));
4184 /* FALLTHROUGH */
4185 case OP_LIST:
4186 o = cLISTOPo->op_first;
4187 continue;
4188
4189 case OP_STUB:
4190 if (o->op_flags & OPf_PARENS)
4191 goto do_next;
4192 /* FALLTHROUGH */
4193 default:
4194 badref:
4195 /* diag_listed_as: Can't modify reference to %s in %s assignment */
4196 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
4197 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
4198 ? "do block"
4199 : OP_DESC(o),
4200 PL_op_desc[type]));
4201 goto do_next;
4202 }
4203
4204 OpTYPE_set(o, OP_LVREF);
4205 o->op_private &=
4206 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
4207 if (type == OP_ENTERLOOP)
4208 o->op_private |= OPpLVREF_ITER;
4209
4210 do_next:
4211 while (1) {
4212 if (o == top_op)
4213 return; /* at top; no parents/siblings to try */
4214 if (OpHAS_SIBLING(o)) {
4215 o = o->op_sibparent;
4216 break;
4217 }
4218 o = o->op_sibparent; /*try parent's next sibling */
4219 }
4220 } /* while */
4221 }
4222
4223
4224 PERL_STATIC_INLINE bool
S_potential_mod_type(I32 type)4225 S_potential_mod_type(I32 type)
4226 {
4227 /* Types that only potentially result in modification. */
4228 return type == OP_GREPSTART || type == OP_ENTERSUB
4229 || type == OP_REFGEN || type == OP_LEAVESUBLV;
4230 }
4231
4232
4233 /*
4234 =for apidoc op_lvalue
4235
4236 Propagate lvalue ("modifiable") context to an op and its children.
4237 C<type> represents the context type, roughly based on the type of op that
4238 would do the modifying, although C<local()> is represented by C<OP_NULL>,
4239 because it has no op type of its own (it is signalled by a flag on
4240 the lvalue op).
4241
4242 This function detects things that can't be modified, such as C<$x+1>, and
4243 generates errors for them. For example, C<$x+1 = 2> would cause it to be
4244 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
4245
4246 It also flags things that need to behave specially in an lvalue context,
4247 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
4248
4249 =cut
4250
4251 Perl_op_lvalue_flags() is a non-API lower-level interface to
4252 op_lvalue(). The flags param has these bits:
4253 OP_LVALUE_NO_CROAK: return rather than croaking on error
4254
4255 */
4256
4257 OP *
Perl_op_lvalue_flags(pTHX_ OP * o,I32 type,U32 flags)4258 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
4259 {
4260 dVAR;
4261 OP *top_op = o;
4262
4263 if (!o || (PL_parser && PL_parser->error_count))
4264 return o;
4265
4266 while (1) {
4267 OP *kid;
4268 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
4269 int localize = -1;
4270 OP *next_kid = NULL;
4271
4272 if ((o->op_private & OPpTARGET_MY)
4273 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
4274 {
4275 goto do_next;
4276 }
4277
4278 /* elements of a list might be in void context because the list is
4279 in scalar context or because they are attribute sub calls */
4280 if ((o->op_flags & OPf_WANT) == OPf_WANT_VOID)
4281 goto do_next;
4282
4283 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
4284
4285 switch (o->op_type) {
4286 case OP_UNDEF:
4287 PL_modcount++;
4288 goto do_next;
4289
4290 case OP_STUB:
4291 if ((o->op_flags & OPf_PARENS))
4292 break;
4293 goto nomod;
4294
4295 case OP_ENTERSUB:
4296 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
4297 !(o->op_flags & OPf_STACKED)) {
4298 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
4299 assert(cUNOPo->op_first->op_type == OP_NULL);
4300 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
4301 break;
4302 }
4303 else { /* lvalue subroutine call */
4304 o->op_private |= OPpLVAL_INTRO;
4305 PL_modcount = RETURN_UNLIMITED_NUMBER;
4306 if (S_potential_mod_type(type)) {
4307 o->op_private |= OPpENTERSUB_INARGS;
4308 break;
4309 }
4310 else { /* Compile-time error message: */
4311 OP *kid = cUNOPo->op_first;
4312 CV *cv;
4313 GV *gv;
4314 SV *namesv;
4315
4316 if (kid->op_type != OP_PUSHMARK) {
4317 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
4318 Perl_croak(aTHX_
4319 "panic: unexpected lvalue entersub "
4320 "args: type/targ %ld:%" UVuf,
4321 (long)kid->op_type, (UV)kid->op_targ);
4322 kid = kLISTOP->op_first;
4323 }
4324 while (OpHAS_SIBLING(kid))
4325 kid = OpSIBLING(kid);
4326 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
4327 break; /* Postpone until runtime */
4328 }
4329
4330 kid = kUNOP->op_first;
4331 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
4332 kid = kUNOP->op_first;
4333 if (kid->op_type == OP_NULL)
4334 Perl_croak(aTHX_
4335 "Unexpected constant lvalue entersub "
4336 "entry via type/targ %ld:%" UVuf,
4337 (long)kid->op_type, (UV)kid->op_targ);
4338 if (kid->op_type != OP_GV) {
4339 break;
4340 }
4341
4342 gv = kGVOP_gv;
4343 cv = isGV(gv)
4344 ? GvCV(gv)
4345 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
4346 ? MUTABLE_CV(SvRV(gv))
4347 : NULL;
4348 if (!cv)
4349 break;
4350 if (CvLVALUE(cv))
4351 break;
4352 if (flags & OP_LVALUE_NO_CROAK)
4353 return NULL;
4354
4355 namesv = cv_name(cv, NULL, 0);
4356 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
4357 "subroutine call of &%" SVf " in %s",
4358 SVfARG(namesv), PL_op_desc[type]),
4359 SvUTF8(namesv));
4360 goto do_next;
4361 }
4362 }
4363 /* FALLTHROUGH */
4364 default:
4365 nomod:
4366 if (flags & OP_LVALUE_NO_CROAK) return NULL;
4367 /* grep, foreach, subcalls, refgen */
4368 if (S_potential_mod_type(type))
4369 break;
4370 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
4371 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
4372 ? "do block"
4373 : OP_DESC(o)),
4374 type ? PL_op_desc[type] : "local"));
4375 goto do_next;
4376
4377 case OP_PREINC:
4378 case OP_PREDEC:
4379 case OP_POW:
4380 case OP_MULTIPLY:
4381 case OP_DIVIDE:
4382 case OP_MODULO:
4383 case OP_ADD:
4384 case OP_SUBTRACT:
4385 case OP_CONCAT:
4386 case OP_LEFT_SHIFT:
4387 case OP_RIGHT_SHIFT:
4388 case OP_BIT_AND:
4389 case OP_BIT_XOR:
4390 case OP_BIT_OR:
4391 case OP_I_MULTIPLY:
4392 case OP_I_DIVIDE:
4393 case OP_I_MODULO:
4394 case OP_I_ADD:
4395 case OP_I_SUBTRACT:
4396 if (!(o->op_flags & OPf_STACKED))
4397 goto nomod;
4398 PL_modcount++;
4399 break;
4400
4401 case OP_REPEAT:
4402 if (o->op_flags & OPf_STACKED) {
4403 PL_modcount++;
4404 break;
4405 }
4406 if (!(o->op_private & OPpREPEAT_DOLIST))
4407 goto nomod;
4408 else {
4409 const I32 mods = PL_modcount;
4410 /* we recurse rather than iterate here because we need to
4411 * calculate and use the delta applied to PL_modcount by the
4412 * first child. So in something like
4413 * ($x, ($y) x 3) = split;
4414 * split knows that 4 elements are wanted
4415 */
4416 modkids(cBINOPo->op_first, type);
4417 if (type != OP_AASSIGN)
4418 goto nomod;
4419 kid = cBINOPo->op_last;
4420 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
4421 const IV iv = SvIV(kSVOP_sv);
4422 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
4423 PL_modcount =
4424 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
4425 }
4426 else
4427 PL_modcount = RETURN_UNLIMITED_NUMBER;
4428 }
4429 break;
4430
4431 case OP_COND_EXPR:
4432 localize = 1;
4433 next_kid = OpSIBLING(cUNOPo->op_first);
4434 break;
4435
4436 case OP_RV2AV:
4437 case OP_RV2HV:
4438 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
4439 PL_modcount = RETURN_UNLIMITED_NUMBER;
4440 /* Treat \(@foo) like ordinary list, but still mark it as modi-
4441 fiable since some contexts need to know. */
4442 o->op_flags |= OPf_MOD;
4443 goto do_next;
4444 }
4445 /* FALLTHROUGH */
4446 case OP_RV2GV:
4447 if (scalar_mod_type(o, type))
4448 goto nomod;
4449 ref(cUNOPo->op_first, o->op_type);
4450 /* FALLTHROUGH */
4451 case OP_ASLICE:
4452 case OP_HSLICE:
4453 localize = 1;
4454 /* FALLTHROUGH */
4455 case OP_AASSIGN:
4456 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
4457 if (type == OP_LEAVESUBLV && (
4458 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
4459 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4460 ))
4461 o->op_private |= OPpMAYBE_LVSUB;
4462 /* FALLTHROUGH */
4463 case OP_NEXTSTATE:
4464 case OP_DBSTATE:
4465 PL_modcount = RETURN_UNLIMITED_NUMBER;
4466 break;
4467
4468 case OP_KVHSLICE:
4469 case OP_KVASLICE:
4470 case OP_AKEYS:
4471 if (type == OP_LEAVESUBLV)
4472 o->op_private |= OPpMAYBE_LVSUB;
4473 goto nomod;
4474
4475 case OP_AVHVSWITCH:
4476 if (type == OP_LEAVESUBLV
4477 && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
4478 o->op_private |= OPpMAYBE_LVSUB;
4479 goto nomod;
4480
4481 case OP_AV2ARYLEN:
4482 PL_hints |= HINT_BLOCK_SCOPE;
4483 if (type == OP_LEAVESUBLV)
4484 o->op_private |= OPpMAYBE_LVSUB;
4485 PL_modcount++;
4486 break;
4487
4488 case OP_RV2SV:
4489 ref(cUNOPo->op_first, o->op_type);
4490 localize = 1;
4491 /* FALLTHROUGH */
4492 case OP_GV:
4493 PL_hints |= HINT_BLOCK_SCOPE;
4494 /* FALLTHROUGH */
4495 case OP_SASSIGN:
4496 case OP_ANDASSIGN:
4497 case OP_ORASSIGN:
4498 case OP_DORASSIGN:
4499 PL_modcount++;
4500 break;
4501
4502 case OP_AELEMFAST:
4503 case OP_AELEMFAST_LEX:
4504 localize = -1;
4505 PL_modcount++;
4506 break;
4507
4508 case OP_PADAV:
4509 case OP_PADHV:
4510 PL_modcount = RETURN_UNLIMITED_NUMBER;
4511 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
4512 {
4513 /* Treat \(@foo) like ordinary list, but still mark it as modi-
4514 fiable since some contexts need to know. */
4515 o->op_flags |= OPf_MOD;
4516 goto do_next;
4517 }
4518 if (scalar_mod_type(o, type))
4519 goto nomod;
4520 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4521 && type == OP_LEAVESUBLV)
4522 o->op_private |= OPpMAYBE_LVSUB;
4523 /* FALLTHROUGH */
4524 case OP_PADSV:
4525 PL_modcount++;
4526 if (!type) /* local() */
4527 Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
4528 PNfARG(PAD_COMPNAME(o->op_targ)));
4529 if (!(o->op_private & OPpLVAL_INTRO)
4530 || ( type != OP_SASSIGN && type != OP_AASSIGN
4531 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
4532 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
4533 break;
4534
4535 case OP_PUSHMARK:
4536 localize = 0;
4537 break;
4538
4539 case OP_KEYS:
4540 if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
4541 goto nomod;
4542 goto lvalue_func;
4543 case OP_SUBSTR:
4544 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
4545 goto nomod;
4546 /* FALLTHROUGH */
4547 case OP_POS:
4548 case OP_VEC:
4549 lvalue_func:
4550 if (type == OP_LEAVESUBLV)
4551 o->op_private |= OPpMAYBE_LVSUB;
4552 if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
4553 /* we recurse rather than iterate here because the child
4554 * needs to be processed with a different 'type' parameter */
4555
4556 /* substr and vec */
4557 /* If this op is in merely potential (non-fatal) modifiable
4558 context, then apply OP_ENTERSUB context to
4559 the kid op (to avoid croaking). Other-
4560 wise pass this op’s own type so the correct op is mentioned
4561 in error messages. */
4562 op_lvalue(OpSIBLING(cBINOPo->op_first),
4563 S_potential_mod_type(type)
4564 ? (I32)OP_ENTERSUB
4565 : o->op_type);
4566 }
4567 break;
4568
4569 case OP_AELEM:
4570 case OP_HELEM:
4571 ref(cBINOPo->op_first, o->op_type);
4572 if (type == OP_ENTERSUB &&
4573 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
4574 o->op_private |= OPpLVAL_DEFER;
4575 if (type == OP_LEAVESUBLV)
4576 o->op_private |= OPpMAYBE_LVSUB;
4577 localize = 1;
4578 PL_modcount++;
4579 break;
4580
4581 case OP_LEAVE:
4582 case OP_LEAVELOOP:
4583 o->op_private |= OPpLVALUE;
4584 /* FALLTHROUGH */
4585 case OP_SCOPE:
4586 case OP_ENTER:
4587 case OP_LINESEQ:
4588 localize = 0;
4589 if (o->op_flags & OPf_KIDS)
4590 next_kid = cLISTOPo->op_last;
4591 break;
4592
4593 case OP_NULL:
4594 localize = 0;
4595 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
4596 goto nomod;
4597 else if (!(o->op_flags & OPf_KIDS))
4598 break;
4599
4600 if (o->op_targ != OP_LIST) {
4601 OP *sib = OpSIBLING(cLISTOPo->op_first);
4602 /* OP_TRANS and OP_TRANSR with argument have a weird optree
4603 * that looks like
4604 *
4605 * null
4606 * arg
4607 * trans
4608 *
4609 * compared with things like OP_MATCH which have the argument
4610 * as a child:
4611 *
4612 * match
4613 * arg
4614 *
4615 * so handle specially to correctly get "Can't modify" croaks etc
4616 */
4617
4618 if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
4619 {
4620 /* this should trigger a "Can't modify transliteration" err */
4621 op_lvalue(sib, type);
4622 }
4623 next_kid = cBINOPo->op_first;
4624 /* we assume OP_NULLs which aren't ex-list have no more than 2
4625 * children. If this assumption is wrong, increase the scan
4626 * limit below */
4627 assert( !OpHAS_SIBLING(next_kid)
4628 || !OpHAS_SIBLING(OpSIBLING(next_kid)));
4629 break;
4630 }
4631 /* FALLTHROUGH */
4632 case OP_LIST:
4633 localize = 0;
4634 next_kid = cLISTOPo->op_first;
4635 break;
4636
4637 case OP_COREARGS:
4638 goto do_next;
4639
4640 case OP_AND:
4641 case OP_OR:
4642 if (type == OP_LEAVESUBLV
4643 || !S_vivifies(cLOGOPo->op_first->op_type))
4644 next_kid = cLOGOPo->op_first;
4645 else if (type == OP_LEAVESUBLV
4646 || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
4647 next_kid = OpSIBLING(cLOGOPo->op_first);
4648 goto nomod;
4649
4650 case OP_SREFGEN:
4651 if (type == OP_NULL) { /* local */
4652 local_refgen:
4653 if (!FEATURE_MYREF_IS_ENABLED)
4654 Perl_croak(aTHX_ "The experimental declared_refs "
4655 "feature is not enabled");
4656 Perl_ck_warner_d(aTHX_
4657 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4658 "Declaring references is experimental");
4659 next_kid = cUNOPo->op_first;
4660 goto do_next;
4661 }
4662 if (type != OP_AASSIGN && type != OP_SASSIGN
4663 && type != OP_ENTERLOOP)
4664 goto nomod;
4665 /* Don’t bother applying lvalue context to the ex-list. */
4666 kid = cUNOPx(cUNOPo->op_first)->op_first;
4667 assert (!OpHAS_SIBLING(kid));
4668 goto kid_2lvref;
4669 case OP_REFGEN:
4670 if (type == OP_NULL) /* local */
4671 goto local_refgen;
4672 if (type != OP_AASSIGN) goto nomod;
4673 kid = cUNOPo->op_first;
4674 kid_2lvref:
4675 {
4676 const U8 ec = PL_parser ? PL_parser->error_count : 0;
4677 S_lvref(aTHX_ kid, type);
4678 if (!PL_parser || PL_parser->error_count == ec) {
4679 if (!FEATURE_REFALIASING_IS_ENABLED)
4680 Perl_croak(aTHX_
4681 "Experimental aliasing via reference not enabled");
4682 Perl_ck_warner_d(aTHX_
4683 packWARN(WARN_EXPERIMENTAL__REFALIASING),
4684 "Aliasing via reference is experimental");
4685 }
4686 }
4687 if (o->op_type == OP_REFGEN)
4688 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
4689 op_null(o);
4690 goto do_next;
4691
4692 case OP_SPLIT:
4693 if ((o->op_private & OPpSPLIT_ASSIGN)) {
4694 /* This is actually @array = split. */
4695 PL_modcount = RETURN_UNLIMITED_NUMBER;
4696 break;
4697 }
4698 goto nomod;
4699
4700 case OP_SCALAR:
4701 op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
4702 goto nomod;
4703 }
4704
4705 /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
4706 their argument is a filehandle; thus \stat(".") should not set
4707 it. AMS 20011102 */
4708 if (type == OP_REFGEN && OP_IS_STAT(o->op_type))
4709 goto do_next;
4710
4711 if (type != OP_LEAVESUBLV)
4712 o->op_flags |= OPf_MOD;
4713
4714 if (type == OP_AASSIGN || type == OP_SASSIGN)
4715 o->op_flags |= OPf_SPECIAL
4716 |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
4717 else if (!type) { /* local() */
4718 switch (localize) {
4719 case 1:
4720 o->op_private |= OPpLVAL_INTRO;
4721 o->op_flags &= ~OPf_SPECIAL;
4722 PL_hints |= HINT_BLOCK_SCOPE;
4723 break;
4724 case 0:
4725 break;
4726 case -1:
4727 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
4728 "Useless localization of %s", OP_DESC(o));
4729 }
4730 }
4731 else if (type != OP_GREPSTART && type != OP_ENTERSUB
4732 && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
4733 o->op_flags |= OPf_REF;
4734
4735 do_next:
4736 while (!next_kid) {
4737 if (o == top_op)
4738 return top_op; /* at top; no parents/siblings to try */
4739 if (OpHAS_SIBLING(o)) {
4740 next_kid = o->op_sibparent;
4741 if (!OpHAS_SIBLING(next_kid)) {
4742 /* a few node types don't recurse into their second child */
4743 OP *parent = next_kid->op_sibparent;
4744 I32 ptype = parent->op_type;
4745 if ( (ptype == OP_NULL && parent->op_targ != OP_LIST)
4746 || ( (ptype == OP_AND || ptype == OP_OR)
4747 && (type != OP_LEAVESUBLV
4748 && S_vivifies(next_kid->op_type))
4749 )
4750 ) {
4751 /*try parent's next sibling */
4752 o = parent;
4753 next_kid = NULL;
4754 }
4755 }
4756 }
4757 else
4758 o = o->op_sibparent; /*try parent's next sibling */
4759
4760 }
4761 o = next_kid;
4762
4763 } /* while */
4764
4765 }
4766
4767
4768 STATIC bool
S_scalar_mod_type(const OP * o,I32 type)4769 S_scalar_mod_type(const OP *o, I32 type)
4770 {
4771 switch (type) {
4772 case OP_POS:
4773 case OP_SASSIGN:
4774 if (o && o->op_type == OP_RV2GV)
4775 return FALSE;
4776 /* FALLTHROUGH */
4777 case OP_PREINC:
4778 case OP_PREDEC:
4779 case OP_POSTINC:
4780 case OP_POSTDEC:
4781 case OP_I_PREINC:
4782 case OP_I_PREDEC:
4783 case OP_I_POSTINC:
4784 case OP_I_POSTDEC:
4785 case OP_POW:
4786 case OP_MULTIPLY:
4787 case OP_DIVIDE:
4788 case OP_MODULO:
4789 case OP_REPEAT:
4790 case OP_ADD:
4791 case OP_SUBTRACT:
4792 case OP_I_MULTIPLY:
4793 case OP_I_DIVIDE:
4794 case OP_I_MODULO:
4795 case OP_I_ADD:
4796 case OP_I_SUBTRACT:
4797 case OP_LEFT_SHIFT:
4798 case OP_RIGHT_SHIFT:
4799 case OP_BIT_AND:
4800 case OP_BIT_XOR:
4801 case OP_BIT_OR:
4802 case OP_NBIT_AND:
4803 case OP_NBIT_XOR:
4804 case OP_NBIT_OR:
4805 case OP_SBIT_AND:
4806 case OP_SBIT_XOR:
4807 case OP_SBIT_OR:
4808 case OP_CONCAT:
4809 case OP_SUBST:
4810 case OP_TRANS:
4811 case OP_TRANSR:
4812 case OP_READ:
4813 case OP_SYSREAD:
4814 case OP_RECV:
4815 case OP_ANDASSIGN:
4816 case OP_ORASSIGN:
4817 case OP_DORASSIGN:
4818 case OP_VEC:
4819 case OP_SUBSTR:
4820 return TRUE;
4821 default:
4822 return FALSE;
4823 }
4824 }
4825
4826 STATIC bool
S_is_handle_constructor(const OP * o,I32 numargs)4827 S_is_handle_constructor(const OP *o, I32 numargs)
4828 {
4829 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
4830
4831 switch (o->op_type) {
4832 case OP_PIPE_OP:
4833 case OP_SOCKPAIR:
4834 if (numargs == 2)
4835 return TRUE;
4836 /* FALLTHROUGH */
4837 case OP_SYSOPEN:
4838 case OP_OPEN:
4839 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
4840 case OP_SOCKET:
4841 case OP_OPEN_DIR:
4842 case OP_ACCEPT:
4843 if (numargs == 1)
4844 return TRUE;
4845 /* FALLTHROUGH */
4846 default:
4847 return FALSE;
4848 }
4849 }
4850
4851 static OP *
S_refkids(pTHX_ OP * o,I32 type)4852 S_refkids(pTHX_ OP *o, I32 type)
4853 {
4854 if (o && o->op_flags & OPf_KIDS) {
4855 OP *kid;
4856 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4857 ref(kid, type);
4858 }
4859 return o;
4860 }
4861
4862
4863 /* Apply reference (autovivification) context to the subtree at o.
4864 * For example in
4865 * push @{expression}, ....;
4866 * o will be the head of 'expression' and type will be OP_RV2AV.
4867 * It marks the op o (or a suitable child) as autovivifying, e.g. by
4868 * setting OPf_MOD.
4869 * For OP_RV2AV/OP_PADAV and OP_RV2HV/OP_PADHV sets OPf_REF too if
4870 * set_op_ref is true.
4871 *
4872 * Also calls scalar(o).
4873 */
4874
4875 OP *
Perl_doref(pTHX_ OP * o,I32 type,bool set_op_ref)4876 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
4877 {
4878 dVAR;
4879 OP * top_op = o;
4880
4881 PERL_ARGS_ASSERT_DOREF;
4882
4883 if (PL_parser && PL_parser->error_count)
4884 return o;
4885
4886 while (1) {
4887 switch (o->op_type) {
4888 case OP_ENTERSUB:
4889 if ((type == OP_EXISTS || type == OP_DEFINED) &&
4890 !(o->op_flags & OPf_STACKED)) {
4891 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
4892 assert(cUNOPo->op_first->op_type == OP_NULL);
4893 /* disable pushmark */
4894 op_null(((LISTOP*)cUNOPo->op_first)->op_first);
4895 o->op_flags |= OPf_SPECIAL;
4896 }
4897 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
4898 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4899 : type == OP_RV2HV ? OPpDEREF_HV
4900 : OPpDEREF_SV);
4901 o->op_flags |= OPf_MOD;
4902 }
4903
4904 break;
4905
4906 case OP_COND_EXPR:
4907 o = OpSIBLING(cUNOPo->op_first);
4908 continue;
4909
4910 case OP_RV2SV:
4911 if (type == OP_DEFINED)
4912 o->op_flags |= OPf_SPECIAL; /* don't create GV */
4913 /* FALLTHROUGH */
4914 case OP_PADSV:
4915 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4916 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4917 : type == OP_RV2HV ? OPpDEREF_HV
4918 : OPpDEREF_SV);
4919 o->op_flags |= OPf_MOD;
4920 }
4921 if (o->op_flags & OPf_KIDS) {
4922 type = o->op_type;
4923 o = cUNOPo->op_first;
4924 continue;
4925 }
4926 break;
4927
4928 case OP_RV2AV:
4929 case OP_RV2HV:
4930 if (set_op_ref)
4931 o->op_flags |= OPf_REF;
4932 /* FALLTHROUGH */
4933 case OP_RV2GV:
4934 if (type == OP_DEFINED)
4935 o->op_flags |= OPf_SPECIAL; /* don't create GV */
4936 type = o->op_type;
4937 o = cUNOPo->op_first;
4938 continue;
4939
4940 case OP_PADAV:
4941 case OP_PADHV:
4942 if (set_op_ref)
4943 o->op_flags |= OPf_REF;
4944 break;
4945
4946 case OP_SCALAR:
4947 case OP_NULL:
4948 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
4949 break;
4950 o = cBINOPo->op_first;
4951 continue;
4952
4953 case OP_AELEM:
4954 case OP_HELEM:
4955 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4956 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4957 : type == OP_RV2HV ? OPpDEREF_HV
4958 : OPpDEREF_SV);
4959 o->op_flags |= OPf_MOD;
4960 }
4961 type = o->op_type;
4962 o = cBINOPo->op_first;
4963 continue;;
4964
4965 case OP_SCOPE:
4966 case OP_LEAVE:
4967 set_op_ref = FALSE;
4968 /* FALLTHROUGH */
4969 case OP_ENTER:
4970 case OP_LIST:
4971 if (!(o->op_flags & OPf_KIDS))
4972 break;
4973 o = cLISTOPo->op_last;
4974 continue;
4975
4976 default:
4977 break;
4978 } /* switch */
4979
4980 while (1) {
4981 if (o == top_op)
4982 return scalar(top_op); /* at top; no parents/siblings to try */
4983 if (OpHAS_SIBLING(o)) {
4984 o = o->op_sibparent;
4985 /* Normally skip all siblings and go straight to the parent;
4986 * the only op that requires two children to be processed
4987 * is OP_COND_EXPR */
4988 if (!OpHAS_SIBLING(o)
4989 && o->op_sibparent->op_type == OP_COND_EXPR)
4990 break;
4991 continue;
4992 }
4993 o = o->op_sibparent; /*try parent's next sibling */
4994 }
4995 } /* while */
4996 }
4997
4998
4999 STATIC OP *
S_dup_attrlist(pTHX_ OP * o)5000 S_dup_attrlist(pTHX_ OP *o)
5001 {
5002 OP *rop;
5003
5004 PERL_ARGS_ASSERT_DUP_ATTRLIST;
5005
5006 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
5007 * where the first kid is OP_PUSHMARK and the remaining ones
5008 * are OP_CONST. We need to push the OP_CONST values.
5009 */
5010 if (o->op_type == OP_CONST)
5011 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
5012 else {
5013 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
5014 rop = NULL;
5015 for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
5016 if (o->op_type == OP_CONST)
5017 rop = op_append_elem(OP_LIST, rop,
5018 newSVOP(OP_CONST, o->op_flags,
5019 SvREFCNT_inc_NN(cSVOPo->op_sv)));
5020 }
5021 }
5022 return rop;
5023 }
5024
5025 STATIC void
S_apply_attrs(pTHX_ HV * stash,SV * target,OP * attrs)5026 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
5027 {
5028 PERL_ARGS_ASSERT_APPLY_ATTRS;
5029 {
5030 SV * const stashsv = newSVhek(HvNAME_HEK(stash));
5031
5032 /* fake up C<use attributes $pkg,$rv,@attrs> */
5033
5034 #define ATTRSMODULE "attributes"
5035 #define ATTRSMODULE_PM "attributes.pm"
5036
5037 Perl_load_module(
5038 aTHX_ PERL_LOADMOD_IMPORT_OPS,
5039 newSVpvs(ATTRSMODULE),
5040 NULL,
5041 op_prepend_elem(OP_LIST,
5042 newSVOP(OP_CONST, 0, stashsv),
5043 op_prepend_elem(OP_LIST,
5044 newSVOP(OP_CONST, 0,
5045 newRV(target)),
5046 dup_attrlist(attrs))));
5047 }
5048 }
5049
5050 STATIC void
S_apply_attrs_my(pTHX_ HV * stash,OP * target,OP * attrs,OP ** imopsp)5051 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
5052 {
5053 OP *pack, *imop, *arg;
5054 SV *meth, *stashsv, **svp;
5055
5056 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
5057
5058 if (!attrs)
5059 return;
5060
5061 assert(target->op_type == OP_PADSV ||
5062 target->op_type == OP_PADHV ||
5063 target->op_type == OP_PADAV);
5064
5065 /* Ensure that attributes.pm is loaded. */
5066 /* Don't force the C<use> if we don't need it. */
5067 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
5068 if (svp && *svp != &PL_sv_undef)
5069 NOOP; /* already in %INC */
5070 else
5071 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5072 newSVpvs(ATTRSMODULE), NULL);
5073
5074 /* Need package name for method call. */
5075 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
5076
5077 /* Build up the real arg-list. */
5078 stashsv = newSVhek(HvNAME_HEK(stash));
5079
5080 arg = newOP(OP_PADSV, 0);
5081 arg->op_targ = target->op_targ;
5082 arg = op_prepend_elem(OP_LIST,
5083 newSVOP(OP_CONST, 0, stashsv),
5084 op_prepend_elem(OP_LIST,
5085 newUNOP(OP_REFGEN, 0,
5086 arg),
5087 dup_attrlist(attrs)));
5088
5089 /* Fake up a method call to import */
5090 meth = newSVpvs_share("import");
5091 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
5092 op_append_elem(OP_LIST,
5093 op_prepend_elem(OP_LIST, pack, arg),
5094 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
5095
5096 /* Combine the ops. */
5097 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
5098 }
5099
5100 /*
5101 =notfor apidoc apply_attrs_string
5102
5103 Attempts to apply a list of attributes specified by the C<attrstr> and
5104 C<len> arguments to the subroutine identified by the C<cv> argument which
5105 is expected to be associated with the package identified by the C<stashpv>
5106 argument (see L<attributes>). It gets this wrong, though, in that it
5107 does not correctly identify the boundaries of the individual attribute
5108 specifications within C<attrstr>. This is not really intended for the
5109 public API, but has to be listed here for systems such as AIX which
5110 need an explicit export list for symbols. (It's called from XS code
5111 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
5112 to respect attribute syntax properly would be welcome.
5113
5114 =cut
5115 */
5116
5117 void
Perl_apply_attrs_string(pTHX_ const char * stashpv,CV * cv,const char * attrstr,STRLEN len)5118 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
5119 const char *attrstr, STRLEN len)
5120 {
5121 OP *attrs = NULL;
5122
5123 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
5124
5125 if (!len) {
5126 len = strlen(attrstr);
5127 }
5128
5129 while (len) {
5130 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
5131 if (len) {
5132 const char * const sstr = attrstr;
5133 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
5134 attrs = op_append_elem(OP_LIST, attrs,
5135 newSVOP(OP_CONST, 0,
5136 newSVpvn(sstr, attrstr-sstr)));
5137 }
5138 }
5139
5140 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
5141 newSVpvs(ATTRSMODULE),
5142 NULL, op_prepend_elem(OP_LIST,
5143 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
5144 op_prepend_elem(OP_LIST,
5145 newSVOP(OP_CONST, 0,
5146 newRV(MUTABLE_SV(cv))),
5147 attrs)));
5148 }
5149
5150 STATIC void
S_move_proto_attr(pTHX_ OP ** proto,OP ** attrs,const GV * name,bool curstash)5151 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
5152 bool curstash)
5153 {
5154 OP *new_proto = NULL;
5155 STRLEN pvlen;
5156 char *pv;
5157 OP *o;
5158
5159 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
5160
5161 if (!*attrs)
5162 return;
5163
5164 o = *attrs;
5165 if (o->op_type == OP_CONST) {
5166 pv = SvPV(cSVOPo_sv, pvlen);
5167 if (memBEGINs(pv, pvlen, "prototype(")) {
5168 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
5169 SV ** const tmpo = cSVOPx_svp(o);
5170 SvREFCNT_dec(cSVOPo_sv);
5171 *tmpo = tmpsv;
5172 new_proto = o;
5173 *attrs = NULL;
5174 }
5175 } else if (o->op_type == OP_LIST) {
5176 OP * lasto;
5177 assert(o->op_flags & OPf_KIDS);
5178 lasto = cLISTOPo->op_first;
5179 assert(lasto->op_type == OP_PUSHMARK);
5180 for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
5181 if (o->op_type == OP_CONST) {
5182 pv = SvPV(cSVOPo_sv, pvlen);
5183 if (memBEGINs(pv, pvlen, "prototype(")) {
5184 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
5185 SV ** const tmpo = cSVOPx_svp(o);
5186 SvREFCNT_dec(cSVOPo_sv);
5187 *tmpo = tmpsv;
5188 if (new_proto && ckWARN(WARN_MISC)) {
5189 STRLEN new_len;
5190 const char * newp = SvPV(cSVOPo_sv, new_len);
5191 Perl_warner(aTHX_ packWARN(WARN_MISC),
5192 "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
5193 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
5194 op_free(new_proto);
5195 }
5196 else if (new_proto)
5197 op_free(new_proto);
5198 new_proto = o;
5199 /* excise new_proto from the list */
5200 op_sibling_splice(*attrs, lasto, 1, NULL);
5201 o = lasto;
5202 continue;
5203 }
5204 }
5205 lasto = o;
5206 }
5207 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
5208 would get pulled in with no real need */
5209 if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
5210 op_free(*attrs);
5211 *attrs = NULL;
5212 }
5213 }
5214
5215 if (new_proto) {
5216 SV *svname;
5217 if (isGV(name)) {
5218 svname = sv_newmortal();
5219 gv_efullname3(svname, name, NULL);
5220 }
5221 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
5222 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
5223 else
5224 svname = (SV *)name;
5225 if (ckWARN(WARN_ILLEGALPROTO))
5226 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
5227 curstash);
5228 if (*proto && ckWARN(WARN_PROTOTYPE)) {
5229 STRLEN old_len, new_len;
5230 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
5231 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
5232
5233 if (curstash && svname == (SV *)name
5234 && !memchr(SvPVX(svname), ':', SvCUR(svname))) {
5235 svname = sv_2mortal(newSVsv(PL_curstname));
5236 sv_catpvs(svname, "::");
5237 sv_catsv(svname, (SV *)name);
5238 }
5239
5240 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
5241 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
5242 " in %" SVf,
5243 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
5244 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
5245 SVfARG(svname));
5246 }
5247 if (*proto)
5248 op_free(*proto);
5249 *proto = new_proto;
5250 }
5251 }
5252
5253 static void
S_cant_declare(pTHX_ OP * o)5254 S_cant_declare(pTHX_ OP *o)
5255 {
5256 if (o->op_type == OP_NULL
5257 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
5258 o = cUNOPo->op_first;
5259 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
5260 o->op_type == OP_NULL
5261 && o->op_flags & OPf_SPECIAL
5262 ? "do block"
5263 : OP_DESC(o),
5264 PL_parser->in_my == KEY_our ? "our" :
5265 PL_parser->in_my == KEY_state ? "state" :
5266 "my"));
5267 }
5268
5269 STATIC OP *
S_my_kid(pTHX_ OP * o,OP * attrs,OP ** imopsp)5270 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
5271 {
5272 I32 type;
5273 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
5274
5275 PERL_ARGS_ASSERT_MY_KID;
5276
5277 if (!o || (PL_parser && PL_parser->error_count))
5278 return o;
5279
5280 type = o->op_type;
5281
5282 if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
5283 OP *kid;
5284 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
5285 my_kid(kid, attrs, imopsp);
5286 return o;
5287 } else if (type == OP_UNDEF || type == OP_STUB) {
5288 return o;
5289 } else if (type == OP_RV2SV || /* "our" declaration */
5290 type == OP_RV2AV ||
5291 type == OP_RV2HV) {
5292 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
5293 S_cant_declare(aTHX_ o);
5294 } else if (attrs) {
5295 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
5296 assert(PL_parser);
5297 PL_parser->in_my = FALSE;
5298 PL_parser->in_my_stash = NULL;
5299 apply_attrs(GvSTASH(gv),
5300 (type == OP_RV2SV ? GvSVn(gv) :
5301 type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
5302 type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
5303 attrs);
5304 }
5305 o->op_private |= OPpOUR_INTRO;
5306 return o;
5307 }
5308 else if (type == OP_REFGEN || type == OP_SREFGEN) {
5309 if (!FEATURE_MYREF_IS_ENABLED)
5310 Perl_croak(aTHX_ "The experimental declared_refs "
5311 "feature is not enabled");
5312 Perl_ck_warner_d(aTHX_
5313 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
5314 "Declaring references is experimental");
5315 /* Kid is a nulled OP_LIST, handled above. */
5316 my_kid(cUNOPo->op_first, attrs, imopsp);
5317 return o;
5318 }
5319 else if (type != OP_PADSV &&
5320 type != OP_PADAV &&
5321 type != OP_PADHV &&
5322 type != OP_PUSHMARK)
5323 {
5324 S_cant_declare(aTHX_ o);
5325 return o;
5326 }
5327 else if (attrs && type != OP_PUSHMARK) {
5328 HV *stash;
5329
5330 assert(PL_parser);
5331 PL_parser->in_my = FALSE;
5332 PL_parser->in_my_stash = NULL;
5333
5334 /* check for C<my Dog $spot> when deciding package */
5335 stash = PAD_COMPNAME_TYPE(o->op_targ);
5336 if (!stash)
5337 stash = PL_curstash;
5338 apply_attrs_my(stash, o, attrs, imopsp);
5339 }
5340 o->op_flags |= OPf_MOD;
5341 o->op_private |= OPpLVAL_INTRO;
5342 if (stately)
5343 o->op_private |= OPpPAD_STATE;
5344 return o;
5345 }
5346
5347 OP *
Perl_my_attrs(pTHX_ OP * o,OP * attrs)5348 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
5349 {
5350 OP *rops;
5351 int maybe_scalar = 0;
5352
5353 PERL_ARGS_ASSERT_MY_ATTRS;
5354
5355 /* [perl #17376]: this appears to be premature, and results in code such as
5356 C< our(%x); > executing in list mode rather than void mode */
5357 #if 0
5358 if (o->op_flags & OPf_PARENS)
5359 list(o);
5360 else
5361 maybe_scalar = 1;
5362 #else
5363 maybe_scalar = 1;
5364 #endif
5365 if (attrs)
5366 SAVEFREEOP(attrs);
5367 rops = NULL;
5368 o = my_kid(o, attrs, &rops);
5369 if (rops) {
5370 if (maybe_scalar && o->op_type == OP_PADSV) {
5371 o = scalar(op_append_list(OP_LIST, rops, o));
5372 o->op_private |= OPpLVAL_INTRO;
5373 }
5374 else {
5375 /* The listop in rops might have a pushmark at the beginning,
5376 which will mess up list assignment. */
5377 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
5378 if (rops->op_type == OP_LIST &&
5379 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
5380 {
5381 OP * const pushmark = lrops->op_first;
5382 /* excise pushmark */
5383 op_sibling_splice(rops, NULL, 1, NULL);
5384 op_free(pushmark);
5385 }
5386 o = op_append_list(OP_LIST, o, rops);
5387 }
5388 }
5389 PL_parser->in_my = FALSE;
5390 PL_parser->in_my_stash = NULL;
5391 return o;
5392 }
5393
5394 OP *
Perl_sawparens(pTHX_ OP * o)5395 Perl_sawparens(pTHX_ OP *o)
5396 {
5397 PERL_UNUSED_CONTEXT;
5398 if (o)
5399 o->op_flags |= OPf_PARENS;
5400 return o;
5401 }
5402
5403 OP *
Perl_bind_match(pTHX_ I32 type,OP * left,OP * right)5404 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
5405 {
5406 OP *o;
5407 bool ismatchop = 0;
5408 const OPCODE ltype = left->op_type;
5409 const OPCODE rtype = right->op_type;
5410
5411 PERL_ARGS_ASSERT_BIND_MATCH;
5412
5413 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
5414 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
5415 {
5416 const char * const desc
5417 = PL_op_desc[(
5418 rtype == OP_SUBST || rtype == OP_TRANS
5419 || rtype == OP_TRANSR
5420 )
5421 ? (int)rtype : OP_MATCH];
5422 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
5423 SV * const name =
5424 S_op_varname(aTHX_ left);
5425 if (name)
5426 Perl_warner(aTHX_ packWARN(WARN_MISC),
5427 "Applying %s to %" SVf " will act on scalar(%" SVf ")",
5428 desc, SVfARG(name), SVfARG(name));
5429 else {
5430 const char * const sample = (isary
5431 ? "@array" : "%hash");
5432 Perl_warner(aTHX_ packWARN(WARN_MISC),
5433 "Applying %s to %s will act on scalar(%s)",
5434 desc, sample, sample);
5435 }
5436 }
5437
5438 if (rtype == OP_CONST &&
5439 cSVOPx(right)->op_private & OPpCONST_BARE &&
5440 cSVOPx(right)->op_private & OPpCONST_STRICT)
5441 {
5442 no_bareword_allowed(right);
5443 }
5444
5445 /* !~ doesn't make sense with /r, so error on it for now */
5446 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
5447 type == OP_NOT)
5448 /* diag_listed_as: Using !~ with %s doesn't make sense */
5449 yyerror("Using !~ with s///r doesn't make sense");
5450 if (rtype == OP_TRANSR && type == OP_NOT)
5451 /* diag_listed_as: Using !~ with %s doesn't make sense */
5452 yyerror("Using !~ with tr///r doesn't make sense");
5453
5454 ismatchop = (rtype == OP_MATCH ||
5455 rtype == OP_SUBST ||
5456 rtype == OP_TRANS || rtype == OP_TRANSR)
5457 && !(right->op_flags & OPf_SPECIAL);
5458 if (ismatchop && right->op_private & OPpTARGET_MY) {
5459 right->op_targ = 0;
5460 right->op_private &= ~OPpTARGET_MY;
5461 }
5462 if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
5463 if (left->op_type == OP_PADSV
5464 && !(left->op_private & OPpLVAL_INTRO))
5465 {
5466 right->op_targ = left->op_targ;
5467 op_free(left);
5468 o = right;
5469 }
5470 else {
5471 right->op_flags |= OPf_STACKED;
5472 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
5473 ! (rtype == OP_TRANS &&
5474 right->op_private & OPpTRANS_IDENTICAL) &&
5475 ! (rtype == OP_SUBST &&
5476 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
5477 left = op_lvalue(left, rtype);
5478 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
5479 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
5480 else
5481 o = op_prepend_elem(rtype, scalar(left), right);
5482 }
5483 if (type == OP_NOT)
5484 return newUNOP(OP_NOT, 0, scalar(o));
5485 return o;
5486 }
5487 else
5488 return bind_match(type, left,
5489 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
5490 }
5491
5492 OP *
Perl_invert(pTHX_ OP * o)5493 Perl_invert(pTHX_ OP *o)
5494 {
5495 if (!o)
5496 return NULL;
5497 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
5498 }
5499
5500 OP *
Perl_cmpchain_start(pTHX_ I32 type,OP * left,OP * right)5501 Perl_cmpchain_start(pTHX_ I32 type, OP *left, OP *right)
5502 {
5503 dVAR;
5504 BINOP *bop;
5505 OP *op;
5506
5507 if (!left)
5508 left = newOP(OP_NULL, 0);
5509 if (!right)
5510 right = newOP(OP_NULL, 0);
5511 scalar(left);
5512 scalar(right);
5513 NewOp(0, bop, 1, BINOP);
5514 op = (OP*)bop;
5515 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP);
5516 OpTYPE_set(op, type);
5517 cBINOPx(op)->op_flags = OPf_KIDS;
5518 cBINOPx(op)->op_private = 2;
5519 cBINOPx(op)->op_first = left;
5520 cBINOPx(op)->op_last = right;
5521 OpMORESIB_set(left, right);
5522 OpLASTSIB_set(right, op);
5523 return op;
5524 }
5525
5526 OP *
Perl_cmpchain_extend(pTHX_ I32 type,OP * ch,OP * right)5527 Perl_cmpchain_extend(pTHX_ I32 type, OP *ch, OP *right)
5528 {
5529 dVAR;
5530 BINOP *bop;
5531 OP *op;
5532
5533 PERL_ARGS_ASSERT_CMPCHAIN_EXTEND;
5534 if (!right)
5535 right = newOP(OP_NULL, 0);
5536 scalar(right);
5537 NewOp(0, bop, 1, BINOP);
5538 op = (OP*)bop;
5539 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP);
5540 OpTYPE_set(op, type);
5541 if (ch->op_type != OP_NULL) {
5542 UNOP *lch;
5543 OP *nch, *cleft, *cright;
5544 NewOp(0, lch, 1, UNOP);
5545 nch = (OP*)lch;
5546 OpTYPE_set(nch, OP_NULL);
5547 nch->op_flags = OPf_KIDS;
5548 cleft = cBINOPx(ch)->op_first;
5549 cright = cBINOPx(ch)->op_last;
5550 cBINOPx(ch)->op_first = NULL;
5551 cBINOPx(ch)->op_last = NULL;
5552 cBINOPx(ch)->op_private = 0;
5553 cBINOPx(ch)->op_flags = 0;
5554 cUNOPx(nch)->op_first = cright;
5555 OpMORESIB_set(cright, ch);
5556 OpMORESIB_set(ch, cleft);
5557 OpLASTSIB_set(cleft, nch);
5558 ch = nch;
5559 }
5560 OpMORESIB_set(right, op);
5561 OpMORESIB_set(op, cUNOPx(ch)->op_first);
5562 cUNOPx(ch)->op_first = right;
5563 return ch;
5564 }
5565
5566 OP *
Perl_cmpchain_finish(pTHX_ OP * ch)5567 Perl_cmpchain_finish(pTHX_ OP *ch)
5568 {
5569 dVAR;
5570
5571 PERL_ARGS_ASSERT_CMPCHAIN_FINISH;
5572 if (ch->op_type != OP_NULL) {
5573 OPCODE cmpoptype = ch->op_type;
5574 ch = CHECKOP(cmpoptype, ch);
5575 if(!ch->op_next && ch->op_type == cmpoptype)
5576 ch = fold_constants(op_integerize(op_std_init(ch)));
5577 return ch;
5578 } else {
5579 OP *condop = NULL;
5580 OP *rightarg = cUNOPx(ch)->op_first;
5581 cUNOPx(ch)->op_first = OpSIBLING(rightarg);
5582 OpLASTSIB_set(rightarg, NULL);
5583 while (1) {
5584 OP *cmpop = cUNOPx(ch)->op_first;
5585 OP *leftarg = OpSIBLING(cmpop);
5586 OPCODE cmpoptype = cmpop->op_type;
5587 OP *nextrightarg;
5588 bool is_last;
5589 is_last = !(cUNOPx(ch)->op_first = OpSIBLING(leftarg));
5590 OpLASTSIB_set(cmpop, NULL);
5591 OpLASTSIB_set(leftarg, NULL);
5592 if (is_last) {
5593 ch->op_flags = 0;
5594 op_free(ch);
5595 nextrightarg = NULL;
5596 } else {
5597 nextrightarg = newUNOP(OP_CMPCHAIN_DUP, 0, leftarg);
5598 leftarg = newOP(OP_NULL, 0);
5599 }
5600 cBINOPx(cmpop)->op_first = leftarg;
5601 cBINOPx(cmpop)->op_last = rightarg;
5602 OpMORESIB_set(leftarg, rightarg);
5603 OpLASTSIB_set(rightarg, cmpop);
5604 cmpop->op_flags = OPf_KIDS;
5605 cmpop->op_private = 2;
5606 cmpop = CHECKOP(cmpoptype, cmpop);
5607 if(!cmpop->op_next && cmpop->op_type == cmpoptype)
5608 cmpop = op_integerize(op_std_init(cmpop));
5609 condop = condop ? newLOGOP(OP_CMPCHAIN_AND, 0, cmpop, condop) :
5610 cmpop;
5611 if (!nextrightarg)
5612 return condop;
5613 rightarg = nextrightarg;
5614 }
5615 }
5616 }
5617
5618 /*
5619 =for apidoc op_scope
5620
5621 Wraps up an op tree with some additional ops so that at runtime a dynamic
5622 scope will be created. The original ops run in the new dynamic scope,
5623 and then, provided that they exit normally, the scope will be unwound.
5624 The additional ops used to create and unwind the dynamic scope will
5625 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
5626 instead if the ops are simple enough to not need the full dynamic scope
5627 structure.
5628
5629 =cut
5630 */
5631
5632 OP *
Perl_op_scope(pTHX_ OP * o)5633 Perl_op_scope(pTHX_ OP *o)
5634 {
5635 dVAR;
5636 if (o) {
5637 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
5638 o = op_prepend_elem(OP_LINESEQ,
5639 newOP(OP_ENTER, (o->op_flags & OPf_WANT)), o);
5640 OpTYPE_set(o, OP_LEAVE);
5641 }
5642 else if (o->op_type == OP_LINESEQ) {
5643 OP *kid;
5644 OpTYPE_set(o, OP_SCOPE);
5645 kid = ((LISTOP*)o)->op_first;
5646 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
5647 op_null(kid);
5648
5649 /* The following deals with things like 'do {1 for 1}' */
5650 kid = OpSIBLING(kid);
5651 if (kid &&
5652 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
5653 op_null(kid);
5654 }
5655 }
5656 else
5657 o = newLISTOP(OP_SCOPE, 0, o, NULL);
5658 }
5659 return o;
5660 }
5661
5662 OP *
Perl_op_unscope(pTHX_ OP * o)5663 Perl_op_unscope(pTHX_ OP *o)
5664 {
5665 if (o && o->op_type == OP_LINESEQ) {
5666 OP *kid = cLISTOPo->op_first;
5667 for(; kid; kid = OpSIBLING(kid))
5668 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
5669 op_null(kid);
5670 }
5671 return o;
5672 }
5673
5674 /*
5675 =for apidoc block_start
5676
5677 Handles compile-time scope entry.
5678 Arranges for hints to be restored on block
5679 exit and also handles pad sequence numbers to make lexical variables scope
5680 right. Returns a savestack index for use with C<block_end>.
5681
5682 =cut
5683 */
5684
5685 int
Perl_block_start(pTHX_ int full)5686 Perl_block_start(pTHX_ int full)
5687 {
5688 const int retval = PL_savestack_ix;
5689
5690 PL_compiling.cop_seq = PL_cop_seqmax;
5691 COP_SEQMAX_INC;
5692 pad_block_start(full);
5693 SAVEHINTS();
5694 PL_hints &= ~HINT_BLOCK_SCOPE;
5695 SAVECOMPILEWARNINGS();
5696 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
5697 SAVEI32(PL_compiling.cop_seq);
5698 PL_compiling.cop_seq = 0;
5699
5700 CALL_BLOCK_HOOKS(bhk_start, full);
5701
5702 return retval;
5703 }
5704
5705 /*
5706 =for apidoc block_end
5707
5708 Handles compile-time scope exit. C<floor>
5709 is the savestack index returned by
5710 C<block_start>, and C<seq> is the body of the block. Returns the block,
5711 possibly modified.
5712
5713 =cut
5714 */
5715
5716 OP*
Perl_block_end(pTHX_ I32 floor,OP * seq)5717 Perl_block_end(pTHX_ I32 floor, OP *seq)
5718 {
5719 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
5720 OP* retval = scalarseq(seq);
5721 OP *o;
5722
5723 /* XXX Is the null PL_parser check necessary here? */
5724 assert(PL_parser); /* Let’s find out under debugging builds. */
5725 if (PL_parser && PL_parser->parsed_sub) {
5726 o = newSTATEOP(0, NULL, NULL);
5727 op_null(o);
5728 retval = op_append_elem(OP_LINESEQ, retval, o);
5729 }
5730
5731 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
5732
5733 LEAVE_SCOPE(floor);
5734 if (needblockscope)
5735 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
5736 o = pad_leavemy();
5737
5738 if (o) {
5739 /* pad_leavemy has created a sequence of introcv ops for all my
5740 subs declared in the block. We have to replicate that list with
5741 clonecv ops, to deal with this situation:
5742
5743 sub {
5744 my sub s1;
5745 my sub s2;
5746 sub s1 { state sub foo { \&s2 } }
5747 }->()
5748
5749 Originally, I was going to have introcv clone the CV and turn
5750 off the stale flag. Since &s1 is declared before &s2, the
5751 introcv op for &s1 is executed (on sub entry) before the one for
5752 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
5753 cloned, since it is a state sub) closes over &s2 and expects
5754 to see it in its outer CV’s pad. If the introcv op clones &s1,
5755 then &s2 is still marked stale. Since &s1 is not active, and
5756 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
5757 ble will not stay shared’ warning. Because it is the same stub
5758 that will be used when the introcv op for &s2 is executed, clos-
5759 ing over it is safe. Hence, we have to turn off the stale flag
5760 on all lexical subs in the block before we clone any of them.
5761 Hence, having introcv clone the sub cannot work. So we create a
5762 list of ops like this:
5763
5764 lineseq
5765 |
5766 +-- introcv
5767 |
5768 +-- introcv
5769 |
5770 +-- introcv
5771 |
5772 .
5773 .
5774 .
5775 |
5776 +-- clonecv
5777 |
5778 +-- clonecv
5779 |
5780 +-- clonecv
5781 |
5782 .
5783 .
5784 .
5785 */
5786 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
5787 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
5788 for (;; kid = OpSIBLING(kid)) {
5789 OP *newkid = newOP(OP_CLONECV, 0);
5790 newkid->op_targ = kid->op_targ;
5791 o = op_append_elem(OP_LINESEQ, o, newkid);
5792 if (kid == last) break;
5793 }
5794 retval = op_prepend_elem(OP_LINESEQ, o, retval);
5795 }
5796
5797 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
5798
5799 return retval;
5800 }
5801
5802 /*
5803 =head1 Compile-time scope hooks
5804
5805 =for apidoc blockhook_register
5806
5807 Register a set of hooks to be called when the Perl lexical scope changes
5808 at compile time. See L<perlguts/"Compile-time scope hooks">.
5809
5810 =cut
5811 */
5812
5813 void
Perl_blockhook_register(pTHX_ BHK * hk)5814 Perl_blockhook_register(pTHX_ BHK *hk)
5815 {
5816 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
5817
5818 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
5819 }
5820
5821 void
Perl_newPROG(pTHX_ OP * o)5822 Perl_newPROG(pTHX_ OP *o)
5823 {
5824 OP *start;
5825
5826 PERL_ARGS_ASSERT_NEWPROG;
5827
5828 if (PL_in_eval) {
5829 PERL_CONTEXT *cx;
5830 I32 i;
5831 if (PL_eval_root)
5832 return;
5833 PL_eval_root = newUNOP(OP_LEAVEEVAL,
5834 ((PL_in_eval & EVAL_KEEPERR)
5835 ? OPf_SPECIAL : 0), o);
5836
5837 cx = CX_CUR();
5838 assert(CxTYPE(cx) == CXt_EVAL);
5839
5840 if ((cx->blk_gimme & G_WANT) == G_VOID)
5841 scalarvoid(PL_eval_root);
5842 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
5843 list(PL_eval_root);
5844 else
5845 scalar(PL_eval_root);
5846
5847 start = op_linklist(PL_eval_root);
5848 PL_eval_root->op_next = 0;
5849 i = PL_savestack_ix;
5850 SAVEFREEOP(o);
5851 ENTER;
5852 S_process_optree(aTHX_ NULL, PL_eval_root, start);
5853 LEAVE;
5854 PL_savestack_ix = i;
5855 }
5856 else {
5857 if (o->op_type == OP_STUB) {
5858 /* This block is entered if nothing is compiled for the main
5859 program. This will be the case for an genuinely empty main
5860 program, or one which only has BEGIN blocks etc, so already
5861 run and freed.
5862
5863 Historically (5.000) the guard above was !o. However, commit
5864 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
5865 c71fccf11fde0068, changed perly.y so that newPROG() is now
5866 called with the output of block_end(), which returns a new
5867 OP_STUB for the case of an empty optree. ByteLoader (and
5868 maybe other things) also take this path, because they set up
5869 PL_main_start and PL_main_root directly, without generating an
5870 optree.
5871
5872 If the parsing the main program aborts (due to parse errors,
5873 or due to BEGIN or similar calling exit), then newPROG()
5874 isn't even called, and hence this code path and its cleanups
5875 are skipped. This shouldn't make a make a difference:
5876 * a non-zero return from perl_parse is a failure, and
5877 perl_destruct() should be called immediately.
5878 * however, if exit(0) is called during the parse, then
5879 perl_parse() returns 0, and perl_run() is called. As
5880 PL_main_start will be NULL, perl_run() will return
5881 promptly, and the exit code will remain 0.
5882 */
5883
5884 PL_comppad_name = 0;
5885 PL_compcv = 0;
5886 S_op_destroy(aTHX_ o);
5887 return;
5888 }
5889 PL_main_root = op_scope(sawparens(scalarvoid(o)));
5890 PL_curcop = &PL_compiling;
5891 start = LINKLIST(PL_main_root);
5892 PL_main_root->op_next = 0;
5893 S_process_optree(aTHX_ NULL, PL_main_root, start);
5894 if (!PL_parser->error_count)
5895 /* on error, leave CV slabbed so that ops left lying around
5896 * will eb cleaned up. Else unslab */
5897 cv_forget_slab(PL_compcv);
5898 PL_compcv = 0;
5899
5900 /* Register with debugger */
5901 if (PERLDB_INTER) {
5902 CV * const cv = get_cvs("DB::postponed", 0);
5903 if (cv) {
5904 dSP;
5905 PUSHMARK(SP);
5906 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
5907 PUTBACK;
5908 call_sv(MUTABLE_SV(cv), G_DISCARD);
5909 }
5910 }
5911 }
5912 }
5913
5914 OP *
Perl_localize(pTHX_ OP * o,I32 lex)5915 Perl_localize(pTHX_ OP *o, I32 lex)
5916 {
5917 PERL_ARGS_ASSERT_LOCALIZE;
5918
5919 if (o->op_flags & OPf_PARENS)
5920 /* [perl #17376]: this appears to be premature, and results in code such as
5921 C< our(%x); > executing in list mode rather than void mode */
5922 #if 0
5923 list(o);
5924 #else
5925 NOOP;
5926 #endif
5927 else {
5928 if ( PL_parser->bufptr > PL_parser->oldbufptr
5929 && PL_parser->bufptr[-1] == ','
5930 && ckWARN(WARN_PARENTHESIS))
5931 {
5932 char *s = PL_parser->bufptr;
5933 bool sigil = FALSE;
5934
5935 /* some heuristics to detect a potential error */
5936 while (*s && (memCHRs(", \t\n", *s)))
5937 s++;
5938
5939 while (1) {
5940 if (*s && (memCHRs("@$%", *s) || (!lex && *s == '*'))
5941 && *++s
5942 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
5943 s++;
5944 sigil = TRUE;
5945 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
5946 s++;
5947 while (*s && (memCHRs(", \t\n", *s)))
5948 s++;
5949 }
5950 else
5951 break;
5952 }
5953 if (sigil && (*s == ';' || *s == '=')) {
5954 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
5955 "Parentheses missing around \"%s\" list",
5956 lex
5957 ? (PL_parser->in_my == KEY_our
5958 ? "our"
5959 : PL_parser->in_my == KEY_state
5960 ? "state"
5961 : "my")
5962 : "local");
5963 }
5964 }
5965 }
5966 if (lex)
5967 o = my(o);
5968 else
5969 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
5970 PL_parser->in_my = FALSE;
5971 PL_parser->in_my_stash = NULL;
5972 return o;
5973 }
5974
5975 OP *
Perl_jmaybe(pTHX_ OP * o)5976 Perl_jmaybe(pTHX_ OP *o)
5977 {
5978 PERL_ARGS_ASSERT_JMAYBE;
5979
5980 if (o->op_type == OP_LIST) {
5981 OP * const o2
5982 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
5983 o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
5984 }
5985 return o;
5986 }
5987
5988 PERL_STATIC_INLINE OP *
S_op_std_init(pTHX_ OP * o)5989 S_op_std_init(pTHX_ OP *o)
5990 {
5991 I32 type = o->op_type;
5992
5993 PERL_ARGS_ASSERT_OP_STD_INIT;
5994
5995 if (PL_opargs[type] & OA_RETSCALAR)
5996 scalar(o);
5997 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
5998 o->op_targ = pad_alloc(type, SVs_PADTMP);
5999
6000 return o;
6001 }
6002
6003 PERL_STATIC_INLINE OP *
S_op_integerize(pTHX_ OP * o)6004 S_op_integerize(pTHX_ OP *o)
6005 {
6006 I32 type = o->op_type;
6007
6008 PERL_ARGS_ASSERT_OP_INTEGERIZE;
6009
6010 /* integerize op. */
6011 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
6012 {
6013 dVAR;
6014 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
6015 }
6016
6017 if (type == OP_NEGATE)
6018 /* XXX might want a ck_negate() for this */
6019 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
6020
6021 return o;
6022 }
6023
6024 /* This function exists solely to provide a scope to limit
6025 setjmp/longjmp() messing with auto variables. It cannot be inlined because
6026 it uses setjmp
6027 */
6028 STATIC int
S_fold_constants_eval(pTHX)6029 S_fold_constants_eval(pTHX) {
6030 int ret = 0;
6031 dJMPENV;
6032
6033 JMPENV_PUSH(ret);
6034
6035 if (ret == 0) {
6036 CALLRUNOPS(aTHX);
6037 }
6038
6039 JMPENV_POP;
6040
6041 return ret;
6042 }
6043
6044 static OP *
S_fold_constants(pTHX_ OP * const o)6045 S_fold_constants(pTHX_ OP *const o)
6046 {
6047 dVAR;
6048 OP *curop;
6049 OP *newop;
6050 I32 type = o->op_type;
6051 bool is_stringify;
6052 SV *sv = NULL;
6053 int ret = 0;
6054 OP *old_next;
6055 SV * const oldwarnhook = PL_warnhook;
6056 SV * const olddiehook = PL_diehook;
6057 COP not_compiling;
6058 U8 oldwarn = PL_dowarn;
6059 I32 old_cxix;
6060
6061 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
6062
6063 if (!(PL_opargs[type] & OA_FOLDCONST))
6064 goto nope;
6065
6066 switch (type) {
6067 case OP_UCFIRST:
6068 case OP_LCFIRST:
6069 case OP_UC:
6070 case OP_LC:
6071 case OP_FC:
6072 #ifdef USE_LOCALE_CTYPE
6073 if (IN_LC_COMPILETIME(LC_CTYPE))
6074 goto nope;
6075 #endif
6076 break;
6077 case OP_SLT:
6078 case OP_SGT:
6079 case OP_SLE:
6080 case OP_SGE:
6081 case OP_SCMP:
6082 #ifdef USE_LOCALE_COLLATE
6083 if (IN_LC_COMPILETIME(LC_COLLATE))
6084 goto nope;
6085 #endif
6086 break;
6087 case OP_SPRINTF:
6088 /* XXX what about the numeric ops? */
6089 #ifdef USE_LOCALE_NUMERIC
6090 if (IN_LC_COMPILETIME(LC_NUMERIC))
6091 goto nope;
6092 #endif
6093 break;
6094 case OP_PACK:
6095 if (!OpHAS_SIBLING(cLISTOPo->op_first)
6096 || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
6097 goto nope;
6098 {
6099 SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
6100 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
6101 {
6102 const char *s = SvPVX_const(sv);
6103 while (s < SvEND(sv)) {
6104 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
6105 s++;
6106 }
6107 }
6108 }
6109 break;
6110 case OP_REPEAT:
6111 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
6112 break;
6113 case OP_SREFGEN:
6114 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
6115 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
6116 goto nope;
6117 }
6118
6119 if (PL_parser && PL_parser->error_count)
6120 goto nope; /* Don't try to run w/ errors */
6121
6122 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
6123 switch (curop->op_type) {
6124 case OP_CONST:
6125 if ( (curop->op_private & OPpCONST_BARE)
6126 && (curop->op_private & OPpCONST_STRICT)) {
6127 no_bareword_allowed(curop);
6128 goto nope;
6129 }
6130 /* FALLTHROUGH */
6131 case OP_LIST:
6132 case OP_SCALAR:
6133 case OP_NULL:
6134 case OP_PUSHMARK:
6135 /* Foldable; move to next op in list */
6136 break;
6137
6138 default:
6139 /* No other op types are considered foldable */
6140 goto nope;
6141 }
6142 }
6143
6144 curop = LINKLIST(o);
6145 old_next = o->op_next;
6146 o->op_next = 0;
6147 PL_op = curop;
6148
6149 old_cxix = cxstack_ix;
6150 create_eval_scope(NULL, G_FAKINGEVAL);
6151
6152 /* Verify that we don't need to save it: */
6153 assert(PL_curcop == &PL_compiling);
6154 StructCopy(&PL_compiling, ¬_compiling, COP);
6155 PL_curcop = ¬_compiling;
6156 /* The above ensures that we run with all the correct hints of the
6157 currently compiling COP, but that IN_PERL_RUNTIME is true. */
6158 assert(IN_PERL_RUNTIME);
6159 PL_warnhook = PERL_WARNHOOK_FATAL;
6160 PL_diehook = NULL;
6161
6162 /* Effective $^W=1. */
6163 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
6164 PL_dowarn |= G_WARN_ON;
6165
6166 ret = S_fold_constants_eval(aTHX);
6167
6168 switch (ret) {
6169 case 0:
6170 sv = *(PL_stack_sp--);
6171 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
6172 pad_swipe(o->op_targ, FALSE);
6173 }
6174 else if (SvTEMP(sv)) { /* grab mortal temp? */
6175 SvREFCNT_inc_simple_void(sv);
6176 SvTEMP_off(sv);
6177 }
6178 else { assert(SvIMMORTAL(sv)); }
6179 break;
6180 case 3:
6181 /* Something tried to die. Abandon constant folding. */
6182 /* Pretend the error never happened. */
6183 CLEAR_ERRSV();
6184 o->op_next = old_next;
6185 break;
6186 default:
6187 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
6188 PL_warnhook = oldwarnhook;
6189 PL_diehook = olddiehook;
6190 /* XXX note that this croak may fail as we've already blown away
6191 * the stack - eg any nested evals */
6192 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
6193 }
6194 PL_dowarn = oldwarn;
6195 PL_warnhook = oldwarnhook;
6196 PL_diehook = olddiehook;
6197 PL_curcop = &PL_compiling;
6198
6199 /* if we croaked, depending on how we croaked the eval scope
6200 * may or may not have already been popped */
6201 if (cxstack_ix > old_cxix) {
6202 assert(cxstack_ix == old_cxix + 1);
6203 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
6204 delete_eval_scope();
6205 }
6206 if (ret)
6207 goto nope;
6208
6209 /* OP_STRINGIFY and constant folding are used to implement qq.
6210 Here the constant folding is an implementation detail that we
6211 want to hide. If the stringify op is itself already marked
6212 folded, however, then it is actually a folded join. */
6213 is_stringify = type == OP_STRINGIFY && !o->op_folded;
6214 op_free(o);
6215 assert(sv);
6216 if (is_stringify)
6217 SvPADTMP_off(sv);
6218 else if (!SvIMMORTAL(sv)) {
6219 SvPADTMP_on(sv);
6220 SvREADONLY_on(sv);
6221 }
6222 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
6223 if (!is_stringify) newop->op_folded = 1;
6224 return newop;
6225
6226 nope:
6227 return o;
6228 }
6229
6230 /* convert a constant range in list context into an OP_RV2AV, OP_CONST pair;
6231 * the constant value being an AV holding the flattened range.
6232 */
6233
6234 static void
S_gen_constant_list(pTHX_ OP * o)6235 S_gen_constant_list(pTHX_ OP *o)
6236 {
6237 dVAR;
6238 OP *curop, *old_next;
6239 SV * const oldwarnhook = PL_warnhook;
6240 SV * const olddiehook = PL_diehook;
6241 COP *old_curcop;
6242 U8 oldwarn = PL_dowarn;
6243 SV **svp;
6244 AV *av;
6245 I32 old_cxix;
6246 COP not_compiling;
6247 int ret = 0;
6248 dJMPENV;
6249 bool op_was_null;
6250
6251 list(o);
6252 if (PL_parser && PL_parser->error_count)
6253 return; /* Don't attempt to run with errors */
6254
6255 curop = LINKLIST(o);
6256 old_next = o->op_next;
6257 o->op_next = 0;
6258 op_was_null = o->op_type == OP_NULL;
6259 if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
6260 o->op_type = OP_CUSTOM;
6261 CALL_PEEP(curop);
6262 if (op_was_null)
6263 o->op_type = OP_NULL;
6264 S_prune_chain_head(&curop);
6265 PL_op = curop;
6266
6267 old_cxix = cxstack_ix;
6268 create_eval_scope(NULL, G_FAKINGEVAL);
6269
6270 old_curcop = PL_curcop;
6271 StructCopy(old_curcop, ¬_compiling, COP);
6272 PL_curcop = ¬_compiling;
6273 /* The above ensures that we run with all the correct hints of the
6274 current COP, but that IN_PERL_RUNTIME is true. */
6275 assert(IN_PERL_RUNTIME);
6276 PL_warnhook = PERL_WARNHOOK_FATAL;
6277 PL_diehook = NULL;
6278 JMPENV_PUSH(ret);
6279
6280 /* Effective $^W=1. */
6281 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
6282 PL_dowarn |= G_WARN_ON;
6283
6284 switch (ret) {
6285 case 0:
6286 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
6287 PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
6288 #endif
6289 Perl_pp_pushmark(aTHX);
6290 CALLRUNOPS(aTHX);
6291 PL_op = curop;
6292 assert (!(curop->op_flags & OPf_SPECIAL));
6293 assert(curop->op_type == OP_RANGE);
6294 Perl_pp_anonlist(aTHX);
6295 break;
6296 case 3:
6297 CLEAR_ERRSV();
6298 o->op_next = old_next;
6299 break;
6300 default:
6301 JMPENV_POP;
6302 PL_warnhook = oldwarnhook;
6303 PL_diehook = olddiehook;
6304 Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
6305 ret);
6306 }
6307
6308 JMPENV_POP;
6309 PL_dowarn = oldwarn;
6310 PL_warnhook = oldwarnhook;
6311 PL_diehook = olddiehook;
6312 PL_curcop = old_curcop;
6313
6314 if (cxstack_ix > old_cxix) {
6315 assert(cxstack_ix == old_cxix + 1);
6316 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
6317 delete_eval_scope();
6318 }
6319 if (ret)
6320 return;
6321
6322 OpTYPE_set(o, OP_RV2AV);
6323 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
6324 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
6325 o->op_opt = 0; /* needs to be revisited in rpeep() */
6326 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
6327
6328 /* replace subtree with an OP_CONST */
6329 curop = ((UNOP*)o)->op_first;
6330 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
6331 op_free(curop);
6332
6333 if (AvFILLp(av) != -1)
6334 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
6335 {
6336 SvPADTMP_on(*svp);
6337 SvREADONLY_on(*svp);
6338 }
6339 LINKLIST(o);
6340 list(o);
6341 return;
6342 }
6343
6344 /*
6345 =head1 Optree Manipulation Functions
6346 */
6347
6348 /* List constructors */
6349
6350 /*
6351 =for apidoc op_append_elem
6352
6353 Append an item to the list of ops contained directly within a list-type
6354 op, returning the lengthened list. C<first> is the list-type op,
6355 and C<last> is the op to append to the list. C<optype> specifies the
6356 intended opcode for the list. If C<first> is not already a list of the
6357 right type, it will be upgraded into one. If either C<first> or C<last>
6358 is null, the other is returned unchanged.
6359
6360 =cut
6361 */
6362
6363 OP *
Perl_op_append_elem(pTHX_ I32 type,OP * first,OP * last)6364 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
6365 {
6366 if (!first)
6367 return last;
6368
6369 if (!last)
6370 return first;
6371
6372 if (first->op_type != (unsigned)type
6373 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
6374 {
6375 return newLISTOP(type, 0, first, last);
6376 }
6377
6378 op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
6379 first->op_flags |= OPf_KIDS;
6380 return first;
6381 }
6382
6383 /*
6384 =for apidoc op_append_list
6385
6386 Concatenate the lists of ops contained directly within two list-type ops,
6387 returning the combined list. C<first> and C<last> are the list-type ops
6388 to concatenate. C<optype> specifies the intended opcode for the list.
6389 If either C<first> or C<last> is not already a list of the right type,
6390 it will be upgraded into one. If either C<first> or C<last> is null,
6391 the other is returned unchanged.
6392
6393 =cut
6394 */
6395
6396 OP *
Perl_op_append_list(pTHX_ I32 type,OP * first,OP * last)6397 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
6398 {
6399 if (!first)
6400 return last;
6401
6402 if (!last)
6403 return first;
6404
6405 if (first->op_type != (unsigned)type)
6406 return op_prepend_elem(type, first, last);
6407
6408 if (last->op_type != (unsigned)type)
6409 return op_append_elem(type, first, last);
6410
6411 OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
6412 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
6413 OpLASTSIB_set(((LISTOP*)first)->op_last, first);
6414 first->op_flags |= (last->op_flags & OPf_KIDS);
6415
6416 S_op_destroy(aTHX_ last);
6417
6418 return first;
6419 }
6420
6421 /*
6422 =for apidoc op_prepend_elem
6423
6424 Prepend an item to the list of ops contained directly within a list-type
6425 op, returning the lengthened list. C<first> is the op to prepend to the
6426 list, and C<last> is the list-type op. C<optype> specifies the intended
6427 opcode for the list. If C<last> is not already a list of the right type,
6428 it will be upgraded into one. If either C<first> or C<last> is null,
6429 the other is returned unchanged.
6430
6431 =cut
6432 */
6433
6434 OP *
Perl_op_prepend_elem(pTHX_ I32 type,OP * first,OP * last)6435 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
6436 {
6437 if (!first)
6438 return last;
6439
6440 if (!last)
6441 return first;
6442
6443 if (last->op_type == (unsigned)type) {
6444 if (type == OP_LIST) { /* already a PUSHMARK there */
6445 /* insert 'first' after pushmark */
6446 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
6447 if (!(first->op_flags & OPf_PARENS))
6448 last->op_flags &= ~OPf_PARENS;
6449 }
6450 else
6451 op_sibling_splice(last, NULL, 0, first);
6452 last->op_flags |= OPf_KIDS;
6453 return last;
6454 }
6455
6456 return newLISTOP(type, 0, first, last);
6457 }
6458
6459 /*
6460 =for apidoc op_convert_list
6461
6462 Converts C<o> into a list op if it is not one already, and then converts it
6463 into the specified C<type>, calling its check function, allocating a target if
6464 it needs one, and folding constants.
6465
6466 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
6467 C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
6468 C<op_convert_list> to make it the right type.
6469
6470 =cut
6471 */
6472
6473 OP *
Perl_op_convert_list(pTHX_ I32 type,I32 flags,OP * o)6474 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
6475 {
6476 dVAR;
6477 if (type < 0) type = -type, flags |= OPf_SPECIAL;
6478 if (!o || o->op_type != OP_LIST)
6479 o = force_list(o, 0);
6480 else
6481 {
6482 o->op_flags &= ~OPf_WANT;
6483 o->op_private &= ~OPpLVAL_INTRO;
6484 }
6485
6486 if (!(PL_opargs[type] & OA_MARK))
6487 op_null(cLISTOPo->op_first);
6488 else {
6489 OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
6490 if (kid2 && kid2->op_type == OP_COREARGS) {
6491 op_null(cLISTOPo->op_first);
6492 kid2->op_private |= OPpCOREARGS_PUSHMARK;
6493 }
6494 }
6495
6496 if (type != OP_SPLIT)
6497 /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
6498 * ck_split() create a real PMOP and leave the op's type as listop
6499 * for now. Otherwise op_free() etc will crash.
6500 */
6501 OpTYPE_set(o, type);
6502
6503 o->op_flags |= flags;
6504 if (flags & OPf_FOLDED)
6505 o->op_folded = 1;
6506
6507 o = CHECKOP(type, o);
6508 if (o->op_type != (unsigned)type)
6509 return o;
6510
6511 return fold_constants(op_integerize(op_std_init(o)));
6512 }
6513
6514 /* Constructors */
6515
6516
6517 /*
6518 =head1 Optree construction
6519
6520 =for apidoc newNULLLIST
6521
6522 Constructs, checks, and returns a new C<stub> op, which represents an
6523 empty list expression.
6524
6525 =cut
6526 */
6527
6528 OP *
Perl_newNULLLIST(pTHX)6529 Perl_newNULLLIST(pTHX)
6530 {
6531 return newOP(OP_STUB, 0);
6532 }
6533
6534 /* promote o and any siblings to be a list if its not already; i.e.
6535 *
6536 * o - A - B
6537 *
6538 * becomes
6539 *
6540 * list
6541 * |
6542 * pushmark - o - A - B
6543 *
6544 * If nullit it true, the list op is nulled.
6545 */
6546
6547 static OP *
S_force_list(pTHX_ OP * o,bool nullit)6548 S_force_list(pTHX_ OP *o, bool nullit)
6549 {
6550 if (!o || o->op_type != OP_LIST) {
6551 OP *rest = NULL;
6552 if (o) {
6553 /* manually detach any siblings then add them back later */
6554 rest = OpSIBLING(o);
6555 OpLASTSIB_set(o, NULL);
6556 }
6557 o = newLISTOP(OP_LIST, 0, o, NULL);
6558 if (rest)
6559 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
6560 }
6561 if (nullit)
6562 op_null(o);
6563 return o;
6564 }
6565
6566 /*
6567 =for apidoc newLISTOP
6568
6569 Constructs, checks, and returns an op of any list type. C<type> is
6570 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
6571 C<OPf_KIDS> will be set automatically if required. C<first> and C<last>
6572 supply up to two ops to be direct children of the list op; they are
6573 consumed by this function and become part of the constructed op tree.
6574
6575 For most list operators, the check function expects all the kid ops to be
6576 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
6577 appropriate. What you want to do in that case is create an op of type
6578 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
6579 See L</op_convert_list> for more information.
6580
6581
6582 =cut
6583 */
6584
6585 OP *
Perl_newLISTOP(pTHX_ I32 type,I32 flags,OP * first,OP * last)6586 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6587 {
6588 dVAR;
6589 LISTOP *listop;
6590 /* Note that allocating an OP_PUSHMARK can die under Safe.pm if
6591 * pushmark is banned. So do it now while existing ops are in a
6592 * consistent state, in case they suddenly get freed */
6593 OP* const pushop = type == OP_LIST ? newOP(OP_PUSHMARK, 0) : NULL;
6594
6595 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
6596 || type == OP_CUSTOM);
6597
6598 NewOp(1101, listop, 1, LISTOP);
6599 OpTYPE_set(listop, type);
6600 if (first || last)
6601 flags |= OPf_KIDS;
6602 listop->op_flags = (U8)flags;
6603
6604 if (!last && first)
6605 last = first;
6606 else if (!first && last)
6607 first = last;
6608 else if (first)
6609 OpMORESIB_set(first, last);
6610 listop->op_first = first;
6611 listop->op_last = last;
6612
6613 if (pushop) {
6614 OpMORESIB_set(pushop, first);
6615 listop->op_first = pushop;
6616 listop->op_flags |= OPf_KIDS;
6617 if (!last)
6618 listop->op_last = pushop;
6619 }
6620 if (listop->op_last)
6621 OpLASTSIB_set(listop->op_last, (OP*)listop);
6622
6623 return CHECKOP(type, listop);
6624 }
6625
6626 /*
6627 =for apidoc newOP
6628
6629 Constructs, checks, and returns an op of any base type (any type that
6630 has no extra fields). C<type> is the opcode. C<flags> gives the
6631 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
6632 of C<op_private>.
6633
6634 =cut
6635 */
6636
6637 OP *
Perl_newOP(pTHX_ I32 type,I32 flags)6638 Perl_newOP(pTHX_ I32 type, I32 flags)
6639 {
6640 dVAR;
6641 OP *o;
6642
6643 if (type == -OP_ENTEREVAL) {
6644 type = OP_ENTEREVAL;
6645 flags |= OPpEVAL_BYTES<<8;
6646 }
6647
6648 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
6649 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6650 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6651 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6652
6653 NewOp(1101, o, 1, OP);
6654 OpTYPE_set(o, type);
6655 o->op_flags = (U8)flags;
6656
6657 o->op_next = o;
6658 o->op_private = (U8)(0 | (flags >> 8));
6659 if (PL_opargs[type] & OA_RETSCALAR)
6660 scalar(o);
6661 if (PL_opargs[type] & OA_TARGET)
6662 o->op_targ = pad_alloc(type, SVs_PADTMP);
6663 return CHECKOP(type, o);
6664 }
6665
6666 /*
6667 =for apidoc newUNOP
6668
6669 Constructs, checks, and returns an op of any unary type. C<type> is
6670 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
6671 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
6672 bits, the eight bits of C<op_private>, except that the bit with value 1
6673 is automatically set. C<first> supplies an optional op to be the direct
6674 child of the unary op; it is consumed by this function and become part
6675 of the constructed op tree.
6676
6677 =for apidoc Amnh||OPf_KIDS
6678
6679 =cut
6680 */
6681
6682 OP *
Perl_newUNOP(pTHX_ I32 type,I32 flags,OP * first)6683 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
6684 {
6685 dVAR;
6686 UNOP *unop;
6687
6688 if (type == -OP_ENTEREVAL) {
6689 type = OP_ENTEREVAL;
6690 flags |= OPpEVAL_BYTES<<8;
6691 }
6692
6693 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
6694 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6695 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6696 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
6697 || type == OP_SASSIGN
6698 || type == OP_ENTERTRY
6699 || type == OP_CUSTOM
6700 || type == OP_NULL );
6701
6702 if (!first)
6703 first = newOP(OP_STUB, 0);
6704 if (PL_opargs[type] & OA_MARK)
6705 first = force_list(first, 1);
6706
6707 NewOp(1101, unop, 1, UNOP);
6708 OpTYPE_set(unop, type);
6709 unop->op_first = first;
6710 unop->op_flags = (U8)(flags | OPf_KIDS);
6711 unop->op_private = (U8)(1 | (flags >> 8));
6712
6713 if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
6714 OpLASTSIB_set(first, (OP*)unop);
6715
6716 unop = (UNOP*) CHECKOP(type, unop);
6717 if (unop->op_next)
6718 return (OP*)unop;
6719
6720 return fold_constants(op_integerize(op_std_init((OP *) unop)));
6721 }
6722
6723 /*
6724 =for apidoc newUNOP_AUX
6725
6726 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
6727 initialised to C<aux>
6728
6729 =cut
6730 */
6731
6732 OP *
Perl_newUNOP_AUX(pTHX_ I32 type,I32 flags,OP * first,UNOP_AUX_item * aux)6733 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
6734 {
6735 dVAR;
6736 UNOP_AUX *unop;
6737
6738 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
6739 || type == OP_CUSTOM);
6740
6741 NewOp(1101, unop, 1, UNOP_AUX);
6742 unop->op_type = (OPCODE)type;
6743 unop->op_ppaddr = PL_ppaddr[type];
6744 unop->op_first = first;
6745 unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
6746 unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
6747 unop->op_aux = aux;
6748
6749 if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
6750 OpLASTSIB_set(first, (OP*)unop);
6751
6752 unop = (UNOP_AUX*) CHECKOP(type, unop);
6753
6754 return op_std_init((OP *) unop);
6755 }
6756
6757 /*
6758 =for apidoc newMETHOP
6759
6760 Constructs, checks, and returns an op of method type with a method name
6761 evaluated at runtime. C<type> is the opcode. C<flags> gives the eight
6762 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
6763 and, shifted up eight bits, the eight bits of C<op_private>, except that
6764 the bit with value 1 is automatically set. C<dynamic_meth> supplies an
6765 op which evaluates method name; it is consumed by this function and
6766 become part of the constructed op tree.
6767 Supported optypes: C<OP_METHOD>.
6768
6769 =cut
6770 */
6771
6772 static OP*
S_newMETHOP_internal(pTHX_ I32 type,I32 flags,OP * dynamic_meth,SV * const_meth)6773 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
6774 dVAR;
6775 METHOP *methop;
6776
6777 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
6778 || type == OP_CUSTOM);
6779
6780 NewOp(1101, methop, 1, METHOP);
6781 if (dynamic_meth) {
6782 if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
6783 methop->op_flags = (U8)(flags | OPf_KIDS);
6784 methop->op_u.op_first = dynamic_meth;
6785 methop->op_private = (U8)(1 | (flags >> 8));
6786
6787 if (!OpHAS_SIBLING(dynamic_meth))
6788 OpLASTSIB_set(dynamic_meth, (OP*)methop);
6789 }
6790 else {
6791 assert(const_meth);
6792 methop->op_flags = (U8)(flags & ~OPf_KIDS);
6793 methop->op_u.op_meth_sv = const_meth;
6794 methop->op_private = (U8)(0 | (flags >> 8));
6795 methop->op_next = (OP*)methop;
6796 }
6797
6798 #ifdef USE_ITHREADS
6799 methop->op_rclass_targ = 0;
6800 #else
6801 methop->op_rclass_sv = NULL;
6802 #endif
6803
6804 OpTYPE_set(methop, type);
6805 return CHECKOP(type, methop);
6806 }
6807
6808 OP *
Perl_newMETHOP(pTHX_ I32 type,I32 flags,OP * dynamic_meth)6809 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
6810 PERL_ARGS_ASSERT_NEWMETHOP;
6811 return newMETHOP_internal(type, flags, dynamic_meth, NULL);
6812 }
6813
6814 /*
6815 =for apidoc newMETHOP_named
6816
6817 Constructs, checks, and returns an op of method type with a constant
6818 method name. C<type> is the opcode. C<flags> gives the eight bits of
6819 C<op_flags>, and, shifted up eight bits, the eight bits of
6820 C<op_private>. C<const_meth> supplies a constant method name;
6821 it must be a shared COW string.
6822 Supported optypes: C<OP_METHOD_NAMED>.
6823
6824 =cut
6825 */
6826
6827 OP *
Perl_newMETHOP_named(pTHX_ I32 type,I32 flags,SV * const_meth)6828 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
6829 PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
6830 return newMETHOP_internal(type, flags, NULL, const_meth);
6831 }
6832
6833 /*
6834 =for apidoc newBINOP
6835
6836 Constructs, checks, and returns an op of any binary type. C<type>
6837 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
6838 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6839 the eight bits of C<op_private>, except that the bit with value 1 or
6840 2 is automatically set as required. C<first> and C<last> supply up to
6841 two ops to be the direct children of the binary op; they are consumed
6842 by this function and become part of the constructed op tree.
6843
6844 =cut
6845 */
6846
6847 OP *
Perl_newBINOP(pTHX_ I32 type,I32 flags,OP * first,OP * last)6848 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6849 {
6850 dVAR;
6851 BINOP *binop;
6852
6853 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
6854 || type == OP_NULL || type == OP_CUSTOM);
6855
6856 NewOp(1101, binop, 1, BINOP);
6857
6858 if (!first)
6859 first = newOP(OP_NULL, 0);
6860
6861 OpTYPE_set(binop, type);
6862 binop->op_first = first;
6863 binop->op_flags = (U8)(flags | OPf_KIDS);
6864 if (!last) {
6865 last = first;
6866 binop->op_private = (U8)(1 | (flags >> 8));
6867 }
6868 else {
6869 binop->op_private = (U8)(2 | (flags >> 8));
6870 OpMORESIB_set(first, last);
6871 }
6872
6873 if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
6874 OpLASTSIB_set(last, (OP*)binop);
6875
6876 binop->op_last = OpSIBLING(binop->op_first);
6877 if (binop->op_last)
6878 OpLASTSIB_set(binop->op_last, (OP*)binop);
6879
6880 binop = (BINOP*)CHECKOP(type, binop);
6881 if (binop->op_next || binop->op_type != (OPCODE)type)
6882 return (OP*)binop;
6883
6884 return fold_constants(op_integerize(op_std_init((OP *)binop)));
6885 }
6886
6887 void
Perl_invmap_dump(pTHX_ SV * invlist,UV * map)6888 Perl_invmap_dump(pTHX_ SV* invlist, UV *map)
6889 {
6890 const char indent[] = " ";
6891
6892 UV len = _invlist_len(invlist);
6893 UV * array = invlist_array(invlist);
6894 UV i;
6895
6896 PERL_ARGS_ASSERT_INVMAP_DUMP;
6897
6898 for (i = 0; i < len; i++) {
6899 UV start = array[i];
6900 UV end = (i + 1 < len) ? array[i+1] - 1 : IV_MAX;
6901
6902 PerlIO_printf(Perl_debug_log, "%s[%" UVuf "] 0x%04" UVXf, indent, i, start);
6903 if (end == IV_MAX) {
6904 PerlIO_printf(Perl_debug_log, " .. INFTY");
6905 }
6906 else if (end != start) {
6907 PerlIO_printf(Perl_debug_log, " .. 0x%04" UVXf, end);
6908 }
6909 else {
6910 PerlIO_printf(Perl_debug_log, " ");
6911 }
6912
6913 PerlIO_printf(Perl_debug_log, "\t");
6914
6915 if (map[i] == TR_UNLISTED) {
6916 PerlIO_printf(Perl_debug_log, "TR_UNLISTED\n");
6917 }
6918 else if (map[i] == TR_SPECIAL_HANDLING) {
6919 PerlIO_printf(Perl_debug_log, "TR_SPECIAL_HANDLING\n");
6920 }
6921 else {
6922 PerlIO_printf(Perl_debug_log, "0x%04" UVXf "\n", map[i]);
6923 }
6924 }
6925 }
6926
6927 /* Given an OP_TRANS / OP_TRANSR op o, plus OP_CONST ops expr and repl
6928 * containing the search and replacement strings, assemble into
6929 * a translation table attached as o->op_pv.
6930 * Free expr and repl.
6931 * It expects the toker to have already set the
6932 * OPpTRANS_COMPLEMENT
6933 * OPpTRANS_SQUASH
6934 * OPpTRANS_DELETE
6935 * flags as appropriate; this function may add
6936 * OPpTRANS_USE_SVOP
6937 * OPpTRANS_CAN_FORCE_UTF8
6938 * OPpTRANS_IDENTICAL
6939 * OPpTRANS_GROWS
6940 * flags
6941 */
6942
6943 static OP *
S_pmtrans(pTHX_ OP * o,OP * expr,OP * repl)6944 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
6945 {
6946 /* This function compiles a tr///, from data gathered from toke.c, into a
6947 * form suitable for use by do_trans() in doop.c at runtime.
6948 *
6949 * It first normalizes the data, while discarding extraneous inputs; then
6950 * writes out the compiled data. The normalization allows for complete
6951 * analysis, and avoids some false negatives and positives earlier versions
6952 * of this code had.
6953 *
6954 * The normalization form is an inversion map (described below in detail).
6955 * This is essentially the compiled form for tr///'s that require UTF-8,
6956 * and its easy to use it to write the 257-byte table for tr///'s that
6957 * don't need UTF-8. That table is identical to what's been in use for
6958 * many perl versions, except that it doesn't handle some edge cases that
6959 * it used to, involving code points above 255. The UTF-8 form now handles
6960 * these. (This could be changed with extra coding should it shown to be
6961 * desirable.)
6962 *
6963 * If the complement (/c) option is specified, the lhs string (tstr) is
6964 * parsed into an inversion list. Complementing these is trivial. Then a
6965 * complemented tstr is built from that, and used thenceforth. This hides
6966 * the fact that it was complemented from almost all successive code.
6967 *
6968 * One of the important characteristics to know about the input is whether
6969 * the transliteration may be done in place, or does a temporary need to be
6970 * allocated, then copied. If the replacement for every character in every
6971 * possible string takes up no more bytes than the character it
6972 * replaces, then it can be edited in place. Otherwise the replacement
6973 * could overwrite a byte we are about to read, depending on the strings
6974 * being processed. The comments and variable names here refer to this as
6975 * "growing". Some inputs won't grow, and might even shrink under /d, but
6976 * some inputs could grow, so we have to assume any given one might grow.
6977 * On very long inputs, the temporary could eat up a lot of memory, so we
6978 * want to avoid it if possible. For non-UTF-8 inputs, everything is
6979 * single-byte, so can be edited in place, unless there is something in the
6980 * pattern that could force it into UTF-8. The inversion map makes it
6981 * feasible to determine this. Previous versions of this code pretty much
6982 * punted on determining if UTF-8 could be edited in place. Now, this code
6983 * is rigorous in making that determination.
6984 *
6985 * Another characteristic we need to know is whether the lhs and rhs are
6986 * identical. If so, and no other flags are present, the only effect of
6987 * the tr/// is to count the characters present in the input that are
6988 * mentioned in the lhs string. The implementation of that is easier and
6989 * runs faster than the more general case. Normalizing here allows for
6990 * accurate determination of this. Previously there were false negatives
6991 * possible.
6992 *
6993 * Instead of 'transliterated', the comments here use 'unmapped' for the
6994 * characters that are left unchanged by the operation; otherwise they are
6995 * 'mapped'
6996 *
6997 * The lhs of the tr/// is here referred to as the t side.
6998 * The rhs of the tr/// is here referred to as the r side.
6999 */
7000
7001 SV * const tstr = ((SVOP*)expr)->op_sv;
7002 SV * const rstr = ((SVOP*)repl)->op_sv;
7003 STRLEN tlen;
7004 STRLEN rlen;
7005 const U8 * t0 = (U8*)SvPV_const(tstr, tlen);
7006 const U8 * r0 = (U8*)SvPV_const(rstr, rlen);
7007 const U8 * t = t0;
7008 const U8 * r = r0;
7009 UV t_count = 0, r_count = 0; /* Number of characters in search and
7010 replacement lists */
7011
7012 /* khw thinks some of the private flags for this op are quaintly named.
7013 * OPpTRANS_GROWS for example is TRUE if the replacement for some lhs
7014 * character when represented in UTF-8 is longer than the original
7015 * character's UTF-8 representation */
7016 const bool complement = cBOOL(o->op_private & OPpTRANS_COMPLEMENT);
7017 const bool squash = cBOOL(o->op_private & OPpTRANS_SQUASH);
7018 const bool del = cBOOL(o->op_private & OPpTRANS_DELETE);
7019
7020 /* Set to true if there is some character < 256 in the lhs that maps to
7021 * above 255. If so, a non-UTF-8 match string can be forced into being in
7022 * UTF-8 by a tr/// operation. */
7023 bool can_force_utf8 = FALSE;
7024
7025 /* What is the maximum expansion factor in UTF-8 transliterations. If a
7026 * 2-byte UTF-8 encoded character is to be replaced by a 3-byte one, its
7027 * expansion factor is 1.5. This number is used at runtime to calculate
7028 * how much space to allocate for non-inplace transliterations. Without
7029 * this number, the worst case is 14, which is extremely unlikely to happen
7030 * in real life, and could require significant memory overhead. */
7031 NV max_expansion = 1.;
7032
7033 UV t_range_count, r_range_count, min_range_count;
7034 UV* t_array;
7035 SV* t_invlist;
7036 UV* r_map;
7037 UV r_cp, t_cp;
7038 UV t_cp_end = (UV) -1;
7039 UV r_cp_end;
7040 Size_t len;
7041 AV* invmap;
7042 UV final_map = TR_UNLISTED; /* The final character in the replacement
7043 list, updated as we go along. Initialize
7044 to something illegal */
7045
7046 bool rstr_utf8 = cBOOL(SvUTF8(rstr));
7047 bool tstr_utf8 = cBOOL(SvUTF8(tstr));
7048
7049 const U8* tend = t + tlen;
7050 const U8* rend = r + rlen;
7051
7052 SV * inverted_tstr = NULL;
7053
7054 Size_t i;
7055 unsigned int pass2;
7056
7057 /* This routine implements detection of a transliteration having a longer
7058 * UTF-8 representation than its source, by partitioning all the possible
7059 * code points of the platform into equivalence classes of the same UTF-8
7060 * byte length in the first pass. As it constructs the mappings, it carves
7061 * these up into smaller chunks, but doesn't merge any together. This
7062 * makes it easy to find the instances it's looking for. A second pass is
7063 * done after this has been determined which merges things together to
7064 * shrink the table for runtime. The table below is used for both ASCII
7065 * and EBCDIC platforms. On EBCDIC, the byte length is not monotonically
7066 * increasing for code points below 256. To correct for that, the macro
7067 * CP_ADJUST defined below converts those code points to ASCII in the first
7068 * pass, and we use the ASCII partition values. That works because the
7069 * growth factor will be unaffected, which is all that is calculated during
7070 * the first pass. */
7071 UV PL_partition_by_byte_length[] = {
7072 0,
7073 0x80, /* Below this is 1 byte representations */
7074 (32 * (1UL << ( UTF_ACCUMULATION_SHIFT))), /* 2 bytes below this */
7075 (16 * (1UL << (2 * UTF_ACCUMULATION_SHIFT))), /* 3 bytes below this */
7076 ( 8 * (1UL << (3 * UTF_ACCUMULATION_SHIFT))), /* 4 bytes below this */
7077 ( 4 * (1UL << (4 * UTF_ACCUMULATION_SHIFT))), /* 5 bytes below this */
7078 ( 2 * (1UL << (5 * UTF_ACCUMULATION_SHIFT))) /* 6 bytes below this */
7079
7080 # ifdef UV_IS_QUAD
7081 ,
7082 ( ((UV) 1U << (6 * UTF_ACCUMULATION_SHIFT))) /* 7 bytes below this */
7083 # endif
7084
7085 };
7086
7087 PERL_ARGS_ASSERT_PMTRANS;
7088
7089 PL_hints |= HINT_BLOCK_SCOPE;
7090
7091 /* If /c, the search list is sorted and complemented. This is now done by
7092 * creating an inversion list from it, and then trivially inverting that.
7093 * The previous implementation used qsort, but creating the list
7094 * automatically keeps it sorted as we go along */
7095 if (complement) {
7096 UV start, end;
7097 SV * inverted_tlist = _new_invlist(tlen);
7098 Size_t temp_len;
7099
7100 DEBUG_y(PerlIO_printf(Perl_debug_log,
7101 "%s: %d: tstr before inversion=\n%s\n",
7102 __FILE__, __LINE__, _byte_dump_string(t, tend - t, 0)));
7103
7104 while (t < tend) {
7105
7106 /* Non-utf8 strings don't have ranges, so each character is listed
7107 * out */
7108 if (! tstr_utf8) {
7109 inverted_tlist = add_cp_to_invlist(inverted_tlist, *t);
7110 t++;
7111 }
7112 else { /* But UTF-8 strings have been parsed in toke.c to have
7113 * ranges if appropriate. */
7114 UV t_cp;
7115 Size_t t_char_len;
7116
7117 /* Get the first character */
7118 t_cp = valid_utf8_to_uvchr(t, &t_char_len);
7119 t += t_char_len;
7120
7121 /* If the next byte indicates that this wasn't the first
7122 * element of a range, the range is just this one */
7123 if (t >= tend || *t != RANGE_INDICATOR) {
7124 inverted_tlist = add_cp_to_invlist(inverted_tlist, t_cp);
7125 }
7126 else { /* Otherwise, ignore the indicator byte, and get the
7127 final element, and add the whole range */
7128 t++;
7129 t_cp_end = valid_utf8_to_uvchr(t, &t_char_len);
7130 t += t_char_len;
7131
7132 inverted_tlist = _add_range_to_invlist(inverted_tlist,
7133 t_cp, t_cp_end);
7134 }
7135 }
7136 } /* End of parse through tstr */
7137
7138 /* The inversion list is done; now invert it */
7139 _invlist_invert(inverted_tlist);
7140
7141 /* Now go through the inverted list and create a new tstr for the rest
7142 * of the routine to use. Since the UTF-8 version can have ranges, and
7143 * can be much more compact than the non-UTF-8 version, we create the
7144 * string in UTF-8 even if not necessary. (This is just an intermediate
7145 * value that gets thrown away anyway.) */
7146 invlist_iterinit(inverted_tlist);
7147 inverted_tstr = newSVpvs("");
7148 while (invlist_iternext(inverted_tlist, &start, &end)) {
7149 U8 temp[UTF8_MAXBYTES];
7150 U8 * temp_end_pos;
7151
7152 /* IV_MAX keeps things from going out of bounds */
7153 start = MIN(IV_MAX, start);
7154 end = MIN(IV_MAX, end);
7155
7156 temp_end_pos = uvchr_to_utf8(temp, start);
7157 sv_catpvn(inverted_tstr, (char *) temp, temp_end_pos - temp);
7158
7159 if (start != end) {
7160 Perl_sv_catpvf(aTHX_ inverted_tstr, "%c", RANGE_INDICATOR);
7161 temp_end_pos = uvchr_to_utf8(temp, end);
7162 sv_catpvn(inverted_tstr, (char *) temp, temp_end_pos - temp);
7163 }
7164 }
7165
7166 /* Set up so the remainder of the routine uses this complement, instead
7167 * of the actual input */
7168 t0 = t = (U8*)SvPV_const(inverted_tstr, temp_len);
7169 tend = t0 + temp_len;
7170 tstr_utf8 = TRUE;
7171
7172 SvREFCNT_dec_NN(inverted_tlist);
7173 }
7174
7175 /* For non-/d, an empty rhs means to use the lhs */
7176 if (rlen == 0 && ! del) {
7177 r0 = t0;
7178 rend = tend;
7179 rstr_utf8 = tstr_utf8;
7180 }
7181
7182 t_invlist = _new_invlist(1);
7183
7184 /* Initialize to a single range */
7185 t_invlist = _add_range_to_invlist(t_invlist, 0, UV_MAX);
7186
7187 /* For the first pass, the lhs is partitioned such that the
7188 * number of UTF-8 bytes required to represent a code point in each
7189 * partition is the same as the number for any other code point in
7190 * that partion. We copy the pre-compiled partion. */
7191 len = C_ARRAY_LENGTH(PL_partition_by_byte_length);
7192 invlist_extend(t_invlist, len);
7193 t_array = invlist_array(t_invlist);
7194 Copy(PL_partition_by_byte_length, t_array, len, UV);
7195 invlist_set_len(t_invlist, len, *(get_invlist_offset_addr(t_invlist)));
7196 Newx(r_map, len + 1, UV);
7197
7198 /* Parse the (potentially adjusted) input, creating the inversion map.
7199 * This is done in two passes. The first pass is to determine if the
7200 * transliteration can be done in place. The inversion map it creates
7201 * could be used, but generally would be larger and slower to run than the
7202 * output of the second pass, which starts with a more compact table and
7203 * allows more ranges to be merged */
7204 for (pass2 = 0; pass2 < 2; pass2++) {
7205 if (pass2) {
7206 /* Initialize to a single range */
7207 t_invlist = _add_range_to_invlist(t_invlist, 0, UV_MAX);
7208
7209 /* In the second pass, we just have the single range */
7210 len = 1;
7211 t_array = invlist_array(t_invlist);
7212 }
7213
7214 /* As noted earlier, we convert EBCDIC code points to Unicode in the first pass
7215 * so as to get the well-behaved length 1 vs length 2 boundary. Only code
7216 * points below 256 differ between the two character sets in this regard. For
7217 * these, we also can't have any ranges, as they have to be individually
7218 * converted. */
7219 #ifdef EBCDIC
7220 # define CP_ADJUST(x) ((pass2) ? (x) : NATIVE_TO_UNI(x))
7221 # define FORCE_RANGE_LEN_1(x) ((pass2) ? 0 : ((x) < 256))
7222 # define CP_SKIP(x) ((pass2) ? UVCHR_SKIP(x) : OFFUNISKIP(x))
7223 #else
7224 # define CP_ADJUST(x) (x)
7225 # define FORCE_RANGE_LEN_1(x) 0
7226 # define CP_SKIP(x) UVCHR_SKIP(x)
7227 #endif
7228
7229 /* And the mapping of each of the ranges is initialized. Initially,
7230 * everything is TR_UNLISTED. */
7231 for (i = 0; i < len; i++) {
7232 r_map[i] = TR_UNLISTED;
7233 }
7234
7235 t = t0;
7236 t_count = 0;
7237 r = r0;
7238 r_count = 0;
7239 t_range_count = r_range_count = 0;
7240
7241 DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d:\ntstr=%s\n",
7242 __FILE__, __LINE__, _byte_dump_string(t, tend - t, 0)));
7243 DEBUG_y(PerlIO_printf(Perl_debug_log, "rstr=%s\n",
7244 _byte_dump_string(r, rend - r, 0)));
7245 DEBUG_y(PerlIO_printf(Perl_debug_log, "/c=%d; /s=%d; /d=%d\n",
7246 complement, squash, del));
7247 DEBUG_y(invmap_dump(t_invlist, r_map));
7248
7249 /* Now go through the search list constructing an inversion map. The
7250 * input is not necessarily in any particular order. Making it an
7251 * inversion map orders it, potentially simplifying, and makes it easy
7252 * to deal with at run time. This is the only place in core that
7253 * generates an inversion map; if others were introduced, it might be
7254 * better to create general purpose routines to handle them.
7255 * (Inversion maps are created in perl in other places.)
7256 *
7257 * An inversion map consists of two parallel arrays. One is
7258 * essentially an inversion list: an ordered list of code points such
7259 * that each element gives the first code point of a range of
7260 * consecutive code points that map to the element in the other array
7261 * that has the same index as this one (in other words, the
7262 * corresponding element). Thus the range extends up to (but not
7263 * including) the code point given by the next higher element. In a
7264 * true inversion map, the corresponding element in the other array
7265 * gives the mapping of the first code point in the range, with the
7266 * understanding that the next higher code point in the inversion
7267 * list's range will map to the next higher code point in the map.
7268 *
7269 * So if at element [i], let's say we have:
7270 *
7271 * t_invlist r_map
7272 * [i] A a
7273 *
7274 * This means that A => a, B => b, C => c.... Let's say that the
7275 * situation is such that:
7276 *
7277 * [i+1] L -1
7278 *
7279 * This means the sequence that started at [i] stops at K => k. This
7280 * illustrates that you need to look at the next element to find where
7281 * a sequence stops. Except, the highest element in the inversion list
7282 * begins a range that is understood to extend to the platform's
7283 * infinity.
7284 *
7285 * This routine modifies traditional inversion maps to reserve two
7286 * mappings:
7287 *
7288 * TR_UNLISTED (or -1) indicates that no code point in the range
7289 * is listed in the tr/// searchlist. At runtime, these are
7290 * always passed through unchanged. In the inversion map, all
7291 * points in the range are mapped to -1, instead of increasing,
7292 * like the 'L' in the example above.
7293 *
7294 * We start the parse with every code point mapped to this, and as
7295 * we parse and find ones that are listed in the search list, we
7296 * carve out ranges as we go along that override that.
7297 *
7298 * TR_SPECIAL_HANDLING (or -2) indicates that every code point in the
7299 * range needs special handling. Again, all code points in the
7300 * range are mapped to -2, instead of increasing.
7301 *
7302 * Under /d this value means the code point should be deleted from
7303 * the transliteration when encountered.
7304 *
7305 * Otherwise, it marks that every code point in the range is to
7306 * map to the final character in the replacement list. This
7307 * happens only when the replacement list is shorter than the
7308 * search one, so there are things in the search list that have no
7309 * correspondence in the replacement list. For example, in
7310 * tr/a-z/A/, 'A' is the final value, and the inversion map
7311 * generated for this would be like this:
7312 * \0 => -1
7313 * a => A
7314 * b-z => -2
7315 * z+1 => -1
7316 * 'A' appears once, then the remainder of the range maps to -2.
7317 * The use of -2 isn't strictly necessary, as an inversion map is
7318 * capable of representing this situation, but not nearly so
7319 * compactly, and this is actually quite commonly encountered.
7320 * Indeed, the original design of this code used a full inversion
7321 * map for this. But things like
7322 * tr/\0-\x{FFFF}/A/
7323 * generated huge data structures, slowly, and the execution was
7324 * also slow. So the current scheme was implemented.
7325 *
7326 * So, if the next element in our example is:
7327 *
7328 * [i+2] Q q
7329 *
7330 * Then all of L, M, N, O, and P map to TR_UNLISTED. If the next
7331 * elements are
7332 *
7333 * [i+3] R z
7334 * [i+4] S TR_UNLISTED
7335 *
7336 * Then Q => q; R => z; and S => TR_UNLISTED. If [i+4] (the 'S') is
7337 * the final element in the arrays, every code point from S to infinity
7338 * maps to TR_UNLISTED.
7339 *
7340 */
7341 /* Finish up range started in what otherwise would
7342 * have been the final iteration */
7343 while (t < tend || t_range_count > 0) {
7344 bool adjacent_to_range_above = FALSE;
7345 bool adjacent_to_range_below = FALSE;
7346
7347 bool merge_with_range_above = FALSE;
7348 bool merge_with_range_below = FALSE;
7349
7350 UV span, invmap_range_length_remaining;
7351 SSize_t j;
7352 Size_t i;
7353
7354 /* If we are in the middle of processing a range in the 'target'
7355 * side, the previous iteration has set us up. Otherwise, look at
7356 * the next character in the search list */
7357 if (t_range_count <= 0) {
7358 if (! tstr_utf8) {
7359
7360 /* Here, not in the middle of a range, and not UTF-8. The
7361 * next code point is the single byte where we're at */
7362 t_cp = CP_ADJUST(*t);
7363 t_range_count = 1;
7364 t++;
7365 }
7366 else {
7367 Size_t t_char_len;
7368
7369 /* Here, not in the middle of a range, and is UTF-8. The
7370 * next code point is the next UTF-8 char in the input. We
7371 * know the input is valid, because the toker constructed
7372 * it */
7373 t_cp = CP_ADJUST(valid_utf8_to_uvchr(t, &t_char_len));
7374 t += t_char_len;
7375
7376 /* UTF-8 strings (only) have been parsed in toke.c to have
7377 * ranges. See if the next byte indicates that this was
7378 * the first element of a range. If so, get the final
7379 * element and calculate the range size. If not, the range
7380 * size is 1 */
7381 if ( t < tend && *t == RANGE_INDICATOR
7382 && ! FORCE_RANGE_LEN_1(t_cp))
7383 {
7384 t++;
7385 t_range_count = valid_utf8_to_uvchr(t, &t_char_len)
7386 - t_cp + 1;
7387 t += t_char_len;
7388 }
7389 else {
7390 t_range_count = 1;
7391 }
7392 }
7393
7394 /* Count the total number of listed code points * */
7395 t_count += t_range_count;
7396 }
7397
7398 /* Similarly, get the next character in the replacement list */
7399 if (r_range_count <= 0) {
7400 if (r >= rend) {
7401
7402 /* But if we've exhausted the rhs, there is nothing to map
7403 * to, except the special handling one, and we make the
7404 * range the same size as the lhs one. */
7405 r_cp = TR_SPECIAL_HANDLING;
7406 r_range_count = t_range_count;
7407
7408 if (! del) {
7409 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7410 "final_map =%" UVXf "\n", final_map));
7411 }
7412 }
7413 else {
7414 if (! rstr_utf8) {
7415 r_cp = CP_ADJUST(*r);
7416 r_range_count = 1;
7417 r++;
7418 }
7419 else {
7420 Size_t r_char_len;
7421
7422 r_cp = CP_ADJUST(valid_utf8_to_uvchr(r, &r_char_len));
7423 r += r_char_len;
7424 if ( r < rend && *r == RANGE_INDICATOR
7425 && ! FORCE_RANGE_LEN_1(r_cp))
7426 {
7427 r++;
7428 r_range_count = valid_utf8_to_uvchr(r,
7429 &r_char_len) - r_cp + 1;
7430 r += r_char_len;
7431 }
7432 else {
7433 r_range_count = 1;
7434 }
7435 }
7436
7437 if (r_cp == TR_SPECIAL_HANDLING) {
7438 r_range_count = t_range_count;
7439 }
7440
7441 /* This is the final character so far */
7442 final_map = r_cp + r_range_count - 1;
7443
7444 r_count += r_range_count;
7445 }
7446 }
7447
7448 /* Here, we have the next things ready in both sides. They are
7449 * potentially ranges. We try to process as big a chunk as
7450 * possible at once, but the lhs and rhs must be synchronized, so
7451 * things like tr/A-Z/a-ij-z/ will need to be processed in 2 chunks
7452 * */
7453 min_range_count = MIN(t_range_count, r_range_count);
7454
7455 /* Search the inversion list for the entry that contains the input
7456 * code point <cp>. The inversion map was initialized to cover the
7457 * entire range of possible inputs, so this should not fail. So
7458 * the return value is the index into the list's array of the range
7459 * that contains <cp>, that is, 'i' such that array[i] <= cp <
7460 * array[i+1] */
7461 j = _invlist_search(t_invlist, t_cp);
7462 assert(j >= 0);
7463 i = j;
7464
7465 /* Here, the data structure might look like:
7466 *
7467 * index t r Meaning
7468 * [i-1] J j # J-L => j-l
7469 * [i] M -1 # M => default; as do N, O, P, Q
7470 * [i+1] R x # R => x, S => x+1, T => x+2
7471 * [i+2] U y # U => y, V => y+1, ...
7472 * ...
7473 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7474 *
7475 * where 'x' and 'y' above are not to be taken literally.
7476 *
7477 * The maximum chunk we can handle in this loop iteration, is the
7478 * smallest of the three components: the lhs 't_', the rhs 'r_',
7479 * and the remainder of the range in element [i]. (In pass 1, that
7480 * range will have everything in it be of the same class; we can't
7481 * cross into another class.) 'min_range_count' already contains
7482 * the smallest of the first two values. The final one is
7483 * irrelevant if the map is to the special indicator */
7484
7485 invmap_range_length_remaining = (i + 1 < len)
7486 ? t_array[i+1] - t_cp
7487 : IV_MAX - t_cp;
7488 span = MAX(1, MIN(min_range_count, invmap_range_length_remaining));
7489
7490 /* The end point of this chunk is where we are, plus the span, but
7491 * never larger than the platform's infinity */
7492 t_cp_end = MIN(IV_MAX, t_cp + span - 1);
7493
7494 if (r_cp == TR_SPECIAL_HANDLING) {
7495
7496 /* If unmatched lhs code points map to the final map, use that
7497 * value. This being set to TR_SPECIAL_HANDLING indicates that
7498 * we don't have a final map: unmatched lhs code points are
7499 * simply deleted */
7500 r_cp_end = (del) ? TR_SPECIAL_HANDLING : final_map;
7501 }
7502 else {
7503 r_cp_end = MIN(IV_MAX, r_cp + span - 1);
7504
7505 /* If something on the lhs is below 256, and something on the
7506 * rhs is above, there is a potential mapping here across that
7507 * boundary. Indeed the only way there isn't is if both sides
7508 * start at the same point. That means they both cross at the
7509 * same time. But otherwise one crosses before the other */
7510 if (t_cp < 256 && r_cp_end > 255 && r_cp != t_cp) {
7511 can_force_utf8 = TRUE;
7512 }
7513 }
7514
7515 /* If a character appears in the search list more than once, the
7516 * 2nd and succeeding occurrences are ignored, so only do this
7517 * range if haven't already processed this character. (The range
7518 * has been set up so that all members in it will be of the same
7519 * ilk) */
7520 if (r_map[i] == TR_UNLISTED) {
7521 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7522 "Processing %" UVxf "-%" UVxf " => %" UVxf "-%" UVxf "\n",
7523 t_cp, t_cp_end, r_cp, r_cp_end));
7524
7525 /* This is the first definition for this chunk, hence is valid
7526 * and needs to be processed. Here and in the comments below,
7527 * we use the above sample data. The t_cp chunk must be any
7528 * contiguous subset of M, N, O, P, and/or Q.
7529 *
7530 * In the first pass, calculate if there is any possible input
7531 * string that has a character whose transliteration will be
7532 * longer than it. If none, the transliteration may be done
7533 * in-place, as it can't write over a so-far unread byte.
7534 * Otherwise, a copy must first be made. This could be
7535 * expensive for long inputs.
7536 *
7537 * In the first pass, the t_invlist has been partitioned so
7538 * that all elements in any single range have the same number
7539 * of bytes in their UTF-8 representations. And the r space is
7540 * either a single byte, or a range of strictly monotonically
7541 * increasing code points. So the final element in the range
7542 * will be represented by no fewer bytes than the initial one.
7543 * That means that if the final code point in the t range has
7544 * at least as many bytes as the final code point in the r,
7545 * then all code points in the t range have at least as many
7546 * bytes as their corresponding r range element. But if that's
7547 * not true, the transliteration of at least the final code
7548 * point grows in length. As an example, suppose we had
7549 * tr/\x{fff0}-\x{fff1}/\x{ffff}-\x{10000}/
7550 * The UTF-8 for all but 10000 occupies 3 bytes on ASCII
7551 * platforms. We have deliberately set up the data structure
7552 * so that any range in the lhs gets split into chunks for
7553 * processing, such that every code point in a chunk has the
7554 * same number of UTF-8 bytes. We only have to check the final
7555 * code point in the rhs against any code point in the lhs. */
7556 if ( ! pass2
7557 && r_cp_end != TR_SPECIAL_HANDLING
7558 && CP_SKIP(t_cp_end) < CP_SKIP(r_cp_end))
7559 {
7560 /* Here, we will need to make a copy of the input string
7561 * before doing the transliteration. The worst possible
7562 * case is an expansion ratio of 14:1. This is rare, and
7563 * we'd rather allocate only the necessary amount of extra
7564 * memory for that copy. We can calculate the worst case
7565 * for this particular transliteration is by keeping track
7566 * of the expansion factor for each range.
7567 *
7568 * Consider tr/\xCB/\X{E000}/. The maximum expansion
7569 * factor is 1 byte going to 3 if the target string is not
7570 * UTF-8, but 2 bytes going to 3 if it is in UTF-8. We
7571 * could pass two different values so doop could choose
7572 * based on the UTF-8ness of the target. But khw thinks
7573 * (perhaps wrongly) that is overkill. It is used only to
7574 * make sure we malloc enough space.
7575 *
7576 * If no target string can force the result to be UTF-8,
7577 * then we don't have to worry about the case of the target
7578 * string not being UTF-8 */
7579 NV t_size = (can_force_utf8 && t_cp < 256)
7580 ? 1
7581 : CP_SKIP(t_cp_end);
7582 NV ratio = CP_SKIP(r_cp_end) / t_size;
7583
7584 o->op_private |= OPpTRANS_GROWS;
7585
7586 /* Now that we know it grows, we can keep track of the
7587 * largest ratio */
7588 if (ratio > max_expansion) {
7589 max_expansion = ratio;
7590 DEBUG_y(PerlIO_printf(Perl_debug_log,
7591 "New expansion factor: %" NVgf "\n",
7592 max_expansion));
7593 }
7594 }
7595
7596 /* The very first range is marked as adjacent to the
7597 * non-existent range below it, as it causes things to "just
7598 * work" (TradeMark)
7599 *
7600 * If the lowest code point in this chunk is M, it adjoins the
7601 * J-L range */
7602 if (t_cp == t_array[i]) {
7603 adjacent_to_range_below = TRUE;
7604
7605 /* And if the map has the same offset from the beginning of
7606 * the range as does this new code point (or both are for
7607 * TR_SPECIAL_HANDLING), this chunk can be completely
7608 * merged with the range below. EXCEPT, in the first pass,
7609 * we don't merge ranges whose UTF-8 byte representations
7610 * have different lengths, so that we can more easily
7611 * detect if a replacement is longer than the source, that
7612 * is if it 'grows'. But in the 2nd pass, there's no
7613 * reason to not merge */
7614 if ( (i > 0 && ( pass2
7615 || CP_SKIP(t_array[i-1])
7616 == CP_SKIP(t_cp)))
7617 && ( ( r_cp == TR_SPECIAL_HANDLING
7618 && r_map[i-1] == TR_SPECIAL_HANDLING)
7619 || ( r_cp != TR_SPECIAL_HANDLING
7620 && r_cp - r_map[i-1] == t_cp - t_array[i-1])))
7621 {
7622 merge_with_range_below = TRUE;
7623 }
7624 }
7625
7626 /* Similarly, if the highest code point in this chunk is 'Q',
7627 * it adjoins the range above, and if the map is suitable, can
7628 * be merged with it */
7629 if ( t_cp_end >= IV_MAX - 1
7630 || ( i + 1 < len
7631 && t_cp_end + 1 == t_array[i+1]))
7632 {
7633 adjacent_to_range_above = TRUE;
7634 if (i + 1 < len)
7635 if ( ( pass2
7636 || CP_SKIP(t_cp) == CP_SKIP(t_array[i+1]))
7637 && ( ( r_cp == TR_SPECIAL_HANDLING
7638 && r_map[i+1] == (UV) TR_SPECIAL_HANDLING)
7639 || ( r_cp != TR_SPECIAL_HANDLING
7640 && r_cp_end == r_map[i+1] - 1)))
7641 {
7642 merge_with_range_above = TRUE;
7643 }
7644 }
7645
7646 if (merge_with_range_below && merge_with_range_above) {
7647
7648 /* Here the new chunk looks like M => m, ... Q => q; and
7649 * the range above is like R => r, .... Thus, the [i-1]
7650 * and [i+1] ranges should be seamlessly melded so the
7651 * result looks like
7652 *
7653 * [i-1] J j # J-T => j-t
7654 * [i] U y # U => y, V => y+1, ...
7655 * ...
7656 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7657 */
7658 Move(t_array + i + 2, t_array + i, len - i - 2, UV);
7659 Move(r_map + i + 2, r_map + i, len - i - 2, UV);
7660 len -= 2;
7661 invlist_set_len(t_invlist,
7662 len,
7663 *(get_invlist_offset_addr(t_invlist)));
7664 }
7665 else if (merge_with_range_below) {
7666
7667 /* Here the new chunk looks like M => m, .... But either
7668 * (or both) it doesn't extend all the way up through Q; or
7669 * the range above doesn't start with R => r. */
7670 if (! adjacent_to_range_above) {
7671
7672 /* In the first case, let's say the new chunk extends
7673 * through O. We then want:
7674 *
7675 * [i-1] J j # J-O => j-o
7676 * [i] P -1 # P => -1, Q => -1
7677 * [i+1] R x # R => x, S => x+1, T => x+2
7678 * [i+2] U y # U => y, V => y+1, ...
7679 * ...
7680 * [-1] Z -1 # Z => default; as do Z+1, ...
7681 * infinity
7682 */
7683 t_array[i] = t_cp_end + 1;
7684 r_map[i] = TR_UNLISTED;
7685 }
7686 else { /* Adjoins the range above, but can't merge with it
7687 (because 'x' is not the next map after q) */
7688 /*
7689 * [i-1] J j # J-Q => j-q
7690 * [i] R x # R => x, S => x+1, T => x+2
7691 * [i+1] U y # U => y, V => y+1, ...
7692 * ...
7693 * [-1] Z -1 # Z => default; as do Z+1, ...
7694 * infinity
7695 */
7696
7697 Move(t_array + i + 1, t_array + i, len - i - 1, UV);
7698 Move(r_map + i + 1, r_map + i, len - i - 1, UV);
7699 len--;
7700 invlist_set_len(t_invlist, len,
7701 *(get_invlist_offset_addr(t_invlist)));
7702 }
7703 }
7704 else if (merge_with_range_above) {
7705
7706 /* Here the new chunk ends with Q => q, and the range above
7707 * must start with R => r, so the two can be merged. But
7708 * either (or both) the new chunk doesn't extend all the
7709 * way down to M; or the mapping of the final code point
7710 * range below isn't m */
7711 if (! adjacent_to_range_below) {
7712
7713 /* In the first case, let's assume the new chunk starts
7714 * with P => p. Then, because it's merge-able with the
7715 * range above, that range must be R => r. We want:
7716 *
7717 * [i-1] J j # J-L => j-l
7718 * [i] M -1 # M => -1, N => -1
7719 * [i+1] P p # P-T => p-t
7720 * [i+2] U y # U => y, V => y+1, ...
7721 * ...
7722 * [-1] Z -1 # Z => default; as do Z+1, ...
7723 * infinity
7724 */
7725 t_array[i+1] = t_cp;
7726 r_map[i+1] = r_cp;
7727 }
7728 else { /* Adjoins the range below, but can't merge with it
7729 */
7730 /*
7731 * [i-1] J j # J-L => j-l
7732 * [i] M x # M-T => x-5 .. x+2
7733 * [i+1] U y # U => y, V => y+1, ...
7734 * ...
7735 * [-1] Z -1 # Z => default; as do Z+1, ...
7736 * infinity
7737 */
7738 Move(t_array + i + 1, t_array + i, len - i - 1, UV);
7739 Move(r_map + i + 1, r_map + i, len - i - 1, UV);
7740 len--;
7741 t_array[i] = t_cp;
7742 r_map[i] = r_cp;
7743 invlist_set_len(t_invlist, len,
7744 *(get_invlist_offset_addr(t_invlist)));
7745 }
7746 }
7747 else if (adjacent_to_range_below && adjacent_to_range_above) {
7748 /* The new chunk completely fills the gap between the
7749 * ranges on either side, but can't merge with either of
7750 * them.
7751 *
7752 * [i-1] J j # J-L => j-l
7753 * [i] M z # M => z, N => z+1 ... Q => z+4
7754 * [i+1] R x # R => x, S => x+1, T => x+2
7755 * [i+2] U y # U => y, V => y+1, ...
7756 * ...
7757 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7758 */
7759 r_map[i] = r_cp;
7760 }
7761 else if (adjacent_to_range_below) {
7762 /* The new chunk adjoins the range below, but not the range
7763 * above, and can't merge. Let's assume the chunk ends at
7764 * O.
7765 *
7766 * [i-1] J j # J-L => j-l
7767 * [i] M z # M => z, N => z+1, O => z+2
7768 * [i+1] P -1 # P => -1, Q => -1
7769 * [i+2] R x # R => x, S => x+1, T => x+2
7770 * [i+3] U y # U => y, V => y+1, ...
7771 * ...
7772 * [-w] Z -1 # Z => default; as do Z+1, ... infinity
7773 */
7774 invlist_extend(t_invlist, len + 1);
7775 t_array = invlist_array(t_invlist);
7776 Renew(r_map, len + 1, UV);
7777
7778 Move(t_array + i + 1, t_array + i + 2, len - i - 1, UV);
7779 Move(r_map + i + 1, r_map + i + 2, len - i - 1, UV);
7780 r_map[i] = r_cp;
7781 t_array[i+1] = t_cp_end + 1;
7782 r_map[i+1] = TR_UNLISTED;
7783 len++;
7784 invlist_set_len(t_invlist, len,
7785 *(get_invlist_offset_addr(t_invlist)));
7786 }
7787 else if (adjacent_to_range_above) {
7788 /* The new chunk adjoins the range above, but not the range
7789 * below, and can't merge. Let's assume the new chunk
7790 * starts at O
7791 *
7792 * [i-1] J j # J-L => j-l
7793 * [i] M -1 # M => default, N => default
7794 * [i+1] O z # O => z, P => z+1, Q => z+2
7795 * [i+2] R x # R => x, S => x+1, T => x+2
7796 * [i+3] U y # U => y, V => y+1, ...
7797 * ...
7798 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7799 */
7800 invlist_extend(t_invlist, len + 1);
7801 t_array = invlist_array(t_invlist);
7802 Renew(r_map, len + 1, UV);
7803
7804 Move(t_array + i + 1, t_array + i + 2, len - i - 1, UV);
7805 Move(r_map + i + 1, r_map + i + 2, len - i - 1, UV);
7806 t_array[i+1] = t_cp;
7807 r_map[i+1] = r_cp;
7808 len++;
7809 invlist_set_len(t_invlist, len,
7810 *(get_invlist_offset_addr(t_invlist)));
7811 }
7812 else {
7813 /* The new chunk adjoins neither the range above, nor the
7814 * range below. Lets assume it is N..P => n..p
7815 *
7816 * [i-1] J j # J-L => j-l
7817 * [i] M -1 # M => default
7818 * [i+1] N n # N..P => n..p
7819 * [i+2] Q -1 # Q => default
7820 * [i+3] R x # R => x, S => x+1, T => x+2
7821 * [i+4] U y # U => y, V => y+1, ...
7822 * ...
7823 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7824 */
7825
7826 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7827 "Before fixing up: len=%d, i=%d\n",
7828 (int) len, (int) i));
7829 DEBUG_yv(invmap_dump(t_invlist, r_map));
7830
7831 invlist_extend(t_invlist, len + 2);
7832 t_array = invlist_array(t_invlist);
7833 Renew(r_map, len + 2, UV);
7834
7835 Move(t_array + i + 1,
7836 t_array + i + 2 + 1, len - i - (2 - 1), UV);
7837 Move(r_map + i + 1,
7838 r_map + i + 2 + 1, len - i - (2 - 1), UV);
7839
7840 len += 2;
7841 invlist_set_len(t_invlist, len,
7842 *(get_invlist_offset_addr(t_invlist)));
7843
7844 t_array[i+1] = t_cp;
7845 r_map[i+1] = r_cp;
7846
7847 t_array[i+2] = t_cp_end + 1;
7848 r_map[i+2] = TR_UNLISTED;
7849 }
7850 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7851 "After iteration: span=%" UVuf ", t_range_count=%"
7852 UVuf " r_range_count=%" UVuf "\n",
7853 span, t_range_count, r_range_count));
7854 DEBUG_yv(invmap_dump(t_invlist, r_map));
7855 } /* End of this chunk needs to be processed */
7856
7857 /* Done with this chunk. */
7858 t_cp += span;
7859 if (t_cp >= IV_MAX) {
7860 break;
7861 }
7862 t_range_count -= span;
7863 if (r_cp != TR_SPECIAL_HANDLING) {
7864 r_cp += span;
7865 r_range_count -= span;
7866 }
7867 else {
7868 r_range_count = 0;
7869 }
7870
7871 } /* End of loop through the search list */
7872
7873 /* We don't need an exact count, but we do need to know if there is
7874 * anything left over in the replacement list. So, just assume it's
7875 * one byte per character */
7876 if (rend > r) {
7877 r_count++;
7878 }
7879 } /* End of passes */
7880
7881 SvREFCNT_dec(inverted_tstr);
7882
7883 DEBUG_y(PerlIO_printf(Perl_debug_log, "After everything: \n"));
7884 DEBUG_y(invmap_dump(t_invlist, r_map));
7885
7886 /* We now have normalized the input into an inversion map.
7887 *
7888 * See if the lhs and rhs are equivalent. If so, this tr/// is a no-op
7889 * except for the count, and streamlined runtime code can be used */
7890 if (!del && !squash) {
7891
7892 /* They are identical if they point to same address, or if everything
7893 * maps to UNLISTED or to itself. This catches things that not looking
7894 * at the normalized inversion map doesn't catch, like tr/aa/ab/ or
7895 * tr/\x{100}-\x{104}/\x{100}-\x{102}\x{103}-\x{104} */
7896 if (r0 != t0) {
7897 for (i = 0; i < len; i++) {
7898 if (r_map[i] != TR_UNLISTED && r_map[i] != t_array[i]) {
7899 goto done_identical_check;
7900 }
7901 }
7902 }
7903
7904 /* Here have gone through entire list, and didn't find any
7905 * non-identical mappings */
7906 o->op_private |= OPpTRANS_IDENTICAL;
7907
7908 done_identical_check: ;
7909 }
7910
7911 t_array = invlist_array(t_invlist);
7912
7913 /* If has components above 255, we generally need to use the inversion map
7914 * implementation */
7915 if ( can_force_utf8
7916 || ( len > 0
7917 && t_array[len-1] > 255
7918 /* If the final range is 0x100-INFINITY and is a special
7919 * mapping, the table implementation can handle it */
7920 && ! ( t_array[len-1] == 256
7921 && ( r_map[len-1] == TR_UNLISTED
7922 || r_map[len-1] == TR_SPECIAL_HANDLING))))
7923 {
7924 SV* r_map_sv;
7925
7926 /* A UTF-8 op is generated, indicated by this flag. This op is an
7927 * sv_op */
7928 o->op_private |= OPpTRANS_USE_SVOP;
7929
7930 if (can_force_utf8) {
7931 o->op_private |= OPpTRANS_CAN_FORCE_UTF8;
7932 }
7933
7934 /* The inversion map is pushed; first the list. */
7935 invmap = MUTABLE_AV(newAV());
7936 av_push(invmap, t_invlist);
7937
7938 /* 2nd is the mapping */
7939 r_map_sv = newSVpvn((char *) r_map, len * sizeof(UV));
7940 av_push(invmap, r_map_sv);
7941
7942 /* 3rd is the max possible expansion factor */
7943 av_push(invmap, newSVnv(max_expansion));
7944
7945 /* Characters that are in the search list, but not in the replacement
7946 * list are mapped to the final character in the replacement list */
7947 if (! del && r_count < t_count) {
7948 av_push(invmap, newSVuv(final_map));
7949 }
7950
7951 #ifdef USE_ITHREADS
7952 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
7953 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
7954 PAD_SETSV(cPADOPo->op_padix, (SV *) invmap);
7955 SvPADTMP_on(invmap);
7956 SvREADONLY_on(invmap);
7957 #else
7958 cSVOPo->op_sv = (SV *) invmap;
7959 #endif
7960
7961 }
7962 else {
7963 OPtrans_map *tbl;
7964 unsigned short i;
7965
7966 /* The OPtrans_map struct already contains one slot; hence the -1. */
7967 SSize_t struct_size = sizeof(OPtrans_map)
7968 + (256 - 1 + 1)*sizeof(short);
7969
7970 /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
7971 * table. Entries with the value TR_UNMAPPED indicate chars not to be
7972 * translated, while TR_DELETE indicates a search char without a
7973 * corresponding replacement char under /d.
7974 *
7975 * In addition, an extra slot at the end is used to store the final
7976 * repeating char, or TR_R_EMPTY under an empty replacement list, or
7977 * TR_DELETE under /d; which makes the runtime code easier.
7978 */
7979
7980 /* Indicate this is an op_pv */
7981 o->op_private &= ~OPpTRANS_USE_SVOP;
7982
7983 tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
7984 tbl->size = 256;
7985 cPVOPo->op_pv = (char*)tbl;
7986
7987 for (i = 0; i < len; i++) {
7988 STATIC_ASSERT_DECL(TR_SPECIAL_HANDLING == TR_DELETE);
7989 short upper = i >= len - 1 ? 256 : (short) t_array[i+1];
7990 short to = (short) r_map[i];
7991 short j;
7992 bool do_increment = TRUE;
7993
7994 /* Any code points above our limit should be irrelevant */
7995 if (t_array[i] >= tbl->size) break;
7996
7997 /* Set up the map */
7998 if (to == (short) TR_SPECIAL_HANDLING && ! del) {
7999 to = (short) final_map;
8000 do_increment = FALSE;
8001 }
8002 else if (to < 0) {
8003 do_increment = FALSE;
8004 }
8005
8006 /* Create a map for everything in this range. The value increases
8007 * except for the special cases */
8008 for (j = (short) t_array[i]; j < upper; j++) {
8009 tbl->map[j] = to;
8010 if (do_increment) to++;
8011 }
8012 }
8013
8014 tbl->map[tbl->size] = del
8015 ? (short) TR_DELETE
8016 : (short) rlen
8017 ? (short) final_map
8018 : (short) TR_R_EMPTY;
8019 DEBUG_y(PerlIO_printf(Perl_debug_log,"%s: %d\n", __FILE__, __LINE__));
8020 for (i = 0; i < tbl->size; i++) {
8021 if (tbl->map[i] < 0) {
8022 DEBUG_y(PerlIO_printf(Perl_debug_log," %02x=>%d",
8023 (unsigned) i, tbl->map[i]));
8024 }
8025 else {
8026 DEBUG_y(PerlIO_printf(Perl_debug_log," %02x=>%02x",
8027 (unsigned) i, tbl->map[i]));
8028 }
8029 if ((i+1) % 8 == 0 || i + 1 == (short) tbl->size) {
8030 DEBUG_y(PerlIO_printf(Perl_debug_log,"\n"));
8031 }
8032 }
8033 DEBUG_y(PerlIO_printf(Perl_debug_log,"Final map 0x%x=>%02x\n",
8034 (unsigned) tbl->size, tbl->map[tbl->size]));
8035
8036 SvREFCNT_dec(t_invlist);
8037
8038 #if 0 /* code that added excess above-255 chars at the end of the table, in
8039 case we ever want to not use the inversion map implementation for
8040 this */
8041
8042 ASSUME(j <= rlen);
8043 excess = rlen - j;
8044
8045 if (excess) {
8046 /* More replacement chars than search chars:
8047 * store excess replacement chars at end of main table.
8048 */
8049
8050 struct_size += excess;
8051 tbl = (OPtrans_map*)PerlMemShared_realloc(tbl,
8052 struct_size + excess * sizeof(short));
8053 tbl->size += excess;
8054 cPVOPo->op_pv = (char*)tbl;
8055
8056 for (i = 0; i < excess; i++)
8057 tbl->map[i + 256] = r[j+i];
8058 }
8059 else {
8060 /* no more replacement chars than search chars */
8061 }
8062 #endif
8063
8064 }
8065
8066 DEBUG_y(PerlIO_printf(Perl_debug_log,
8067 "/d=%d, /s=%d, /c=%d, identical=%d, grows=%d,"
8068 " use_svop=%d, can_force_utf8=%d,\nexpansion=%" NVgf "\n",
8069 del, squash, complement,
8070 cBOOL(o->op_private & OPpTRANS_IDENTICAL),
8071 cBOOL(o->op_private & OPpTRANS_USE_SVOP),
8072 cBOOL(o->op_private & OPpTRANS_GROWS),
8073 cBOOL(o->op_private & OPpTRANS_CAN_FORCE_UTF8),
8074 max_expansion));
8075
8076 Safefree(r_map);
8077
8078 if(del && rlen != 0 && r_count == t_count) {
8079 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
8080 } else if(r_count > t_count) {
8081 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
8082 }
8083
8084 op_free(expr);
8085 op_free(repl);
8086
8087 return o;
8088 }
8089
8090
8091 /*
8092 =for apidoc newPMOP
8093
8094 Constructs, checks, and returns an op of any pattern matching type.
8095 C<type> is the opcode. C<flags> gives the eight bits of C<op_flags>
8096 and, shifted up eight bits, the eight bits of C<op_private>.
8097
8098 =cut
8099 */
8100
8101 OP *
Perl_newPMOP(pTHX_ I32 type,I32 flags)8102 Perl_newPMOP(pTHX_ I32 type, I32 flags)
8103 {
8104 dVAR;
8105 PMOP *pmop;
8106
8107 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
8108 || type == OP_CUSTOM);
8109
8110 NewOp(1101, pmop, 1, PMOP);
8111 OpTYPE_set(pmop, type);
8112 pmop->op_flags = (U8)flags;
8113 pmop->op_private = (U8)(0 | (flags >> 8));
8114 if (PL_opargs[type] & OA_RETSCALAR)
8115 scalar((OP *)pmop);
8116
8117 if (PL_hints & HINT_RE_TAINT)
8118 pmop->op_pmflags |= PMf_RETAINT;
8119 #ifdef USE_LOCALE_CTYPE
8120 if (IN_LC_COMPILETIME(LC_CTYPE)) {
8121 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
8122 }
8123 else
8124 #endif
8125 if (IN_UNI_8_BIT) {
8126 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
8127 }
8128 if (PL_hints & HINT_RE_FLAGS) {
8129 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
8130 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
8131 );
8132 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
8133 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
8134 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
8135 );
8136 if (reflags && SvOK(reflags)) {
8137 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
8138 }
8139 }
8140
8141
8142 #ifdef USE_ITHREADS
8143 assert(SvPOK(PL_regex_pad[0]));
8144 if (SvCUR(PL_regex_pad[0])) {
8145 /* Pop off the "packed" IV from the end. */
8146 SV *const repointer_list = PL_regex_pad[0];
8147 const char *p = SvEND(repointer_list) - sizeof(IV);
8148 const IV offset = *((IV*)p);
8149
8150 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
8151
8152 SvEND_set(repointer_list, p);
8153
8154 pmop->op_pmoffset = offset;
8155 /* This slot should be free, so assert this: */
8156 assert(PL_regex_pad[offset] == &PL_sv_undef);
8157 } else {
8158 SV * const repointer = &PL_sv_undef;
8159 av_push(PL_regex_padav, repointer);
8160 pmop->op_pmoffset = av_tindex(PL_regex_padav);
8161 PL_regex_pad = AvARRAY(PL_regex_padav);
8162 }
8163 #endif
8164
8165 return CHECKOP(type, pmop);
8166 }
8167
8168 static void
S_set_haseval(pTHX)8169 S_set_haseval(pTHX)
8170 {
8171 PADOFFSET i = 1;
8172 PL_cv_has_eval = 1;
8173 /* Any pad names in scope are potentially lvalues. */
8174 for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
8175 PADNAME *pn = PAD_COMPNAME_SV(i);
8176 if (!pn || !PadnameLEN(pn))
8177 continue;
8178 if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
8179 S_mark_padname_lvalue(aTHX_ pn);
8180 }
8181 }
8182
8183 /* Given some sort of match op o, and an expression expr containing a
8184 * pattern, either compile expr into a regex and attach it to o (if it's
8185 * constant), or convert expr into a runtime regcomp op sequence (if it's
8186 * not)
8187 *
8188 * Flags currently has 2 bits of meaning:
8189 * 1: isreg indicates that the pattern is part of a regex construct, eg
8190 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
8191 * split "pattern", which aren't. In the former case, expr will be a list
8192 * if the pattern contains more than one term (eg /a$b/).
8193 * 2: The pattern is for a split.
8194 *
8195 * When the pattern has been compiled within a new anon CV (for
8196 * qr/(?{...})/ ), then floor indicates the savestack level just before
8197 * the new sub was created
8198 *
8199 * tr/// is also handled.
8200 */
8201
8202 OP *
Perl_pmruntime(pTHX_ OP * o,OP * expr,OP * repl,UV flags,I32 floor)8203 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
8204 {
8205 PMOP *pm;
8206 LOGOP *rcop;
8207 I32 repl_has_vars = 0;
8208 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
8209 bool is_compiletime;
8210 bool has_code;
8211 bool isreg = cBOOL(flags & 1);
8212 bool is_split = cBOOL(flags & 2);
8213
8214 PERL_ARGS_ASSERT_PMRUNTIME;
8215
8216 if (is_trans) {
8217 return pmtrans(o, expr, repl);
8218 }
8219
8220 /* find whether we have any runtime or code elements;
8221 * at the same time, temporarily set the op_next of each DO block;
8222 * then when we LINKLIST, this will cause the DO blocks to be excluded
8223 * from the op_next chain (and from having LINKLIST recursively
8224 * applied to them). We fix up the DOs specially later */
8225
8226 is_compiletime = 1;
8227 has_code = 0;
8228 if (expr->op_type == OP_LIST) {
8229 OP *child;
8230 for (child = cLISTOPx(expr)->op_first; child; child = OpSIBLING(child)) {
8231 if (child->op_type == OP_NULL && (child->op_flags & OPf_SPECIAL)) {
8232 has_code = 1;
8233 assert(!child->op_next);
8234 if (UNLIKELY(!OpHAS_SIBLING(child))) {
8235 assert(PL_parser && PL_parser->error_count);
8236 /* This can happen with qr/ (?{(^{})/. Just fake up
8237 the op we were expecting to see, to avoid crashing
8238 elsewhere. */
8239 op_sibling_splice(expr, child, 0,
8240 newSVOP(OP_CONST, 0, &PL_sv_no));
8241 }
8242 child->op_next = OpSIBLING(child);
8243 }
8244 else if (child->op_type != OP_CONST && child->op_type != OP_PUSHMARK)
8245 is_compiletime = 0;
8246 }
8247 }
8248 else if (expr->op_type != OP_CONST)
8249 is_compiletime = 0;
8250
8251 LINKLIST(expr);
8252
8253 /* fix up DO blocks; treat each one as a separate little sub;
8254 * also, mark any arrays as LIST/REF */
8255
8256 if (expr->op_type == OP_LIST) {
8257 OP *child;
8258 for (child = cLISTOPx(expr)->op_first; child; child = OpSIBLING(child)) {
8259
8260 if (child->op_type == OP_PADAV || child->op_type == OP_RV2AV) {
8261 assert( !(child->op_flags & OPf_WANT));
8262 /* push the array rather than its contents. The regex
8263 * engine will retrieve and join the elements later */
8264 child->op_flags |= (OPf_WANT_LIST | OPf_REF);
8265 continue;
8266 }
8267
8268 if (!(child->op_type == OP_NULL && (child->op_flags & OPf_SPECIAL)))
8269 continue;
8270 child->op_next = NULL; /* undo temporary hack from above */
8271 scalar(child);
8272 LINKLIST(child);
8273 if (cLISTOPx(child)->op_first->op_type == OP_LEAVE) {
8274 LISTOP *leaveop = cLISTOPx(cLISTOPx(child)->op_first);
8275 /* skip ENTER */
8276 assert(leaveop->op_first->op_type == OP_ENTER);
8277 assert(OpHAS_SIBLING(leaveop->op_first));
8278 child->op_next = OpSIBLING(leaveop->op_first);
8279 /* skip leave */
8280 assert(leaveop->op_flags & OPf_KIDS);
8281 assert(leaveop->op_last->op_next == (OP*)leaveop);
8282 leaveop->op_next = NULL; /* stop on last op */
8283 op_null((OP*)leaveop);
8284 }
8285 else {
8286 /* skip SCOPE */
8287 OP *scope = cLISTOPx(child)->op_first;
8288 assert(scope->op_type == OP_SCOPE);
8289 assert(scope->op_flags & OPf_KIDS);
8290 scope->op_next = NULL; /* stop on last op */
8291 op_null(scope);
8292 }
8293
8294 /* XXX optimize_optree() must be called on o before
8295 * CALL_PEEP(), as currently S_maybe_multiconcat() can't
8296 * currently cope with a peephole-optimised optree.
8297 * Calling optimize_optree() here ensures that condition
8298 * is met, but may mean optimize_optree() is applied
8299 * to the same optree later (where hopefully it won't do any
8300 * harm as it can't convert an op to multiconcat if it's
8301 * already been converted */
8302 optimize_optree(child);
8303
8304 /* have to peep the DOs individually as we've removed it from
8305 * the op_next chain */
8306 CALL_PEEP(child);
8307 S_prune_chain_head(&(child->op_next));
8308 if (is_compiletime)
8309 /* runtime finalizes as part of finalizing whole tree */
8310 finalize_optree(child);
8311 }
8312 }
8313 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
8314 assert( !(expr->op_flags & OPf_WANT));
8315 /* push the array rather than its contents. The regex
8316 * engine will retrieve and join the elements later */
8317 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
8318 }
8319
8320 PL_hints |= HINT_BLOCK_SCOPE;
8321 pm = (PMOP*)o;
8322 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
8323
8324 if (is_compiletime) {
8325 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
8326 regexp_engine const *eng = current_re_engine();
8327
8328 if (is_split) {
8329 /* make engine handle split ' ' specially */
8330 pm->op_pmflags |= PMf_SPLIT;
8331 rx_flags |= RXf_SPLIT;
8332 }
8333
8334 if (!has_code || !eng->op_comp) {
8335 /* compile-time simple constant pattern */
8336
8337 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
8338 /* whoops! we guessed that a qr// had a code block, but we
8339 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
8340 * that isn't required now. Note that we have to be pretty
8341 * confident that nothing used that CV's pad while the
8342 * regex was parsed, except maybe op targets for \Q etc.
8343 * If there were any op targets, though, they should have
8344 * been stolen by constant folding.
8345 */
8346 #ifdef DEBUGGING
8347 SSize_t i = 0;
8348 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
8349 while (++i <= AvFILLp(PL_comppad)) {
8350 # ifdef USE_PAD_RESET
8351 /* under USE_PAD_RESET, pad swipe replaces a swiped
8352 * folded constant with a fresh padtmp */
8353 assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
8354 # else
8355 assert(!PL_curpad[i]);
8356 # endif
8357 }
8358 #endif
8359 /* This LEAVE_SCOPE will restore PL_compcv to point to the
8360 * outer CV (the one whose slab holds the pm op). The
8361 * inner CV (which holds expr) will be freed later, once
8362 * all the entries on the parse stack have been popped on
8363 * return from this function. Which is why its safe to
8364 * call op_free(expr) below.
8365 */
8366 LEAVE_SCOPE(floor);
8367 pm->op_pmflags &= ~PMf_HAS_CV;
8368 }
8369
8370 /* Skip compiling if parser found an error for this pattern */
8371 if (pm->op_pmflags & PMf_HAS_ERROR) {
8372 return o;
8373 }
8374
8375 PM_SETRE(pm,
8376 eng->op_comp
8377 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
8378 rx_flags, pm->op_pmflags)
8379 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
8380 rx_flags, pm->op_pmflags)
8381 );
8382 op_free(expr);
8383 }
8384 else {
8385 /* compile-time pattern that includes literal code blocks */
8386
8387 REGEXP* re;
8388
8389 /* Skip compiling if parser found an error for this pattern */
8390 if (pm->op_pmflags & PMf_HAS_ERROR) {
8391 return o;
8392 }
8393
8394 re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
8395 rx_flags,
8396 (pm->op_pmflags |
8397 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
8398 );
8399 PM_SETRE(pm, re);
8400 if (pm->op_pmflags & PMf_HAS_CV) {
8401 CV *cv;
8402 /* this QR op (and the anon sub we embed it in) is never
8403 * actually executed. It's just a placeholder where we can
8404 * squirrel away expr in op_code_list without the peephole
8405 * optimiser etc processing it for a second time */
8406 OP *qr = newPMOP(OP_QR, 0);
8407 ((PMOP*)qr)->op_code_list = expr;
8408
8409 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
8410 SvREFCNT_inc_simple_void(PL_compcv);
8411 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
8412 ReANY(re)->qr_anoncv = cv;
8413
8414 /* attach the anon CV to the pad so that
8415 * pad_fixup_inner_anons() can find it */
8416 (void)pad_add_anon(cv, o->op_type);
8417 SvREFCNT_inc_simple_void(cv);
8418 }
8419 else {
8420 pm->op_code_list = expr;
8421 }
8422 }
8423 }
8424 else {
8425 /* runtime pattern: build chain of regcomp etc ops */
8426 bool reglist;
8427 PADOFFSET cv_targ = 0;
8428
8429 reglist = isreg && expr->op_type == OP_LIST;
8430 if (reglist)
8431 op_null(expr);
8432
8433 if (has_code) {
8434 pm->op_code_list = expr;
8435 /* don't free op_code_list; its ops are embedded elsewhere too */
8436 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
8437 }
8438
8439 if (is_split)
8440 /* make engine handle split ' ' specially */
8441 pm->op_pmflags |= PMf_SPLIT;
8442
8443 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
8444 * to allow its op_next to be pointed past the regcomp and
8445 * preceding stacking ops;
8446 * OP_REGCRESET is there to reset taint before executing the
8447 * stacking ops */
8448 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
8449 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
8450
8451 if (pm->op_pmflags & PMf_HAS_CV) {
8452 /* we have a runtime qr with literal code. This means
8453 * that the qr// has been wrapped in a new CV, which
8454 * means that runtime consts, vars etc will have been compiled
8455 * against a new pad. So... we need to execute those ops
8456 * within the environment of the new CV. So wrap them in a call
8457 * to a new anon sub. i.e. for
8458 *
8459 * qr/a$b(?{...})/,
8460 *
8461 * we build an anon sub that looks like
8462 *
8463 * sub { "a", $b, '(?{...})' }
8464 *
8465 * and call it, passing the returned list to regcomp.
8466 * Or to put it another way, the list of ops that get executed
8467 * are:
8468 *
8469 * normal PMf_HAS_CV
8470 * ------ -------------------
8471 * pushmark (for regcomp)
8472 * pushmark (for entersub)
8473 * anoncode
8474 * srefgen
8475 * entersub
8476 * regcreset regcreset
8477 * pushmark pushmark
8478 * const("a") const("a")
8479 * gvsv(b) gvsv(b)
8480 * const("(?{...})") const("(?{...})")
8481 * leavesub
8482 * regcomp regcomp
8483 */
8484
8485 SvREFCNT_inc_simple_void(PL_compcv);
8486 CvLVALUE_on(PL_compcv);
8487 /* these lines are just an unrolled newANONATTRSUB */
8488 expr = newSVOP(OP_ANONCODE, 0,
8489 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
8490 cv_targ = expr->op_targ;
8491 expr = newUNOP(OP_REFGEN, 0, expr);
8492
8493 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
8494 }
8495
8496 rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
8497 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
8498 | (reglist ? OPf_STACKED : 0);
8499 rcop->op_targ = cv_targ;
8500
8501 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
8502 if (PL_hints & HINT_RE_EVAL)
8503 S_set_haseval(aTHX);
8504
8505 /* establish postfix order */
8506 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
8507 LINKLIST(expr);
8508 rcop->op_next = expr;
8509 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
8510 }
8511 else {
8512 rcop->op_next = LINKLIST(expr);
8513 expr->op_next = (OP*)rcop;
8514 }
8515
8516 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
8517 }
8518
8519 if (repl) {
8520 OP *curop = repl;
8521 bool konst;
8522 /* If we are looking at s//.../e with a single statement, get past
8523 the implicit do{}. */
8524 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
8525 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
8526 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
8527 {
8528 OP *sib;
8529 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
8530 if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
8531 && !OpHAS_SIBLING(sib))
8532 curop = sib;
8533 }
8534 if (curop->op_type == OP_CONST)
8535 konst = TRUE;
8536 else if (( (curop->op_type == OP_RV2SV ||
8537 curop->op_type == OP_RV2AV ||
8538 curop->op_type == OP_RV2HV ||
8539 curop->op_type == OP_RV2GV)
8540 && cUNOPx(curop)->op_first
8541 && cUNOPx(curop)->op_first->op_type == OP_GV )
8542 || curop->op_type == OP_PADSV
8543 || curop->op_type == OP_PADAV
8544 || curop->op_type == OP_PADHV
8545 || curop->op_type == OP_PADANY) {
8546 repl_has_vars = 1;
8547 konst = TRUE;
8548 }
8549 else konst = FALSE;
8550 if (konst
8551 && !(repl_has_vars
8552 && (!PM_GETRE(pm)
8553 || !RX_PRELEN(PM_GETRE(pm))
8554 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
8555 {
8556 pm->op_pmflags |= PMf_CONST; /* const for long enough */
8557 op_prepend_elem(o->op_type, scalar(repl), o);
8558 }
8559 else {
8560 rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
8561 rcop->op_private = 1;
8562
8563 /* establish postfix order */
8564 rcop->op_next = LINKLIST(repl);
8565 repl->op_next = (OP*)rcop;
8566
8567 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
8568 assert(!(pm->op_pmflags & PMf_ONCE));
8569 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
8570 rcop->op_next = 0;
8571 }
8572 }
8573
8574 return (OP*)pm;
8575 }
8576
8577 /*
8578 =for apidoc newSVOP
8579
8580 Constructs, checks, and returns an op of any type that involves an
8581 embedded SV. C<type> is the opcode. C<flags> gives the eight bits
8582 of C<op_flags>. C<sv> gives the SV to embed in the op; this function
8583 takes ownership of one reference to it.
8584
8585 =cut
8586 */
8587
8588 OP *
Perl_newSVOP(pTHX_ I32 type,I32 flags,SV * sv)8589 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
8590 {
8591 dVAR;
8592 SVOP *svop;
8593
8594 PERL_ARGS_ASSERT_NEWSVOP;
8595
8596 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
8597 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
8598 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
8599 || type == OP_CUSTOM);
8600
8601 NewOp(1101, svop, 1, SVOP);
8602 OpTYPE_set(svop, type);
8603 svop->op_sv = sv;
8604 svop->op_next = (OP*)svop;
8605 svop->op_flags = (U8)flags;
8606 svop->op_private = (U8)(0 | (flags >> 8));
8607 if (PL_opargs[type] & OA_RETSCALAR)
8608 scalar((OP*)svop);
8609 if (PL_opargs[type] & OA_TARGET)
8610 svop->op_targ = pad_alloc(type, SVs_PADTMP);
8611 return CHECKOP(type, svop);
8612 }
8613
8614 /*
8615 =for apidoc newDEFSVOP
8616
8617 Constructs and returns an op to access C<$_>.
8618
8619 =cut
8620 */
8621
8622 OP *
Perl_newDEFSVOP(pTHX)8623 Perl_newDEFSVOP(pTHX)
8624 {
8625 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
8626 }
8627
8628 #ifdef USE_ITHREADS
8629
8630 /*
8631 =for apidoc newPADOP
8632
8633 Constructs, checks, and returns an op of any type that involves a
8634 reference to a pad element. C<type> is the opcode. C<flags> gives the
8635 eight bits of C<op_flags>. A pad slot is automatically allocated, and
8636 is populated with C<sv>; this function takes ownership of one reference
8637 to it.
8638
8639 This function only exists if Perl has been compiled to use ithreads.
8640
8641 =cut
8642 */
8643
8644 OP *
Perl_newPADOP(pTHX_ I32 type,I32 flags,SV * sv)8645 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
8646 {
8647 dVAR;
8648 PADOP *padop;
8649
8650 PERL_ARGS_ASSERT_NEWPADOP;
8651
8652 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
8653 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
8654 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
8655 || type == OP_CUSTOM);
8656
8657 NewOp(1101, padop, 1, PADOP);
8658 OpTYPE_set(padop, type);
8659 padop->op_padix =
8660 pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
8661 SvREFCNT_dec(PAD_SVl(padop->op_padix));
8662 PAD_SETSV(padop->op_padix, sv);
8663 assert(sv);
8664 padop->op_next = (OP*)padop;
8665 padop->op_flags = (U8)flags;
8666 if (PL_opargs[type] & OA_RETSCALAR)
8667 scalar((OP*)padop);
8668 if (PL_opargs[type] & OA_TARGET)
8669 padop->op_targ = pad_alloc(type, SVs_PADTMP);
8670 return CHECKOP(type, padop);
8671 }
8672
8673 #endif /* USE_ITHREADS */
8674
8675 /*
8676 =for apidoc newGVOP
8677
8678 Constructs, checks, and returns an op of any type that involves an
8679 embedded reference to a GV. C<type> is the opcode. C<flags> gives the
8680 eight bits of C<op_flags>. C<gv> identifies the GV that the op should
8681 reference; calling this function does not transfer ownership of any
8682 reference to it.
8683
8684 =cut
8685 */
8686
8687 OP *
Perl_newGVOP(pTHX_ I32 type,I32 flags,GV * gv)8688 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
8689 {
8690 PERL_ARGS_ASSERT_NEWGVOP;
8691
8692 #ifdef USE_ITHREADS
8693 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
8694 #else
8695 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
8696 #endif
8697 }
8698
8699 /*
8700 =for apidoc newPVOP
8701
8702 Constructs, checks, and returns an op of any type that involves an
8703 embedded C-level pointer (PV). C<type> is the opcode. C<flags> gives
8704 the eight bits of C<op_flags>. C<pv> supplies the C-level pointer.
8705 Depending on the op type, the memory referenced by C<pv> may be freed
8706 when the op is destroyed. If the op is of a freeing type, C<pv> must
8707 have been allocated using C<PerlMemShared_malloc>.
8708
8709 =cut
8710 */
8711
8712 OP *
Perl_newPVOP(pTHX_ I32 type,I32 flags,char * pv)8713 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
8714 {
8715 dVAR;
8716 const bool utf8 = cBOOL(flags & SVf_UTF8);
8717 PVOP *pvop;
8718
8719 flags &= ~SVf_UTF8;
8720
8721 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
8722 || type == OP_RUNCV || type == OP_CUSTOM
8723 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
8724
8725 NewOp(1101, pvop, 1, PVOP);
8726 OpTYPE_set(pvop, type);
8727 pvop->op_pv = pv;
8728 pvop->op_next = (OP*)pvop;
8729 pvop->op_flags = (U8)flags;
8730 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
8731 if (PL_opargs[type] & OA_RETSCALAR)
8732 scalar((OP*)pvop);
8733 if (PL_opargs[type] & OA_TARGET)
8734 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
8735 return CHECKOP(type, pvop);
8736 }
8737
8738 void
Perl_package(pTHX_ OP * o)8739 Perl_package(pTHX_ OP *o)
8740 {
8741 SV *const sv = cSVOPo->op_sv;
8742
8743 PERL_ARGS_ASSERT_PACKAGE;
8744
8745 SAVEGENERICSV(PL_curstash);
8746 save_item(PL_curstname);
8747
8748 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
8749
8750 sv_setsv(PL_curstname, sv);
8751
8752 PL_hints |= HINT_BLOCK_SCOPE;
8753 PL_parser->copline = NOLINE;
8754
8755 op_free(o);
8756 }
8757
8758 void
Perl_package_version(pTHX_ OP * v)8759 Perl_package_version( pTHX_ OP *v )
8760 {
8761 U32 savehints = PL_hints;
8762 PERL_ARGS_ASSERT_PACKAGE_VERSION;
8763 PL_hints &= ~HINT_STRICT_VARS;
8764 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
8765 PL_hints = savehints;
8766 op_free(v);
8767 }
8768
8769 void
Perl_utilize(pTHX_ int aver,I32 floor,OP * version,OP * idop,OP * arg)8770 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
8771 {
8772 OP *pack;
8773 OP *imop;
8774 OP *veop;
8775 SV *use_version = NULL;
8776
8777 PERL_ARGS_ASSERT_UTILIZE;
8778
8779 if (idop->op_type != OP_CONST)
8780 Perl_croak(aTHX_ "Module name must be constant");
8781
8782 veop = NULL;
8783
8784 if (version) {
8785 SV * const vesv = ((SVOP*)version)->op_sv;
8786
8787 if (!arg && !SvNIOKp(vesv)) {
8788 arg = version;
8789 }
8790 else {
8791 OP *pack;
8792 SV *meth;
8793
8794 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
8795 Perl_croak(aTHX_ "Version number must be a constant number");
8796
8797 /* Make copy of idop so we don't free it twice */
8798 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
8799
8800 /* Fake up a method call to VERSION */
8801 meth = newSVpvs_share("VERSION");
8802 veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
8803 op_append_elem(OP_LIST,
8804 op_prepend_elem(OP_LIST, pack, version),
8805 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
8806 }
8807 }
8808
8809 /* Fake up an import/unimport */
8810 if (arg && arg->op_type == OP_STUB) {
8811 imop = arg; /* no import on explicit () */
8812 }
8813 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
8814 imop = NULL; /* use 5.0; */
8815 if (aver)
8816 use_version = ((SVOP*)idop)->op_sv;
8817 else
8818 idop->op_private |= OPpCONST_NOVER;
8819 }
8820 else {
8821 SV *meth;
8822
8823 /* Make copy of idop so we don't free it twice */
8824 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
8825
8826 /* Fake up a method call to import/unimport */
8827 meth = aver
8828 ? newSVpvs_share("import") : newSVpvs_share("unimport");
8829 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
8830 op_append_elem(OP_LIST,
8831 op_prepend_elem(OP_LIST, pack, arg),
8832 newMETHOP_named(OP_METHOD_NAMED, 0, meth)
8833 ));
8834 }
8835
8836 /* Fake up the BEGIN {}, which does its thing immediately. */
8837 newATTRSUB(floor,
8838 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
8839 NULL,
8840 NULL,
8841 op_append_elem(OP_LINESEQ,
8842 op_append_elem(OP_LINESEQ,
8843 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
8844 newSTATEOP(0, NULL, veop)),
8845 newSTATEOP(0, NULL, imop) ));
8846
8847 if (use_version) {
8848 /* Enable the
8849 * feature bundle that corresponds to the required version. */
8850 use_version = sv_2mortal(new_version(use_version));
8851 S_enable_feature_bundle(aTHX_ use_version);
8852
8853 /* If a version >= 5.11.0 is requested, strictures are on by default! */
8854 if (vcmp(use_version,
8855 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
8856 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
8857 PL_hints |= HINT_STRICT_REFS;
8858 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
8859 PL_hints |= HINT_STRICT_SUBS;
8860 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
8861 PL_hints |= HINT_STRICT_VARS;
8862 }
8863 /* otherwise they are off */
8864 else {
8865 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
8866 PL_hints &= ~HINT_STRICT_REFS;
8867 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
8868 PL_hints &= ~HINT_STRICT_SUBS;
8869 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
8870 PL_hints &= ~HINT_STRICT_VARS;
8871 }
8872 }
8873
8874 /* The "did you use incorrect case?" warning used to be here.
8875 * The problem is that on case-insensitive filesystems one
8876 * might get false positives for "use" (and "require"):
8877 * "use Strict" or "require CARP" will work. This causes
8878 * portability problems for the script: in case-strict
8879 * filesystems the script will stop working.
8880 *
8881 * The "incorrect case" warning checked whether "use Foo"
8882 * imported "Foo" to your namespace, but that is wrong, too:
8883 * there is no requirement nor promise in the language that
8884 * a Foo.pm should or would contain anything in package "Foo".
8885 *
8886 * There is very little Configure-wise that can be done, either:
8887 * the case-sensitivity of the build filesystem of Perl does not
8888 * help in guessing the case-sensitivity of the runtime environment.
8889 */
8890
8891 PL_hints |= HINT_BLOCK_SCOPE;
8892 PL_parser->copline = NOLINE;
8893 COP_SEQMAX_INC; /* Purely for B::*'s benefit */
8894 }
8895
8896 /*
8897 =head1 Embedding Functions
8898
8899 =for apidoc load_module
8900
8901 Loads the module whose name is pointed to by the string part of C<name>.
8902 Note that the actual module name, not its filename, should be given.
8903 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
8904 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
8905 trailing arguments can be used to specify arguments to the module's C<import()>
8906 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
8907 on the flags. The flags argument is a bitwise-ORed collection of any of
8908 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
8909 (or 0 for no flags).
8910
8911 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
8912 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
8913 the trailing optional arguments may be omitted entirely. Otherwise, if
8914 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
8915 exactly one C<OP*>, containing the op tree that produces the relevant import
8916 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
8917 will be used as import arguments; and the list must be terminated with C<(SV*)
8918 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
8919 set, the trailing C<NULL> pointer is needed even if no import arguments are
8920 desired. The reference count for each specified C<SV*> argument is
8921 decremented. In addition, the C<name> argument is modified.
8922
8923 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
8924 than C<use>.
8925
8926 =for apidoc Amnh||PERL_LOADMOD_DENY
8927 =for apidoc Amnh||PERL_LOADMOD_NOIMPORT
8928 =for apidoc Amnh||PERL_LOADMOD_IMPORT_OPS
8929
8930 =cut */
8931
8932 void
Perl_load_module(pTHX_ U32 flags,SV * name,SV * ver,...)8933 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
8934 {
8935 va_list args;
8936
8937 PERL_ARGS_ASSERT_LOAD_MODULE;
8938
8939 va_start(args, ver);
8940 vload_module(flags, name, ver, &args);
8941 va_end(args);
8942 }
8943
8944 #ifdef PERL_IMPLICIT_CONTEXT
8945 void
Perl_load_module_nocontext(U32 flags,SV * name,SV * ver,...)8946 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
8947 {
8948 dTHX;
8949 va_list args;
8950 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
8951 va_start(args, ver);
8952 vload_module(flags, name, ver, &args);
8953 va_end(args);
8954 }
8955 #endif
8956
8957 void
Perl_vload_module(pTHX_ U32 flags,SV * name,SV * ver,va_list * args)8958 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
8959 {
8960 OP *veop, *imop;
8961 OP * modname;
8962 I32 floor;
8963
8964 PERL_ARGS_ASSERT_VLOAD_MODULE;
8965
8966 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
8967 * that it has a PL_parser to play with while doing that, and also
8968 * that it doesn't mess with any existing parser, by creating a tmp
8969 * new parser with lex_start(). This won't actually be used for much,
8970 * since pp_require() will create another parser for the real work.
8971 * The ENTER/LEAVE pair protect callers from any side effects of use.
8972 *
8973 * start_subparse() creates a new PL_compcv. This means that any ops
8974 * allocated below will be allocated from that CV's op slab, and so
8975 * will be automatically freed if the utilise() fails
8976 */
8977
8978 ENTER;
8979 SAVEVPTR(PL_curcop);
8980 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
8981 floor = start_subparse(FALSE, 0);
8982
8983 modname = newSVOP(OP_CONST, 0, name);
8984 modname->op_private |= OPpCONST_BARE;
8985 if (ver) {
8986 veop = newSVOP(OP_CONST, 0, ver);
8987 }
8988 else
8989 veop = NULL;
8990 if (flags & PERL_LOADMOD_NOIMPORT) {
8991 imop = sawparens(newNULLLIST());
8992 }
8993 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
8994 imop = va_arg(*args, OP*);
8995 }
8996 else {
8997 SV *sv;
8998 imop = NULL;
8999 sv = va_arg(*args, SV*);
9000 while (sv) {
9001 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
9002 sv = va_arg(*args, SV*);
9003 }
9004 }
9005
9006 utilize(!(flags & PERL_LOADMOD_DENY), floor, veop, modname, imop);
9007 LEAVE;
9008 }
9009
9010 PERL_STATIC_INLINE OP *
S_new_entersubop(pTHX_ GV * gv,OP * arg)9011 S_new_entersubop(pTHX_ GV *gv, OP *arg)
9012 {
9013 return newUNOP(OP_ENTERSUB, OPf_STACKED,
9014 newLISTOP(OP_LIST, 0, arg,
9015 newUNOP(OP_RV2CV, 0,
9016 newGVOP(OP_GV, 0, gv))));
9017 }
9018
9019 OP *
Perl_dofile(pTHX_ OP * term,I32 force_builtin)9020 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
9021 {
9022 OP *doop;
9023 GV *gv;
9024
9025 PERL_ARGS_ASSERT_DOFILE;
9026
9027 if (!force_builtin && (gv = gv_override("do", 2))) {
9028 doop = S_new_entersubop(aTHX_ gv, term);
9029 }
9030 else {
9031 doop = newUNOP(OP_DOFILE, 0, scalar(term));
9032 }
9033 return doop;
9034 }
9035
9036 /*
9037 =head1 Optree construction
9038
9039 =for apidoc newSLICEOP
9040
9041 Constructs, checks, and returns an C<lslice> (list slice) op. C<flags>
9042 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
9043 be set automatically, and, shifted up eight bits, the eight bits of
9044 C<op_private>, except that the bit with value 1 or 2 is automatically
9045 set as required. C<listval> and C<subscript> supply the parameters of
9046 the slice; they are consumed by this function and become part of the
9047 constructed op tree.
9048
9049 =cut
9050 */
9051
9052 OP *
Perl_newSLICEOP(pTHX_ I32 flags,OP * subscript,OP * listval)9053 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
9054 {
9055 return newBINOP(OP_LSLICE, flags,
9056 list(force_list(subscript, 1)),
9057 list(force_list(listval, 1)) );
9058 }
9059
9060 #define ASSIGN_SCALAR 0
9061 #define ASSIGN_LIST 1
9062 #define ASSIGN_REF 2
9063
9064 /* given the optree o on the LHS of an assignment, determine whether its:
9065 * ASSIGN_SCALAR $x = ...
9066 * ASSIGN_LIST ($x) = ...
9067 * ASSIGN_REF \$x = ...
9068 */
9069
9070 STATIC I32
S_assignment_type(pTHX_ const OP * o)9071 S_assignment_type(pTHX_ const OP *o)
9072 {
9073 unsigned type;
9074 U8 flags;
9075 U8 ret;
9076
9077 if (!o)
9078 return ASSIGN_LIST;
9079
9080 if (o->op_type == OP_SREFGEN)
9081 {
9082 OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
9083 type = kid->op_type;
9084 flags = o->op_flags | kid->op_flags;
9085 if (!(flags & OPf_PARENS)
9086 && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
9087 kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
9088 return ASSIGN_REF;
9089 ret = ASSIGN_REF;
9090 } else {
9091 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
9092 o = cUNOPo->op_first;
9093 flags = o->op_flags;
9094 type = o->op_type;
9095 ret = ASSIGN_SCALAR;
9096 }
9097
9098 if (type == OP_COND_EXPR) {
9099 OP * const sib = OpSIBLING(cLOGOPo->op_first);
9100 const I32 t = assignment_type(sib);
9101 const I32 f = assignment_type(OpSIBLING(sib));
9102
9103 if (t == ASSIGN_LIST && f == ASSIGN_LIST)
9104 return ASSIGN_LIST;
9105 if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
9106 yyerror("Assignment to both a list and a scalar");
9107 return ASSIGN_SCALAR;
9108 }
9109
9110 if (type == OP_LIST &&
9111 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
9112 o->op_private & OPpLVAL_INTRO)
9113 return ret;
9114
9115 if (type == OP_LIST || flags & OPf_PARENS ||
9116 type == OP_RV2AV || type == OP_RV2HV ||
9117 type == OP_ASLICE || type == OP_HSLICE ||
9118 type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
9119 return ASSIGN_LIST;
9120
9121 if (type == OP_PADAV || type == OP_PADHV)
9122 return ASSIGN_LIST;
9123
9124 if (type == OP_RV2SV)
9125 return ret;
9126
9127 return ret;
9128 }
9129
9130 static OP *
S_newONCEOP(pTHX_ OP * initop,OP * padop)9131 S_newONCEOP(pTHX_ OP *initop, OP *padop)
9132 {
9133 dVAR;
9134 const PADOFFSET target = padop->op_targ;
9135 OP *const other = newOP(OP_PADSV,
9136 padop->op_flags
9137 | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
9138 OP *const first = newOP(OP_NULL, 0);
9139 OP *const nullop = newCONDOP(0, first, initop, other);
9140 /* XXX targlex disabled for now; see ticket #124160
9141 newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
9142 */
9143 OP *const condop = first->op_next;
9144
9145 OpTYPE_set(condop, OP_ONCE);
9146 other->op_targ = target;
9147 nullop->op_flags |= OPf_WANT_SCALAR;
9148
9149 /* Store the initializedness of state vars in a separate
9150 pad entry. */
9151 condop->op_targ =
9152 pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
9153 /* hijacking PADSTALE for uninitialized state variables */
9154 SvPADSTALE_on(PAD_SVl(condop->op_targ));
9155
9156 return nullop;
9157 }
9158
9159 /*
9160 =for apidoc newASSIGNOP
9161
9162 Constructs, checks, and returns an assignment op. C<left> and C<right>
9163 supply the parameters of the assignment; they are consumed by this
9164 function and become part of the constructed op tree.
9165
9166 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
9167 a suitable conditional optree is constructed. If C<optype> is the opcode
9168 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
9169 performs the binary operation and assigns the result to the left argument.
9170 Either way, if C<optype> is non-zero then C<flags> has no effect.
9171
9172 If C<optype> is zero, then a plain scalar or list assignment is
9173 constructed. Which type of assignment it is is automatically determined.
9174 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
9175 will be set automatically, and, shifted up eight bits, the eight bits
9176 of C<op_private>, except that the bit with value 1 or 2 is automatically
9177 set as required.
9178
9179 =cut
9180 */
9181
9182 OP *
Perl_newASSIGNOP(pTHX_ I32 flags,OP * left,I32 optype,OP * right)9183 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
9184 {
9185 OP *o;
9186 I32 assign_type;
9187
9188 if (optype) {
9189 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
9190 right = scalar(right);
9191 return newLOGOP(optype, 0,
9192 op_lvalue(scalar(left), optype),
9193 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
9194 }
9195 else {
9196 return newBINOP(optype, OPf_STACKED,
9197 op_lvalue(scalar(left), optype), scalar(right));
9198 }
9199 }
9200
9201 if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
9202 OP *state_var_op = NULL;
9203 static const char no_list_state[] = "Initialization of state variables"
9204 " in list currently forbidden";
9205 OP *curop;
9206
9207 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
9208 left->op_private &= ~ OPpSLICEWARNING;
9209
9210 PL_modcount = 0;
9211 left = op_lvalue(left, OP_AASSIGN);
9212 curop = list(force_list(left, 1));
9213 o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
9214 o->op_private = (U8)(0 | (flags >> 8));
9215
9216 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
9217 {
9218 OP *lop = ((LISTOP*)left)->op_first, *vop, *eop;
9219 if (!(left->op_flags & OPf_PARENS) &&
9220 lop->op_type == OP_PUSHMARK &&
9221 (vop = OpSIBLING(lop)) &&
9222 (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
9223 !(vop->op_flags & OPf_PARENS) &&
9224 (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
9225 (OPpLVAL_INTRO|OPpPAD_STATE) &&
9226 (eop = OpSIBLING(vop)) &&
9227 eop->op_type == OP_ENTERSUB &&
9228 !OpHAS_SIBLING(eop)) {
9229 state_var_op = vop;
9230 } else {
9231 while (lop) {
9232 if ((lop->op_type == OP_PADSV ||
9233 lop->op_type == OP_PADAV ||
9234 lop->op_type == OP_PADHV ||
9235 lop->op_type == OP_PADANY)
9236 && (lop->op_private & OPpPAD_STATE)
9237 )
9238 yyerror(no_list_state);
9239 lop = OpSIBLING(lop);
9240 }
9241 }
9242 }
9243 else if ( (left->op_private & OPpLVAL_INTRO)
9244 && (left->op_private & OPpPAD_STATE)
9245 && ( left->op_type == OP_PADSV
9246 || left->op_type == OP_PADAV
9247 || left->op_type == OP_PADHV
9248 || left->op_type == OP_PADANY)
9249 ) {
9250 /* All single variable list context state assignments, hence
9251 state ($a) = ...
9252 (state $a) = ...
9253 state @a = ...
9254 state (@a) = ...
9255 (state @a) = ...
9256 state %a = ...
9257 state (%a) = ...
9258 (state %a) = ...
9259 */
9260 if (left->op_flags & OPf_PARENS)
9261 yyerror(no_list_state);
9262 else
9263 state_var_op = left;
9264 }
9265
9266 /* optimise @a = split(...) into:
9267 * @{expr}: split(..., @{expr}) (where @a is not flattened)
9268 * @a, my @a, local @a: split(...) (where @a is attached to
9269 * the split op itself)
9270 */
9271
9272 if ( right
9273 && right->op_type == OP_SPLIT
9274 /* don't do twice, e.g. @b = (@a = split) */
9275 && !(right->op_private & OPpSPLIT_ASSIGN))
9276 {
9277 OP *gvop = NULL;
9278
9279 if ( ( left->op_type == OP_RV2AV
9280 && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
9281 || left->op_type == OP_PADAV)
9282 {
9283 /* @pkg or @lex or local @pkg' or 'my @lex' */
9284 OP *tmpop;
9285 if (gvop) {
9286 #ifdef USE_ITHREADS
9287 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
9288 = cPADOPx(gvop)->op_padix;
9289 cPADOPx(gvop)->op_padix = 0; /* steal it */
9290 #else
9291 ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
9292 = MUTABLE_GV(cSVOPx(gvop)->op_sv);
9293 cSVOPx(gvop)->op_sv = NULL; /* steal it */
9294 #endif
9295 right->op_private |=
9296 left->op_private & OPpOUR_INTRO;
9297 }
9298 else {
9299 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
9300 left->op_targ = 0; /* steal it */
9301 right->op_private |= OPpSPLIT_LEX;
9302 }
9303 right->op_private |= left->op_private & OPpLVAL_INTRO;
9304
9305 detach_split:
9306 tmpop = cUNOPo->op_first; /* to list (nulled) */
9307 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
9308 assert(OpSIBLING(tmpop) == right);
9309 assert(!OpHAS_SIBLING(right));
9310 /* detach the split subtreee from the o tree,
9311 * then free the residual o tree */
9312 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
9313 op_free(o); /* blow off assign */
9314 right->op_private |= OPpSPLIT_ASSIGN;
9315 right->op_flags &= ~OPf_WANT;
9316 /* "I don't know and I don't care." */
9317 return right;
9318 }
9319 else if (left->op_type == OP_RV2AV) {
9320 /* @{expr} */
9321
9322 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
9323 assert(OpSIBLING(pushop) == left);
9324 /* Detach the array ... */
9325 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
9326 /* ... and attach it to the split. */
9327 op_sibling_splice(right, cLISTOPx(right)->op_last,
9328 0, left);
9329 right->op_flags |= OPf_STACKED;
9330 /* Detach split and expunge aassign as above. */
9331 goto detach_split;
9332 }
9333 else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
9334 ((LISTOP*)right)->op_last->op_type == OP_CONST)
9335 {
9336 /* convert split(...,0) to split(..., PL_modcount+1) */
9337 SV ** const svp =
9338 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
9339 SV * const sv = *svp;
9340 if (SvIOK(sv) && SvIVX(sv) == 0)
9341 {
9342 if (right->op_private & OPpSPLIT_IMPLIM) {
9343 /* our own SV, created in ck_split */
9344 SvREADONLY_off(sv);
9345 sv_setiv(sv, PL_modcount+1);
9346 }
9347 else {
9348 /* SV may belong to someone else */
9349 SvREFCNT_dec(sv);
9350 *svp = newSViv(PL_modcount+1);
9351 }
9352 }
9353 }
9354 }
9355
9356 if (state_var_op)
9357 o = S_newONCEOP(aTHX_ o, state_var_op);
9358 return o;
9359 }
9360 if (assign_type == ASSIGN_REF)
9361 return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
9362 if (!right)
9363 right = newOP(OP_UNDEF, 0);
9364 if (right->op_type == OP_READLINE) {
9365 right->op_flags |= OPf_STACKED;
9366 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
9367 scalar(right));
9368 }
9369 else {
9370 o = newBINOP(OP_SASSIGN, flags,
9371 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
9372 }
9373 return o;
9374 }
9375
9376 /*
9377 =for apidoc newSTATEOP
9378
9379 Constructs a state op (COP). The state op is normally a C<nextstate> op,
9380 but will be a C<dbstate> op if debugging is enabled for currently-compiled
9381 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
9382 If C<label> is non-null, it supplies the name of a label to attach to
9383 the state op; this function takes ownership of the memory pointed at by
9384 C<label>, and will free it. C<flags> gives the eight bits of C<op_flags>
9385 for the state op.
9386
9387 If C<o> is null, the state op is returned. Otherwise the state op is
9388 combined with C<o> into a C<lineseq> list op, which is returned. C<o>
9389 is consumed by this function and becomes part of the returned op tree.
9390
9391 =cut
9392 */
9393
9394 OP *
Perl_newSTATEOP(pTHX_ I32 flags,char * label,OP * o)9395 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
9396 {
9397 dVAR;
9398 const U32 seq = intro_my();
9399 const U32 utf8 = flags & SVf_UTF8;
9400 COP *cop;
9401
9402 PL_parser->parsed_sub = 0;
9403
9404 flags &= ~SVf_UTF8;
9405
9406 NewOp(1101, cop, 1, COP);
9407 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
9408 OpTYPE_set(cop, OP_DBSTATE);
9409 }
9410 else {
9411 OpTYPE_set(cop, OP_NEXTSTATE);
9412 }
9413 cop->op_flags = (U8)flags;
9414 CopHINTS_set(cop, PL_hints);
9415 #ifdef VMS
9416 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
9417 #endif
9418 cop->op_next = (OP*)cop;
9419
9420 cop->cop_seq = seq;
9421 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
9422 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
9423 if (label) {
9424 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
9425
9426 PL_hints |= HINT_BLOCK_SCOPE;
9427 /* It seems that we need to defer freeing this pointer, as other parts
9428 of the grammar end up wanting to copy it after this op has been
9429 created. */
9430 SAVEFREEPV(label);
9431 }
9432
9433 if (PL_parser->preambling != NOLINE) {
9434 CopLINE_set(cop, PL_parser->preambling);
9435 PL_parser->copline = NOLINE;
9436 }
9437 else if (PL_parser->copline == NOLINE)
9438 CopLINE_set(cop, CopLINE(PL_curcop));
9439 else {
9440 CopLINE_set(cop, PL_parser->copline);
9441 PL_parser->copline = NOLINE;
9442 }
9443 #ifdef USE_ITHREADS
9444 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
9445 #else
9446 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
9447 #endif
9448 CopSTASH_set(cop, PL_curstash);
9449
9450 if (cop->op_type == OP_DBSTATE) {
9451 /* this line can have a breakpoint - store the cop in IV */
9452 AV *av = CopFILEAVx(PL_curcop);
9453 if (av) {
9454 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
9455 if (svp && *svp != &PL_sv_undef ) {
9456 (void)SvIOK_on(*svp);
9457 SvIV_set(*svp, PTR2IV(cop));
9458 }
9459 }
9460 }
9461
9462 if (flags & OPf_SPECIAL)
9463 op_null((OP*)cop);
9464 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
9465 }
9466
9467 /*
9468 =for apidoc newLOGOP
9469
9470 Constructs, checks, and returns a logical (flow control) op. C<type>
9471 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
9472 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
9473 the eight bits of C<op_private>, except that the bit with value 1 is
9474 automatically set. C<first> supplies the expression controlling the
9475 flow, and C<other> supplies the side (alternate) chain of ops; they are
9476 consumed by this function and become part of the constructed op tree.
9477
9478 =cut
9479 */
9480
9481 OP *
Perl_newLOGOP(pTHX_ I32 type,I32 flags,OP * first,OP * other)9482 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
9483 {
9484 PERL_ARGS_ASSERT_NEWLOGOP;
9485
9486 return new_logop(type, flags, &first, &other);
9487 }
9488
9489
9490 /* See if the optree o contains a single OP_CONST (plus possibly
9491 * surrounding enter/nextstate/null etc). If so, return it, else return
9492 * NULL.
9493 */
9494
9495 STATIC OP *
S_search_const(pTHX_ OP * o)9496 S_search_const(pTHX_ OP *o)
9497 {
9498 PERL_ARGS_ASSERT_SEARCH_CONST;
9499
9500 redo:
9501 switch (o->op_type) {
9502 case OP_CONST:
9503 return o;
9504 case OP_NULL:
9505 if (o->op_flags & OPf_KIDS) {
9506 o = cUNOPo->op_first;
9507 goto redo;
9508 }
9509 break;
9510 case OP_LEAVE:
9511 case OP_SCOPE:
9512 case OP_LINESEQ:
9513 {
9514 OP *kid;
9515 if (!(o->op_flags & OPf_KIDS))
9516 return NULL;
9517 kid = cLISTOPo->op_first;
9518
9519 do {
9520 switch (kid->op_type) {
9521 case OP_ENTER:
9522 case OP_NULL:
9523 case OP_NEXTSTATE:
9524 kid = OpSIBLING(kid);
9525 break;
9526 default:
9527 if (kid != cLISTOPo->op_last)
9528 return NULL;
9529 goto last;
9530 }
9531 } while (kid);
9532
9533 if (!kid)
9534 kid = cLISTOPo->op_last;
9535 last:
9536 o = kid;
9537 goto redo;
9538 }
9539 }
9540
9541 return NULL;
9542 }
9543
9544
9545 STATIC OP *
S_new_logop(pTHX_ I32 type,I32 flags,OP ** firstp,OP ** otherp)9546 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
9547 {
9548 dVAR;
9549 LOGOP *logop;
9550 OP *o;
9551 OP *first;
9552 OP *other;
9553 OP *cstop = NULL;
9554 int prepend_not = 0;
9555
9556 PERL_ARGS_ASSERT_NEW_LOGOP;
9557
9558 first = *firstp;
9559 other = *otherp;
9560
9561 /* [perl #59802]: Warn about things like "return $a or $b", which
9562 is parsed as "(return $a) or $b" rather than "return ($a or
9563 $b)". NB: This also applies to xor, which is why we do it
9564 here.
9565 */
9566 switch (first->op_type) {
9567 case OP_NEXT:
9568 case OP_LAST:
9569 case OP_REDO:
9570 /* XXX: Perhaps we should emit a stronger warning for these.
9571 Even with the high-precedence operator they don't seem to do
9572 anything sensible.
9573
9574 But until we do, fall through here.
9575 */
9576 case OP_RETURN:
9577 case OP_EXIT:
9578 case OP_DIE:
9579 case OP_GOTO:
9580 /* XXX: Currently we allow people to "shoot themselves in the
9581 foot" by explicitly writing "(return $a) or $b".
9582
9583 Warn unless we are looking at the result from folding or if
9584 the programmer explicitly grouped the operators like this.
9585 The former can occur with e.g.
9586
9587 use constant FEATURE => ( $] >= ... );
9588 sub { not FEATURE and return or do_stuff(); }
9589 */
9590 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
9591 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9592 "Possible precedence issue with control flow operator");
9593 /* XXX: Should we optimze this to "return $a;" (i.e. remove
9594 the "or $b" part)?
9595 */
9596 break;
9597 }
9598
9599 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
9600 return newBINOP(type, flags, scalar(first), scalar(other));
9601
9602 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
9603 || type == OP_CUSTOM);
9604
9605 scalarboolean(first);
9606
9607 /* search for a constant op that could let us fold the test */
9608 if ((cstop = search_const(first))) {
9609 if (cstop->op_private & OPpCONST_STRICT)
9610 no_bareword_allowed(cstop);
9611 else if ((cstop->op_private & OPpCONST_BARE))
9612 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
9613 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
9614 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
9615 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
9616 /* Elide the (constant) lhs, since it can't affect the outcome */
9617 *firstp = NULL;
9618 if (other->op_type == OP_CONST)
9619 other->op_private |= OPpCONST_SHORTCIRCUIT;
9620 op_free(first);
9621 if (other->op_type == OP_LEAVE)
9622 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
9623 else if (other->op_type == OP_MATCH
9624 || other->op_type == OP_SUBST
9625 || other->op_type == OP_TRANSR
9626 || other->op_type == OP_TRANS)
9627 /* Mark the op as being unbindable with =~ */
9628 other->op_flags |= OPf_SPECIAL;
9629
9630 other->op_folded = 1;
9631 return other;
9632 }
9633 else {
9634 /* Elide the rhs, since the outcome is entirely determined by
9635 * the (constant) lhs */
9636
9637 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
9638 const OP *o2 = other;
9639 if ( ! (o2->op_type == OP_LIST
9640 && (( o2 = cUNOPx(o2)->op_first))
9641 && o2->op_type == OP_PUSHMARK
9642 && (( o2 = OpSIBLING(o2))) )
9643 )
9644 o2 = other;
9645 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
9646 || o2->op_type == OP_PADHV)
9647 && o2->op_private & OPpLVAL_INTRO
9648 && !(o2->op_private & OPpPAD_STATE))
9649 {
9650 Perl_croak(aTHX_ "This use of my() in false conditional is "
9651 "no longer allowed");
9652 }
9653
9654 *otherp = NULL;
9655 if (cstop->op_type == OP_CONST)
9656 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
9657 op_free(other);
9658 return first;
9659 }
9660 }
9661 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
9662 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
9663 {
9664 const OP * const k1 = ((UNOP*)first)->op_first;
9665 const OP * const k2 = OpSIBLING(k1);
9666 OPCODE warnop = 0;
9667 switch (first->op_type)
9668 {
9669 case OP_NULL:
9670 if (k2 && k2->op_type == OP_READLINE
9671 && (k2->op_flags & OPf_STACKED)
9672 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
9673 {
9674 warnop = k2->op_type;
9675 }
9676 break;
9677
9678 case OP_SASSIGN:
9679 if (k1->op_type == OP_READDIR
9680 || k1->op_type == OP_GLOB
9681 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
9682 || k1->op_type == OP_EACH
9683 || k1->op_type == OP_AEACH)
9684 {
9685 warnop = ((k1->op_type == OP_NULL)
9686 ? (OPCODE)k1->op_targ : k1->op_type);
9687 }
9688 break;
9689 }
9690 if (warnop) {
9691 const line_t oldline = CopLINE(PL_curcop);
9692 /* This ensures that warnings are reported at the first line
9693 of the construction, not the last. */
9694 CopLINE_set(PL_curcop, PL_parser->copline);
9695 Perl_warner(aTHX_ packWARN(WARN_MISC),
9696 "Value of %s%s can be \"0\"; test with defined()",
9697 PL_op_desc[warnop],
9698 ((warnop == OP_READLINE || warnop == OP_GLOB)
9699 ? " construct" : "() operator"));
9700 CopLINE_set(PL_curcop, oldline);
9701 }
9702 }
9703
9704 /* optimize AND and OR ops that have NOTs as children */
9705 if (first->op_type == OP_NOT
9706 && (first->op_flags & OPf_KIDS)
9707 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
9708 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
9709 ) {
9710 if (type == OP_AND || type == OP_OR) {
9711 if (type == OP_AND)
9712 type = OP_OR;
9713 else
9714 type = OP_AND;
9715 op_null(first);
9716 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
9717 op_null(other);
9718 prepend_not = 1; /* prepend a NOT op later */
9719 }
9720 }
9721 }
9722
9723 logop = alloc_LOGOP(type, first, LINKLIST(other));
9724 logop->op_flags |= (U8)flags;
9725 logop->op_private = (U8)(1 | (flags >> 8));
9726
9727 /* establish postfix order */
9728 logop->op_next = LINKLIST(first);
9729 first->op_next = (OP*)logop;
9730 assert(!OpHAS_SIBLING(first));
9731 op_sibling_splice((OP*)logop, first, 0, other);
9732
9733 CHECKOP(type,logop);
9734
9735 o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
9736 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
9737 (OP*)logop);
9738 other->op_next = o;
9739
9740 return o;
9741 }
9742
9743 /*
9744 =for apidoc newCONDOP
9745
9746 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
9747 op. C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
9748 will be set automatically, and, shifted up eight bits, the eight bits of
9749 C<op_private>, except that the bit with value 1 is automatically set.
9750 C<first> supplies the expression selecting between the two branches,
9751 and C<trueop> and C<falseop> supply the branches; they are consumed by
9752 this function and become part of the constructed op tree.
9753
9754 =cut
9755 */
9756
9757 OP *
Perl_newCONDOP(pTHX_ I32 flags,OP * first,OP * trueop,OP * falseop)9758 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
9759 {
9760 dVAR;
9761 LOGOP *logop;
9762 OP *start;
9763 OP *o;
9764 OP *cstop;
9765
9766 PERL_ARGS_ASSERT_NEWCONDOP;
9767
9768 if (!falseop)
9769 return newLOGOP(OP_AND, 0, first, trueop);
9770 if (!trueop)
9771 return newLOGOP(OP_OR, 0, first, falseop);
9772
9773 scalarboolean(first);
9774 if ((cstop = search_const(first))) {
9775 /* Left or right arm of the conditional? */
9776 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
9777 OP *live = left ? trueop : falseop;
9778 OP *const dead = left ? falseop : trueop;
9779 if (cstop->op_private & OPpCONST_BARE &&
9780 cstop->op_private & OPpCONST_STRICT) {
9781 no_bareword_allowed(cstop);
9782 }
9783 op_free(first);
9784 op_free(dead);
9785 if (live->op_type == OP_LEAVE)
9786 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
9787 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
9788 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
9789 /* Mark the op as being unbindable with =~ */
9790 live->op_flags |= OPf_SPECIAL;
9791 live->op_folded = 1;
9792 return live;
9793 }
9794 logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
9795 logop->op_flags |= (U8)flags;
9796 logop->op_private = (U8)(1 | (flags >> 8));
9797 logop->op_next = LINKLIST(falseop);
9798
9799 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
9800 logop);
9801
9802 /* establish postfix order */
9803 start = LINKLIST(first);
9804 first->op_next = (OP*)logop;
9805
9806 /* make first, trueop, falseop siblings */
9807 op_sibling_splice((OP*)logop, first, 0, trueop);
9808 op_sibling_splice((OP*)logop, trueop, 0, falseop);
9809
9810 o = newUNOP(OP_NULL, 0, (OP*)logop);
9811
9812 trueop->op_next = falseop->op_next = o;
9813
9814 o->op_next = start;
9815 return o;
9816 }
9817
9818 /*
9819 =for apidoc newRANGE
9820
9821 Constructs and returns a C<range> op, with subordinate C<flip> and
9822 C<flop> ops. C<flags> gives the eight bits of C<op_flags> for the
9823 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
9824 for both the C<flip> and C<range> ops, except that the bit with value
9825 1 is automatically set. C<left> and C<right> supply the expressions
9826 controlling the endpoints of the range; they are consumed by this function
9827 and become part of the constructed op tree.
9828
9829 =cut
9830 */
9831
9832 OP *
Perl_newRANGE(pTHX_ I32 flags,OP * left,OP * right)9833 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
9834 {
9835 LOGOP *range;
9836 OP *flip;
9837 OP *flop;
9838 OP *leftstart;
9839 OP *o;
9840
9841 PERL_ARGS_ASSERT_NEWRANGE;
9842
9843 range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
9844 range->op_flags = OPf_KIDS;
9845 leftstart = LINKLIST(left);
9846 range->op_private = (U8)(1 | (flags >> 8));
9847
9848 /* make left and right siblings */
9849 op_sibling_splice((OP*)range, left, 0, right);
9850
9851 range->op_next = (OP*)range;
9852 flip = newUNOP(OP_FLIP, flags, (OP*)range);
9853 flop = newUNOP(OP_FLOP, 0, flip);
9854 o = newUNOP(OP_NULL, 0, flop);
9855 LINKLIST(flop);
9856 range->op_next = leftstart;
9857
9858 left->op_next = flip;
9859 right->op_next = flop;
9860
9861 range->op_targ =
9862 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
9863 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
9864 flip->op_targ =
9865 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
9866 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
9867 SvPADTMP_on(PAD_SV(flip->op_targ));
9868
9869 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
9870 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
9871
9872 /* check barewords before they might be optimized aways */
9873 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
9874 no_bareword_allowed(left);
9875 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
9876 no_bareword_allowed(right);
9877
9878 flip->op_next = o;
9879 if (!flip->op_private || !flop->op_private)
9880 LINKLIST(o); /* blow off optimizer unless constant */
9881
9882 return o;
9883 }
9884
9885 /*
9886 =for apidoc newLOOPOP
9887
9888 Constructs, checks, and returns an op tree expressing a loop. This is
9889 only a loop in the control flow through the op tree; it does not have
9890 the heavyweight loop structure that allows exiting the loop by C<last>
9891 and suchlike. C<flags> gives the eight bits of C<op_flags> for the
9892 top-level op, except that some bits will be set automatically as required.
9893 C<expr> supplies the expression controlling loop iteration, and C<block>
9894 supplies the body of the loop; they are consumed by this function and
9895 become part of the constructed op tree. C<debuggable> is currently
9896 unused and should always be 1.
9897
9898 =cut
9899 */
9900
9901 OP *
Perl_newLOOPOP(pTHX_ I32 flags,I32 debuggable,OP * expr,OP * block)9902 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
9903 {
9904 OP* listop;
9905 OP* o;
9906 const bool once = block && block->op_flags & OPf_SPECIAL &&
9907 block->op_type == OP_NULL;
9908
9909 PERL_UNUSED_ARG(debuggable);
9910
9911 if (expr) {
9912 if (once && (
9913 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
9914 || ( expr->op_type == OP_NOT
9915 && cUNOPx(expr)->op_first->op_type == OP_CONST
9916 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
9917 )
9918 ))
9919 /* Return the block now, so that S_new_logop does not try to
9920 fold it away. */
9921 {
9922 op_free(expr);
9923 return block; /* do {} while 0 does once */
9924 }
9925
9926 if (expr->op_type == OP_READLINE
9927 || expr->op_type == OP_READDIR
9928 || expr->op_type == OP_GLOB
9929 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
9930 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
9931 expr = newUNOP(OP_DEFINED, 0,
9932 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
9933 } else if (expr->op_flags & OPf_KIDS) {
9934 const OP * const k1 = ((UNOP*)expr)->op_first;
9935 const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
9936 switch (expr->op_type) {
9937 case OP_NULL:
9938 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
9939 && (k2->op_flags & OPf_STACKED)
9940 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
9941 expr = newUNOP(OP_DEFINED, 0, expr);
9942 break;
9943
9944 case OP_SASSIGN:
9945 if (k1 && (k1->op_type == OP_READDIR
9946 || k1->op_type == OP_GLOB
9947 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
9948 || k1->op_type == OP_EACH
9949 || k1->op_type == OP_AEACH))
9950 expr = newUNOP(OP_DEFINED, 0, expr);
9951 break;
9952 }
9953 }
9954 }
9955
9956 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
9957 * op, in listop. This is wrong. [perl #27024] */
9958 if (!block)
9959 block = newOP(OP_NULL, 0);
9960 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
9961 o = new_logop(OP_AND, 0, &expr, &listop);
9962
9963 if (once) {
9964 ASSUME(listop);
9965 }
9966
9967 if (listop)
9968 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
9969
9970 if (once && o != listop)
9971 {
9972 assert(cUNOPo->op_first->op_type == OP_AND
9973 || cUNOPo->op_first->op_type == OP_OR);
9974 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
9975 }
9976
9977 if (o == listop)
9978 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
9979
9980 o->op_flags |= flags;
9981 o = op_scope(o);
9982 o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
9983 return o;
9984 }
9985
9986 /*
9987 =for apidoc newWHILEOP
9988
9989 Constructs, checks, and returns an op tree expressing a C<while> loop.
9990 This is a heavyweight loop, with structure that allows exiting the loop
9991 by C<last> and suchlike.
9992
9993 C<loop> is an optional preconstructed C<enterloop> op to use in the
9994 loop; if it is null then a suitable op will be constructed automatically.
9995 C<expr> supplies the loop's controlling expression. C<block> supplies the
9996 main body of the loop, and C<cont> optionally supplies a C<continue> block
9997 that operates as a second half of the body. All of these optree inputs
9998 are consumed by this function and become part of the constructed op tree.
9999
10000 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
10001 op and, shifted up eight bits, the eight bits of C<op_private> for
10002 the C<leaveloop> op, except that (in both cases) some bits will be set
10003 automatically. C<debuggable> is currently unused and should always be 1.
10004 C<has_my> can be supplied as true to force the
10005 loop body to be enclosed in its own scope.
10006
10007 =cut
10008 */
10009
10010 OP *
Perl_newWHILEOP(pTHX_ I32 flags,I32 debuggable,LOOP * loop,OP * expr,OP * block,OP * cont,I32 has_my)10011 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
10012 OP *expr, OP *block, OP *cont, I32 has_my)
10013 {
10014 dVAR;
10015 OP *redo;
10016 OP *next = NULL;
10017 OP *listop;
10018 OP *o;
10019 U8 loopflags = 0;
10020
10021 PERL_UNUSED_ARG(debuggable);
10022
10023 if (expr) {
10024 if (expr->op_type == OP_READLINE
10025 || expr->op_type == OP_READDIR
10026 || expr->op_type == OP_GLOB
10027 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
10028 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
10029 expr = newUNOP(OP_DEFINED, 0,
10030 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
10031 } else if (expr->op_flags & OPf_KIDS) {
10032 const OP * const k1 = ((UNOP*)expr)->op_first;
10033 const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
10034 switch (expr->op_type) {
10035 case OP_NULL:
10036 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
10037 && (k2->op_flags & OPf_STACKED)
10038 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
10039 expr = newUNOP(OP_DEFINED, 0, expr);
10040 break;
10041
10042 case OP_SASSIGN:
10043 if (k1 && (k1->op_type == OP_READDIR
10044 || k1->op_type == OP_GLOB
10045 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
10046 || k1->op_type == OP_EACH
10047 || k1->op_type == OP_AEACH))
10048 expr = newUNOP(OP_DEFINED, 0, expr);
10049 break;
10050 }
10051 }
10052 }
10053
10054 if (!block)
10055 block = newOP(OP_NULL, 0);
10056 else if (cont || has_my) {
10057 block = op_scope(block);
10058 }
10059
10060 if (cont) {
10061 next = LINKLIST(cont);
10062 }
10063 if (expr) {
10064 OP * const unstack = newOP(OP_UNSTACK, 0);
10065 if (!next)
10066 next = unstack;
10067 cont = op_append_elem(OP_LINESEQ, cont, unstack);
10068 }
10069
10070 assert(block);
10071 listop = op_append_list(OP_LINESEQ, block, cont);
10072 assert(listop);
10073 redo = LINKLIST(listop);
10074
10075 if (expr) {
10076 scalar(listop);
10077 o = new_logop(OP_AND, 0, &expr, &listop);
10078 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
10079 op_free((OP*)loop);
10080 return expr; /* listop already freed by new_logop */
10081 }
10082 if (listop)
10083 ((LISTOP*)listop)->op_last->op_next =
10084 (o == listop ? redo : LINKLIST(o));
10085 }
10086 else
10087 o = listop;
10088
10089 if (!loop) {
10090 NewOp(1101,loop,1,LOOP);
10091 OpTYPE_set(loop, OP_ENTERLOOP);
10092 loop->op_private = 0;
10093 loop->op_next = (OP*)loop;
10094 }
10095
10096 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
10097
10098 loop->op_redoop = redo;
10099 loop->op_lastop = o;
10100 o->op_private |= loopflags;
10101
10102 if (next)
10103 loop->op_nextop = next;
10104 else
10105 loop->op_nextop = o;
10106
10107 o->op_flags |= flags;
10108 o->op_private |= (flags >> 8);
10109 return o;
10110 }
10111
10112 /*
10113 =for apidoc newFOROP
10114
10115 Constructs, checks, and returns an op tree expressing a C<foreach>
10116 loop (iteration through a list of values). This is a heavyweight loop,
10117 with structure that allows exiting the loop by C<last> and suchlike.
10118
10119 C<sv> optionally supplies the variable that will be aliased to each
10120 item in turn; if null, it defaults to C<$_>.
10121 C<expr> supplies the list of values to iterate over. C<block> supplies
10122 the main body of the loop, and C<cont> optionally supplies a C<continue>
10123 block that operates as a second half of the body. All of these optree
10124 inputs are consumed by this function and become part of the constructed
10125 op tree.
10126
10127 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
10128 op and, shifted up eight bits, the eight bits of C<op_private> for
10129 the C<leaveloop> op, except that (in both cases) some bits will be set
10130 automatically.
10131
10132 =cut
10133 */
10134
10135 OP *
Perl_newFOROP(pTHX_ I32 flags,OP * sv,OP * expr,OP * block,OP * cont)10136 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
10137 {
10138 dVAR;
10139 LOOP *loop;
10140 OP *wop;
10141 PADOFFSET padoff = 0;
10142 I32 iterflags = 0;
10143 I32 iterpflags = 0;
10144
10145 PERL_ARGS_ASSERT_NEWFOROP;
10146
10147 if (sv) {
10148 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
10149 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
10150 OpTYPE_set(sv, OP_RV2GV);
10151
10152 /* The op_type check is needed to prevent a possible segfault
10153 * if the loop variable is undeclared and 'strict vars' is in
10154 * effect. This is illegal but is nonetheless parsed, so we
10155 * may reach this point with an OP_CONST where we're expecting
10156 * an OP_GV.
10157 */
10158 if (cUNOPx(sv)->op_first->op_type == OP_GV
10159 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
10160 iterpflags |= OPpITER_DEF;
10161 }
10162 else if (sv->op_type == OP_PADSV) { /* private variable */
10163 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
10164 padoff = sv->op_targ;
10165 sv->op_targ = 0;
10166 op_free(sv);
10167 sv = NULL;
10168 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
10169 }
10170 else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
10171 NOOP;
10172 else
10173 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
10174 if (padoff) {
10175 PADNAME * const pn = PAD_COMPNAME(padoff);
10176 const char * const name = PadnamePV(pn);
10177
10178 if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
10179 iterpflags |= OPpITER_DEF;
10180 }
10181 }
10182 else {
10183 sv = newGVOP(OP_GV, 0, PL_defgv);
10184 iterpflags |= OPpITER_DEF;
10185 }
10186
10187 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
10188 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
10189 iterflags |= OPf_STACKED;
10190 }
10191 else if (expr->op_type == OP_NULL &&
10192 (expr->op_flags & OPf_KIDS) &&
10193 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
10194 {
10195 /* Basically turn for($x..$y) into the same as for($x,$y), but we
10196 * set the STACKED flag to indicate that these values are to be
10197 * treated as min/max values by 'pp_enteriter'.
10198 */
10199 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
10200 LOGOP* const range = (LOGOP*) flip->op_first;
10201 OP* const left = range->op_first;
10202 OP* const right = OpSIBLING(left);
10203 LISTOP* listop;
10204
10205 range->op_flags &= ~OPf_KIDS;
10206 /* detach range's children */
10207 op_sibling_splice((OP*)range, NULL, -1, NULL);
10208
10209 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
10210 listop->op_first->op_next = range->op_next;
10211 left->op_next = range->op_other;
10212 right->op_next = (OP*)listop;
10213 listop->op_next = listop->op_first;
10214
10215 op_free(expr);
10216 expr = (OP*)(listop);
10217 op_null(expr);
10218 iterflags |= OPf_STACKED;
10219 }
10220 else {
10221 expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
10222 }
10223
10224 loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
10225 op_append_elem(OP_LIST, list(expr),
10226 scalar(sv)));
10227 assert(!loop->op_next);
10228 /* for my $x () sets OPpLVAL_INTRO;
10229 * for our $x () sets OPpOUR_INTRO */
10230 loop->op_private = (U8)iterpflags;
10231
10232 /* upgrade loop from a LISTOP to a LOOPOP;
10233 * keep it in-place if there's space */
10234 if (loop->op_slabbed
10235 && OpSLOT(loop)->opslot_size
10236 < SIZE_TO_PSIZE(sizeof(LOOP)) + OPSLOT_HEADER_P)
10237 {
10238 /* no space; allocate new op */
10239 LOOP *tmp;
10240 NewOp(1234,tmp,1,LOOP);
10241 Copy(loop,tmp,1,LISTOP);
10242 assert(loop->op_last->op_sibparent == (OP*)loop);
10243 OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
10244 S_op_destroy(aTHX_ (OP*)loop);
10245 loop = tmp;
10246 }
10247 else if (!loop->op_slabbed)
10248 {
10249 /* loop was malloc()ed */
10250 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
10251 OpLASTSIB_set(loop->op_last, (OP*)loop);
10252 }
10253 loop->op_targ = padoff;
10254 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
10255 return wop;
10256 }
10257
10258 /*
10259 =for apidoc newLOOPEX
10260
10261 Constructs, checks, and returns a loop-exiting op (such as C<goto>
10262 or C<last>). C<type> is the opcode. C<label> supplies the parameter
10263 determining the target of the op; it is consumed by this function and
10264 becomes part of the constructed op tree.
10265
10266 =cut
10267 */
10268
10269 OP*
Perl_newLOOPEX(pTHX_ I32 type,OP * label)10270 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
10271 {
10272 OP *o = NULL;
10273
10274 PERL_ARGS_ASSERT_NEWLOOPEX;
10275
10276 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
10277 || type == OP_CUSTOM);
10278
10279 if (type != OP_GOTO) {
10280 /* "last()" means "last" */
10281 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
10282 o = newOP(type, OPf_SPECIAL);
10283 }
10284 }
10285 else {
10286 /* Check whether it's going to be a goto &function */
10287 if (label->op_type == OP_ENTERSUB
10288 && !(label->op_flags & OPf_STACKED))
10289 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
10290 }
10291
10292 /* Check for a constant argument */
10293 if (label->op_type == OP_CONST) {
10294 SV * const sv = ((SVOP *)label)->op_sv;
10295 STRLEN l;
10296 const char *s = SvPV_const(sv,l);
10297 if (l == strlen(s)) {
10298 o = newPVOP(type,
10299 SvUTF8(((SVOP*)label)->op_sv),
10300 savesharedpv(
10301 SvPV_nolen_const(((SVOP*)label)->op_sv)));
10302 }
10303 }
10304
10305 /* If we have already created an op, we do not need the label. */
10306 if (o)
10307 op_free(label);
10308 else o = newUNOP(type, OPf_STACKED, label);
10309
10310 PL_hints |= HINT_BLOCK_SCOPE;
10311 return o;
10312 }
10313
10314 /* if the condition is a literal array or hash
10315 (or @{ ... } etc), make a reference to it.
10316 */
10317 STATIC OP *
S_ref_array_or_hash(pTHX_ OP * cond)10318 S_ref_array_or_hash(pTHX_ OP *cond)
10319 {
10320 if (cond
10321 && (cond->op_type == OP_RV2AV
10322 || cond->op_type == OP_PADAV
10323 || cond->op_type == OP_RV2HV
10324 || cond->op_type == OP_PADHV))
10325
10326 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
10327
10328 else if(cond
10329 && (cond->op_type == OP_ASLICE
10330 || cond->op_type == OP_KVASLICE
10331 || cond->op_type == OP_HSLICE
10332 || cond->op_type == OP_KVHSLICE)) {
10333
10334 /* anonlist now needs a list from this op, was previously used in
10335 * scalar context */
10336 cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
10337 cond->op_flags |= OPf_WANT_LIST;
10338
10339 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
10340 }
10341
10342 else
10343 return cond;
10344 }
10345
10346 /* These construct the optree fragments representing given()
10347 and when() blocks.
10348
10349 entergiven and enterwhen are LOGOPs; the op_other pointer
10350 points up to the associated leave op. We need this so we
10351 can put it in the context and make break/continue work.
10352 (Also, of course, pp_enterwhen will jump straight to
10353 op_other if the match fails.)
10354 */
10355
10356 STATIC OP *
S_newGIVWHENOP(pTHX_ OP * cond,OP * block,I32 enter_opcode,I32 leave_opcode,PADOFFSET entertarg)10357 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
10358 I32 enter_opcode, I32 leave_opcode,
10359 PADOFFSET entertarg)
10360 {
10361 dVAR;
10362 LOGOP *enterop;
10363 OP *o;
10364
10365 PERL_ARGS_ASSERT_NEWGIVWHENOP;
10366 PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
10367
10368 enterop = alloc_LOGOP(enter_opcode, block, NULL);
10369 enterop->op_targ = 0;
10370 enterop->op_private = 0;
10371
10372 o = newUNOP(leave_opcode, 0, (OP *) enterop);
10373
10374 if (cond) {
10375 /* prepend cond if we have one */
10376 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
10377
10378 o->op_next = LINKLIST(cond);
10379 cond->op_next = (OP *) enterop;
10380 }
10381 else {
10382 /* This is a default {} block */
10383 enterop->op_flags |= OPf_SPECIAL;
10384 o ->op_flags |= OPf_SPECIAL;
10385
10386 o->op_next = (OP *) enterop;
10387 }
10388
10389 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
10390 entergiven and enterwhen both
10391 use ck_null() */
10392
10393 enterop->op_next = LINKLIST(block);
10394 block->op_next = enterop->op_other = o;
10395
10396 return o;
10397 }
10398
10399
10400 /* For the purposes of 'when(implied_smartmatch)'
10401 * versus 'when(boolean_expression)',
10402 * does this look like a boolean operation? For these purposes
10403 a boolean operation is:
10404 - a subroutine call [*]
10405 - a logical connective
10406 - a comparison operator
10407 - a filetest operator, with the exception of -s -M -A -C
10408 - defined(), exists() or eof()
10409 - /$re/ or $foo =~ /$re/
10410
10411 [*] possibly surprising
10412 */
10413 STATIC bool
S_looks_like_bool(pTHX_ const OP * o)10414 S_looks_like_bool(pTHX_ const OP *o)
10415 {
10416 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
10417
10418 switch(o->op_type) {
10419 case OP_OR:
10420 case OP_DOR:
10421 return looks_like_bool(cLOGOPo->op_first);
10422
10423 case OP_AND:
10424 {
10425 OP* sibl = OpSIBLING(cLOGOPo->op_first);
10426 ASSUME(sibl);
10427 return (
10428 looks_like_bool(cLOGOPo->op_first)
10429 && looks_like_bool(sibl));
10430 }
10431
10432 case OP_NULL:
10433 case OP_SCALAR:
10434 return (
10435 o->op_flags & OPf_KIDS
10436 && looks_like_bool(cUNOPo->op_first));
10437
10438 case OP_ENTERSUB:
10439
10440 case OP_NOT: case OP_XOR:
10441
10442 case OP_EQ: case OP_NE: case OP_LT:
10443 case OP_GT: case OP_LE: case OP_GE:
10444
10445 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
10446 case OP_I_GT: case OP_I_LE: case OP_I_GE:
10447
10448 case OP_SEQ: case OP_SNE: case OP_SLT:
10449 case OP_SGT: case OP_SLE: case OP_SGE:
10450
10451 case OP_SMARTMATCH:
10452
10453 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
10454 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
10455 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
10456 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
10457 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
10458 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
10459 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
10460 case OP_FTTEXT: case OP_FTBINARY:
10461
10462 case OP_DEFINED: case OP_EXISTS:
10463 case OP_MATCH: case OP_EOF:
10464
10465 case OP_FLOP:
10466
10467 return TRUE;
10468
10469 case OP_INDEX:
10470 case OP_RINDEX:
10471 /* optimised-away (index() != -1) or similar comparison */
10472 if (o->op_private & OPpTRUEBOOL)
10473 return TRUE;
10474 return FALSE;
10475
10476 case OP_CONST:
10477 /* Detect comparisons that have been optimized away */
10478 if (cSVOPo->op_sv == &PL_sv_yes
10479 || cSVOPo->op_sv == &PL_sv_no)
10480
10481 return TRUE;
10482 else
10483 return FALSE;
10484 /* FALLTHROUGH */
10485 default:
10486 return FALSE;
10487 }
10488 }
10489
10490
10491 /*
10492 =for apidoc newGIVENOP
10493
10494 Constructs, checks, and returns an op tree expressing a C<given> block.
10495 C<cond> supplies the expression to whose value C<$_> will be locally
10496 aliased, and C<block> supplies the body of the C<given> construct; they
10497 are consumed by this function and become part of the constructed op tree.
10498 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
10499
10500 =cut
10501 */
10502
10503 OP *
Perl_newGIVENOP(pTHX_ OP * cond,OP * block,PADOFFSET defsv_off)10504 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
10505 {
10506 PERL_ARGS_ASSERT_NEWGIVENOP;
10507 PERL_UNUSED_ARG(defsv_off);
10508
10509 assert(!defsv_off);
10510 return newGIVWHENOP(
10511 ref_array_or_hash(cond),
10512 block,
10513 OP_ENTERGIVEN, OP_LEAVEGIVEN,
10514 0);
10515 }
10516
10517 /*
10518 =for apidoc newWHENOP
10519
10520 Constructs, checks, and returns an op tree expressing a C<when> block.
10521 C<cond> supplies the test expression, and C<block> supplies the block
10522 that will be executed if the test evaluates to true; they are consumed
10523 by this function and become part of the constructed op tree. C<cond>
10524 will be interpreted DWIMically, often as a comparison against C<$_>,
10525 and may be null to generate a C<default> block.
10526
10527 =cut
10528 */
10529
10530 OP *
Perl_newWHENOP(pTHX_ OP * cond,OP * block)10531 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
10532 {
10533 const bool cond_llb = (!cond || looks_like_bool(cond));
10534 OP *cond_op;
10535
10536 PERL_ARGS_ASSERT_NEWWHENOP;
10537
10538 if (cond_llb)
10539 cond_op = cond;
10540 else {
10541 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
10542 newDEFSVOP(),
10543 scalar(ref_array_or_hash(cond)));
10544 }
10545
10546 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
10547 }
10548
10549 /* must not conflict with SVf_UTF8 */
10550 #define CV_CKPROTO_CURSTASH 0x1
10551
10552 void
Perl_cv_ckproto_len_flags(pTHX_ const CV * cv,const GV * gv,const char * p,const STRLEN len,const U32 flags)10553 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
10554 const STRLEN len, const U32 flags)
10555 {
10556 SV *name = NULL, *msg;
10557 const char * cvp = SvROK(cv)
10558 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
10559 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
10560 : ""
10561 : CvPROTO(cv);
10562 STRLEN clen = CvPROTOLEN(cv), plen = len;
10563
10564 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
10565
10566 if (p == NULL && cvp == NULL)
10567 return;
10568
10569 if (!ckWARN_d(WARN_PROTOTYPE))
10570 return;
10571
10572 if (p && cvp) {
10573 p = S_strip_spaces(aTHX_ p, &plen);
10574 cvp = S_strip_spaces(aTHX_ cvp, &clen);
10575 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
10576 if (plen == clen && memEQ(cvp, p, plen))
10577 return;
10578 } else {
10579 if (flags & SVf_UTF8) {
10580 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
10581 return;
10582 }
10583 else {
10584 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
10585 return;
10586 }
10587 }
10588 }
10589
10590 msg = sv_newmortal();
10591
10592 if (gv)
10593 {
10594 if (isGV(gv))
10595 gv_efullname3(name = sv_newmortal(), gv, NULL);
10596 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
10597 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
10598 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
10599 name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
10600 sv_catpvs(name, "::");
10601 if (SvROK(gv)) {
10602 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
10603 assert (CvNAMED(SvRV_const(gv)));
10604 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
10605 }
10606 else sv_catsv(name, (SV *)gv);
10607 }
10608 else name = (SV *)gv;
10609 }
10610 sv_setpvs(msg, "Prototype mismatch:");
10611 if (name)
10612 Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
10613 if (cvp)
10614 Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
10615 UTF8fARG(SvUTF8(cv),clen,cvp)
10616 );
10617 else
10618 sv_catpvs(msg, ": none");
10619 sv_catpvs(msg, " vs ");
10620 if (p)
10621 Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
10622 else
10623 sv_catpvs(msg, "none");
10624 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
10625 }
10626
10627 static void const_sv_xsub(pTHX_ CV* cv);
10628 static void const_av_xsub(pTHX_ CV* cv);
10629
10630 /*
10631
10632 =head1 Optree Manipulation Functions
10633
10634 =for apidoc cv_const_sv
10635
10636 If C<cv> is a constant sub eligible for inlining, returns the constant
10637 value returned by the sub. Otherwise, returns C<NULL>.
10638
10639 Constant subs can be created with C<newCONSTSUB> or as described in
10640 L<perlsub/"Constant Functions">.
10641
10642 =cut
10643 */
10644 SV *
Perl_cv_const_sv(const CV * const cv)10645 Perl_cv_const_sv(const CV *const cv)
10646 {
10647 SV *sv;
10648 if (!cv)
10649 return NULL;
10650 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
10651 return NULL;
10652 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
10653 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
10654 return sv;
10655 }
10656
10657 SV *
Perl_cv_const_sv_or_av(const CV * const cv)10658 Perl_cv_const_sv_or_av(const CV * const cv)
10659 {
10660 if (!cv)
10661 return NULL;
10662 if (SvROK(cv)) return SvRV((SV *)cv);
10663 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
10664 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
10665 }
10666
10667 /* op_const_sv: examine an optree to determine whether it's in-lineable.
10668 * Can be called in 2 ways:
10669 *
10670 * !allow_lex
10671 * look for a single OP_CONST with attached value: return the value
10672 *
10673 * allow_lex && !CvCONST(cv);
10674 *
10675 * examine the clone prototype, and if contains only a single
10676 * OP_CONST, return the value; or if it contains a single PADSV ref-
10677 * erencing an outer lexical, turn on CvCONST to indicate the CV is
10678 * a candidate for "constizing" at clone time, and return NULL.
10679 */
10680
10681 static SV *
S_op_const_sv(pTHX_ const OP * o,CV * cv,bool allow_lex)10682 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
10683 {
10684 SV *sv = NULL;
10685 bool padsv = FALSE;
10686
10687 assert(o);
10688 assert(cv);
10689
10690 for (; o; o = o->op_next) {
10691 const OPCODE type = o->op_type;
10692
10693 if (type == OP_NEXTSTATE || type == OP_LINESEQ
10694 || type == OP_NULL
10695 || type == OP_PUSHMARK)
10696 continue;
10697 if (type == OP_DBSTATE)
10698 continue;
10699 if (type == OP_LEAVESUB)
10700 break;
10701 if (sv)
10702 return NULL;
10703 if (type == OP_CONST && cSVOPo->op_sv)
10704 sv = cSVOPo->op_sv;
10705 else if (type == OP_UNDEF && !o->op_private) {
10706 sv = newSV(0);
10707 SAVEFREESV(sv);
10708 }
10709 else if (allow_lex && type == OP_PADSV) {
10710 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
10711 {
10712 sv = &PL_sv_undef; /* an arbitrary non-null value */
10713 padsv = TRUE;
10714 }
10715 else
10716 return NULL;
10717 }
10718 else {
10719 return NULL;
10720 }
10721 }
10722 if (padsv) {
10723 CvCONST_on(cv);
10724 return NULL;
10725 }
10726 return sv;
10727 }
10728
10729 static void
S_already_defined(pTHX_ CV * const cv,OP * const block,OP * const o,PADNAME * const name,SV ** const const_svp)10730 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
10731 PADNAME * const name, SV ** const const_svp)
10732 {
10733 assert (cv);
10734 assert (o || name);
10735 assert (const_svp);
10736 if (!block) {
10737 if (CvFLAGS(PL_compcv)) {
10738 /* might have had built-in attrs applied */
10739 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
10740 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
10741 && ckWARN(WARN_MISC))
10742 {
10743 /* protect against fatal warnings leaking compcv */
10744 SAVEFREESV(PL_compcv);
10745 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
10746 SvREFCNT_inc_simple_void_NN(PL_compcv);
10747 }
10748 CvFLAGS(cv) |=
10749 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
10750 & ~(CVf_LVALUE * pureperl));
10751 }
10752 return;
10753 }
10754
10755 /* redundant check for speed: */
10756 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
10757 const line_t oldline = CopLINE(PL_curcop);
10758 SV *namesv = o
10759 ? cSVOPo->op_sv
10760 : sv_2mortal(newSVpvn_utf8(
10761 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
10762 ));
10763 if (PL_parser && PL_parser->copline != NOLINE)
10764 /* This ensures that warnings are reported at the first
10765 line of a redefinition, not the last. */
10766 CopLINE_set(PL_curcop, PL_parser->copline);
10767 /* protect against fatal warnings leaking compcv */
10768 SAVEFREESV(PL_compcv);
10769 report_redefined_cv(namesv, cv, const_svp);
10770 SvREFCNT_inc_simple_void_NN(PL_compcv);
10771 CopLINE_set(PL_curcop, oldline);
10772 }
10773 SAVEFREESV(cv);
10774 return;
10775 }
10776
10777 CV *
Perl_newMYSUB(pTHX_ I32 floor,OP * o,OP * proto,OP * attrs,OP * block)10778 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
10779 {
10780 CV **spot;
10781 SV **svspot;
10782 const char *ps;
10783 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
10784 U32 ps_utf8 = 0;
10785 CV *cv = NULL;
10786 CV *compcv = PL_compcv;
10787 SV *const_sv;
10788 PADNAME *name;
10789 PADOFFSET pax = o->op_targ;
10790 CV *outcv = CvOUTSIDE(PL_compcv);
10791 CV *clonee = NULL;
10792 HEK *hek = NULL;
10793 bool reusable = FALSE;
10794 OP *start = NULL;
10795 #ifdef PERL_DEBUG_READONLY_OPS
10796 OPSLAB *slab = NULL;
10797 #endif
10798
10799 PERL_ARGS_ASSERT_NEWMYSUB;
10800
10801 PL_hints |= HINT_BLOCK_SCOPE;
10802
10803 /* Find the pad slot for storing the new sub.
10804 We cannot use PL_comppad, as it is the pad owned by the new sub. We
10805 need to look in CvOUTSIDE and find the pad belonging to the enclos-
10806 ing sub. And then we need to dig deeper if this is a lexical from
10807 outside, as in:
10808 my sub foo; sub { sub foo { } }
10809 */
10810 redo:
10811 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
10812 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
10813 pax = PARENT_PAD_INDEX(name);
10814 outcv = CvOUTSIDE(outcv);
10815 assert(outcv);
10816 goto redo;
10817 }
10818 svspot =
10819 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
10820 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
10821 spot = (CV **)svspot;
10822
10823 if (!(PL_parser && PL_parser->error_count))
10824 move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
10825
10826 if (proto) {
10827 assert(proto->op_type == OP_CONST);
10828 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
10829 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
10830 }
10831 else
10832 ps = NULL;
10833
10834 if (proto)
10835 SAVEFREEOP(proto);
10836 if (attrs)
10837 SAVEFREEOP(attrs);
10838
10839 if (PL_parser && PL_parser->error_count) {
10840 op_free(block);
10841 SvREFCNT_dec(PL_compcv);
10842 PL_compcv = 0;
10843 goto done;
10844 }
10845
10846 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
10847 cv = *spot;
10848 svspot = (SV **)(spot = &clonee);
10849 }
10850 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
10851 cv = *spot;
10852 else {
10853 assert (SvTYPE(*spot) == SVt_PVCV);
10854 if (CvNAMED(*spot))
10855 hek = CvNAME_HEK(*spot);
10856 else {
10857 dVAR;
10858 U32 hash;
10859 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
10860 CvNAME_HEK_set(*spot, hek =
10861 share_hek(
10862 PadnamePV(name)+1,
10863 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
10864 hash
10865 )
10866 );
10867 CvLEXICAL_on(*spot);
10868 }
10869 cv = PadnamePROTOCV(name);
10870 svspot = (SV **)(spot = &PadnamePROTOCV(name));
10871 }
10872
10873 if (block) {
10874 /* This makes sub {}; work as expected. */
10875 if (block->op_type == OP_STUB) {
10876 const line_t l = PL_parser->copline;
10877 op_free(block);
10878 block = newSTATEOP(0, NULL, 0);
10879 PL_parser->copline = l;
10880 }
10881 block = CvLVALUE(compcv)
10882 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
10883 ? newUNOP(OP_LEAVESUBLV, 0,
10884 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
10885 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
10886 start = LINKLIST(block);
10887 block->op_next = 0;
10888 if (ps && !*ps && !attrs && !CvLVALUE(compcv))
10889 const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
10890 else
10891 const_sv = NULL;
10892 }
10893 else
10894 const_sv = NULL;
10895
10896 if (cv) {
10897 const bool exists = CvROOT(cv) || CvXSUB(cv);
10898
10899 /* if the subroutine doesn't exist and wasn't pre-declared
10900 * with a prototype, assume it will be AUTOLOADed,
10901 * skipping the prototype check
10902 */
10903 if (exists || SvPOK(cv))
10904 cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
10905 ps_utf8);
10906 /* already defined? */
10907 if (exists) {
10908 S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
10909 if (block)
10910 cv = NULL;
10911 else {
10912 if (attrs)
10913 goto attrs;
10914 /* just a "sub foo;" when &foo is already defined */
10915 SAVEFREESV(compcv);
10916 goto done;
10917 }
10918 }
10919 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
10920 cv = NULL;
10921 reusable = TRUE;
10922 }
10923 }
10924
10925 if (const_sv) {
10926 SvREFCNT_inc_simple_void_NN(const_sv);
10927 SvFLAGS(const_sv) |= SVs_PADTMP;
10928 if (cv) {
10929 assert(!CvROOT(cv) && !CvCONST(cv));
10930 cv_forget_slab(cv);
10931 }
10932 else {
10933 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10934 CvFILE_set_from_cop(cv, PL_curcop);
10935 CvSTASH_set(cv, PL_curstash);
10936 *spot = cv;
10937 }
10938 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
10939 CvXSUBANY(cv).any_ptr = const_sv;
10940 CvXSUB(cv) = const_sv_xsub;
10941 CvCONST_on(cv);
10942 CvISXSUB_on(cv);
10943 PoisonPADLIST(cv);
10944 CvFLAGS(cv) |= CvMETHOD(compcv);
10945 op_free(block);
10946 SvREFCNT_dec(compcv);
10947 PL_compcv = NULL;
10948 goto setname;
10949 }
10950
10951 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
10952 determine whether this sub definition is in the same scope as its
10953 declaration. If this sub definition is inside an inner named pack-
10954 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
10955 the package sub. So check PadnameOUTER(name) too.
10956 */
10957 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
10958 assert(!CvWEAKOUTSIDE(compcv));
10959 SvREFCNT_dec(CvOUTSIDE(compcv));
10960 CvWEAKOUTSIDE_on(compcv);
10961 }
10962 /* XXX else do we have a circular reference? */
10963
10964 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
10965 /* transfer PL_compcv to cv */
10966 if (block) {
10967 bool free_file = CvFILE(cv) && CvDYNFILE(cv);
10968 cv_flags_t preserved_flags =
10969 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
10970 PADLIST *const temp_padl = CvPADLIST(cv);
10971 CV *const temp_cv = CvOUTSIDE(cv);
10972 const cv_flags_t other_flags =
10973 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
10974 OP * const cvstart = CvSTART(cv);
10975
10976 SvPOK_off(cv);
10977 CvFLAGS(cv) =
10978 CvFLAGS(compcv) | preserved_flags;
10979 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
10980 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
10981 CvPADLIST_set(cv, CvPADLIST(compcv));
10982 CvOUTSIDE(compcv) = temp_cv;
10983 CvPADLIST_set(compcv, temp_padl);
10984 CvSTART(cv) = CvSTART(compcv);
10985 CvSTART(compcv) = cvstart;
10986 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10987 CvFLAGS(compcv) |= other_flags;
10988
10989 if (free_file) {
10990 Safefree(CvFILE(cv));
10991 CvFILE(cv) = NULL;
10992 }
10993
10994 /* inner references to compcv must be fixed up ... */
10995 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
10996 if (PERLDB_INTER)/* Advice debugger on the new sub. */
10997 ++PL_sub_generation;
10998 }
10999 else {
11000 /* Might have had built-in attributes applied -- propagate them. */
11001 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
11002 }
11003 /* ... before we throw it away */
11004 SvREFCNT_dec(compcv);
11005 PL_compcv = compcv = cv;
11006 }
11007 else {
11008 cv = compcv;
11009 *spot = cv;
11010 }
11011
11012 setname:
11013 CvLEXICAL_on(cv);
11014 if (!CvNAME_HEK(cv)) {
11015 if (hek) (void)share_hek_hek(hek);
11016 else {
11017 dVAR;
11018 U32 hash;
11019 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
11020 hek = share_hek(PadnamePV(name)+1,
11021 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
11022 hash);
11023 }
11024 CvNAME_HEK_set(cv, hek);
11025 }
11026
11027 if (const_sv)
11028 goto clone;
11029
11030 if (CvFILE(cv) && CvDYNFILE(cv))
11031 Safefree(CvFILE(cv));
11032 CvFILE_set_from_cop(cv, PL_curcop);
11033 CvSTASH_set(cv, PL_curstash);
11034
11035 if (ps) {
11036 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
11037 if (ps_utf8)
11038 SvUTF8_on(MUTABLE_SV(cv));
11039 }
11040
11041 if (block) {
11042 /* If we assign an optree to a PVCV, then we've defined a
11043 * subroutine that the debugger could be able to set a breakpoint
11044 * in, so signal to pp_entereval that it should not throw away any
11045 * saved lines at scope exit. */
11046
11047 PL_breakable_sub_gen++;
11048 CvROOT(cv) = block;
11049 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
11050 itself has a refcount. */
11051 CvSLABBED_off(cv);
11052 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
11053 #ifdef PERL_DEBUG_READONLY_OPS
11054 slab = (OPSLAB *)CvSTART(cv);
11055 #endif
11056 S_process_optree(aTHX_ cv, block, start);
11057 }
11058
11059 attrs:
11060 if (attrs) {
11061 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
11062 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
11063 }
11064
11065 if (block) {
11066 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
11067 SV * const tmpstr = sv_newmortal();
11068 GV * const db_postponed = gv_fetchpvs("DB::postponed",
11069 GV_ADDMULTI, SVt_PVHV);
11070 HV *hv;
11071 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
11072 CopFILE(PL_curcop),
11073 (long)PL_subline,
11074 (long)CopLINE(PL_curcop));
11075 if (HvNAME_HEK(PL_curstash)) {
11076 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
11077 sv_catpvs(tmpstr, "::");
11078 }
11079 else
11080 sv_setpvs(tmpstr, "__ANON__::");
11081
11082 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
11083 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
11084 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
11085 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
11086 hv = GvHVn(db_postponed);
11087 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
11088 CV * const pcv = GvCV(db_postponed);
11089 if (pcv) {
11090 dSP;
11091 PUSHMARK(SP);
11092 XPUSHs(tmpstr);
11093 PUTBACK;
11094 call_sv(MUTABLE_SV(pcv), G_DISCARD);
11095 }
11096 }
11097 }
11098 }
11099
11100 clone:
11101 if (clonee) {
11102 assert(CvDEPTH(outcv));
11103 spot = (CV **)
11104 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
11105 if (reusable)
11106 cv_clone_into(clonee, *spot);
11107 else *spot = cv_clone(clonee);
11108 SvREFCNT_dec_NN(clonee);
11109 cv = *spot;
11110 }
11111
11112 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
11113 PADOFFSET depth = CvDEPTH(outcv);
11114 while (--depth) {
11115 SV *oldcv;
11116 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
11117 oldcv = *svspot;
11118 *svspot = SvREFCNT_inc_simple_NN(cv);
11119 SvREFCNT_dec(oldcv);
11120 }
11121 }
11122
11123 done:
11124 if (PL_parser)
11125 PL_parser->copline = NOLINE;
11126 LEAVE_SCOPE(floor);
11127 #ifdef PERL_DEBUG_READONLY_OPS
11128 if (slab)
11129 Slab_to_ro(slab);
11130 #endif
11131 op_free(o);
11132 return cv;
11133 }
11134
11135 /*
11136 =for apidoc newATTRSUB_x
11137
11138 Construct a Perl subroutine, also performing some surrounding jobs.
11139
11140 This function is expected to be called in a Perl compilation context,
11141 and some aspects of the subroutine are taken from global variables
11142 associated with compilation. In particular, C<PL_compcv> represents
11143 the subroutine that is currently being compiled. It must be non-null
11144 when this function is called, and some aspects of the subroutine being
11145 constructed are taken from it. The constructed subroutine may actually
11146 be a reuse of the C<PL_compcv> object, but will not necessarily be so.
11147
11148 If C<block> is null then the subroutine will have no body, and for the
11149 time being it will be an error to call it. This represents a forward
11150 subroutine declaration such as S<C<sub foo ($$);>>. If C<block> is
11151 non-null then it provides the Perl code of the subroutine body, which
11152 will be executed when the subroutine is called. This body includes
11153 any argument unwrapping code resulting from a subroutine signature or
11154 similar. The pad use of the code must correspond to the pad attached
11155 to C<PL_compcv>. The code is not expected to include a C<leavesub> or
11156 C<leavesublv> op; this function will add such an op. C<block> is consumed
11157 by this function and will become part of the constructed subroutine.
11158
11159 C<proto> specifies the subroutine's prototype, unless one is supplied
11160 as an attribute (see below). If C<proto> is null, then the subroutine
11161 will not have a prototype. If C<proto> is non-null, it must point to a
11162 C<const> op whose value is a string, and the subroutine will have that
11163 string as its prototype. If a prototype is supplied as an attribute, the
11164 attribute takes precedence over C<proto>, but in that case C<proto> should
11165 preferably be null. In any case, C<proto> is consumed by this function.
11166
11167 C<attrs> supplies attributes to be applied the subroutine. A handful of
11168 attributes take effect by built-in means, being applied to C<PL_compcv>
11169 immediately when seen. Other attributes are collected up and attached
11170 to the subroutine by this route. C<attrs> may be null to supply no
11171 attributes, or point to a C<const> op for a single attribute, or point
11172 to a C<list> op whose children apart from the C<pushmark> are C<const>
11173 ops for one or more attributes. Each C<const> op must be a string,
11174 giving the attribute name optionally followed by parenthesised arguments,
11175 in the manner in which attributes appear in Perl source. The attributes
11176 will be applied to the sub by this function. C<attrs> is consumed by
11177 this function.
11178
11179 If C<o_is_gv> is false and C<o> is null, then the subroutine will
11180 be anonymous. If C<o_is_gv> is false and C<o> is non-null, then C<o>
11181 must point to a C<const> op, which will be consumed by this function,
11182 and its string value supplies a name for the subroutine. The name may
11183 be qualified or unqualified, and if it is unqualified then a default
11184 stash will be selected in some manner. If C<o_is_gv> is true, then C<o>
11185 doesn't point to an C<OP> at all, but is instead a cast pointer to a C<GV>
11186 by which the subroutine will be named.
11187
11188 If there is already a subroutine of the specified name, then the new
11189 sub will either replace the existing one in the glob or be merged with
11190 the existing one. A warning may be generated about redefinition.
11191
11192 If the subroutine has one of a few special names, such as C<BEGIN> or
11193 C<END>, then it will be claimed by the appropriate queue for automatic
11194 running of phase-related subroutines. In this case the relevant glob will
11195 be left not containing any subroutine, even if it did contain one before.
11196 In the case of C<BEGIN>, the subroutine will be executed and the reference
11197 to it disposed of before this function returns.
11198
11199 The function returns a pointer to the constructed subroutine. If the sub
11200 is anonymous then ownership of one counted reference to the subroutine
11201 is transferred to the caller. If the sub is named then the caller does
11202 not get ownership of a reference. In most such cases, where the sub
11203 has a non-phase name, the sub will be alive at the point it is returned
11204 by virtue of being contained in the glob that names it. A phase-named
11205 subroutine will usually be alive by virtue of the reference owned by the
11206 phase's automatic run queue. But a C<BEGIN> subroutine, having already
11207 been executed, will quite likely have been destroyed already by the
11208 time this function returns, making it erroneous for the caller to make
11209 any use of the returned pointer. It is the caller's responsibility to
11210 ensure that it knows which of these situations applies.
11211
11212 =cut
11213 */
11214
11215 /* _x = extended */
11216 CV *
Perl_newATTRSUB_x(pTHX_ I32 floor,OP * o,OP * proto,OP * attrs,OP * block,bool o_is_gv)11217 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
11218 OP *block, bool o_is_gv)
11219 {
11220 GV *gv;
11221 const char *ps;
11222 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
11223 U32 ps_utf8 = 0;
11224 CV *cv = NULL; /* the previous CV with this name, if any */
11225 SV *const_sv;
11226 const bool ec = PL_parser && PL_parser->error_count;
11227 /* If the subroutine has no body, no attributes, and no builtin attributes
11228 then it's just a sub declaration, and we may be able to get away with
11229 storing with a placeholder scalar in the symbol table, rather than a
11230 full CV. If anything is present then it will take a full CV to
11231 store it. */
11232 const I32 gv_fetch_flags
11233 = ec ? GV_NOADD_NOINIT :
11234 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
11235 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
11236 STRLEN namlen = 0;
11237 const char * const name =
11238 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
11239 bool has_name;
11240 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
11241 bool evanescent = FALSE;
11242 OP *start = NULL;
11243 #ifdef PERL_DEBUG_READONLY_OPS
11244 OPSLAB *slab = NULL;
11245 #endif
11246
11247 if (o_is_gv) {
11248 gv = (GV*)o;
11249 o = NULL;
11250 has_name = TRUE;
11251 } else if (name) {
11252 /* Try to optimise and avoid creating a GV. Instead, the CV’s name
11253 hek and CvSTASH pointer together can imply the GV. If the name
11254 contains a package name, then GvSTASH(CvGV(cv)) may differ from
11255 CvSTASH, so forego the optimisation if we find any.
11256 Also, we may be called from load_module at run time, so
11257 PL_curstash (which sets CvSTASH) may not point to the stash the
11258 sub is stored in. */
11259 /* XXX This optimization is currently disabled for packages other
11260 than main, since there was too much CPAN breakage. */
11261 const I32 flags =
11262 ec ? GV_NOADD_NOINIT
11263 : (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
11264 || PL_curstash != PL_defstash
11265 || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
11266 ? gv_fetch_flags
11267 : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
11268 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
11269 has_name = TRUE;
11270 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
11271 SV * const sv = sv_newmortal();
11272 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
11273 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
11274 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
11275 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
11276 has_name = TRUE;
11277 } else if (PL_curstash) {
11278 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
11279 has_name = FALSE;
11280 } else {
11281 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
11282 has_name = FALSE;
11283 }
11284
11285 if (!ec) {
11286 if (isGV(gv)) {
11287 move_proto_attr(&proto, &attrs, gv, 0);
11288 } else {
11289 assert(cSVOPo);
11290 move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
11291 }
11292 }
11293
11294 if (proto) {
11295 assert(proto->op_type == OP_CONST);
11296 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
11297 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
11298 }
11299 else
11300 ps = NULL;
11301
11302 if (o)
11303 SAVEFREEOP(o);
11304 if (proto)
11305 SAVEFREEOP(proto);
11306 if (attrs)
11307 SAVEFREEOP(attrs);
11308
11309 if (ec) {
11310 op_free(block);
11311
11312 if (name)
11313 SvREFCNT_dec(PL_compcv);
11314 else
11315 cv = PL_compcv;
11316
11317 PL_compcv = 0;
11318 if (name && block) {
11319 const char *s = (char *) my_memrchr(name, ':', namlen);
11320 s = s ? s+1 : name;
11321 if (strEQ(s, "BEGIN")) {
11322 if (PL_in_eval & EVAL_KEEPERR)
11323 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
11324 else {
11325 SV * const errsv = ERRSV;
11326 /* force display of errors found but not reported */
11327 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
11328 Perl_croak_nocontext("%" SVf, SVfARG(errsv));
11329 }
11330 }
11331 }
11332 goto done;
11333 }
11334
11335 if (!block && SvTYPE(gv) != SVt_PVGV) {
11336 /* If we are not defining a new sub and the existing one is not a
11337 full GV + CV... */
11338 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
11339 /* We are applying attributes to an existing sub, so we need it
11340 upgraded if it is a constant. */
11341 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
11342 gv_init_pvn(gv, PL_curstash, name, namlen,
11343 SVf_UTF8 * name_is_utf8);
11344 }
11345 else { /* Maybe prototype now, and had at maximum
11346 a prototype or const/sub ref before. */
11347 if (SvTYPE(gv) > SVt_NULL) {
11348 cv_ckproto_len_flags((const CV *)gv,
11349 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
11350 ps_len, ps_utf8);
11351 }
11352
11353 if (!SvROK(gv)) {
11354 if (ps) {
11355 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
11356 if (ps_utf8)
11357 SvUTF8_on(MUTABLE_SV(gv));
11358 }
11359 else
11360 sv_setiv(MUTABLE_SV(gv), -1);
11361 }
11362
11363 SvREFCNT_dec(PL_compcv);
11364 cv = PL_compcv = NULL;
11365 goto done;
11366 }
11367 }
11368
11369 cv = (!name || (isGV(gv) && GvCVGEN(gv)))
11370 ? NULL
11371 : isGV(gv)
11372 ? GvCV(gv)
11373 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
11374 ? (CV *)SvRV(gv)
11375 : NULL;
11376
11377 if (block) {
11378 assert(PL_parser);
11379 /* This makes sub {}; work as expected. */
11380 if (block->op_type == OP_STUB) {
11381 const line_t l = PL_parser->copline;
11382 op_free(block);
11383 block = newSTATEOP(0, NULL, 0);
11384 PL_parser->copline = l;
11385 }
11386 block = CvLVALUE(PL_compcv)
11387 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
11388 && (!isGV(gv) || !GvASSUMECV(gv)))
11389 ? newUNOP(OP_LEAVESUBLV, 0,
11390 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
11391 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
11392 start = LINKLIST(block);
11393 block->op_next = 0;
11394 if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
11395 const_sv =
11396 S_op_const_sv(aTHX_ start, PL_compcv,
11397 cBOOL(CvCLONE(PL_compcv)));
11398 else
11399 const_sv = NULL;
11400 }
11401 else
11402 const_sv = NULL;
11403
11404 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
11405 cv_ckproto_len_flags((const CV *)gv,
11406 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
11407 ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
11408 if (SvROK(gv)) {
11409 /* All the other code for sub redefinition warnings expects the
11410 clobbered sub to be a CV. Instead of making all those code
11411 paths more complex, just inline the RV version here. */
11412 const line_t oldline = CopLINE(PL_curcop);
11413 assert(IN_PERL_COMPILETIME);
11414 if (PL_parser && PL_parser->copline != NOLINE)
11415 /* This ensures that warnings are reported at the first
11416 line of a redefinition, not the last. */
11417 CopLINE_set(PL_curcop, PL_parser->copline);
11418 /* protect against fatal warnings leaking compcv */
11419 SAVEFREESV(PL_compcv);
11420
11421 if (ckWARN(WARN_REDEFINE)
11422 || ( ckWARN_d(WARN_REDEFINE)
11423 && ( !const_sv || SvRV(gv) == const_sv
11424 || sv_cmp(SvRV(gv), const_sv) ))) {
11425 assert(cSVOPo);
11426 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11427 "Constant subroutine %" SVf " redefined",
11428 SVfARG(cSVOPo->op_sv));
11429 }
11430
11431 SvREFCNT_inc_simple_void_NN(PL_compcv);
11432 CopLINE_set(PL_curcop, oldline);
11433 SvREFCNT_dec(SvRV(gv));
11434 }
11435 }
11436
11437 if (cv) {
11438 const bool exists = CvROOT(cv) || CvXSUB(cv);
11439
11440 /* if the subroutine doesn't exist and wasn't pre-declared
11441 * with a prototype, assume it will be AUTOLOADed,
11442 * skipping the prototype check
11443 */
11444 if (exists || SvPOK(cv))
11445 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
11446 /* already defined (or promised)? */
11447 if (exists || (isGV(gv) && GvASSUMECV(gv))) {
11448 S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
11449 if (block)
11450 cv = NULL;
11451 else {
11452 if (attrs)
11453 goto attrs;
11454 /* just a "sub foo;" when &foo is already defined */
11455 SAVEFREESV(PL_compcv);
11456 goto done;
11457 }
11458 }
11459 }
11460
11461 if (const_sv) {
11462 SvREFCNT_inc_simple_void_NN(const_sv);
11463 SvFLAGS(const_sv) |= SVs_PADTMP;
11464 if (cv) {
11465 assert(!CvROOT(cv) && !CvCONST(cv));
11466 cv_forget_slab(cv);
11467 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
11468 CvXSUBANY(cv).any_ptr = const_sv;
11469 CvXSUB(cv) = const_sv_xsub;
11470 CvCONST_on(cv);
11471 CvISXSUB_on(cv);
11472 PoisonPADLIST(cv);
11473 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
11474 }
11475 else {
11476 if (isGV(gv) || CvMETHOD(PL_compcv)) {
11477 if (name && isGV(gv))
11478 GvCV_set(gv, NULL);
11479 cv = newCONSTSUB_flags(
11480 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
11481 const_sv
11482 );
11483 assert(cv);
11484 assert(SvREFCNT((SV*)cv) != 0);
11485 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
11486 }
11487 else {
11488 if (!SvROK(gv)) {
11489 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
11490 prepare_SV_for_RV((SV *)gv);
11491 SvOK_off((SV *)gv);
11492 SvROK_on(gv);
11493 }
11494 SvRV_set(gv, const_sv);
11495 }
11496 }
11497 op_free(block);
11498 SvREFCNT_dec(PL_compcv);
11499 PL_compcv = NULL;
11500 goto done;
11501 }
11502
11503 /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
11504 if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
11505 cv = NULL;
11506
11507 if (cv) { /* must reuse cv if autoloaded */
11508 /* transfer PL_compcv to cv */
11509 if (block) {
11510 bool free_file = CvFILE(cv) && CvDYNFILE(cv);
11511 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
11512 PADLIST *const temp_av = CvPADLIST(cv);
11513 CV *const temp_cv = CvOUTSIDE(cv);
11514 const cv_flags_t other_flags =
11515 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
11516 OP * const cvstart = CvSTART(cv);
11517
11518 if (isGV(gv)) {
11519 CvGV_set(cv,gv);
11520 assert(!CvCVGV_RC(cv));
11521 assert(CvGV(cv) == gv);
11522 }
11523 else {
11524 dVAR;
11525 U32 hash;
11526 PERL_HASH(hash, name, namlen);
11527 CvNAME_HEK_set(cv,
11528 share_hek(name,
11529 name_is_utf8
11530 ? -(SSize_t)namlen
11531 : (SSize_t)namlen,
11532 hash));
11533 }
11534
11535 SvPOK_off(cv);
11536 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
11537 | CvNAMED(cv);
11538 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
11539 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
11540 CvPADLIST_set(cv,CvPADLIST(PL_compcv));
11541 CvOUTSIDE(PL_compcv) = temp_cv;
11542 CvPADLIST_set(PL_compcv, temp_av);
11543 CvSTART(cv) = CvSTART(PL_compcv);
11544 CvSTART(PL_compcv) = cvstart;
11545 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
11546 CvFLAGS(PL_compcv) |= other_flags;
11547
11548 if (free_file) {
11549 Safefree(CvFILE(cv));
11550 }
11551 CvFILE_set_from_cop(cv, PL_curcop);
11552 CvSTASH_set(cv, PL_curstash);
11553
11554 /* inner references to PL_compcv must be fixed up ... */
11555 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
11556 if (PERLDB_INTER)/* Advice debugger on the new sub. */
11557 ++PL_sub_generation;
11558 }
11559 else {
11560 /* Might have had built-in attributes applied -- propagate them. */
11561 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
11562 }
11563 /* ... before we throw it away */
11564 SvREFCNT_dec(PL_compcv);
11565 PL_compcv = cv;
11566 }
11567 else {
11568 cv = PL_compcv;
11569 if (name && isGV(gv)) {
11570 GvCV_set(gv, cv);
11571 GvCVGEN(gv) = 0;
11572 if (HvENAME_HEK(GvSTASH(gv)))
11573 /* sub Foo::bar { (shift)+1 } */
11574 gv_method_changed(gv);
11575 }
11576 else if (name) {
11577 if (!SvROK(gv)) {
11578 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
11579 prepare_SV_for_RV((SV *)gv);
11580 SvOK_off((SV *)gv);
11581 SvROK_on(gv);
11582 }
11583 SvRV_set(gv, (SV *)cv);
11584 if (HvENAME_HEK(PL_curstash))
11585 mro_method_changed_in(PL_curstash);
11586 }
11587 }
11588 assert(cv);
11589 assert(SvREFCNT((SV*)cv) != 0);
11590
11591 if (!CvHASGV(cv)) {
11592 if (isGV(gv))
11593 CvGV_set(cv, gv);
11594 else {
11595 dVAR;
11596 U32 hash;
11597 PERL_HASH(hash, name, namlen);
11598 CvNAME_HEK_set(cv, share_hek(name,
11599 name_is_utf8
11600 ? -(SSize_t)namlen
11601 : (SSize_t)namlen,
11602 hash));
11603 }
11604 CvFILE_set_from_cop(cv, PL_curcop);
11605 CvSTASH_set(cv, PL_curstash);
11606 }
11607
11608 if (ps) {
11609 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
11610 if ( ps_utf8 )
11611 SvUTF8_on(MUTABLE_SV(cv));
11612 }
11613
11614 if (block) {
11615 /* If we assign an optree to a PVCV, then we've defined a
11616 * subroutine that the debugger could be able to set a breakpoint
11617 * in, so signal to pp_entereval that it should not throw away any
11618 * saved lines at scope exit. */
11619
11620 PL_breakable_sub_gen++;
11621 CvROOT(cv) = block;
11622 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
11623 itself has a refcount. */
11624 CvSLABBED_off(cv);
11625 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
11626 #ifdef PERL_DEBUG_READONLY_OPS
11627 slab = (OPSLAB *)CvSTART(cv);
11628 #endif
11629 S_process_optree(aTHX_ cv, block, start);
11630 }
11631
11632 attrs:
11633 if (attrs) {
11634 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
11635 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
11636 ? GvSTASH(CvGV(cv))
11637 : PL_curstash;
11638 if (!name)
11639 SAVEFREESV(cv);
11640 apply_attrs(stash, MUTABLE_SV(cv), attrs);
11641 if (!name)
11642 SvREFCNT_inc_simple_void_NN(cv);
11643 }
11644
11645 if (block && has_name) {
11646 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
11647 SV * const tmpstr = cv_name(cv,NULL,0);
11648 GV * const db_postponed = gv_fetchpvs("DB::postponed",
11649 GV_ADDMULTI, SVt_PVHV);
11650 HV *hv;
11651 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
11652 CopFILE(PL_curcop),
11653 (long)PL_subline,
11654 (long)CopLINE(PL_curcop));
11655 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
11656 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
11657 hv = GvHVn(db_postponed);
11658 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
11659 CV * const pcv = GvCV(db_postponed);
11660 if (pcv) {
11661 dSP;
11662 PUSHMARK(SP);
11663 XPUSHs(tmpstr);
11664 PUTBACK;
11665 call_sv(MUTABLE_SV(pcv), G_DISCARD);
11666 }
11667 }
11668 }
11669
11670 if (name) {
11671 if (PL_parser && PL_parser->error_count)
11672 clear_special_blocks(name, gv, cv);
11673 else
11674 evanescent =
11675 process_special_blocks(floor, name, gv, cv);
11676 }
11677 }
11678 assert(cv);
11679
11680 done:
11681 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
11682 if (PL_parser)
11683 PL_parser->copline = NOLINE;
11684 LEAVE_SCOPE(floor);
11685
11686 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
11687 if (!evanescent) {
11688 #ifdef PERL_DEBUG_READONLY_OPS
11689 if (slab)
11690 Slab_to_ro(slab);
11691 #endif
11692 if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
11693 pad_add_weakref(cv);
11694 }
11695 return cv;
11696 }
11697
11698 STATIC void
S_clear_special_blocks(pTHX_ const char * const fullname,GV * const gv,CV * const cv)11699 S_clear_special_blocks(pTHX_ const char *const fullname,
11700 GV *const gv, CV *const cv) {
11701 const char *colon;
11702 const char *name;
11703
11704 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
11705
11706 colon = strrchr(fullname,':');
11707 name = colon ? colon + 1 : fullname;
11708
11709 if ((*name == 'B' && strEQ(name, "BEGIN"))
11710 || (*name == 'E' && strEQ(name, "END"))
11711 || (*name == 'U' && strEQ(name, "UNITCHECK"))
11712 || (*name == 'C' && strEQ(name, "CHECK"))
11713 || (*name == 'I' && strEQ(name, "INIT"))) {
11714 if (!isGV(gv)) {
11715 (void)CvGV(cv);
11716 assert(isGV(gv));
11717 }
11718 GvCV_set(gv, NULL);
11719 SvREFCNT_dec_NN(MUTABLE_SV(cv));
11720 }
11721 }
11722
11723 /* Returns true if the sub has been freed. */
11724 STATIC bool
S_process_special_blocks(pTHX_ I32 floor,const char * const fullname,GV * const gv,CV * const cv)11725 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
11726 GV *const gv,
11727 CV *const cv)
11728 {
11729 const char *const colon = strrchr(fullname,':');
11730 const char *const name = colon ? colon + 1 : fullname;
11731
11732 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
11733
11734 if (*name == 'B') {
11735 if (strEQ(name, "BEGIN")) {
11736 const I32 oldscope = PL_scopestack_ix;
11737 dSP;
11738 (void)CvGV(cv);
11739 if (floor) LEAVE_SCOPE(floor);
11740 ENTER;
11741 PUSHSTACKi(PERLSI_REQUIRE);
11742 SAVECOPFILE(&PL_compiling);
11743 SAVECOPLINE(&PL_compiling);
11744 SAVEVPTR(PL_curcop);
11745
11746 DEBUG_x( dump_sub(gv) );
11747 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
11748 GvCV_set(gv,0); /* cv has been hijacked */
11749 call_list(oldscope, PL_beginav);
11750
11751 POPSTACK;
11752 LEAVE;
11753 return !PL_savebegin;
11754 }
11755 else
11756 return FALSE;
11757 } else {
11758 if (*name == 'E') {
11759 if (strEQ(name, "END")) {
11760 DEBUG_x( dump_sub(gv) );
11761 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
11762 } else
11763 return FALSE;
11764 } else if (*name == 'U') {
11765 if (strEQ(name, "UNITCHECK")) {
11766 /* It's never too late to run a unitcheck block */
11767 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
11768 }
11769 else
11770 return FALSE;
11771 } else if (*name == 'C') {
11772 if (strEQ(name, "CHECK")) {
11773 if (PL_main_start)
11774 /* diag_listed_as: Too late to run %s block */
11775 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
11776 "Too late to run CHECK block");
11777 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
11778 }
11779 else
11780 return FALSE;
11781 } else if (*name == 'I') {
11782 if (strEQ(name, "INIT")) {
11783 if (PL_main_start)
11784 /* diag_listed_as: Too late to run %s block */
11785 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
11786 "Too late to run INIT block");
11787 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
11788 }
11789 else
11790 return FALSE;
11791 } else
11792 return FALSE;
11793 DEBUG_x( dump_sub(gv) );
11794 (void)CvGV(cv);
11795 GvCV_set(gv,0); /* cv has been hijacked */
11796 return FALSE;
11797 }
11798 }
11799
11800 /*
11801 =for apidoc newCONSTSUB
11802
11803 Behaves like L</newCONSTSUB_flags>, except that C<name> is nul-terminated
11804 rather than of counted length, and no flags are set. (This means that
11805 C<name> is always interpreted as Latin-1.)
11806
11807 =cut
11808 */
11809
11810 CV *
Perl_newCONSTSUB(pTHX_ HV * stash,const char * name,SV * sv)11811 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
11812 {
11813 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
11814 }
11815
11816 /*
11817 =for apidoc newCONSTSUB_flags
11818
11819 Construct a constant subroutine, also performing some surrounding
11820 jobs. A scalar constant-valued subroutine is eligible for inlining
11821 at compile-time, and in Perl code can be created by S<C<sub FOO () {
11822 123 }>>. Other kinds of constant subroutine have other treatment.
11823
11824 The subroutine will have an empty prototype and will ignore any arguments
11825 when called. Its constant behaviour is determined by C<sv>. If C<sv>
11826 is null, the subroutine will yield an empty list. If C<sv> points to a
11827 scalar, the subroutine will always yield that scalar. If C<sv> points
11828 to an array, the subroutine will always yield a list of the elements of
11829 that array in list context, or the number of elements in the array in
11830 scalar context. This function takes ownership of one counted reference
11831 to the scalar or array, and will arrange for the object to live as long
11832 as the subroutine does. If C<sv> points to a scalar then the inlining
11833 assumes that the value of the scalar will never change, so the caller
11834 must ensure that the scalar is not subsequently written to. If C<sv>
11835 points to an array then no such assumption is made, so it is ostensibly
11836 safe to mutate the array or its elements, but whether this is really
11837 supported has not been determined.
11838
11839 The subroutine will have C<CvFILE> set according to C<PL_curcop>.
11840 Other aspects of the subroutine will be left in their default state.
11841 The caller is free to mutate the subroutine beyond its initial state
11842 after this function has returned.
11843
11844 If C<name> is null then the subroutine will be anonymous, with its
11845 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
11846 subroutine will be named accordingly, referenced by the appropriate glob.
11847 C<name> is a string of length C<len> bytes giving a sigilless symbol
11848 name, in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1
11849 otherwise. The name may be either qualified or unqualified. If the
11850 name is unqualified then it defaults to being in the stash specified by
11851 C<stash> if that is non-null, or to C<PL_curstash> if C<stash> is null.
11852 The symbol is always added to the stash if necessary, with C<GV_ADDMULTI>
11853 semantics.
11854
11855 C<flags> should not have bits set other than C<SVf_UTF8>.
11856
11857 If there is already a subroutine of the specified name, then the new sub
11858 will replace the existing one in the glob. A warning may be generated
11859 about the redefinition.
11860
11861 If the subroutine has one of a few special names, such as C<BEGIN> or
11862 C<END>, then it will be claimed by the appropriate queue for automatic
11863 running of phase-related subroutines. In this case the relevant glob will
11864 be left not containing any subroutine, even if it did contain one before.
11865 Execution of the subroutine will likely be a no-op, unless C<sv> was
11866 a tied array or the caller modified the subroutine in some interesting
11867 way before it was executed. In the case of C<BEGIN>, the treatment is
11868 buggy: the sub will be executed when only half built, and may be deleted
11869 prematurely, possibly causing a crash.
11870
11871 The function returns a pointer to the constructed subroutine. If the sub
11872 is anonymous then ownership of one counted reference to the subroutine
11873 is transferred to the caller. If the sub is named then the caller does
11874 not get ownership of a reference. In most such cases, where the sub
11875 has a non-phase name, the sub will be alive at the point it is returned
11876 by virtue of being contained in the glob that names it. A phase-named
11877 subroutine will usually be alive by virtue of the reference owned by
11878 the phase's automatic run queue. A C<BEGIN> subroutine may have been
11879 destroyed already by the time this function returns, but currently bugs
11880 occur in that case before the caller gets control. It is the caller's
11881 responsibility to ensure that it knows which of these situations applies.
11882
11883 =cut
11884 */
11885
11886 CV *
Perl_newCONSTSUB_flags(pTHX_ HV * stash,const char * name,STRLEN len,U32 flags,SV * sv)11887 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
11888 U32 flags, SV *sv)
11889 {
11890 CV* cv;
11891 const char *const file = CopFILE(PL_curcop);
11892
11893 ENTER;
11894
11895 if (IN_PERL_RUNTIME) {
11896 /* at runtime, it's not safe to manipulate PL_curcop: it may be
11897 * an op shared between threads. Use a non-shared COP for our
11898 * dirty work */
11899 SAVEVPTR(PL_curcop);
11900 SAVECOMPILEWARNINGS();
11901 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
11902 PL_curcop = &PL_compiling;
11903 }
11904 SAVECOPLINE(PL_curcop);
11905 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
11906
11907 SAVEHINTS();
11908 PL_hints &= ~HINT_BLOCK_SCOPE;
11909
11910 if (stash) {
11911 SAVEGENERICSV(PL_curstash);
11912 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
11913 }
11914
11915 /* Protect sv against leakage caused by fatal warnings. */
11916 if (sv) SAVEFREESV(sv);
11917
11918 /* file becomes the CvFILE. For an XS, it's usually static storage,
11919 and so doesn't get free()d. (It's expected to be from the C pre-
11920 processor __FILE__ directive). But we need a dynamically allocated one,
11921 and we need it to get freed. */
11922 cv = newXS_len_flags(name, len,
11923 sv && SvTYPE(sv) == SVt_PVAV
11924 ? const_av_xsub
11925 : const_sv_xsub,
11926 file ? file : "", "",
11927 &sv, XS_DYNAMIC_FILENAME | flags);
11928 assert(cv);
11929 assert(SvREFCNT((SV*)cv) != 0);
11930 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
11931 CvCONST_on(cv);
11932
11933 LEAVE;
11934
11935 return cv;
11936 }
11937
11938 /*
11939 =for apidoc newXS
11940
11941 Used by C<xsubpp> to hook up XSUBs as Perl subs. C<filename> needs to be
11942 static storage, as it is used directly as CvFILE(), without a copy being made.
11943
11944 =cut
11945 */
11946
11947 CV *
Perl_newXS(pTHX_ const char * name,XSUBADDR_t subaddr,const char * filename)11948 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
11949 {
11950 PERL_ARGS_ASSERT_NEWXS;
11951 return newXS_len_flags(
11952 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
11953 );
11954 }
11955
11956 CV *
Perl_newXS_flags(pTHX_ const char * name,XSUBADDR_t subaddr,const char * const filename,const char * const proto,U32 flags)11957 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
11958 const char *const filename, const char *const proto,
11959 U32 flags)
11960 {
11961 PERL_ARGS_ASSERT_NEWXS_FLAGS;
11962 return newXS_len_flags(
11963 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
11964 );
11965 }
11966
11967 CV *
Perl_newXS_deffile(pTHX_ const char * name,XSUBADDR_t subaddr)11968 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
11969 {
11970 PERL_ARGS_ASSERT_NEWXS_DEFFILE;
11971 return newXS_len_flags(
11972 name, strlen(name), subaddr, NULL, NULL, NULL, 0
11973 );
11974 }
11975
11976 /*
11977 =for apidoc newXS_len_flags
11978
11979 Construct an XS subroutine, also performing some surrounding jobs.
11980
11981 The subroutine will have the entry point C<subaddr>. It will have
11982 the prototype specified by the nul-terminated string C<proto>, or
11983 no prototype if C<proto> is null. The prototype string is copied;
11984 the caller can mutate the supplied string afterwards. If C<filename>
11985 is non-null, it must be a nul-terminated filename, and the subroutine
11986 will have its C<CvFILE> set accordingly. By default C<CvFILE> is set to
11987 point directly to the supplied string, which must be static. If C<flags>
11988 has the C<XS_DYNAMIC_FILENAME> bit set, then a copy of the string will
11989 be taken instead.
11990
11991 Other aspects of the subroutine will be left in their default state.
11992 If anything else needs to be done to the subroutine for it to function
11993 correctly, it is the caller's responsibility to do that after this
11994 function has constructed it. However, beware of the subroutine
11995 potentially being destroyed before this function returns, as described
11996 below.
11997
11998 If C<name> is null then the subroutine will be anonymous, with its
11999 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
12000 subroutine will be named accordingly, referenced by the appropriate glob.
12001 C<name> is a string of length C<len> bytes giving a sigilless symbol name,
12002 in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 otherwise.
12003 The name may be either qualified or unqualified, with the stash defaulting
12004 in the same manner as for C<gv_fetchpvn_flags>. C<flags> may contain
12005 flag bits understood by C<gv_fetchpvn_flags> with the same meaning as
12006 they have there, such as C<GV_ADDWARN>. The symbol is always added to
12007 the stash if necessary, with C<GV_ADDMULTI> semantics.
12008
12009 If there is already a subroutine of the specified name, then the new sub
12010 will replace the existing one in the glob. A warning may be generated
12011 about the redefinition. If the old subroutine was C<CvCONST> then the
12012 decision about whether to warn is influenced by an expectation about
12013 whether the new subroutine will become a constant of similar value.
12014 That expectation is determined by C<const_svp>. (Note that the call to
12015 this function doesn't make the new subroutine C<CvCONST> in any case;
12016 that is left to the caller.) If C<const_svp> is null then it indicates
12017 that the new subroutine will not become a constant. If C<const_svp>
12018 is non-null then it indicates that the new subroutine will become a
12019 constant, and it points to an C<SV*> that provides the constant value
12020 that the subroutine will have.
12021
12022 If the subroutine has one of a few special names, such as C<BEGIN> or
12023 C<END>, then it will be claimed by the appropriate queue for automatic
12024 running of phase-related subroutines. In this case the relevant glob will
12025 be left not containing any subroutine, even if it did contain one before.
12026 In the case of C<BEGIN>, the subroutine will be executed and the reference
12027 to it disposed of before this function returns, and also before its
12028 prototype is set. If a C<BEGIN> subroutine would not be sufficiently
12029 constructed by this function to be ready for execution then the caller
12030 must prevent this happening by giving the subroutine a different name.
12031
12032 The function returns a pointer to the constructed subroutine. If the sub
12033 is anonymous then ownership of one counted reference to the subroutine
12034 is transferred to the caller. If the sub is named then the caller does
12035 not get ownership of a reference. In most such cases, where the sub
12036 has a non-phase name, the sub will be alive at the point it is returned
12037 by virtue of being contained in the glob that names it. A phase-named
12038 subroutine will usually be alive by virtue of the reference owned by the
12039 phase's automatic run queue. But a C<BEGIN> subroutine, having already
12040 been executed, will quite likely have been destroyed already by the
12041 time this function returns, making it erroneous for the caller to make
12042 any use of the returned pointer. It is the caller's responsibility to
12043 ensure that it knows which of these situations applies.
12044
12045 =cut
12046 */
12047
12048 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)12049 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
12050 XSUBADDR_t subaddr, const char *const filename,
12051 const char *const proto, SV **const_svp,
12052 U32 flags)
12053 {
12054 CV *cv;
12055 bool interleave = FALSE;
12056 bool evanescent = FALSE;
12057
12058 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
12059
12060 {
12061 GV * const gv = gv_fetchpvn(
12062 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
12063 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
12064 sizeof("__ANON__::__ANON__") - 1,
12065 GV_ADDMULTI | flags, SVt_PVCV);
12066
12067 if ((cv = (name ? GvCV(gv) : NULL))) {
12068 if (GvCVGEN(gv)) {
12069 /* just a cached method */
12070 SvREFCNT_dec(cv);
12071 cv = NULL;
12072 }
12073 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
12074 /* already defined (or promised) */
12075 /* Redundant check that allows us to avoid creating an SV
12076 most of the time: */
12077 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
12078 report_redefined_cv(newSVpvn_flags(
12079 name,len,(flags&SVf_UTF8)|SVs_TEMP
12080 ),
12081 cv, const_svp);
12082 }
12083 interleave = TRUE;
12084 ENTER;
12085 SAVEFREESV(cv);
12086 cv = NULL;
12087 }
12088 }
12089
12090 if (cv) /* must reuse cv if autoloaded */
12091 cv_undef(cv);
12092 else {
12093 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
12094 if (name) {
12095 GvCV_set(gv,cv);
12096 GvCVGEN(gv) = 0;
12097 if (HvENAME_HEK(GvSTASH(gv)))
12098 gv_method_changed(gv); /* newXS */
12099 }
12100 }
12101 assert(cv);
12102 assert(SvREFCNT((SV*)cv) != 0);
12103
12104 CvGV_set(cv, gv);
12105 if(filename) {
12106 /* XSUBs can't be perl lang/perl5db.pl debugged
12107 if (PERLDB_LINE_OR_SAVESRC)
12108 (void)gv_fetchfile(filename); */
12109 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
12110 if (flags & XS_DYNAMIC_FILENAME) {
12111 CvDYNFILE_on(cv);
12112 CvFILE(cv) = savepv(filename);
12113 } else {
12114 /* NOTE: not copied, as it is expected to be an external constant string */
12115 CvFILE(cv) = (char *)filename;
12116 }
12117 } else {
12118 assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
12119 CvFILE(cv) = (char*)PL_xsubfilename;
12120 }
12121 CvISXSUB_on(cv);
12122 CvXSUB(cv) = subaddr;
12123 #ifndef PERL_IMPLICIT_CONTEXT
12124 CvHSCXT(cv) = &PL_stack_sp;
12125 #else
12126 PoisonPADLIST(cv);
12127 #endif
12128
12129 if (name)
12130 evanescent = process_special_blocks(0, name, gv, cv);
12131 else
12132 CvANON_on(cv);
12133 } /* <- not a conditional branch */
12134
12135 assert(cv);
12136 assert(evanescent || SvREFCNT((SV*)cv) != 0);
12137
12138 if (!evanescent) sv_setpv(MUTABLE_SV(cv), proto);
12139 if (interleave) LEAVE;
12140 assert(evanescent || SvREFCNT((SV*)cv) != 0);
12141 return cv;
12142 }
12143
12144 /* Add a stub CV to a typeglob.
12145 * This is the implementation of a forward declaration, 'sub foo';'
12146 */
12147
12148 CV *
Perl_newSTUB(pTHX_ GV * gv,bool fake)12149 Perl_newSTUB(pTHX_ GV *gv, bool fake)
12150 {
12151 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
12152 GV *cvgv;
12153 PERL_ARGS_ASSERT_NEWSTUB;
12154 assert(!GvCVu(gv));
12155 GvCV_set(gv, cv);
12156 GvCVGEN(gv) = 0;
12157 if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
12158 gv_method_changed(gv);
12159 if (SvFAKE(gv)) {
12160 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
12161 SvFAKE_off(cvgv);
12162 }
12163 else cvgv = gv;
12164 CvGV_set(cv, cvgv);
12165 CvFILE_set_from_cop(cv, PL_curcop);
12166 CvSTASH_set(cv, PL_curstash);
12167 GvMULTI_on(gv);
12168 return cv;
12169 }
12170
12171 void
Perl_newFORM(pTHX_ I32 floor,OP * o,OP * block)12172 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
12173 {
12174 CV *cv;
12175 GV *gv;
12176 OP *root;
12177 OP *start;
12178
12179 if (PL_parser && PL_parser->error_count) {
12180 op_free(block);
12181 goto finish;
12182 }
12183
12184 gv = o
12185 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
12186 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
12187
12188 GvMULTI_on(gv);
12189 if ((cv = GvFORM(gv))) {
12190 if (ckWARN(WARN_REDEFINE)) {
12191 const line_t oldline = CopLINE(PL_curcop);
12192 if (PL_parser && PL_parser->copline != NOLINE)
12193 CopLINE_set(PL_curcop, PL_parser->copline);
12194 if (o) {
12195 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
12196 "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
12197 } else {
12198 /* diag_listed_as: Format %s redefined */
12199 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
12200 "Format STDOUT redefined");
12201 }
12202 CopLINE_set(PL_curcop, oldline);
12203 }
12204 SvREFCNT_dec(cv);
12205 }
12206 cv = PL_compcv;
12207 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
12208 CvGV_set(cv, gv);
12209 CvFILE_set_from_cop(cv, PL_curcop);
12210
12211
12212 root = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
12213 CvROOT(cv) = root;
12214 start = LINKLIST(root);
12215 root->op_next = 0;
12216 S_process_optree(aTHX_ cv, root, start);
12217 cv_forget_slab(cv);
12218
12219 finish:
12220 op_free(o);
12221 if (PL_parser)
12222 PL_parser->copline = NOLINE;
12223 LEAVE_SCOPE(floor);
12224 PL_compiling.cop_seq = 0;
12225 }
12226
12227 OP *
Perl_newANONLIST(pTHX_ OP * o)12228 Perl_newANONLIST(pTHX_ OP *o)
12229 {
12230 return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
12231 }
12232
12233 OP *
Perl_newANONHASH(pTHX_ OP * o)12234 Perl_newANONHASH(pTHX_ OP *o)
12235 {
12236 return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
12237 }
12238
12239 OP *
Perl_newANONSUB(pTHX_ I32 floor,OP * proto,OP * block)12240 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
12241 {
12242 return newANONATTRSUB(floor, proto, NULL, block);
12243 }
12244
12245 OP *
Perl_newANONATTRSUB(pTHX_ I32 floor,OP * proto,OP * attrs,OP * block)12246 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
12247 {
12248 SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
12249 OP * anoncode =
12250 newSVOP(OP_ANONCODE, 0,
12251 cv);
12252 if (CvANONCONST(cv))
12253 anoncode = newUNOP(OP_ANONCONST, 0,
12254 op_convert_list(OP_ENTERSUB,
12255 OPf_STACKED|OPf_WANT_SCALAR,
12256 anoncode));
12257 return newUNOP(OP_REFGEN, 0, anoncode);
12258 }
12259
12260 OP *
Perl_oopsAV(pTHX_ OP * o)12261 Perl_oopsAV(pTHX_ OP *o)
12262 {
12263 dVAR;
12264
12265 PERL_ARGS_ASSERT_OOPSAV;
12266
12267 switch (o->op_type) {
12268 case OP_PADSV:
12269 case OP_PADHV:
12270 OpTYPE_set(o, OP_PADAV);
12271 return ref(o, OP_RV2AV);
12272
12273 case OP_RV2SV:
12274 case OP_RV2HV:
12275 OpTYPE_set(o, OP_RV2AV);
12276 ref(o, OP_RV2AV);
12277 break;
12278
12279 default:
12280 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
12281 break;
12282 }
12283 return o;
12284 }
12285
12286 OP *
Perl_oopsHV(pTHX_ OP * o)12287 Perl_oopsHV(pTHX_ OP *o)
12288 {
12289 dVAR;
12290
12291 PERL_ARGS_ASSERT_OOPSHV;
12292
12293 switch (o->op_type) {
12294 case OP_PADSV:
12295 case OP_PADAV:
12296 OpTYPE_set(o, OP_PADHV);
12297 return ref(o, OP_RV2HV);
12298
12299 case OP_RV2SV:
12300 case OP_RV2AV:
12301 OpTYPE_set(o, OP_RV2HV);
12302 /* rv2hv steals the bottom bit for its own uses */
12303 o->op_private &= ~OPpARG1_MASK;
12304 ref(o, OP_RV2HV);
12305 break;
12306
12307 default:
12308 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
12309 break;
12310 }
12311 return o;
12312 }
12313
12314 OP *
Perl_newAVREF(pTHX_ OP * o)12315 Perl_newAVREF(pTHX_ OP *o)
12316 {
12317 dVAR;
12318
12319 PERL_ARGS_ASSERT_NEWAVREF;
12320
12321 if (o->op_type == OP_PADANY) {
12322 OpTYPE_set(o, OP_PADAV);
12323 return o;
12324 }
12325 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
12326 Perl_croak(aTHX_ "Can't use an array as a reference");
12327 }
12328 return newUNOP(OP_RV2AV, 0, scalar(o));
12329 }
12330
12331 OP *
Perl_newGVREF(pTHX_ I32 type,OP * o)12332 Perl_newGVREF(pTHX_ I32 type, OP *o)
12333 {
12334 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
12335 return newUNOP(OP_NULL, 0, o);
12336 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
12337 }
12338
12339 OP *
Perl_newHVREF(pTHX_ OP * o)12340 Perl_newHVREF(pTHX_ OP *o)
12341 {
12342 dVAR;
12343
12344 PERL_ARGS_ASSERT_NEWHVREF;
12345
12346 if (o->op_type == OP_PADANY) {
12347 OpTYPE_set(o, OP_PADHV);
12348 return o;
12349 }
12350 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
12351 Perl_croak(aTHX_ "Can't use a hash as a reference");
12352 }
12353 return newUNOP(OP_RV2HV, 0, scalar(o));
12354 }
12355
12356 OP *
Perl_newCVREF(pTHX_ I32 flags,OP * o)12357 Perl_newCVREF(pTHX_ I32 flags, OP *o)
12358 {
12359 if (o->op_type == OP_PADANY) {
12360 dVAR;
12361 OpTYPE_set(o, OP_PADCV);
12362 }
12363 return newUNOP(OP_RV2CV, flags, scalar(o));
12364 }
12365
12366 OP *
Perl_newSVREF(pTHX_ OP * o)12367 Perl_newSVREF(pTHX_ OP *o)
12368 {
12369 dVAR;
12370
12371 PERL_ARGS_ASSERT_NEWSVREF;
12372
12373 if (o->op_type == OP_PADANY) {
12374 OpTYPE_set(o, OP_PADSV);
12375 scalar(o);
12376 return o;
12377 }
12378 return newUNOP(OP_RV2SV, 0, scalar(o));
12379 }
12380
12381 /* Check routines. See the comments at the top of this file for details
12382 * on when these are called */
12383
12384 OP *
Perl_ck_anoncode(pTHX_ OP * o)12385 Perl_ck_anoncode(pTHX_ OP *o)
12386 {
12387 PERL_ARGS_ASSERT_CK_ANONCODE;
12388
12389 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
12390 cSVOPo->op_sv = NULL;
12391 return o;
12392 }
12393
12394 static void
S_io_hints(pTHX_ OP * o)12395 S_io_hints(pTHX_ OP *o)
12396 {
12397 #if O_BINARY != 0 || O_TEXT != 0
12398 HV * const table =
12399 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
12400 if (table) {
12401 SV **svp = hv_fetchs(table, "open_IN", FALSE);
12402 if (svp && *svp) {
12403 STRLEN len = 0;
12404 const char *d = SvPV_const(*svp, len);
12405 const I32 mode = mode_from_discipline(d, len);
12406 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
12407 # if O_BINARY != 0
12408 if (mode & O_BINARY)
12409 o->op_private |= OPpOPEN_IN_RAW;
12410 # endif
12411 # if O_TEXT != 0
12412 if (mode & O_TEXT)
12413 o->op_private |= OPpOPEN_IN_CRLF;
12414 # endif
12415 }
12416
12417 svp = hv_fetchs(table, "open_OUT", FALSE);
12418 if (svp && *svp) {
12419 STRLEN len = 0;
12420 const char *d = SvPV_const(*svp, len);
12421 const I32 mode = mode_from_discipline(d, len);
12422 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
12423 # if O_BINARY != 0
12424 if (mode & O_BINARY)
12425 o->op_private |= OPpOPEN_OUT_RAW;
12426 # endif
12427 # if O_TEXT != 0
12428 if (mode & O_TEXT)
12429 o->op_private |= OPpOPEN_OUT_CRLF;
12430 # endif
12431 }
12432 }
12433 #else
12434 PERL_UNUSED_CONTEXT;
12435 PERL_UNUSED_ARG(o);
12436 #endif
12437 }
12438
12439 OP *
Perl_ck_backtick(pTHX_ OP * o)12440 Perl_ck_backtick(pTHX_ OP *o)
12441 {
12442 GV *gv;
12443 OP *newop = NULL;
12444 OP *sibl;
12445 PERL_ARGS_ASSERT_CK_BACKTICK;
12446 o = ck_fun(o);
12447 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
12448 if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
12449 && (gv = gv_override("readpipe",8)))
12450 {
12451 /* detach rest of siblings from o and its first child */
12452 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
12453 newop = S_new_entersubop(aTHX_ gv, sibl);
12454 }
12455 else if (!(o->op_flags & OPf_KIDS))
12456 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
12457 if (newop) {
12458 op_free(o);
12459 return newop;
12460 }
12461 S_io_hints(aTHX_ o);
12462 return o;
12463 }
12464
12465 OP *
Perl_ck_bitop(pTHX_ OP * o)12466 Perl_ck_bitop(pTHX_ OP *o)
12467 {
12468 PERL_ARGS_ASSERT_CK_BITOP;
12469
12470 o->op_private = (U8)(PL_hints & HINT_INTEGER);
12471
12472 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
12473 && OP_IS_INFIX_BIT(o->op_type))
12474 {
12475 const OP * const left = cBINOPo->op_first;
12476 const OP * const right = OpSIBLING(left);
12477 if ((OP_IS_NUMCOMPARE(left->op_type) &&
12478 (left->op_flags & OPf_PARENS) == 0) ||
12479 (OP_IS_NUMCOMPARE(right->op_type) &&
12480 (right->op_flags & OPf_PARENS) == 0))
12481 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
12482 "Possible precedence problem on bitwise %s operator",
12483 o->op_type == OP_BIT_OR
12484 ||o->op_type == OP_NBIT_OR ? "|"
12485 : o->op_type == OP_BIT_AND
12486 ||o->op_type == OP_NBIT_AND ? "&"
12487 : o->op_type == OP_BIT_XOR
12488 ||o->op_type == OP_NBIT_XOR ? "^"
12489 : o->op_type == OP_SBIT_OR ? "|."
12490 : o->op_type == OP_SBIT_AND ? "&." : "^."
12491 );
12492 }
12493 return o;
12494 }
12495
12496 PERL_STATIC_INLINE bool
is_dollar_bracket(pTHX_ const OP * const o)12497 is_dollar_bracket(pTHX_ const OP * const o)
12498 {
12499 const OP *kid;
12500 PERL_UNUSED_CONTEXT;
12501 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
12502 && (kid = cUNOPx(o)->op_first)
12503 && kid->op_type == OP_GV
12504 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
12505 }
12506
12507 /* for lt, gt, le, ge, eq, ne and their i_ variants */
12508
12509 OP *
Perl_ck_cmp(pTHX_ OP * o)12510 Perl_ck_cmp(pTHX_ OP *o)
12511 {
12512 bool is_eq;
12513 bool neg;
12514 bool reverse;
12515 bool iv0;
12516 OP *indexop, *constop, *start;
12517 SV *sv;
12518 IV iv;
12519
12520 PERL_ARGS_ASSERT_CK_CMP;
12521
12522 is_eq = ( o->op_type == OP_EQ
12523 || o->op_type == OP_NE
12524 || o->op_type == OP_I_EQ
12525 || o->op_type == OP_I_NE);
12526
12527 if (!is_eq && ckWARN(WARN_SYNTAX)) {
12528 const OP *kid = cUNOPo->op_first;
12529 if (kid &&
12530 (
12531 ( is_dollar_bracket(aTHX_ kid)
12532 && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
12533 )
12534 || ( kid->op_type == OP_CONST
12535 && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
12536 )
12537 )
12538 )
12539 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12540 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
12541 }
12542
12543 /* convert (index(...) == -1) and variations into
12544 * (r)index/BOOL(,NEG)
12545 */
12546
12547 reverse = FALSE;
12548
12549 indexop = cUNOPo->op_first;
12550 constop = OpSIBLING(indexop);
12551 start = NULL;
12552 if (indexop->op_type == OP_CONST) {
12553 constop = indexop;
12554 indexop = OpSIBLING(constop);
12555 start = constop;
12556 reverse = TRUE;
12557 }
12558
12559 if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
12560 return o;
12561
12562 /* ($lex = index(....)) == -1 */
12563 if (indexop->op_private & OPpTARGET_MY)
12564 return o;
12565
12566 if (constop->op_type != OP_CONST)
12567 return o;
12568
12569 sv = cSVOPx_sv(constop);
12570 if (!(sv && SvIOK_notUV(sv)))
12571 return o;
12572
12573 iv = SvIVX(sv);
12574 if (iv != -1 && iv != 0)
12575 return o;
12576 iv0 = (iv == 0);
12577
12578 if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
12579 if (!(iv0 ^ reverse))
12580 return o;
12581 neg = iv0;
12582 }
12583 else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
12584 if (iv0 ^ reverse)
12585 return o;
12586 neg = !iv0;
12587 }
12588 else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
12589 if (!(iv0 ^ reverse))
12590 return o;
12591 neg = !iv0;
12592 }
12593 else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
12594 if (iv0 ^ reverse)
12595 return o;
12596 neg = iv0;
12597 }
12598 else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
12599 if (iv0)
12600 return o;
12601 neg = TRUE;
12602 }
12603 else {
12604 assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
12605 if (iv0)
12606 return o;
12607 neg = FALSE;
12608 }
12609
12610 indexop->op_flags &= ~OPf_PARENS;
12611 indexop->op_flags |= (o->op_flags & OPf_PARENS);
12612 indexop->op_private |= OPpTRUEBOOL;
12613 if (neg)
12614 indexop->op_private |= OPpINDEX_BOOLNEG;
12615 /* cut out the index op and free the eq,const ops */
12616 (void)op_sibling_splice(o, start, 1, NULL);
12617 op_free(o);
12618
12619 return indexop;
12620 }
12621
12622
12623 OP *
Perl_ck_concat(pTHX_ OP * o)12624 Perl_ck_concat(pTHX_ OP *o)
12625 {
12626 const OP * const kid = cUNOPo->op_first;
12627
12628 PERL_ARGS_ASSERT_CK_CONCAT;
12629 PERL_UNUSED_CONTEXT;
12630
12631 /* reuse the padtmp returned by the concat child */
12632 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
12633 !(kUNOP->op_first->op_flags & OPf_MOD))
12634 {
12635 o->op_flags |= OPf_STACKED;
12636 o->op_private |= OPpCONCAT_NESTED;
12637 }
12638 return o;
12639 }
12640
12641 OP *
Perl_ck_spair(pTHX_ OP * o)12642 Perl_ck_spair(pTHX_ OP *o)
12643 {
12644 dVAR;
12645
12646 PERL_ARGS_ASSERT_CK_SPAIR;
12647
12648 if (o->op_flags & OPf_KIDS) {
12649 OP* newop;
12650 OP* kid;
12651 OP* kidkid;
12652 const OPCODE type = o->op_type;
12653 o = modkids(ck_fun(o), type);
12654 kid = cUNOPo->op_first;
12655 kidkid = kUNOP->op_first;
12656 newop = OpSIBLING(kidkid);
12657 if (newop) {
12658 const OPCODE type = newop->op_type;
12659 if (OpHAS_SIBLING(newop))
12660 return o;
12661 if (o->op_type == OP_REFGEN
12662 && ( type == OP_RV2CV
12663 || ( !(newop->op_flags & OPf_PARENS)
12664 && ( type == OP_RV2AV || type == OP_PADAV
12665 || type == OP_RV2HV || type == OP_PADHV))))
12666 NOOP; /* OK (allow srefgen for \@a and \%h) */
12667 else if (OP_GIMME(newop,0) != G_SCALAR)
12668 return o;
12669 }
12670 /* excise first sibling */
12671 op_sibling_splice(kid, NULL, 1, NULL);
12672 op_free(kidkid);
12673 }
12674 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
12675 * and OP_CHOMP into OP_SCHOMP */
12676 o->op_ppaddr = PL_ppaddr[++o->op_type];
12677 return ck_fun(o);
12678 }
12679
12680 OP *
Perl_ck_delete(pTHX_ OP * o)12681 Perl_ck_delete(pTHX_ OP *o)
12682 {
12683 PERL_ARGS_ASSERT_CK_DELETE;
12684
12685 o = ck_fun(o);
12686 o->op_private = 0;
12687 if (o->op_flags & OPf_KIDS) {
12688 OP * const kid = cUNOPo->op_first;
12689 switch (kid->op_type) {
12690 case OP_ASLICE:
12691 o->op_flags |= OPf_SPECIAL;
12692 /* FALLTHROUGH */
12693 case OP_HSLICE:
12694 o->op_private |= OPpSLICE;
12695 break;
12696 case OP_AELEM:
12697 o->op_flags |= OPf_SPECIAL;
12698 /* FALLTHROUGH */
12699 case OP_HELEM:
12700 break;
12701 case OP_KVASLICE:
12702 o->op_flags |= OPf_SPECIAL;
12703 /* FALLTHROUGH */
12704 case OP_KVHSLICE:
12705 o->op_private |= OPpKVSLICE;
12706 break;
12707 default:
12708 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
12709 "element or slice");
12710 }
12711 if (kid->op_private & OPpLVAL_INTRO)
12712 o->op_private |= OPpLVAL_INTRO;
12713 op_null(kid);
12714 }
12715 return o;
12716 }
12717
12718 OP *
Perl_ck_eof(pTHX_ OP * o)12719 Perl_ck_eof(pTHX_ OP *o)
12720 {
12721 PERL_ARGS_ASSERT_CK_EOF;
12722
12723 if (o->op_flags & OPf_KIDS) {
12724 OP *kid;
12725 if (cLISTOPo->op_first->op_type == OP_STUB) {
12726 OP * const newop
12727 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
12728 op_free(o);
12729 o = newop;
12730 }
12731 o = ck_fun(o);
12732 kid = cLISTOPo->op_first;
12733 if (kid->op_type == OP_RV2GV)
12734 kid->op_private |= OPpALLOW_FAKE;
12735 }
12736 return o;
12737 }
12738
12739
12740 OP *
Perl_ck_eval(pTHX_ OP * o)12741 Perl_ck_eval(pTHX_ OP *o)
12742 {
12743 dVAR;
12744
12745 PERL_ARGS_ASSERT_CK_EVAL;
12746
12747 PL_hints |= HINT_BLOCK_SCOPE;
12748 if (o->op_flags & OPf_KIDS) {
12749 SVOP * const kid = (SVOP*)cUNOPo->op_first;
12750 assert(kid);
12751
12752 if (o->op_type == OP_ENTERTRY) {
12753 LOGOP *enter;
12754
12755 /* cut whole sibling chain free from o */
12756 op_sibling_splice(o, NULL, -1, NULL);
12757 op_free(o);
12758
12759 enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
12760
12761 /* establish postfix order */
12762 enter->op_next = (OP*)enter;
12763
12764 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
12765 OpTYPE_set(o, OP_LEAVETRY);
12766 enter->op_other = o;
12767 return o;
12768 }
12769 else {
12770 scalar((OP*)kid);
12771 S_set_haseval(aTHX);
12772 }
12773 }
12774 else {
12775 const U8 priv = o->op_private;
12776 op_free(o);
12777 /* the newUNOP will recursively call ck_eval(), which will handle
12778 * all the stuff at the end of this function, like adding
12779 * OP_HINTSEVAL
12780 */
12781 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
12782 }
12783 o->op_targ = (PADOFFSET)PL_hints;
12784 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
12785 if ((PL_hints & HINT_LOCALIZE_HH) != 0
12786 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
12787 /* Store a copy of %^H that pp_entereval can pick up. */
12788 HV *hh = hv_copy_hints_hv(GvHV(PL_hintgv));
12789 OP *hhop;
12790 STOREFEATUREBITSHH(hh);
12791 hhop = newSVOP(OP_HINTSEVAL, 0, MUTABLE_SV(hh));
12792 /* append hhop to only child */
12793 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
12794
12795 o->op_private |= OPpEVAL_HAS_HH;
12796 }
12797 if (!(o->op_private & OPpEVAL_BYTES)
12798 && FEATURE_UNIEVAL_IS_ENABLED)
12799 o->op_private |= OPpEVAL_UNICODE;
12800 return o;
12801 }
12802
12803 OP *
Perl_ck_exec(pTHX_ OP * o)12804 Perl_ck_exec(pTHX_ OP *o)
12805 {
12806 PERL_ARGS_ASSERT_CK_EXEC;
12807
12808 if (o->op_flags & OPf_STACKED) {
12809 OP *kid;
12810 o = ck_fun(o);
12811 kid = OpSIBLING(cUNOPo->op_first);
12812 if (kid->op_type == OP_RV2GV)
12813 op_null(kid);
12814 }
12815 else
12816 o = listkids(o);
12817 return o;
12818 }
12819
12820 OP *
Perl_ck_exists(pTHX_ OP * o)12821 Perl_ck_exists(pTHX_ OP *o)
12822 {
12823 PERL_ARGS_ASSERT_CK_EXISTS;
12824
12825 o = ck_fun(o);
12826 if (o->op_flags & OPf_KIDS) {
12827 OP * const kid = cUNOPo->op_first;
12828 if (kid->op_type == OP_ENTERSUB) {
12829 (void) ref(kid, o->op_type);
12830 if (kid->op_type != OP_RV2CV
12831 && !(PL_parser && PL_parser->error_count))
12832 Perl_croak(aTHX_
12833 "exists argument is not a subroutine name");
12834 o->op_private |= OPpEXISTS_SUB;
12835 }
12836 else if (kid->op_type == OP_AELEM)
12837 o->op_flags |= OPf_SPECIAL;
12838 else if (kid->op_type != OP_HELEM)
12839 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
12840 "element or a subroutine");
12841 op_null(kid);
12842 }
12843 return o;
12844 }
12845
12846 OP *
Perl_ck_rvconst(pTHX_ OP * o)12847 Perl_ck_rvconst(pTHX_ OP *o)
12848 {
12849 dVAR;
12850 SVOP * const kid = (SVOP*)cUNOPo->op_first;
12851
12852 PERL_ARGS_ASSERT_CK_RVCONST;
12853
12854 if (o->op_type == OP_RV2HV)
12855 /* rv2hv steals the bottom bit for its own uses */
12856 o->op_private &= ~OPpARG1_MASK;
12857
12858 o->op_private |= (PL_hints & HINT_STRICT_REFS);
12859
12860 if (kid->op_type == OP_CONST) {
12861 int iscv;
12862 GV *gv;
12863 SV * const kidsv = kid->op_sv;
12864
12865 /* Is it a constant from cv_const_sv()? */
12866 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
12867 return o;
12868 }
12869 if (SvTYPE(kidsv) == SVt_PVAV) return o;
12870 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
12871 const char *badthing;
12872 switch (o->op_type) {
12873 case OP_RV2SV:
12874 badthing = "a SCALAR";
12875 break;
12876 case OP_RV2AV:
12877 badthing = "an ARRAY";
12878 break;
12879 case OP_RV2HV:
12880 badthing = "a HASH";
12881 break;
12882 default:
12883 badthing = NULL;
12884 break;
12885 }
12886 if (badthing)
12887 Perl_croak(aTHX_
12888 "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
12889 SVfARG(kidsv), badthing);
12890 }
12891 /*
12892 * This is a little tricky. We only want to add the symbol if we
12893 * didn't add it in the lexer. Otherwise we get duplicate strict
12894 * warnings. But if we didn't add it in the lexer, we must at
12895 * least pretend like we wanted to add it even if it existed before,
12896 * or we get possible typo warnings. OPpCONST_ENTERED says
12897 * whether the lexer already added THIS instance of this symbol.
12898 */
12899 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
12900 gv = gv_fetchsv(kidsv,
12901 o->op_type == OP_RV2CV
12902 && o->op_private & OPpMAY_RETURN_CONSTANT
12903 ? GV_NOEXPAND
12904 : iscv | !(kid->op_private & OPpCONST_ENTERED),
12905 iscv
12906 ? SVt_PVCV
12907 : o->op_type == OP_RV2SV
12908 ? SVt_PV
12909 : o->op_type == OP_RV2AV
12910 ? SVt_PVAV
12911 : o->op_type == OP_RV2HV
12912 ? SVt_PVHV
12913 : SVt_PVGV);
12914 if (gv) {
12915 if (!isGV(gv)) {
12916 assert(iscv);
12917 assert(SvROK(gv));
12918 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
12919 && SvTYPE(SvRV(gv)) != SVt_PVCV)
12920 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
12921 }
12922 OpTYPE_set(kid, OP_GV);
12923 SvREFCNT_dec(kid->op_sv);
12924 #ifdef USE_ITHREADS
12925 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
12926 STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
12927 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
12928 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
12929 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
12930 #else
12931 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
12932 #endif
12933 kid->op_private = 0;
12934 /* FAKE globs in the symbol table cause weird bugs (#77810) */
12935 SvFAKE_off(gv);
12936 }
12937 }
12938 return o;
12939 }
12940
12941 OP *
Perl_ck_ftst(pTHX_ OP * o)12942 Perl_ck_ftst(pTHX_ OP *o)
12943 {
12944 dVAR;
12945 const I32 type = o->op_type;
12946
12947 PERL_ARGS_ASSERT_CK_FTST;
12948
12949 if (o->op_flags & OPf_REF) {
12950 NOOP;
12951 }
12952 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
12953 SVOP * const kid = (SVOP*)cUNOPo->op_first;
12954 const OPCODE kidtype = kid->op_type;
12955
12956 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
12957 && !kid->op_folded) {
12958 OP * const newop = newGVOP(type, OPf_REF,
12959 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
12960 op_free(o);
12961 return newop;
12962 }
12963
12964 if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
12965 SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
12966 if (name) {
12967 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
12968 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
12969 array_passed_to_stat, name);
12970 }
12971 else {
12972 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
12973 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
12974 }
12975 }
12976 scalar((OP *) kid);
12977 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
12978 o->op_private |= OPpFT_ACCESS;
12979 if (OP_IS_FILETEST(type)
12980 && OP_IS_FILETEST(kidtype)
12981 ) {
12982 o->op_private |= OPpFT_STACKED;
12983 kid->op_private |= OPpFT_STACKING;
12984 if (kidtype == OP_FTTTY && (
12985 !(kid->op_private & OPpFT_STACKED)
12986 || kid->op_private & OPpFT_AFTER_t
12987 ))
12988 o->op_private |= OPpFT_AFTER_t;
12989 }
12990 }
12991 else {
12992 op_free(o);
12993 if (type == OP_FTTTY)
12994 o = newGVOP(type, OPf_REF, PL_stdingv);
12995 else
12996 o = newUNOP(type, 0, newDEFSVOP());
12997 }
12998 return o;
12999 }
13000
13001 OP *
Perl_ck_fun(pTHX_ OP * o)13002 Perl_ck_fun(pTHX_ OP *o)
13003 {
13004 const int type = o->op_type;
13005 I32 oa = PL_opargs[type] >> OASHIFT;
13006
13007 PERL_ARGS_ASSERT_CK_FUN;
13008
13009 if (o->op_flags & OPf_STACKED) {
13010 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
13011 oa &= ~OA_OPTIONAL;
13012 else
13013 return no_fh_allowed(o);
13014 }
13015
13016 if (o->op_flags & OPf_KIDS) {
13017 OP *prev_kid = NULL;
13018 OP *kid = cLISTOPo->op_first;
13019 I32 numargs = 0;
13020 bool seen_optional = FALSE;
13021
13022 if (kid->op_type == OP_PUSHMARK ||
13023 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
13024 {
13025 prev_kid = kid;
13026 kid = OpSIBLING(kid);
13027 }
13028 if (kid && kid->op_type == OP_COREARGS) {
13029 bool optional = FALSE;
13030 while (oa) {
13031 numargs++;
13032 if (oa & OA_OPTIONAL) optional = TRUE;
13033 oa = oa >> 4;
13034 }
13035 if (optional) o->op_private |= numargs;
13036 return o;
13037 }
13038
13039 while (oa) {
13040 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
13041 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
13042 kid = newDEFSVOP();
13043 /* append kid to chain */
13044 op_sibling_splice(o, prev_kid, 0, kid);
13045 }
13046 seen_optional = TRUE;
13047 }
13048 if (!kid) break;
13049
13050 numargs++;
13051 switch (oa & 7) {
13052 case OA_SCALAR:
13053 /* list seen where single (scalar) arg expected? */
13054 if (numargs == 1 && !(oa >> 4)
13055 && kid->op_type == OP_LIST && type != OP_SCALAR)
13056 {
13057 return too_many_arguments_pv(o,PL_op_desc[type], 0);
13058 }
13059 if (type != OP_DELETE) scalar(kid);
13060 break;
13061 case OA_LIST:
13062 if (oa < 16) {
13063 kid = 0;
13064 continue;
13065 }
13066 else
13067 list(kid);
13068 break;
13069 case OA_AVREF:
13070 if ((type == OP_PUSH || type == OP_UNSHIFT)
13071 && !OpHAS_SIBLING(kid))
13072 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
13073 "Useless use of %s with no values",
13074 PL_op_desc[type]);
13075
13076 if (kid->op_type == OP_CONST
13077 && ( !SvROK(cSVOPx_sv(kid))
13078 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
13079 )
13080 bad_type_pv(numargs, "array", o, kid);
13081 else if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV
13082 || kid->op_type == OP_RV2GV) {
13083 bad_type_pv(1, "array", o, kid);
13084 }
13085 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
13086 yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
13087 PL_op_desc[type]), 0);
13088 }
13089 else {
13090 op_lvalue(kid, type);
13091 }
13092 break;
13093 case OA_HVREF:
13094 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
13095 bad_type_pv(numargs, "hash", o, kid);
13096 op_lvalue(kid, type);
13097 break;
13098 case OA_CVREF:
13099 {
13100 /* replace kid with newop in chain */
13101 OP * const newop =
13102 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
13103 newop->op_next = newop;
13104 kid = newop;
13105 }
13106 break;
13107 case OA_FILEREF:
13108 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
13109 if (kid->op_type == OP_CONST &&
13110 (kid->op_private & OPpCONST_BARE))
13111 {
13112 OP * const newop = newGVOP(OP_GV, 0,
13113 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
13114 /* replace kid with newop in chain */
13115 op_sibling_splice(o, prev_kid, 1, newop);
13116 op_free(kid);
13117 kid = newop;
13118 }
13119 else if (kid->op_type == OP_READLINE) {
13120 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
13121 bad_type_pv(numargs, "HANDLE", o, kid);
13122 }
13123 else {
13124 I32 flags = OPf_SPECIAL;
13125 I32 priv = 0;
13126 PADOFFSET targ = 0;
13127
13128 /* is this op a FH constructor? */
13129 if (is_handle_constructor(o,numargs)) {
13130 const char *name = NULL;
13131 STRLEN len = 0;
13132 U32 name_utf8 = 0;
13133 bool want_dollar = TRUE;
13134
13135 flags = 0;
13136 /* Set a flag to tell rv2gv to vivify
13137 * need to "prove" flag does not mean something
13138 * else already - NI-S 1999/05/07
13139 */
13140 priv = OPpDEREF;
13141 if (kid->op_type == OP_PADSV) {
13142 PADNAME * const pn
13143 = PAD_COMPNAME_SV(kid->op_targ);
13144 name = PadnamePV (pn);
13145 len = PadnameLEN(pn);
13146 name_utf8 = PadnameUTF8(pn);
13147 }
13148 else if (kid->op_type == OP_RV2SV
13149 && kUNOP->op_first->op_type == OP_GV)
13150 {
13151 GV * const gv = cGVOPx_gv(kUNOP->op_first);
13152 name = GvNAME(gv);
13153 len = GvNAMELEN(gv);
13154 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
13155 }
13156 else if (kid->op_type == OP_AELEM
13157 || kid->op_type == OP_HELEM)
13158 {
13159 OP *firstop;
13160 OP *op = ((BINOP*)kid)->op_first;
13161 name = NULL;
13162 if (op) {
13163 SV *tmpstr = NULL;
13164 const char * const a =
13165 kid->op_type == OP_AELEM ?
13166 "[]" : "{}";
13167 if (((op->op_type == OP_RV2AV) ||
13168 (op->op_type == OP_RV2HV)) &&
13169 (firstop = ((UNOP*)op)->op_first) &&
13170 (firstop->op_type == OP_GV)) {
13171 /* packagevar $a[] or $h{} */
13172 GV * const gv = cGVOPx_gv(firstop);
13173 if (gv)
13174 tmpstr =
13175 Perl_newSVpvf(aTHX_
13176 "%s%c...%c",
13177 GvNAME(gv),
13178 a[0], a[1]);
13179 }
13180 else if (op->op_type == OP_PADAV
13181 || op->op_type == OP_PADHV) {
13182 /* lexicalvar $a[] or $h{} */
13183 const char * const padname =
13184 PAD_COMPNAME_PV(op->op_targ);
13185 if (padname)
13186 tmpstr =
13187 Perl_newSVpvf(aTHX_
13188 "%s%c...%c",
13189 padname + 1,
13190 a[0], a[1]);
13191 }
13192 if (tmpstr) {
13193 name = SvPV_const(tmpstr, len);
13194 name_utf8 = SvUTF8(tmpstr);
13195 sv_2mortal(tmpstr);
13196 }
13197 }
13198 if (!name) {
13199 name = "__ANONIO__";
13200 len = 10;
13201 want_dollar = FALSE;
13202 }
13203 op_lvalue(kid, type);
13204 }
13205 if (name) {
13206 SV *namesv;
13207 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
13208 namesv = PAD_SVl(targ);
13209 if (want_dollar && *name != '$')
13210 sv_setpvs(namesv, "$");
13211 else
13212 SvPVCLEAR(namesv);
13213 sv_catpvn(namesv, name, len);
13214 if ( name_utf8 ) SvUTF8_on(namesv);
13215 }
13216 }
13217 scalar(kid);
13218 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
13219 OP_RV2GV, flags);
13220 kid->op_targ = targ;
13221 kid->op_private |= priv;
13222 }
13223 }
13224 scalar(kid);
13225 break;
13226 case OA_SCALARREF:
13227 if ((type == OP_UNDEF || type == OP_POS)
13228 && numargs == 1 && !(oa >> 4)
13229 && kid->op_type == OP_LIST)
13230 return too_many_arguments_pv(o,PL_op_desc[type], 0);
13231 op_lvalue(scalar(kid), type);
13232 break;
13233 }
13234 oa >>= 4;
13235 prev_kid = kid;
13236 kid = OpSIBLING(kid);
13237 }
13238 /* FIXME - should the numargs or-ing move after the too many
13239 * arguments check? */
13240 o->op_private |= numargs;
13241 if (kid)
13242 return too_many_arguments_pv(o,OP_DESC(o), 0);
13243 listkids(o);
13244 }
13245 else if (PL_opargs[type] & OA_DEFGV) {
13246 /* Ordering of these two is important to keep f_map.t passing. */
13247 op_free(o);
13248 return newUNOP(type, 0, newDEFSVOP());
13249 }
13250
13251 if (oa) {
13252 while (oa & OA_OPTIONAL)
13253 oa >>= 4;
13254 if (oa && oa != OA_LIST)
13255 return too_few_arguments_pv(o,OP_DESC(o), 0);
13256 }
13257 return o;
13258 }
13259
13260 OP *
Perl_ck_glob(pTHX_ OP * o)13261 Perl_ck_glob(pTHX_ OP *o)
13262 {
13263 GV *gv;
13264
13265 PERL_ARGS_ASSERT_CK_GLOB;
13266
13267 o = ck_fun(o);
13268 if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
13269 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
13270
13271 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
13272 {
13273 /* convert
13274 * glob
13275 * \ null - const(wildcard)
13276 * into
13277 * null
13278 * \ enter
13279 * \ list
13280 * \ mark - glob - rv2cv
13281 * | \ gv(CORE::GLOBAL::glob)
13282 * |
13283 * \ null - const(wildcard)
13284 */
13285 o->op_flags |= OPf_SPECIAL;
13286 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
13287 o = S_new_entersubop(aTHX_ gv, o);
13288 o = newUNOP(OP_NULL, 0, o);
13289 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
13290 return o;
13291 }
13292 else o->op_flags &= ~OPf_SPECIAL;
13293 #if !defined(PERL_EXTERNAL_GLOB)
13294 if (!PL_globhook) {
13295 ENTER;
13296 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
13297 newSVpvs("File::Glob"), NULL, NULL, NULL);
13298 LEAVE;
13299 }
13300 #endif /* !PERL_EXTERNAL_GLOB */
13301 gv = (GV *)newSV(0);
13302 gv_init(gv, 0, "", 0, 0);
13303 gv_IOadd(gv);
13304 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
13305 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
13306 scalarkids(o);
13307 return o;
13308 }
13309
13310 OP *
Perl_ck_grep(pTHX_ OP * o)13311 Perl_ck_grep(pTHX_ OP *o)
13312 {
13313 LOGOP *gwop;
13314 OP *kid;
13315 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
13316
13317 PERL_ARGS_ASSERT_CK_GREP;
13318
13319 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
13320
13321 if (o->op_flags & OPf_STACKED) {
13322 kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
13323 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
13324 return no_fh_allowed(o);
13325 o->op_flags &= ~OPf_STACKED;
13326 }
13327 kid = OpSIBLING(cLISTOPo->op_first);
13328 if (type == OP_MAPWHILE)
13329 list(kid);
13330 else
13331 scalar(kid);
13332 o = ck_fun(o);
13333 if (PL_parser && PL_parser->error_count)
13334 return o;
13335 kid = OpSIBLING(cLISTOPo->op_first);
13336 if (kid->op_type != OP_NULL)
13337 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
13338 kid = kUNOP->op_first;
13339
13340 gwop = alloc_LOGOP(type, o, LINKLIST(kid));
13341 kid->op_next = (OP*)gwop;
13342 o->op_private = gwop->op_private = 0;
13343 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
13344
13345 kid = OpSIBLING(cLISTOPo->op_first);
13346 for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
13347 op_lvalue(kid, OP_GREPSTART);
13348
13349 return (OP*)gwop;
13350 }
13351
13352 OP *
Perl_ck_index(pTHX_ OP * o)13353 Perl_ck_index(pTHX_ OP *o)
13354 {
13355 PERL_ARGS_ASSERT_CK_INDEX;
13356
13357 if (o->op_flags & OPf_KIDS) {
13358 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13359 if (kid)
13360 kid = OpSIBLING(kid); /* get past "big" */
13361 if (kid && kid->op_type == OP_CONST) {
13362 const bool save_taint = TAINT_get;
13363 SV *sv = kSVOP->op_sv;
13364 if ( (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
13365 && SvOK(sv) && !SvROK(sv))
13366 {
13367 sv = newSV(0);
13368 sv_copypv(sv, kSVOP->op_sv);
13369 SvREFCNT_dec_NN(kSVOP->op_sv);
13370 kSVOP->op_sv = sv;
13371 }
13372 if (SvOK(sv)) fbm_compile(sv, 0);
13373 TAINT_set(save_taint);
13374 #ifdef NO_TAINT_SUPPORT
13375 PERL_UNUSED_VAR(save_taint);
13376 #endif
13377 }
13378 }
13379 return ck_fun(o);
13380 }
13381
13382 OP *
Perl_ck_lfun(pTHX_ OP * o)13383 Perl_ck_lfun(pTHX_ OP *o)
13384 {
13385 const OPCODE type = o->op_type;
13386
13387 PERL_ARGS_ASSERT_CK_LFUN;
13388
13389 return modkids(ck_fun(o), type);
13390 }
13391
13392 OP *
Perl_ck_defined(pTHX_ OP * o)13393 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
13394 {
13395 PERL_ARGS_ASSERT_CK_DEFINED;
13396
13397 if ((o->op_flags & OPf_KIDS)) {
13398 switch (cUNOPo->op_first->op_type) {
13399 case OP_RV2AV:
13400 case OP_PADAV:
13401 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
13402 " (Maybe you should just omit the defined()?)");
13403 NOT_REACHED; /* NOTREACHED */
13404 break;
13405 case OP_RV2HV:
13406 case OP_PADHV:
13407 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
13408 " (Maybe you should just omit the defined()?)");
13409 NOT_REACHED; /* NOTREACHED */
13410 break;
13411 default:
13412 /* no warning */
13413 break;
13414 }
13415 }
13416 return ck_rfun(o);
13417 }
13418
13419 OP *
Perl_ck_readline(pTHX_ OP * o)13420 Perl_ck_readline(pTHX_ OP *o)
13421 {
13422 PERL_ARGS_ASSERT_CK_READLINE;
13423
13424 if (o->op_flags & OPf_KIDS) {
13425 OP *kid = cLISTOPo->op_first;
13426 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
13427 scalar(kid);
13428 }
13429 else {
13430 OP * const newop
13431 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
13432 op_free(o);
13433 return newop;
13434 }
13435 return o;
13436 }
13437
13438 OP *
Perl_ck_rfun(pTHX_ OP * o)13439 Perl_ck_rfun(pTHX_ OP *o)
13440 {
13441 const OPCODE type = o->op_type;
13442
13443 PERL_ARGS_ASSERT_CK_RFUN;
13444
13445 return refkids(ck_fun(o), type);
13446 }
13447
13448 OP *
Perl_ck_listiob(pTHX_ OP * o)13449 Perl_ck_listiob(pTHX_ OP *o)
13450 {
13451 OP *kid;
13452
13453 PERL_ARGS_ASSERT_CK_LISTIOB;
13454
13455 kid = cLISTOPo->op_first;
13456 if (!kid) {
13457 o = force_list(o, 1);
13458 kid = cLISTOPo->op_first;
13459 }
13460 if (kid->op_type == OP_PUSHMARK)
13461 kid = OpSIBLING(kid);
13462 if (kid && o->op_flags & OPf_STACKED)
13463 kid = OpSIBLING(kid);
13464 else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */
13465 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
13466 && !kid->op_folded) {
13467 o->op_flags |= OPf_STACKED; /* make it a filehandle */
13468 scalar(kid);
13469 /* replace old const op with new OP_RV2GV parent */
13470 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
13471 OP_RV2GV, OPf_REF);
13472 kid = OpSIBLING(kid);
13473 }
13474 }
13475
13476 if (!kid)
13477 op_append_elem(o->op_type, o, newDEFSVOP());
13478
13479 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
13480 return listkids(o);
13481 }
13482
13483 OP *
Perl_ck_smartmatch(pTHX_ OP * o)13484 Perl_ck_smartmatch(pTHX_ OP *o)
13485 {
13486 dVAR;
13487 PERL_ARGS_ASSERT_CK_SMARTMATCH;
13488 if (0 == (o->op_flags & OPf_SPECIAL)) {
13489 OP *first = cBINOPo->op_first;
13490 OP *second = OpSIBLING(first);
13491
13492 /* Implicitly take a reference to an array or hash */
13493
13494 /* remove the original two siblings, then add back the
13495 * (possibly different) first and second sibs.
13496 */
13497 op_sibling_splice(o, NULL, 1, NULL);
13498 op_sibling_splice(o, NULL, 1, NULL);
13499 first = ref_array_or_hash(first);
13500 second = ref_array_or_hash(second);
13501 op_sibling_splice(o, NULL, 0, second);
13502 op_sibling_splice(o, NULL, 0, first);
13503
13504 /* Implicitly take a reference to a regular expression */
13505 if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
13506 OpTYPE_set(first, OP_QR);
13507 }
13508 if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
13509 OpTYPE_set(second, OP_QR);
13510 }
13511 }
13512
13513 return o;
13514 }
13515
13516
13517 static OP *
S_maybe_targlex(pTHX_ OP * o)13518 S_maybe_targlex(pTHX_ OP *o)
13519 {
13520 OP * const kid = cLISTOPo->op_first;
13521 /* has a disposable target? */
13522 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
13523 && !(kid->op_flags & OPf_STACKED)
13524 /* Cannot steal the second time! */
13525 && !(kid->op_private & OPpTARGET_MY)
13526 )
13527 {
13528 OP * const kkid = OpSIBLING(kid);
13529
13530 /* Can just relocate the target. */
13531 if (kkid && kkid->op_type == OP_PADSV
13532 && (!(kkid->op_private & OPpLVAL_INTRO)
13533 || kkid->op_private & OPpPAD_STATE))
13534 {
13535 kid->op_targ = kkid->op_targ;
13536 kkid->op_targ = 0;
13537 /* Now we do not need PADSV and SASSIGN.
13538 * Detach kid and free the rest. */
13539 op_sibling_splice(o, NULL, 1, NULL);
13540 op_free(o);
13541 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
13542 return kid;
13543 }
13544 }
13545 return o;
13546 }
13547
13548 OP *
Perl_ck_sassign(pTHX_ OP * o)13549 Perl_ck_sassign(pTHX_ OP *o)
13550 {
13551 dVAR;
13552 OP * const kid = cBINOPo->op_first;
13553
13554 PERL_ARGS_ASSERT_CK_SASSIGN;
13555
13556 if (OpHAS_SIBLING(kid)) {
13557 OP *kkid = OpSIBLING(kid);
13558 /* For state variable assignment with attributes, kkid is a list op
13559 whose op_last is a padsv. */
13560 if ((kkid->op_type == OP_PADSV ||
13561 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
13562 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
13563 )
13564 )
13565 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
13566 == (OPpLVAL_INTRO|OPpPAD_STATE)) {
13567 return S_newONCEOP(aTHX_ o, kkid);
13568 }
13569 }
13570 return S_maybe_targlex(aTHX_ o);
13571 }
13572
13573
13574 OP *
Perl_ck_match(pTHX_ OP * o)13575 Perl_ck_match(pTHX_ OP *o)
13576 {
13577 PERL_UNUSED_CONTEXT;
13578 PERL_ARGS_ASSERT_CK_MATCH;
13579
13580 return o;
13581 }
13582
13583 OP *
Perl_ck_method(pTHX_ OP * o)13584 Perl_ck_method(pTHX_ OP *o)
13585 {
13586 SV *sv, *methsv, *rclass;
13587 const char* method;
13588 char* compatptr;
13589 int utf8;
13590 STRLEN len, nsplit = 0, i;
13591 OP* new_op;
13592 OP * const kid = cUNOPo->op_first;
13593
13594 PERL_ARGS_ASSERT_CK_METHOD;
13595 if (kid->op_type != OP_CONST) return o;
13596
13597 sv = kSVOP->op_sv;
13598
13599 /* replace ' with :: */
13600 while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
13601 SvEND(sv) - SvPVX(sv) )))
13602 {
13603 *compatptr = ':';
13604 sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
13605 }
13606
13607 method = SvPVX_const(sv);
13608 len = SvCUR(sv);
13609 utf8 = SvUTF8(sv) ? -1 : 1;
13610
13611 for (i = len - 1; i > 0; --i) if (method[i] == ':') {
13612 nsplit = i+1;
13613 break;
13614 }
13615
13616 methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
13617
13618 if (!nsplit) { /* $proto->method() */
13619 op_free(o);
13620 return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
13621 }
13622
13623 if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
13624 op_free(o);
13625 return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
13626 }
13627
13628 /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
13629 if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
13630 rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
13631 new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
13632 } else {
13633 rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
13634 new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
13635 }
13636 #ifdef USE_ITHREADS
13637 op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
13638 #else
13639 cMETHOPx(new_op)->op_rclass_sv = rclass;
13640 #endif
13641 op_free(o);
13642 return new_op;
13643 }
13644
13645 OP *
Perl_ck_null(pTHX_ OP * o)13646 Perl_ck_null(pTHX_ OP *o)
13647 {
13648 PERL_ARGS_ASSERT_CK_NULL;
13649 PERL_UNUSED_CONTEXT;
13650 return o;
13651 }
13652
13653 OP *
Perl_ck_open(pTHX_ OP * o)13654 Perl_ck_open(pTHX_ OP *o)
13655 {
13656 PERL_ARGS_ASSERT_CK_OPEN;
13657
13658 S_io_hints(aTHX_ o);
13659 {
13660 /* In case of three-arg dup open remove strictness
13661 * from the last arg if it is a bareword. */
13662 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
13663 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
13664 OP *oa;
13665 const char *mode;
13666
13667 if ((last->op_type == OP_CONST) && /* The bareword. */
13668 (last->op_private & OPpCONST_BARE) &&
13669 (last->op_private & OPpCONST_STRICT) &&
13670 (oa = OpSIBLING(first)) && /* The fh. */
13671 (oa = OpSIBLING(oa)) && /* The mode. */
13672 (oa->op_type == OP_CONST) &&
13673 SvPOK(((SVOP*)oa)->op_sv) &&
13674 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
13675 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
13676 (last == OpSIBLING(oa))) /* The bareword. */
13677 last->op_private &= ~OPpCONST_STRICT;
13678 }
13679 return ck_fun(o);
13680 }
13681
13682 OP *
Perl_ck_prototype(pTHX_ OP * o)13683 Perl_ck_prototype(pTHX_ OP *o)
13684 {
13685 PERL_ARGS_ASSERT_CK_PROTOTYPE;
13686 if (!(o->op_flags & OPf_KIDS)) {
13687 op_free(o);
13688 return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
13689 }
13690 return o;
13691 }
13692
13693 OP *
Perl_ck_refassign(pTHX_ OP * o)13694 Perl_ck_refassign(pTHX_ OP *o)
13695 {
13696 OP * const right = cLISTOPo->op_first;
13697 OP * const left = OpSIBLING(right);
13698 OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
13699 bool stacked = 0;
13700
13701 PERL_ARGS_ASSERT_CK_REFASSIGN;
13702 assert (left);
13703 assert (left->op_type == OP_SREFGEN);
13704
13705 o->op_private = 0;
13706 /* we use OPpPAD_STATE in refassign to mean either of those things,
13707 * and the code assumes the two flags occupy the same bit position
13708 * in the various ops below */
13709 assert(OPpPAD_STATE == OPpOUR_INTRO);
13710
13711 switch (varop->op_type) {
13712 case OP_PADAV:
13713 o->op_private |= OPpLVREF_AV;
13714 goto settarg;
13715 case OP_PADHV:
13716 o->op_private |= OPpLVREF_HV;
13717 /* FALLTHROUGH */
13718 case OP_PADSV:
13719 settarg:
13720 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
13721 o->op_targ = varop->op_targ;
13722 varop->op_targ = 0;
13723 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
13724 break;
13725
13726 case OP_RV2AV:
13727 o->op_private |= OPpLVREF_AV;
13728 goto checkgv;
13729 NOT_REACHED; /* NOTREACHED */
13730 case OP_RV2HV:
13731 o->op_private |= OPpLVREF_HV;
13732 /* FALLTHROUGH */
13733 case OP_RV2SV:
13734 checkgv:
13735 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
13736 if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
13737 detach_and_stack:
13738 /* Point varop to its GV kid, detached. */
13739 varop = op_sibling_splice(varop, NULL, -1, NULL);
13740 stacked = TRUE;
13741 break;
13742 case OP_RV2CV: {
13743 OP * const kidparent =
13744 OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
13745 OP * const kid = cUNOPx(kidparent)->op_first;
13746 o->op_private |= OPpLVREF_CV;
13747 if (kid->op_type == OP_GV) {
13748 SV *sv = (SV*)cGVOPx_gv(kid);
13749 varop = kidparent;
13750 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
13751 /* a CVREF here confuses pp_refassign, so make sure
13752 it gets a GV */
13753 CV *const cv = (CV*)SvRV(sv);
13754 SV *name_sv = sv_2mortal(newSVhek(CvNAME_HEK(cv)));
13755 (void)gv_init_sv((GV*)sv, CvSTASH(cv), name_sv, 0);
13756 assert(SvTYPE(sv) == SVt_PVGV);
13757 }
13758 goto detach_and_stack;
13759 }
13760 if (kid->op_type != OP_PADCV) goto bad;
13761 o->op_targ = kid->op_targ;
13762 kid->op_targ = 0;
13763 break;
13764 }
13765 case OP_AELEM:
13766 case OP_HELEM:
13767 o->op_private |= (varop->op_private & OPpLVAL_INTRO);
13768 o->op_private |= OPpLVREF_ELEM;
13769 op_null(varop);
13770 stacked = TRUE;
13771 /* Detach varop. */
13772 op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
13773 break;
13774 default:
13775 bad:
13776 /* diag_listed_as: Can't modify reference to %s in %s assignment */
13777 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
13778 "assignment",
13779 OP_DESC(varop)));
13780 return o;
13781 }
13782 if (!FEATURE_REFALIASING_IS_ENABLED)
13783 Perl_croak(aTHX_
13784 "Experimental aliasing via reference not enabled");
13785 Perl_ck_warner_d(aTHX_
13786 packWARN(WARN_EXPERIMENTAL__REFALIASING),
13787 "Aliasing via reference is experimental");
13788 if (stacked) {
13789 o->op_flags |= OPf_STACKED;
13790 op_sibling_splice(o, right, 1, varop);
13791 }
13792 else {
13793 o->op_flags &=~ OPf_STACKED;
13794 op_sibling_splice(o, right, 1, NULL);
13795 }
13796 op_free(left);
13797 return o;
13798 }
13799
13800 OP *
Perl_ck_repeat(pTHX_ OP * o)13801 Perl_ck_repeat(pTHX_ OP *o)
13802 {
13803 PERL_ARGS_ASSERT_CK_REPEAT;
13804
13805 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
13806 OP* kids;
13807 o->op_private |= OPpREPEAT_DOLIST;
13808 kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
13809 kids = force_list(kids, 1); /* promote it to a list */
13810 op_sibling_splice(o, NULL, 0, kids); /* and add back */
13811 }
13812 else
13813 scalar(o);
13814 return o;
13815 }
13816
13817 OP *
Perl_ck_require(pTHX_ OP * o)13818 Perl_ck_require(pTHX_ OP *o)
13819 {
13820 GV* gv;
13821
13822 PERL_ARGS_ASSERT_CK_REQUIRE;
13823
13824 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
13825 SVOP * const kid = (SVOP*)cUNOPo->op_first;
13826 U32 hash;
13827 char *s;
13828 STRLEN len;
13829 if (kid->op_type == OP_CONST) {
13830 SV * const sv = kid->op_sv;
13831 U32 const was_readonly = SvREADONLY(sv);
13832 if (kid->op_private & OPpCONST_BARE) {
13833 dVAR;
13834 const char *end;
13835 HEK *hek;
13836
13837 if (was_readonly) {
13838 SvREADONLY_off(sv);
13839 }
13840
13841 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
13842
13843 s = SvPVX(sv);
13844 len = SvCUR(sv);
13845 end = s + len;
13846 /* treat ::foo::bar as foo::bar */
13847 if (len >= 2 && s[0] == ':' && s[1] == ':')
13848 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
13849 if (s == end)
13850 DIE(aTHX_ "Bareword in require maps to empty filename");
13851
13852 for (; s < end; s++) {
13853 if (*s == ':' && s[1] == ':') {
13854 *s = '/';
13855 Move(s+2, s+1, end - s - 1, char);
13856 --end;
13857 }
13858 }
13859 SvEND_set(sv, end);
13860 sv_catpvs(sv, ".pm");
13861 PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
13862 hek = share_hek(SvPVX(sv),
13863 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
13864 hash);
13865 sv_sethek(sv, hek);
13866 unshare_hek(hek);
13867 SvFLAGS(sv) |= was_readonly;
13868 }
13869 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
13870 && !SvVOK(sv)) {
13871 s = SvPV(sv, len);
13872 if (SvREFCNT(sv) > 1) {
13873 kid->op_sv = newSVpvn_share(
13874 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
13875 SvREFCNT_dec_NN(sv);
13876 }
13877 else {
13878 dVAR;
13879 HEK *hek;
13880 if (was_readonly) SvREADONLY_off(sv);
13881 PERL_HASH(hash, s, len);
13882 hek = share_hek(s,
13883 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
13884 hash);
13885 sv_sethek(sv, hek);
13886 unshare_hek(hek);
13887 SvFLAGS(sv) |= was_readonly;
13888 }
13889 }
13890 }
13891 }
13892
13893 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
13894 /* handle override, if any */
13895 && (gv = gv_override("require", 7))) {
13896 OP *kid, *newop;
13897 if (o->op_flags & OPf_KIDS) {
13898 kid = cUNOPo->op_first;
13899 op_sibling_splice(o, NULL, -1, NULL);
13900 }
13901 else {
13902 kid = newDEFSVOP();
13903 }
13904 op_free(o);
13905 newop = S_new_entersubop(aTHX_ gv, kid);
13906 return newop;
13907 }
13908
13909 return ck_fun(o);
13910 }
13911
13912 OP *
Perl_ck_return(pTHX_ OP * o)13913 Perl_ck_return(pTHX_ OP *o)
13914 {
13915 OP *kid;
13916
13917 PERL_ARGS_ASSERT_CK_RETURN;
13918
13919 kid = OpSIBLING(cLISTOPo->op_first);
13920 if (PL_compcv && CvLVALUE(PL_compcv)) {
13921 for (; kid; kid = OpSIBLING(kid))
13922 op_lvalue(kid, OP_LEAVESUBLV);
13923 }
13924
13925 return o;
13926 }
13927
13928 OP *
Perl_ck_select(pTHX_ OP * o)13929 Perl_ck_select(pTHX_ OP *o)
13930 {
13931 dVAR;
13932 OP* kid;
13933
13934 PERL_ARGS_ASSERT_CK_SELECT;
13935
13936 if (o->op_flags & OPf_KIDS) {
13937 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13938 if (kid && OpHAS_SIBLING(kid)) {
13939 OpTYPE_set(o, OP_SSELECT);
13940 o = ck_fun(o);
13941 return fold_constants(op_integerize(op_std_init(o)));
13942 }
13943 }
13944 o = ck_fun(o);
13945 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13946 if (kid && kid->op_type == OP_RV2GV)
13947 kid->op_private &= ~HINT_STRICT_REFS;
13948 return o;
13949 }
13950
13951 OP *
Perl_ck_shift(pTHX_ OP * o)13952 Perl_ck_shift(pTHX_ OP *o)
13953 {
13954 const I32 type = o->op_type;
13955
13956 PERL_ARGS_ASSERT_CK_SHIFT;
13957
13958 if (!(o->op_flags & OPf_KIDS)) {
13959 OP *argop;
13960
13961 if (!CvUNIQUE(PL_compcv)) {
13962 o->op_flags |= OPf_SPECIAL;
13963 return o;
13964 }
13965
13966 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
13967 op_free(o);
13968 return newUNOP(type, 0, scalar(argop));
13969 }
13970 return scalar(ck_fun(o));
13971 }
13972
13973 OP *
Perl_ck_sort(pTHX_ OP * o)13974 Perl_ck_sort(pTHX_ OP *o)
13975 {
13976 OP *firstkid;
13977 OP *kid;
13978 HV * const hinthv =
13979 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
13980 U8 stacked;
13981
13982 PERL_ARGS_ASSERT_CK_SORT;
13983
13984 if (hinthv) {
13985 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
13986 if (svp) {
13987 const I32 sorthints = (I32)SvIV(*svp);
13988 if ((sorthints & HINT_SORT_STABLE) != 0)
13989 o->op_private |= OPpSORT_STABLE;
13990 if ((sorthints & HINT_SORT_UNSTABLE) != 0)
13991 o->op_private |= OPpSORT_UNSTABLE;
13992 }
13993 }
13994
13995 if (o->op_flags & OPf_STACKED)
13996 simplify_sort(o);
13997 firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13998
13999 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
14000 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
14001
14002 /* if the first arg is a code block, process it and mark sort as
14003 * OPf_SPECIAL */
14004 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
14005 LINKLIST(kid);
14006 if (kid->op_type == OP_LEAVE)
14007 op_null(kid); /* wipe out leave */
14008 /* Prevent execution from escaping out of the sort block. */
14009 kid->op_next = 0;
14010
14011 /* provide scalar context for comparison function/block */
14012 kid = scalar(firstkid);
14013 kid->op_next = kid;
14014 o->op_flags |= OPf_SPECIAL;
14015 }
14016 else if (kid->op_type == OP_CONST
14017 && kid->op_private & OPpCONST_BARE) {
14018 char tmpbuf[256];
14019 STRLEN len;
14020 PADOFFSET off;
14021 const char * const name = SvPV(kSVOP_sv, len);
14022 *tmpbuf = '&';
14023 assert (len < 256);
14024 Copy(name, tmpbuf+1, len, char);
14025 off = pad_findmy_pvn(tmpbuf, len+1, 0);
14026 if (off != NOT_IN_PAD) {
14027 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
14028 SV * const fq =
14029 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
14030 sv_catpvs(fq, "::");
14031 sv_catsv(fq, kSVOP_sv);
14032 SvREFCNT_dec_NN(kSVOP_sv);
14033 kSVOP->op_sv = fq;
14034 }
14035 else {
14036 OP * const padop = newOP(OP_PADCV, 0);
14037 padop->op_targ = off;
14038 /* replace the const op with the pad op */
14039 op_sibling_splice(firstkid, NULL, 1, padop);
14040 op_free(kid);
14041 }
14042 }
14043 }
14044
14045 firstkid = OpSIBLING(firstkid);
14046 }
14047
14048 for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
14049 /* provide list context for arguments */
14050 list(kid);
14051 if (stacked)
14052 op_lvalue(kid, OP_GREPSTART);
14053 }
14054
14055 return o;
14056 }
14057
14058 /* for sort { X } ..., where X is one of
14059 * $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
14060 * elide the second child of the sort (the one containing X),
14061 * and set these flags as appropriate
14062 OPpSORT_NUMERIC;
14063 OPpSORT_INTEGER;
14064 OPpSORT_DESCEND;
14065 * Also, check and warn on lexical $a, $b.
14066 */
14067
14068 STATIC void
S_simplify_sort(pTHX_ OP * o)14069 S_simplify_sort(pTHX_ OP *o)
14070 {
14071 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
14072 OP *k;
14073 int descending;
14074 GV *gv;
14075 const char *gvname;
14076 bool have_scopeop;
14077
14078 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
14079
14080 kid = kUNOP->op_first; /* get past null */
14081 if (!(have_scopeop = kid->op_type == OP_SCOPE)
14082 && kid->op_type != OP_LEAVE)
14083 return;
14084 kid = kLISTOP->op_last; /* get past scope */
14085 switch(kid->op_type) {
14086 case OP_NCMP:
14087 case OP_I_NCMP:
14088 case OP_SCMP:
14089 if (!have_scopeop) goto padkids;
14090 break;
14091 default:
14092 return;
14093 }
14094 k = kid; /* remember this node*/
14095 if (kBINOP->op_first->op_type != OP_RV2SV
14096 || kBINOP->op_last ->op_type != OP_RV2SV)
14097 {
14098 /*
14099 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
14100 then used in a comparison. This catches most, but not
14101 all cases. For instance, it catches
14102 sort { my($a); $a <=> $b }
14103 but not
14104 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
14105 (although why you'd do that is anyone's guess).
14106 */
14107
14108 padkids:
14109 if (!ckWARN(WARN_SYNTAX)) return;
14110 kid = kBINOP->op_first;
14111 do {
14112 if (kid->op_type == OP_PADSV) {
14113 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
14114 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
14115 && ( PadnamePV(name)[1] == 'a'
14116 || PadnamePV(name)[1] == 'b' ))
14117 /* diag_listed_as: "my %s" used in sort comparison */
14118 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14119 "\"%s %s\" used in sort comparison",
14120 PadnameIsSTATE(name)
14121 ? "state"
14122 : "my",
14123 PadnamePV(name));
14124 }
14125 } while ((kid = OpSIBLING(kid)));
14126 return;
14127 }
14128 kid = kBINOP->op_first; /* get past cmp */
14129 if (kUNOP->op_first->op_type != OP_GV)
14130 return;
14131 kid = kUNOP->op_first; /* get past rv2sv */
14132 gv = kGVOP_gv;
14133 if (GvSTASH(gv) != PL_curstash)
14134 return;
14135 gvname = GvNAME(gv);
14136 if (*gvname == 'a' && gvname[1] == '\0')
14137 descending = 0;
14138 else if (*gvname == 'b' && gvname[1] == '\0')
14139 descending = 1;
14140 else
14141 return;
14142
14143 kid = k; /* back to cmp */
14144 /* already checked above that it is rv2sv */
14145 kid = kBINOP->op_last; /* down to 2nd arg */
14146 if (kUNOP->op_first->op_type != OP_GV)
14147 return;
14148 kid = kUNOP->op_first; /* get past rv2sv */
14149 gv = kGVOP_gv;
14150 if (GvSTASH(gv) != PL_curstash)
14151 return;
14152 gvname = GvNAME(gv);
14153 if ( descending
14154 ? !(*gvname == 'a' && gvname[1] == '\0')
14155 : !(*gvname == 'b' && gvname[1] == '\0'))
14156 return;
14157 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
14158 if (descending)
14159 o->op_private |= OPpSORT_DESCEND;
14160 if (k->op_type == OP_NCMP)
14161 o->op_private |= OPpSORT_NUMERIC;
14162 if (k->op_type == OP_I_NCMP)
14163 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
14164 kid = OpSIBLING(cLISTOPo->op_first);
14165 /* cut out and delete old block (second sibling) */
14166 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
14167 op_free(kid);
14168 }
14169
14170 OP *
Perl_ck_split(pTHX_ OP * o)14171 Perl_ck_split(pTHX_ OP *o)
14172 {
14173 dVAR;
14174 OP *kid;
14175 OP *sibs;
14176
14177 PERL_ARGS_ASSERT_CK_SPLIT;
14178
14179 assert(o->op_type == OP_LIST);
14180
14181 if (o->op_flags & OPf_STACKED)
14182 return no_fh_allowed(o);
14183
14184 kid = cLISTOPo->op_first;
14185 /* delete leading NULL node, then add a CONST if no other nodes */
14186 assert(kid->op_type == OP_NULL);
14187 op_sibling_splice(o, NULL, 1,
14188 OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
14189 op_free(kid);
14190 kid = cLISTOPo->op_first;
14191
14192 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
14193 /* remove match expression, and replace with new optree with
14194 * a match op at its head */
14195 op_sibling_splice(o, NULL, 1, NULL);
14196 /* pmruntime will handle split " " behavior with flag==2 */
14197 kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
14198 op_sibling_splice(o, NULL, 0, kid);
14199 }
14200
14201 assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
14202
14203 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
14204 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
14205 "Use of /g modifier is meaningless in split");
14206 }
14207
14208 /* eliminate the split op, and move the match op (plus any children)
14209 * into its place, then convert the match op into a split op. i.e.
14210 *
14211 * SPLIT MATCH SPLIT(ex-MATCH)
14212 * | | |
14213 * MATCH - A - B - C => R - A - B - C => R - A - B - C
14214 * | | |
14215 * R X - Y X - Y
14216 * |
14217 * X - Y
14218 *
14219 * (R, if it exists, will be a regcomp op)
14220 */
14221
14222 op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
14223 sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
14224 op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
14225 OpTYPE_set(kid, OP_SPLIT);
14226 kid->op_flags = (o->op_flags | (kid->op_flags & OPf_KIDS));
14227 kid->op_private = o->op_private;
14228 op_free(o);
14229 o = kid;
14230 kid = sibs; /* kid is now the string arg of the split */
14231
14232 if (!kid) {
14233 kid = newDEFSVOP();
14234 op_append_elem(OP_SPLIT, o, kid);
14235 }
14236 scalar(kid);
14237
14238 kid = OpSIBLING(kid);
14239 if (!kid) {
14240 kid = newSVOP(OP_CONST, 0, newSViv(0));
14241 op_append_elem(OP_SPLIT, o, kid);
14242 o->op_private |= OPpSPLIT_IMPLIM;
14243 }
14244 scalar(kid);
14245
14246 if (OpHAS_SIBLING(kid))
14247 return too_many_arguments_pv(o,OP_DESC(o), 0);
14248
14249 return o;
14250 }
14251
14252 OP *
Perl_ck_stringify(pTHX_ OP * o)14253 Perl_ck_stringify(pTHX_ OP *o)
14254 {
14255 OP * const kid = OpSIBLING(cUNOPo->op_first);
14256 PERL_ARGS_ASSERT_CK_STRINGIFY;
14257 if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
14258 || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
14259 || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
14260 && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
14261 {
14262 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
14263 op_free(o);
14264 return kid;
14265 }
14266 return ck_fun(o);
14267 }
14268
14269 OP *
Perl_ck_join(pTHX_ OP * o)14270 Perl_ck_join(pTHX_ OP *o)
14271 {
14272 OP * const kid = OpSIBLING(cLISTOPo->op_first);
14273
14274 PERL_ARGS_ASSERT_CK_JOIN;
14275
14276 if (kid && kid->op_type == OP_MATCH) {
14277 if (ckWARN(WARN_SYNTAX)) {
14278 const REGEXP *re = PM_GETRE(kPMOP);
14279 const SV *msg = re
14280 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
14281 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
14282 : newSVpvs_flags( "STRING", SVs_TEMP );
14283 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14284 "/%" SVf "/ should probably be written as \"%" SVf "\"",
14285 SVfARG(msg), SVfARG(msg));
14286 }
14287 }
14288 if (kid
14289 && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
14290 || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
14291 || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
14292 && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
14293 {
14294 const OP * const bairn = OpSIBLING(kid); /* the list */
14295 if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
14296 && OP_GIMME(bairn,0) == G_SCALAR)
14297 {
14298 OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
14299 op_sibling_splice(o, kid, 1, NULL));
14300 op_free(o);
14301 return ret;
14302 }
14303 }
14304
14305 return ck_fun(o);
14306 }
14307
14308 /*
14309 =for apidoc rv2cv_op_cv
14310
14311 Examines an op, which is expected to identify a subroutine at runtime,
14312 and attempts to determine at compile time which subroutine it identifies.
14313 This is normally used during Perl compilation to determine whether
14314 a prototype can be applied to a function call. C<cvop> is the op
14315 being considered, normally an C<rv2cv> op. A pointer to the identified
14316 subroutine is returned, if it could be determined statically, and a null
14317 pointer is returned if it was not possible to determine statically.
14318
14319 Currently, the subroutine can be identified statically if the RV that the
14320 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
14321 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
14322 suitable if the constant value must be an RV pointing to a CV. Details of
14323 this process may change in future versions of Perl. If the C<rv2cv> op
14324 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
14325 the subroutine statically: this flag is used to suppress compile-time
14326 magic on a subroutine call, forcing it to use default runtime behaviour.
14327
14328 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
14329 of a GV reference is modified. If a GV was examined and its CV slot was
14330 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
14331 If the op is not optimised away, and the CV slot is later populated with
14332 a subroutine having a prototype, that flag eventually triggers the warning
14333 "called too early to check prototype".
14334
14335 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
14336 of returning a pointer to the subroutine it returns a pointer to the
14337 GV giving the most appropriate name for the subroutine in this context.
14338 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
14339 (C<CvANON>) subroutine that is referenced through a GV it will be the
14340 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
14341 A null pointer is returned as usual if there is no statically-determinable
14342 subroutine.
14343
14344 =for apidoc Amnh||OPpEARLY_CV
14345 =for apidoc Amnh||OPpENTERSUB_AMPER
14346 =for apidoc Amnh||RV2CVOPCV_MARK_EARLY
14347 =for apidoc Amnh||RV2CVOPCV_RETURN_NAME_GV
14348
14349 =cut
14350 */
14351
14352 /* shared by toke.c:yylex */
14353 CV *
Perl_find_lexical_cv(pTHX_ PADOFFSET off)14354 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
14355 {
14356 PADNAME *name = PAD_COMPNAME(off);
14357 CV *compcv = PL_compcv;
14358 while (PadnameOUTER(name)) {
14359 assert(PARENT_PAD_INDEX(name));
14360 compcv = CvOUTSIDE(compcv);
14361 name = PadlistNAMESARRAY(CvPADLIST(compcv))
14362 [off = PARENT_PAD_INDEX(name)];
14363 }
14364 assert(!PadnameIsOUR(name));
14365 if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
14366 return PadnamePROTOCV(name);
14367 }
14368 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
14369 }
14370
14371 CV *
Perl_rv2cv_op_cv(pTHX_ OP * cvop,U32 flags)14372 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
14373 {
14374 OP *rvop;
14375 CV *cv;
14376 GV *gv;
14377 PERL_ARGS_ASSERT_RV2CV_OP_CV;
14378 if (flags & ~RV2CVOPCV_FLAG_MASK)
14379 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
14380 if (cvop->op_type != OP_RV2CV)
14381 return NULL;
14382 if (cvop->op_private & OPpENTERSUB_AMPER)
14383 return NULL;
14384 if (!(cvop->op_flags & OPf_KIDS))
14385 return NULL;
14386 rvop = cUNOPx(cvop)->op_first;
14387 switch (rvop->op_type) {
14388 case OP_GV: {
14389 gv = cGVOPx_gv(rvop);
14390 if (!isGV(gv)) {
14391 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
14392 cv = MUTABLE_CV(SvRV(gv));
14393 gv = NULL;
14394 break;
14395 }
14396 if (flags & RV2CVOPCV_RETURN_STUB)
14397 return (CV *)gv;
14398 else return NULL;
14399 }
14400 cv = GvCVu(gv);
14401 if (!cv) {
14402 if (flags & RV2CVOPCV_MARK_EARLY)
14403 rvop->op_private |= OPpEARLY_CV;
14404 return NULL;
14405 }
14406 } break;
14407 case OP_CONST: {
14408 SV *rv = cSVOPx_sv(rvop);
14409 if (!SvROK(rv))
14410 return NULL;
14411 cv = (CV*)SvRV(rv);
14412 gv = NULL;
14413 } break;
14414 case OP_PADCV: {
14415 cv = find_lexical_cv(rvop->op_targ);
14416 gv = NULL;
14417 } break;
14418 default: {
14419 return NULL;
14420 } NOT_REACHED; /* NOTREACHED */
14421 }
14422 if (SvTYPE((SV*)cv) != SVt_PVCV)
14423 return NULL;
14424 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
14425 if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
14426 gv = CvGV(cv);
14427 return (CV*)gv;
14428 }
14429 else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
14430 if (CvLEXICAL(cv) || CvNAMED(cv))
14431 return NULL;
14432 if (!CvANON(cv) || !gv)
14433 gv = CvGV(cv);
14434 return (CV*)gv;
14435
14436 } else {
14437 return cv;
14438 }
14439 }
14440
14441 /*
14442 =for apidoc ck_entersub_args_list
14443
14444 Performs the default fixup of the arguments part of an C<entersub>
14445 op tree. This consists of applying list context to each of the
14446 argument ops. This is the standard treatment used on a call marked
14447 with C<&>, or a method call, or a call through a subroutine reference,
14448 or any other call where the callee can't be identified at compile time,
14449 or a call where the callee has no prototype.
14450
14451 =cut
14452 */
14453
14454 OP *
Perl_ck_entersub_args_list(pTHX_ OP * entersubop)14455 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
14456 {
14457 OP *aop;
14458
14459 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
14460
14461 aop = cUNOPx(entersubop)->op_first;
14462 if (!OpHAS_SIBLING(aop))
14463 aop = cUNOPx(aop)->op_first;
14464 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
14465 /* skip the extra attributes->import() call implicitly added in
14466 * something like foo(my $x : bar)
14467 */
14468 if ( aop->op_type == OP_ENTERSUB
14469 && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
14470 )
14471 continue;
14472 list(aop);
14473 op_lvalue(aop, OP_ENTERSUB);
14474 }
14475 return entersubop;
14476 }
14477
14478 /*
14479 =for apidoc ck_entersub_args_proto
14480
14481 Performs the fixup of the arguments part of an C<entersub> op tree
14482 based on a subroutine prototype. This makes various modifications to
14483 the argument ops, from applying context up to inserting C<refgen> ops,
14484 and checking the number and syntactic types of arguments, as directed by
14485 the prototype. This is the standard treatment used on a subroutine call,
14486 not marked with C<&>, where the callee can be identified at compile time
14487 and has a prototype.
14488
14489 C<protosv> supplies the subroutine prototype to be applied to the call.
14490 It may be a normal defined scalar, of which the string value will be used.
14491 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
14492 that has been cast to C<SV*>) which has a prototype. The prototype
14493 supplied, in whichever form, does not need to match the actual callee
14494 referenced by the op tree.
14495
14496 If the argument ops disagree with the prototype, for example by having
14497 an unacceptable number of arguments, a valid op tree is returned anyway.
14498 The error is reflected in the parser state, normally resulting in a single
14499 exception at the top level of parsing which covers all the compilation
14500 errors that occurred. In the error message, the callee is referred to
14501 by the name defined by the C<namegv> parameter.
14502
14503 =cut
14504 */
14505
14506 OP *
Perl_ck_entersub_args_proto(pTHX_ OP * entersubop,GV * namegv,SV * protosv)14507 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
14508 {
14509 STRLEN proto_len;
14510 const char *proto, *proto_end;
14511 OP *aop, *prev, *cvop, *parent;
14512 int optional = 0;
14513 I32 arg = 0;
14514 I32 contextclass = 0;
14515 const char *e = NULL;
14516 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
14517 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
14518 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
14519 "flags=%lx", (unsigned long) SvFLAGS(protosv));
14520 if (SvTYPE(protosv) == SVt_PVCV)
14521 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
14522 else proto = SvPV(protosv, proto_len);
14523 proto = S_strip_spaces(aTHX_ proto, &proto_len);
14524 proto_end = proto + proto_len;
14525 parent = entersubop;
14526 aop = cUNOPx(entersubop)->op_first;
14527 if (!OpHAS_SIBLING(aop)) {
14528 parent = aop;
14529 aop = cUNOPx(aop)->op_first;
14530 }
14531 prev = aop;
14532 aop = OpSIBLING(aop);
14533 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14534 while (aop != cvop) {
14535 OP* o3 = aop;
14536
14537 if (proto >= proto_end)
14538 {
14539 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
14540 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14541 SVfARG(namesv)), SvUTF8(namesv));
14542 return entersubop;
14543 }
14544
14545 switch (*proto) {
14546 case ';':
14547 optional = 1;
14548 proto++;
14549 continue;
14550 case '_':
14551 /* _ must be at the end */
14552 if (proto[1] && !memCHRs(";@%", proto[1]))
14553 goto oops;
14554 /* FALLTHROUGH */
14555 case '$':
14556 proto++;
14557 arg++;
14558 scalar(aop);
14559 break;
14560 case '%':
14561 case '@':
14562 list(aop);
14563 arg++;
14564 break;
14565 case '&':
14566 proto++;
14567 arg++;
14568 if ( o3->op_type != OP_UNDEF
14569 && (o3->op_type != OP_SREFGEN
14570 || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
14571 != OP_ANONCODE
14572 && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
14573 != OP_RV2CV)))
14574 bad_type_gv(arg, namegv, o3,
14575 arg == 1 ? "block or sub {}" : "sub {}");
14576 break;
14577 case '*':
14578 /* '*' allows any scalar type, including bareword */
14579 proto++;
14580 arg++;
14581 if (o3->op_type == OP_RV2GV)
14582 goto wrapref; /* autoconvert GLOB -> GLOBref */
14583 else if (o3->op_type == OP_CONST)
14584 o3->op_private &= ~OPpCONST_STRICT;
14585 scalar(aop);
14586 break;
14587 case '+':
14588 proto++;
14589 arg++;
14590 if (o3->op_type == OP_RV2AV ||
14591 o3->op_type == OP_PADAV ||
14592 o3->op_type == OP_RV2HV ||
14593 o3->op_type == OP_PADHV
14594 ) {
14595 goto wrapref;
14596 }
14597 scalar(aop);
14598 break;
14599 case '[': case ']':
14600 goto oops;
14601
14602 case '\\':
14603 proto++;
14604 arg++;
14605 again:
14606 switch (*proto++) {
14607 case '[':
14608 if (contextclass++ == 0) {
14609 e = (char *) memchr(proto, ']', proto_end - proto);
14610 if (!e || e == proto)
14611 goto oops;
14612 }
14613 else
14614 goto oops;
14615 goto again;
14616
14617 case ']':
14618 if (contextclass) {
14619 const char *p = proto;
14620 const char *const end = proto;
14621 contextclass = 0;
14622 while (*--p != '[')
14623 /* \[$] accepts any scalar lvalue */
14624 if (*p == '$'
14625 && Perl_op_lvalue_flags(aTHX_
14626 scalar(o3),
14627 OP_READ, /* not entersub */
14628 OP_LVALUE_NO_CROAK
14629 )) goto wrapref;
14630 bad_type_gv(arg, namegv, o3,
14631 Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
14632 } else
14633 goto oops;
14634 break;
14635 case '*':
14636 if (o3->op_type == OP_RV2GV)
14637 goto wrapref;
14638 if (!contextclass)
14639 bad_type_gv(arg, namegv, o3, "symbol");
14640 break;
14641 case '&':
14642 if (o3->op_type == OP_ENTERSUB
14643 && !(o3->op_flags & OPf_STACKED))
14644 goto wrapref;
14645 if (!contextclass)
14646 bad_type_gv(arg, namegv, o3, "subroutine");
14647 break;
14648 case '$':
14649 if (o3->op_type == OP_RV2SV ||
14650 o3->op_type == OP_PADSV ||
14651 o3->op_type == OP_HELEM ||
14652 o3->op_type == OP_AELEM)
14653 goto wrapref;
14654 if (!contextclass) {
14655 /* \$ accepts any scalar lvalue */
14656 if (Perl_op_lvalue_flags(aTHX_
14657 scalar(o3),
14658 OP_READ, /* not entersub */
14659 OP_LVALUE_NO_CROAK
14660 )) goto wrapref;
14661 bad_type_gv(arg, namegv, o3, "scalar");
14662 }
14663 break;
14664 case '@':
14665 if (o3->op_type == OP_RV2AV ||
14666 o3->op_type == OP_PADAV)
14667 {
14668 o3->op_flags &=~ OPf_PARENS;
14669 goto wrapref;
14670 }
14671 if (!contextclass)
14672 bad_type_gv(arg, namegv, o3, "array");
14673 break;
14674 case '%':
14675 if (o3->op_type == OP_RV2HV ||
14676 o3->op_type == OP_PADHV)
14677 {
14678 o3->op_flags &=~ OPf_PARENS;
14679 goto wrapref;
14680 }
14681 if (!contextclass)
14682 bad_type_gv(arg, namegv, o3, "hash");
14683 break;
14684 wrapref:
14685 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
14686 OP_REFGEN, 0);
14687 if (contextclass && e) {
14688 proto = e + 1;
14689 contextclass = 0;
14690 }
14691 break;
14692 default: goto oops;
14693 }
14694 if (contextclass)
14695 goto again;
14696 break;
14697 case ' ':
14698 proto++;
14699 continue;
14700 default:
14701 oops: {
14702 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
14703 SVfARG(cv_name((CV *)namegv, NULL, 0)),
14704 SVfARG(protosv));
14705 }
14706 }
14707
14708 op_lvalue(aop, OP_ENTERSUB);
14709 prev = aop;
14710 aop = OpSIBLING(aop);
14711 }
14712 if (aop == cvop && *proto == '_') {
14713 /* generate an access to $_ */
14714 op_sibling_splice(parent, prev, 0, newDEFSVOP());
14715 }
14716 if (!optional && proto_end > proto &&
14717 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
14718 {
14719 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
14720 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
14721 SVfARG(namesv)), SvUTF8(namesv));
14722 }
14723 return entersubop;
14724 }
14725
14726 /*
14727 =for apidoc ck_entersub_args_proto_or_list
14728
14729 Performs the fixup of the arguments part of an C<entersub> op tree either
14730 based on a subroutine prototype or using default list-context processing.
14731 This is the standard treatment used on a subroutine call, not marked
14732 with C<&>, where the callee can be identified at compile time.
14733
14734 C<protosv> supplies the subroutine prototype to be applied to the call,
14735 or indicates that there is no prototype. It may be a normal scalar,
14736 in which case if it is defined then the string value will be used
14737 as a prototype, and if it is undefined then there is no prototype.
14738 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
14739 that has been cast to C<SV*>), of which the prototype will be used if it
14740 has one. The prototype (or lack thereof) supplied, in whichever form,
14741 does not need to match the actual callee referenced by the op tree.
14742
14743 If the argument ops disagree with the prototype, for example by having
14744 an unacceptable number of arguments, a valid op tree is returned anyway.
14745 The error is reflected in the parser state, normally resulting in a single
14746 exception at the top level of parsing which covers all the compilation
14747 errors that occurred. In the error message, the callee is referred to
14748 by the name defined by the C<namegv> parameter.
14749
14750 =cut
14751 */
14752
14753 OP *
Perl_ck_entersub_args_proto_or_list(pTHX_ OP * entersubop,GV * namegv,SV * protosv)14754 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
14755 GV *namegv, SV *protosv)
14756 {
14757 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
14758 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
14759 return ck_entersub_args_proto(entersubop, namegv, protosv);
14760 else
14761 return ck_entersub_args_list(entersubop);
14762 }
14763
14764 OP *
Perl_ck_entersub_args_core(pTHX_ OP * entersubop,GV * namegv,SV * protosv)14765 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
14766 {
14767 IV cvflags = SvIVX(protosv);
14768 int opnum = cvflags & 0xffff;
14769 OP *aop = cUNOPx(entersubop)->op_first;
14770
14771 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
14772
14773 if (!opnum) {
14774 OP *cvop;
14775 if (!OpHAS_SIBLING(aop))
14776 aop = cUNOPx(aop)->op_first;
14777 aop = OpSIBLING(aop);
14778 for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14779 if (aop != cvop) {
14780 SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
14781 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14782 SVfARG(namesv)), SvUTF8(namesv));
14783 }
14784
14785 op_free(entersubop);
14786 switch(cvflags >> 16) {
14787 case 'F': return newSVOP(OP_CONST, 0,
14788 newSVpv(CopFILE(PL_curcop),0));
14789 case 'L': return newSVOP(
14790 OP_CONST, 0,
14791 Perl_newSVpvf(aTHX_
14792 "%" IVdf, (IV)CopLINE(PL_curcop)
14793 )
14794 );
14795 case 'P': return newSVOP(OP_CONST, 0,
14796 (PL_curstash
14797 ? newSVhek(HvNAME_HEK(PL_curstash))
14798 : &PL_sv_undef
14799 )
14800 );
14801 }
14802 NOT_REACHED; /* NOTREACHED */
14803 }
14804 else {
14805 OP *prev, *cvop, *first, *parent;
14806 U32 flags = 0;
14807
14808 parent = entersubop;
14809 if (!OpHAS_SIBLING(aop)) {
14810 parent = aop;
14811 aop = cUNOPx(aop)->op_first;
14812 }
14813
14814 first = prev = aop;
14815 aop = OpSIBLING(aop);
14816 /* find last sibling */
14817 for (cvop = aop;
14818 OpHAS_SIBLING(cvop);
14819 prev = cvop, cvop = OpSIBLING(cvop))
14820 ;
14821 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
14822 /* Usually, OPf_SPECIAL on an op with no args means that it had
14823 * parens, but these have their own meaning for that flag: */
14824 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
14825 && opnum != OP_DELETE && opnum != OP_EXISTS)
14826 flags |= OPf_SPECIAL;
14827 /* excise cvop from end of sibling chain */
14828 op_sibling_splice(parent, prev, 1, NULL);
14829 op_free(cvop);
14830 if (aop == cvop) aop = NULL;
14831
14832 /* detach remaining siblings from the first sibling, then
14833 * dispose of original optree */
14834
14835 if (aop)
14836 op_sibling_splice(parent, first, -1, NULL);
14837 op_free(entersubop);
14838
14839 if (cvflags == (OP_ENTEREVAL | (1<<16)))
14840 flags |= OPpEVAL_BYTES <<8;
14841
14842 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
14843 case OA_UNOP:
14844 case OA_BASEOP_OR_UNOP:
14845 case OA_FILESTATOP:
14846 if (!aop)
14847 return newOP(opnum,flags); /* zero args */
14848 if (aop == prev)
14849 return newUNOP(opnum,flags,aop); /* one arg */
14850 /* too many args */
14851 /* FALLTHROUGH */
14852 case OA_BASEOP:
14853 if (aop) {
14854 SV *namesv;
14855 OP *nextop;
14856
14857 namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
14858 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14859 SVfARG(namesv)), SvUTF8(namesv));
14860 while (aop) {
14861 nextop = OpSIBLING(aop);
14862 op_free(aop);
14863 aop = nextop;
14864 }
14865
14866 }
14867 return opnum == OP_RUNCV
14868 ? newPVOP(OP_RUNCV,0,NULL)
14869 : newOP(opnum,0);
14870 default:
14871 return op_convert_list(opnum,0,aop);
14872 }
14873 }
14874 NOT_REACHED; /* NOTREACHED */
14875 return entersubop;
14876 }
14877
14878 /*
14879 =for apidoc cv_get_call_checker_flags
14880
14881 Retrieves the function that will be used to fix up a call to C<cv>.
14882 Specifically, the function is applied to an C<entersub> op tree for a
14883 subroutine call, not marked with C<&>, where the callee can be identified
14884 at compile time as C<cv>.
14885
14886 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
14887 for it is returned in C<*ckobj_p>, and control flags are returned in
14888 C<*ckflags_p>. The function is intended to be called in this manner:
14889
14890 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
14891
14892 In this call, C<entersubop> is a pointer to the C<entersub> op,
14893 which may be replaced by the check function, and C<namegv> supplies
14894 the name that should be used by the check function to refer
14895 to the callee of the C<entersub> op if it needs to emit any diagnostics.
14896 It is permitted to apply the check function in non-standard situations,
14897 such as to a call to a different subroutine or to a method call.
14898
14899 C<namegv> may not actually be a GV. If the C<CALL_CHECKER_REQUIRE_GV>
14900 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
14901 instead, anything that can be used as the first argument to L</cv_name>.
14902 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
14903 check function requires C<namegv> to be a genuine GV.
14904
14905 By default, the check function is
14906 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
14907 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
14908 flag is clear. This implements standard prototype processing. It can
14909 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
14910
14911 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
14912 indicates that the caller only knows about the genuine GV version of
14913 C<namegv>, and accordingly the corresponding bit will always be set in
14914 C<*ckflags_p>, regardless of the check function's recorded requirements.
14915 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
14916 indicates the caller knows about the possibility of passing something
14917 other than a GV as C<namegv>, and accordingly the corresponding bit may
14918 be either set or clear in C<*ckflags_p>, indicating the check function's
14919 recorded requirements.
14920
14921 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
14922 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
14923 (for which see above). All other bits should be clear.
14924
14925 =for apidoc Amnh||CALL_CHECKER_REQUIRE_GV
14926
14927 =for apidoc cv_get_call_checker
14928
14929 The original form of L</cv_get_call_checker_flags>, which does not return
14930 checker flags. When using a checker function returned by this function,
14931 it is only safe to call it with a genuine GV as its C<namegv> argument.
14932
14933 =cut
14934 */
14935
14936 void
Perl_cv_get_call_checker_flags(pTHX_ CV * cv,U32 gflags,Perl_call_checker * ckfun_p,SV ** ckobj_p,U32 * ckflags_p)14937 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
14938 Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
14939 {
14940 MAGIC *callmg;
14941 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
14942 PERL_UNUSED_CONTEXT;
14943 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
14944 if (callmg) {
14945 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
14946 *ckobj_p = callmg->mg_obj;
14947 *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
14948 } else {
14949 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
14950 *ckobj_p = (SV*)cv;
14951 *ckflags_p = gflags & MGf_REQUIRE_GV;
14952 }
14953 }
14954
14955 void
Perl_cv_get_call_checker(pTHX_ CV * cv,Perl_call_checker * ckfun_p,SV ** ckobj_p)14956 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
14957 {
14958 U32 ckflags;
14959 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
14960 PERL_UNUSED_CONTEXT;
14961 cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
14962 &ckflags);
14963 }
14964
14965 /*
14966 =for apidoc cv_set_call_checker_flags
14967
14968 Sets the function that will be used to fix up a call to C<cv>.
14969 Specifically, the function is applied to an C<entersub> op tree for a
14970 subroutine call, not marked with C<&>, where the callee can be identified
14971 at compile time as C<cv>.
14972
14973 The C-level function pointer is supplied in C<ckfun>, an SV argument for
14974 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
14975 The function should be defined like this:
14976
14977 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
14978
14979 It is intended to be called in this manner:
14980
14981 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
14982
14983 In this call, C<entersubop> is a pointer to the C<entersub> op,
14984 which may be replaced by the check function, and C<namegv> supplies
14985 the name that should be used by the check function to refer
14986 to the callee of the C<entersub> op if it needs to emit any diagnostics.
14987 It is permitted to apply the check function in non-standard situations,
14988 such as to a call to a different subroutine or to a method call.
14989
14990 C<namegv> may not actually be a GV. For efficiency, perl may pass a
14991 CV or other SV instead. Whatever is passed can be used as the first
14992 argument to L</cv_name>. You can force perl to pass a GV by including
14993 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
14994
14995 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
14996 bit currently has a defined meaning (for which see above). All other
14997 bits should be clear.
14998
14999 The current setting for a particular CV can be retrieved by
15000 L</cv_get_call_checker_flags>.
15001
15002 =for apidoc cv_set_call_checker
15003
15004 The original form of L</cv_set_call_checker_flags>, which passes it the
15005 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility. The effect
15006 of that flag setting is that the check function is guaranteed to get a
15007 genuine GV as its C<namegv> argument.
15008
15009 =cut
15010 */
15011
15012 void
Perl_cv_set_call_checker(pTHX_ CV * cv,Perl_call_checker ckfun,SV * ckobj)15013 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
15014 {
15015 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
15016 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
15017 }
15018
15019 void
Perl_cv_set_call_checker_flags(pTHX_ CV * cv,Perl_call_checker ckfun,SV * ckobj,U32 ckflags)15020 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
15021 SV *ckobj, U32 ckflags)
15022 {
15023 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
15024 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
15025 if (SvMAGICAL((SV*)cv))
15026 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
15027 } else {
15028 MAGIC *callmg;
15029 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
15030 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
15031 assert(callmg);
15032 if (callmg->mg_flags & MGf_REFCOUNTED) {
15033 SvREFCNT_dec(callmg->mg_obj);
15034 callmg->mg_flags &= ~MGf_REFCOUNTED;
15035 }
15036 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
15037 callmg->mg_obj = ckobj;
15038 if (ckobj != (SV*)cv) {
15039 SvREFCNT_inc_simple_void_NN(ckobj);
15040 callmg->mg_flags |= MGf_REFCOUNTED;
15041 }
15042 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
15043 | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
15044 }
15045 }
15046
15047 static void
S_entersub_alloc_targ(pTHX_ OP * const o)15048 S_entersub_alloc_targ(pTHX_ OP * const o)
15049 {
15050 o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
15051 o->op_private |= OPpENTERSUB_HASTARG;
15052 }
15053
15054 OP *
Perl_ck_subr(pTHX_ OP * o)15055 Perl_ck_subr(pTHX_ OP *o)
15056 {
15057 OP *aop, *cvop;
15058 CV *cv;
15059 GV *namegv;
15060 SV **const_class = NULL;
15061
15062 PERL_ARGS_ASSERT_CK_SUBR;
15063
15064 aop = cUNOPx(o)->op_first;
15065 if (!OpHAS_SIBLING(aop))
15066 aop = cUNOPx(aop)->op_first;
15067 aop = OpSIBLING(aop);
15068 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
15069 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
15070 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
15071
15072 o->op_private &= ~1;
15073 o->op_private |= (PL_hints & HINT_STRICT_REFS);
15074 if (PERLDB_SUB && PL_curstash != PL_debstash)
15075 o->op_private |= OPpENTERSUB_DB;
15076 switch (cvop->op_type) {
15077 case OP_RV2CV:
15078 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
15079 op_null(cvop);
15080 break;
15081 case OP_METHOD:
15082 case OP_METHOD_NAMED:
15083 case OP_METHOD_SUPER:
15084 case OP_METHOD_REDIR:
15085 case OP_METHOD_REDIR_SUPER:
15086 o->op_flags |= OPf_REF;
15087 if (aop->op_type == OP_CONST) {
15088 aop->op_private &= ~OPpCONST_STRICT;
15089 const_class = &cSVOPx(aop)->op_sv;
15090 }
15091 else if (aop->op_type == OP_LIST) {
15092 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
15093 if (sib && sib->op_type == OP_CONST) {
15094 sib->op_private &= ~OPpCONST_STRICT;
15095 const_class = &cSVOPx(sib)->op_sv;
15096 }
15097 }
15098 /* make class name a shared cow string to speedup method calls */
15099 /* constant string might be replaced with object, f.e. bigint */
15100 if (const_class && SvPOK(*const_class)) {
15101 STRLEN len;
15102 const char* str = SvPV(*const_class, len);
15103 if (len) {
15104 SV* const shared = newSVpvn_share(
15105 str, SvUTF8(*const_class)
15106 ? -(SSize_t)len : (SSize_t)len,
15107 0
15108 );
15109 if (SvREADONLY(*const_class))
15110 SvREADONLY_on(shared);
15111 SvREFCNT_dec(*const_class);
15112 *const_class = shared;
15113 }
15114 }
15115 break;
15116 }
15117
15118 if (!cv) {
15119 S_entersub_alloc_targ(aTHX_ o);
15120 return ck_entersub_args_list(o);
15121 } else {
15122 Perl_call_checker ckfun;
15123 SV *ckobj;
15124 U32 ckflags;
15125 cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
15126 if (CvISXSUB(cv) || !CvROOT(cv))
15127 S_entersub_alloc_targ(aTHX_ o);
15128 if (!namegv) {
15129 /* The original call checker API guarantees that a GV will
15130 be provided with the right name. So, if the old API was
15131 used (or the REQUIRE_GV flag was passed), we have to reify
15132 the CV’s GV, unless this is an anonymous sub. This is not
15133 ideal for lexical subs, as its stringification will include
15134 the package. But it is the best we can do. */
15135 if (ckflags & CALL_CHECKER_REQUIRE_GV) {
15136 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
15137 namegv = CvGV(cv);
15138 }
15139 else namegv = MUTABLE_GV(cv);
15140 /* After a syntax error in a lexical sub, the cv that
15141 rv2cv_op_cv returns may be a nameless stub. */
15142 if (!namegv) return ck_entersub_args_list(o);
15143
15144 }
15145 return ckfun(aTHX_ o, namegv, ckobj);
15146 }
15147 }
15148
15149 OP *
Perl_ck_svconst(pTHX_ OP * o)15150 Perl_ck_svconst(pTHX_ OP *o)
15151 {
15152 SV * const sv = cSVOPo->op_sv;
15153 PERL_ARGS_ASSERT_CK_SVCONST;
15154 PERL_UNUSED_CONTEXT;
15155 #ifdef PERL_COPY_ON_WRITE
15156 /* Since the read-only flag may be used to protect a string buffer, we
15157 cannot do copy-on-write with existing read-only scalars that are not
15158 already copy-on-write scalars. To allow $_ = "hello" to do COW with
15159 that constant, mark the constant as COWable here, if it is not
15160 already read-only. */
15161 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
15162 SvIsCOW_on(sv);
15163 CowREFCNT(sv) = 0;
15164 # ifdef PERL_DEBUG_READONLY_COW
15165 sv_buf_to_ro(sv);
15166 # endif
15167 }
15168 #endif
15169 SvREADONLY_on(sv);
15170 return o;
15171 }
15172
15173 OP *
Perl_ck_trunc(pTHX_ OP * o)15174 Perl_ck_trunc(pTHX_ OP *o)
15175 {
15176 PERL_ARGS_ASSERT_CK_TRUNC;
15177
15178 if (o->op_flags & OPf_KIDS) {
15179 SVOP *kid = (SVOP*)cUNOPo->op_first;
15180
15181 if (kid->op_type == OP_NULL)
15182 kid = (SVOP*)OpSIBLING(kid);
15183 if (kid && kid->op_type == OP_CONST &&
15184 (kid->op_private & OPpCONST_BARE) &&
15185 !kid->op_folded)
15186 {
15187 o->op_flags |= OPf_SPECIAL;
15188 kid->op_private &= ~OPpCONST_STRICT;
15189 }
15190 }
15191 return ck_fun(o);
15192 }
15193
15194 OP *
Perl_ck_substr(pTHX_ OP * o)15195 Perl_ck_substr(pTHX_ OP *o)
15196 {
15197 PERL_ARGS_ASSERT_CK_SUBSTR;
15198
15199 o = ck_fun(o);
15200 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
15201 OP *kid = cLISTOPo->op_first;
15202
15203 if (kid->op_type == OP_NULL)
15204 kid = OpSIBLING(kid);
15205 if (kid)
15206 /* Historically, substr(delete $foo{bar},...) has been allowed
15207 with 4-arg substr. Keep it working by applying entersub
15208 lvalue context. */
15209 op_lvalue(kid, OP_ENTERSUB);
15210
15211 }
15212 return o;
15213 }
15214
15215 OP *
Perl_ck_tell(pTHX_ OP * o)15216 Perl_ck_tell(pTHX_ OP *o)
15217 {
15218 PERL_ARGS_ASSERT_CK_TELL;
15219 o = ck_fun(o);
15220 if (o->op_flags & OPf_KIDS) {
15221 OP *kid = cLISTOPo->op_first;
15222 if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
15223 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
15224 }
15225 return o;
15226 }
15227
15228 OP *
Perl_ck_each(pTHX_ OP * o)15229 Perl_ck_each(pTHX_ OP *o)
15230 {
15231 dVAR;
15232 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
15233 const unsigned orig_type = o->op_type;
15234
15235 PERL_ARGS_ASSERT_CK_EACH;
15236
15237 if (kid) {
15238 switch (kid->op_type) {
15239 case OP_PADHV:
15240 case OP_RV2HV:
15241 break;
15242 case OP_PADAV:
15243 case OP_RV2AV:
15244 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
15245 : orig_type == OP_KEYS ? OP_AKEYS
15246 : OP_AVALUES);
15247 break;
15248 case OP_CONST:
15249 if (kid->op_private == OPpCONST_BARE
15250 || !SvROK(cSVOPx_sv(kid))
15251 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
15252 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
15253 )
15254 goto bad;
15255 /* FALLTHROUGH */
15256 default:
15257 qerror(Perl_mess(aTHX_
15258 "Experimental %s on scalar is now forbidden",
15259 PL_op_desc[orig_type]));
15260 bad:
15261 bad_type_pv(1, "hash or array", o, kid);
15262 return o;
15263 }
15264 }
15265 return ck_fun(o);
15266 }
15267
15268 OP *
Perl_ck_length(pTHX_ OP * o)15269 Perl_ck_length(pTHX_ OP *o)
15270 {
15271 PERL_ARGS_ASSERT_CK_LENGTH;
15272
15273 o = ck_fun(o);
15274
15275 if (ckWARN(WARN_SYNTAX)) {
15276 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
15277
15278 if (kid) {
15279 SV *name = NULL;
15280 const bool hash = kid->op_type == OP_PADHV
15281 || kid->op_type == OP_RV2HV;
15282 switch (kid->op_type) {
15283 case OP_PADHV:
15284 case OP_PADAV:
15285 case OP_RV2HV:
15286 case OP_RV2AV:
15287 name = S_op_varname(aTHX_ kid);
15288 break;
15289 default:
15290 return o;
15291 }
15292 if (name)
15293 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
15294 "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
15295 ")\"?)",
15296 SVfARG(name), hash ? "keys " : "", SVfARG(name)
15297 );
15298 else if (hash)
15299 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
15300 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
15301 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
15302 else
15303 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
15304 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
15305 "length() used on @array (did you mean \"scalar(@array)\"?)");
15306 }
15307 }
15308
15309 return o;
15310 }
15311
15312
15313 OP *
Perl_ck_isa(pTHX_ OP * o)15314 Perl_ck_isa(pTHX_ OP *o)
15315 {
15316 OP *classop = cBINOPo->op_last;
15317
15318 PERL_ARGS_ASSERT_CK_ISA;
15319
15320 /* Convert barename into PV */
15321 if(classop->op_type == OP_CONST && classop->op_private & OPpCONST_BARE) {
15322 /* TODO: Optionally convert package to raw HV here */
15323 classop->op_private &= ~(OPpCONST_BARE|OPpCONST_STRICT);
15324 }
15325
15326 return o;
15327 }
15328
15329
15330 /*
15331 ---------------------------------------------------------
15332
15333 Common vars in list assignment
15334
15335 There now follows some enums and static functions for detecting
15336 common variables in list assignments. Here is a little essay I wrote
15337 for myself when trying to get my head around this. DAPM.
15338
15339 ----
15340
15341 First some random observations:
15342
15343 * If a lexical var is an alias of something else, e.g.
15344 for my $x ($lex, $pkg, $a[0]) {...}
15345 then the act of aliasing will increase the reference count of the SV
15346
15347 * If a package var is an alias of something else, it may still have a
15348 reference count of 1, depending on how the alias was created, e.g.
15349 in *a = *b, $a may have a refcount of 1 since the GP is shared
15350 with a single GvSV pointer to the SV. So If it's an alias of another
15351 package var, then RC may be 1; if it's an alias of another scalar, e.g.
15352 a lexical var or an array element, then it will have RC > 1.
15353
15354 * There are many ways to create a package alias; ultimately, XS code
15355 may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
15356 run-time tracing mechanisms are unlikely to be able to catch all cases.
15357
15358 * When the LHS is all my declarations, the same vars can't appear directly
15359 on the RHS, but they can indirectly via closures, aliasing and lvalue
15360 subs. But those techniques all involve an increase in the lexical
15361 scalar's ref count.
15362
15363 * When the LHS is all lexical vars (but not necessarily my declarations),
15364 it is possible for the same lexicals to appear directly on the RHS, and
15365 without an increased ref count, since the stack isn't refcounted.
15366 This case can be detected at compile time by scanning for common lex
15367 vars with PL_generation.
15368
15369 * lvalue subs defeat common var detection, but they do at least
15370 return vars with a temporary ref count increment. Also, you can't
15371 tell at compile time whether a sub call is lvalue.
15372
15373
15374 So...
15375
15376 A: There are a few circumstances where there definitely can't be any
15377 commonality:
15378
15379 LHS empty: () = (...);
15380 RHS empty: (....) = ();
15381 RHS contains only constants or other 'can't possibly be shared'
15382 elements (e.g. ops that return PADTMPs): (...) = (1,2, length)
15383 i.e. they only contain ops not marked as dangerous, whose children
15384 are also not dangerous;
15385 LHS ditto;
15386 LHS contains a single scalar element: e.g. ($x) = (....); because
15387 after $x has been modified, it won't be used again on the RHS;
15388 RHS contains a single element with no aggregate on LHS: e.g.
15389 ($a,$b,$c) = ($x); again, once $a has been modified, its value
15390 won't be used again.
15391
15392 B: If LHS are all 'my' lexical var declarations (or safe ops, which
15393 we can ignore):
15394
15395 my ($a, $b, @c) = ...;
15396
15397 Due to closure and goto tricks, these vars may already have content.
15398 For the same reason, an element on the RHS may be a lexical or package
15399 alias of one of the vars on the left, or share common elements, for
15400 example:
15401
15402 my ($x,$y) = f(); # $x and $y on both sides
15403 sub f : lvalue { ($x,$y) = (1,2); $y, $x }
15404
15405 and
15406
15407 my $ra = f();
15408 my @a = @$ra; # elements of @a on both sides
15409 sub f { @a = 1..4; \@a }
15410
15411
15412 First, just consider scalar vars on LHS:
15413
15414 RHS is safe only if (A), or in addition,
15415 * contains only lexical *scalar* vars, where neither side's
15416 lexicals have been flagged as aliases
15417
15418 If RHS is not safe, then it's always legal to check LHS vars for
15419 RC==1, since the only RHS aliases will always be associated
15420 with an RC bump.
15421
15422 Note that in particular, RHS is not safe if:
15423
15424 * it contains package scalar vars; e.g.:
15425
15426 f();
15427 my ($x, $y) = (2, $x_alias);
15428 sub f { $x = 1; *x_alias = \$x; }
15429
15430 * It contains other general elements, such as flattened or
15431 * spliced or single array or hash elements, e.g.
15432
15433 f();
15434 my ($x,$y) = @a; # or $a[0] or @a{@b} etc
15435
15436 sub f {
15437 ($x, $y) = (1,2);
15438 use feature 'refaliasing';
15439 \($a[0], $a[1]) = \($y,$x);
15440 }
15441
15442 It doesn't matter if the array/hash is lexical or package.
15443
15444 * it contains a function call that happens to be an lvalue
15445 sub which returns one or more of the above, e.g.
15446
15447 f();
15448 my ($x,$y) = f();
15449
15450 sub f : lvalue {
15451 ($x, $y) = (1,2);
15452 *x1 = \$x;
15453 $y, $x1;
15454 }
15455
15456 (so a sub call on the RHS should be treated the same
15457 as having a package var on the RHS).
15458
15459 * any other "dangerous" thing, such an op or built-in that
15460 returns one of the above, e.g. pp_preinc
15461
15462
15463 If RHS is not safe, what we can do however is at compile time flag
15464 that the LHS are all my declarations, and at run time check whether
15465 all the LHS have RC == 1, and if so skip the full scan.
15466
15467 Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
15468
15469 Here the issue is whether there can be elements of @a on the RHS
15470 which will get prematurely freed when @a is cleared prior to
15471 assignment. This is only a problem if the aliasing mechanism
15472 is one which doesn't increase the refcount - only if RC == 1
15473 will the RHS element be prematurely freed.
15474
15475 Because the array/hash is being INTROed, it or its elements
15476 can't directly appear on the RHS:
15477
15478 my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
15479
15480 but can indirectly, e.g.:
15481
15482 my $r = f();
15483 my (@a) = @$r;
15484 sub f { @a = 1..3; \@a }
15485
15486 So if the RHS isn't safe as defined by (A), we must always
15487 mortalise and bump the ref count of any remaining RHS elements
15488 when assigning to a non-empty LHS aggregate.
15489
15490 Lexical scalars on the RHS aren't safe if they've been involved in
15491 aliasing, e.g.
15492
15493 use feature 'refaliasing';
15494
15495 f();
15496 \(my $lex) = \$pkg;
15497 my @a = ($lex,3); # equivalent to ($a[0],3)
15498
15499 sub f {
15500 @a = (1,2);
15501 \$pkg = \$a[0];
15502 }
15503
15504 Similarly with lexical arrays and hashes on the RHS:
15505
15506 f();
15507 my @b;
15508 my @a = (@b);
15509
15510 sub f {
15511 @a = (1,2);
15512 \$b[0] = \$a[1];
15513 \$b[1] = \$a[0];
15514 }
15515
15516
15517
15518 C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
15519 my $a; ($a, my $b) = (....);
15520
15521 The difference between (B) and (C) is that it is now physically
15522 possible for the LHS vars to appear on the RHS too, where they
15523 are not reference counted; but in this case, the compile-time
15524 PL_generation sweep will detect such common vars.
15525
15526 So the rules for (C) differ from (B) in that if common vars are
15527 detected, the runtime "test RC==1" optimisation can no longer be used,
15528 and a full mark and sweep is required
15529
15530 D: As (C), but in addition the LHS may contain package vars.
15531
15532 Since package vars can be aliased without a corresponding refcount
15533 increase, all bets are off. It's only safe if (A). E.g.
15534
15535 my ($x, $y) = (1,2);
15536
15537 for $x_alias ($x) {
15538 ($x_alias, $y) = (3, $x); # whoops
15539 }
15540
15541 Ditto for LHS aggregate package vars.
15542
15543 E: Any other dangerous ops on LHS, e.g.
15544 (f(), $a[0], @$r) = (...);
15545
15546 this is similar to (E) in that all bets are off. In addition, it's
15547 impossible to determine at compile time whether the LHS
15548 contains a scalar or an aggregate, e.g.
15549
15550 sub f : lvalue { @a }
15551 (f()) = 1..3;
15552
15553 * ---------------------------------------------------------
15554 */
15555
15556
15557 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
15558 * that at least one of the things flagged was seen.
15559 */
15560
15561 enum {
15562 AAS_MY_SCALAR = 0x001, /* my $scalar */
15563 AAS_MY_AGG = 0x002, /* aggregate: my @array or my %hash */
15564 AAS_LEX_SCALAR = 0x004, /* $lexical */
15565 AAS_LEX_AGG = 0x008, /* @lexical or %lexical aggregate */
15566 AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
15567 AAS_PKG_SCALAR = 0x020, /* $scalar (where $scalar is pkg var) */
15568 AAS_PKG_AGG = 0x040, /* package @array or %hash aggregate */
15569 AAS_DANGEROUS = 0x080, /* an op (other than the above)
15570 that's flagged OA_DANGEROUS */
15571 AAS_SAFE_SCALAR = 0x100, /* produces at least one scalar SV that's
15572 not in any of the categories above */
15573 AAS_DEFAV = 0x200 /* contains just a single '@_' on RHS */
15574 };
15575
15576
15577
15578 /* helper function for S_aassign_scan().
15579 * check a PAD-related op for commonality and/or set its generation number.
15580 * Returns a boolean indicating whether its shared */
15581
15582 static bool
S_aassign_padcheck(pTHX_ OP * o,bool rhs)15583 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
15584 {
15585 if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
15586 /* lexical used in aliasing */
15587 return TRUE;
15588
15589 if (rhs)
15590 return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
15591 else
15592 PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
15593
15594 return FALSE;
15595 }
15596
15597
15598 /*
15599 Helper function for OPpASSIGN_COMMON* detection in rpeep().
15600 It scans the left or right hand subtree of the aassign op, and returns a
15601 set of flags indicating what sorts of things it found there.
15602 'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
15603 set PL_generation on lexical vars; if the latter, we see if
15604 PL_generation matches.
15605 'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
15606 This fn will increment it by the number seen. It's not intended to
15607 be an accurate count (especially as many ops can push a variable
15608 number of SVs onto the stack); rather it's used as to test whether there
15609 can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
15610 */
15611
15612 static int
S_aassign_scan(pTHX_ OP * o,bool rhs,int * scalars_p)15613 S_aassign_scan(pTHX_ OP* o, bool rhs, int *scalars_p)
15614 {
15615 OP *top_op = o;
15616 OP *effective_top_op = o;
15617 int all_flags = 0;
15618
15619 while (1) {
15620 bool top = o == effective_top_op;
15621 int flags = 0;
15622 OP* next_kid = NULL;
15623
15624 /* first, look for a solitary @_ on the RHS */
15625 if ( rhs
15626 && top
15627 && (o->op_flags & OPf_KIDS)
15628 && OP_TYPE_IS_OR_WAS(o, OP_LIST)
15629 ) {
15630 OP *kid = cUNOPo->op_first;
15631 if ( ( kid->op_type == OP_PUSHMARK
15632 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
15633 && ((kid = OpSIBLING(kid)))
15634 && !OpHAS_SIBLING(kid)
15635 && kid->op_type == OP_RV2AV
15636 && !(kid->op_flags & OPf_REF)
15637 && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
15638 && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
15639 && ((kid = cUNOPx(kid)->op_first))
15640 && kid->op_type == OP_GV
15641 && cGVOPx_gv(kid) == PL_defgv
15642 )
15643 flags = AAS_DEFAV;
15644 }
15645
15646 switch (o->op_type) {
15647 case OP_GVSV:
15648 (*scalars_p)++;
15649 all_flags |= AAS_PKG_SCALAR;
15650 goto do_next;
15651
15652 case OP_PADAV:
15653 case OP_PADHV:
15654 (*scalars_p) += 2;
15655 /* if !top, could be e.g. @a[0,1] */
15656 all_flags |= (top && (o->op_flags & OPf_REF))
15657 ? ((o->op_private & OPpLVAL_INTRO)
15658 ? AAS_MY_AGG : AAS_LEX_AGG)
15659 : AAS_DANGEROUS;
15660 goto do_next;
15661
15662 case OP_PADSV:
15663 {
15664 int comm = S_aassign_padcheck(aTHX_ o, rhs)
15665 ? AAS_LEX_SCALAR_COMM : 0;
15666 (*scalars_p)++;
15667 all_flags |= (o->op_private & OPpLVAL_INTRO)
15668 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
15669 goto do_next;
15670
15671 }
15672
15673 case OP_RV2AV:
15674 case OP_RV2HV:
15675 (*scalars_p) += 2;
15676 if (cUNOPx(o)->op_first->op_type != OP_GV)
15677 all_flags |= AAS_DANGEROUS; /* @{expr}, %{expr} */
15678 /* @pkg, %pkg */
15679 /* if !top, could be e.g. @a[0,1] */
15680 else if (top && (o->op_flags & OPf_REF))
15681 all_flags |= AAS_PKG_AGG;
15682 else
15683 all_flags |= AAS_DANGEROUS;
15684 goto do_next;
15685
15686 case OP_RV2SV:
15687 (*scalars_p)++;
15688 if (cUNOPx(o)->op_first->op_type != OP_GV) {
15689 (*scalars_p) += 2;
15690 all_flags |= AAS_DANGEROUS; /* ${expr} */
15691 }
15692 else
15693 all_flags |= AAS_PKG_SCALAR; /* $pkg */
15694 goto do_next;
15695
15696 case OP_SPLIT:
15697 if (o->op_private & OPpSPLIT_ASSIGN) {
15698 /* the assign in @a = split() has been optimised away
15699 * and the @a attached directly to the split op
15700 * Treat the array as appearing on the RHS, i.e.
15701 * ... = (@a = split)
15702 * is treated like
15703 * ... = @a;
15704 */
15705
15706 if (o->op_flags & OPf_STACKED) {
15707 /* @{expr} = split() - the array expression is tacked
15708 * on as an extra child to split - process kid */
15709 next_kid = cLISTOPo->op_last;
15710 goto do_next;
15711 }
15712
15713 /* ... else array is directly attached to split op */
15714 (*scalars_p) += 2;
15715 all_flags |= (PL_op->op_private & OPpSPLIT_LEX)
15716 ? ((o->op_private & OPpLVAL_INTRO)
15717 ? AAS_MY_AGG : AAS_LEX_AGG)
15718 : AAS_PKG_AGG;
15719 goto do_next;
15720 }
15721 (*scalars_p)++;
15722 /* other args of split can't be returned */
15723 all_flags |= AAS_SAFE_SCALAR;
15724 goto do_next;
15725
15726 case OP_UNDEF:
15727 /* undef on LHS following a var is significant, e.g.
15728 * my $x = 1;
15729 * @a = (($x, undef) = (2 => $x));
15730 * # @a shoul be (2,1) not (2,2)
15731 *
15732 * undef on RHS counts as a scalar:
15733 * ($x, $y) = (undef, $x); # 2 scalars on RHS: unsafe
15734 */
15735 if ((!rhs && *scalars_p) || rhs)
15736 (*scalars_p)++;
15737 flags = AAS_SAFE_SCALAR;
15738 break;
15739
15740 case OP_PUSHMARK:
15741 case OP_STUB:
15742 /* these are all no-ops; they don't push a potentially common SV
15743 * onto the stack, so they are neither AAS_DANGEROUS nor
15744 * AAS_SAFE_SCALAR */
15745 goto do_next;
15746
15747 case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
15748 break;
15749
15750 case OP_NULL:
15751 case OP_LIST:
15752 /* these do nothing, but may have children */
15753 break;
15754
15755 default:
15756 if (PL_opargs[o->op_type] & OA_DANGEROUS) {
15757 (*scalars_p) += 2;
15758 flags = AAS_DANGEROUS;
15759 break;
15760 }
15761
15762 if ( (PL_opargs[o->op_type] & OA_TARGLEX)
15763 && (o->op_private & OPpTARGET_MY))
15764 {
15765 (*scalars_p)++;
15766 all_flags |= S_aassign_padcheck(aTHX_ o, rhs)
15767 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
15768 goto do_next;
15769 }
15770
15771 /* if its an unrecognised, non-dangerous op, assume that it
15772 * is the cause of at least one safe scalar */
15773 (*scalars_p)++;
15774 flags = AAS_SAFE_SCALAR;
15775 break;
15776 }
15777
15778 all_flags |= flags;
15779
15780 /* by default, process all kids next
15781 * XXX this assumes that all other ops are "transparent" - i.e. that
15782 * they can return some of their children. While this true for e.g.
15783 * sort and grep, it's not true for e.g. map. We really need a
15784 * 'transparent' flag added to regen/opcodes
15785 */
15786 if (o->op_flags & OPf_KIDS) {
15787 next_kid = cUNOPo->op_first;
15788 /* these ops do nothing but may have children; but their
15789 * children should also be treated as top-level */
15790 if ( o == effective_top_op
15791 && (o->op_type == OP_NULL || o->op_type == OP_LIST)
15792 )
15793 effective_top_op = next_kid;
15794 }
15795
15796
15797 /* If next_kid is set, someone in the code above wanted us to process
15798 * that kid and all its remaining siblings. Otherwise, work our way
15799 * back up the tree */
15800 do_next:
15801 while (!next_kid) {
15802 if (o == top_op)
15803 return all_flags; /* at top; no parents/siblings to try */
15804 if (OpHAS_SIBLING(o)) {
15805 next_kid = o->op_sibparent;
15806 if (o == effective_top_op)
15807 effective_top_op = next_kid;
15808 }
15809 else
15810 if (o == effective_top_op)
15811 effective_top_op = o->op_sibparent;
15812 o = o->op_sibparent; /* try parent's next sibling */
15813
15814 }
15815 o = next_kid;
15816 } /* while */
15817
15818 }
15819
15820
15821 /* Check for in place reverse and sort assignments like "@a = reverse @a"
15822 and modify the optree to make them work inplace */
15823
15824 STATIC void
S_inplace_aassign(pTHX_ OP * o)15825 S_inplace_aassign(pTHX_ OP *o) {
15826
15827 OP *modop, *modop_pushmark;
15828 OP *oright;
15829 OP *oleft, *oleft_pushmark;
15830
15831 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
15832
15833 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
15834
15835 assert(cUNOPo->op_first->op_type == OP_NULL);
15836 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
15837 assert(modop_pushmark->op_type == OP_PUSHMARK);
15838 modop = OpSIBLING(modop_pushmark);
15839
15840 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
15841 return;
15842
15843 /* no other operation except sort/reverse */
15844 if (OpHAS_SIBLING(modop))
15845 return;
15846
15847 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
15848 if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
15849
15850 if (modop->op_flags & OPf_STACKED) {
15851 /* skip sort subroutine/block */
15852 assert(oright->op_type == OP_NULL);
15853 oright = OpSIBLING(oright);
15854 }
15855
15856 assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
15857 oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
15858 assert(oleft_pushmark->op_type == OP_PUSHMARK);
15859 oleft = OpSIBLING(oleft_pushmark);
15860
15861 /* Check the lhs is an array */
15862 if (!oleft ||
15863 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
15864 || OpHAS_SIBLING(oleft)
15865 || (oleft->op_private & OPpLVAL_INTRO)
15866 )
15867 return;
15868
15869 /* Only one thing on the rhs */
15870 if (OpHAS_SIBLING(oright))
15871 return;
15872
15873 /* check the array is the same on both sides */
15874 if (oleft->op_type == OP_RV2AV) {
15875 if (oright->op_type != OP_RV2AV
15876 || !cUNOPx(oright)->op_first
15877 || cUNOPx(oright)->op_first->op_type != OP_GV
15878 || cUNOPx(oleft )->op_first->op_type != OP_GV
15879 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
15880 cGVOPx_gv(cUNOPx(oright)->op_first)
15881 )
15882 return;
15883 }
15884 else if (oright->op_type != OP_PADAV
15885 || oright->op_targ != oleft->op_targ
15886 )
15887 return;
15888
15889 /* This actually is an inplace assignment */
15890
15891 modop->op_private |= OPpSORT_INPLACE;
15892
15893 /* transfer MODishness etc from LHS arg to RHS arg */
15894 oright->op_flags = oleft->op_flags;
15895
15896 /* remove the aassign op and the lhs */
15897 op_null(o);
15898 op_null(oleft_pushmark);
15899 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
15900 op_null(cUNOPx(oleft)->op_first);
15901 op_null(oleft);
15902 }
15903
15904
15905
15906 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
15907 * that potentially represent a series of one or more aggregate derefs
15908 * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
15909 * the whole chain to a single OP_MULTIDEREF op (maybe with a few
15910 * additional ops left in too).
15911 *
15912 * The caller will have already verified that the first few ops in the
15913 * chain following 'start' indicate a multideref candidate, and will have
15914 * set 'orig_o' to the point further on in the chain where the first index
15915 * expression (if any) begins. 'orig_action' specifies what type of
15916 * beginning has already been determined by the ops between start..orig_o
15917 * (e.g. $lex_ary[], $pkg_ary->{}, expr->[], etc).
15918 *
15919 * 'hints' contains any hints flags that need adding (currently just
15920 * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
15921 */
15922
15923 STATIC void
S_maybe_multideref(pTHX_ OP * start,OP * orig_o,UV orig_action,U8 hints)15924 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
15925 {
15926 dVAR;
15927 int pass;
15928 UNOP_AUX_item *arg_buf = NULL;
15929 bool reset_start_targ = FALSE; /* start->op_targ needs zeroing */
15930 int index_skip = -1; /* don't output index arg on this action */
15931
15932 /* similar to regex compiling, do two passes; the first pass
15933 * determines whether the op chain is convertible and calculates the
15934 * buffer size; the second pass populates the buffer and makes any
15935 * changes necessary to ops (such as moving consts to the pad on
15936 * threaded builds).
15937 *
15938 * NB: for things like Coverity, note that both passes take the same
15939 * path through the logic tree (except for 'if (pass)' bits), since
15940 * both passes are following the same op_next chain; and in
15941 * particular, if it would return early on the second pass, it would
15942 * already have returned early on the first pass.
15943 */
15944 for (pass = 0; pass < 2; pass++) {
15945 OP *o = orig_o;
15946 UV action = orig_action;
15947 OP *first_elem_op = NULL; /* first seen aelem/helem */
15948 OP *top_op = NULL; /* highest [ah]elem/exists/del/rv2[ah]v */
15949 int action_count = 0; /* number of actions seen so far */
15950 int action_ix = 0; /* action_count % (actions per IV) */
15951 bool next_is_hash = FALSE; /* is the next lookup to be a hash? */
15952 bool is_last = FALSE; /* no more derefs to follow */
15953 bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
15954 UV action_word = 0; /* all actions so far */
15955 UNOP_AUX_item *arg = arg_buf;
15956 UNOP_AUX_item *action_ptr = arg_buf;
15957
15958 arg++; /* reserve slot for first action word */
15959
15960 switch (action) {
15961 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
15962 case MDEREF_HV_gvhv_helem:
15963 next_is_hash = TRUE;
15964 /* FALLTHROUGH */
15965 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
15966 case MDEREF_AV_gvav_aelem:
15967 if (pass) {
15968 #ifdef USE_ITHREADS
15969 arg->pad_offset = cPADOPx(start)->op_padix;
15970 /* stop it being swiped when nulled */
15971 cPADOPx(start)->op_padix = 0;
15972 #else
15973 arg->sv = cSVOPx(start)->op_sv;
15974 cSVOPx(start)->op_sv = NULL;
15975 #endif
15976 }
15977 arg++;
15978 break;
15979
15980 case MDEREF_HV_padhv_helem:
15981 case MDEREF_HV_padsv_vivify_rv2hv_helem:
15982 next_is_hash = TRUE;
15983 /* FALLTHROUGH */
15984 case MDEREF_AV_padav_aelem:
15985 case MDEREF_AV_padsv_vivify_rv2av_aelem:
15986 if (pass) {
15987 arg->pad_offset = start->op_targ;
15988 /* we skip setting op_targ = 0 for now, since the intact
15989 * OP_PADXV is needed by S_check_hash_fields_and_hekify */
15990 reset_start_targ = TRUE;
15991 }
15992 arg++;
15993 break;
15994
15995 case MDEREF_HV_pop_rv2hv_helem:
15996 next_is_hash = TRUE;
15997 /* FALLTHROUGH */
15998 case MDEREF_AV_pop_rv2av_aelem:
15999 break;
16000
16001 default:
16002 NOT_REACHED; /* NOTREACHED */
16003 return;
16004 }
16005
16006 while (!is_last) {
16007 /* look for another (rv2av/hv; get index;
16008 * aelem/helem/exists/delele) sequence */
16009
16010 OP *kid;
16011 bool is_deref;
16012 bool ok;
16013 UV index_type = MDEREF_INDEX_none;
16014
16015 if (action_count) {
16016 /* if this is not the first lookup, consume the rv2av/hv */
16017
16018 /* for N levels of aggregate lookup, we normally expect
16019 * that the first N-1 [ah]elem ops will be flagged as
16020 * /DEREF (so they autovivifiy if necessary), and the last
16021 * lookup op not to be.
16022 * For other things (like @{$h{k1}{k2}}) extra scope or
16023 * leave ops can appear, so abandon the effort in that
16024 * case */
16025 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
16026 return;
16027
16028 /* rv2av or rv2hv sKR/1 */
16029
16030 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16031 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16032 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
16033 return;
16034
16035 /* at this point, we wouldn't expect any of these
16036 * possible private flags:
16037 * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
16038 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
16039 */
16040 ASSUME(!(o->op_private &
16041 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
16042
16043 hints = (o->op_private & OPpHINT_STRICT_REFS);
16044
16045 /* make sure the type of the previous /DEREF matches the
16046 * type of the next lookup */
16047 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
16048 top_op = o;
16049
16050 action = next_is_hash
16051 ? MDEREF_HV_vivify_rv2hv_helem
16052 : MDEREF_AV_vivify_rv2av_aelem;
16053 o = o->op_next;
16054 }
16055
16056 /* if this is the second pass, and we're at the depth where
16057 * previously we encountered a non-simple index expression,
16058 * stop processing the index at this point */
16059 if (action_count != index_skip) {
16060
16061 /* look for one or more simple ops that return an array
16062 * index or hash key */
16063
16064 switch (o->op_type) {
16065 case OP_PADSV:
16066 /* it may be a lexical var index */
16067 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
16068 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16069 ASSUME(!(o->op_private &
16070 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
16071
16072 if ( OP_GIMME(o,0) == G_SCALAR
16073 && !(o->op_flags & (OPf_REF|OPf_MOD))
16074 && o->op_private == 0)
16075 {
16076 if (pass)
16077 arg->pad_offset = o->op_targ;
16078 arg++;
16079 index_type = MDEREF_INDEX_padsv;
16080 o = o->op_next;
16081 }
16082 break;
16083
16084 case OP_CONST:
16085 if (next_is_hash) {
16086 /* it's a constant hash index */
16087 if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
16088 /* "use constant foo => FOO; $h{+foo}" for
16089 * some weird FOO, can leave you with constants
16090 * that aren't simple strings. It's not worth
16091 * the extra hassle for those edge cases */
16092 break;
16093
16094 {
16095 UNOP *rop = NULL;
16096 OP * helem_op = o->op_next;
16097
16098 ASSUME( helem_op->op_type == OP_HELEM
16099 || helem_op->op_type == OP_NULL
16100 || pass == 0);
16101 if (helem_op->op_type == OP_HELEM) {
16102 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
16103 if ( helem_op->op_private & OPpLVAL_INTRO
16104 || rop->op_type != OP_RV2HV
16105 )
16106 rop = NULL;
16107 }
16108 /* on first pass just check; on second pass
16109 * hekify */
16110 S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo,
16111 pass);
16112 }
16113
16114 if (pass) {
16115 #ifdef USE_ITHREADS
16116 /* Relocate sv to the pad for thread safety */
16117 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
16118 arg->pad_offset = o->op_targ;
16119 o->op_targ = 0;
16120 #else
16121 arg->sv = cSVOPx_sv(o);
16122 #endif
16123 }
16124 }
16125 else {
16126 /* it's a constant array index */
16127 IV iv;
16128 SV *ix_sv = cSVOPo->op_sv;
16129 if (!SvIOK(ix_sv))
16130 break;
16131 iv = SvIV(ix_sv);
16132
16133 if ( action_count == 0
16134 && iv >= -128
16135 && iv <= 127
16136 && ( action == MDEREF_AV_padav_aelem
16137 || action == MDEREF_AV_gvav_aelem)
16138 )
16139 maybe_aelemfast = TRUE;
16140
16141 if (pass) {
16142 arg->iv = iv;
16143 SvREFCNT_dec_NN(cSVOPo->op_sv);
16144 }
16145 }
16146 if (pass)
16147 /* we've taken ownership of the SV */
16148 cSVOPo->op_sv = NULL;
16149 arg++;
16150 index_type = MDEREF_INDEX_const;
16151 o = o->op_next;
16152 break;
16153
16154 case OP_GV:
16155 /* it may be a package var index */
16156
16157 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_SPECIAL)));
16158 ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
16159 if ( (o->op_flags & ~(OPf_PARENS|OPf_SPECIAL)) != OPf_WANT_SCALAR
16160 || o->op_private != 0
16161 )
16162 break;
16163
16164 kid = o->op_next;
16165 if (kid->op_type != OP_RV2SV)
16166 break;
16167
16168 ASSUME(!(kid->op_flags &
16169 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
16170 |OPf_SPECIAL|OPf_PARENS)));
16171 ASSUME(!(kid->op_private &
16172 ~(OPpARG1_MASK
16173 |OPpHINT_STRICT_REFS|OPpOUR_INTRO
16174 |OPpDEREF|OPpLVAL_INTRO)));
16175 if( (kid->op_flags &~ OPf_PARENS)
16176 != (OPf_WANT_SCALAR|OPf_KIDS)
16177 || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
16178 )
16179 break;
16180
16181 if (pass) {
16182 #ifdef USE_ITHREADS
16183 arg->pad_offset = cPADOPx(o)->op_padix;
16184 /* stop it being swiped when nulled */
16185 cPADOPx(o)->op_padix = 0;
16186 #else
16187 arg->sv = cSVOPx(o)->op_sv;
16188 cSVOPo->op_sv = NULL;
16189 #endif
16190 }
16191 arg++;
16192 index_type = MDEREF_INDEX_gvsv;
16193 o = kid->op_next;
16194 break;
16195
16196 } /* switch */
16197 } /* action_count != index_skip */
16198
16199 action |= index_type;
16200
16201
16202 /* at this point we have either:
16203 * * detected what looks like a simple index expression,
16204 * and expect the next op to be an [ah]elem, or
16205 * an nulled [ah]elem followed by a delete or exists;
16206 * * found a more complex expression, so something other
16207 * than the above follows.
16208 */
16209
16210 /* possibly an optimised away [ah]elem (where op_next is
16211 * exists or delete) */
16212 if (o->op_type == OP_NULL)
16213 o = o->op_next;
16214
16215 /* at this point we're looking for an OP_AELEM, OP_HELEM,
16216 * OP_EXISTS or OP_DELETE */
16217
16218 /* if a custom array/hash access checker is in scope,
16219 * abandon optimisation attempt */
16220 if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
16221 && PL_check[o->op_type] != Perl_ck_null)
16222 return;
16223 /* similarly for customised exists and delete */
16224 if ( (o->op_type == OP_EXISTS)
16225 && PL_check[o->op_type] != Perl_ck_exists)
16226 return;
16227 if ( (o->op_type == OP_DELETE)
16228 && PL_check[o->op_type] != Perl_ck_delete)
16229 return;
16230
16231 if ( o->op_type != OP_AELEM
16232 || (o->op_private &
16233 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
16234 )
16235 maybe_aelemfast = FALSE;
16236
16237 /* look for aelem/helem/exists/delete. If it's not the last elem
16238 * lookup, it *must* have OPpDEREF_AV/HV, but not many other
16239 * flags; if it's the last, then it mustn't have
16240 * OPpDEREF_AV/HV, but may have lots of other flags, like
16241 * OPpLVAL_INTRO etc
16242 */
16243
16244 if ( index_type == MDEREF_INDEX_none
16245 || ( o->op_type != OP_AELEM && o->op_type != OP_HELEM
16246 && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
16247 )
16248 ok = FALSE;
16249 else {
16250 /* we have aelem/helem/exists/delete with valid simple index */
16251
16252 is_deref = (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
16253 && ( (o->op_private & OPpDEREF) == OPpDEREF_AV
16254 || (o->op_private & OPpDEREF) == OPpDEREF_HV);
16255
16256 /* This doesn't make much sense but is legal:
16257 * @{ local $x[0][0] } = 1
16258 * Since scope exit will undo the autovivification,
16259 * don't bother in the first place. The OP_LEAVE
16260 * assertion is in case there are other cases of both
16261 * OPpLVAL_INTRO and OPpDEREF which don't include a scope
16262 * exit that would undo the local - in which case this
16263 * block of code would need rethinking.
16264 */
16265 if (is_deref && (o->op_private & OPpLVAL_INTRO)) {
16266 #ifdef DEBUGGING
16267 OP *n = o->op_next;
16268 while (n && ( n->op_type == OP_NULL
16269 || n->op_type == OP_LIST
16270 || n->op_type == OP_SCALAR))
16271 n = n->op_next;
16272 assert(n && n->op_type == OP_LEAVE);
16273 #endif
16274 o->op_private &= ~OPpDEREF;
16275 is_deref = FALSE;
16276 }
16277
16278 if (is_deref) {
16279 ASSUME(!(o->op_flags &
16280 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
16281 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
16282
16283 ok = (o->op_flags &~ OPf_PARENS)
16284 == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
16285 && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
16286 }
16287 else if (o->op_type == OP_EXISTS) {
16288 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16289 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16290 ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
16291 ok = !(o->op_private & ~OPpARG1_MASK);
16292 }
16293 else if (o->op_type == OP_DELETE) {
16294 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16295 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16296 ASSUME(!(o->op_private &
16297 ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
16298 /* don't handle slices or 'local delete'; the latter
16299 * is fairly rare, and has a complex runtime */
16300 ok = !(o->op_private & ~OPpARG1_MASK);
16301 if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
16302 /* skip handling run-tome error */
16303 ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
16304 }
16305 else {
16306 ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
16307 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
16308 |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
16309 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
16310 |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
16311 ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
16312 }
16313 }
16314
16315 if (ok) {
16316 if (!first_elem_op)
16317 first_elem_op = o;
16318 top_op = o;
16319 if (is_deref) {
16320 next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
16321 o = o->op_next;
16322 }
16323 else {
16324 is_last = TRUE;
16325 action |= MDEREF_FLAG_last;
16326 }
16327 }
16328 else {
16329 /* at this point we have something that started
16330 * promisingly enough (with rv2av or whatever), but failed
16331 * to find a simple index followed by an
16332 * aelem/helem/exists/delete. If this is the first action,
16333 * give up; but if we've already seen at least one
16334 * aelem/helem, then keep them and add a new action with
16335 * MDEREF_INDEX_none, which causes it to do the vivify
16336 * from the end of the previous lookup, and do the deref,
16337 * but stop at that point. So $a[0][expr] will do one
16338 * av_fetch, vivify and deref, then continue executing at
16339 * expr */
16340 if (!action_count)
16341 return;
16342 is_last = TRUE;
16343 index_skip = action_count;
16344 action |= MDEREF_FLAG_last;
16345 if (index_type != MDEREF_INDEX_none)
16346 arg--;
16347 }
16348
16349 action_word |= (action << (action_ix * MDEREF_SHIFT));
16350 action_ix++;
16351 action_count++;
16352 /* if there's no space for the next action, reserve a new slot
16353 * for it *before* we start adding args for that action */
16354 if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
16355 if (pass)
16356 action_ptr->uv = action_word;
16357 action_word = 0;
16358 action_ptr = arg;
16359 arg++;
16360 action_ix = 0;
16361 }
16362 } /* while !is_last */
16363
16364 /* success! */
16365
16366 if (!action_ix)
16367 /* slot reserved for next action word not now needed */
16368 arg--;
16369 else if (pass)
16370 action_ptr->uv = action_word;
16371
16372 if (pass) {
16373 OP *mderef;
16374 OP *p, *q;
16375
16376 mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
16377 if (index_skip == -1) {
16378 mderef->op_flags = o->op_flags
16379 & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
16380 if (o->op_type == OP_EXISTS)
16381 mderef->op_private = OPpMULTIDEREF_EXISTS;
16382 else if (o->op_type == OP_DELETE)
16383 mderef->op_private = OPpMULTIDEREF_DELETE;
16384 else
16385 mderef->op_private = o->op_private
16386 & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
16387 }
16388 /* accumulate strictness from every level (although I don't think
16389 * they can actually vary) */
16390 mderef->op_private |= hints;
16391
16392 /* integrate the new multideref op into the optree and the
16393 * op_next chain.
16394 *
16395 * In general an op like aelem or helem has two child
16396 * sub-trees: the aggregate expression (a_expr) and the
16397 * index expression (i_expr):
16398 *
16399 * aelem
16400 * |
16401 * a_expr - i_expr
16402 *
16403 * The a_expr returns an AV or HV, while the i-expr returns an
16404 * index. In general a multideref replaces most or all of a
16405 * multi-level tree, e.g.
16406 *
16407 * exists
16408 * |
16409 * ex-aelem
16410 * |
16411 * rv2av - i_expr1
16412 * |
16413 * helem
16414 * |
16415 * rv2hv - i_expr2
16416 * |
16417 * aelem
16418 * |
16419 * a_expr - i_expr3
16420 *
16421 * With multideref, all the i_exprs will be simple vars or
16422 * constants, except that i_expr1 may be arbitrary in the case
16423 * of MDEREF_INDEX_none.
16424 *
16425 * The bottom-most a_expr will be either:
16426 * 1) a simple var (so padXv or gv+rv2Xv);
16427 * 2) a simple scalar var dereferenced (e.g. $r->[0]):
16428 * so a simple var with an extra rv2Xv;
16429 * 3) or an arbitrary expression.
16430 *
16431 * 'start', the first op in the execution chain, will point to
16432 * 1),2): the padXv or gv op;
16433 * 3): the rv2Xv which forms the last op in the a_expr
16434 * execution chain, and the top-most op in the a_expr
16435 * subtree.
16436 *
16437 * For all cases, the 'start' node is no longer required,
16438 * but we can't free it since one or more external nodes
16439 * may point to it. E.g. consider
16440 * $h{foo} = $a ? $b : $c
16441 * Here, both the op_next and op_other branches of the
16442 * cond_expr point to the gv[*h] of the hash expression, so
16443 * we can't free the 'start' op.
16444 *
16445 * For expr->[...], we need to save the subtree containing the
16446 * expression; for the other cases, we just need to save the
16447 * start node.
16448 * So in all cases, we null the start op and keep it around by
16449 * making it the child of the multideref op; for the expr->
16450 * case, the expr will be a subtree of the start node.
16451 *
16452 * So in the simple 1,2 case the optree above changes to
16453 *
16454 * ex-exists
16455 * |
16456 * multideref
16457 * |
16458 * ex-gv (or ex-padxv)
16459 *
16460 * with the op_next chain being
16461 *
16462 * -> ex-gv -> multideref -> op-following-ex-exists ->
16463 *
16464 * In the 3 case, we have
16465 *
16466 * ex-exists
16467 * |
16468 * multideref
16469 * |
16470 * ex-rv2xv
16471 * |
16472 * rest-of-a_expr
16473 * subtree
16474 *
16475 * and
16476 *
16477 * -> rest-of-a_expr subtree ->
16478 * ex-rv2xv -> multideref -> op-following-ex-exists ->
16479 *
16480 *
16481 * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
16482 * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
16483 * multideref attached as the child, e.g.
16484 *
16485 * exists
16486 * |
16487 * ex-aelem
16488 * |
16489 * ex-rv2av - i_expr1
16490 * |
16491 * multideref
16492 * |
16493 * ex-whatever
16494 *
16495 */
16496
16497 /* if we free this op, don't free the pad entry */
16498 if (reset_start_targ)
16499 start->op_targ = 0;
16500
16501
16502 /* Cut the bit we need to save out of the tree and attach to
16503 * the multideref op, then free the rest of the tree */
16504
16505 /* find parent of node to be detached (for use by splice) */
16506 p = first_elem_op;
16507 if ( orig_action == MDEREF_AV_pop_rv2av_aelem
16508 || orig_action == MDEREF_HV_pop_rv2hv_helem)
16509 {
16510 /* there is an arbitrary expression preceding us, e.g.
16511 * expr->[..]? so we need to save the 'expr' subtree */
16512 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
16513 p = cUNOPx(p)->op_first;
16514 ASSUME( start->op_type == OP_RV2AV
16515 || start->op_type == OP_RV2HV);
16516 }
16517 else {
16518 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
16519 * above for exists/delete. */
16520 while ( (p->op_flags & OPf_KIDS)
16521 && cUNOPx(p)->op_first != start
16522 )
16523 p = cUNOPx(p)->op_first;
16524 }
16525 ASSUME(cUNOPx(p)->op_first == start);
16526
16527 /* detach from main tree, and re-attach under the multideref */
16528 op_sibling_splice(mderef, NULL, 0,
16529 op_sibling_splice(p, NULL, 1, NULL));
16530 op_null(start);
16531
16532 start->op_next = mderef;
16533
16534 mderef->op_next = index_skip == -1 ? o->op_next : o;
16535
16536 /* excise and free the original tree, and replace with
16537 * the multideref op */
16538 p = op_sibling_splice(top_op, NULL, -1, mderef);
16539 while (p) {
16540 q = OpSIBLING(p);
16541 op_free(p);
16542 p = q;
16543 }
16544 op_null(top_op);
16545 }
16546 else {
16547 Size_t size = arg - arg_buf;
16548
16549 if (maybe_aelemfast && action_count == 1)
16550 return;
16551
16552 arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
16553 sizeof(UNOP_AUX_item) * (size + 1));
16554 /* for dumping etc: store the length in a hidden first slot;
16555 * we set the op_aux pointer to the second slot */
16556 arg_buf->uv = size;
16557 arg_buf++;
16558 }
16559 } /* for (pass = ...) */
16560 }
16561
16562 /* See if the ops following o are such that o will always be executed in
16563 * boolean context: that is, the SV which o pushes onto the stack will
16564 * only ever be consumed by later ops via SvTRUE(sv) or similar.
16565 * If so, set a suitable private flag on o. Normally this will be
16566 * bool_flag; but see below why maybe_flag is needed too.
16567 *
16568 * Typically the two flags you pass will be the generic OPpTRUEBOOL and
16569 * OPpMAYBE_TRUEBOOL, buts it's possible that for some ops those bits may
16570 * already be taken, so you'll have to give that op two different flags.
16571 *
16572 * More explanation of 'maybe_flag' and 'safe_and' parameters.
16573 * The binary logical ops &&, ||, // (plus 'if' and 'unless' which use
16574 * those underlying ops) short-circuit, which means that rather than
16575 * necessarily returning a truth value, they may return the LH argument,
16576 * which may not be boolean. For example in $x = (keys %h || -1), keys
16577 * should return a key count rather than a boolean, even though its
16578 * sort-of being used in boolean context.
16579 *
16580 * So we only consider such logical ops to provide boolean context to
16581 * their LH argument if they themselves are in void or boolean context.
16582 * However, sometimes the context isn't known until run-time. In this
16583 * case the op is marked with the maybe_flag flag it.
16584 *
16585 * Consider the following.
16586 *
16587 * sub f { ....; if (%h) { .... } }
16588 *
16589 * This is actually compiled as
16590 *
16591 * sub f { ....; %h && do { .... } }
16592 *
16593 * Here we won't know until runtime whether the final statement (and hence
16594 * the &&) is in void context and so is safe to return a boolean value.
16595 * So mark o with maybe_flag rather than the bool_flag.
16596 * Note that there is cost associated with determining context at runtime
16597 * (e.g. a call to block_gimme()), so it may not be worth setting (at
16598 * compile time) and testing (at runtime) maybe_flag if the scalar verses
16599 * boolean costs savings are marginal.
16600 *
16601 * However, we can do slightly better with && (compared to || and //):
16602 * this op only returns its LH argument when that argument is false. In
16603 * this case, as long as the op promises to return a false value which is
16604 * valid in both boolean and scalar contexts, we can mark an op consumed
16605 * by && with bool_flag rather than maybe_flag.
16606 * For example as long as pp_padhv and pp_rv2hv return &PL_sv_zero rather
16607 * than &PL_sv_no for a false result in boolean context, then it's safe. An
16608 * op which promises to handle this case is indicated by setting safe_and
16609 * to true.
16610 */
16611
16612 static void
S_check_for_bool_cxt(OP * o,bool safe_and,U8 bool_flag,U8 maybe_flag)16613 S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag)
16614 {
16615 OP *lop;
16616 U8 flag = 0;
16617
16618 assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR);
16619
16620 /* OPpTARGET_MY and boolean context probably don't mix well.
16621 * If someone finds a valid use case, maybe add an extra flag to this
16622 * function which indicates its safe to do so for this op? */
16623 assert(!( (PL_opargs[o->op_type] & OA_TARGLEX)
16624 && (o->op_private & OPpTARGET_MY)));
16625
16626 lop = o->op_next;
16627
16628 while (lop) {
16629 switch (lop->op_type) {
16630 case OP_NULL:
16631 case OP_SCALAR:
16632 break;
16633
16634 /* these two consume the stack argument in the scalar case,
16635 * and treat it as a boolean in the non linenumber case */
16636 case OP_FLIP:
16637 case OP_FLOP:
16638 if ( ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST)
16639 || (lop->op_private & OPpFLIP_LINENUM))
16640 {
16641 lop = NULL;
16642 break;
16643 }
16644 /* FALLTHROUGH */
16645 /* these never leave the original value on the stack */
16646 case OP_NOT:
16647 case OP_XOR:
16648 case OP_COND_EXPR:
16649 case OP_GREPWHILE:
16650 flag = bool_flag;
16651 lop = NULL;
16652 break;
16653
16654 /* OR DOR and AND evaluate their arg as a boolean, but then may
16655 * leave the original scalar value on the stack when following the
16656 * op_next route. If not in void context, we need to ensure
16657 * that whatever follows consumes the arg only in boolean context
16658 * too.
16659 */
16660 case OP_AND:
16661 if (safe_and) {
16662 flag = bool_flag;
16663 lop = NULL;
16664 break;
16665 }
16666 /* FALLTHROUGH */
16667 case OP_OR:
16668 case OP_DOR:
16669 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
16670 flag = bool_flag;
16671 lop = NULL;
16672 }
16673 else if (!(lop->op_flags & OPf_WANT)) {
16674 /* unknown context - decide at runtime */
16675 flag = maybe_flag;
16676 lop = NULL;
16677 }
16678 break;
16679
16680 default:
16681 lop = NULL;
16682 break;
16683 }
16684
16685 if (lop)
16686 lop = lop->op_next;
16687 }
16688
16689 o->op_private |= flag;
16690 }
16691
16692
16693
16694 /* mechanism for deferring recursion in rpeep() */
16695
16696 #define MAX_DEFERRED 4
16697
16698 #define DEFER(o) \
16699 STMT_START { \
16700 if (defer_ix == (MAX_DEFERRED-1)) { \
16701 OP **defer = defer_queue[defer_base]; \
16702 CALL_RPEEP(*defer); \
16703 S_prune_chain_head(defer); \
16704 defer_base = (defer_base + 1) % MAX_DEFERRED; \
16705 defer_ix--; \
16706 } \
16707 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
16708 } STMT_END
16709
16710 #define IS_AND_OP(o) (o->op_type == OP_AND)
16711 #define IS_OR_OP(o) (o->op_type == OP_OR)
16712
16713
16714 /* A peephole optimizer. We visit the ops in the order they're to execute.
16715 * See the comments at the top of this file for more details about when
16716 * peep() is called */
16717
16718 void
Perl_rpeep(pTHX_ OP * o)16719 Perl_rpeep(pTHX_ OP *o)
16720 {
16721 dVAR;
16722 OP* oldop = NULL;
16723 OP* oldoldop = NULL;
16724 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
16725 int defer_base = 0;
16726 int defer_ix = -1;
16727
16728 if (!o || o->op_opt)
16729 return;
16730
16731 assert(o->op_type != OP_FREED);
16732
16733 ENTER;
16734 SAVEOP();
16735 SAVEVPTR(PL_curcop);
16736 for (;; o = o->op_next) {
16737 if (o && o->op_opt)
16738 o = NULL;
16739 if (!o) {
16740 while (defer_ix >= 0) {
16741 OP **defer =
16742 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
16743 CALL_RPEEP(*defer);
16744 S_prune_chain_head(defer);
16745 }
16746 break;
16747 }
16748
16749 redo:
16750
16751 /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
16752 assert(!oldoldop || oldoldop->op_next == oldop);
16753 assert(!oldop || oldop->op_next == o);
16754
16755 /* By default, this op has now been optimised. A couple of cases below
16756 clear this again. */
16757 o->op_opt = 1;
16758 PL_op = o;
16759
16760 /* look for a series of 1 or more aggregate derefs, e.g.
16761 * $a[1]{foo}[$i]{$k}
16762 * and replace with a single OP_MULTIDEREF op.
16763 * Each index must be either a const, or a simple variable,
16764 *
16765 * First, look for likely combinations of starting ops,
16766 * corresponding to (global and lexical variants of)
16767 * $a[...] $h{...}
16768 * $r->[...] $r->{...}
16769 * (preceding expression)->[...]
16770 * (preceding expression)->{...}
16771 * and if so, call maybe_multideref() to do a full inspection
16772 * of the op chain and if appropriate, replace with an
16773 * OP_MULTIDEREF
16774 */
16775 {
16776 UV action;
16777 OP *o2 = o;
16778 U8 hints = 0;
16779
16780 switch (o2->op_type) {
16781 case OP_GV:
16782 /* $pkg[..] : gv[*pkg]
16783 * $pkg->[...]: gv[*pkg]; rv2sv sKM/DREFAV */
16784
16785 /* Fail if there are new op flag combinations that we're
16786 * not aware of, rather than:
16787 * * silently failing to optimise, or
16788 * * silently optimising the flag away.
16789 * If this ASSUME starts failing, examine what new flag
16790 * has been added to the op, and decide whether the
16791 * optimisation should still occur with that flag, then
16792 * update the code accordingly. This applies to all the
16793 * other ASSUMEs in the block of code too.
16794 */
16795 ASSUME(!(o2->op_flags &
16796 ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
16797 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
16798
16799 o2 = o2->op_next;
16800
16801 if (o2->op_type == OP_RV2AV) {
16802 action = MDEREF_AV_gvav_aelem;
16803 goto do_deref;
16804 }
16805
16806 if (o2->op_type == OP_RV2HV) {
16807 action = MDEREF_HV_gvhv_helem;
16808 goto do_deref;
16809 }
16810
16811 if (o2->op_type != OP_RV2SV)
16812 break;
16813
16814 /* at this point we've seen gv,rv2sv, so the only valid
16815 * construct left is $pkg->[] or $pkg->{} */
16816
16817 ASSUME(!(o2->op_flags & OPf_STACKED));
16818 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
16819 != (OPf_WANT_SCALAR|OPf_MOD))
16820 break;
16821
16822 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
16823 |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
16824 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
16825 break;
16826 if ( (o2->op_private & OPpDEREF) != OPpDEREF_AV
16827 && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
16828 break;
16829
16830 o2 = o2->op_next;
16831 if (o2->op_type == OP_RV2AV) {
16832 action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
16833 goto do_deref;
16834 }
16835 if (o2->op_type == OP_RV2HV) {
16836 action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
16837 goto do_deref;
16838 }
16839 break;
16840
16841 case OP_PADSV:
16842 /* $lex->[...]: padsv[$lex] sM/DREFAV */
16843
16844 ASSUME(!(o2->op_flags &
16845 ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
16846 if ((o2->op_flags &
16847 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
16848 != (OPf_WANT_SCALAR|OPf_MOD))
16849 break;
16850
16851 ASSUME(!(o2->op_private &
16852 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
16853 /* skip if state or intro, or not a deref */
16854 if ( o2->op_private != OPpDEREF_AV
16855 && o2->op_private != OPpDEREF_HV)
16856 break;
16857
16858 o2 = o2->op_next;
16859 if (o2->op_type == OP_RV2AV) {
16860 action = MDEREF_AV_padsv_vivify_rv2av_aelem;
16861 goto do_deref;
16862 }
16863 if (o2->op_type == OP_RV2HV) {
16864 action = MDEREF_HV_padsv_vivify_rv2hv_helem;
16865 goto do_deref;
16866 }
16867 break;
16868
16869 case OP_PADAV:
16870 case OP_PADHV:
16871 /* $lex[..]: padav[@lex:1,2] sR *
16872 * or $lex{..}: padhv[%lex:1,2] sR */
16873 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
16874 OPf_REF|OPf_SPECIAL)));
16875 if ((o2->op_flags &
16876 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
16877 != (OPf_WANT_SCALAR|OPf_REF))
16878 break;
16879 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
16880 break;
16881 /* OPf_PARENS isn't currently used in this case;
16882 * if that changes, let us know! */
16883 ASSUME(!(o2->op_flags & OPf_PARENS));
16884
16885 /* at this point, we wouldn't expect any of the remaining
16886 * possible private flags:
16887 * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
16888 * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
16889 *
16890 * OPpSLICEWARNING shouldn't affect runtime
16891 */
16892 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
16893
16894 action = o2->op_type == OP_PADAV
16895 ? MDEREF_AV_padav_aelem
16896 : MDEREF_HV_padhv_helem;
16897 o2 = o2->op_next;
16898 S_maybe_multideref(aTHX_ o, o2, action, 0);
16899 break;
16900
16901
16902 case OP_RV2AV:
16903 case OP_RV2HV:
16904 action = o2->op_type == OP_RV2AV
16905 ? MDEREF_AV_pop_rv2av_aelem
16906 : MDEREF_HV_pop_rv2hv_helem;
16907 /* FALLTHROUGH */
16908 do_deref:
16909 /* (expr)->[...]: rv2av sKR/1;
16910 * (expr)->{...}: rv2hv sKR/1; */
16911
16912 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
16913
16914 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16915 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
16916 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
16917 break;
16918
16919 /* at this point, we wouldn't expect any of these
16920 * possible private flags:
16921 * OPpMAYBE_LVSUB, OPpLVAL_INTRO
16922 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
16923 */
16924 ASSUME(!(o2->op_private &
16925 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
16926 |OPpOUR_INTRO)));
16927 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
16928
16929 o2 = o2->op_next;
16930
16931 S_maybe_multideref(aTHX_ o, o2, action, hints);
16932 break;
16933
16934 default:
16935 break;
16936 }
16937 }
16938
16939
16940 switch (o->op_type) {
16941 case OP_DBSTATE:
16942 PL_curcop = ((COP*)o); /* for warnings */
16943 break;
16944 case OP_NEXTSTATE:
16945 PL_curcop = ((COP*)o); /* for warnings */
16946
16947 /* Optimise a "return ..." at the end of a sub to just be "...".
16948 * This saves 2 ops. Before:
16949 * 1 <;> nextstate(main 1 -e:1) v ->2
16950 * 4 <@> return K ->5
16951 * 2 <0> pushmark s ->3
16952 * - <1> ex-rv2sv sK/1 ->4
16953 * 3 <#> gvsv[*cat] s ->4
16954 *
16955 * After:
16956 * - <@> return K ->-
16957 * - <0> pushmark s ->2
16958 * - <1> ex-rv2sv sK/1 ->-
16959 * 2 <$> gvsv(*cat) s ->3
16960 */
16961 {
16962 OP *next = o->op_next;
16963 OP *sibling = OpSIBLING(o);
16964 if ( OP_TYPE_IS(next, OP_PUSHMARK)
16965 && OP_TYPE_IS(sibling, OP_RETURN)
16966 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
16967 && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
16968 ||OP_TYPE_IS(sibling->op_next->op_next,
16969 OP_LEAVESUBLV))
16970 && cUNOPx(sibling)->op_first == next
16971 && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
16972 && next->op_next
16973 ) {
16974 /* Look through the PUSHMARK's siblings for one that
16975 * points to the RETURN */
16976 OP *top = OpSIBLING(next);
16977 while (top && top->op_next) {
16978 if (top->op_next == sibling) {
16979 top->op_next = sibling->op_next;
16980 o->op_next = next->op_next;
16981 break;
16982 }
16983 top = OpSIBLING(top);
16984 }
16985 }
16986 }
16987
16988 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
16989 *
16990 * This latter form is then suitable for conversion into padrange
16991 * later on. Convert:
16992 *
16993 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
16994 *
16995 * into:
16996 *
16997 * nextstate1 -> listop -> nextstate3
16998 * / \
16999 * pushmark -> padop1 -> padop2
17000 */
17001 if (o->op_next && (
17002 o->op_next->op_type == OP_PADSV
17003 || o->op_next->op_type == OP_PADAV
17004 || o->op_next->op_type == OP_PADHV
17005 )
17006 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
17007 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
17008 && o->op_next->op_next->op_next && (
17009 o->op_next->op_next->op_next->op_type == OP_PADSV
17010 || o->op_next->op_next->op_next->op_type == OP_PADAV
17011 || o->op_next->op_next->op_next->op_type == OP_PADHV
17012 )
17013 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
17014 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
17015 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
17016 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
17017 ) {
17018 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
17019
17020 pad1 = o->op_next;
17021 ns2 = pad1->op_next;
17022 pad2 = ns2->op_next;
17023 ns3 = pad2->op_next;
17024
17025 /* we assume here that the op_next chain is the same as
17026 * the op_sibling chain */
17027 assert(OpSIBLING(o) == pad1);
17028 assert(OpSIBLING(pad1) == ns2);
17029 assert(OpSIBLING(ns2) == pad2);
17030 assert(OpSIBLING(pad2) == ns3);
17031
17032 /* excise and delete ns2 */
17033 op_sibling_splice(NULL, pad1, 1, NULL);
17034 op_free(ns2);
17035
17036 /* excise pad1 and pad2 */
17037 op_sibling_splice(NULL, o, 2, NULL);
17038
17039 /* create new listop, with children consisting of:
17040 * a new pushmark, pad1, pad2. */
17041 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
17042 newop->op_flags |= OPf_PARENS;
17043 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
17044
17045 /* insert newop between o and ns3 */
17046 op_sibling_splice(NULL, o, 0, newop);
17047
17048 /*fixup op_next chain */
17049 newpm = cUNOPx(newop)->op_first; /* pushmark */
17050 o ->op_next = newpm;
17051 newpm->op_next = pad1;
17052 pad1 ->op_next = pad2;
17053 pad2 ->op_next = newop; /* listop */
17054 newop->op_next = ns3;
17055
17056 /* Ensure pushmark has this flag if padops do */
17057 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
17058 newpm->op_flags |= OPf_MOD;
17059 }
17060
17061 break;
17062 }
17063
17064 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
17065 to carry two labels. For now, take the easier option, and skip
17066 this optimisation if the first NEXTSTATE has a label. */
17067 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
17068 OP *nextop = o->op_next;
17069 while (nextop) {
17070 switch (nextop->op_type) {
17071 case OP_NULL:
17072 case OP_SCALAR:
17073 case OP_LINESEQ:
17074 case OP_SCOPE:
17075 nextop = nextop->op_next;
17076 continue;
17077 }
17078 break;
17079 }
17080
17081 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
17082 op_null(o);
17083 if (oldop)
17084 oldop->op_next = nextop;
17085 o = nextop;
17086 /* Skip (old)oldop assignment since the current oldop's
17087 op_next already points to the next op. */
17088 goto redo;
17089 }
17090 }
17091 break;
17092
17093 case OP_CONCAT:
17094 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
17095 if (o->op_next->op_private & OPpTARGET_MY) {
17096 if (o->op_flags & OPf_STACKED) /* chained concats */
17097 break; /* ignore_optimization */
17098 else {
17099 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
17100 o->op_targ = o->op_next->op_targ;
17101 o->op_next->op_targ = 0;
17102 o->op_private |= OPpTARGET_MY;
17103 }
17104 }
17105 op_null(o->op_next);
17106 }
17107 break;
17108 case OP_STUB:
17109 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
17110 break; /* Scalar stub must produce undef. List stub is noop */
17111 }
17112 goto nothin;
17113 case OP_NULL:
17114 if (o->op_targ == OP_NEXTSTATE
17115 || o->op_targ == OP_DBSTATE)
17116 {
17117 PL_curcop = ((COP*)o);
17118 }
17119 /* XXX: We avoid setting op_seq here to prevent later calls
17120 to rpeep() from mistakenly concluding that optimisation
17121 has already occurred. This doesn't fix the real problem,
17122 though (See 20010220.007 (#5874)). AMS 20010719 */
17123 /* op_seq functionality is now replaced by op_opt */
17124 o->op_opt = 0;
17125 /* FALLTHROUGH */
17126 case OP_SCALAR:
17127 case OP_LINESEQ:
17128 case OP_SCOPE:
17129 nothin:
17130 if (oldop) {
17131 oldop->op_next = o->op_next;
17132 o->op_opt = 0;
17133 continue;
17134 }
17135 break;
17136
17137 case OP_PUSHMARK:
17138
17139 /* Given
17140 5 repeat/DOLIST
17141 3 ex-list
17142 1 pushmark
17143 2 scalar or const
17144 4 const[0]
17145 convert repeat into a stub with no kids.
17146 */
17147 if (o->op_next->op_type == OP_CONST
17148 || ( o->op_next->op_type == OP_PADSV
17149 && !(o->op_next->op_private & OPpLVAL_INTRO))
17150 || ( o->op_next->op_type == OP_GV
17151 && o->op_next->op_next->op_type == OP_RV2SV
17152 && !(o->op_next->op_next->op_private
17153 & (OPpLVAL_INTRO|OPpOUR_INTRO))))
17154 {
17155 const OP *kid = o->op_next->op_next;
17156 if (o->op_next->op_type == OP_GV)
17157 kid = kid->op_next;
17158 /* kid is now the ex-list. */
17159 if (kid->op_type == OP_NULL
17160 && (kid = kid->op_next)->op_type == OP_CONST
17161 /* kid is now the repeat count. */
17162 && kid->op_next->op_type == OP_REPEAT
17163 && kid->op_next->op_private & OPpREPEAT_DOLIST
17164 && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
17165 && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
17166 && oldop)
17167 {
17168 o = kid->op_next; /* repeat */
17169 oldop->op_next = o;
17170 op_free(cBINOPo->op_first);
17171 op_free(cBINOPo->op_last );
17172 o->op_flags &=~ OPf_KIDS;
17173 /* stub is a baseop; repeat is a binop */
17174 STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
17175 OpTYPE_set(o, OP_STUB);
17176 o->op_private = 0;
17177 break;
17178 }
17179 }
17180
17181 /* Convert a series of PAD ops for my vars plus support into a
17182 * single padrange op. Basically
17183 *
17184 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
17185 *
17186 * becomes, depending on circumstances, one of
17187 *
17188 * padrange ----------------------------------> (list) -> rest
17189 * padrange --------------------------------------------> rest
17190 *
17191 * where all the pad indexes are sequential and of the same type
17192 * (INTRO or not).
17193 * We convert the pushmark into a padrange op, then skip
17194 * any other pad ops, and possibly some trailing ops.
17195 * Note that we don't null() the skipped ops, to make it
17196 * easier for Deparse to undo this optimisation (and none of
17197 * the skipped ops are holding any resourses). It also makes
17198 * it easier for find_uninit_var(), as it can just ignore
17199 * padrange, and examine the original pad ops.
17200 */
17201 {
17202 OP *p;
17203 OP *followop = NULL; /* the op that will follow the padrange op */
17204 U8 count = 0;
17205 U8 intro = 0;
17206 PADOFFSET base = 0; /* init only to stop compiler whining */
17207 bool gvoid = 0; /* init only to stop compiler whining */
17208 bool defav = 0; /* seen (...) = @_ */
17209 bool reuse = 0; /* reuse an existing padrange op */
17210
17211 /* look for a pushmark -> gv[_] -> rv2av */
17212
17213 {
17214 OP *rv2av, *q;
17215 p = o->op_next;
17216 if ( p->op_type == OP_GV
17217 && cGVOPx_gv(p) == PL_defgv
17218 && (rv2av = p->op_next)
17219 && rv2av->op_type == OP_RV2AV
17220 && !(rv2av->op_flags & OPf_REF)
17221 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
17222 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
17223 ) {
17224 q = rv2av->op_next;
17225 if (q->op_type == OP_NULL)
17226 q = q->op_next;
17227 if (q->op_type == OP_PUSHMARK) {
17228 defav = 1;
17229 p = q;
17230 }
17231 }
17232 }
17233 if (!defav) {
17234 p = o;
17235 }
17236
17237 /* scan for PAD ops */
17238
17239 for (p = p->op_next; p; p = p->op_next) {
17240 if (p->op_type == OP_NULL)
17241 continue;
17242
17243 if (( p->op_type != OP_PADSV
17244 && p->op_type != OP_PADAV
17245 && p->op_type != OP_PADHV
17246 )
17247 /* any private flag other than INTRO? e.g. STATE */
17248 || (p->op_private & ~OPpLVAL_INTRO)
17249 )
17250 break;
17251
17252 /* let $a[N] potentially be optimised into AELEMFAST_LEX
17253 * instead */
17254 if ( p->op_type == OP_PADAV
17255 && p->op_next
17256 && p->op_next->op_type == OP_CONST
17257 && p->op_next->op_next
17258 && p->op_next->op_next->op_type == OP_AELEM
17259 )
17260 break;
17261
17262 /* for 1st padop, note what type it is and the range
17263 * start; for the others, check that it's the same type
17264 * and that the targs are contiguous */
17265 if (count == 0) {
17266 intro = (p->op_private & OPpLVAL_INTRO);
17267 base = p->op_targ;
17268 gvoid = OP_GIMME(p,0) == G_VOID;
17269 }
17270 else {
17271 if ((p->op_private & OPpLVAL_INTRO) != intro)
17272 break;
17273 /* Note that you'd normally expect targs to be
17274 * contiguous in my($a,$b,$c), but that's not the case
17275 * when external modules start doing things, e.g.
17276 * Function::Parameters */
17277 if (p->op_targ != base + count)
17278 break;
17279 assert(p->op_targ == base + count);
17280 /* Either all the padops or none of the padops should
17281 be in void context. Since we only do the optimisa-
17282 tion for av/hv when the aggregate itself is pushed
17283 on to the stack (one item), there is no need to dis-
17284 tinguish list from scalar context. */
17285 if (gvoid != (OP_GIMME(p,0) == G_VOID))
17286 break;
17287 }
17288
17289 /* for AV, HV, only when we're not flattening */
17290 if ( p->op_type != OP_PADSV
17291 && !gvoid
17292 && !(p->op_flags & OPf_REF)
17293 )
17294 break;
17295
17296 if (count >= OPpPADRANGE_COUNTMASK)
17297 break;
17298
17299 /* there's a biggest base we can fit into a
17300 * SAVEt_CLEARPADRANGE in pp_padrange.
17301 * (The sizeof() stuff will be constant-folded, and is
17302 * intended to avoid getting "comparison is always false"
17303 * compiler warnings. See the comments above
17304 * MEM_WRAP_CHECK for more explanation on why we do this
17305 * in a weird way to avoid compiler warnings.)
17306 */
17307 if ( intro
17308 && (8*sizeof(base) >
17309 8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
17310 ? (Size_t)base
17311 : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
17312 ) >
17313 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
17314 )
17315 break;
17316
17317 /* Success! We've got another valid pad op to optimise away */
17318 count++;
17319 followop = p->op_next;
17320 }
17321
17322 if (count < 1 || (count == 1 && !defav))
17323 break;
17324
17325 /* pp_padrange in specifically compile-time void context
17326 * skips pushing a mark and lexicals; in all other contexts
17327 * (including unknown till runtime) it pushes a mark and the
17328 * lexicals. We must be very careful then, that the ops we
17329 * optimise away would have exactly the same effect as the
17330 * padrange.
17331 * In particular in void context, we can only optimise to
17332 * a padrange if we see the complete sequence
17333 * pushmark, pad*v, ...., list
17334 * which has the net effect of leaving the markstack as it
17335 * was. Not pushing onto the stack (whereas padsv does touch
17336 * the stack) makes no difference in void context.
17337 */
17338 assert(followop);
17339 if (gvoid) {
17340 if (followop->op_type == OP_LIST
17341 && OP_GIMME(followop,0) == G_VOID
17342 )
17343 {
17344 followop = followop->op_next; /* skip OP_LIST */
17345
17346 /* consolidate two successive my(...);'s */
17347
17348 if ( oldoldop
17349 && oldoldop->op_type == OP_PADRANGE
17350 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
17351 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
17352 && !(oldoldop->op_flags & OPf_SPECIAL)
17353 ) {
17354 U8 old_count;
17355 assert(oldoldop->op_next == oldop);
17356 assert( oldop->op_type == OP_NEXTSTATE
17357 || oldop->op_type == OP_DBSTATE);
17358 assert(oldop->op_next == o);
17359
17360 old_count
17361 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
17362
17363 /* Do not assume pad offsets for $c and $d are con-
17364 tiguous in
17365 my ($a,$b,$c);
17366 my ($d,$e,$f);
17367 */
17368 if ( oldoldop->op_targ + old_count == base
17369 && old_count < OPpPADRANGE_COUNTMASK - count) {
17370 base = oldoldop->op_targ;
17371 count += old_count;
17372 reuse = 1;
17373 }
17374 }
17375
17376 /* if there's any immediately following singleton
17377 * my var's; then swallow them and the associated
17378 * nextstates; i.e.
17379 * my ($a,$b); my $c; my $d;
17380 * is treated as
17381 * my ($a,$b,$c,$d);
17382 */
17383
17384 while ( ((p = followop->op_next))
17385 && ( p->op_type == OP_PADSV
17386 || p->op_type == OP_PADAV
17387 || p->op_type == OP_PADHV)
17388 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
17389 && (p->op_private & OPpLVAL_INTRO) == intro
17390 && !(p->op_private & ~OPpLVAL_INTRO)
17391 && p->op_next
17392 && ( p->op_next->op_type == OP_NEXTSTATE
17393 || p->op_next->op_type == OP_DBSTATE)
17394 && count < OPpPADRANGE_COUNTMASK
17395 && base + count == p->op_targ
17396 ) {
17397 count++;
17398 followop = p->op_next;
17399 }
17400 }
17401 else
17402 break;
17403 }
17404
17405 if (reuse) {
17406 assert(oldoldop->op_type == OP_PADRANGE);
17407 oldoldop->op_next = followop;
17408 oldoldop->op_private = (intro | count);
17409 o = oldoldop;
17410 oldop = NULL;
17411 oldoldop = NULL;
17412 }
17413 else {
17414 /* Convert the pushmark into a padrange.
17415 * To make Deparse easier, we guarantee that a padrange was
17416 * *always* formerly a pushmark */
17417 assert(o->op_type == OP_PUSHMARK);
17418 o->op_next = followop;
17419 OpTYPE_set(o, OP_PADRANGE);
17420 o->op_targ = base;
17421 /* bit 7: INTRO; bit 6..0: count */
17422 o->op_private = (intro | count);
17423 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
17424 | gvoid * OPf_WANT_VOID
17425 | (defav ? OPf_SPECIAL : 0));
17426 }
17427 break;
17428 }
17429
17430 case OP_RV2AV:
17431 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17432 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17433 break;
17434
17435 case OP_RV2HV:
17436 case OP_PADHV:
17437 /*'keys %h' in void or scalar context: skip the OP_KEYS
17438 * and perform the functionality directly in the RV2HV/PADHV
17439 * op
17440 */
17441 if (o->op_flags & OPf_REF) {
17442 OP *k = o->op_next;
17443 U8 want = (k->op_flags & OPf_WANT);
17444 if ( k
17445 && k->op_type == OP_KEYS
17446 && ( want == OPf_WANT_VOID
17447 || want == OPf_WANT_SCALAR)
17448 && !(k->op_private & OPpMAYBE_LVSUB)
17449 && !(k->op_flags & OPf_MOD)
17450 ) {
17451 o->op_next = k->op_next;
17452 o->op_flags &= ~(OPf_REF|OPf_WANT);
17453 o->op_flags |= want;
17454 o->op_private |= (o->op_type == OP_PADHV ?
17455 OPpPADHV_ISKEYS : OPpRV2HV_ISKEYS);
17456 /* for keys(%lex), hold onto the OP_KEYS's targ
17457 * since padhv doesn't have its own targ to return
17458 * an int with */
17459 if (!(o->op_type ==OP_PADHV && want == OPf_WANT_SCALAR))
17460 op_null(k);
17461 }
17462 }
17463
17464 /* see if %h is used in boolean context */
17465 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17466 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
17467
17468
17469 if (o->op_type != OP_PADHV)
17470 break;
17471 /* FALLTHROUGH */
17472 case OP_PADAV:
17473 if ( o->op_type == OP_PADAV
17474 && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
17475 )
17476 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17477 /* FALLTHROUGH */
17478 case OP_PADSV:
17479 /* Skip over state($x) in void context. */
17480 if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
17481 && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
17482 {
17483 oldop->op_next = o->op_next;
17484 goto redo_nextstate;
17485 }
17486 if (o->op_type != OP_PADAV)
17487 break;
17488 /* FALLTHROUGH */
17489 case OP_GV:
17490 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
17491 OP* const pop = (o->op_type == OP_PADAV) ?
17492 o->op_next : o->op_next->op_next;
17493 IV i;
17494 if (pop && pop->op_type == OP_CONST &&
17495 ((PL_op = pop->op_next)) &&
17496 pop->op_next->op_type == OP_AELEM &&
17497 !(pop->op_next->op_private &
17498 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
17499 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
17500 {
17501 GV *gv;
17502 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
17503 no_bareword_allowed(pop);
17504 if (o->op_type == OP_GV)
17505 op_null(o->op_next);
17506 op_null(pop->op_next);
17507 op_null(pop);
17508 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
17509 o->op_next = pop->op_next->op_next;
17510 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
17511 o->op_private = (U8)i;
17512 if (o->op_type == OP_GV) {
17513 gv = cGVOPo_gv;
17514 GvAVn(gv);
17515 o->op_type = OP_AELEMFAST;
17516 }
17517 else
17518 o->op_type = OP_AELEMFAST_LEX;
17519 }
17520 if (o->op_type != OP_GV)
17521 break;
17522 }
17523
17524 /* Remove $foo from the op_next chain in void context. */
17525 if (oldop
17526 && ( o->op_next->op_type == OP_RV2SV
17527 || o->op_next->op_type == OP_RV2AV
17528 || o->op_next->op_type == OP_RV2HV )
17529 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
17530 && !(o->op_next->op_private & OPpLVAL_INTRO))
17531 {
17532 oldop->op_next = o->op_next->op_next;
17533 /* Reprocess the previous op if it is a nextstate, to
17534 allow double-nextstate optimisation. */
17535 redo_nextstate:
17536 if (oldop->op_type == OP_NEXTSTATE) {
17537 oldop->op_opt = 0;
17538 o = oldop;
17539 oldop = oldoldop;
17540 oldoldop = NULL;
17541 goto redo;
17542 }
17543 o = oldop->op_next;
17544 goto redo;
17545 }
17546 else if (o->op_next->op_type == OP_RV2SV) {
17547 if (!(o->op_next->op_private & OPpDEREF)) {
17548 op_null(o->op_next);
17549 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
17550 | OPpOUR_INTRO);
17551 o->op_next = o->op_next->op_next;
17552 OpTYPE_set(o, OP_GVSV);
17553 }
17554 }
17555 else if (o->op_next->op_type == OP_READLINE
17556 && o->op_next->op_next->op_type == OP_CONCAT
17557 && (o->op_next->op_next->op_flags & OPf_STACKED))
17558 {
17559 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
17560 OpTYPE_set(o, OP_RCATLINE);
17561 o->op_flags |= OPf_STACKED;
17562 op_null(o->op_next->op_next);
17563 op_null(o->op_next);
17564 }
17565
17566 break;
17567
17568 case OP_NOT:
17569 break;
17570
17571 case OP_AND:
17572 case OP_OR:
17573 case OP_DOR:
17574 case OP_CMPCHAIN_AND:
17575 while (cLOGOP->op_other->op_type == OP_NULL)
17576 cLOGOP->op_other = cLOGOP->op_other->op_next;
17577 while (o->op_next && ( o->op_type == o->op_next->op_type
17578 || o->op_next->op_type == OP_NULL))
17579 o->op_next = o->op_next->op_next;
17580
17581 /* If we're an OR and our next is an AND in void context, we'll
17582 follow its op_other on short circuit, same for reverse.
17583 We can't do this with OP_DOR since if it's true, its return
17584 value is the underlying value which must be evaluated
17585 by the next op. */
17586 if (o->op_next &&
17587 (
17588 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
17589 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
17590 )
17591 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
17592 ) {
17593 o->op_next = ((LOGOP*)o->op_next)->op_other;
17594 }
17595 DEFER(cLOGOP->op_other);
17596 o->op_opt = 1;
17597 break;
17598
17599 case OP_GREPWHILE:
17600 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17601 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17602 /* FALLTHROUGH */
17603 case OP_COND_EXPR:
17604 case OP_MAPWHILE:
17605 case OP_ANDASSIGN:
17606 case OP_ORASSIGN:
17607 case OP_DORASSIGN:
17608 case OP_RANGE:
17609 case OP_ONCE:
17610 case OP_ARGDEFELEM:
17611 while (cLOGOP->op_other->op_type == OP_NULL)
17612 cLOGOP->op_other = cLOGOP->op_other->op_next;
17613 DEFER(cLOGOP->op_other);
17614 break;
17615
17616 case OP_ENTERLOOP:
17617 case OP_ENTERITER:
17618 while (cLOOP->op_redoop->op_type == OP_NULL)
17619 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
17620 while (cLOOP->op_nextop->op_type == OP_NULL)
17621 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
17622 while (cLOOP->op_lastop->op_type == OP_NULL)
17623 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
17624 /* a while(1) loop doesn't have an op_next that escapes the
17625 * loop, so we have to explicitly follow the op_lastop to
17626 * process the rest of the code */
17627 DEFER(cLOOP->op_lastop);
17628 break;
17629
17630 case OP_ENTERTRY:
17631 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
17632 DEFER(cLOGOPo->op_other);
17633 break;
17634
17635 case OP_SUBST:
17636 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17637 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17638 assert(!(cPMOP->op_pmflags & PMf_ONCE));
17639 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
17640 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
17641 cPMOP->op_pmstashstartu.op_pmreplstart
17642 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
17643 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
17644 break;
17645
17646 case OP_SORT: {
17647 OP *oright;
17648
17649 if (o->op_flags & OPf_SPECIAL) {
17650 /* first arg is a code block */
17651 OP * const nullop = OpSIBLING(cLISTOP->op_first);
17652 OP * kid = cUNOPx(nullop)->op_first;
17653
17654 assert(nullop->op_type == OP_NULL);
17655 assert(kid->op_type == OP_SCOPE
17656 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
17657 /* since OP_SORT doesn't have a handy op_other-style
17658 * field that can point directly to the start of the code
17659 * block, store it in the otherwise-unused op_next field
17660 * of the top-level OP_NULL. This will be quicker at
17661 * run-time, and it will also allow us to remove leading
17662 * OP_NULLs by just messing with op_nexts without
17663 * altering the basic op_first/op_sibling layout. */
17664 kid = kLISTOP->op_first;
17665 assert(
17666 (kid->op_type == OP_NULL
17667 && ( kid->op_targ == OP_NEXTSTATE
17668 || kid->op_targ == OP_DBSTATE ))
17669 || kid->op_type == OP_STUB
17670 || kid->op_type == OP_ENTER
17671 || (PL_parser && PL_parser->error_count));
17672 nullop->op_next = kid->op_next;
17673 DEFER(nullop->op_next);
17674 }
17675
17676 /* check that RHS of sort is a single plain array */
17677 oright = cUNOPo->op_first;
17678 if (!oright || oright->op_type != OP_PUSHMARK)
17679 break;
17680
17681 if (o->op_private & OPpSORT_INPLACE)
17682 break;
17683
17684 /* reverse sort ... can be optimised. */
17685 if (!OpHAS_SIBLING(cUNOPo)) {
17686 /* Nothing follows us on the list. */
17687 OP * const reverse = o->op_next;
17688
17689 if (reverse->op_type == OP_REVERSE &&
17690 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
17691 OP * const pushmark = cUNOPx(reverse)->op_first;
17692 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
17693 && (OpSIBLING(cUNOPx(pushmark)) == o)) {
17694 /* reverse -> pushmark -> sort */
17695 o->op_private |= OPpSORT_REVERSE;
17696 op_null(reverse);
17697 pushmark->op_next = oright->op_next;
17698 op_null(oright);
17699 }
17700 }
17701 }
17702
17703 break;
17704 }
17705
17706 case OP_REVERSE: {
17707 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
17708 OP *gvop = NULL;
17709 LISTOP *enter, *exlist;
17710
17711 if (o->op_private & OPpSORT_INPLACE)
17712 break;
17713
17714 enter = (LISTOP *) o->op_next;
17715 if (!enter)
17716 break;
17717 if (enter->op_type == OP_NULL) {
17718 enter = (LISTOP *) enter->op_next;
17719 if (!enter)
17720 break;
17721 }
17722 /* for $a (...) will have OP_GV then OP_RV2GV here.
17723 for (...) just has an OP_GV. */
17724 if (enter->op_type == OP_GV) {
17725 gvop = (OP *) enter;
17726 enter = (LISTOP *) enter->op_next;
17727 if (!enter)
17728 break;
17729 if (enter->op_type == OP_RV2GV) {
17730 enter = (LISTOP *) enter->op_next;
17731 if (!enter)
17732 break;
17733 }
17734 }
17735
17736 if (enter->op_type != OP_ENTERITER)
17737 break;
17738
17739 iter = enter->op_next;
17740 if (!iter || iter->op_type != OP_ITER)
17741 break;
17742
17743 expushmark = enter->op_first;
17744 if (!expushmark || expushmark->op_type != OP_NULL
17745 || expushmark->op_targ != OP_PUSHMARK)
17746 break;
17747
17748 exlist = (LISTOP *) OpSIBLING(expushmark);
17749 if (!exlist || exlist->op_type != OP_NULL
17750 || exlist->op_targ != OP_LIST)
17751 break;
17752
17753 if (exlist->op_last != o) {
17754 /* Mmm. Was expecting to point back to this op. */
17755 break;
17756 }
17757 theirmark = exlist->op_first;
17758 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
17759 break;
17760
17761 if (OpSIBLING(theirmark) != o) {
17762 /* There's something between the mark and the reverse, eg
17763 for (1, reverse (...))
17764 so no go. */
17765 break;
17766 }
17767
17768 ourmark = ((LISTOP *)o)->op_first;
17769 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
17770 break;
17771
17772 ourlast = ((LISTOP *)o)->op_last;
17773 if (!ourlast || ourlast->op_next != o)
17774 break;
17775
17776 rv2av = OpSIBLING(ourmark);
17777 if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
17778 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
17779 /* We're just reversing a single array. */
17780 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
17781 enter->op_flags |= OPf_STACKED;
17782 }
17783
17784 /* We don't have control over who points to theirmark, so sacrifice
17785 ours. */
17786 theirmark->op_next = ourmark->op_next;
17787 theirmark->op_flags = ourmark->op_flags;
17788 ourlast->op_next = gvop ? gvop : (OP *) enter;
17789 op_null(ourmark);
17790 op_null(o);
17791 enter->op_private |= OPpITER_REVERSED;
17792 iter->op_private |= OPpITER_REVERSED;
17793
17794 oldoldop = NULL;
17795 oldop = ourlast;
17796 o = oldop->op_next;
17797 goto redo;
17798 NOT_REACHED; /* NOTREACHED */
17799 break;
17800 }
17801
17802 case OP_QR:
17803 case OP_MATCH:
17804 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
17805 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
17806 }
17807 break;
17808
17809 case OP_RUNCV:
17810 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
17811 && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
17812 {
17813 SV *sv;
17814 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
17815 else {
17816 sv = newRV((SV *)PL_compcv);
17817 sv_rvweaken(sv);
17818 SvREADONLY_on(sv);
17819 }
17820 OpTYPE_set(o, OP_CONST);
17821 o->op_flags |= OPf_SPECIAL;
17822 cSVOPo->op_sv = sv;
17823 }
17824 break;
17825
17826 case OP_SASSIGN:
17827 if (OP_GIMME(o,0) == G_VOID
17828 || ( o->op_next->op_type == OP_LINESEQ
17829 && ( o->op_next->op_next->op_type == OP_LEAVESUB
17830 || ( o->op_next->op_next->op_type == OP_RETURN
17831 && !CvLVALUE(PL_compcv)))))
17832 {
17833 OP *right = cBINOP->op_first;
17834 if (right) {
17835 /* sassign
17836 * RIGHT
17837 * substr
17838 * pushmark
17839 * arg1
17840 * arg2
17841 * ...
17842 * becomes
17843 *
17844 * ex-sassign
17845 * substr
17846 * pushmark
17847 * RIGHT
17848 * arg1
17849 * arg2
17850 * ...
17851 */
17852 OP *left = OpSIBLING(right);
17853 if (left->op_type == OP_SUBSTR
17854 && (left->op_private & 7) < 4) {
17855 op_null(o);
17856 /* cut out right */
17857 op_sibling_splice(o, NULL, 1, NULL);
17858 /* and insert it as second child of OP_SUBSTR */
17859 op_sibling_splice(left, cBINOPx(left)->op_first, 0,
17860 right);
17861 left->op_private |= OPpSUBSTR_REPL_FIRST;
17862 left->op_flags =
17863 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
17864 }
17865 }
17866 }
17867 break;
17868
17869 case OP_AASSIGN: {
17870 int l, r, lr, lscalars, rscalars;
17871
17872 /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
17873 Note that we do this now rather than in newASSIGNOP(),
17874 since only by now are aliased lexicals flagged as such
17875
17876 See the essay "Common vars in list assignment" above for
17877 the full details of the rationale behind all the conditions
17878 below.
17879
17880 PL_generation sorcery:
17881 To detect whether there are common vars, the global var
17882 PL_generation is incremented for each assign op we scan.
17883 Then we run through all the lexical variables on the LHS,
17884 of the assignment, setting a spare slot in each of them to
17885 PL_generation. Then we scan the RHS, and if any lexicals
17886 already have that value, we know we've got commonality.
17887 Also, if the generation number is already set to
17888 PERL_INT_MAX, then the variable is involved in aliasing, so
17889 we also have potential commonality in that case.
17890 */
17891
17892 PL_generation++;
17893 /* scan LHS */
17894 lscalars = 0;
17895 l = S_aassign_scan(aTHX_ cLISTOPo->op_last, FALSE, &lscalars);
17896 /* scan RHS */
17897 rscalars = 0;
17898 r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, &rscalars);
17899 lr = (l|r);
17900
17901
17902 /* After looking for things which are *always* safe, this main
17903 * if/else chain selects primarily based on the type of the
17904 * LHS, gradually working its way down from the more dangerous
17905 * to the more restrictive and thus safer cases */
17906
17907 if ( !l /* () = ....; */
17908 || !r /* .... = (); */
17909 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
17910 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
17911 || (lscalars < 2) /* ($x, undef) = ... */
17912 ) {
17913 NOOP; /* always safe */
17914 }
17915 else if (l & AAS_DANGEROUS) {
17916 /* always dangerous */
17917 o->op_private |= OPpASSIGN_COMMON_SCALAR;
17918 o->op_private |= OPpASSIGN_COMMON_AGG;
17919 }
17920 else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
17921 /* package vars are always dangerous - too many
17922 * aliasing possibilities */
17923 if (l & AAS_PKG_SCALAR)
17924 o->op_private |= OPpASSIGN_COMMON_SCALAR;
17925 if (l & AAS_PKG_AGG)
17926 o->op_private |= OPpASSIGN_COMMON_AGG;
17927 }
17928 else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
17929 |AAS_LEX_SCALAR|AAS_LEX_AGG))
17930 {
17931 /* LHS contains only lexicals and safe ops */
17932
17933 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
17934 o->op_private |= OPpASSIGN_COMMON_AGG;
17935
17936 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
17937 if (lr & AAS_LEX_SCALAR_COMM)
17938 o->op_private |= OPpASSIGN_COMMON_SCALAR;
17939 else if ( !(l & AAS_LEX_SCALAR)
17940 && (r & AAS_DEFAV))
17941 {
17942 /* falsely mark
17943 * my (...) = @_
17944 * as scalar-safe for performance reasons.
17945 * (it will still have been marked _AGG if necessary */
17946 NOOP;
17947 }
17948 else if (r & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
17949 /* if there are only lexicals on the LHS and no
17950 * common ones on the RHS, then we assume that the
17951 * only way those lexicals could also get
17952 * on the RHS is via some sort of dereffing or
17953 * closure, e.g.
17954 * $r = \$lex;
17955 * ($lex, $x) = (1, $$r)
17956 * and in this case we assume the var must have
17957 * a bumped ref count. So if its ref count is 1,
17958 * it must only be on the LHS.
17959 */
17960 o->op_private |= OPpASSIGN_COMMON_RC1;
17961 }
17962 }
17963
17964 /* ... = ($x)
17965 * may have to handle aggregate on LHS, but we can't
17966 * have common scalars. */
17967 if (rscalars < 2)
17968 o->op_private &=
17969 ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
17970
17971 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17972 S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0);
17973 break;
17974 }
17975
17976 case OP_REF:
17977 /* see if ref() is used in boolean context */
17978 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17979 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
17980 break;
17981
17982 case OP_LENGTH:
17983 /* see if the op is used in known boolean context,
17984 * but not if OA_TARGLEX optimisation is enabled */
17985 if ( (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
17986 && !(o->op_private & OPpTARGET_MY)
17987 )
17988 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17989 break;
17990
17991 case OP_POS:
17992 /* see if the op is used in known boolean context */
17993 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17994 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17995 break;
17996
17997 case OP_CUSTOM: {
17998 Perl_cpeep_t cpeep =
17999 XopENTRYCUSTOM(o, xop_peep);
18000 if (cpeep)
18001 cpeep(aTHX_ o, oldop);
18002 break;
18003 }
18004
18005 }
18006 /* did we just null the current op? If so, re-process it to handle
18007 * eliding "empty" ops from the chain */
18008 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
18009 o->op_opt = 0;
18010 o = oldop;
18011 }
18012 else {
18013 oldoldop = oldop;
18014 oldop = o;
18015 }
18016 }
18017 LEAVE;
18018 }
18019
18020 void
Perl_peep(pTHX_ OP * o)18021 Perl_peep(pTHX_ OP *o)
18022 {
18023 CALL_RPEEP(o);
18024 }
18025
18026 /*
18027 =head1 Custom Operators
18028
18029 =for apidoc Perl_custom_op_xop
18030 Return the XOP structure for a given custom op. This macro should be
18031 considered internal to C<OP_NAME> and the other access macros: use them instead.
18032 This macro does call a function. Prior
18033 to 5.19.6, this was implemented as a
18034 function.
18035
18036 =cut
18037 */
18038
18039
18040 /* use PERL_MAGIC_ext to call a function to free the xop structure when
18041 * freeing PL_custom_ops */
18042
18043 static int
custom_op_register_free(pTHX_ SV * sv,MAGIC * mg)18044 custom_op_register_free(pTHX_ SV *sv, MAGIC *mg)
18045 {
18046 XOP *xop;
18047
18048 PERL_UNUSED_ARG(mg);
18049 xop = INT2PTR(XOP *, SvIV(sv));
18050 Safefree(xop->xop_name);
18051 Safefree(xop->xop_desc);
18052 Safefree(xop);
18053 return 0;
18054 }
18055
18056
18057 static const MGVTBL custom_op_register_vtbl = {
18058 0, /* get */
18059 0, /* set */
18060 0, /* len */
18061 0, /* clear */
18062 custom_op_register_free, /* free */
18063 0, /* copy */
18064 0, /* dup */
18065 #ifdef MGf_LOCAL
18066 0, /* local */
18067 #endif
18068 };
18069
18070
18071 XOPRETANY
Perl_custom_op_get_field(pTHX_ const OP * o,const xop_flags_enum field)18072 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
18073 {
18074 SV *keysv;
18075 HE *he = NULL;
18076 XOP *xop;
18077
18078 static const XOP xop_null = { 0, 0, 0, 0, 0 };
18079
18080 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
18081 assert(o->op_type == OP_CUSTOM);
18082
18083 /* This is wrong. It assumes a function pointer can be cast to IV,
18084 * which isn't guaranteed, but this is what the old custom OP code
18085 * did. In principle it should be safer to Copy the bytes of the
18086 * pointer into a PV: since the new interface is hidden behind
18087 * functions, this can be changed later if necessary. */
18088 /* Change custom_op_xop if this ever happens */
18089 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
18090
18091 if (PL_custom_ops)
18092 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
18093
18094 /* See if the op isn't registered, but its name *is* registered.
18095 * That implies someone is using the pre-5.14 API,where only name and
18096 * description could be registered. If so, fake up a real
18097 * registration.
18098 * We only check for an existing name, and assume no one will have
18099 * just registered a desc */
18100 if (!he && PL_custom_op_names &&
18101 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
18102 ) {
18103 const char *pv;
18104 STRLEN l;
18105
18106 /* XXX does all this need to be shared mem? */
18107 Newxz(xop, 1, XOP);
18108 pv = SvPV(HeVAL(he), l);
18109 XopENTRY_set(xop, xop_name, savepvn(pv, l));
18110 if (PL_custom_op_descs &&
18111 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
18112 ) {
18113 pv = SvPV(HeVAL(he), l);
18114 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
18115 }
18116 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
18117 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
18118 /* add magic to the SV so that the xop struct (pointed to by
18119 * SvIV(sv)) is freed. Normally a static xop is registered, but
18120 * for this backcompat hack, we've alloced one */
18121 (void)sv_magicext(HeVAL(he), NULL, PERL_MAGIC_ext,
18122 &custom_op_register_vtbl, NULL, 0);
18123
18124 }
18125 else {
18126 if (!he)
18127 xop = (XOP *)&xop_null;
18128 else
18129 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
18130 }
18131 {
18132 XOPRETANY any;
18133 if(field == XOPe_xop_ptr) {
18134 any.xop_ptr = xop;
18135 } else {
18136 const U32 flags = XopFLAGS(xop);
18137 if(flags & field) {
18138 switch(field) {
18139 case XOPe_xop_name:
18140 any.xop_name = xop->xop_name;
18141 break;
18142 case XOPe_xop_desc:
18143 any.xop_desc = xop->xop_desc;
18144 break;
18145 case XOPe_xop_class:
18146 any.xop_class = xop->xop_class;
18147 break;
18148 case XOPe_xop_peep:
18149 any.xop_peep = xop->xop_peep;
18150 break;
18151 default:
18152 NOT_REACHED; /* NOTREACHED */
18153 break;
18154 }
18155 } else {
18156 switch(field) {
18157 case XOPe_xop_name:
18158 any.xop_name = XOPd_xop_name;
18159 break;
18160 case XOPe_xop_desc:
18161 any.xop_desc = XOPd_xop_desc;
18162 break;
18163 case XOPe_xop_class:
18164 any.xop_class = XOPd_xop_class;
18165 break;
18166 case XOPe_xop_peep:
18167 any.xop_peep = XOPd_xop_peep;
18168 break;
18169 default:
18170 NOT_REACHED; /* NOTREACHED */
18171 break;
18172 }
18173 }
18174 }
18175 /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
18176 * op.c: In function 'Perl_custom_op_get_field':
18177 * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
18178 * This is because on those platforms (with -DEBUGGING) NOT_REACHED
18179 * expands to assert(0), which expands to ((0) ? (void)0 :
18180 * __assert(...)), and gcc doesn't know that __assert can never return. */
18181 return any;
18182 }
18183 }
18184
18185 /*
18186 =for apidoc custom_op_register
18187 Register a custom op. See L<perlguts/"Custom Operators">.
18188
18189 =cut
18190 */
18191
18192 void
Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr,const XOP * xop)18193 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
18194 {
18195 SV *keysv;
18196
18197 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
18198
18199 /* see the comment in custom_op_xop */
18200 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
18201
18202 if (!PL_custom_ops)
18203 PL_custom_ops = newHV();
18204
18205 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
18206 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
18207 }
18208
18209 /*
18210
18211 =for apidoc core_prototype
18212
18213 This function assigns the prototype of the named core function to C<sv>, or
18214 to a new mortal SV if C<sv> is C<NULL>. It returns the modified C<sv>, or
18215 C<NULL> if the core function has no prototype. C<code> is a code as returned
18216 by C<keyword()>. It must not be equal to 0.
18217
18218 =cut
18219 */
18220
18221 SV *
Perl_core_prototype(pTHX_ SV * sv,const char * name,const int code,int * const opnum)18222 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
18223 int * const opnum)
18224 {
18225 int i = 0, n = 0, seen_question = 0, defgv = 0;
18226 I32 oa;
18227 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
18228 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
18229 bool nullret = FALSE;
18230
18231 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
18232
18233 assert (code);
18234
18235 if (!sv) sv = sv_newmortal();
18236
18237 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
18238
18239 switch (code < 0 ? -code : code) {
18240 case KEY_and : case KEY_chop: case KEY_chomp:
18241 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
18242 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
18243 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
18244 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
18245 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
18246 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
18247 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
18248 case KEY_x : case KEY_xor :
18249 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
18250 case KEY_glob: retsetpvs("_;", OP_GLOB);
18251 case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
18252 case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
18253 case KEY_each: retsetpvs("\\[%@]", OP_EACH);
18254 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
18255 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
18256 retsetpvs("", 0);
18257 case KEY_evalbytes:
18258 name = "entereval"; break;
18259 case KEY_readpipe:
18260 name = "backtick";
18261 }
18262
18263 #undef retsetpvs
18264
18265 findopnum:
18266 while (i < MAXO) { /* The slow way. */
18267 if (strEQ(name, PL_op_name[i])
18268 || strEQ(name, PL_op_desc[i]))
18269 {
18270 if (nullret) { assert(opnum); *opnum = i; return NULL; }
18271 goto found;
18272 }
18273 i++;
18274 }
18275 return NULL;
18276 found:
18277 defgv = PL_opargs[i] & OA_DEFGV;
18278 oa = PL_opargs[i] >> OASHIFT;
18279 while (oa) {
18280 if (oa & OA_OPTIONAL && !seen_question && (
18281 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
18282 )) {
18283 seen_question = 1;
18284 str[n++] = ';';
18285 }
18286 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
18287 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
18288 /* But globs are already references (kinda) */
18289 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
18290 ) {
18291 str[n++] = '\\';
18292 }
18293 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
18294 && !scalar_mod_type(NULL, i)) {
18295 str[n++] = '[';
18296 str[n++] = '$';
18297 str[n++] = '@';
18298 str[n++] = '%';
18299 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
18300 str[n++] = '*';
18301 str[n++] = ']';
18302 }
18303 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
18304 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
18305 str[n-1] = '_'; defgv = 0;
18306 }
18307 oa = oa >> 4;
18308 }
18309 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
18310 str[n++] = '\0';
18311 sv_setpvn(sv, str, n - 1);
18312 if (opnum) *opnum = i;
18313 return sv;
18314 }
18315
18316 OP *
Perl_coresub_op(pTHX_ SV * const coreargssv,const int code,const int opnum)18317 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
18318 const int opnum)
18319 {
18320 OP * const argop = (opnum == OP_SELECT && code) ? NULL :
18321 newSVOP(OP_COREARGS,0,coreargssv);
18322 OP *o;
18323
18324 PERL_ARGS_ASSERT_CORESUB_OP;
18325
18326 switch(opnum) {
18327 case 0:
18328 return op_append_elem(OP_LINESEQ,
18329 argop,
18330 newSLICEOP(0,
18331 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
18332 newOP(OP_CALLER,0)
18333 )
18334 );
18335 case OP_EACH:
18336 case OP_KEYS:
18337 case OP_VALUES:
18338 o = newUNOP(OP_AVHVSWITCH,0,argop);
18339 o->op_private = opnum-OP_EACH;
18340 return o;
18341 case OP_SELECT: /* which represents OP_SSELECT as well */
18342 if (code)
18343 return newCONDOP(
18344 0,
18345 newBINOP(OP_GT, 0,
18346 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
18347 newSVOP(OP_CONST, 0, newSVuv(1))
18348 ),
18349 coresub_op(newSVuv((UV)OP_SSELECT), 0,
18350 OP_SSELECT),
18351 coresub_op(coreargssv, 0, OP_SELECT)
18352 );
18353 /* FALLTHROUGH */
18354 default:
18355 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
18356 case OA_BASEOP:
18357 return op_append_elem(
18358 OP_LINESEQ, argop,
18359 newOP(opnum,
18360 opnum == OP_WANTARRAY || opnum == OP_RUNCV
18361 ? OPpOFFBYONE << 8 : 0)
18362 );
18363 case OA_BASEOP_OR_UNOP:
18364 if (opnum == OP_ENTEREVAL) {
18365 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
18366 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
18367 }
18368 else o = newUNOP(opnum,0,argop);
18369 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
18370 else {
18371 onearg:
18372 if (is_handle_constructor(o, 1))
18373 argop->op_private |= OPpCOREARGS_DEREF1;
18374 if (scalar_mod_type(NULL, opnum))
18375 argop->op_private |= OPpCOREARGS_SCALARMOD;
18376 }
18377 return o;
18378 default:
18379 o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
18380 if (is_handle_constructor(o, 2))
18381 argop->op_private |= OPpCOREARGS_DEREF2;
18382 if (opnum == OP_SUBSTR) {
18383 o->op_private |= OPpMAYBE_LVSUB;
18384 return o;
18385 }
18386 else goto onearg;
18387 }
18388 }
18389 }
18390
18391 void
Perl_report_redefined_cv(pTHX_ const SV * name,const CV * old_cv,SV * const * new_const_svp)18392 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
18393 SV * const *new_const_svp)
18394 {
18395 const char *hvname;
18396 bool is_const = !!CvCONST(old_cv);
18397 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
18398
18399 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
18400
18401 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
18402 return;
18403 /* They are 2 constant subroutines generated from
18404 the same constant. This probably means that
18405 they are really the "same" proxy subroutine
18406 instantiated in 2 places. Most likely this is
18407 when a constant is exported twice. Don't warn.
18408 */
18409 if (
18410 (ckWARN(WARN_REDEFINE)
18411 && !(
18412 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
18413 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
18414 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
18415 strEQ(hvname, "autouse"))
18416 )
18417 )
18418 || (is_const
18419 && ckWARN_d(WARN_REDEFINE)
18420 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
18421 )
18422 )
18423 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
18424 is_const
18425 ? "Constant subroutine %" SVf " redefined"
18426 : "Subroutine %" SVf " redefined",
18427 SVfARG(name));
18428 }
18429
18430 /*
18431 =head1 Hook manipulation
18432
18433 These functions provide convenient and thread-safe means of manipulating
18434 hook variables.
18435
18436 =cut
18437 */
18438
18439 /*
18440 =for apidoc wrap_op_checker
18441
18442 Puts a C function into the chain of check functions for a specified op
18443 type. This is the preferred way to manipulate the L</PL_check> array.
18444 C<opcode> specifies which type of op is to be affected. C<new_checker>
18445 is a pointer to the C function that is to be added to that opcode's
18446 check chain, and C<old_checker_p> points to the storage location where a
18447 pointer to the next function in the chain will be stored. The value of
18448 C<new_checker> is written into the L</PL_check> array, while the value
18449 previously stored there is written to C<*old_checker_p>.
18450
18451 L</PL_check> is global to an entire process, and a module wishing to
18452 hook op checking may find itself invoked more than once per process,
18453 typically in different threads. To handle that situation, this function
18454 is idempotent. The location C<*old_checker_p> must initially (once
18455 per process) contain a null pointer. A C variable of static duration
18456 (declared at file scope, typically also marked C<static> to give
18457 it internal linkage) will be implicitly initialised appropriately,
18458 if it does not have an explicit initialiser. This function will only
18459 actually modify the check chain if it finds C<*old_checker_p> to be null.
18460 This function is also thread safe on the small scale. It uses appropriate
18461 locking to avoid race conditions in accessing L</PL_check>.
18462
18463 When this function is called, the function referenced by C<new_checker>
18464 must be ready to be called, except for C<*old_checker_p> being unfilled.
18465 In a threading situation, C<new_checker> may be called immediately,
18466 even before this function has returned. C<*old_checker_p> will always
18467 be appropriately set before C<new_checker> is called. If C<new_checker>
18468 decides not to do anything special with an op that it is given (which
18469 is the usual case for most uses of op check hooking), it must chain the
18470 check function referenced by C<*old_checker_p>.
18471
18472 Taken all together, XS code to hook an op checker should typically look
18473 something like this:
18474
18475 static Perl_check_t nxck_frob;
18476 static OP *myck_frob(pTHX_ OP *op) {
18477 ...
18478 op = nxck_frob(aTHX_ op);
18479 ...
18480 return op;
18481 }
18482 BOOT:
18483 wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
18484
18485 If you want to influence compilation of calls to a specific subroutine,
18486 then use L</cv_set_call_checker_flags> rather than hooking checking of
18487 all C<entersub> ops.
18488
18489 =cut
18490 */
18491
18492 void
Perl_wrap_op_checker(pTHX_ Optype opcode,Perl_check_t new_checker,Perl_check_t * old_checker_p)18493 Perl_wrap_op_checker(pTHX_ Optype opcode,
18494 Perl_check_t new_checker, Perl_check_t *old_checker_p)
18495 {
18496 dVAR;
18497
18498 PERL_UNUSED_CONTEXT;
18499 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
18500 if (*old_checker_p) return;
18501 OP_CHECK_MUTEX_LOCK;
18502 if (!*old_checker_p) {
18503 *old_checker_p = PL_check[opcode];
18504 PL_check[opcode] = new_checker;
18505 }
18506 OP_CHECK_MUTEX_UNLOCK;
18507 }
18508
18509 #include "XSUB.h"
18510
18511 /* Efficient sub that returns a constant scalar value. */
18512 static void
const_sv_xsub(pTHX_ CV * cv)18513 const_sv_xsub(pTHX_ CV* cv)
18514 {
18515 dXSARGS;
18516 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
18517 PERL_UNUSED_ARG(items);
18518 if (!sv) {
18519 XSRETURN(0);
18520 }
18521 EXTEND(sp, 1);
18522 ST(0) = sv;
18523 XSRETURN(1);
18524 }
18525
18526 static void
const_av_xsub(pTHX_ CV * cv)18527 const_av_xsub(pTHX_ CV* cv)
18528 {
18529 dXSARGS;
18530 AV * const av = MUTABLE_AV(XSANY.any_ptr);
18531 SP -= items;
18532 assert(av);
18533 #ifndef DEBUGGING
18534 if (!av) {
18535 XSRETURN(0);
18536 }
18537 #endif
18538 if (SvRMAGICAL(av))
18539 Perl_croak(aTHX_ "Magical list constants are not supported");
18540 if (GIMME_V != G_ARRAY) {
18541 EXTEND(SP, 1);
18542 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
18543 XSRETURN(1);
18544 }
18545 EXTEND(SP, AvFILLp(av)+1);
18546 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
18547 XSRETURN(AvFILLp(av)+1);
18548 }
18549
18550 /* Copy an existing cop->cop_warnings field.
18551 * If it's one of the standard addresses, just re-use the address.
18552 * This is the e implementation for the DUP_WARNINGS() macro
18553 */
18554
18555 STRLEN*
Perl_dup_warnings(pTHX_ STRLEN * warnings)18556 Perl_dup_warnings(pTHX_ STRLEN* warnings)
18557 {
18558 Size_t size;
18559 STRLEN *new_warnings;
18560
18561 if (warnings == NULL || specialWARN(warnings))
18562 return warnings;
18563
18564 size = sizeof(*warnings) + *warnings;
18565
18566 new_warnings = (STRLEN*)PerlMemShared_malloc(size);
18567 Copy(warnings, new_warnings, size, char);
18568 return new_warnings;
18569 }
18570
18571 /*
18572 * ex: set ts=8 sts=4 sw=4 et:
18573 */
18574