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 and manipulate the OP
23 * 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_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
171
172 static const char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar";
173
174 /* remove any leading "empty" ops from the op_next chain whose first
175 * node's address is stored in op_p. Store the updated address of the
176 * first node in op_p.
177 */
178
179 void
Perl_op_prune_chain_head(OP ** op_p)180 Perl_op_prune_chain_head(OP** op_p)
181 {
182 PERL_ARGS_ASSERT_OP_PRUNE_CHAIN_HEAD;
183
184 while (*op_p
185 && ( (*op_p)->op_type == OP_NULL
186 || (*op_p)->op_type == OP_SCOPE
187 || (*op_p)->op_type == OP_SCALAR
188 || (*op_p)->op_type == OP_LINESEQ)
189 )
190 *op_p = (*op_p)->op_next;
191 }
192
193
194 /* See the explanatory comments above struct opslab in op.h. */
195
196 #ifdef PERL_DEBUG_READONLY_OPS
197 # define PERL_SLAB_SIZE 128
198 # define PERL_MAX_SLAB_SIZE 4096
199 # include <sys/mman.h>
200 #endif
201
202 #ifndef PERL_SLAB_SIZE
203 # define PERL_SLAB_SIZE 64
204 #endif
205 #ifndef PERL_MAX_SLAB_SIZE
206 # define PERL_MAX_SLAB_SIZE 2048
207 #endif
208
209 /* rounds up to nearest pointer */
210 #define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
211
212 #define DIFF(o,p) \
213 (assert(((char *)(p) - (char *)(o)) % sizeof(I32**) == 0), \
214 ((size_t)((I32 **)(p) - (I32**)(o))))
215
216 /* requires double parens and aTHX_ */
217 #define DEBUG_S_warn(args) \
218 DEBUG_S( \
219 PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
220 )
221
222 /* opslot_size includes the size of the slot header, and an op can't be smaller than BASEOP */
223 #define OPSLOT_SIZE_BASE (SIZE_TO_PSIZE(sizeof(OPSLOT)))
224
225 /* the number of bytes to allocate for a slab with sz * sizeof(I32 **) space for op */
226 #define OpSLABSizeBytes(sz) \
227 ((sz) * sizeof(I32 *) + STRUCT_OFFSET(OPSLAB, opslab_slots))
228
229 /* malloc a new op slab (suitable for attaching to PL_compcv).
230 * sz is in units of pointers from the beginning of opslab_opslots */
231
232 static OPSLAB *
S_new_slab(pTHX_ OPSLAB * head,size_t sz)233 S_new_slab(pTHX_ OPSLAB *head, size_t sz)
234 {
235 OPSLAB *slab;
236 size_t sz_bytes = OpSLABSizeBytes(sz);
237
238 /* opslot_offset is only U16 */
239 assert(sz < U16_MAX);
240 /* room for at least one op */
241 assert(sz >= OPSLOT_SIZE_BASE);
242
243 #ifdef PERL_DEBUG_READONLY_OPS
244 slab = (OPSLAB *) mmap(0, sz_bytes,
245 PROT_READ|PROT_WRITE,
246 MAP_ANON|MAP_PRIVATE, -1, 0);
247 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
248 (unsigned long) sz, slab));
249 if (slab == MAP_FAILED) {
250 perror("mmap failed");
251 abort();
252 }
253 #else
254 slab = (OPSLAB *)PerlMemShared_malloc(sz_bytes);
255 Zero(slab, sz_bytes, char);
256 #endif
257 slab->opslab_size = (U16)sz;
258
259 #ifndef WIN32
260 /* The context is unused in non-Windows */
261 PERL_UNUSED_CONTEXT;
262 #endif
263 slab->opslab_free_space = sz;
264 slab->opslab_head = head ? head : slab;
265 DEBUG_S_warn((aTHX_ "allocated new op slab sz 0x%x, %p, head slab %p",
266 (unsigned int)slab->opslab_size, (void*)slab,
267 (void*)(slab->opslab_head)));
268 return slab;
269 }
270
271 #define OPSLOT_SIZE_TO_INDEX(sz) ((sz) - OPSLOT_SIZE_BASE)
272
273 #define link_freed_op(slab, o) S_link_freed_op(aTHX_ slab, o)
274 static void
S_link_freed_op(pTHX_ OPSLAB * slab,OP * o)275 S_link_freed_op(pTHX_ OPSLAB *slab, OP *o) {
276 U16 sz = OpSLOT(o)->opslot_size;
277 U16 index = OPSLOT_SIZE_TO_INDEX(sz);
278
279 assert(sz >= OPSLOT_SIZE_BASE);
280 /* make sure the array is large enough to include ops this large */
281 if (!slab->opslab_freed) {
282 /* we don't have a free list array yet, make a new one */
283 slab->opslab_freed_size = index+1;
284 slab->opslab_freed = (OP**)PerlMemShared_calloc((slab->opslab_freed_size), sizeof(OP*));
285
286 if (!slab->opslab_freed)
287 croak_no_mem_ext(STR_WITH_LEN("op:link_freed_op"));
288 }
289 else if (index >= slab->opslab_freed_size) {
290 /* It's probably not worth doing exponential expansion here, the number of op sizes
291 is small.
292 */
293 /* We already have a list that isn't large enough, expand it */
294 size_t newsize = index+1;
295 OP **p = (OP **)PerlMemShared_realloc(slab->opslab_freed, newsize * sizeof(OP*));
296
297 if (!p)
298 croak_no_mem_ext(STR_WITH_LEN("op:link_freed_op"));
299
300 Zero(p+slab->opslab_freed_size, newsize - slab->opslab_freed_size, OP *);
301
302 slab->opslab_freed = p;
303 slab->opslab_freed_size = newsize;
304 }
305
306 o->op_next = slab->opslab_freed[index];
307 slab->opslab_freed[index] = o;
308 }
309
310 /* Returns a sz-sized block of memory (suitable for holding an op) from
311 * a free slot in the chain of op slabs attached to PL_compcv.
312 * Allocates a new slab if necessary.
313 * if PL_compcv isn't compiling, malloc() instead.
314 */
315
316 void *
Perl_Slab_Alloc(pTHX_ size_t sz)317 Perl_Slab_Alloc(pTHX_ size_t sz)
318 {
319 OPSLAB *head_slab; /* first slab in the chain */
320 OPSLAB *slab2;
321 OPSLOT *slot;
322 OP *o;
323 size_t sz_in_p; /* size in pointer units, including the OPSLOT header */
324
325 /* We only allocate ops from the slab during subroutine compilation.
326 We find the slab via PL_compcv, hence that must be non-NULL. It could
327 also be pointing to a subroutine which is now fully set up (CvROOT()
328 pointing to the top of the optree for that sub), or a subroutine
329 which isn't using the slab allocator. If our sanity checks aren't met,
330 don't use a slab, but allocate the OP directly from the heap. */
331 if (!PL_compcv || CvROOT(PL_compcv)
332 || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
333 {
334 o = (OP*)PerlMemShared_calloc(1, sz);
335 goto gotit;
336 }
337
338 /* While the subroutine is under construction, the slabs are accessed via
339 CvSTART(), to avoid needing to expand PVCV by one pointer for something
340 unneeded at runtime. Once a subroutine is constructed, the slabs are
341 accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
342 allocated yet. See the commit message for 8be227ab5eaa23f2 for more
343 details. */
344 if (!CvSTART(PL_compcv)) {
345 CvSTART(PL_compcv) =
346 (OP *)(head_slab = S_new_slab(aTHX_ NULL, PERL_SLAB_SIZE));
347 CvSLABBED_on(PL_compcv);
348 head_slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
349 }
350 else ++(head_slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
351
352 sz_in_p = SIZE_TO_PSIZE(sz + OPSLOT_HEADER);
353
354 /* The head slab for each CV maintains a free list of OPs. In particular, constant folding
355 will free up OPs, so it makes sense to re-use them where possible. A
356 freed up slot is used in preference to a new allocation. */
357 if (head_slab->opslab_freed &&
358 OPSLOT_SIZE_TO_INDEX(sz_in_p) < head_slab->opslab_freed_size) {
359 U16 base_index;
360
361 /* look for a large enough size with any freed ops */
362 for (base_index = OPSLOT_SIZE_TO_INDEX(sz_in_p);
363 base_index < head_slab->opslab_freed_size && !head_slab->opslab_freed[base_index];
364 ++base_index) {
365 }
366
367 if (base_index < head_slab->opslab_freed_size) {
368 /* found a freed op */
369 o = head_slab->opslab_freed[base_index];
370
371 DEBUG_S_warn((aTHX_ "realloced op at %p, slab %p, head slab %p",
372 (void *)o, (void *)OpMySLAB(o), (void *)head_slab));
373 head_slab->opslab_freed[base_index] = o->op_next;
374 Zero(o, sz, char);
375 o->op_slabbed = 1;
376 goto gotit;
377 }
378 }
379
380 #define INIT_OPSLOT(s) \
381 slot->opslot_offset = DIFF(&slab2->opslab_slots, slot) ; \
382 slot->opslot_size = s; \
383 slab2->opslab_free_space -= s; \
384 o = &slot->opslot_op; \
385 o->op_slabbed = 1
386
387 /* The partially-filled slab is next in the chain. */
388 slab2 = head_slab->opslab_next ? head_slab->opslab_next : head_slab;
389 if (slab2->opslab_free_space < sz_in_p) {
390 /* Remaining space is too small. */
391 /* If we can fit a BASEOP, add it to the free chain, so as not
392 to waste it. */
393 if (slab2->opslab_free_space >= OPSLOT_SIZE_BASE) {
394 slot = &slab2->opslab_slots;
395 INIT_OPSLOT(slab2->opslab_free_space);
396 o->op_type = OP_FREED;
397 DEBUG_S_warn((aTHX_ "linked unused op space at %p, slab %p, head slab %p",
398 (void *)o, (void *)slab2, (void *)head_slab));
399 link_freed_op(head_slab, o);
400 }
401
402 /* Create a new slab. Make this one twice as big. */
403 slab2 = S_new_slab(aTHX_ head_slab,
404 slab2->opslab_size > PERL_MAX_SLAB_SIZE / 2
405 ? PERL_MAX_SLAB_SIZE
406 : slab2->opslab_size * 2);
407 slab2->opslab_next = head_slab->opslab_next;
408 head_slab->opslab_next = slab2;
409 }
410 assert(slab2->opslab_size >= sz_in_p);
411
412 /* Create a new op slot */
413 slot = OpSLOToff(slab2, slab2->opslab_free_space - sz_in_p);
414 assert(slot >= &slab2->opslab_slots);
415 INIT_OPSLOT(sz_in_p);
416 DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p, head slab %p",
417 (void*)o, (void*)slab2, (void*)head_slab));
418
419 gotit:
420 /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
421 assert(!o->op_moresib);
422 assert(!o->op_sibparent);
423
424 return (void *)o;
425 }
426
427 #undef INIT_OPSLOT
428
429 #ifdef PERL_DEBUG_READONLY_OPS
430 void
Perl_Slab_to_ro(pTHX_ OPSLAB * slab)431 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
432 {
433 PERL_ARGS_ASSERT_SLAB_TO_RO;
434
435 if (slab->opslab_readonly) return;
436 slab->opslab_readonly = 1;
437 for (; slab; slab = slab->opslab_next) {
438 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
439 (unsigned long) slab->opslab_size, (void *)slab));*/
440 if (mprotect(slab, OpSLABSizeBytes(slab->opslab_size), PROT_READ))
441 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", (void *)slab,
442 (unsigned long)slab->opslab_size, errno);
443 }
444 }
445
446 void
Perl_Slab_to_rw(pTHX_ OPSLAB * const slab)447 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
448 {
449 OPSLAB *slab2;
450
451 PERL_ARGS_ASSERT_SLAB_TO_RW;
452
453 if (!slab->opslab_readonly) return;
454 slab2 = slab;
455 for (; slab2; slab2 = slab2->opslab_next) {
456 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
457 (unsigned long) size, (void *)slab2));*/
458 if (mprotect((void *)slab2, OpSLABSizeBytes(slab2->opslab_size),
459 PROT_READ|PROT_WRITE)) {
460 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", (void *)slab,
461 (unsigned long)slab2->opslab_size, errno);
462 }
463 }
464 slab->opslab_readonly = 0;
465 }
466
467 #else
468 # define Slab_to_rw(op) NOOP
469 #endif
470
471 /* make freed ops die if they're inadvertently executed */
472 #ifdef DEBUGGING
473 static OP *
S_pp_freed(pTHX)474 S_pp_freed(pTHX)
475 {
476 DIE(aTHX_ "panic: freed op 0x%p called\n", PL_op);
477 }
478 #endif
479
480
481 /* Return the block of memory used by an op to the free list of
482 * the OP slab associated with that op.
483 */
484
485 void
Perl_Slab_Free(pTHX_ void * op)486 Perl_Slab_Free(pTHX_ void *op)
487 {
488 OP * const o = (OP *)op;
489 OPSLAB *slab;
490
491 PERL_ARGS_ASSERT_SLAB_FREE;
492
493 #ifdef DEBUGGING
494 o->op_ppaddr = S_pp_freed;
495 #endif
496
497 if (!o->op_slabbed) {
498 if (!o->op_static)
499 PerlMemShared_free(op);
500 return;
501 }
502
503 slab = OpSLAB(o);
504 /* If this op is already freed, our refcount will get screwy. */
505 assert(o->op_type != OP_FREED);
506 o->op_type = OP_FREED;
507 link_freed_op(slab, o);
508 DEBUG_S_warn((aTHX_ "freeing op at %p, slab %p, head slab %p",
509 (void*)o, (void *)OpMySLAB(o), (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 = cBOOL(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, OpSLABSizeBytes(slab->opslab_size))) {
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 = OpSLOToff(slab2, slab2->opslab_free_space);
579 OPSLOT *end = OpSLOToff(slab2, slab2->opslab_size);
580 for (; slot < end;
581 slot = (OPSLOT*) ((I32**)slot + slot->opslot_size) )
582 {
583 if (slot->opslot_op.op_type != OP_FREED
584 && !(slot->opslot_op.op_savefree
585 #ifdef DEBUGGING
586 && ++savestack_count
587 #endif
588 )
589 ) {
590 assert(slot->opslot_op.op_slabbed);
591 op_free(&slot->opslot_op);
592 if (slab->opslab_refcnt == 1) goto free;
593 }
594 }
595 } while ((slab2 = slab2->opslab_next));
596 /* > 1 because the CV still holds a reference count. */
597 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
598 #ifdef DEBUGGING
599 assert(savestack_count == slab->opslab_refcnt-1);
600 #endif
601 /* Remove the CV’s reference count. */
602 slab->opslab_refcnt--;
603 return;
604 }
605 free:
606 opslab_free(slab);
607 }
608
609 #ifdef PERL_DEBUG_READONLY_OPS
610 OP *
Perl_op_refcnt_inc(pTHX_ OP * o)611 Perl_op_refcnt_inc(pTHX_ OP *o)
612 {
613 if(o) {
614 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
615 if (slab && slab->opslab_readonly) {
616 Slab_to_rw(slab);
617 ++o->op_targ;
618 Slab_to_ro(slab);
619 } else {
620 ++o->op_targ;
621 }
622 }
623 return o;
624
625 }
626
627 PADOFFSET
Perl_op_refcnt_dec(pTHX_ OP * o)628 Perl_op_refcnt_dec(pTHX_ OP *o)
629 {
630 PADOFFSET result;
631 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
632
633 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
634
635 if (slab && slab->opslab_readonly) {
636 Slab_to_rw(slab);
637 result = --o->op_targ;
638 Slab_to_ro(slab);
639 } else {
640 result = --o->op_targ;
641 }
642 return result;
643 }
644 #endif
645 /*
646 * In the following definition, the ", (OP*)0" is just to make the compiler
647 * think the expression is of the right type: croak actually does a Siglongjmp.
648 */
649 #define CHECKOP(type,o) \
650 ((PL_op_mask && PL_op_mask[type]) \
651 ? ( op_free((OP*)o), \
652 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
653 (OP*)0 ) \
654 : PL_check[type](aTHX_ (OP*)o))
655
656 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
657
658 STATIC OP *
S_no_fh_allowed(pTHX_ OP * o)659 S_no_fh_allowed(pTHX_ OP *o)
660 {
661 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
662
663 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
664 OP_DESC(o)));
665 return o;
666 }
667
668 STATIC OP *
S_too_few_arguments_pv(pTHX_ OP * o,const char * name,U32 flags)669 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
670 {
671 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
672 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
673 return o;
674 }
675
676 STATIC OP *
S_too_many_arguments_pv(pTHX_ OP * o,const char * name,U32 flags)677 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
678 {
679 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
680
681 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
682 return o;
683 }
684
685 STATIC void
S_bad_type_pv(pTHX_ I32 n,const char * t,const OP * o,const OP * kid)686 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
687 {
688 PERL_ARGS_ASSERT_BAD_TYPE_PV;
689
690 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
691 (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
692 }
693
694 STATIC void
S_bad_type_gv(pTHX_ I32 n,GV * gv,const OP * kid,const char * t)695 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
696 {
697 SV * const namesv = cv_name((CV *)gv, NULL, 0);
698 PERL_ARGS_ASSERT_BAD_TYPE_GV;
699
700 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)",
701 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
702 }
703
704 void
Perl_no_bareword_allowed(pTHX_ OP * o)705 Perl_no_bareword_allowed(pTHX_ OP *o)
706 {
707 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
708
709 qerror(Perl_mess(aTHX_
710 "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use",
711 SVfARG(cSVOPo_sv)));
712 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
713 }
714
715 /*
716 Return true if the supplied string is the name of one of the built-in
717 filehandles.
718 */
719
720 PERL_STATIC_INLINE bool
S_is_standard_filehandle_name(const char * fhname)721 S_is_standard_filehandle_name(const char *fhname) {
722 return strEQ(fhname, "STDERR")
723 || strEQ(fhname, "STDOUT")
724 || strEQ(fhname, "STDIN")
725 || strEQ(fhname, "_")
726 || strEQ(fhname, "ARGV")
727 || strEQ(fhname, "ARGVOUT")
728 || strEQ(fhname, "DATA");
729 }
730
731 void
Perl_no_bareword_filehandle(pTHX_ const char * fhname)732 Perl_no_bareword_filehandle(pTHX_ const char *fhname) {
733 PERL_ARGS_ASSERT_NO_BAREWORD_FILEHANDLE;
734
735 if (!is_standard_filehandle_name(fhname)) {
736 qerror(Perl_mess(aTHX_ "Bareword filehandle \"%s\" not allowed under 'no feature \"bareword_filehandles\"'", fhname));
737 }
738 }
739
740 /* "register" allocation */
741
742 PADOFFSET
Perl_allocmy(pTHX_ const char * const name,const STRLEN len,const U32 flags)743 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
744 {
745 PADOFFSET off;
746 bool is_idfirst, is_default;
747 const bool is_our = (PL_parser->in_my == KEY_our);
748
749 PERL_ARGS_ASSERT_ALLOCMY;
750
751 if (flags & ~SVf_UTF8)
752 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
753 (UV)flags);
754
755 is_idfirst = flags & SVf_UTF8
756 ? isIDFIRST_utf8_safe((U8*)name + 1, name + len)
757 : isIDFIRST_A(name[1]);
758
759 /* $_, @_, etc. */
760 is_default = len == 2 && name[1] == '_';
761
762 /* complain about "my $<special_var>" etc etc */
763 if (!is_our && (!is_idfirst || is_default)) {
764 const char * const type =
765 PL_parser->in_my == KEY_sigvar ? "subroutine signature" :
766 PL_parser->in_my == KEY_state ? "\"state\"" : "\"my\"";
767
768 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
769 && isASCII(name[1])
770 && (!isPRINT(name[1]) || memCHRs("\t\n\r\f", name[1]))) {
771 /* diag_listed_as: Can't use global %s in %s */
772 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in %s",
773 name[0], toCTRL(name[1]),
774 (int)(len - 2), name + 2,
775 type));
776 } else {
777 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in %s",
778 (int) len, name,
779 type), flags & SVf_UTF8);
780 }
781 }
782
783 /* allocate a spare slot and store the name in that slot */
784
785 U32 addflags = 0;
786 if(is_our)
787 addflags |= padadd_OUR;
788 else if(PL_parser->in_my == KEY_state)
789 addflags |= padadd_STATE;
790 else if(PL_parser->in_my == KEY_field)
791 addflags |= padadd_FIELD;
792
793 off = pad_add_name_pvn(name, len, addflags,
794 PL_parser->in_my_stash,
795 (is_our
796 /* $_ is always in main::, even with our */
797 ? (PL_curstash && !memEQs(name,len,"$_")
798 ? PL_curstash
799 : PL_defstash)
800 : NULL
801 )
802 );
803 /* anon sub prototypes contains state vars should always be cloned,
804 * otherwise the state var would be shared between anon subs */
805
806 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
807 CvCLONE_on(PL_compcv);
808
809 return off;
810 }
811
812 /*
813 =for apidoc_section $optree_manipulation
814
815 =for apidoc alloccopstash
816
817 Available only under threaded builds, this function allocates an entry in
818 C<PL_stashpad> for the stash passed to it.
819
820 =cut
821 */
822
823 #ifdef USE_ITHREADS
824 PADOFFSET
Perl_alloccopstash(pTHX_ HV * hv)825 Perl_alloccopstash(pTHX_ HV *hv)
826 {
827 PADOFFSET off = 0, o = 1;
828 bool found_slot = FALSE;
829
830 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
831
832 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
833
834 for (; o < PL_stashpadmax; ++o) {
835 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
836 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
837 found_slot = TRUE, off = o;
838 }
839 if (!found_slot) {
840 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
841 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
842 off = PL_stashpadmax;
843 PL_stashpadmax += 10;
844 }
845
846 PL_stashpad[PL_stashpadix = off] = hv;
847 return off;
848 }
849 #endif
850
851 /* free the body of an op without examining its contents.
852 * Always use this rather than FreeOp directly */
853
854 static void
S_op_destroy(pTHX_ OP * o)855 S_op_destroy(pTHX_ OP *o)
856 {
857 FreeOp(o);
858 }
859
860 /* Destructor */
861
862 /*
863 =for apidoc op_free
864
865 Free an op and its children. Only use this when an op is no longer linked
866 to from any optree.
867
868 Remember that any op with C<OPf_KIDS> set is expected to have a valid
869 C<op_first> pointer. If you are attempting to free an op but preserve its
870 child op, make sure to clear that flag before calling C<op_free()>. For
871 example:
872
873 OP *kid = o->op_first; o->op_first = NULL;
874 o->op_flags &= ~OPf_KIDS;
875 op_free(o);
876
877 =cut
878 */
879
880 void
Perl_op_free(pTHX_ OP * o)881 Perl_op_free(pTHX_ OP *o)
882 {
883 OPCODE type;
884 OP *top_op = o;
885 OP *next_op = o;
886 bool went_up = FALSE; /* whether we reached the current node by
887 following the parent pointer from a child, and
888 so have already seen this node */
889
890 if (!o || o->op_type == OP_FREED)
891 return;
892
893 if (o->op_private & OPpREFCOUNTED) {
894 /* if base of tree is refcounted, just decrement */
895 switch (o->op_type) {
896 case OP_LEAVESUB:
897 case OP_LEAVESUBLV:
898 case OP_LEAVEEVAL:
899 case OP_LEAVE:
900 case OP_SCOPE:
901 case OP_LEAVEWRITE:
902 {
903 PADOFFSET refcnt;
904 OP_REFCNT_LOCK;
905 refcnt = OpREFCNT_dec(o);
906 OP_REFCNT_UNLOCK;
907 if (refcnt) {
908 /* Need to find and remove any pattern match ops from
909 * the list we maintain for reset(). */
910 find_and_forget_pmops(o);
911 return;
912 }
913 }
914 break;
915 default:
916 break;
917 }
918 }
919
920 while (next_op) {
921 o = next_op;
922
923 /* free child ops before ourself, (then free ourself "on the
924 * way back up") */
925
926 /* Ensure the caller maintains the relationship between OPf_KIDS and
927 * op_first != NULL when restructuring the tree
928 * https://github.com/Perl/perl5/issues/20764
929 */
930 assert(!(o->op_flags & OPf_KIDS) || cUNOPo->op_first);
931
932 if (!went_up && o->op_flags & OPf_KIDS) {
933 next_op = cUNOPo->op_first;
934 continue;
935 }
936
937 /* find the next node to visit, *then* free the current node
938 * (can't rely on o->op_* fields being valid after o has been
939 * freed) */
940
941 /* The next node to visit will be either the sibling, or the
942 * parent if no siblings left, or NULL if we've worked our way
943 * back up to the top node in the tree */
944 next_op = (o == top_op) ? NULL : o->op_sibparent;
945 went_up = cBOOL(!OpHAS_SIBLING(o)); /* parents are already visited */
946
947 /* Now process the current node */
948
949 /* Though ops may be freed twice, freeing the op after its slab is a
950 big no-no. */
951 assert(!o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
952 /* During the forced freeing of ops after compilation failure, kidops
953 may be freed before their parents. */
954 if (!o || o->op_type == OP_FREED)
955 continue;
956
957 type = o->op_type;
958
959 /* an op should only ever acquire op_private flags that we know about.
960 * If this fails, you may need to fix something in regen/op_private.
961 * Don't bother testing if:
962 * * the op_ppaddr doesn't match the op; someone may have
963 * overridden the op and be doing strange things with it;
964 * * we've errored, as op flags are often left in an
965 * inconsistent state then. Note that an error when
966 * compiling the main program leaves PL_parser NULL, so
967 * we can't spot faults in the main code, only
968 * evaled/required code;
969 * * it's a banned op - we may be croaking before the op is
970 * fully formed. - see CHECKOP. */
971 #ifdef DEBUGGING
972 if ( o->op_ppaddr == PL_ppaddr[type]
973 && PL_parser
974 && !PL_parser->error_count
975 && !(PL_op_mask && PL_op_mask[type])
976 )
977 {
978 assert(!(o->op_private & ~PL_op_private_valid[type]));
979 }
980 #endif
981
982
983 /* Call the op_free hook if it has been set. Do it now so that it's called
984 * at the right time for refcounted ops, but still before all of the kids
985 * are freed. */
986 CALL_OPFREEHOOK(o);
987
988 if (type == OP_NULL)
989 type = (OPCODE)o->op_targ;
990
991 if (o->op_slabbed)
992 Slab_to_rw(OpSLAB(o));
993
994 /* COP* is not cleared by op_clear() so that we may track line
995 * numbers etc even after null() */
996 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
997 cop_free((COP*)o);
998 }
999
1000 op_clear(o);
1001 FreeOp(o);
1002 if (PL_op == o)
1003 PL_op = NULL;
1004 }
1005 }
1006
1007
1008 /* S_op_clear_gv(): free a GV attached to an OP */
1009
1010 STATIC
1011 #ifdef USE_ITHREADS
S_op_clear_gv(pTHX_ OP * o,PADOFFSET * ixp)1012 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
1013 #else
1014 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
1015 #endif
1016 {
1017
1018 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
1019 || o->op_type == OP_MULTIDEREF)
1020 #ifdef USE_ITHREADS
1021 && PL_curpad
1022 ? ((GV*)PAD_SVl(*ixp)) : NULL;
1023 #else
1024 ? (GV*)(*svp) : NULL;
1025 #endif
1026 /* It's possible during global destruction that the GV is freed
1027 before the optree. Whilst the SvREFCNT_inc is happy to bump from
1028 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
1029 will trigger an assertion failure, because the entry to sv_clear
1030 checks that the scalar is not already freed. A check of for
1031 !SvIS_FREED(gv) turns out to be invalid, because during global
1032 destruction the reference count can be forced down to zero
1033 (with SVf_BREAK set). In which case raising to 1 and then
1034 dropping to 0 triggers cleanup before it should happen. I
1035 *think* that this might actually be a general, systematic,
1036 weakness of the whole idea of SVf_BREAK, in that code *is*
1037 allowed to raise and lower references during global destruction,
1038 so any *valid* code that happens to do this during global
1039 destruction might well trigger premature cleanup. */
1040 bool still_valid = gv && SvREFCNT(gv);
1041
1042 if (still_valid)
1043 SvREFCNT_inc_simple_void(gv);
1044 #ifdef USE_ITHREADS
1045 if (*ixp > 0) {
1046 pad_swipe(*ixp, TRUE);
1047 *ixp = 0;
1048 }
1049 #else
1050 SvREFCNT_dec(*svp);
1051 *svp = NULL;
1052 #endif
1053 if (still_valid) {
1054 int try_downgrade = SvREFCNT(gv) == 2;
1055 SvREFCNT_dec_NN(gv);
1056 if (try_downgrade)
1057 gv_try_downgrade(gv);
1058 }
1059 }
1060
1061
1062 void
Perl_op_clear(pTHX_ OP * o)1063 Perl_op_clear(pTHX_ OP *o)
1064 {
1065
1066
1067 PERL_ARGS_ASSERT_OP_CLEAR;
1068
1069 switch (o->op_type) {
1070 case OP_NULL: /* Was holding old type, if any. */
1071 /* FALLTHROUGH */
1072 case OP_ENTERTRY:
1073 case OP_ENTEREVAL: /* Was holding hints. */
1074 case OP_ARGDEFELEM: /* Was holding signature index. */
1075 o->op_targ = 0;
1076 break;
1077 default:
1078 if (!(o->op_flags & OPf_REF) || !OP_IS_STAT(o->op_type))
1079 break;
1080 /* FALLTHROUGH */
1081 case OP_GVSV:
1082 case OP_GV:
1083 case OP_AELEMFAST:
1084 #ifdef USE_ITHREADS
1085 S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
1086 #else
1087 S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
1088 #endif
1089 break;
1090 case OP_METHOD_REDIR:
1091 case OP_METHOD_REDIR_SUPER:
1092 #ifdef USE_ITHREADS
1093 if (cMETHOPo->op_rclass_targ) {
1094 pad_swipe(cMETHOPo->op_rclass_targ, 1);
1095 cMETHOPo->op_rclass_targ = 0;
1096 }
1097 #else
1098 SvREFCNT_dec(cMETHOPo->op_rclass_sv);
1099 cMETHOPo->op_rclass_sv = NULL;
1100 #endif
1101 /* FALLTHROUGH */
1102 case OP_METHOD_NAMED:
1103 case OP_METHOD_SUPER:
1104 SvREFCNT_dec(cMETHOPo->op_u.op_meth_sv);
1105 cMETHOPo->op_u.op_meth_sv = NULL;
1106 #ifdef USE_ITHREADS
1107 if (o->op_targ) {
1108 pad_swipe(o->op_targ, 1);
1109 o->op_targ = 0;
1110 }
1111 #endif
1112 break;
1113 case OP_CONST:
1114 case OP_HINTSEVAL:
1115 SvREFCNT_dec(cSVOPo->op_sv);
1116 cSVOPo->op_sv = NULL;
1117 #ifdef USE_ITHREADS
1118 /** Bug #15654
1119 Even if op_clear does a pad_free for the target of the op,
1120 pad_free doesn't actually remove the sv that exists in the pad;
1121 instead it lives on. This results in that it could be reused as
1122 a target later on when the pad was reallocated.
1123 **/
1124 if(o->op_targ) {
1125 pad_swipe(o->op_targ,1);
1126 o->op_targ = 0;
1127 }
1128 #endif
1129 break;
1130 case OP_DUMP:
1131 case OP_GOTO:
1132 case OP_NEXT:
1133 case OP_LAST:
1134 case OP_REDO:
1135 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1136 break;
1137 /* FALLTHROUGH */
1138 case OP_TRANS:
1139 case OP_TRANSR:
1140 if ( (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
1141 && (o->op_private & OPpTRANS_USE_SVOP))
1142 {
1143 #ifdef USE_ITHREADS
1144 if (cPADOPo->op_padix > 0) {
1145 pad_swipe(cPADOPo->op_padix, TRUE);
1146 cPADOPo->op_padix = 0;
1147 }
1148 #else
1149 SvREFCNT_dec(cSVOPo->op_sv);
1150 cSVOPo->op_sv = NULL;
1151 #endif
1152 }
1153 else {
1154 PerlMemShared_free(cPVOPo->op_pv);
1155 cPVOPo->op_pv = NULL;
1156 }
1157 break;
1158 case OP_SUBST:
1159 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1160 goto clear_pmop;
1161
1162 case OP_SPLIT:
1163 if ( (o->op_private & OPpSPLIT_ASSIGN) /* @array = split */
1164 && !(o->op_flags & OPf_STACKED)) /* @{expr} = split */
1165 {
1166 if (o->op_private & OPpSPLIT_LEX)
1167 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1168 else
1169 #ifdef USE_ITHREADS
1170 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1171 #else
1172 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1173 #endif
1174 }
1175 /* FALLTHROUGH */
1176 case OP_MATCH:
1177 case OP_QR:
1178 clear_pmop:
1179 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1180 op_free(cPMOPo->op_code_list);
1181 cPMOPo->op_code_list = NULL;
1182 forget_pmop(cPMOPo);
1183 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1184 /* we use the same protection as the "SAFE" version of the PM_ macros
1185 * here since sv_clean_all might release some PMOPs
1186 * after PL_regex_padav has been cleared
1187 * and the clearing of PL_regex_padav needs to
1188 * happen before sv_clean_all
1189 */
1190 #ifdef USE_ITHREADS
1191 if(PL_regex_pad) { /* We could be in destruction */
1192 const IV offset = (cPMOPo)->op_pmoffset;
1193 ReREFCNT_dec(PM_GETRE(cPMOPo));
1194 PL_regex_pad[offset] = &PL_sv_undef;
1195 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1196 sizeof(offset));
1197 }
1198 #else
1199 ReREFCNT_dec(PM_GETRE(cPMOPo));
1200 PM_SETRE(cPMOPo, NULL);
1201 #endif
1202
1203 break;
1204
1205 case OP_ARGCHECK:
1206 PerlMemShared_free(cUNOP_AUXo->op_aux);
1207 break;
1208
1209 case OP_MULTICONCAT:
1210 {
1211 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
1212 /* aux[PERL_MULTICONCAT_IX_PLAIN_PV] and/or
1213 * aux[PERL_MULTICONCAT_IX_UTF8_PV] point to plain and/or
1214 * utf8 shared strings */
1215 char *p1 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
1216 char *p2 = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
1217 if (p1)
1218 PerlMemShared_free(p1);
1219 if (p2 && p1 != p2)
1220 PerlMemShared_free(p2);
1221 PerlMemShared_free(aux);
1222 }
1223 break;
1224
1225 case OP_MULTIDEREF:
1226 {
1227 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1228 UV actions = items->uv;
1229 bool last = 0;
1230 bool is_hash = FALSE;
1231
1232 while (!last) {
1233 switch (actions & MDEREF_ACTION_MASK) {
1234
1235 case MDEREF_reload:
1236 actions = (++items)->uv;
1237 continue;
1238
1239 case MDEREF_HV_padhv_helem:
1240 is_hash = TRUE;
1241 /* FALLTHROUGH */
1242 case MDEREF_AV_padav_aelem:
1243 pad_free((++items)->pad_offset);
1244 goto do_elem;
1245
1246 case MDEREF_HV_gvhv_helem:
1247 is_hash = TRUE;
1248 /* FALLTHROUGH */
1249 case MDEREF_AV_gvav_aelem:
1250 #ifdef USE_ITHREADS
1251 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1252 #else
1253 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1254 #endif
1255 goto do_elem;
1256
1257 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1258 is_hash = TRUE;
1259 /* FALLTHROUGH */
1260 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
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 goto do_vivify_rv2xv_elem;
1267
1268 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1269 is_hash = TRUE;
1270 /* FALLTHROUGH */
1271 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1272 pad_free((++items)->pad_offset);
1273 goto do_vivify_rv2xv_elem;
1274
1275 case MDEREF_HV_pop_rv2hv_helem:
1276 case MDEREF_HV_vivify_rv2hv_helem:
1277 is_hash = TRUE;
1278 /* FALLTHROUGH */
1279 do_vivify_rv2xv_elem:
1280 case MDEREF_AV_pop_rv2av_aelem:
1281 case MDEREF_AV_vivify_rv2av_aelem:
1282 do_elem:
1283 switch (actions & MDEREF_INDEX_MASK) {
1284 case MDEREF_INDEX_none:
1285 last = 1;
1286 break;
1287 case MDEREF_INDEX_const:
1288 if (is_hash) {
1289 #ifdef USE_ITHREADS
1290 /* see RT #15654 */
1291 pad_swipe((++items)->pad_offset, 1);
1292 #else
1293 SvREFCNT_dec((++items)->sv);
1294 #endif
1295 }
1296 else
1297 items++;
1298 break;
1299 case MDEREF_INDEX_padsv:
1300 pad_free((++items)->pad_offset);
1301 break;
1302 case MDEREF_INDEX_gvsv:
1303 #ifdef USE_ITHREADS
1304 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1305 #else
1306 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1307 #endif
1308 break;
1309 }
1310
1311 if (actions & MDEREF_FLAG_last)
1312 last = 1;
1313 is_hash = FALSE;
1314
1315 break;
1316
1317 default:
1318 assert(0);
1319 last = 1;
1320 break;
1321
1322 } /* switch */
1323
1324 actions >>= MDEREF_SHIFT;
1325 } /* while */
1326
1327 /* start of malloc is at op_aux[-1], where the length is
1328 * stored */
1329 PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1330 }
1331 break;
1332
1333 case OP_METHSTART:
1334 {
1335 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
1336 /* Every item in aux is a UV, so nothing in it to free */
1337 PerlMemShared_free(aux);
1338 }
1339 break;
1340
1341 case OP_INITFIELD:
1342 {
1343 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
1344 /* Every item in aux is a UV, so nothing in it to free */
1345 PerlMemShared_free(aux);
1346 }
1347 break;
1348 }
1349
1350 if (o->op_targ > 0) {
1351 pad_free(o->op_targ);
1352 o->op_targ = 0;
1353 }
1354 }
1355
1356 STATIC void
S_cop_free(pTHX_ COP * cop)1357 S_cop_free(pTHX_ COP* cop)
1358 {
1359 PERL_ARGS_ASSERT_COP_FREE;
1360
1361 /* If called during global destruction PL_defstash might be NULL and there
1362 shouldn't be any code running that will trip over the bad cop address.
1363 This also avoids uselessly creating the AV after it's been destroyed.
1364 */
1365 if (cop->op_type == OP_DBSTATE && PL_phase != PERL_PHASE_DESTRUCT) {
1366 /* Remove the now invalid op from the line number information.
1367 This could cause a freed memory overwrite if the debugger tried to
1368 set a breakpoint on this line.
1369 */
1370 AV *av = CopFILEAVn(cop);
1371 if (av) {
1372 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
1373 if (svp && *svp != &PL_sv_undef && SvIVX(*svp) == PTR2IV(cop) ) {
1374 SvIV_set(*svp, 0);
1375 }
1376 }
1377 }
1378 CopFILE_free(cop);
1379 if (! specialWARN(cop->cop_warnings))
1380 cop->cop_warnings = rcpv_free(cop->cop_warnings);
1381
1382 cophh_free(CopHINTHASH_get(cop));
1383 if (PL_curcop == cop)
1384 PL_curcop = NULL;
1385 }
1386
1387 STATIC void
S_forget_pmop(pTHX_ PMOP * const o)1388 S_forget_pmop(pTHX_ PMOP *const o)
1389 {
1390 HV * const pmstash = PmopSTASH(o);
1391
1392 PERL_ARGS_ASSERT_FORGET_PMOP;
1393
1394 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1395 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1396 if (mg) {
1397 PMOP **const array = (PMOP**) mg->mg_ptr;
1398 U32 count = mg->mg_len / sizeof(PMOP**);
1399 U32 i = count;
1400
1401 while (i--) {
1402 if (array[i] == o) {
1403 /* Found it. Move the entry at the end to overwrite it. */
1404 array[i] = array[--count];
1405 mg->mg_len = count * sizeof(PMOP**);
1406 /* Could realloc smaller at this point always, but probably
1407 not worth it. Probably worth free()ing if we're the
1408 last. */
1409 if(!count) {
1410 Safefree(mg->mg_ptr);
1411 mg->mg_ptr = NULL;
1412 }
1413 break;
1414 }
1415 }
1416 }
1417 }
1418 if (PL_curpm == o)
1419 PL_curpm = NULL;
1420 }
1421
1422
1423 STATIC void
S_find_and_forget_pmops(pTHX_ OP * o)1424 S_find_and_forget_pmops(pTHX_ OP *o)
1425 {
1426 OP* top_op = o;
1427
1428 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1429
1430 while (1) {
1431 switch (o->op_type) {
1432 case OP_SUBST:
1433 case OP_SPLIT:
1434 case OP_MATCH:
1435 case OP_QR:
1436 forget_pmop(cPMOPo);
1437 }
1438
1439 if (o->op_flags & OPf_KIDS) {
1440 o = cUNOPo->op_first;
1441 continue;
1442 }
1443
1444 while (1) {
1445 if (o == top_op)
1446 return; /* at top; no parents/siblings to try */
1447 if (OpHAS_SIBLING(o)) {
1448 o = o->op_sibparent; /* process next sibling */
1449 break;
1450 }
1451 o = o->op_sibparent; /*try parent's next sibling */
1452 }
1453 }
1454 }
1455
1456
1457 /*
1458 =for apidoc op_null
1459
1460 Neutralizes an op when it is no longer needed, but is still linked to from
1461 other ops.
1462
1463 =cut
1464 */
1465
1466 void
Perl_op_null(pTHX_ OP * o)1467 Perl_op_null(pTHX_ OP *o)
1468 {
1469
1470 PERL_ARGS_ASSERT_OP_NULL;
1471
1472 if (o->op_type == OP_NULL)
1473 return;
1474 op_clear(o);
1475 o->op_targ = o->op_type;
1476 OpTYPE_set(o, OP_NULL);
1477 }
1478
1479 /*
1480 =for apidoc op_refcnt_lock
1481
1482 Implements the C<OP_REFCNT_LOCK> macro which you should use instead.
1483
1484 =cut
1485 */
1486
1487 void
Perl_op_refcnt_lock(pTHX)1488 Perl_op_refcnt_lock(pTHX)
1489 PERL_TSA_ACQUIRE(PL_op_mutex)
1490 {
1491 PERL_UNUSED_CONTEXT;
1492 OP_REFCNT_LOCK;
1493 }
1494
1495 /*
1496 =for apidoc op_refcnt_unlock
1497
1498 Implements the C<OP_REFCNT_UNLOCK> macro which you should use instead.
1499
1500 =cut
1501 */
1502
1503 void
Perl_op_refcnt_unlock(pTHX)1504 Perl_op_refcnt_unlock(pTHX)
1505 PERL_TSA_RELEASE(PL_op_mutex)
1506 {
1507 PERL_UNUSED_CONTEXT;
1508 OP_REFCNT_UNLOCK;
1509 }
1510
1511
1512 /*
1513 =for apidoc op_sibling_splice
1514
1515 A general function for editing the structure of an existing chain of
1516 op_sibling nodes. By analogy with the perl-level C<splice()> function, allows
1517 you to delete zero or more sequential nodes, replacing them with zero or
1518 more different nodes. Performs the necessary op_first/op_last
1519 housekeeping on the parent node and op_sibling manipulation on the
1520 children. The last deleted node will be marked as the last node by
1521 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1522
1523 Note that op_next is not manipulated, and nodes are not freed; that is the
1524 responsibility of the caller. It also won't create a new list op for an
1525 empty list etc; use higher-level functions like op_append_elem() for that.
1526
1527 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1528 the splicing doesn't affect the first or last op in the chain.
1529
1530 C<start> is the node preceding the first node to be spliced. Node(s)
1531 following it will be deleted, and ops will be inserted after it. If it is
1532 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1533 beginning.
1534
1535 C<del_count> is the number of nodes to delete. If zero, no nodes are deleted.
1536 If -1 or greater than or equal to the number of remaining kids, all
1537 remaining kids are deleted.
1538
1539 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1540 If C<NULL>, no nodes are inserted.
1541
1542 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1543 deleted.
1544
1545 For example:
1546
1547 action before after returns
1548 ------ ----- ----- -------
1549
1550 P P
1551 splice(P, A, 2, X-Y-Z) | | B-C
1552 A-B-C-D A-X-Y-Z-D
1553
1554 P P
1555 splice(P, NULL, 1, X-Y) | | A
1556 A-B-C-D X-Y-B-C-D
1557
1558 P P
1559 splice(P, NULL, 3, NULL) | | A-B-C
1560 A-B-C-D D
1561
1562 P P
1563 splice(P, B, 0, X-Y) | | NULL
1564 A-B-C-D A-B-X-Y-C-D
1565
1566
1567 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1568 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1569
1570 =cut
1571 */
1572
1573 OP *
Perl_op_sibling_splice(OP * parent,OP * start,int del_count,OP * insert)1574 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1575 {
1576 OP *first;
1577 OP *rest;
1578 OP *last_del = NULL;
1579 OP *last_ins = NULL;
1580
1581 if (start)
1582 first = OpSIBLING(start);
1583 else if (!parent)
1584 goto no_parent;
1585 else
1586 first = cLISTOPx(parent)->op_first;
1587
1588 assert(del_count >= -1);
1589
1590 if (del_count && first) {
1591 last_del = first;
1592 while (--del_count && OpHAS_SIBLING(last_del))
1593 last_del = OpSIBLING(last_del);
1594 rest = OpSIBLING(last_del);
1595 OpLASTSIB_set(last_del, NULL);
1596 }
1597 else
1598 rest = first;
1599
1600 if (insert) {
1601 last_ins = insert;
1602 while (OpHAS_SIBLING(last_ins))
1603 last_ins = OpSIBLING(last_ins);
1604 OpMAYBESIB_set(last_ins, rest, NULL);
1605 }
1606 else
1607 insert = rest;
1608
1609 if (start) {
1610 OpMAYBESIB_set(start, insert, NULL);
1611 }
1612 else {
1613 assert(parent);
1614 cLISTOPx(parent)->op_first = insert;
1615 if (insert)
1616 parent->op_flags |= OPf_KIDS;
1617 else
1618 parent->op_flags &= ~OPf_KIDS;
1619 }
1620
1621 if (!rest) {
1622 /* update op_last etc */
1623 U32 type;
1624 OP *lastop;
1625
1626 if (!parent)
1627 goto no_parent;
1628
1629 /* ought to use OP_CLASS(parent) here, but that can't handle
1630 * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1631 * either */
1632 type = parent->op_type;
1633 if (type == OP_CUSTOM) {
1634 dTHX;
1635 type = XopENTRYCUSTOM(parent, xop_class);
1636 }
1637 else {
1638 if (type == OP_NULL)
1639 type = parent->op_targ;
1640 type = PL_opargs[type] & OA_CLASS_MASK;
1641 }
1642
1643 lastop = last_ins ? last_ins : start ? start : NULL;
1644 if ( type == OA_BINOP
1645 || type == OA_LISTOP
1646 || type == OA_PMOP
1647 || type == OA_LOOP
1648 )
1649 cLISTOPx(parent)->op_last = lastop;
1650
1651 if (lastop)
1652 OpLASTSIB_set(lastop, parent);
1653 }
1654 return last_del ? first : NULL;
1655
1656 no_parent:
1657 Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1658 }
1659
1660 /*
1661 =for apidoc op_parent
1662
1663 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1664
1665 =cut
1666 */
1667
1668 OP *
Perl_op_parent(OP * o)1669 Perl_op_parent(OP *o)
1670 {
1671 PERL_ARGS_ASSERT_OP_PARENT;
1672 while (OpHAS_SIBLING(o))
1673 o = OpSIBLING(o);
1674 return o->op_sibparent;
1675 }
1676
1677 /* replace the sibling following start with a new UNOP, which becomes
1678 * the parent of the original sibling; e.g.
1679 *
1680 * op_sibling_newUNOP(P, A, unop-args...)
1681 *
1682 * P P
1683 * | becomes |
1684 * A-B-C A-U-C
1685 * |
1686 * B
1687 *
1688 * where U is the new UNOP.
1689 *
1690 * parent and start args are the same as for op_sibling_splice();
1691 * type and flags args are as newUNOP().
1692 *
1693 * Returns the new UNOP.
1694 */
1695
1696 STATIC OP *
S_op_sibling_newUNOP(pTHX_ OP * parent,OP * start,I32 type,I32 flags)1697 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1698 {
1699 OP *kid, *newop;
1700
1701 kid = op_sibling_splice(parent, start, 1, NULL);
1702 newop = newUNOP(type, flags, kid);
1703 op_sibling_splice(parent, start, 0, newop);
1704 return newop;
1705 }
1706
1707
1708 /* lowest-level newLOGOP-style function - just allocates and populates
1709 * the struct. Higher-level stuff should be done by S_new_logop() /
1710 * newLOGOP(). This function exists mainly to avoid op_first assignment
1711 * being spread throughout this file.
1712 */
1713
1714 LOGOP *
Perl_alloc_LOGOP(pTHX_ I32 type,OP * first,OP * other)1715 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1716 {
1717 LOGOP *logop;
1718 OP *kid = first;
1719 NewOp(1101, logop, 1, LOGOP);
1720 OpTYPE_set(logop, type);
1721 logop->op_first = first;
1722 logop->op_other = other;
1723 if (first)
1724 logop->op_flags = OPf_KIDS;
1725 while (kid && OpHAS_SIBLING(kid))
1726 kid = OpSIBLING(kid);
1727 if (kid)
1728 OpLASTSIB_set(kid, (OP*)logop);
1729 return logop;
1730 }
1731
1732
1733 /* Contextualizers */
1734
1735 /*
1736 =for apidoc op_contextualize
1737
1738 Applies a syntactic context to an op tree representing an expression.
1739 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_LIST>,
1740 or C<G_VOID> to specify the context to apply. The modified op tree
1741 is returned.
1742
1743 =cut
1744 */
1745
1746 OP *
Perl_op_contextualize(pTHX_ OP * o,I32 context)1747 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1748 {
1749 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1750 switch (context) {
1751 case G_SCALAR: return scalar(o);
1752 case G_LIST: return list(o);
1753 case G_VOID: return scalarvoid(o);
1754 default:
1755 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1756 (long) context);
1757 }
1758 }
1759
1760 /*
1761
1762 =for apidoc op_linklist
1763 This function is the implementation of the L</LINKLIST> macro. It should
1764 not be called directly.
1765
1766 =cut
1767 */
1768
1769
1770 OP *
Perl_op_linklist(pTHX_ OP * o)1771 Perl_op_linklist(pTHX_ OP *o)
1772 {
1773
1774 OP **prevp;
1775 OP *kid;
1776 OP * top_op = o;
1777
1778 PERL_ARGS_ASSERT_OP_LINKLIST;
1779
1780 while (1) {
1781 /* Descend down the tree looking for any unprocessed subtrees to
1782 * do first */
1783 if (!o->op_next) {
1784 if (o->op_flags & OPf_KIDS) {
1785 o = cUNOPo->op_first;
1786 continue;
1787 }
1788 o->op_next = o; /* leaf node; link to self initially */
1789 }
1790
1791 /* if we're at the top level, there either weren't any children
1792 * to process, or we've worked our way back to the top. */
1793 if (o == top_op)
1794 return o->op_next;
1795
1796 /* o is now processed. Next, process any sibling subtrees */
1797
1798 if (OpHAS_SIBLING(o)) {
1799 o = OpSIBLING(o);
1800 continue;
1801 }
1802
1803 /* Done all the subtrees at this level. Go back up a level and
1804 * link the parent in with all its (processed) children.
1805 */
1806
1807 o = o->op_sibparent;
1808 assert(!o->op_next);
1809 prevp = &(o->op_next);
1810 kid = (o->op_flags & OPf_KIDS) ? cUNOPo->op_first : NULL;
1811 while (kid) {
1812 *prevp = kid->op_next;
1813 prevp = &(kid->op_next);
1814 kid = OpSIBLING(kid);
1815 }
1816 *prevp = o;
1817 }
1818 }
1819
1820
1821 static OP *
S_scalarkids(pTHX_ OP * o)1822 S_scalarkids(pTHX_ OP *o)
1823 {
1824 if (o && o->op_flags & OPf_KIDS) {
1825 OP *kid;
1826 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1827 scalar(kid);
1828 }
1829 return o;
1830 }
1831
1832 STATIC OP *
S_scalarboolean(pTHX_ OP * o)1833 S_scalarboolean(pTHX_ OP *o)
1834 {
1835 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1836
1837 if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1838 !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1839 (o->op_type == OP_NOT && cUNOPo->op_first->op_type == OP_SASSIGN &&
1840 cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1841 !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1842 if (ckWARN(WARN_SYNTAX)) {
1843 const line_t oldline = CopLINE(PL_curcop);
1844
1845 if (PL_parser && PL_parser->copline != NOLINE) {
1846 /* This ensures that warnings are reported at the first line
1847 of the conditional, not the last. */
1848 CopLINE_set(PL_curcop, PL_parser->copline);
1849 }
1850 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1851 CopLINE_set(PL_curcop, oldline);
1852 }
1853 }
1854 return scalar(o);
1855 }
1856
1857 static SV *
S_op_varname_subscript(pTHX_ const OP * o,int subscript_type)1858 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1859 {
1860 assert(o);
1861 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1862 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1863 {
1864 const char funny = o->op_type == OP_PADAV
1865 || o->op_type == OP_RV2AV ? '@' : '%';
1866 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1867 GV *gv;
1868 if (cUNOPo->op_first->op_type != OP_GV
1869 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1870 return NULL;
1871 return varname(gv, funny, 0, NULL, 0, subscript_type);
1872 }
1873 return
1874 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1875 }
1876 }
1877
1878 SV *
Perl_op_varname(pTHX_ const OP * o)1879 Perl_op_varname(pTHX_ const OP *o)
1880 {
1881 PERL_ARGS_ASSERT_OP_VARNAME;
1882
1883 return S_op_varname_subscript(aTHX_ o, 1);
1884 }
1885
1886 /*
1887
1888 Warns that an access of a single element from a named container variable in
1889 scalar context might not be what the programmer wanted. The container
1890 variable's (sigiled, full) name is given by C<name>, and the key to access
1891 it is given by the C<SVOP_sv> of the C<OP_CONST> op given by C<o>.
1892 C<is_hash> selects whether it prints using {KEY} or [KEY] brackets.
1893
1894 C<is_slice> selects between two different messages used in different places.
1895 */
1896 void
Perl_warn_elem_scalar_context(pTHX_ const OP * o,SV * name,bool is_hash,bool is_slice)1897 Perl_warn_elem_scalar_context(pTHX_ const OP *o, SV *name, bool is_hash, bool is_slice)
1898 {
1899 PERL_ARGS_ASSERT_WARN_ELEM_SCALAR_CONTEXT;
1900
1901 SV *keysv = NULL;
1902 const char *keypv = NULL;
1903
1904 const char lbrack = is_hash ? '{' : '[';
1905 const char rbrack = is_hash ? '}' : ']';
1906
1907 if (o->op_type == OP_CONST) {
1908 keysv = cSVOPo_sv;
1909 if (SvPOK(keysv)) {
1910 SV *sv = keysv;
1911 keysv = sv_newmortal();
1912 pv_pretty(keysv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1913 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1914 }
1915 else if (!SvOK(keysv))
1916 keypv = "undef";
1917 }
1918 else keypv = "...";
1919
1920 assert(SvPOK(name));
1921 sv_chop(name,SvPVX(name)+1);
1922
1923 const char *msg;
1924
1925 if (keypv) {
1926 msg = is_slice ?
1927 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1928 PERL_DIAG_WARN_SYNTAX(
1929 "Scalar value @%" SVf "%c%s%c better written as $%" SVf "%c%s%c") :
1930 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1931 PERL_DIAG_WARN_SYNTAX(
1932 "%%%" SVf "%c%s%c in scalar context better written as $%" SVf "%c%s%c");
1933
1934 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), msg,
1935 SVfARG(name), lbrack, keypv, rbrack,
1936 SVfARG(name), lbrack, keypv, rbrack);
1937 }
1938 else {
1939 msg = is_slice ?
1940 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1941 PERL_DIAG_WARN_SYNTAX(
1942 "Scalar value @%" SVf "%c%" SVf "%c better written as $%" SVf "%c%" SVf "%c") :
1943 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1944 PERL_DIAG_WARN_SYNTAX(
1945 "%%%" SVf "%c%" SVf "%c in scalar context better written as $%" SVf "%c%" SVf "%c");
1946
1947 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), msg,
1948 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1949 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1950 }
1951 }
1952
1953
1954 /* apply scalar context to the o subtree */
1955
1956 OP *
Perl_scalar(pTHX_ OP * o)1957 Perl_scalar(pTHX_ OP *o)
1958 {
1959 OP * top_op = o;
1960
1961 while (1) {
1962 OP *next_kid = NULL; /* what op (if any) to process next */
1963 OP *kid;
1964
1965 /* assumes no premature commitment */
1966 if (!o || (PL_parser && PL_parser->error_count)
1967 || (o->op_flags & OPf_WANT)
1968 || o->op_type == OP_RETURN)
1969 {
1970 goto do_next;
1971 }
1972
1973 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1974
1975 switch (o->op_type) {
1976 case OP_REPEAT:
1977 scalar(cBINOPo->op_first);
1978 /* convert what initially looked like a list repeat into a
1979 * scalar repeat, e.g. $s = (1) x $n
1980 */
1981 if (o->op_private & OPpREPEAT_DOLIST) {
1982 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1983 assert(kid->op_type == OP_PUSHMARK);
1984 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1985 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1986 o->op_private &=~ OPpREPEAT_DOLIST;
1987 }
1988 }
1989 break;
1990
1991 case OP_OR:
1992 case OP_AND:
1993 case OP_COND_EXPR:
1994 /* impose scalar context on everything except the condition */
1995 next_kid = OpSIBLING(cUNOPo->op_first);
1996 break;
1997
1998 default:
1999 if (o->op_flags & OPf_KIDS)
2000 next_kid = cUNOPo->op_first; /* do all kids */
2001 break;
2002
2003 /* the children of these ops are usually a list of statements,
2004 * except the leaves, whose first child is a corresponding enter
2005 */
2006 case OP_SCOPE:
2007 case OP_LINESEQ:
2008 case OP_LIST:
2009 kid = cLISTOPo->op_first;
2010 goto do_kids;
2011 case OP_LEAVE:
2012 case OP_LEAVETRY:
2013 kid = cLISTOPo->op_first;
2014 scalar(kid);
2015 kid = OpSIBLING(kid);
2016 do_kids:
2017 while (kid) {
2018 OP *sib = OpSIBLING(kid);
2019 /* Apply void context to all kids except the last, which
2020 * is scalar (ignoring a trailing ex-nextstate in determining
2021 * if it's the last kid). E.g.
2022 * $scalar = do { void; void; scalar }
2023 * Except that 'when's are always scalar, e.g.
2024 * $scalar = do { given(..) {
2025 * when (..) { scalar }
2026 * when (..) { scalar }
2027 * ...
2028 * }}
2029 */
2030 if (!sib
2031 || ( !OpHAS_SIBLING(sib)
2032 && sib->op_type == OP_NULL
2033 && ( sib->op_targ == OP_NEXTSTATE
2034 || sib->op_targ == OP_DBSTATE )
2035 )
2036 )
2037 {
2038 /* tail call optimise calling scalar() on the last kid */
2039 next_kid = kid;
2040 goto do_next;
2041 }
2042 else if (kid->op_type == OP_LEAVEWHEN)
2043 scalar(kid);
2044 else
2045 scalarvoid(kid);
2046 kid = sib;
2047 }
2048 NOT_REACHED; /* NOTREACHED */
2049 break;
2050
2051 case OP_SORT:
2052 Perl_ck_warner(aTHX_ packWARN(WARN_SCALAR), "Useless use of %s in scalar context", "sort");
2053 break;
2054
2055 case OP_KVHSLICE:
2056 case OP_KVASLICE:
2057 {
2058 /* Warn about scalar context */
2059 SV *name;
2060
2061 /* This warning can be nonsensical when there is a syntax error. */
2062 if (PL_parser && PL_parser->error_count)
2063 break;
2064
2065 if (!ckWARN(WARN_SYNTAX)) break;
2066
2067 kid = cLISTOPo->op_first;
2068 kid = OpSIBLING(kid); /* get past pushmark */
2069 assert(OpSIBLING(kid));
2070 name = op_varname(OpSIBLING(kid));
2071 if (!name) /* XS module fiddling with the op tree */
2072 break;
2073 warn_elem_scalar_context(kid, name, o->op_type == OP_KVHSLICE, false);
2074 }
2075 } /* switch */
2076
2077 /* If next_kid is set, someone in the code above wanted us to process
2078 * that kid and all its remaining siblings. Otherwise, work our way
2079 * back up the tree */
2080 do_next:
2081 while (!next_kid) {
2082 if (o == top_op)
2083 return top_op; /* at top; no parents/siblings to try */
2084 if (OpHAS_SIBLING(o))
2085 next_kid = o->op_sibparent;
2086 else {
2087 o = o->op_sibparent; /*try parent's next sibling */
2088 switch (o->op_type) {
2089 case OP_SCOPE:
2090 case OP_LINESEQ:
2091 case OP_LIST:
2092 case OP_LEAVE:
2093 case OP_LEAVETRY:
2094 /* should really restore PL_curcop to its old value, but
2095 * setting it to PL_compiling is better than do nothing */
2096 PL_curcop = &PL_compiling;
2097 }
2098 }
2099 }
2100 o = next_kid;
2101 } /* while */
2102 }
2103
2104
2105 /* apply void context to the optree arg */
2106
2107 OP *
Perl_scalarvoid(pTHX_ OP * arg)2108 Perl_scalarvoid(pTHX_ OP *arg)
2109 {
2110 OP *kid;
2111 SV* sv;
2112 OP *o = arg;
2113
2114 PERL_ARGS_ASSERT_SCALARVOID;
2115
2116 while (1) {
2117 U8 want;
2118 SV *useless_sv = NULL;
2119 const char* useless = NULL;
2120 OP * next_kid = NULL;
2121
2122 if (o->op_type == OP_NEXTSTATE
2123 || o->op_type == OP_DBSTATE
2124 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
2125 || o->op_targ == OP_DBSTATE)))
2126 PL_curcop = (COP*)o; /* for warning below */
2127
2128 /* assumes no premature commitment */
2129 want = o->op_flags & OPf_WANT;
2130 if ((want && want != OPf_WANT_SCALAR)
2131 || (PL_parser && PL_parser->error_count)
2132 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
2133 {
2134 goto get_next_op;
2135 }
2136
2137 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
2138
2139 switch (o->op_type) {
2140 default:
2141 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
2142 break;
2143 /* FALLTHROUGH */
2144 case OP_REPEAT:
2145 if (o->op_flags & OPf_STACKED)
2146 break;
2147 if (o->op_type == OP_REPEAT)
2148 scalar(cBINOPo->op_first);
2149 goto func_ops;
2150 case OP_CONCAT:
2151 if ((o->op_flags & OPf_STACKED) &&
2152 !(o->op_private & OPpCONCAT_NESTED))
2153 break;
2154 goto func_ops;
2155 case OP_SUBSTR:
2156 if (o->op_private == 4)
2157 break;
2158 /* FALLTHROUGH */
2159 case OP_WANTARRAY:
2160 case OP_GV:
2161 case OP_SMARTMATCH:
2162 case OP_AV2ARYLEN:
2163 case OP_REF:
2164 case OP_REFGEN:
2165 case OP_SREFGEN:
2166 case OP_ANONCODE:
2167 case OP_DEFINED:
2168 case OP_HEX:
2169 case OP_OCT:
2170 case OP_LENGTH:
2171 case OP_VEC:
2172 case OP_INDEX:
2173 case OP_RINDEX:
2174 case OP_SPRINTF:
2175 case OP_KVASLICE:
2176 case OP_KVHSLICE:
2177 case OP_UNPACK:
2178 case OP_PACK:
2179 case OP_JOIN:
2180 case OP_LSLICE:
2181 case OP_ANONLIST:
2182 case OP_ANONHASH:
2183 case OP_SORT:
2184 case OP_REVERSE:
2185 case OP_RANGE:
2186 case OP_FLIP:
2187 case OP_FLOP:
2188 case OP_CALLER:
2189 case OP_FILENO:
2190 case OP_EOF:
2191 case OP_TELL:
2192 case OP_GETSOCKNAME:
2193 case OP_GETPEERNAME:
2194 case OP_READLINK:
2195 case OP_TELLDIR:
2196 case OP_GETPPID:
2197 case OP_GETPGRP:
2198 case OP_GETPRIORITY:
2199 case OP_TIME:
2200 case OP_TMS:
2201 case OP_LOCALTIME:
2202 case OP_GMTIME:
2203 case OP_GHBYNAME:
2204 case OP_GHBYADDR:
2205 case OP_GHOSTENT:
2206 case OP_GNBYNAME:
2207 case OP_GNBYADDR:
2208 case OP_GNETENT:
2209 case OP_GPBYNAME:
2210 case OP_GPBYNUMBER:
2211 case OP_GPROTOENT:
2212 case OP_GSBYNAME:
2213 case OP_GSBYPORT:
2214 case OP_GSERVENT:
2215 case OP_GPWNAM:
2216 case OP_GPWUID:
2217 case OP_GGRNAM:
2218 case OP_GGRGID:
2219 case OP_GETLOGIN:
2220 case OP_PROTOTYPE:
2221 case OP_RUNCV:
2222 func_ops:
2223 if ( (PL_opargs[o->op_type] & OA_TARGLEX)
2224 && (o->op_private & OPpTARGET_MY)
2225 )
2226 /* '$lex = $a + $b' etc is optimised to '$a + $b' but
2227 * where the add op's TARG is actually $lex. So it's not
2228 * useless to be in void context in this special case */
2229 break;
2230
2231 useless = OP_DESC(o);
2232 break;
2233
2234 case OP_GVSV:
2235 case OP_PADSV:
2236 case OP_PADAV:
2237 case OP_PADHV:
2238 case OP_PADANY:
2239 case OP_AELEM:
2240 case OP_AELEMFAST:
2241 case OP_AELEMFAST_LEX:
2242 case OP_ASLICE:
2243 case OP_HELEM:
2244 case OP_HSLICE:
2245 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
2246 /* Otherwise it's "Useless use of grep iterator" */
2247 useless = OP_DESC(o);
2248 break;
2249
2250 case OP_SPLIT:
2251 if (!(o->op_private & OPpSPLIT_ASSIGN))
2252 useless = OP_DESC(o);
2253 break;
2254
2255 case OP_NOT:
2256 kid = cUNOPo->op_first;
2257 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2258 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2259 goto func_ops;
2260 }
2261 useless = "negative pattern binding (!~)";
2262 break;
2263
2264 case OP_SUBST:
2265 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2266 useless = "non-destructive substitution (s///r)";
2267 break;
2268
2269 case OP_TRANSR:
2270 useless = "non-destructive transliteration (tr///r)";
2271 break;
2272
2273 case OP_RV2GV:
2274 case OP_RV2SV:
2275 case OP_RV2AV:
2276 case OP_RV2HV:
2277 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2278 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2279 useless = "a variable";
2280 break;
2281
2282 case OP_CONST:
2283 sv = cSVOPo_sv;
2284 if (cSVOPo->op_private & OPpCONST_STRICT)
2285 no_bareword_allowed(o);
2286 else {
2287 if (ckWARN(WARN_VOID)) {
2288 NV nv;
2289 /* don't warn on optimised away booleans, eg
2290 * use constant Foo, 5; Foo || print; */
2291 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2292 useless = NULL;
2293 /* the constants 0 and 1 are permitted as they are
2294 conventionally used as dummies in constructs like
2295 1 while some_condition_with_side_effects; */
2296 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2297 useless = NULL;
2298 else if (SvPOK(sv)) {
2299 SV * const dsv = newSVpvs("");
2300 useless_sv
2301 = Perl_newSVpvf(aTHX_
2302 "a constant (%s)",
2303 pv_pretty(dsv, SvPVX_const(sv),
2304 SvCUR(sv), 32, NULL, NULL,
2305 PERL_PV_PRETTY_DUMP
2306 | PERL_PV_ESCAPE_NOCLEAR
2307 | PERL_PV_ESCAPE_UNI_DETECT));
2308 SvREFCNT_dec_NN(dsv);
2309 }
2310 else if (SvOK(sv)) {
2311 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2312 }
2313 else
2314 useless = "a constant (undef)";
2315 }
2316 }
2317 op_null(o); /* don't execute or even remember it */
2318 break;
2319
2320 case OP_POSTINC:
2321 OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */
2322 break;
2323
2324 case OP_POSTDEC:
2325 OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */
2326 break;
2327
2328 case OP_I_POSTINC:
2329 OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */
2330 break;
2331
2332 case OP_I_POSTDEC:
2333 OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */
2334 break;
2335
2336 case OP_SASSIGN: {
2337 OP *rv2gv;
2338 UNOP *refgen, *rv2cv;
2339 LISTOP *exlist;
2340
2341 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2342 break;
2343
2344 rv2gv = cBINOPo->op_last;
2345 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2346 break;
2347
2348 refgen = cUNOPx(cBINOPo->op_first);
2349
2350 if (!refgen || (refgen->op_type != OP_REFGEN
2351 && refgen->op_type != OP_SREFGEN))
2352 break;
2353
2354 exlist = cLISTOPx(refgen->op_first);
2355 if (!exlist || exlist->op_type != OP_NULL
2356 || exlist->op_targ != OP_LIST)
2357 break;
2358
2359 if (exlist->op_first->op_type != OP_PUSHMARK
2360 && exlist->op_first != exlist->op_last)
2361 break;
2362
2363 rv2cv = cUNOPx(exlist->op_last);
2364
2365 if (rv2cv->op_type != OP_RV2CV)
2366 break;
2367
2368 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2369 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2370 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2371
2372 o->op_private |= OPpASSIGN_CV_TO_GV;
2373 rv2gv->op_private |= OPpDONT_INIT_GV;
2374 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2375
2376 break;
2377 }
2378
2379 case OP_AASSIGN: {
2380 inplace_aassign(o);
2381 break;
2382 }
2383
2384 case OP_OR:
2385 case OP_AND:
2386 kid = cLOGOPo->op_first;
2387 if (kid->op_type == OP_NOT
2388 && (kid->op_flags & OPf_KIDS)) {
2389 if (o->op_type == OP_AND) {
2390 OpTYPE_set(o, OP_OR);
2391 } else {
2392 OpTYPE_set(o, OP_AND);
2393 }
2394 op_null(kid);
2395 }
2396 /* FALLTHROUGH */
2397
2398 case OP_DOR:
2399 case OP_COND_EXPR:
2400 case OP_ENTERGIVEN:
2401 case OP_ENTERWHEN:
2402 next_kid = OpSIBLING(cUNOPo->op_first);
2403 break;
2404
2405 case OP_NULL:
2406 if (o->op_flags & OPf_STACKED)
2407 break;
2408 /* FALLTHROUGH */
2409 case OP_NEXTSTATE:
2410 case OP_DBSTATE:
2411 case OP_ENTERTRY:
2412 case OP_ENTER:
2413 if (!(o->op_flags & OPf_KIDS))
2414 break;
2415 /* FALLTHROUGH */
2416 case OP_SCOPE:
2417 case OP_LEAVE:
2418 case OP_LEAVETRY:
2419 case OP_LEAVELOOP:
2420 case OP_LINESEQ:
2421 case OP_LEAVEGIVEN:
2422 case OP_LEAVEWHEN:
2423 case OP_ONCE:
2424 kids:
2425 next_kid = cLISTOPo->op_first;
2426 break;
2427 case OP_LIST:
2428 /* If the first kid after pushmark is something that the padrange
2429 optimisation would reject, then null the list and the pushmark.
2430 */
2431 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2432 && ( !(kid = OpSIBLING(kid))
2433 || ( kid->op_type != OP_PADSV
2434 && kid->op_type != OP_PADAV
2435 && kid->op_type != OP_PADHV)
2436 || kid->op_private & ~OPpLVAL_INTRO
2437 || !(kid = OpSIBLING(kid))
2438 || ( kid->op_type != OP_PADSV
2439 && kid->op_type != OP_PADAV
2440 && kid->op_type != OP_PADHV)
2441 || kid->op_private & ~OPpLVAL_INTRO)
2442 ) {
2443 op_null(cUNOPo->op_first); /* NULL the pushmark */
2444 op_null(o); /* NULL the list */
2445 }
2446 goto kids;
2447 case OP_ENTEREVAL:
2448 scalarkids(o);
2449 break;
2450 case OP_SCALAR:
2451 scalar(o);
2452 break;
2453 case OP_EMPTYAVHV:
2454 if (!(o->op_private & OPpTARGET_MY))
2455 useless = (o->op_private & OPpEMPTYAVHV_IS_HV) ?
2456 "anonymous hash ({})" :
2457 "anonymous array ([])";
2458 break;
2459 }
2460
2461 if (useless_sv) {
2462 /* mortalise it, in case warnings are fatal. */
2463 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2464 "Useless use of %" SVf " in void context",
2465 SVfARG(sv_2mortal(useless_sv)));
2466 }
2467 else if (useless) {
2468 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2469 "Useless use of %s in void context",
2470 useless);
2471 }
2472
2473 get_next_op:
2474 /* if a kid hasn't been nominated to process, continue with the
2475 * next sibling, or if no siblings left, go back to the parent's
2476 * siblings and so on
2477 */
2478 while (!next_kid) {
2479 if (o == arg)
2480 return arg; /* at top; no parents/siblings to try */
2481 if (OpHAS_SIBLING(o))
2482 next_kid = o->op_sibparent;
2483 else
2484 o = o->op_sibparent; /*try parent's next sibling */
2485 }
2486 o = next_kid;
2487 }
2488 NOT_REACHED;
2489 }
2490
2491
2492 static OP *
S_listkids(pTHX_ OP * o)2493 S_listkids(pTHX_ OP *o)
2494 {
2495 if (o && o->op_flags & OPf_KIDS) {
2496 OP *kid;
2497 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2498 list(kid);
2499 }
2500 return o;
2501 }
2502
2503
2504 /* apply list context to the o subtree */
2505
2506 OP *
Perl_list(pTHX_ OP * o)2507 Perl_list(pTHX_ OP *o)
2508 {
2509 OP * top_op = o;
2510
2511 while (1) {
2512 OP *next_kid = NULL; /* what op (if any) to process next */
2513
2514 OP *kid;
2515
2516 /* assumes no premature commitment */
2517 if (!o || (o->op_flags & OPf_WANT)
2518 || (PL_parser && PL_parser->error_count)
2519 || o->op_type == OP_RETURN)
2520 {
2521 goto do_next;
2522 }
2523
2524 if ((o->op_private & OPpTARGET_MY)
2525 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2526 {
2527 goto do_next; /* As if inside SASSIGN */
2528 }
2529
2530 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2531
2532 switch (o->op_type) {
2533 case OP_REPEAT:
2534 if (o->op_private & OPpREPEAT_DOLIST
2535 && !(o->op_flags & OPf_STACKED))
2536 {
2537 list(cBINOPo->op_first);
2538 kid = cBINOPo->op_last;
2539 /* optimise away (.....) x 1 */
2540 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2541 && SvIVX(kSVOP_sv) == 1)
2542 {
2543 op_null(o); /* repeat */
2544 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2545 /* const (rhs): */
2546 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2547 }
2548 }
2549 break;
2550
2551 case OP_OR:
2552 case OP_AND:
2553 case OP_COND_EXPR:
2554 /* impose list context on everything except the condition */
2555 next_kid = OpSIBLING(cUNOPo->op_first);
2556 break;
2557
2558 default:
2559 if (!(o->op_flags & OPf_KIDS))
2560 break;
2561 /* possibly flatten 1..10 into a constant array */
2562 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2563 list(cBINOPo->op_first);
2564 gen_constant_list(o);
2565 goto do_next;
2566 }
2567 next_kid = cUNOPo->op_first; /* do all kids */
2568 break;
2569
2570 case OP_LIST:
2571 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2572 op_null(cUNOPo->op_first); /* NULL the pushmark */
2573 op_null(o); /* NULL the list */
2574 }
2575 if (o->op_flags & OPf_KIDS)
2576 next_kid = cUNOPo->op_first; /* do all kids */
2577 break;
2578
2579 /* the children of these ops are usually a list of statements,
2580 * except the leaves, whose first child is a corresponding enter
2581 */
2582 case OP_SCOPE:
2583 case OP_LINESEQ:
2584 kid = cLISTOPo->op_first;
2585 goto do_kids;
2586 case OP_LEAVE:
2587 case OP_LEAVETRY:
2588 kid = cLISTOPo->op_first;
2589 list(kid);
2590 kid = OpSIBLING(kid);
2591 do_kids:
2592 while (kid) {
2593 OP *sib = OpSIBLING(kid);
2594 /* Apply void context to all kids except the last, which
2595 * is list. E.g.
2596 * @a = do { void; void; list }
2597 * Except that 'when's are always list context, e.g.
2598 * @a = do { given(..) {
2599 * when (..) { list }
2600 * when (..) { list }
2601 * ...
2602 * }}
2603 */
2604 if (!sib) {
2605 /* tail call optimise calling list() on the last kid */
2606 next_kid = kid;
2607 goto do_next;
2608 }
2609 else if (kid->op_type == OP_LEAVEWHEN)
2610 list(kid);
2611 else
2612 scalarvoid(kid);
2613 kid = sib;
2614 }
2615 NOT_REACHED; /* NOTREACHED */
2616 break;
2617
2618 }
2619
2620 /* If next_kid is set, someone in the code above wanted us to process
2621 * that kid and all its remaining siblings. Otherwise, work our way
2622 * back up the tree */
2623 do_next:
2624 while (!next_kid) {
2625 if (o == top_op)
2626 return top_op; /* at top; no parents/siblings to try */
2627 if (OpHAS_SIBLING(o))
2628 next_kid = o->op_sibparent;
2629 else {
2630 o = o->op_sibparent; /*try parent's next sibling */
2631 switch (o->op_type) {
2632 case OP_SCOPE:
2633 case OP_LINESEQ:
2634 case OP_LIST:
2635 case OP_LEAVE:
2636 case OP_LEAVETRY:
2637 /* should really restore PL_curcop to its old value, but
2638 * setting it to PL_compiling is better than do nothing */
2639 PL_curcop = &PL_compiling;
2640 }
2641 }
2642
2643
2644 }
2645 o = next_kid;
2646 } /* while */
2647 }
2648
2649 /* apply void context to non-final ops of a sequence */
2650
2651 static OP *
S_voidnonfinal(pTHX_ OP * o)2652 S_voidnonfinal(pTHX_ OP *o)
2653 {
2654 if (o) {
2655 const OPCODE type = o->op_type;
2656
2657 if (type == OP_LINESEQ || type == OP_SCOPE ||
2658 type == OP_LEAVE || type == OP_LEAVETRY)
2659 {
2660 OP *kid = cLISTOPo->op_first, *sib;
2661 if(type == OP_LEAVE) {
2662 /* Don't put the OP_ENTER in void context */
2663 assert(kid->op_type == OP_ENTER);
2664 kid = OpSIBLING(kid);
2665 }
2666 for (; kid; kid = sib) {
2667 if ((sib = OpSIBLING(kid))
2668 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2669 || ( sib->op_targ != OP_NEXTSTATE
2670 && sib->op_targ != OP_DBSTATE )))
2671 {
2672 scalarvoid(kid);
2673 }
2674 }
2675 PL_curcop = &PL_compiling;
2676 }
2677 o->op_flags &= ~OPf_PARENS;
2678 if (PL_hints & HINT_BLOCK_SCOPE)
2679 o->op_flags |= OPf_PARENS;
2680 }
2681 else
2682 o = newOP(OP_STUB, 0);
2683 return o;
2684 }
2685
2686 STATIC OP *
S_modkids(pTHX_ OP * o,I32 type)2687 S_modkids(pTHX_ OP *o, I32 type)
2688 {
2689 if (o && o->op_flags & OPf_KIDS) {
2690 OP *kid;
2691 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2692 op_lvalue(kid, type);
2693 }
2694 return o;
2695 }
2696
2697
2698 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2699 * const fields. Also, convert CONST keys to HEK-in-SVs.
2700 * rop is the op that retrieves the hash;
2701 * key_op is the first key
2702 * real if false, only check (and possibly croak); don't update op
2703 */
2704
2705 void
Perl_check_hash_fields_and_hekify(pTHX_ UNOP * rop,SVOP * key_op,int real)2706 Perl_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real)
2707 {
2708 PADNAME *lexname;
2709 GV **fields;
2710 bool check_fields;
2711
2712 /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2713 if (rop) {
2714 if (rop->op_first->op_type == OP_PADSV)
2715 /* @$hash{qw(keys here)} */
2716 rop = cUNOPx(rop->op_first);
2717 else {
2718 /* @{$hash}{qw(keys here)} */
2719 if (rop->op_first->op_type == OP_SCOPE
2720 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2721 {
2722 rop = cUNOPx(cLISTOPx(rop->op_first)->op_last);
2723 }
2724 else
2725 rop = NULL;
2726 }
2727 }
2728
2729 lexname = NULL; /* just to silence compiler warnings */
2730 fields = NULL; /* just to silence compiler warnings */
2731
2732 check_fields =
2733 rop
2734 && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2735 PadnameHasTYPE(lexname))
2736 && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2737 && isGV(*fields) && GvHV(*fields);
2738
2739 for (; key_op; key_op = cSVOPx(OpSIBLING(key_op))) {
2740 SV **svp, *sv;
2741 if (key_op->op_type != OP_CONST)
2742 continue;
2743 svp = cSVOPx_svp(key_op);
2744
2745 /* make sure it's not a bareword under strict subs */
2746 if (key_op->op_private & OPpCONST_BARE &&
2747 key_op->op_private & OPpCONST_STRICT)
2748 {
2749 no_bareword_allowed((OP*)key_op);
2750 }
2751
2752 /* Make the CONST have a shared SV */
2753 if ( !SvIsCOW_shared_hash(sv = *svp)
2754 && SvTYPE(sv) < SVt_PVMG
2755 && SvOK(sv)
2756 && !SvROK(sv)
2757 && real)
2758 {
2759 SSize_t keylen;
2760 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2761 if (keylen > I32_MAX) {
2762 Perl_croak_nocontext("Sorry, hash keys must be smaller than 2**31 bytes");
2763 }
2764
2765 SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -(I32)keylen : (I32)keylen, 0);
2766 SvREFCNT_dec_NN(sv);
2767 *svp = nsv;
2768 }
2769
2770 if ( check_fields
2771 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2772 {
2773 Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2774 "in variable %" PNf " of type %" HEKf,
2775 SVfARG(*svp), PNfARG(lexname),
2776 HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2777 }
2778 }
2779 }
2780
2781
2782 /* do all the final processing on an optree (e.g. running the peephole
2783 * optimiser on it), then attach it to cv (if cv is non-null)
2784 */
2785
2786 static void
S_process_optree(pTHX_ CV * cv,OP * optree,OP * start)2787 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
2788 {
2789 OP **startp;
2790
2791 /* XXX for some reason, evals, require and main optrees are
2792 * never attached to their CV; instead they just hang off
2793 * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
2794 * and get manually freed when appropriate */
2795 if (cv)
2796 startp = &CvSTART(cv);
2797 else
2798 startp = PL_in_eval? &PL_eval_start : &PL_main_start;
2799
2800 *startp = start;
2801 optree->op_private |= OPpREFCOUNTED;
2802 OpREFCNT_set(optree, 1);
2803 optimize_optree(optree);
2804 CALL_PEEP(*startp);
2805 finalize_optree(optree);
2806 op_prune_chain_head(startp);
2807
2808 if (cv) {
2809 /* now that optimizer has done its work, adjust pad values */
2810 pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
2811 : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
2812 }
2813 }
2814
2815 #ifdef USE_ITHREADS
2816 /* Relocate sv to the pad for thread safety.
2817 * Despite being a "constant", the SV is written to,
2818 * for reference counts, sv_upgrade() etc. */
2819 void
Perl_op_relocate_sv(pTHX_ SV ** svp,PADOFFSET * targp)2820 Perl_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2821 {
2822 PADOFFSET ix;
2823 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2824 if (!*svp) return;
2825 ix = pad_alloc(OP_CONST, SVf_READONLY);
2826 SvREFCNT_dec(PAD_SVl(ix));
2827 PAD_SETSV(ix, *svp);
2828 /* XXX I don't know how this isn't readonly already. */
2829 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2830 *svp = NULL;
2831 *targp = ix;
2832 }
2833 #endif
2834
2835 static void
S_mark_padname_lvalue(pTHX_ PADNAME * pn)2836 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
2837 {
2838 CV *cv = PL_compcv;
2839 PadnameLVALUE_on(pn);
2840 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
2841 cv = CvOUTSIDE(cv);
2842 /* RT #127786: cv can be NULL due to an eval within the DB package
2843 * called from an anon sub - anon subs don't have CvOUTSIDE() set
2844 * unless they contain an eval, but calling eval within DB
2845 * pretends the eval was done in the caller's scope.
2846 */
2847 if (!cv)
2848 break;
2849 assert(CvPADLIST(cv));
2850 pn =
2851 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
2852 assert(PadnameLEN(pn));
2853 PadnameLVALUE_on(pn);
2854 }
2855 }
2856
2857 static bool
S_vivifies(const OPCODE type)2858 S_vivifies(const OPCODE type)
2859 {
2860 switch(type) {
2861 case OP_RV2AV: case OP_ASLICE:
2862 case OP_RV2HV: case OP_KVASLICE:
2863 case OP_RV2SV: case OP_HSLICE:
2864 case OP_AELEMFAST: case OP_KVHSLICE:
2865 case OP_HELEM:
2866 case OP_AELEM:
2867 return 1;
2868 }
2869 return 0;
2870 }
2871
2872
2873 /* apply lvalue reference (aliasing) context to the optree o.
2874 * E.g. in
2875 * \($x,$y) = (...)
2876 * o would be the list ($x,$y) and type would be OP_AASSIGN.
2877 * It may descend and apply this to children too, for example in
2878 * \( $cond ? $x, $y) = (...)
2879 */
2880
2881 static void
S_lvref(pTHX_ OP * o,I32 type)2882 S_lvref(pTHX_ OP *o, I32 type)
2883 {
2884 OP *kid;
2885 OP * top_op = o;
2886
2887 while (1) {
2888 switch (o->op_type) {
2889 case OP_COND_EXPR:
2890 o = OpSIBLING(cUNOPo->op_first);
2891 continue;
2892
2893 case OP_PUSHMARK:
2894 goto do_next;
2895
2896 case OP_RV2AV:
2897 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2898 o->op_flags |= OPf_STACKED;
2899 if (o->op_flags & OPf_PARENS) {
2900 if (o->op_private & OPpLVAL_INTRO) {
2901 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2902 "localized parenthesized array in list assignment"));
2903 goto do_next;
2904 }
2905 slurpy:
2906 OpTYPE_set(o, OP_LVAVREF);
2907 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2908 o->op_flags |= OPf_MOD|OPf_REF;
2909 goto do_next;
2910 }
2911 o->op_private |= OPpLVREF_AV;
2912 goto checkgv;
2913
2914 case OP_RV2CV:
2915 kid = cUNOPo->op_first;
2916 if (kid->op_type == OP_NULL)
2917 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
2918 ->op_first;
2919 o->op_private = OPpLVREF_CV;
2920 if (kid->op_type == OP_GV)
2921 o->op_flags |= OPf_STACKED;
2922 else if (kid->op_type == OP_PADCV) {
2923 o->op_targ = kid->op_targ;
2924 kid->op_targ = 0;
2925 op_free(cUNOPo->op_first);
2926 cUNOPo->op_first = NULL;
2927 o->op_flags &=~ OPf_KIDS;
2928 }
2929 else goto badref;
2930 break;
2931
2932 case OP_RV2HV:
2933 if (o->op_flags & OPf_PARENS) {
2934 parenhash:
2935 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2936 "parenthesized hash in list assignment"));
2937 goto do_next;
2938 }
2939 o->op_private |= OPpLVREF_HV;
2940 /* FALLTHROUGH */
2941 case OP_RV2SV:
2942 checkgv:
2943 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2944 o->op_flags |= OPf_STACKED;
2945 break;
2946
2947 case OP_PADHV:
2948 if (o->op_flags & OPf_PARENS) goto parenhash;
2949 o->op_private |= OPpLVREF_HV;
2950 /* FALLTHROUGH */
2951 case OP_PADSV:
2952 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2953 break;
2954
2955 case OP_PADAV:
2956 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2957 if (o->op_flags & OPf_PARENS) goto slurpy;
2958 o->op_private |= OPpLVREF_AV;
2959 break;
2960
2961 case OP_AELEM:
2962 case OP_HELEM:
2963 o->op_private |= OPpLVREF_ELEM;
2964 o->op_flags |= OPf_STACKED;
2965 break;
2966
2967 case OP_ASLICE:
2968 case OP_HSLICE:
2969 OpTYPE_set(o, OP_LVREFSLICE);
2970 o->op_private &= OPpLVAL_INTRO;
2971 goto do_next;
2972
2973 case OP_NULL:
2974 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2975 goto badref;
2976 else if (!(o->op_flags & OPf_KIDS))
2977 goto do_next;
2978
2979 /* the code formerly only recursed into the first child of
2980 * a non ex-list OP_NULL. if we ever encounter such a null op with
2981 * more than one child, need to decide whether its ok to process
2982 * *all* its kids or not */
2983 assert(o->op_targ == OP_LIST
2984 || !(OpHAS_SIBLING(cBINOPo->op_first)));
2985 /* FALLTHROUGH */
2986 case OP_LIST:
2987 o = cLISTOPo->op_first;
2988 continue;
2989
2990 case OP_STUB:
2991 if (o->op_flags & OPf_PARENS)
2992 goto do_next;
2993 /* FALLTHROUGH */
2994 default:
2995 badref:
2996 /* diag_listed_as: Can't modify reference to %s in %s assignment */
2997 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2998 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2999 ? "do block"
3000 : OP_DESC(o),
3001 PL_op_desc[type]));
3002 goto do_next;
3003 }
3004
3005 OpTYPE_set(o, OP_LVREF);
3006 o->op_private &=
3007 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
3008 if (type == OP_ENTERLOOP)
3009 o->op_private |= OPpLVREF_ITER;
3010
3011 do_next:
3012 while (1) {
3013 if (o == top_op)
3014 return; /* at top; no parents/siblings to try */
3015 if (OpHAS_SIBLING(o)) {
3016 o = o->op_sibparent;
3017 break;
3018 }
3019 o = o->op_sibparent; /*try parent's next sibling */
3020 }
3021 } /* while */
3022 }
3023
3024
3025 PERL_STATIC_INLINE bool
S_potential_mod_type(I32 type)3026 S_potential_mod_type(I32 type)
3027 {
3028 /* Types that only potentially result in modification. */
3029 return type == OP_GREPSTART || type == OP_ENTERSUB
3030 || type == OP_REFGEN || type == OP_LEAVESUBLV;
3031 }
3032
3033
3034 /*
3035 =for apidoc op_lvalue
3036
3037 Propagate lvalue ("modifiable") context to an op and its children.
3038 C<type> represents the context type, roughly based on the type of op that
3039 would do the modifying, although C<local()> is represented by C<OP_NULL>,
3040 because it has no op type of its own (it is signalled by a flag on
3041 the lvalue op).
3042
3043 This function detects things that can't be modified, such as C<$x+1>, and
3044 generates errors for them. For example, C<$x+1 = 2> would cause it to be
3045 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
3046
3047 It also flags things that need to behave specially in an lvalue context,
3048 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3049
3050 =cut
3051
3052 Perl_op_lvalue_flags() is a non-API lower-level interface to
3053 op_lvalue(). The flags param has these bits:
3054 OP_LVALUE_NO_CROAK: return rather than croaking on error
3055
3056 */
3057
3058 OP *
Perl_op_lvalue_flags(pTHX_ OP * o,I32 type,U32 flags)3059 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
3060 {
3061 OP *top_op = o;
3062
3063 if (!o || (PL_parser && PL_parser->error_count))
3064 return o;
3065
3066 while (1) {
3067 OP *kid;
3068 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
3069 int localize = -1;
3070 OP *next_kid = NULL;
3071
3072 if ((o->op_private & OPpTARGET_MY)
3073 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
3074 {
3075 goto do_next;
3076 }
3077
3078 /* elements of a list might be in void context because the list is
3079 in scalar context or because they are attribute sub calls */
3080 if ((o->op_flags & OPf_WANT) == OPf_WANT_VOID)
3081 goto do_next;
3082
3083 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
3084
3085 switch (o->op_type) {
3086 case OP_UNDEF:
3087 if (type == OP_SASSIGN)
3088 goto nomod;
3089 PL_modcount++;
3090 goto do_next;
3091
3092 case OP_STUB:
3093 if ((o->op_flags & OPf_PARENS))
3094 break;
3095 goto nomod;
3096
3097 case OP_ENTERSUB:
3098 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
3099 !(o->op_flags & OPf_STACKED)) {
3100 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
3101 assert(cUNOPo->op_first->op_type == OP_NULL);
3102 op_null(cLISTOPx(cUNOPo->op_first)->op_first);/* disable pushmark */
3103 break;
3104 }
3105 else { /* lvalue subroutine call */
3106 o->op_private |= OPpLVAL_INTRO;
3107 PL_modcount = RETURN_UNLIMITED_NUMBER;
3108 if (S_potential_mod_type(type)) {
3109 o->op_private |= OPpENTERSUB_INARGS;
3110 break;
3111 }
3112 else { /* Compile-time error message: */
3113 OP *kid = cUNOPo->op_first;
3114 CV *cv;
3115 GV *gv;
3116 SV *namesv;
3117
3118 if (kid->op_type != OP_PUSHMARK) {
3119 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
3120 Perl_croak(aTHX_
3121 "panic: unexpected lvalue entersub "
3122 "args: type/targ %ld:%" UVuf,
3123 (long)kid->op_type, (UV)kid->op_targ);
3124 kid = kLISTOP->op_first;
3125 }
3126 while (OpHAS_SIBLING(kid))
3127 kid = OpSIBLING(kid);
3128 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
3129 break; /* Postpone until runtime */
3130 }
3131
3132 kid = kUNOP->op_first;
3133 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
3134 kid = kUNOP->op_first;
3135 if (kid->op_type == OP_NULL)
3136 Perl_croak(aTHX_
3137 "panic: unexpected constant lvalue entersub "
3138 "entry via type/targ %ld:%" UVuf,
3139 (long)kid->op_type, (UV)kid->op_targ);
3140 if (kid->op_type != OP_GV) {
3141 break;
3142 }
3143
3144 gv = kGVOP_gv;
3145 cv = isGV(gv)
3146 ? GvCV(gv)
3147 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
3148 ? MUTABLE_CV(SvRV(gv))
3149 : NULL;
3150 if (!cv)
3151 break;
3152 if (CvLVALUE(cv))
3153 break;
3154 if (flags & OP_LVALUE_NO_CROAK)
3155 return NULL;
3156
3157 namesv = cv_name(cv, NULL, 0);
3158 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
3159 "subroutine call of &%" SVf " in %s",
3160 SVfARG(namesv), PL_op_desc[type]),
3161 SvUTF8(namesv));
3162 goto do_next;
3163 }
3164 }
3165 /* FALLTHROUGH */
3166 default:
3167 nomod:
3168 if (flags & OP_LVALUE_NO_CROAK) return NULL;
3169 /* grep, foreach, subcalls, refgen */
3170 if (S_potential_mod_type(type))
3171 break;
3172 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
3173 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
3174 ? "do block"
3175 : OP_DESC(o)),
3176 type ? PL_op_desc[type] : "local"));
3177 goto do_next;
3178
3179 case OP_PREINC:
3180 case OP_PREDEC:
3181 case OP_POW:
3182 case OP_MULTIPLY:
3183 case OP_DIVIDE:
3184 case OP_MODULO:
3185 case OP_ADD:
3186 case OP_SUBTRACT:
3187 case OP_CONCAT:
3188 case OP_LEFT_SHIFT:
3189 case OP_RIGHT_SHIFT:
3190 case OP_BIT_AND:
3191 case OP_BIT_XOR:
3192 case OP_BIT_OR:
3193 case OP_I_MULTIPLY:
3194 case OP_I_DIVIDE:
3195 case OP_I_MODULO:
3196 case OP_I_ADD:
3197 case OP_I_SUBTRACT:
3198 if (!(o->op_flags & OPf_STACKED))
3199 goto nomod;
3200 PL_modcount++;
3201 break;
3202
3203 case OP_REPEAT:
3204 if (o->op_flags & OPf_STACKED) {
3205 PL_modcount++;
3206 break;
3207 }
3208 if (!(o->op_private & OPpREPEAT_DOLIST))
3209 goto nomod;
3210 else {
3211 const I32 mods = PL_modcount;
3212 /* we recurse rather than iterate here because we need to
3213 * calculate and use the delta applied to PL_modcount by the
3214 * first child. So in something like
3215 * ($x, ($y) x 3) = split;
3216 * split knows that 4 elements are wanted
3217 */
3218 modkids(cBINOPo->op_first, type);
3219 if (type != OP_AASSIGN)
3220 goto nomod;
3221 kid = cBINOPo->op_last;
3222 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
3223 const IV iv = SvIV(kSVOP_sv);
3224 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
3225 PL_modcount =
3226 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
3227 }
3228 else
3229 PL_modcount = RETURN_UNLIMITED_NUMBER;
3230 }
3231 break;
3232
3233 case OP_COND_EXPR:
3234 localize = 1;
3235 next_kid = OpSIBLING(cUNOPo->op_first);
3236 break;
3237
3238 case OP_RV2AV:
3239 case OP_RV2HV:
3240 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
3241 PL_modcount = RETURN_UNLIMITED_NUMBER;
3242 /* Treat \(@foo) like ordinary list, but still mark it as modi-
3243 fiable since some contexts need to know. */
3244 o->op_flags |= OPf_MOD;
3245 goto do_next;
3246 }
3247 /* FALLTHROUGH */
3248 case OP_RV2GV:
3249 if (scalar_mod_type(o, type))
3250 goto nomod;
3251 ref(cUNOPo->op_first, o->op_type);
3252 /* FALLTHROUGH */
3253 case OP_ASLICE:
3254 case OP_HSLICE:
3255 localize = 1;
3256 /* FALLTHROUGH */
3257 case OP_AASSIGN:
3258 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
3259 if (type == OP_LEAVESUBLV && (
3260 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
3261 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3262 ))
3263 o->op_private |= OPpMAYBE_LVSUB;
3264 /* FALLTHROUGH */
3265 case OP_NEXTSTATE:
3266 case OP_DBSTATE:
3267 PL_modcount = RETURN_UNLIMITED_NUMBER;
3268 break;
3269
3270 case OP_KVHSLICE:
3271 case OP_KVASLICE:
3272 case OP_AKEYS:
3273 if (type == OP_LEAVESUBLV)
3274 o->op_private |= OPpMAYBE_LVSUB;
3275 goto nomod;
3276
3277 case OP_AVHVSWITCH:
3278 if (type == OP_LEAVESUBLV
3279 && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
3280 o->op_private |= OPpMAYBE_LVSUB;
3281 goto nomod;
3282
3283 case OP_AV2ARYLEN:
3284 PL_hints |= HINT_BLOCK_SCOPE;
3285 if (type == OP_LEAVESUBLV)
3286 o->op_private |= OPpMAYBE_LVSUB;
3287 PL_modcount++;
3288 break;
3289
3290 case OP_RV2SV:
3291 ref(cUNOPo->op_first, o->op_type);
3292 localize = 1;
3293 /* FALLTHROUGH */
3294 case OP_GV:
3295 PL_hints |= HINT_BLOCK_SCOPE;
3296 /* FALLTHROUGH */
3297 case OP_SASSIGN:
3298 case OP_ANDASSIGN:
3299 case OP_ORASSIGN:
3300 case OP_DORASSIGN:
3301 PL_modcount++;
3302 break;
3303
3304 case OP_AELEMFAST:
3305 case OP_AELEMFAST_LEX:
3306 localize = -1;
3307 PL_modcount++;
3308 break;
3309
3310 case OP_PADAV:
3311 case OP_PADHV:
3312 PL_modcount = RETURN_UNLIMITED_NUMBER;
3313 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
3314 {
3315 /* Treat \(@foo) like ordinary list, but still mark it as modi-
3316 fiable since some contexts need to know. */
3317 o->op_flags |= OPf_MOD;
3318 goto do_next;
3319 }
3320 if (scalar_mod_type(o, type))
3321 goto nomod;
3322 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3323 && type == OP_LEAVESUBLV)
3324 o->op_private |= OPpMAYBE_LVSUB;
3325 /* FALLTHROUGH */
3326 case OP_PADSV:
3327 PL_modcount++;
3328 if (!type) /* local() */
3329 Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
3330 PNfARG(PAD_COMPNAME(o->op_targ)));
3331 if (!(o->op_private & OPpLVAL_INTRO)
3332 || ( type != OP_SASSIGN && type != OP_AASSIGN
3333 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
3334 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
3335 break;
3336
3337 case OP_PUSHMARK:
3338 localize = 0;
3339 break;
3340
3341 case OP_KEYS:
3342 if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
3343 goto nomod;
3344 goto lvalue_func;
3345 case OP_SUBSTR:
3346 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
3347 goto nomod;
3348 /* FALLTHROUGH */
3349 case OP_POS:
3350 case OP_VEC:
3351 lvalue_func:
3352 if (type == OP_LEAVESUBLV)
3353 o->op_private |= OPpMAYBE_LVSUB;
3354 if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
3355 /* we recurse rather than iterate here because the child
3356 * needs to be processed with a different 'type' parameter */
3357
3358 /* substr and vec */
3359 /* If this op is in merely potential (non-fatal) modifiable
3360 context, then apply OP_ENTERSUB context to
3361 the kid op (to avoid croaking). Other-
3362 wise pass this op’s own type so the correct op is mentioned
3363 in error messages. */
3364 op_lvalue(OpSIBLING(cBINOPo->op_first),
3365 S_potential_mod_type(type)
3366 ? (I32)OP_ENTERSUB
3367 : o->op_type);
3368 }
3369 break;
3370
3371 case OP_AELEM:
3372 case OP_HELEM:
3373 ref(cBINOPo->op_first, o->op_type);
3374 if (type == OP_ENTERSUB &&
3375 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
3376 o->op_private |= OPpLVAL_DEFER;
3377 if (type == OP_LEAVESUBLV)
3378 o->op_private |= OPpMAYBE_LVSUB;
3379 localize = 1;
3380 PL_modcount++;
3381 break;
3382
3383 case OP_LEAVE:
3384 case OP_LEAVELOOP:
3385 o->op_private |= OPpLVALUE;
3386 /* FALLTHROUGH */
3387 case OP_SCOPE:
3388 case OP_ENTER:
3389 case OP_LINESEQ:
3390 localize = 0;
3391 if (o->op_flags & OPf_KIDS)
3392 next_kid = cLISTOPo->op_last;
3393 break;
3394
3395 case OP_NULL:
3396 localize = 0;
3397 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
3398 goto nomod;
3399 else if (!(o->op_flags & OPf_KIDS))
3400 break;
3401
3402 if (o->op_targ != OP_LIST) {
3403 OP *sib = OpSIBLING(cLISTOPo->op_first);
3404 /* OP_TRANS and OP_TRANSR with argument have a weird optree
3405 * that looks like
3406 *
3407 * null
3408 * arg
3409 * trans
3410 *
3411 * compared with things like OP_MATCH which have the argument
3412 * as a child:
3413 *
3414 * match
3415 * arg
3416 *
3417 * so handle specially to correctly get "Can't modify" croaks etc
3418 */
3419
3420 if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
3421 {
3422 /* this should trigger a "Can't modify transliteration" err */
3423 op_lvalue(sib, type);
3424 }
3425 next_kid = cBINOPo->op_first;
3426 /* we assume OP_NULLs which aren't ex-list have no more than 2
3427 * children. If this assumption is wrong, increase the scan
3428 * limit below */
3429 assert( !OpHAS_SIBLING(next_kid)
3430 || !OpHAS_SIBLING(OpSIBLING(next_kid)));
3431 break;
3432 }
3433 /* FALLTHROUGH */
3434 case OP_LIST:
3435 localize = 0;
3436 next_kid = cLISTOPo->op_first;
3437 break;
3438
3439 case OP_COREARGS:
3440 goto do_next;
3441
3442 case OP_AND:
3443 case OP_OR:
3444 if (type == OP_LEAVESUBLV
3445 || !S_vivifies(cLOGOPo->op_first->op_type))
3446 next_kid = cLOGOPo->op_first;
3447 else if (type == OP_LEAVESUBLV
3448 || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
3449 next_kid = OpSIBLING(cLOGOPo->op_first);
3450 goto nomod;
3451
3452 case OP_SREFGEN:
3453 if (type == OP_NULL) { /* local */
3454 local_refgen:
3455 if (!FEATURE_MYREF_IS_ENABLED)
3456 Perl_croak(aTHX_ "The experimental declared_refs "
3457 "feature is not enabled");
3458 Perl_ck_warner_d(aTHX_
3459 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
3460 "Declaring references is experimental");
3461 next_kid = cUNOPo->op_first;
3462 goto do_next;
3463 }
3464 if (type != OP_AASSIGN && type != OP_SASSIGN
3465 && type != OP_ENTERLOOP)
3466 goto nomod;
3467 /* Don’t bother applying lvalue context to the ex-list. */
3468 kid = cUNOPx(cUNOPo->op_first)->op_first;
3469 assert (!OpHAS_SIBLING(kid));
3470 goto kid_2lvref;
3471 case OP_REFGEN:
3472 if (type == OP_NULL) /* local */
3473 goto local_refgen;
3474 if (type != OP_AASSIGN) goto nomod;
3475 kid = cUNOPo->op_first;
3476 kid_2lvref:
3477 {
3478 const U8 ec = PL_parser ? PL_parser->error_count : 0;
3479 S_lvref(aTHX_ kid, type);
3480 if (!PL_parser || PL_parser->error_count == ec) {
3481 if (!FEATURE_REFALIASING_IS_ENABLED)
3482 Perl_croak(aTHX_
3483 "Experimental aliasing via reference not enabled");
3484 Perl_ck_warner_d(aTHX_
3485 packWARN(WARN_EXPERIMENTAL__REFALIASING),
3486 "Aliasing via reference is experimental");
3487 }
3488 }
3489 if (o->op_type == OP_REFGEN)
3490 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
3491 op_null(o);
3492 goto do_next;
3493
3494 case OP_SPLIT:
3495 if ((o->op_private & OPpSPLIT_ASSIGN)) {
3496 /* This is actually @array = split. */
3497 PL_modcount = RETURN_UNLIMITED_NUMBER;
3498 break;
3499 }
3500 goto nomod;
3501
3502 case OP_SCALAR:
3503 op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
3504 goto nomod;
3505
3506 case OP_ANONCODE:
3507 /* If we were to set OPf_REF on this and it was constructed by XS
3508 * code as a child of an OP_REFGEN then we'd end up generating a
3509 * double-ref when executed. We don't want to do that, so don't
3510 * set flag here.
3511 * See also https://github.com/Perl/perl5/issues/20384
3512 */
3513
3514 // Perl always sets OPf_REF as of 5.37.5.
3515 //
3516 if (LIKELY(o->op_flags & OPf_REF)) goto nomod;
3517
3518 // If we got here, then our op came from an XS module that predates
3519 // 5.37.5’s change to the op tree, which we have to handle a bit
3520 // diffrently to preserve backward compatibility.
3521 //
3522 goto do_next;
3523 }
3524
3525 /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
3526 their argument is a filehandle; thus \stat(".") should not set
3527 it. AMS 20011102 */
3528 if (type == OP_REFGEN && OP_IS_STAT(o->op_type))
3529 goto do_next;
3530
3531 if (type != OP_LEAVESUBLV)
3532 o->op_flags |= OPf_MOD;
3533
3534 if (type == OP_AASSIGN || type == OP_SASSIGN)
3535 o->op_flags |= o->op_type == OP_ENTERSUB ? 0 : OPf_SPECIAL|OPf_REF;
3536 else if (!type) { /* local() */
3537 switch (localize) {
3538 case 1:
3539 o->op_private |= OPpLVAL_INTRO;
3540 o->op_flags &= ~OPf_SPECIAL;
3541 PL_hints |= HINT_BLOCK_SCOPE;
3542 break;
3543 case 0:
3544 break;
3545 case -1:
3546 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
3547 "Useless localization of %s", OP_DESC(o));
3548 }
3549 }
3550 else if (type != OP_GREPSTART && type != OP_ENTERSUB
3551 && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
3552 o->op_flags |= OPf_REF;
3553
3554 do_next:
3555 while (!next_kid) {
3556 if (o == top_op)
3557 return top_op; /* at top; no parents/siblings to try */
3558 if (OpHAS_SIBLING(o)) {
3559 next_kid = o->op_sibparent;
3560 if (!OpHAS_SIBLING(next_kid)) {
3561 /* a few node types don't recurse into their second child */
3562 OP *parent = next_kid->op_sibparent;
3563 I32 ptype = parent->op_type;
3564 if ( (ptype == OP_NULL && parent->op_targ != OP_LIST)
3565 || ( (ptype == OP_AND || ptype == OP_OR)
3566 && (type != OP_LEAVESUBLV
3567 && S_vivifies(next_kid->op_type))
3568 )
3569 ) {
3570 /*try parent's next sibling */
3571 o = parent;
3572 next_kid = NULL;
3573 }
3574 }
3575 }
3576 else
3577 o = o->op_sibparent; /*try parent's next sibling */
3578
3579 }
3580 o = next_kid;
3581
3582 } /* while */
3583
3584 }
3585
3586
3587 STATIC bool
S_scalar_mod_type(const OP * o,I32 type)3588 S_scalar_mod_type(const OP *o, I32 type)
3589 {
3590 switch (type) {
3591 case OP_POS:
3592 case OP_SASSIGN:
3593 if (o && o->op_type == OP_RV2GV)
3594 return FALSE;
3595 /* FALLTHROUGH */
3596 case OP_PREINC:
3597 case OP_PREDEC:
3598 case OP_POSTINC:
3599 case OP_POSTDEC:
3600 case OP_I_PREINC:
3601 case OP_I_PREDEC:
3602 case OP_I_POSTINC:
3603 case OP_I_POSTDEC:
3604 case OP_POW:
3605 case OP_MULTIPLY:
3606 case OP_DIVIDE:
3607 case OP_MODULO:
3608 case OP_REPEAT:
3609 case OP_ADD:
3610 case OP_SUBTRACT:
3611 case OP_I_MULTIPLY:
3612 case OP_I_DIVIDE:
3613 case OP_I_MODULO:
3614 case OP_I_ADD:
3615 case OP_I_SUBTRACT:
3616 case OP_LEFT_SHIFT:
3617 case OP_RIGHT_SHIFT:
3618 case OP_BIT_AND:
3619 case OP_BIT_XOR:
3620 case OP_BIT_OR:
3621 case OP_NBIT_AND:
3622 case OP_NBIT_XOR:
3623 case OP_NBIT_OR:
3624 case OP_SBIT_AND:
3625 case OP_SBIT_XOR:
3626 case OP_SBIT_OR:
3627 case OP_CONCAT:
3628 case OP_SUBST:
3629 case OP_TRANS:
3630 case OP_TRANSR:
3631 case OP_READ:
3632 case OP_SYSREAD:
3633 case OP_RECV:
3634 case OP_ANDASSIGN:
3635 case OP_ORASSIGN:
3636 case OP_DORASSIGN:
3637 case OP_VEC:
3638 case OP_SUBSTR:
3639 return TRUE;
3640 default:
3641 return FALSE;
3642 }
3643 }
3644
3645 STATIC bool
S_is_handle_constructor(const OP * o,I32 numargs)3646 S_is_handle_constructor(const OP *o, I32 numargs)
3647 {
3648 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3649
3650 switch (o->op_type) {
3651 case OP_PIPE_OP:
3652 case OP_SOCKPAIR:
3653 if (numargs == 2)
3654 return TRUE;
3655 /* FALLTHROUGH */
3656 case OP_SYSOPEN:
3657 case OP_OPEN:
3658 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
3659 case OP_SOCKET:
3660 case OP_OPEN_DIR:
3661 case OP_ACCEPT:
3662 if (numargs == 1)
3663 return TRUE;
3664 /* FALLTHROUGH */
3665 default:
3666 return FALSE;
3667 }
3668 }
3669
3670 static OP *
S_refkids(pTHX_ OP * o,I32 type)3671 S_refkids(pTHX_ OP *o, I32 type)
3672 {
3673 if (o && o->op_flags & OPf_KIDS) {
3674 OP *kid;
3675 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3676 ref(kid, type);
3677 }
3678 return o;
3679 }
3680
3681
3682 /* Apply reference (autovivification) context to the subtree at o.
3683 * For example in
3684 * push @{expression}, ....;
3685 * o will be the head of 'expression' and type will be OP_RV2AV.
3686 * It marks the op o (or a suitable child) as autovivifying, e.g. by
3687 * setting OPf_MOD.
3688 * For OP_RV2AV/OP_PADAV and OP_RV2HV/OP_PADHV sets OPf_REF too if
3689 * set_op_ref is true.
3690 *
3691 * Also calls scalar(o).
3692 */
3693
3694 OP *
Perl_doref(pTHX_ OP * o,I32 type,bool set_op_ref)3695 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
3696 {
3697 OP * top_op = o;
3698
3699 PERL_ARGS_ASSERT_DOREF;
3700
3701 if (PL_parser && PL_parser->error_count)
3702 return o;
3703
3704 while (1) {
3705 switch (o->op_type) {
3706 case OP_ENTERSUB:
3707 if ((type == OP_EXISTS || type == OP_DEFINED) &&
3708 !(o->op_flags & OPf_STACKED)) {
3709 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
3710 assert(cUNOPo->op_first->op_type == OP_NULL);
3711 /* disable pushmark */
3712 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
3713 o->op_flags |= OPf_SPECIAL;
3714 }
3715 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
3716 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3717 : type == OP_RV2HV ? OPpDEREF_HV
3718 : OPpDEREF_SV);
3719 o->op_flags |= OPf_MOD;
3720 }
3721
3722 break;
3723
3724 case OP_COND_EXPR:
3725 o = OpSIBLING(cUNOPo->op_first);
3726 continue;
3727
3728 case OP_RV2SV:
3729 if (type == OP_DEFINED)
3730 o->op_flags |= OPf_SPECIAL; /* don't create GV */
3731 /* FALLTHROUGH */
3732 case OP_PADSV:
3733 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3734 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3735 : type == OP_RV2HV ? OPpDEREF_HV
3736 : OPpDEREF_SV);
3737 o->op_flags |= OPf_MOD;
3738 }
3739 if (o->op_flags & OPf_KIDS) {
3740 type = o->op_type;
3741 o = cUNOPo->op_first;
3742 continue;
3743 }
3744 break;
3745
3746 case OP_RV2AV:
3747 case OP_RV2HV:
3748 if (set_op_ref)
3749 o->op_flags |= OPf_REF;
3750 /* FALLTHROUGH */
3751 case OP_RV2GV:
3752 if (type == OP_DEFINED)
3753 o->op_flags |= OPf_SPECIAL; /* don't create GV */
3754 type = o->op_type;
3755 o = cUNOPo->op_first;
3756 continue;
3757
3758 case OP_PADAV:
3759 case OP_PADHV:
3760 if (set_op_ref)
3761 o->op_flags |= OPf_REF;
3762 break;
3763
3764 case OP_SCALAR:
3765 case OP_NULL:
3766 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
3767 break;
3768 o = cBINOPo->op_first;
3769 continue;
3770
3771 case OP_AELEM:
3772 case OP_HELEM:
3773 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3774 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3775 : type == OP_RV2HV ? OPpDEREF_HV
3776 : OPpDEREF_SV);
3777 o->op_flags |= OPf_MOD;
3778 }
3779 type = o->op_type;
3780 o = cBINOPo->op_first;
3781 continue;;
3782
3783 case OP_SCOPE:
3784 case OP_LEAVE:
3785 set_op_ref = FALSE;
3786 /* FALLTHROUGH */
3787 case OP_ENTER:
3788 case OP_LIST:
3789 if (!(o->op_flags & OPf_KIDS))
3790 break;
3791 o = cLISTOPo->op_last;
3792 continue;
3793
3794 default:
3795 break;
3796 } /* switch */
3797
3798 while (1) {
3799 if (o == top_op)
3800 return scalar(top_op); /* at top; no parents/siblings to try */
3801 if (OpHAS_SIBLING(o)) {
3802 o = o->op_sibparent;
3803 /* Normally skip all siblings and go straight to the parent;
3804 * the only op that requires two children to be processed
3805 * is OP_COND_EXPR */
3806 if (!OpHAS_SIBLING(o)
3807 && o->op_sibparent->op_type == OP_COND_EXPR)
3808 break;
3809 continue;
3810 }
3811 o = o->op_sibparent; /*try parent's next sibling */
3812 }
3813 } /* while */
3814 }
3815
3816
3817 STATIC OP *
S_dup_attrlist(pTHX_ OP * o)3818 S_dup_attrlist(pTHX_ OP *o)
3819 {
3820 OP *rop;
3821
3822 PERL_ARGS_ASSERT_DUP_ATTRLIST;
3823
3824 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3825 * where the first kid is OP_PUSHMARK and the remaining ones
3826 * are OP_CONST. We need to push the OP_CONST values.
3827 */
3828 if (o->op_type == OP_CONST)
3829 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3830 else {
3831 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3832 rop = NULL;
3833 for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
3834 if (o->op_type == OP_CONST)
3835 rop = op_append_elem(OP_LIST, rop,
3836 newSVOP(OP_CONST, o->op_flags,
3837 SvREFCNT_inc_NN(cSVOPo->op_sv)));
3838 }
3839 }
3840 return rop;
3841 }
3842
3843 STATIC void
S_apply_attrs(pTHX_ HV * stash,SV * target,OP * attrs)3844 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3845 {
3846 PERL_ARGS_ASSERT_APPLY_ATTRS;
3847 {
3848 SV * const stashsv = newSVhek(HvNAME_HEK(stash));
3849
3850 /* fake up C<use attributes $pkg,$rv,@attrs> */
3851
3852 #define ATTRSMODULE "attributes"
3853 #define ATTRSMODULE_PM "attributes.pm"
3854
3855 Perl_load_module(
3856 aTHX_ PERL_LOADMOD_IMPORT_OPS,
3857 newSVpvs(ATTRSMODULE),
3858 NULL,
3859 op_prepend_elem(OP_LIST,
3860 newSVOP(OP_CONST, 0, stashsv),
3861 op_prepend_elem(OP_LIST,
3862 newSVOP(OP_CONST, 0,
3863 newRV(target)),
3864 dup_attrlist(attrs))));
3865 }
3866 }
3867
3868 STATIC void
S_apply_attrs_my(pTHX_ HV * stash,OP * target,OP * attrs,OP ** imopsp)3869 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3870 {
3871 OP *pack, *imop, *arg;
3872 SV *meth, *stashsv, **svp;
3873
3874 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3875
3876 if (!attrs)
3877 return;
3878
3879 assert(target->op_type == OP_PADSV ||
3880 target->op_type == OP_PADHV ||
3881 target->op_type == OP_PADAV);
3882
3883 /* Ensure that attributes.pm is loaded. */
3884 /* Don't force the C<use> if we don't need it. */
3885 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3886 if (svp && *svp != &PL_sv_undef)
3887 NOOP; /* already in %INC */
3888 else
3889 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3890 newSVpvs(ATTRSMODULE), NULL);
3891
3892 /* Need package name for method call. */
3893 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3894
3895 /* Build up the real arg-list. */
3896 stashsv = newSVhek(HvNAME_HEK(stash));
3897
3898 arg = newPADxVOP(OP_PADSV, 0, target->op_targ);
3899 arg = op_prepend_elem(OP_LIST,
3900 newSVOP(OP_CONST, 0, stashsv),
3901 op_prepend_elem(OP_LIST,
3902 newUNOP(OP_REFGEN, 0,
3903 arg),
3904 dup_attrlist(attrs)));
3905
3906 /* Fake up a method call to import */
3907 meth = newSVpvs_share("import");
3908 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_WANT_VOID,
3909 op_append_elem(OP_LIST,
3910 op_prepend_elem(OP_LIST, pack, arg),
3911 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3912
3913 /* Combine the ops. */
3914 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3915 }
3916
3917 /*
3918 =notfor apidoc apply_attrs_string
3919
3920 Attempts to apply a list of attributes specified by the C<attrstr> and
3921 C<len> arguments to the subroutine identified by the C<cv> argument which
3922 is expected to be associated with the package identified by the C<stashpv>
3923 argument (see L<attributes>). It gets this wrong, though, in that it
3924 does not correctly identify the boundaries of the individual attribute
3925 specifications within C<attrstr>. This is not really intended for the
3926 public API, but has to be listed here for systems such as AIX which
3927 need an explicit export list for symbols. (It's called from XS code
3928 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
3929 to respect attribute syntax properly would be welcome.
3930
3931 =cut
3932 */
3933
3934 void
Perl_apply_attrs_string(pTHX_ const char * stashpv,CV * cv,const char * attrstr,STRLEN len)3935 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3936 const char *attrstr, STRLEN len)
3937 {
3938 OP *attrs = NULL;
3939
3940 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3941
3942 if (!len) {
3943 len = strlen(attrstr);
3944 }
3945
3946 while (len) {
3947 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3948 if (len) {
3949 const char * const sstr = attrstr;
3950 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3951 attrs = op_append_elem(OP_LIST, attrs,
3952 newSVOP(OP_CONST, 0,
3953 newSVpvn(sstr, attrstr-sstr)));
3954 }
3955 }
3956
3957 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3958 newSVpvs(ATTRSMODULE),
3959 NULL, op_prepend_elem(OP_LIST,
3960 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3961 op_prepend_elem(OP_LIST,
3962 newSVOP(OP_CONST, 0,
3963 newRV(MUTABLE_SV(cv))),
3964 attrs)));
3965 }
3966
3967 STATIC void
S_move_proto_attr(pTHX_ OP ** proto,OP ** attrs,const GV * name,bool curstash)3968 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
3969 bool curstash)
3970 {
3971 OP *new_proto = NULL;
3972 STRLEN pvlen;
3973 char *pv;
3974 OP *o;
3975
3976 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3977
3978 if (!*attrs)
3979 return;
3980
3981 o = *attrs;
3982 if (o->op_type == OP_CONST) {
3983 pv = SvPV(cSVOPo_sv, pvlen);
3984 if (memBEGINs(pv, pvlen, "prototype(")) {
3985 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3986 SV ** const tmpo = cSVOPx_svp(o);
3987 SvREFCNT_dec(cSVOPo_sv);
3988 *tmpo = tmpsv;
3989 new_proto = o;
3990 *attrs = NULL;
3991 }
3992 } else if (o->op_type == OP_LIST) {
3993 OP * lasto;
3994 assert(o->op_flags & OPf_KIDS);
3995 lasto = cLISTOPo->op_first;
3996 assert(lasto->op_type == OP_PUSHMARK);
3997 for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
3998 if (o->op_type == OP_CONST) {
3999 pv = SvPV(cSVOPo_sv, pvlen);
4000 if (memBEGINs(pv, pvlen, "prototype(")) {
4001 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
4002 SV ** const tmpo = cSVOPx_svp(o);
4003 SvREFCNT_dec(cSVOPo_sv);
4004 *tmpo = tmpsv;
4005 if (new_proto && ckWARN(WARN_MISC)) {
4006 STRLEN new_len;
4007 const char * newp = SvPV(cSVOPo_sv, new_len);
4008 Perl_warner(aTHX_ packWARN(WARN_MISC),
4009 "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
4010 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
4011 }
4012 op_free(new_proto);
4013 new_proto = o;
4014 /* excise new_proto from the list */
4015 op_sibling_splice(*attrs, lasto, 1, NULL);
4016 o = lasto;
4017 continue;
4018 }
4019 }
4020 lasto = o;
4021 }
4022 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
4023 would get pulled in with no real need */
4024 if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
4025 op_free(*attrs);
4026 *attrs = NULL;
4027 }
4028 }
4029
4030 if (new_proto) {
4031 SV *svname;
4032 if (isGV(name)) {
4033 svname = sv_newmortal();
4034 gv_efullname3(svname, name, NULL);
4035 }
4036 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
4037 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
4038 else
4039 svname = (SV *)name;
4040 if (ckWARN(WARN_ILLEGALPROTO))
4041 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
4042 curstash);
4043 if (*proto && ckWARN(WARN_PROTOTYPE)) {
4044 STRLEN old_len, new_len;
4045 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
4046 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
4047
4048 if (curstash && svname == (SV *)name
4049 && !memchr(SvPVX(svname), ':', SvCUR(svname))) {
4050 svname = sv_2mortal(newSVsv(PL_curstname));
4051 sv_catpvs(svname, "::");
4052 sv_catsv(svname, (SV *)name);
4053 }
4054
4055 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
4056 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
4057 " in %" SVf,
4058 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
4059 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
4060 SVfARG(svname));
4061 }
4062 op_free(*proto);
4063 *proto = new_proto;
4064 }
4065 }
4066
4067 static void
S_cant_declare(pTHX_ OP * o)4068 S_cant_declare(pTHX_ OP *o)
4069 {
4070 if (o->op_type == OP_NULL
4071 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
4072 o = cUNOPo->op_first;
4073 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
4074 o->op_type == OP_NULL
4075 && o->op_flags & OPf_SPECIAL
4076 ? "do block"
4077 : OP_DESC(o),
4078 PL_parser->in_my == KEY_our ? "our" :
4079 PL_parser->in_my == KEY_state ? "state" :
4080 "my"));
4081 }
4082
4083 STATIC OP *
S_my_kid(pTHX_ OP * o,OP * attrs,OP ** imopsp)4084 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
4085 {
4086 I32 type;
4087 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
4088
4089 PERL_ARGS_ASSERT_MY_KID;
4090
4091 if (!o || (PL_parser && PL_parser->error_count))
4092 return o;
4093
4094 type = o->op_type;
4095
4096 if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
4097 OP *kid;
4098 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4099 my_kid(kid, attrs, imopsp);
4100 return o;
4101 } else if (type == OP_UNDEF || type == OP_STUB) {
4102 return o;
4103 } else if (type == OP_RV2SV || /* "our" declaration */
4104 type == OP_RV2AV ||
4105 type == OP_RV2HV) {
4106 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
4107 S_cant_declare(aTHX_ o);
4108 } else if (attrs) {
4109 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
4110 assert(PL_parser);
4111 PL_parser->in_my = FALSE;
4112 PL_parser->in_my_stash = NULL;
4113 apply_attrs(GvSTASH(gv),
4114 (type == OP_RV2SV ? GvSVn(gv) :
4115 type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
4116 type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
4117 attrs);
4118 }
4119 o->op_private |= OPpOUR_INTRO;
4120 return o;
4121 }
4122 else if (type == OP_REFGEN || type == OP_SREFGEN) {
4123 if (!FEATURE_MYREF_IS_ENABLED)
4124 Perl_croak(aTHX_ "The experimental declared_refs "
4125 "feature is not enabled");
4126 Perl_ck_warner_d(aTHX_
4127 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4128 "Declaring references is experimental");
4129 /* Kid is a nulled OP_LIST, handled above. */
4130 my_kid(cUNOPo->op_first, attrs, imopsp);
4131 return o;
4132 }
4133 else if (type != OP_PADSV &&
4134 type != OP_PADAV &&
4135 type != OP_PADHV &&
4136 type != OP_PUSHMARK)
4137 {
4138 S_cant_declare(aTHX_ o);
4139 return o;
4140 }
4141 else if (attrs && type != OP_PUSHMARK) {
4142 HV *stash;
4143
4144 assert(PL_parser);
4145 PL_parser->in_my = FALSE;
4146 PL_parser->in_my_stash = NULL;
4147
4148 /* check for C<my Dog $spot> when deciding package */
4149 stash = PAD_COMPNAME_TYPE(o->op_targ);
4150 if (!stash)
4151 stash = PL_curstash;
4152 apply_attrs_my(stash, o, attrs, imopsp);
4153 }
4154 o->op_flags |= OPf_MOD;
4155 o->op_private |= OPpLVAL_INTRO;
4156 if (stately)
4157 o->op_private |= OPpPAD_STATE;
4158 return o;
4159 }
4160
4161 OP *
Perl_my_attrs(pTHX_ OP * o,OP * attrs)4162 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
4163 {
4164 OP *rops;
4165 int maybe_scalar = 0;
4166
4167 PERL_ARGS_ASSERT_MY_ATTRS;
4168
4169 /* [perl #17376]: this appears to be premature, and results in code such as
4170 C< our(%x); > executing in list mode rather than void mode */
4171 #if 0
4172 if (o->op_flags & OPf_PARENS)
4173 list(o);
4174 else
4175 maybe_scalar = 1;
4176 #else
4177 maybe_scalar = 1;
4178 #endif
4179 if (attrs)
4180 SAVEFREEOP(attrs);
4181 rops = NULL;
4182 o = my_kid(o, attrs, &rops);
4183 if (rops) {
4184 if (maybe_scalar && o->op_type == OP_PADSV) {
4185 o = scalar(op_append_list(OP_LIST, rops, o));
4186 o->op_private |= OPpLVAL_INTRO;
4187 }
4188 else {
4189 /* The listop in rops might have a pushmark at the beginning,
4190 which will mess up list assignment. */
4191 LISTOP * const lrops = cLISTOPx(rops); /* for brevity */
4192 if (rops->op_type == OP_LIST &&
4193 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
4194 {
4195 OP * const pushmark = lrops->op_first;
4196 /* excise pushmark */
4197 op_sibling_splice(rops, NULL, 1, NULL);
4198 op_free(pushmark);
4199 }
4200 o = op_append_list(OP_LIST, o, rops);
4201 }
4202 }
4203 PL_parser->in_my = FALSE;
4204 PL_parser->in_my_stash = NULL;
4205 return o;
4206 }
4207
4208 OP *
Perl_sawparens(pTHX_ OP * o)4209 Perl_sawparens(pTHX_ OP *o)
4210 {
4211 PERL_UNUSED_CONTEXT;
4212 if (o)
4213 o->op_flags |= OPf_PARENS;
4214 return o;
4215 }
4216
4217 OP *
Perl_bind_match(pTHX_ I32 type,OP * left,OP * right)4218 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
4219 {
4220 OP *o;
4221 bool ismatchop = 0;
4222 const OPCODE ltype = left->op_type;
4223 const OPCODE rtype = right->op_type;
4224
4225 PERL_ARGS_ASSERT_BIND_MATCH;
4226
4227 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
4228 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
4229 {
4230 const char * const desc
4231 = PL_op_desc[(
4232 rtype == OP_SUBST || rtype == OP_TRANS
4233 || rtype == OP_TRANSR
4234 )
4235 ? (int)rtype : OP_MATCH];
4236 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
4237 SV * const name = op_varname(left);
4238 if (name)
4239 Perl_warner(aTHX_ packWARN(WARN_MISC),
4240 "Applying %s to %" SVf " will act on scalar(%" SVf ")",
4241 desc, SVfARG(name), SVfARG(name));
4242 else {
4243 const char * const sample = (isary
4244 ? "@array" : "%hash");
4245 Perl_warner(aTHX_ packWARN(WARN_MISC),
4246 "Applying %s to %s will act on scalar(%s)",
4247 desc, sample, sample);
4248 }
4249 }
4250
4251 if (rtype == OP_CONST &&
4252 cSVOPx(right)->op_private & OPpCONST_BARE &&
4253 cSVOPx(right)->op_private & OPpCONST_STRICT)
4254 {
4255 no_bareword_allowed(right);
4256 }
4257
4258 /* !~ doesn't make sense with /r, so error on it for now */
4259 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
4260 type == OP_NOT)
4261 /* diag_listed_as: Using !~ with %s doesn't make sense */
4262 yyerror("Using !~ with s///r doesn't make sense");
4263 if (rtype == OP_TRANSR && type == OP_NOT)
4264 /* diag_listed_as: Using !~ with %s doesn't make sense */
4265 yyerror("Using !~ with tr///r doesn't make sense");
4266
4267 ismatchop = (rtype == OP_MATCH ||
4268 rtype == OP_SUBST ||
4269 rtype == OP_TRANS || rtype == OP_TRANSR)
4270 && !(right->op_flags & OPf_SPECIAL);
4271 if (ismatchop && right->op_private & OPpTARGET_MY) {
4272 right->op_targ = 0;
4273 right->op_private &= ~OPpTARGET_MY;
4274 }
4275 if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
4276 if (left->op_type == OP_PADSV
4277 && !(left->op_private & OPpLVAL_INTRO))
4278 {
4279 right->op_targ = left->op_targ;
4280 op_free(left);
4281 o = right;
4282 }
4283 else {
4284 right->op_flags |= OPf_STACKED;
4285 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
4286 ! (rtype == OP_TRANS &&
4287 right->op_private & OPpTRANS_IDENTICAL) &&
4288 ! (rtype == OP_SUBST &&
4289 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
4290 left = op_lvalue(left, rtype);
4291 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
4292 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
4293 else
4294 o = op_prepend_elem(rtype, scalar(left), right);
4295 }
4296 if (type == OP_NOT)
4297 return newUNOP(OP_NOT, 0, scalar(o));
4298 return o;
4299 }
4300 else
4301 return bind_match(type, left,
4302 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
4303 }
4304
4305 OP *
Perl_invert(pTHX_ OP * o)4306 Perl_invert(pTHX_ OP *o)
4307 {
4308 if (!o)
4309 return NULL;
4310 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
4311 }
4312
4313 /* Warn about possible precedence issues if op is a control flow operator that
4314 does not terminate normally (return, exit, next, etc).
4315 */
4316 static bool
S_is_control_transfer(pTHX_ OP * op)4317 S_is_control_transfer(pTHX_ OP *op)
4318 {
4319 assert(op != NULL);
4320
4321 /* [perl #59802]: Warn about things like "return $a or $b", which
4322 is parsed as "(return $a) or $b" rather than "return ($a or
4323 $b)".
4324 */
4325 switch (op->op_type) {
4326 case OP_DUMP:
4327 case OP_NEXT:
4328 case OP_LAST:
4329 case OP_REDO:
4330 case OP_EXIT:
4331 case OP_RETURN:
4332 case OP_DIE:
4333 case OP_GOTO:
4334 /* XXX: Currently we allow people to "shoot themselves in the
4335 foot" by explicitly writing "(return $a) or $b".
4336
4337 Warn unless we are looking at the result from folding or if
4338 the programmer explicitly grouped the operators like this.
4339 The former can occur with e.g.
4340
4341 use constant FEATURE => ( $] >= ... );
4342 sub { not FEATURE and return or do_stuff(); }
4343 */
4344 if (!op->op_folded && !(op->op_flags & OPf_PARENS))
4345 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
4346 "Possible precedence issue with control flow operator (%s)", OP_DESC(op));
4347
4348 return true;
4349 }
4350
4351 return false;
4352 }
4353
4354 OP *
Perl_cmpchain_start(pTHX_ I32 type,OP * left,OP * right)4355 Perl_cmpchain_start(pTHX_ I32 type, OP *left, OP *right)
4356 {
4357 BINOP *bop;
4358 OP *op;
4359
4360 if (!left)
4361 left = newOP(OP_NULL, 0);
4362 else
4363 (void)S_is_control_transfer(aTHX_ left);
4364 if (!right)
4365 right = newOP(OP_NULL, 0);
4366 scalar(left);
4367 scalar(right);
4368 NewOp(0, bop, 1, BINOP);
4369 op = (OP*)bop;
4370 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP);
4371 OpTYPE_set(op, type);
4372 cBINOPx(op)->op_flags = OPf_KIDS;
4373 cBINOPx(op)->op_private = 2;
4374 cBINOPx(op)->op_first = left;
4375 cBINOPx(op)->op_last = right;
4376 OpMORESIB_set(left, right);
4377 OpLASTSIB_set(right, op);
4378 return op;
4379 }
4380
4381 OP *
Perl_cmpchain_extend(pTHX_ I32 type,OP * ch,OP * right)4382 Perl_cmpchain_extend(pTHX_ I32 type, OP *ch, OP *right)
4383 {
4384 BINOP *bop;
4385 OP *op;
4386
4387 PERL_ARGS_ASSERT_CMPCHAIN_EXTEND;
4388 if (!right)
4389 right = newOP(OP_NULL, 0);
4390 scalar(right);
4391 NewOp(0, bop, 1, BINOP);
4392 op = (OP*)bop;
4393 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP);
4394 OpTYPE_set(op, type);
4395 if (ch->op_type != OP_NULL) {
4396 UNOP *lch;
4397 OP *nch, *cleft, *cright;
4398 NewOp(0, lch, 1, UNOP);
4399 nch = (OP*)lch;
4400 OpTYPE_set(nch, OP_NULL);
4401 nch->op_flags = OPf_KIDS;
4402 cleft = cBINOPx(ch)->op_first;
4403 cright = cBINOPx(ch)->op_last;
4404 cBINOPx(ch)->op_first = NULL;
4405 cBINOPx(ch)->op_last = NULL;
4406 cBINOPx(ch)->op_private = 0;
4407 cBINOPx(ch)->op_flags = 0;
4408 cUNOPx(nch)->op_first = cright;
4409 OpMORESIB_set(cright, ch);
4410 OpMORESIB_set(ch, cleft);
4411 OpLASTSIB_set(cleft, nch);
4412 ch = nch;
4413 }
4414 OpMORESIB_set(right, op);
4415 OpMORESIB_set(op, cUNOPx(ch)->op_first);
4416 cUNOPx(ch)->op_first = right;
4417 return ch;
4418 }
4419
4420 OP *
Perl_cmpchain_finish(pTHX_ OP * ch)4421 Perl_cmpchain_finish(pTHX_ OP *ch)
4422 {
4423
4424 PERL_ARGS_ASSERT_CMPCHAIN_FINISH;
4425 if (ch->op_type != OP_NULL) {
4426 OPCODE cmpoptype = ch->op_type;
4427 ch = CHECKOP(cmpoptype, ch);
4428 if(!ch->op_next && ch->op_type == cmpoptype)
4429 ch = fold_constants(op_integerize(op_std_init(ch)));
4430 return ch;
4431 } else {
4432 OP *condop = NULL;
4433 OP *rightarg = cUNOPx(ch)->op_first;
4434 cUNOPx(ch)->op_first = OpSIBLING(rightarg);
4435 OpLASTSIB_set(rightarg, NULL);
4436 while (1) {
4437 OP *cmpop = cUNOPx(ch)->op_first;
4438 OP *leftarg = OpSIBLING(cmpop);
4439 OPCODE cmpoptype = cmpop->op_type;
4440 OP *nextrightarg;
4441 bool is_last;
4442 is_last = !(cUNOPx(ch)->op_first = OpSIBLING(leftarg));
4443 OpLASTSIB_set(cmpop, NULL);
4444 OpLASTSIB_set(leftarg, NULL);
4445 if (is_last) {
4446 ch->op_flags = 0;
4447 op_free(ch);
4448 nextrightarg = NULL;
4449 } else {
4450 nextrightarg = newUNOP(OP_CMPCHAIN_DUP, 0, leftarg);
4451 leftarg = newOP(OP_NULL, 0);
4452 }
4453 cBINOPx(cmpop)->op_first = leftarg;
4454 cBINOPx(cmpop)->op_last = rightarg;
4455 OpMORESIB_set(leftarg, rightarg);
4456 OpLASTSIB_set(rightarg, cmpop);
4457 cmpop->op_flags = OPf_KIDS;
4458 cmpop->op_private = 2;
4459 cmpop = CHECKOP(cmpoptype, cmpop);
4460 if(!cmpop->op_next && cmpop->op_type == cmpoptype)
4461 cmpop = op_integerize(op_std_init(cmpop));
4462 condop = condop ? newLOGOP(OP_CMPCHAIN_AND, 0, cmpop, condop) :
4463 cmpop;
4464 if (!nextrightarg)
4465 return condop;
4466 rightarg = nextrightarg;
4467 }
4468 }
4469 }
4470
4471 /*
4472 =for apidoc op_scope
4473
4474 Wraps up an op tree with some additional ops so that at runtime a dynamic
4475 scope will be created. The original ops run in the new dynamic scope,
4476 and then, provided that they exit normally, the scope will be unwound.
4477 The additional ops used to create and unwind the dynamic scope will
4478 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
4479 instead if the ops are simple enough to not need the full dynamic scope
4480 structure.
4481
4482 =cut
4483 */
4484
4485 OP *
Perl_op_scope(pTHX_ OP * o)4486 Perl_op_scope(pTHX_ OP *o)
4487 {
4488 if (o) {
4489 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
4490 o = op_prepend_elem(OP_LINESEQ,
4491 newOP(OP_ENTER, (o->op_flags & OPf_WANT)), o);
4492 OpTYPE_set(o, OP_LEAVE);
4493 }
4494 else if (o->op_type == OP_LINESEQ) {
4495 OP *kid;
4496 OpTYPE_set(o, OP_SCOPE);
4497 kid = cLISTOPo->op_first;
4498 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
4499 op_null(kid);
4500
4501 /* The following deals with things like 'do {1 for 1}' */
4502 kid = OpSIBLING(kid);
4503 if (kid &&
4504 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
4505 op_null(kid);
4506 }
4507 }
4508 else
4509 o = newLISTOP(OP_SCOPE, 0, o, NULL);
4510 }
4511 return o;
4512 }
4513
4514 OP *
Perl_op_unscope(pTHX_ OP * o)4515 Perl_op_unscope(pTHX_ OP *o)
4516 {
4517 if (o && o->op_type == OP_LINESEQ) {
4518 OP *kid = cLISTOPo->op_first;
4519 for(; kid; kid = OpSIBLING(kid))
4520 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
4521 op_null(kid);
4522 }
4523 return o;
4524 }
4525
4526 /*
4527 =for apidoc block_start
4528
4529 Handles compile-time scope entry.
4530 Arranges for hints to be restored on block
4531 exit and also handles pad sequence numbers to make lexical variables scope
4532 right. Returns a savestack index for use with C<block_end>.
4533
4534 =cut
4535 */
4536
4537 int
Perl_block_start(pTHX_ int full)4538 Perl_block_start(pTHX_ int full)
4539 {
4540 const int retval = PL_savestack_ix;
4541
4542 PL_compiling.cop_seq = PL_cop_seqmax;
4543 COP_SEQMAX_INC;
4544 pad_block_start(full);
4545 SAVEHINTS();
4546 PL_hints &= ~HINT_BLOCK_SCOPE;
4547 SAVECOMPILEWARNINGS();
4548 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
4549 SAVEI32(PL_compiling.cop_seq);
4550 PL_compiling.cop_seq = 0;
4551
4552 CALL_BLOCK_HOOKS(bhk_start, full);
4553
4554 return retval;
4555 }
4556
4557 /*
4558 =for apidoc block_end
4559
4560 Handles compile-time scope exit. C<floor>
4561 is the savestack index returned by
4562 C<block_start>, and C<seq> is the body of the block. Returns the block,
4563 possibly modified.
4564
4565 =cut
4566 */
4567
4568 OP*
Perl_block_end(pTHX_ I32 floor,OP * seq)4569 Perl_block_end(pTHX_ I32 floor, OP *seq)
4570 {
4571 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
4572 OP* retval = voidnonfinal(seq);
4573 OP *o;
4574
4575 /* XXX Is the null PL_parser check necessary here? */
4576 assert(PL_parser); /* Let’s find out under debugging builds. */
4577 if (PL_parser && PL_parser->parsed_sub) {
4578 o = newSTATEOP(0, NULL, NULL);
4579 op_null(o);
4580 retval = op_append_elem(OP_LINESEQ, retval, o);
4581 }
4582
4583 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
4584
4585 LEAVE_SCOPE(floor);
4586 if (needblockscope)
4587 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
4588 o = pad_leavemy();
4589
4590 if (o) {
4591 /* pad_leavemy has created a sequence of introcv ops for all my
4592 subs declared in the block. We have to replicate that list with
4593 clonecv ops, to deal with this situation:
4594
4595 sub {
4596 my sub s1;
4597 my sub s2;
4598 sub s1 { state sub foo { \&s2 } }
4599 }->()
4600
4601 Originally, I was going to have introcv clone the CV and turn
4602 off the stale flag. Since &s1 is declared before &s2, the
4603 introcv op for &s1 is executed (on sub entry) before the one for
4604 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
4605 cloned, since it is a state sub) closes over &s2 and expects
4606 to see it in its outer CV’s pad. If the introcv op clones &s1,
4607 then &s2 is still marked stale. Since &s1 is not active, and
4608 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
4609 ble will not stay shared’ warning. Because it is the same stub
4610 that will be used when the introcv op for &s2 is executed, clos-
4611 ing over it is safe. Hence, we have to turn off the stale flag
4612 on all lexical subs in the block before we clone any of them.
4613 Hence, having introcv clone the sub cannot work. So we create a
4614 list of ops like this:
4615
4616 lineseq
4617 |
4618 +-- introcv
4619 |
4620 +-- introcv
4621 |
4622 +-- introcv
4623 |
4624 .
4625 .
4626 .
4627 |
4628 +-- clonecv
4629 |
4630 +-- clonecv
4631 |
4632 +-- clonecv
4633 |
4634 .
4635 .
4636 .
4637 */
4638 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
4639 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
4640 for (;; kid = OpSIBLING(kid)) {
4641 OP *newkid = newOP(OP_CLONECV, 0);
4642 newkid->op_targ = kid->op_targ;
4643 o = op_append_elem(OP_LINESEQ, o, newkid);
4644 if (kid == last) break;
4645 }
4646 retval = op_prepend_elem(OP_LINESEQ, o, retval);
4647 }
4648
4649 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
4650
4651 return retval;
4652 }
4653
4654 /*
4655 =for apidoc_section $scope
4656
4657 =for apidoc blockhook_register
4658
4659 Register a set of hooks to be called when the Perl lexical scope changes
4660 at compile time. See L<perlguts/"Compile-time scope hooks">.
4661
4662 =cut
4663 */
4664
4665 void
Perl_blockhook_register(pTHX_ BHK * hk)4666 Perl_blockhook_register(pTHX_ BHK *hk)
4667 {
4668 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
4669
4670 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
4671 }
4672
4673 void
Perl_newPROG(pTHX_ OP * o)4674 Perl_newPROG(pTHX_ OP *o)
4675 {
4676 OP *start;
4677
4678 PERL_ARGS_ASSERT_NEWPROG;
4679
4680 if (PL_in_eval) {
4681 PERL_CONTEXT *cx;
4682 I32 i;
4683 if (PL_eval_root)
4684 return;
4685 PL_eval_root = newUNOP(OP_LEAVEEVAL,
4686 ((PL_in_eval & EVAL_KEEPERR)
4687 ? OPf_SPECIAL : 0), o);
4688
4689 cx = CX_CUR();
4690 assert(CxTYPE(cx) == CXt_EVAL);
4691
4692 if ((cx->blk_gimme & G_WANT) == G_VOID)
4693 scalarvoid(PL_eval_root);
4694 else if ((cx->blk_gimme & G_WANT) == G_LIST)
4695 list(PL_eval_root);
4696 else
4697 scalar(PL_eval_root);
4698
4699 start = op_linklist(PL_eval_root);
4700 PL_eval_root->op_next = 0;
4701 i = PL_savestack_ix;
4702 SAVEFREEOP(o);
4703 ENTER;
4704 S_process_optree(aTHX_ NULL, PL_eval_root, start);
4705 LEAVE;
4706 PL_savestack_ix = i;
4707 }
4708 else {
4709 if (o->op_type == OP_STUB) {
4710 /* This block is entered if nothing is compiled for the main
4711 program. This will be the case for an genuinely empty main
4712 program, or one which only has BEGIN blocks etc, so already
4713 run and freed.
4714
4715 Historically (5.000) the guard above was !o. However, commit
4716 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
4717 c71fccf11fde0068, changed perly.y so that newPROG() is now
4718 called with the output of block_end(), which returns a new
4719 OP_STUB for the case of an empty optree. ByteLoader (and
4720 maybe other things) also take this path, because they set up
4721 PL_main_start and PL_main_root directly, without generating an
4722 optree.
4723
4724 If the parsing the main program aborts (due to parse errors,
4725 or due to BEGIN or similar calling exit), then newPROG()
4726 isn't even called, and hence this code path and its cleanups
4727 are skipped. This shouldn't make a make a difference:
4728 * a non-zero return from perl_parse is a failure, and
4729 perl_destruct() should be called immediately.
4730 * however, if exit(0) is called during the parse, then
4731 perl_parse() returns 0, and perl_run() is called. As
4732 PL_main_start will be NULL, perl_run() will return
4733 promptly, and the exit code will remain 0.
4734 */
4735
4736 PL_comppad_name = 0;
4737 PL_compcv = 0;
4738 S_op_destroy(aTHX_ o);
4739 return;
4740 }
4741 PL_main_root = op_scope(sawparens(scalarvoid(o)));
4742 PL_curcop = &PL_compiling;
4743 start = LINKLIST(PL_main_root);
4744 PL_main_root->op_next = 0;
4745 S_process_optree(aTHX_ NULL, PL_main_root, start);
4746 if (!PL_parser->error_count)
4747 /* on error, leave CV slabbed so that ops left lying around
4748 * will eb cleaned up. Else unslab */
4749 cv_forget_slab(PL_compcv);
4750 PL_compcv = 0;
4751
4752 /* Register with debugger */
4753 if (PERLDB_INTER) {
4754 CV * const cv = get_cvs("DB::postponed", 0);
4755 if (cv) {
4756 PUSHMARK(PL_stack_sp);
4757 SV *comp = MUTABLE_SV(CopFILEGV(&PL_compiling));
4758 #ifdef PERL_RC_STACK
4759 assert(rpp_stack_is_rc());
4760 #endif
4761 rpp_xpush_1(comp);
4762 call_sv(MUTABLE_SV(cv), G_DISCARD);
4763 }
4764 }
4765 }
4766 }
4767
4768 OP *
Perl_localize(pTHX_ OP * o,I32 lex)4769 Perl_localize(pTHX_ OP *o, I32 lex)
4770 {
4771 PERL_ARGS_ASSERT_LOCALIZE;
4772
4773 if (o->op_flags & OPf_PARENS)
4774 /* [perl #17376]: this appears to be premature, and results in code such as
4775 C< our(%x); > executing in list mode rather than void mode */
4776 #if 0
4777 list(o);
4778 #else
4779 NOOP;
4780 #endif
4781 else {
4782 if ( PL_parser->bufptr > PL_parser->oldbufptr
4783 && PL_parser->bufptr[-1] == ','
4784 && ckWARN(WARN_PARENTHESIS))
4785 {
4786 char *s = PL_parser->bufptr;
4787 bool sigil = FALSE;
4788
4789 /* some heuristics to detect a potential error */
4790 while (*s && (memCHRs(", \t\n", *s)))
4791 s++;
4792
4793 while (1) {
4794 if (*s && (memCHRs("@$%", *s) || (!lex && *s == '*'))
4795 && *++s
4796 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
4797 s++;
4798 sigil = TRUE;
4799 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
4800 s++;
4801 while (*s && (memCHRs(", \t\n", *s)))
4802 s++;
4803 }
4804 else
4805 break;
4806 }
4807 if (sigil && (*s == ';' || *s == '=')) {
4808 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
4809 "Parentheses missing around \"%s\" list",
4810 lex
4811 ? (PL_parser->in_my == KEY_our
4812 ? "our"
4813 : PL_parser->in_my == KEY_state
4814 ? "state"
4815 : "my")
4816 : "local");
4817 }
4818 }
4819 }
4820 if (lex)
4821 o = my(o);
4822 else
4823 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
4824 PL_parser->in_my = FALSE;
4825 PL_parser->in_my_stash = NULL;
4826 return o;
4827 }
4828
4829 OP *
Perl_jmaybe(pTHX_ OP * o)4830 Perl_jmaybe(pTHX_ OP *o)
4831 {
4832 PERL_ARGS_ASSERT_JMAYBE;
4833
4834 if (o->op_type == OP_LIST) {
4835 if (FEATURE_MULTIDIMENSIONAL_IS_ENABLED) {
4836 OP * const o2
4837 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
4838 o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
4839 }
4840 else {
4841 /* If the user disables this, then a warning might not be enough to alert
4842 them to a possible change of behaviour here, so throw an exception.
4843 */
4844 yyerror("Multidimensional hash lookup is disabled");
4845 }
4846 }
4847 return o;
4848 }
4849
4850 PERL_STATIC_INLINE OP *
S_op_std_init(pTHX_ OP * o)4851 S_op_std_init(pTHX_ OP *o)
4852 {
4853 I32 type = o->op_type;
4854
4855 PERL_ARGS_ASSERT_OP_STD_INIT;
4856
4857 if (PL_opargs[type] & OA_RETSCALAR)
4858 scalar(o);
4859 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
4860 o->op_targ = pad_alloc(type, SVs_PADTMP);
4861
4862 return o;
4863 }
4864
4865 PERL_STATIC_INLINE OP *
S_op_integerize(pTHX_ OP * o)4866 S_op_integerize(pTHX_ OP *o)
4867 {
4868 I32 type = o->op_type;
4869
4870 PERL_ARGS_ASSERT_OP_INTEGERIZE;
4871
4872 /* integerize op. */
4873 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
4874 {
4875 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
4876 }
4877
4878 if (type == OP_NEGATE)
4879 /* XXX might want a ck_negate() for this */
4880 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
4881
4882 return o;
4883 }
4884
4885 /* This function exists solely to provide a scope to limit
4886 setjmp/longjmp() messing with auto variables. It cannot be inlined because
4887 it uses setjmp
4888 */
4889 STATIC int
S_fold_constants_eval(pTHX)4890 S_fold_constants_eval(pTHX) {
4891 int ret = 0;
4892 dJMPENV;
4893
4894 JMPENV_PUSH(ret);
4895
4896 if (ret == 0) {
4897 CALLRUNOPS(aTHX);
4898 }
4899
4900 JMPENV_POP;
4901
4902 return ret;
4903 }
4904
4905 static OP *
S_fold_constants(pTHX_ OP * const o)4906 S_fold_constants(pTHX_ OP *const o)
4907 {
4908 OP *curop;
4909 OP *newop;
4910 I32 type = o->op_type;
4911 bool is_stringify;
4912 SV *sv = NULL;
4913 int ret = 0;
4914 OP *old_next;
4915 SV * const oldwarnhook = PL_warnhook;
4916 SV * const olddiehook = PL_diehook;
4917 COP not_compiling;
4918 U8 oldwarn = PL_dowarn;
4919 I32 old_cxix;
4920
4921 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
4922
4923 if (!(PL_opargs[type] & OA_FOLDCONST))
4924 goto nope;
4925
4926 switch (type) {
4927 case OP_UCFIRST:
4928 case OP_LCFIRST:
4929 case OP_UC:
4930 case OP_LC:
4931 case OP_FC:
4932 #ifdef USE_LOCALE_CTYPE
4933 if (IN_LC_COMPILETIME(LC_CTYPE))
4934 goto nope;
4935 #endif
4936 break;
4937 case OP_SLT:
4938 case OP_SGT:
4939 case OP_SLE:
4940 case OP_SGE:
4941 case OP_SCMP:
4942 #ifdef USE_LOCALE_COLLATE
4943 if (IN_LC_COMPILETIME(LC_COLLATE))
4944 goto nope;
4945 #endif
4946 break;
4947 case OP_SPRINTF:
4948 /* XXX what about the numeric ops? */
4949 #ifdef USE_LOCALE_NUMERIC
4950 if (IN_LC_COMPILETIME(LC_NUMERIC))
4951 goto nope;
4952 #endif
4953 break;
4954 case OP_PACK:
4955 if (!OpHAS_SIBLING(cLISTOPo->op_first)
4956 || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
4957 goto nope;
4958 {
4959 SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
4960 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
4961 {
4962 const char *s = SvPVX_const(sv);
4963 while (s < SvEND(sv)) {
4964 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
4965 s++;
4966 }
4967 }
4968 }
4969 break;
4970 case OP_REPEAT:
4971 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
4972 break;
4973 case OP_SREFGEN:
4974 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
4975 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
4976 goto nope;
4977 }
4978
4979 if (PL_parser && PL_parser->error_count)
4980 goto nope; /* Don't try to run w/ errors */
4981
4982 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4983 switch (curop->op_type) {
4984 case OP_CONST:
4985 if ( (curop->op_private & OPpCONST_BARE)
4986 && (curop->op_private & OPpCONST_STRICT)) {
4987 no_bareword_allowed(curop);
4988 goto nope;
4989 }
4990 /* FALLTHROUGH */
4991 case OP_LIST:
4992 case OP_SCALAR:
4993 case OP_NULL:
4994 case OP_PUSHMARK:
4995 /* Foldable; move to next op in list */
4996 break;
4997
4998 default:
4999 /* No other op types are considered foldable */
5000 goto nope;
5001 }
5002 }
5003
5004 curop = LINKLIST(o);
5005 old_next = o->op_next;
5006 o->op_next = 0;
5007 PL_op = curop;
5008
5009 old_cxix = cxstack_ix;
5010 create_eval_scope(NULL, PL_stack_sp, G_FAKINGEVAL);
5011
5012 /* Verify that we don't need to save it: */
5013 assert(PL_curcop == &PL_compiling);
5014 StructCopy(&PL_compiling, ¬_compiling, COP);
5015 PL_curcop = ¬_compiling;
5016 /* The above ensures that we run with all the correct hints of the
5017 currently compiling COP, but that IN_PERL_RUNTIME is true. */
5018 assert(IN_PERL_RUNTIME);
5019 PL_warnhook = PERL_WARNHOOK_FATAL;
5020 PL_diehook = NULL;
5021
5022 /* Effective $^W=1. */
5023 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5024 PL_dowarn |= G_WARN_ON;
5025
5026 ret = S_fold_constants_eval(aTHX);
5027
5028 switch (ret) {
5029 case 0:
5030 sv = *PL_stack_sp;
5031 if (rpp_stack_is_rc())
5032 SvREFCNT_dec(sv);
5033 PL_stack_sp--;
5034
5035 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
5036 pad_swipe(o->op_targ, FALSE);
5037 }
5038 else if (SvTEMP(sv)) { /* grab mortal temp? */
5039 SvREFCNT_inc_simple_void(sv);
5040 SvTEMP_off(sv);
5041 }
5042 else { assert(SvIMMORTAL(sv)); }
5043 break;
5044 case 3:
5045 /* Something tried to die. Abandon constant folding. */
5046 /* Pretend the error never happened. */
5047 CLEAR_ERRSV();
5048 o->op_next = old_next;
5049 break;
5050 default:
5051 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
5052 PL_warnhook = oldwarnhook;
5053 PL_diehook = olddiehook;
5054 /* XXX note that this croak may fail as we've already blown away
5055 * the stack - eg any nested evals */
5056 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
5057 }
5058 PL_dowarn = oldwarn;
5059 PL_warnhook = oldwarnhook;
5060 PL_diehook = olddiehook;
5061 PL_curcop = &PL_compiling;
5062
5063 /* if we croaked, depending on how we croaked the eval scope
5064 * may or may not have already been popped */
5065 if (cxstack_ix > old_cxix) {
5066 assert(cxstack_ix == old_cxix + 1);
5067 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5068 delete_eval_scope();
5069 }
5070 if (ret)
5071 goto nope;
5072
5073 /* OP_STRINGIFY and constant folding are used to implement qq.
5074 Here the constant folding is an implementation detail that we
5075 want to hide. If the stringify op is itself already marked
5076 folded, however, then it is actually a folded join. */
5077 is_stringify = type == OP_STRINGIFY && !o->op_folded;
5078 op_free(o);
5079 assert(sv);
5080 if (is_stringify)
5081 SvPADTMP_off(sv);
5082 else if (!SvIMMORTAL(sv)) {
5083 SvPADTMP_on(sv);
5084 SvREADONLY_on(sv);
5085 }
5086 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
5087 if (!is_stringify) newop->op_folded = 1;
5088 return newop;
5089
5090 nope:
5091 return o;
5092 }
5093
5094 /* convert a constant range in list context into an OP_RV2AV, OP_CONST pair;
5095 * the constant value being an AV holding the flattened range.
5096 */
5097
5098 static void
S_gen_constant_list(pTHX_ OP * o)5099 S_gen_constant_list(pTHX_ OP *o)
5100 {
5101 OP *curop, *old_next;
5102 SV * const oldwarnhook = PL_warnhook;
5103 SV * const olddiehook = PL_diehook;
5104 COP *old_curcop;
5105 U8 oldwarn = PL_dowarn;
5106 SV **svp;
5107 AV *av;
5108 I32 old_cxix;
5109 COP not_compiling;
5110 int ret = 0;
5111 dJMPENV;
5112 bool op_was_null;
5113
5114 list(o);
5115 if (PL_parser && PL_parser->error_count)
5116 return; /* Don't attempt to run with errors */
5117
5118 curop = LINKLIST(o);
5119 old_next = o->op_next;
5120 o->op_next = 0;
5121 op_was_null = o->op_type == OP_NULL;
5122 if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
5123 o->op_type = OP_CUSTOM;
5124 CALL_PEEP(curop);
5125 if (op_was_null)
5126 o->op_type = OP_NULL;
5127 op_prune_chain_head(&curop);
5128 PL_op = curop;
5129
5130 old_cxix = cxstack_ix;
5131 create_eval_scope(NULL, PL_stack_sp, G_FAKINGEVAL);
5132
5133 old_curcop = PL_curcop;
5134 StructCopy(old_curcop, ¬_compiling, COP);
5135 PL_curcop = ¬_compiling;
5136 /* The above ensures that we run with all the correct hints of the
5137 current COP, but that IN_PERL_RUNTIME is true. */
5138 assert(IN_PERL_RUNTIME);
5139 PL_warnhook = PERL_WARNHOOK_FATAL;
5140 PL_diehook = NULL;
5141 JMPENV_PUSH(ret);
5142
5143 /* Effective $^W=1. */
5144 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5145 PL_dowarn |= G_WARN_ON;
5146
5147 switch (ret) {
5148 case 0:
5149 #ifdef PERL_USE_HWM
5150 PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
5151 #endif
5152 Perl_pp_pushmark(aTHX);
5153 CALLRUNOPS(aTHX);
5154 PL_op = curop;
5155 assert (!(curop->op_flags & OPf_SPECIAL));
5156 assert(curop->op_type == OP_RANGE);
5157 Perl_pp_anonlist(aTHX);
5158 break;
5159 case 3:
5160 CLEAR_ERRSV();
5161 o->op_next = old_next;
5162 break;
5163 default:
5164 JMPENV_POP;
5165 PL_warnhook = oldwarnhook;
5166 PL_diehook = olddiehook;
5167 Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
5168 ret);
5169 }
5170
5171 JMPENV_POP;
5172 PL_dowarn = oldwarn;
5173 PL_warnhook = oldwarnhook;
5174 PL_diehook = olddiehook;
5175 PL_curcop = old_curcop;
5176
5177 if (cxstack_ix > old_cxix) {
5178 assert(cxstack_ix == old_cxix + 1);
5179 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5180 delete_eval_scope();
5181 }
5182 if (ret)
5183 return;
5184
5185 OpTYPE_set(o, OP_RV2AV);
5186 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
5187 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
5188 o->op_opt = 0; /* needs to be revisited in rpeep() */
5189 av = (AV *)*PL_stack_sp;
5190
5191 /* replace subtree with an OP_CONST */
5192 curop = cUNOPo->op_first;
5193 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
5194 rpp_pop_1_norc();
5195 op_free(curop);
5196
5197 if (AvFILLp(av) != -1)
5198 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
5199 {
5200 SvPADTMP_on(*svp);
5201 SvREADONLY_on(*svp);
5202 }
5203 LINKLIST(o);
5204 list(o);
5205 return;
5206 }
5207
5208 /*
5209 =for apidoc_section $optree_manipulation
5210 */
5211
5212 enum {
5213 FORBID_LOOPEX_DEFAULT = (1<<0),
5214 };
5215
walk_ops_find_labels(pTHX_ OP * o,HV * gotolabels)5216 static void walk_ops_find_labels(pTHX_ OP *o, HV *gotolabels)
5217 {
5218 switch(o->op_type) {
5219 case OP_NEXTSTATE:
5220 case OP_DBSTATE:
5221 {
5222 STRLEN label_len;
5223 U32 label_flags;
5224 const char *label_pv = CopLABEL_len_flags((COP *)o, &label_len, &label_flags);
5225 if(!label_pv)
5226 break;
5227
5228 SV *labelsv = newSVpvn_flags(label_pv, label_len, label_flags);
5229 SAVEFREESV(labelsv);
5230
5231 sv_inc(HeVAL(hv_fetch_ent(gotolabels, labelsv, TRUE, 0)));
5232 break;
5233 }
5234 }
5235
5236 if(!(o->op_flags & OPf_KIDS))
5237 return;
5238
5239 OP *kid = cUNOPo->op_first;
5240 while(kid) {
5241 walk_ops_find_labels(aTHX_ kid, gotolabels);
5242 kid = OpSIBLING(kid);
5243 }
5244 }
5245
walk_ops_forbid(pTHX_ OP * o,U32 flags,HV * permittedloops,HV * permittedgotos,const char * blockname)5246 static void walk_ops_forbid(pTHX_ OP *o, U32 flags, HV *permittedloops, HV *permittedgotos, const char *blockname)
5247 {
5248 bool is_loop = FALSE;
5249 SV *labelsv = NULL;
5250
5251 switch(o->op_type) {
5252 case OP_NEXTSTATE:
5253 case OP_DBSTATE:
5254 PL_curcop = (COP *)o;
5255 return;
5256
5257 case OP_RETURN:
5258 goto forbid;
5259
5260 case OP_GOTO:
5261 {
5262 /* OPf_STACKED means either dynamically computed label or `goto &sub` */
5263 if(o->op_flags & OPf_STACKED)
5264 goto forbid;
5265
5266 SV *target = newSVpvn_utf8(cPVOPo->op_pv, strlen(cPVOPo->op_pv),
5267 cPVOPo->op_private & OPpPV_IS_UTF8);
5268 SAVEFREESV(target);
5269
5270 if(hv_fetch_ent(permittedgotos, target, FALSE, 0))
5271 break;
5272
5273 goto forbid;
5274 }
5275
5276 case OP_NEXT:
5277 case OP_LAST:
5278 case OP_REDO:
5279 {
5280 /* OPf_SPECIAL means this is a default loopex */
5281 if(o->op_flags & OPf_SPECIAL) {
5282 if(flags & FORBID_LOOPEX_DEFAULT)
5283 goto forbid;
5284
5285 break;
5286 }
5287 /* OPf_STACKED means it's a dynamically computed label */
5288 if(o->op_flags & OPf_STACKED)
5289 goto forbid;
5290
5291 SV *target = newSVpv(cPVOPo->op_pv, strlen(cPVOPo->op_pv));
5292 if(cPVOPo->op_private & OPpPV_IS_UTF8)
5293 SvUTF8_on(target);
5294 SAVEFREESV(target);
5295
5296 if(hv_fetch_ent(permittedloops, target, FALSE, 0))
5297 break;
5298
5299 goto forbid;
5300 }
5301
5302 case OP_LEAVELOOP:
5303 {
5304 STRLEN label_len;
5305 U32 label_flags;
5306 const char *label_pv = CopLABEL_len_flags(PL_curcop, &label_len, &label_flags);
5307
5308 if(label_pv) {
5309 labelsv = newSVpvn(label_pv, label_len);
5310 if(label_flags & SVf_UTF8)
5311 SvUTF8_on(labelsv);
5312 SAVEFREESV(labelsv);
5313
5314 sv_inc(HeVAL(hv_fetch_ent(permittedloops, labelsv, TRUE, 0)));
5315 }
5316
5317 is_loop = TRUE;
5318 break;
5319 }
5320
5321 forbid:
5322 /* diag_listed_as: Can't "%s" out of a "defer" block */
5323 /* diag_listed_as: Can't "%s" out of a "finally" block */
5324 croak("Can't \"%s\" out of %s", PL_op_name[o->op_type], blockname);
5325
5326 default:
5327 break;
5328 }
5329
5330 if(!(o->op_flags & OPf_KIDS))
5331 return;
5332
5333 OP *kid = cUNOPo->op_first;
5334 while(kid) {
5335 walk_ops_forbid(aTHX_ kid, flags, permittedloops, permittedgotos, blockname);
5336 kid = OpSIBLING(kid);
5337
5338 if(is_loop) {
5339 /* Now in the body of the loop; we can permit loopex default */
5340 flags &= ~FORBID_LOOPEX_DEFAULT;
5341 }
5342 }
5343
5344 if(is_loop && labelsv) {
5345 HE *he = hv_fetch_ent(permittedloops, labelsv, FALSE, 0);
5346 if(SvIV(HeVAL(he)) > 1)
5347 sv_dec(HeVAL(he));
5348 else
5349 hv_delete_ent(permittedloops, labelsv, 0, 0);
5350 }
5351 }
5352
5353 /*
5354 =for apidoc forbid_outofblock_ops
5355
5356 Checks an optree that implements a block, to ensure there are no control-flow
5357 ops that attempt to leave the block. Any C<OP_RETURN> is forbidden, as is any
5358 C<OP_GOTO>. Loops are analysed, so any LOOPEX op (C<OP_NEXT>, C<OP_LAST> or
5359 C<OP_REDO>) that affects a loop that contains it within the block are
5360 permitted, but those that do not are forbidden.
5361
5362 If any of these forbidden constructions are detected, an exception is thrown
5363 by using the op name and the blockname argument to construct a suitable
5364 message.
5365
5366 This function alone is not sufficient to ensure the optree does not perform
5367 any of these forbidden activities during runtime, as it might call a different
5368 function that performs a non-local LOOPEX, or a string-eval() that performs a
5369 C<goto>, or various other things. It is intended purely as a compile-time
5370 check for those that could be detected statically. Additional runtime checks
5371 may be required depending on the circumstance it is used for.
5372
5373 Note currently that I<all> C<OP_GOTO> ops are forbidden, even in cases where
5374 they might otherwise be safe to execute. This may be permitted in a later
5375 version.
5376
5377 =cut
5378 */
5379
5380 void
Perl_forbid_outofblock_ops(pTHX_ OP * o,const char * blockname)5381 Perl_forbid_outofblock_ops(pTHX_ OP *o, const char *blockname)
5382 {
5383 PERL_ARGS_ASSERT_FORBID_OUTOFBLOCK_OPS;
5384
5385 ENTER;
5386 SAVEVPTR(PL_curcop);
5387
5388 HV *looplabels = newHV();
5389 SAVEFREESV((SV *)looplabels);
5390
5391 HV *gotolabels = newHV();
5392 SAVEFREESV((SV *)gotolabels);
5393
5394 walk_ops_find_labels(aTHX_ o, gotolabels);
5395
5396 walk_ops_forbid(aTHX_ o, FORBID_LOOPEX_DEFAULT, looplabels, gotolabels, blockname);
5397
5398 LEAVE;
5399 }
5400
5401 /* List constructors */
5402
5403 /*
5404 =for apidoc op_append_elem
5405
5406 Append an item to the list of ops contained directly within a list-type
5407 op, returning the lengthened list. C<first> is the list-type op,
5408 and C<last> is the op to append to the list. C<optype> specifies the
5409 intended opcode for the list. If C<first> is not already a list of the
5410 right type, it will be upgraded into one. If either C<first> or C<last>
5411 is null, the other is returned unchanged.
5412
5413 =cut
5414 */
5415
5416 OP *
Perl_op_append_elem(pTHX_ I32 type,OP * first,OP * last)5417 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
5418 {
5419 if (!first)
5420 return last;
5421
5422 if (!last)
5423 return first;
5424
5425 if (first->op_type != (unsigned)type
5426 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
5427 {
5428 return newLISTOP(type, 0, first, last);
5429 }
5430
5431 op_sibling_splice(first, cLISTOPx(first)->op_last, 0, last);
5432 first->op_flags |= OPf_KIDS;
5433 return first;
5434 }
5435
5436 /*
5437 =for apidoc op_append_list
5438
5439 Concatenate the lists of ops contained directly within two list-type ops,
5440 returning the combined list. C<first> and C<last> are the list-type ops
5441 to concatenate. C<optype> specifies the intended opcode for the list.
5442 If either C<first> or C<last> is not already a list of the right type,
5443 it will be upgraded into one. If either C<first> or C<last> is null,
5444 the other is returned unchanged.
5445
5446 =cut
5447 */
5448
5449 OP *
Perl_op_append_list(pTHX_ I32 type,OP * first,OP * last)5450 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
5451 {
5452 if (!first)
5453 return last;
5454
5455 if (!last)
5456 return first;
5457
5458 if (first->op_type != (unsigned)type)
5459 return op_prepend_elem(type, first, last);
5460
5461 if (last->op_type != (unsigned)type)
5462 return op_append_elem(type, first, last);
5463
5464 OpMORESIB_set(cLISTOPx(first)->op_last, cLISTOPx(last)->op_first);
5465 cLISTOPx(first)->op_last = cLISTOPx(last)->op_last;
5466 OpLASTSIB_set(cLISTOPx(first)->op_last, first);
5467 first->op_flags |= (last->op_flags & OPf_KIDS);
5468
5469 S_op_destroy(aTHX_ last);
5470
5471 return first;
5472 }
5473
5474 /*
5475 =for apidoc op_prepend_elem
5476
5477 Prepend an item to the list of ops contained directly within a list-type
5478 op, returning the lengthened list. C<first> is the op to prepend to the
5479 list, and C<last> is the list-type op. C<optype> specifies the intended
5480 opcode for the list. If C<last> is not already a list of the right type,
5481 it will be upgraded into one. If either C<first> or C<last> is null,
5482 the other is returned unchanged.
5483
5484 =cut
5485 */
5486
5487 OP *
Perl_op_prepend_elem(pTHX_ I32 type,OP * first,OP * last)5488 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
5489 {
5490 if (!first)
5491 return last;
5492
5493 if (!last)
5494 return first;
5495
5496 if (last->op_type == (unsigned)type) {
5497 if (type == OP_LIST) { /* already a PUSHMARK there */
5498 /* insert 'first' after pushmark */
5499 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
5500 if (!(first->op_flags & OPf_PARENS))
5501 last->op_flags &= ~OPf_PARENS;
5502 }
5503 else
5504 op_sibling_splice(last, NULL, 0, first);
5505 last->op_flags |= OPf_KIDS;
5506 return last;
5507 }
5508
5509 return newLISTOP(type, 0, first, last);
5510 }
5511
5512 /*
5513 =for apidoc op_convert_list
5514
5515 Converts C<o> into a list op if it is not one already, and then converts it
5516 into the specified C<type>, calling its check function, allocating a target if
5517 it needs one, and folding constants.
5518
5519 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
5520 C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
5521 C<op_convert_list> to make it the right type.
5522
5523 =cut
5524 */
5525
5526 OP *
Perl_op_convert_list(pTHX_ I32 type,I32 flags,OP * o)5527 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
5528 {
5529 if (type < 0) type = -type, flags |= OPf_SPECIAL;
5530 if (type == OP_RETURN) {
5531 if (FEATURE_MODULE_TRUE_IS_ENABLED)
5532 flags |= OPf_SPECIAL;
5533 }
5534 if (!o || o->op_type != OP_LIST)
5535 o = force_list(o, FALSE);
5536 else
5537 {
5538 o->op_flags &= ~OPf_WANT;
5539 o->op_private &= ~OPpLVAL_INTRO;
5540 }
5541
5542 if (!(PL_opargs[type] & OA_MARK))
5543 op_null(cLISTOPo->op_first);
5544 else {
5545 OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
5546 if (kid2 && kid2->op_type == OP_COREARGS) {
5547 op_null(cLISTOPo->op_first);
5548 kid2->op_private |= OPpCOREARGS_PUSHMARK;
5549 }
5550 }
5551
5552 if (type != OP_SPLIT)
5553 /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
5554 * ck_split() create a real PMOP and leave the op's type as listop
5555 * for now. Otherwise op_free() etc will crash.
5556 */
5557 OpTYPE_set(o, type);
5558
5559 o->op_flags |= flags;
5560 if (flags & OPf_FOLDED)
5561 o->op_folded = 1;
5562
5563 o = CHECKOP(type, o);
5564 if (o->op_type != (unsigned)type)
5565 return o;
5566
5567 return fold_constants(op_integerize(op_std_init(o)));
5568 }
5569
5570 /* Constructors */
5571
5572
5573 /*
5574 =for apidoc_section $optree_construction
5575
5576 =for apidoc newNULLLIST
5577
5578 Constructs, checks, and returns a new C<stub> op, which represents an
5579 empty list expression.
5580
5581 =cut
5582 */
5583
5584 OP *
Perl_newNULLLIST(pTHX)5585 Perl_newNULLLIST(pTHX)
5586 {
5587 return newOP(OP_STUB, 0);
5588 }
5589
5590 /* promote o and any siblings to be a list if its not already; i.e.
5591 *
5592 * o - A - B
5593 *
5594 * becomes
5595 *
5596 * list
5597 * |
5598 * pushmark - o - A - B
5599 *
5600 * If nullit it true, the list op is nulled.
5601 */
5602
5603 static OP *
S_force_list(pTHX_ OP * o,bool nullit)5604 S_force_list(pTHX_ OP *o, bool nullit)
5605 {
5606 if (!o || o->op_type != OP_LIST) {
5607 OP *rest = NULL;
5608 if (o) {
5609 /* manually detach any siblings then add them back later */
5610 rest = OpSIBLING(o);
5611 OpLASTSIB_set(o, NULL);
5612 }
5613 o = newLISTOP(OP_LIST, 0, o, NULL);
5614 if (rest)
5615 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
5616 }
5617 if (nullit)
5618 op_null(o);
5619 return o;
5620 }
5621
5622 /*
5623 =for apidoc op_force_list
5624
5625 Promotes o and any siblings to be an C<OP_LIST> if it is not already. If
5626 a new C<OP_LIST> op was created, its first child will be C<OP_PUSHMARK>.
5627 The returned node itself will be nulled, leaving only its children.
5628
5629 This is often what you want to do before putting the optree into list
5630 context; as
5631
5632 o = op_contextualize(op_force_list(o), G_LIST);
5633
5634 =cut
5635 */
5636
5637 OP *
Perl_op_force_list(pTHX_ OP * o)5638 Perl_op_force_list(pTHX_ OP *o)
5639 {
5640 return force_list(o, TRUE);
5641 }
5642
5643 /*
5644 =for apidoc newLISTOP
5645
5646 Constructs, checks, and returns an op of any list type. C<type> is
5647 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
5648 C<OPf_KIDS> will be set automatically if required. C<first> and C<last>
5649 supply up to two ops to be direct children of the list op; they are
5650 consumed by this function and become part of the constructed op tree.
5651
5652 For most list operators, the check function expects all the kid ops to be
5653 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
5654 appropriate. What you want to do in that case is create an op of type
5655 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
5656 See L</op_convert_list> for more information.
5657
5658 If a compiletime-known fixed list of child ops is required, the
5659 L</newLISTOPn> function can be used as a convenient shortcut, avoiding the
5660 need to create a temporary plain C<OP_LIST> in a new variable.
5661
5662 =cut
5663 */
5664
5665 OP *
Perl_newLISTOP(pTHX_ I32 type,I32 flags,OP * first,OP * last)5666 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
5667 {
5668 LISTOP *listop;
5669 /* Note that allocating an OP_PUSHMARK can die under Safe.pm if
5670 * pushmark is banned. So do it now while existing ops are in a
5671 * consistent state, in case they suddenly get freed */
5672 OP* const pushop = type == OP_LIST ? newOP(OP_PUSHMARK, 0) : NULL;
5673
5674 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
5675 || type == OP_CUSTOM);
5676
5677 NewOp(1101, listop, 1, LISTOP);
5678 OpTYPE_set(listop, type);
5679 if (first || last)
5680 flags |= OPf_KIDS;
5681 listop->op_flags = (U8)flags;
5682
5683 if (!last && first)
5684 last = first;
5685 else if (!first && last)
5686 first = last;
5687 else if (first)
5688 OpMORESIB_set(first, last);
5689 listop->op_first = first;
5690 listop->op_last = last;
5691
5692 if (pushop) {
5693 OpMORESIB_set(pushop, first);
5694 listop->op_first = pushop;
5695 listop->op_flags |= OPf_KIDS;
5696 if (!last)
5697 listop->op_last = pushop;
5698 }
5699 if (listop->op_last)
5700 OpLASTSIB_set(listop->op_last, (OP*)listop);
5701
5702 return CHECKOP(type, listop);
5703 }
5704
5705 /*
5706 =for apidoc newLISTOPn
5707
5708 Constructs, checks, and returns an op of any list type. C<type> is
5709 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
5710 C<OPf_KIDS> will be set automatically if required. The variable number of
5711 arguments after C<flags> must all be OP pointers, terminated by a final
5712 C<NULL> pointer. These will all be consumed as direct children of the list
5713 op and become part of the constructed op tree.
5714
5715 Do not forget to end the arguments list with a C<NULL> pointer.
5716
5717 This function is useful as a shortcut to performing the sequence of
5718 C<newLISTOP()>, C<op_append_elem()> on each element and final
5719 C<op_convert_list()> in the case where a compiletime-known fixed sequence of
5720 child ops is required. If a variable number of elements are required, or for
5721 splicing in an entire sub-list of child ops, see instead L</newLISTOP> and
5722 L</op_convert_list>.
5723
5724 =cut
5725 */
5726
5727 OP *
Perl_newLISTOPn(pTHX_ I32 type,I32 flags,...)5728 Perl_newLISTOPn(pTHX_ I32 type, I32 flags, ...)
5729 {
5730 va_list args;
5731 va_start(args, flags);
5732
5733 OP *o = newLISTOP(OP_LIST, 0, NULL, NULL);
5734
5735 OP *kid;
5736 while((kid = va_arg(args, OP *)))
5737 o = op_append_elem(OP_LIST, o, kid);
5738
5739 va_end(args);
5740
5741 return op_convert_list(type, flags, o);
5742 }
5743
5744 /*
5745 =for apidoc newOP
5746
5747 Constructs, checks, and returns an op of any base type (any type that
5748 has no extra fields). C<type> is the opcode. C<flags> gives the
5749 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
5750 of C<op_private>.
5751
5752 =cut
5753 */
5754
5755 OP *
Perl_newOP(pTHX_ I32 type,I32 flags)5756 Perl_newOP(pTHX_ I32 type, I32 flags)
5757 {
5758 OP *o;
5759
5760 if (type == -OP_ENTEREVAL) {
5761 type = OP_ENTEREVAL;
5762 flags |= OPpEVAL_BYTES<<8;
5763 }
5764
5765 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
5766 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
5767 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5768 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5769
5770 NewOp(1101, o, 1, OP);
5771 OpTYPE_set(o, type);
5772 o->op_flags = (U8)flags;
5773
5774 o->op_next = o;
5775 o->op_private = (U8)(0 | (flags >> 8));
5776 if (PL_opargs[type] & OA_RETSCALAR)
5777 scalar(o);
5778 if (PL_opargs[type] & OA_TARGET)
5779 o->op_targ = pad_alloc(type, SVs_PADTMP);
5780 return CHECKOP(type, o);
5781 }
5782
5783 /*
5784 =for apidoc newUNOP
5785
5786 Constructs, checks, and returns an op of any unary type. C<type> is
5787 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
5788 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
5789 bits, the eight bits of C<op_private>, except that the bit with value 1
5790 is automatically set. C<first> supplies an optional op to be the direct
5791 child of the unary op; it is consumed by this function and become part
5792 of the constructed op tree.
5793
5794 =for apidoc Amnh||OPf_KIDS
5795
5796 =cut
5797 */
5798
5799 OP *
Perl_newUNOP(pTHX_ I32 type,I32 flags,OP * first)5800 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
5801 {
5802 UNOP *unop;
5803
5804 if (type == -OP_ENTEREVAL) {
5805 type = OP_ENTEREVAL;
5806 flags |= OPpEVAL_BYTES<<8;
5807 }
5808
5809 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
5810 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
5811 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5812 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
5813 || type == OP_SASSIGN
5814 || type == OP_ENTERTRY
5815 || type == OP_ENTERTRYCATCH
5816 || type == OP_CUSTOM
5817 || type == OP_NULL );
5818
5819 if (!first)
5820 first = newOP(OP_STUB, 0);
5821 if (PL_opargs[type] & OA_MARK)
5822 first = op_force_list(first);
5823
5824 NewOp(1101, unop, 1, UNOP);
5825 OpTYPE_set(unop, type);
5826 unop->op_first = first;
5827 unop->op_flags = (U8)(flags | OPf_KIDS);
5828 unop->op_private = (U8)(1 | (flags >> 8));
5829
5830 if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
5831 OpLASTSIB_set(first, (OP*)unop);
5832
5833 unop = (UNOP*) CHECKOP(type, unop);
5834 if (unop->op_next)
5835 return (OP*)unop;
5836
5837 return fold_constants(op_integerize(op_std_init((OP *) unop)));
5838 }
5839
5840 /*
5841 =for apidoc newUNOP_AUX
5842
5843 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
5844 initialised to C<aux>
5845
5846 =cut
5847 */
5848
5849 OP *
Perl_newUNOP_AUX(pTHX_ I32 type,I32 flags,OP * first,UNOP_AUX_item * aux)5850 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
5851 {
5852 UNOP_AUX *unop;
5853
5854 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
5855 || type == OP_CUSTOM);
5856
5857 NewOp(1101, unop, 1, UNOP_AUX);
5858 unop->op_type = (OPCODE)type;
5859 unop->op_ppaddr = PL_ppaddr[type];
5860 unop->op_first = first;
5861 unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
5862 unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
5863 unop->op_aux = aux;
5864
5865 if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
5866 OpLASTSIB_set(first, (OP*)unop);
5867
5868 unop = (UNOP_AUX*) CHECKOP(type, unop);
5869
5870 return op_std_init((OP *) unop);
5871 }
5872
5873 /*
5874 =for apidoc newMETHOP
5875
5876 Constructs, checks, and returns an op of method type with a method name
5877 evaluated at runtime. C<type> is the opcode. C<flags> gives the eight
5878 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
5879 and, shifted up eight bits, the eight bits of C<op_private>, except that
5880 the bit with value 1 is automatically set. C<dynamic_meth> supplies an
5881 op which evaluates method name; it is consumed by this function and
5882 become part of the constructed op tree.
5883 Supported optypes: C<OP_METHOD>.
5884
5885 =cut
5886 */
5887
5888 static OP*
S_newMETHOP_internal(pTHX_ I32 type,I32 flags,OP * dynamic_meth,SV * const_meth)5889 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
5890 METHOP *methop;
5891
5892 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
5893 || type == OP_CUSTOM);
5894
5895 NewOp(1101, methop, 1, METHOP);
5896 if (dynamic_meth) {
5897 if (PL_opargs[type] & OA_MARK) dynamic_meth = op_force_list(dynamic_meth);
5898 methop->op_flags = (U8)(flags | OPf_KIDS);
5899 methop->op_u.op_first = dynamic_meth;
5900 methop->op_private = (U8)(1 | (flags >> 8));
5901
5902 if (!OpHAS_SIBLING(dynamic_meth))
5903 OpLASTSIB_set(dynamic_meth, (OP*)methop);
5904 }
5905 else {
5906 assert(const_meth);
5907 methop->op_flags = (U8)(flags & ~OPf_KIDS);
5908 methop->op_u.op_meth_sv = const_meth;
5909 methop->op_private = (U8)(0 | (flags >> 8));
5910 methop->op_next = (OP*)methop;
5911 }
5912
5913 #ifdef USE_ITHREADS
5914 methop->op_rclass_targ = 0;
5915 #else
5916 methop->op_rclass_sv = NULL;
5917 #endif
5918
5919 OpTYPE_set(methop, type);
5920 return CHECKOP(type, methop);
5921 }
5922
5923 OP *
Perl_newMETHOP(pTHX_ I32 type,I32 flags,OP * dynamic_meth)5924 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
5925 PERL_ARGS_ASSERT_NEWMETHOP;
5926 return newMETHOP_internal(type, flags, dynamic_meth, NULL);
5927 }
5928
5929 /*
5930 =for apidoc newMETHOP_named
5931
5932 Constructs, checks, and returns an op of method type with a constant
5933 method name. C<type> is the opcode. C<flags> gives the eight bits of
5934 C<op_flags>, and, shifted up eight bits, the eight bits of
5935 C<op_private>. C<const_meth> supplies a constant method name;
5936 it must be a shared COW string.
5937 Supported optypes: C<OP_METHOD_NAMED>.
5938
5939 =cut
5940 */
5941
5942 OP *
Perl_newMETHOP_named(pTHX_ I32 type,I32 flags,SV * const_meth)5943 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
5944 PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
5945 return newMETHOP_internal(type, flags, NULL, const_meth);
5946 }
5947
5948 /*
5949 =for apidoc newBINOP
5950
5951 Constructs, checks, and returns an op of any binary type. C<type>
5952 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
5953 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5954 the eight bits of C<op_private>, except that the bit with value 1 or
5955 2 is automatically set as required. C<first> and C<last> supply up to
5956 two ops to be the direct children of the binary op; they are consumed
5957 by this function and become part of the constructed op tree.
5958
5959 =cut
5960 */
5961
5962 OP *
Perl_newBINOP(pTHX_ I32 type,I32 flags,OP * first,OP * last)5963 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
5964 {
5965 BINOP *binop;
5966
5967 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
5968 || type == OP_NULL || type == OP_CUSTOM);
5969
5970 if (!first)
5971 first = newOP(OP_NULL, 0);
5972 else if (type != OP_SASSIGN && S_is_control_transfer(aTHX_ first)) {
5973 /* Skip OP_SASSIGN.
5974 * '$x = return 42' is represented by (SASSIGN (RETURN 42) (GVSV *x));
5975 * in other words, OP_SASSIGN has its operands "backwards". Skip the
5976 * control transfer check because '$x = return $y' is not a precedence
5977 * issue (the '$x =' part has no runtime effect no matter how you
5978 * parenthesize it).
5979 * Also, don't try to optimize the OP_SASSIGN case because the logical
5980 * assignment ops like //= are represented by an OP_{AND,OR,DOR}ASSIGN
5981 * containing an OP_SASSIGN with a single child (first == last):
5982 * '$x //= return 42' is (DORASSIGN (GVSV *x) (SASSIGN (RETURN 42))).
5983 * Naively eliminating the OP_ASSIGN leaves the incomplete (DORASSIGN
5984 * (GVSV *x) (RETURN 42)), which e.g. B::Deparse doesn't handle.
5985 */
5986 assert(first != last);
5987 op_free(last);
5988 first->op_folded = 1;
5989 return first;
5990 }
5991
5992 NewOp(1101, binop, 1, BINOP);
5993
5994 OpTYPE_set(binop, type);
5995 binop->op_first = first;
5996 binop->op_flags = (U8)(flags | OPf_KIDS);
5997 if (!last) {
5998 last = first;
5999 binop->op_private = (U8)(1 | (flags >> 8));
6000 }
6001 else {
6002 binop->op_private = (U8)(2 | (flags >> 8));
6003 OpMORESIB_set(first, last);
6004 }
6005
6006 if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
6007 OpLASTSIB_set(last, (OP*)binop);
6008
6009 binop->op_last = OpSIBLING(binop->op_first);
6010 if (binop->op_last)
6011 OpLASTSIB_set(binop->op_last, (OP*)binop);
6012
6013 binop = (BINOP*) CHECKOP(type, binop);
6014 if (binop->op_next || binop->op_type != (OPCODE)type)
6015 return (OP*)binop;
6016
6017 return fold_constants(op_integerize(op_std_init((OP *)binop)));
6018 }
6019
6020 void
Perl_invmap_dump(pTHX_ SV * invlist,UV * map)6021 Perl_invmap_dump(pTHX_ SV* invlist, UV *map)
6022 {
6023 const char indent[] = " ";
6024
6025 UV len = _invlist_len(invlist);
6026 UV * array = invlist_array(invlist);
6027 UV i;
6028
6029 PERL_ARGS_ASSERT_INVMAP_DUMP;
6030
6031 for (i = 0; i < len; i++) {
6032 UV start = array[i];
6033 UV end = (i + 1 < len) ? array[i+1] - 1 : IV_MAX;
6034
6035 PerlIO_printf(Perl_debug_log, "%s[%" UVuf "] 0x%04" UVXf, indent, i, start);
6036 if (end == IV_MAX) {
6037 PerlIO_printf(Perl_debug_log, " .. INFTY");
6038 }
6039 else if (end != start) {
6040 PerlIO_printf(Perl_debug_log, " .. 0x%04" UVXf, end);
6041 }
6042 else {
6043 PerlIO_printf(Perl_debug_log, " ");
6044 }
6045
6046 PerlIO_printf(Perl_debug_log, "\t");
6047
6048 if (map[i] == TR_UNLISTED) {
6049 PerlIO_printf(Perl_debug_log, "TR_UNLISTED\n");
6050 }
6051 else if (map[i] == TR_SPECIAL_HANDLING) {
6052 PerlIO_printf(Perl_debug_log, "TR_SPECIAL_HANDLING\n");
6053 }
6054 else {
6055 PerlIO_printf(Perl_debug_log, "0x%04" UVXf "\n", map[i]);
6056 }
6057 }
6058 }
6059
6060 /* Given an OP_TRANS / OP_TRANSR op o, plus OP_CONST ops expr and repl
6061 * containing the search and replacement strings, assemble into
6062 * a translation table attached as o->op_pv.
6063 * Free expr and repl.
6064 * It expects the toker to have already set the
6065 * OPpTRANS_COMPLEMENT
6066 * OPpTRANS_SQUASH
6067 * OPpTRANS_DELETE
6068 * flags as appropriate; this function may add
6069 * OPpTRANS_USE_SVOP
6070 * OPpTRANS_CAN_FORCE_UTF8
6071 * OPpTRANS_IDENTICAL
6072 * OPpTRANS_GROWS
6073 * flags
6074 */
6075
6076 static OP *
S_pmtrans(pTHX_ OP * o,OP * expr,OP * repl)6077 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
6078 {
6079 /* This function compiles a tr///, from data gathered from toke.c, into a
6080 * form suitable for use by do_trans() in doop.c at runtime.
6081 *
6082 * It first normalizes the data, while discarding extraneous inputs; then
6083 * writes out the compiled data. The normalization allows for complete
6084 * analysis, and avoids some false negatives and positives earlier versions
6085 * of this code had.
6086 *
6087 * The normalization form is an inversion map (described below in detail).
6088 * This is essentially the compiled form for tr///'s that require UTF-8,
6089 * and its easy to use it to write the 257-byte table for tr///'s that
6090 * don't need UTF-8. That table is identical to what's been in use for
6091 * many perl versions, except that it doesn't handle some edge cases that
6092 * it used to, involving code points above 255. The UTF-8 form now handles
6093 * these. (This could be changed with extra coding should it shown to be
6094 * desirable.)
6095 *
6096 * If the complement (/c) option is specified, the lhs string (tstr) is
6097 * parsed into an inversion list. Complementing these is trivial. Then a
6098 * complemented tstr is built from that, and used thenceforth. This hides
6099 * the fact that it was complemented from almost all successive code.
6100 *
6101 * One of the important characteristics to know about the input is whether
6102 * the transliteration may be done in place, or does a temporary need to be
6103 * allocated, then copied. If the replacement for every character in every
6104 * possible string takes up no more bytes than the character it
6105 * replaces, then it can be edited in place. Otherwise the replacement
6106 * could overwrite a byte we are about to read, depending on the strings
6107 * being processed. The comments and variable names here refer to this as
6108 * "growing". Some inputs won't grow, and might even shrink under /d, but
6109 * some inputs could grow, so we have to assume any given one might grow.
6110 * On very long inputs, the temporary could eat up a lot of memory, so we
6111 * want to avoid it if possible. For non-UTF-8 inputs, everything is
6112 * single-byte, so can be edited in place, unless there is something in the
6113 * pattern that could force it into UTF-8. The inversion map makes it
6114 * feasible to determine this. Previous versions of this code pretty much
6115 * punted on determining if UTF-8 could be edited in place. Now, this code
6116 * is rigorous in making that determination.
6117 *
6118 * Another characteristic we need to know is whether the lhs and rhs are
6119 * identical. If so, and no other flags are present, the only effect of
6120 * the tr/// is to count the characters present in the input that are
6121 * mentioned in the lhs string. The implementation of that is easier and
6122 * runs faster than the more general case. Normalizing here allows for
6123 * accurate determination of this. Previously there were false negatives
6124 * possible.
6125 *
6126 * Instead of 'transliterated', the comments here use 'unmapped' for the
6127 * characters that are left unchanged by the operation; otherwise they are
6128 * 'mapped'
6129 *
6130 * The lhs of the tr/// is here referred to as the t side.
6131 * The rhs of the tr/// is here referred to as the r side.
6132 */
6133
6134 SV * const tstr = cSVOPx(expr)->op_sv;
6135 SV * const rstr = cSVOPx(repl)->op_sv;
6136 STRLEN tlen;
6137 STRLEN rlen;
6138 const U8 * t0 = (U8*)SvPV_const(tstr, tlen);
6139 const U8 * r0 = (U8*)SvPV_const(rstr, rlen);
6140 const U8 * t = t0;
6141 const U8 * r = r0;
6142 UV t_count = 0, r_count = 0; /* Number of characters in search and
6143 replacement lists */
6144
6145 /* khw thinks some of the private flags for this op are quaintly named.
6146 * OPpTRANS_GROWS for example is TRUE if the replacement for some lhs
6147 * character when represented in UTF-8 is longer than the original
6148 * character's UTF-8 representation */
6149 const bool complement = cBOOL(o->op_private & OPpTRANS_COMPLEMENT);
6150 const bool squash = cBOOL(o->op_private & OPpTRANS_SQUASH);
6151 const bool del = cBOOL(o->op_private & OPpTRANS_DELETE);
6152
6153 /* Set to true if there is some character < 256 in the lhs that maps to
6154 * above 255. If so, a non-UTF-8 match string can be forced into being in
6155 * UTF-8 by a tr/// operation. */
6156 bool can_force_utf8 = FALSE;
6157
6158 /* What is the maximum expansion factor in UTF-8 transliterations. If a
6159 * 2-byte UTF-8 encoded character is to be replaced by a 3-byte one, its
6160 * expansion factor is 1.5. This number is used at runtime to calculate
6161 * how much space to allocate for non-inplace transliterations. Without
6162 * this number, the worst case is 14, which is extremely unlikely to happen
6163 * in real life, and could require significant memory overhead. */
6164 NV max_expansion = 1.;
6165
6166 UV t_range_count, r_range_count, min_range_count;
6167 UV* t_array;
6168 SV* t_invlist;
6169 UV* r_map;
6170 UV r_cp = 0, t_cp = 0;
6171 UV t_cp_end = (UV) -1;
6172 UV r_cp_end;
6173 Size_t len;
6174 AV* invmap;
6175 UV final_map = TR_UNLISTED; /* The final character in the replacement
6176 list, updated as we go along. Initialize
6177 to something illegal */
6178
6179 bool rstr_utf8 = cBOOL(SvUTF8(rstr));
6180 bool tstr_utf8 = cBOOL(SvUTF8(tstr));
6181
6182 const U8* tend = t + tlen;
6183 const U8* rend = r + rlen;
6184
6185 SV * inverted_tstr = NULL;
6186
6187 Size_t i;
6188 unsigned int pass2;
6189
6190 /* This routine implements detection of a transliteration having a longer
6191 * UTF-8 representation than its source, by partitioning all the possible
6192 * code points of the platform into equivalence classes of the same UTF-8
6193 * byte length in the first pass. As it constructs the mappings, it carves
6194 * these up into smaller chunks, but doesn't merge any together. This
6195 * makes it easy to find the instances it's looking for. A second pass is
6196 * done after this has been determined which merges things together to
6197 * shrink the table for runtime. The table below is used for both ASCII
6198 * and EBCDIC platforms. On EBCDIC, the byte length is not monotonically
6199 * increasing for code points below 256. To correct for that, the macro
6200 * CP_ADJUST defined below converts those code points to ASCII in the first
6201 * pass, and we use the ASCII partition values. That works because the
6202 * growth factor will be unaffected, which is all that is calculated during
6203 * the first pass. */
6204 UV PL_partition_by_byte_length[] = {
6205 0,
6206 0x80, /* Below this is 1 byte representations */
6207 (32 * (1UL << ( UTF_ACCUMULATION_SHIFT))), /* 2 bytes below this */
6208 (16 * (1UL << (2 * UTF_ACCUMULATION_SHIFT))), /* 3 bytes below this */
6209 ( 8 * (1UL << (3 * UTF_ACCUMULATION_SHIFT))), /* 4 bytes below this */
6210 ( 4 * (1UL << (4 * UTF_ACCUMULATION_SHIFT))), /* 5 bytes below this */
6211 ( 2 * (1UL << (5 * UTF_ACCUMULATION_SHIFT))) /* 6 bytes below this */
6212
6213 # ifdef UV_IS_QUAD
6214 ,
6215 ( ((UV) 1U << (6 * UTF_ACCUMULATION_SHIFT))) /* 7 bytes below this */
6216 # endif
6217
6218 };
6219
6220 PERL_ARGS_ASSERT_PMTRANS;
6221
6222 PL_hints |= HINT_BLOCK_SCOPE;
6223
6224 /* If /c, the search list is sorted and complemented. This is now done by
6225 * creating an inversion list from it, and then trivially inverting that.
6226 * The previous implementation used qsort, but creating the list
6227 * automatically keeps it sorted as we go along */
6228 if (complement) {
6229 UV start, end;
6230 SV * inverted_tlist = _new_invlist(tlen);
6231 Size_t temp_len;
6232
6233 DEBUG_y(PerlIO_printf(Perl_debug_log,
6234 "%s: %d: tstr before inversion=\n%s\n",
6235 __FILE__, __LINE__, _byte_dump_string(t, tend - t, 0)));
6236
6237 while (t < tend) {
6238
6239 /* Non-utf8 strings don't have ranges, so each character is listed
6240 * out */
6241 if (! tstr_utf8) {
6242 inverted_tlist = add_cp_to_invlist(inverted_tlist, *t);
6243 t++;
6244 }
6245 else { /* But UTF-8 strings have been parsed in toke.c to have
6246 * ranges if appropriate. */
6247 UV t_cp;
6248 Size_t t_char_len;
6249
6250 /* Get the first character */
6251 t_cp = valid_utf8_to_uvchr(t, &t_char_len);
6252 t += t_char_len;
6253
6254 /* If the next byte indicates that this wasn't the first
6255 * element of a range, the range is just this one */
6256 if (t >= tend || *t != RANGE_INDICATOR) {
6257 inverted_tlist = add_cp_to_invlist(inverted_tlist, t_cp);
6258 }
6259 else { /* Otherwise, ignore the indicator byte, and get the
6260 final element, and add the whole range */
6261 t++;
6262 t_cp_end = valid_utf8_to_uvchr(t, &t_char_len);
6263 t += t_char_len;
6264
6265 inverted_tlist = _add_range_to_invlist(inverted_tlist,
6266 t_cp, t_cp_end);
6267 }
6268 }
6269 } /* End of parse through tstr */
6270
6271 /* The inversion list is done; now invert it */
6272 _invlist_invert(inverted_tlist);
6273
6274 /* Now go through the inverted list and create a new tstr for the rest
6275 * of the routine to use. Since the UTF-8 version can have ranges, and
6276 * can be much more compact than the non-UTF-8 version, we create the
6277 * string in UTF-8 even if not necessary. (This is just an intermediate
6278 * value that gets thrown away anyway.) */
6279 invlist_iterinit(inverted_tlist);
6280 inverted_tstr = newSVpvs("");
6281 while (invlist_iternext(inverted_tlist, &start, &end)) {
6282 U8 temp[UTF8_MAXBYTES];
6283 U8 * temp_end_pos;
6284
6285 /* IV_MAX keeps things from going out of bounds */
6286 start = MIN(IV_MAX, start);
6287 end = MIN(IV_MAX, end);
6288
6289 temp_end_pos = uvchr_to_utf8(temp, start);
6290 sv_catpvn(inverted_tstr, (char *) temp, temp_end_pos - temp);
6291
6292 if (start != end) {
6293 Perl_sv_catpvf(aTHX_ inverted_tstr, "%c", RANGE_INDICATOR);
6294 temp_end_pos = uvchr_to_utf8(temp, end);
6295 sv_catpvn(inverted_tstr, (char *) temp, temp_end_pos - temp);
6296 }
6297 }
6298
6299 /* Set up so the remainder of the routine uses this complement, instead
6300 * of the actual input */
6301 t0 = t = (U8*)SvPV_const(inverted_tstr, temp_len);
6302 tend = t0 + temp_len;
6303 tstr_utf8 = TRUE;
6304
6305 SvREFCNT_dec_NN(inverted_tlist);
6306 }
6307
6308 /* For non-/d, an empty rhs means to use the lhs */
6309 if (rlen == 0 && ! del) {
6310 r0 = t0;
6311 rend = tend;
6312 rstr_utf8 = tstr_utf8;
6313 }
6314
6315 t_invlist = _new_invlist(1);
6316
6317 /* Initialize to a single range */
6318 t_invlist = _add_range_to_invlist(t_invlist, 0, UV_MAX);
6319
6320 /* Below, we parse the (potentially adjusted) input, creating the inversion
6321 * map. This is done in two passes. The first pass is just to determine
6322 * if the transliteration can be done in-place. It can be done in place if
6323 * no possible inputs result in the replacement taking up more bytes than
6324 * the input. To figure that out, in the first pass we start with all the
6325 * possible code points partitioned into ranges so that every code point in
6326 * a range occupies the same number of UTF-8 bytes as every other code
6327 * point in the range. Constructing the inversion map doesn't merge ranges
6328 * together, but can split them into multiple ones. Given the starting
6329 * partition, the ending state will also have the same characteristic,
6330 * namely that each code point in each partition requires the same number
6331 * of UTF-8 bytes to represent as every other code point in the same
6332 * partition.
6333 *
6334 * This partitioning has been pre-compiled. Copy it to initialize */
6335 len = C_ARRAY_LENGTH(PL_partition_by_byte_length);
6336 invlist_extend(t_invlist, len);
6337 t_array = invlist_array(t_invlist);
6338 Copy(PL_partition_by_byte_length, t_array, len, UV);
6339 invlist_set_len(t_invlist, len, *(get_invlist_offset_addr(t_invlist)));
6340 Newx(r_map, len + 1, UV);
6341
6342 /* The inversion map the first pass creates could be used as-is, but
6343 * generally would be larger and slower to run than the output of the
6344 * second pass. */
6345
6346 for (pass2 = 0; pass2 < 2; pass2++) {
6347 if (pass2) {
6348 /* In the second pass, we start with a single range */
6349 t_invlist = _add_range_to_invlist(t_invlist, 0, UV_MAX);
6350 len = 1;
6351 t_array = invlist_array(t_invlist);
6352 }
6353
6354 /* As noted earlier, we convert EBCDIC code points to Unicode in the first pass
6355 * so as to get the well-behaved length 1 vs length 2 boundary. Only code
6356 * points below 256 differ between the two character sets in this regard. For
6357 * these, we also can't have any ranges, as they have to be individually
6358 * converted. */
6359 #ifdef EBCDIC
6360 # define CP_ADJUST(x) ((pass2) ? (x) : NATIVE_TO_UNI(x))
6361 # define FORCE_RANGE_LEN_1(x) ((pass2) ? 0 : ((x) < 256))
6362 # define CP_SKIP(x) ((pass2) ? UVCHR_SKIP(x) : OFFUNISKIP(x))
6363 #else
6364 # define CP_ADJUST(x) (x)
6365 # define FORCE_RANGE_LEN_1(x) 0
6366 # define CP_SKIP(x) UVCHR_SKIP(x)
6367 #endif
6368
6369 /* And the mapping of each of the ranges is initialized. Initially,
6370 * everything is TR_UNLISTED. */
6371 for (i = 0; i < len; i++) {
6372 r_map[i] = TR_UNLISTED;
6373 }
6374
6375 t = t0;
6376 t_count = 0;
6377 r = r0;
6378 r_count = 0;
6379 t_range_count = r_range_count = 0;
6380
6381 DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d:\ntstr=%s\n",
6382 __FILE__, __LINE__, _byte_dump_string(t, tend - t, 0)));
6383 DEBUG_y(PerlIO_printf(Perl_debug_log, "rstr=%s\n",
6384 _byte_dump_string(r, rend - r, 0)));
6385 DEBUG_y(PerlIO_printf(Perl_debug_log, "/c=%d; /s=%d; /d=%d\n",
6386 complement, squash, del));
6387 DEBUG_y(invmap_dump(t_invlist, r_map));
6388
6389 /* Now go through the search list constructing an inversion map. The
6390 * input is not necessarily in any particular order. Making it an
6391 * inversion map orders it, potentially simplifying, and makes it easy
6392 * to deal with at run time. This is the only place in core that
6393 * generates an inversion map; if others were introduced, it might be
6394 * better to create general purpose routines to handle them.
6395 * (Inversion maps are created in perl in other places.)
6396 *
6397 * An inversion map consists of two parallel arrays. One is
6398 * essentially an inversion list: an ordered list of code points such
6399 * that each element gives the first code point of a range of
6400 * consecutive code points that map to the element in the other array
6401 * that has the same index as this one (in other words, the
6402 * corresponding element). Thus the range extends up to (but not
6403 * including) the code point given by the next higher element. In a
6404 * true inversion map, the corresponding element in the other array
6405 * gives the mapping of the first code point in the range, with the
6406 * understanding that the next higher code point in the inversion
6407 * list's range will map to the next higher code point in the map.
6408 *
6409 * So if at element [i], let's say we have:
6410 *
6411 * t_invlist r_map
6412 * [i] A a
6413 *
6414 * This means that A => a, B => b, C => c.... Let's say that the
6415 * situation is such that:
6416 *
6417 * [i+1] L -1
6418 *
6419 * This means the sequence that started at [i] stops at K => k. This
6420 * illustrates that you need to look at the next element to find where
6421 * a sequence stops. Except, the highest element in the inversion list
6422 * begins a range that is understood to extend to the platform's
6423 * infinity.
6424 *
6425 * This routine modifies traditional inversion maps to reserve two
6426 * mappings:
6427 *
6428 * TR_UNLISTED (or -1) indicates that no code point in the range
6429 * is listed in the tr/// searchlist. At runtime, these are
6430 * always passed through unchanged. In the inversion map, all
6431 * points in the range are mapped to -1, instead of increasing,
6432 * like the 'L' in the example above.
6433 *
6434 * We start the parse with every code point mapped to this, and as
6435 * we parse and find ones that are listed in the search list, we
6436 * carve out ranges as we go along that override that.
6437 *
6438 * TR_SPECIAL_HANDLING (or -2) indicates that every code point in the
6439 * range needs special handling. Again, all code points in the
6440 * range are mapped to -2, instead of increasing.
6441 *
6442 * Under /d this value means the code point should be deleted from
6443 * the transliteration when encountered.
6444 *
6445 * Otherwise, it marks that every code point in the range is to
6446 * map to the final character in the replacement list. This
6447 * happens only when the replacement list is shorter than the
6448 * search one, so there are things in the search list that have no
6449 * correspondence in the replacement list. For example, in
6450 * tr/a-z/A/, 'A' is the final value, and the inversion map
6451 * generated for this would be like this:
6452 * \0 => -1
6453 * a => A
6454 * b-z => -2
6455 * z+1 => -1
6456 * 'A' appears once, then the remainder of the range maps to -2.
6457 * The use of -2 isn't strictly necessary, as an inversion map is
6458 * capable of representing this situation, but not nearly so
6459 * compactly, and this is actually quite commonly encountered.
6460 * Indeed, the original design of this code used a full inversion
6461 * map for this. But things like
6462 * tr/\0-\x{FFFF}/A/
6463 * generated huge data structures, slowly, and the execution was
6464 * also slow. So the current scheme was implemented.
6465 *
6466 * So, if the next element in our example is:
6467 *
6468 * [i+2] Q q
6469 *
6470 * Then all of L, M, N, O, and P map to TR_UNLISTED. If the next
6471 * elements are
6472 *
6473 * [i+3] R z
6474 * [i+4] S TR_UNLISTED
6475 *
6476 * Then Q => q; R => z; and S => TR_UNLISTED. If [i+4] (the 'S') is
6477 * the final element in the arrays, every code point from S to infinity
6478 * maps to TR_UNLISTED.
6479 *
6480 */
6481 /* Finish up range started in what otherwise would
6482 * have been the final iteration */
6483 while (t < tend || t_range_count > 0) {
6484 bool adjacent_to_range_above = FALSE;
6485 bool adjacent_to_range_below = FALSE;
6486
6487 bool merge_with_range_above = FALSE;
6488 bool merge_with_range_below = FALSE;
6489
6490 UV span, invmap_range_length_remaining;
6491 SSize_t j;
6492 Size_t i;
6493
6494 /* If we are in the middle of processing a range in the 'target'
6495 * side, the previous iteration has set us up. Otherwise, look at
6496 * the next character in the search list */
6497 if (t_range_count <= 0) {
6498 if (! tstr_utf8) {
6499
6500 /* Here, not in the middle of a range, and not UTF-8. The
6501 * next code point is the single byte where we're at */
6502 t_cp = CP_ADJUST(*t);
6503 t_range_count = 1;
6504 t++;
6505 }
6506 else {
6507 Size_t t_char_len;
6508
6509 /* Here, not in the middle of a range, and is UTF-8. The
6510 * next code point is the next UTF-8 char in the input. We
6511 * know the input is valid, because the toker constructed
6512 * it */
6513 t_cp = CP_ADJUST(valid_utf8_to_uvchr(t, &t_char_len));
6514 t += t_char_len;
6515
6516 /* UTF-8 strings (only) have been parsed in toke.c to have
6517 * ranges. See if the next byte indicates that this was
6518 * the first element of a range. If so, get the final
6519 * element and calculate the range size. If not, the range
6520 * size is 1 */
6521 if ( t < tend && *t == RANGE_INDICATOR
6522 && ! FORCE_RANGE_LEN_1(t_cp))
6523 {
6524 t++;
6525 t_range_count = valid_utf8_to_uvchr(t, &t_char_len)
6526 - t_cp + 1;
6527 t += t_char_len;
6528 }
6529 else {
6530 t_range_count = 1;
6531 }
6532 }
6533
6534 /* Count the total number of listed code points * */
6535 t_count += t_range_count;
6536 }
6537
6538 /* Similarly, get the next character in the replacement list */
6539 if (r_range_count <= 0) {
6540 if (r >= rend) {
6541
6542 /* But if we've exhausted the rhs, there is nothing to map
6543 * to, except the special handling one, and we make the
6544 * range the same size as the lhs one. */
6545 r_cp = TR_SPECIAL_HANDLING;
6546 r_range_count = t_range_count;
6547
6548 if (! del) {
6549 DEBUG_yv(PerlIO_printf(Perl_debug_log,
6550 "final_map =%" UVXf "\n", final_map));
6551 }
6552 }
6553 else {
6554 if (! rstr_utf8) {
6555 r_cp = CP_ADJUST(*r);
6556 r_range_count = 1;
6557 r++;
6558 }
6559 else {
6560 Size_t r_char_len;
6561
6562 r_cp = CP_ADJUST(valid_utf8_to_uvchr(r, &r_char_len));
6563 r += r_char_len;
6564 if ( r < rend && *r == RANGE_INDICATOR
6565 && ! FORCE_RANGE_LEN_1(r_cp))
6566 {
6567 r++;
6568 r_range_count = valid_utf8_to_uvchr(r,
6569 &r_char_len) - r_cp + 1;
6570 r += r_char_len;
6571 }
6572 else {
6573 r_range_count = 1;
6574 }
6575 }
6576
6577 if (r_cp == TR_SPECIAL_HANDLING) {
6578 r_range_count = t_range_count;
6579 }
6580
6581 /* This is the final character so far */
6582 final_map = r_cp + r_range_count - 1;
6583
6584 r_count += r_range_count;
6585 }
6586 }
6587
6588 /* Here, we have the next things ready in both sides. They are
6589 * potentially ranges. We try to process as big a chunk as
6590 * possible at once, but the lhs and rhs must be synchronized, so
6591 * things like tr/A-Z/a-ij-z/ will need to be processed in 2 chunks
6592 * */
6593 min_range_count = MIN(t_range_count, r_range_count);
6594
6595 /* Search the inversion list for the entry that contains the input
6596 * code point <cp>. The inversion map was initialized to cover the
6597 * entire range of possible inputs, so this should not fail. So
6598 * the return value is the index into the list's array of the range
6599 * that contains <cp>, that is, 'i' such that array[i] <= cp <
6600 * array[i+1] */
6601 j = _invlist_search(t_invlist, t_cp);
6602 assert(j >= 0);
6603 i = j;
6604
6605 /* Here, the data structure might look like:
6606 *
6607 * index t r Meaning
6608 * [i-1] J j # J-L => j-l
6609 * [i] M -1 # M => default; as do N, O, P, Q
6610 * [i+1] R x # R => x, S => x+1, T => x+2
6611 * [i+2] U y # U => y, V => y+1, ...
6612 * ...
6613 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
6614 *
6615 * where 'x' and 'y' above are not to be taken literally.
6616 *
6617 * The maximum chunk we can handle in this loop iteration, is the
6618 * smallest of the three components: the lhs 't_', the rhs 'r_',
6619 * and the remainder of the range in element [i]. (In pass 1, that
6620 * range will have everything in it be of the same class; we can't
6621 * cross into another class.) 'min_range_count' already contains
6622 * the smallest of the first two values. The final one is
6623 * irrelevant if the map is to the special indicator */
6624
6625 invmap_range_length_remaining = (i + 1 < len)
6626 ? t_array[i+1] - t_cp
6627 : IV_MAX - t_cp;
6628 span = MAX(1, MIN(min_range_count, invmap_range_length_remaining));
6629
6630 /* The end point of this chunk is where we are, plus the span, but
6631 * never larger than the platform's infinity */
6632 t_cp_end = MIN(IV_MAX, t_cp + span - 1);
6633
6634 if (r_cp == TR_SPECIAL_HANDLING) {
6635
6636 /* If unmatched lhs code points map to the final map, use that
6637 * value. This being set to TR_SPECIAL_HANDLING indicates that
6638 * we don't have a final map: unmatched lhs code points are
6639 * simply deleted */
6640 r_cp_end = (del) ? TR_SPECIAL_HANDLING : final_map;
6641 }
6642 else {
6643 r_cp_end = MIN(IV_MAX, r_cp + span - 1);
6644
6645 /* If something on the lhs is below 256, and something on the
6646 * rhs is above, there is a potential mapping here across that
6647 * boundary. Indeed the only way there isn't is if both sides
6648 * start at the same point. That means they both cross at the
6649 * same time. But otherwise one crosses before the other */
6650 if (t_cp < 256 && r_cp_end > 255 && r_cp != t_cp) {
6651 can_force_utf8 = TRUE;
6652 }
6653 }
6654
6655 /* If a character appears in the search list more than once, the
6656 * 2nd and succeeding occurrences are ignored, so only do this
6657 * range if haven't already processed this character. (The range
6658 * has been set up so that all members in it will be of the same
6659 * ilk) */
6660 if (r_map[i] == TR_UNLISTED) {
6661 DEBUG_yv(PerlIO_printf(Perl_debug_log,
6662 "Processing %" UVxf "-%" UVxf " => %" UVxf "-%" UVxf "\n",
6663 t_cp, t_cp_end, r_cp, r_cp_end));
6664
6665 /* This is the first definition for this chunk, hence is valid
6666 * and needs to be processed. Here and in the comments below,
6667 * we use the above sample data. The t_cp chunk must be any
6668 * contiguous subset of M, N, O, P, and/or Q.
6669 *
6670 * In the first pass, calculate if there is any possible input
6671 * string that has a character whose transliteration will be
6672 * longer than it. If none, the transliteration may be done
6673 * in-place, as it can't write over a so-far unread byte.
6674 * Otherwise, a copy must first be made. This could be
6675 * expensive for long inputs.
6676 *
6677 * In the first pass, the t_invlist has been partitioned so
6678 * that all elements in any single range have the same number
6679 * of bytes in their UTF-8 representations. And the r space is
6680 * either a single byte, or a range of strictly monotonically
6681 * increasing code points. So the final element in the range
6682 * will be represented by no fewer bytes than the initial one.
6683 * That means that if the final code point in the t range has
6684 * at least as many bytes as the final code point in the r,
6685 * then all code points in the t range have at least as many
6686 * bytes as their corresponding r range element. But if that's
6687 * not true, the transliteration of at least the final code
6688 * point grows in length. As an example, suppose we had
6689 * tr/\x{fff0}-\x{fff1}/\x{ffff}-\x{10000}/
6690 * The UTF-8 for all but 10000 occupies 3 bytes on ASCII
6691 * platforms. We have deliberately set up the data structure
6692 * so that any range in the lhs gets split into chunks for
6693 * processing, such that every code point in a chunk has the
6694 * same number of UTF-8 bytes. We only have to check the final
6695 * code point in the rhs against any code point in the lhs. */
6696 if ( ! pass2
6697 && r_cp_end != TR_SPECIAL_HANDLING
6698 && CP_SKIP(t_cp_end) < CP_SKIP(r_cp_end))
6699 {
6700 /* Here, we will need to make a copy of the input string
6701 * before doing the transliteration. The worst possible
6702 * case is an expansion ratio of 14:1. This is rare, and
6703 * we'd rather allocate only the necessary amount of extra
6704 * memory for that copy. We can calculate the worst case
6705 * for this particular transliteration is by keeping track
6706 * of the expansion factor for each range.
6707 *
6708 * Consider tr/\xCB/\X{E000}/. The maximum expansion
6709 * factor is 1 byte going to 3 if the target string is not
6710 * UTF-8, but 2 bytes going to 3 if it is in UTF-8. We
6711 * could pass two different values so doop could choose
6712 * based on the UTF-8ness of the target. But khw thinks
6713 * (perhaps wrongly) that is overkill. It is used only to
6714 * make sure we malloc enough space.
6715 *
6716 * If no target string can force the result to be UTF-8,
6717 * then we don't have to worry about the case of the target
6718 * string not being UTF-8 */
6719 NV t_size = (can_force_utf8 && t_cp < 256)
6720 ? 1
6721 : CP_SKIP(t_cp_end);
6722 NV ratio = CP_SKIP(r_cp_end) / t_size;
6723
6724 o->op_private |= OPpTRANS_GROWS;
6725
6726 /* Now that we know it grows, we can keep track of the
6727 * largest ratio */
6728 if (ratio > max_expansion) {
6729 max_expansion = ratio;
6730 DEBUG_y(PerlIO_printf(Perl_debug_log,
6731 "New expansion factor: %" NVgf "\n",
6732 max_expansion));
6733 }
6734 }
6735
6736 /* The very first range is marked as adjacent to the
6737 * non-existent range below it, as it causes things to "just
6738 * work" (TradeMark)
6739 *
6740 * If the lowest code point in this chunk is M, it adjoins the
6741 * J-L range */
6742 if (t_cp == t_array[i]) {
6743 adjacent_to_range_below = TRUE;
6744
6745 /* And if the map has the same offset from the beginning of
6746 * the range as does this new code point (or both are for
6747 * TR_SPECIAL_HANDLING), this chunk can be completely
6748 * merged with the range below. EXCEPT, in the first pass,
6749 * we don't merge ranges whose UTF-8 byte representations
6750 * have different lengths, so that we can more easily
6751 * detect if a replacement is longer than the source, that
6752 * is if it 'grows'. But in the 2nd pass, there's no
6753 * reason to not merge */
6754 if ( (i > 0 && ( pass2
6755 || CP_SKIP(t_array[i-1])
6756 == CP_SKIP(t_cp)))
6757 && ( ( r_cp == TR_SPECIAL_HANDLING
6758 && r_map[i-1] == TR_SPECIAL_HANDLING)
6759 || ( r_cp != TR_SPECIAL_HANDLING
6760 && r_cp - r_map[i-1] == t_cp - t_array[i-1])))
6761 {
6762 merge_with_range_below = TRUE;
6763 }
6764 }
6765
6766 /* Similarly, if the highest code point in this chunk is 'Q',
6767 * it adjoins the range above, and if the map is suitable, can
6768 * be merged with it */
6769 if ( t_cp_end >= IV_MAX - 1
6770 || ( i + 1 < len
6771 && t_cp_end + 1 == t_array[i+1]))
6772 {
6773 adjacent_to_range_above = TRUE;
6774 if (i + 1 < len)
6775 if ( ( pass2
6776 || CP_SKIP(t_cp) == CP_SKIP(t_array[i+1]))
6777 && ( ( r_cp == TR_SPECIAL_HANDLING
6778 && r_map[i+1] == (UV) TR_SPECIAL_HANDLING)
6779 || ( r_cp != TR_SPECIAL_HANDLING
6780 && r_cp_end == r_map[i+1] - 1)))
6781 {
6782 merge_with_range_above = TRUE;
6783 }
6784 }
6785
6786 if (merge_with_range_below && merge_with_range_above) {
6787
6788 /* Here the new chunk looks like M => m, ... Q => q; and
6789 * the range above is like R => r, .... Thus, the [i-1]
6790 * and [i+1] ranges should be seamlessly melded so the
6791 * result looks like
6792 *
6793 * [i-1] J j # J-T => j-t
6794 * [i] U y # U => y, V => y+1, ...
6795 * ...
6796 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
6797 */
6798 Move(t_array + i + 2, t_array + i, len - i - 2, UV);
6799 Move(r_map + i + 2, r_map + i, len - i - 2, UV);
6800 len -= 2;
6801 invlist_set_len(t_invlist,
6802 len,
6803 *(get_invlist_offset_addr(t_invlist)));
6804 }
6805 else if (merge_with_range_below) {
6806
6807 /* Here the new chunk looks like M => m, .... But either
6808 * (or both) it doesn't extend all the way up through Q; or
6809 * the range above doesn't start with R => r. */
6810 if (! adjacent_to_range_above) {
6811
6812 /* In the first case, let's say the new chunk extends
6813 * through O. We then want:
6814 *
6815 * [i-1] J j # J-O => j-o
6816 * [i] P -1 # P => -1, Q => -1
6817 * [i+1] R x # R => x, S => x+1, T => x+2
6818 * [i+2] U y # U => y, V => y+1, ...
6819 * ...
6820 * [-1] Z -1 # Z => default; as do Z+1, ...
6821 * infinity
6822 */
6823 t_array[i] = t_cp_end + 1;
6824 r_map[i] = TR_UNLISTED;
6825 }
6826 else { /* Adjoins the range above, but can't merge with it
6827 (because 'x' is not the next map after q) */
6828 /*
6829 * [i-1] J j # J-Q => j-q
6830 * [i] R x # R => x, S => x+1, T => x+2
6831 * [i+1] U y # U => y, V => y+1, ...
6832 * ...
6833 * [-1] Z -1 # Z => default; as do Z+1, ...
6834 * infinity
6835 */
6836
6837 Move(t_array + i + 1, t_array + i, len - i - 1, UV);
6838 Move(r_map + i + 1, r_map + i, len - i - 1, UV);
6839 len--;
6840 invlist_set_len(t_invlist, len,
6841 *(get_invlist_offset_addr(t_invlist)));
6842 }
6843 }
6844 else if (merge_with_range_above) {
6845
6846 /* Here the new chunk ends with Q => q, and the range above
6847 * must start with R => r, so the two can be merged. But
6848 * either (or both) the new chunk doesn't extend all the
6849 * way down to M; or the mapping of the final code point
6850 * range below isn't m */
6851 if (! adjacent_to_range_below) {
6852
6853 /* In the first case, let's assume the new chunk starts
6854 * with P => p. Then, because it's merge-able with the
6855 * range above, that range must be R => r. We want:
6856 *
6857 * [i-1] J j # J-L => j-l
6858 * [i] M -1 # M => -1, N => -1
6859 * [i+1] P p # P-T => p-t
6860 * [i+2] U y # U => y, V => y+1, ...
6861 * ...
6862 * [-1] Z -1 # Z => default; as do Z+1, ...
6863 * infinity
6864 */
6865 t_array[i+1] = t_cp;
6866 r_map[i+1] = r_cp;
6867 }
6868 else { /* Adjoins the range below, but can't merge with it
6869 */
6870 /*
6871 * [i-1] J j # J-L => j-l
6872 * [i] M x # M-T => x-5 .. x+2
6873 * [i+1] U y # U => y, V => y+1, ...
6874 * ...
6875 * [-1] Z -1 # Z => default; as do Z+1, ...
6876 * infinity
6877 */
6878 Move(t_array + i + 1, t_array + i, len - i - 1, UV);
6879 Move(r_map + i + 1, r_map + i, len - i - 1, UV);
6880 len--;
6881 t_array[i] = t_cp;
6882 r_map[i] = r_cp;
6883 invlist_set_len(t_invlist, len,
6884 *(get_invlist_offset_addr(t_invlist)));
6885 }
6886 }
6887 else if (adjacent_to_range_below && adjacent_to_range_above) {
6888 /* The new chunk completely fills the gap between the
6889 * ranges on either side, but can't merge with either of
6890 * them.
6891 *
6892 * [i-1] J j # J-L => j-l
6893 * [i] M z # M => z, N => z+1 ... Q => z+4
6894 * [i+1] R x # R => x, S => x+1, T => x+2
6895 * [i+2] U y # U => y, V => y+1, ...
6896 * ...
6897 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
6898 */
6899 r_map[i] = r_cp;
6900 }
6901 else if (adjacent_to_range_below) {
6902 /* The new chunk adjoins the range below, but not the range
6903 * above, and can't merge. Let's assume the chunk ends at
6904 * O.
6905 *
6906 * [i-1] J j # J-L => j-l
6907 * [i] M z # M => z, N => z+1, O => z+2
6908 * [i+1] P -1 # P => -1, Q => -1
6909 * [i+2] R x # R => x, S => x+1, T => x+2
6910 * [i+3] U y # U => y, V => y+1, ...
6911 * ...
6912 * [-w] Z -1 # Z => default; as do Z+1, ... infinity
6913 */
6914 invlist_extend(t_invlist, len + 1);
6915 t_array = invlist_array(t_invlist);
6916 Renew(r_map, len + 1, UV);
6917
6918 Move(t_array + i + 1, t_array + i + 2, len - i - 1, UV);
6919 Move(r_map + i + 1, r_map + i + 2, len - i - 1, UV);
6920 r_map[i] = r_cp;
6921 t_array[i+1] = t_cp_end + 1;
6922 r_map[i+1] = TR_UNLISTED;
6923 len++;
6924 invlist_set_len(t_invlist, len,
6925 *(get_invlist_offset_addr(t_invlist)));
6926 }
6927 else if (adjacent_to_range_above) {
6928 /* The new chunk adjoins the range above, but not the range
6929 * below, and can't merge. Let's assume the new chunk
6930 * starts at O
6931 *
6932 * [i-1] J j # J-L => j-l
6933 * [i] M -1 # M => default, N => default
6934 * [i+1] O z # O => z, P => z+1, Q => z+2
6935 * [i+2] R x # R => x, S => x+1, T => x+2
6936 * [i+3] U y # U => y, V => y+1, ...
6937 * ...
6938 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
6939 */
6940 invlist_extend(t_invlist, len + 1);
6941 t_array = invlist_array(t_invlist);
6942 Renew(r_map, len + 1, UV);
6943
6944 Move(t_array + i + 1, t_array + i + 2, len - i - 1, UV);
6945 Move(r_map + i + 1, r_map + i + 2, len - i - 1, UV);
6946 t_array[i+1] = t_cp;
6947 r_map[i+1] = r_cp;
6948 len++;
6949 invlist_set_len(t_invlist, len,
6950 *(get_invlist_offset_addr(t_invlist)));
6951 }
6952 else {
6953 /* The new chunk adjoins neither the range above, nor the
6954 * range below. Lets assume it is N..P => n..p
6955 *
6956 * [i-1] J j # J-L => j-l
6957 * [i] M -1 # M => default
6958 * [i+1] N n # N..P => n..p
6959 * [i+2] Q -1 # Q => default
6960 * [i+3] R x # R => x, S => x+1, T => x+2
6961 * [i+4] U y # U => y, V => y+1, ...
6962 * ...
6963 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
6964 */
6965
6966 DEBUG_yv(PerlIO_printf(Perl_debug_log,
6967 "Before fixing up: len=%d, i=%d\n",
6968 (int) len, (int) i));
6969 DEBUG_yv(invmap_dump(t_invlist, r_map));
6970
6971 invlist_extend(t_invlist, len + 2);
6972 t_array = invlist_array(t_invlist);
6973 Renew(r_map, len + 2, UV);
6974
6975 Move(t_array + i + 1,
6976 t_array + i + 2 + 1, len - i - (2 - 1), UV);
6977 Move(r_map + i + 1,
6978 r_map + i + 2 + 1, len - i - (2 - 1), UV);
6979
6980 len += 2;
6981 invlist_set_len(t_invlist, len,
6982 *(get_invlist_offset_addr(t_invlist)));
6983
6984 t_array[i+1] = t_cp;
6985 r_map[i+1] = r_cp;
6986
6987 t_array[i+2] = t_cp_end + 1;
6988 r_map[i+2] = TR_UNLISTED;
6989 }
6990 DEBUG_yv(PerlIO_printf(Perl_debug_log,
6991 "After iteration: span=%" UVuf ", t_range_count=%"
6992 UVuf " r_range_count=%" UVuf "\n",
6993 span, t_range_count, r_range_count));
6994 DEBUG_yv(invmap_dump(t_invlist, r_map));
6995 } /* End of this chunk needs to be processed */
6996
6997 /* Done with this chunk. */
6998 t_cp += span;
6999 if (t_cp >= IV_MAX) {
7000 break;
7001 }
7002 t_range_count -= span;
7003 if (r_cp != TR_SPECIAL_HANDLING) {
7004 r_cp += span;
7005 r_range_count -= span;
7006 }
7007 else {
7008 r_range_count = 0;
7009 }
7010
7011 } /* End of loop through the search list */
7012
7013 /* We don't need an exact count, but we do need to know if there is
7014 * anything left over in the replacement list. So, just assume it's
7015 * one byte per character */
7016 if (rend > r) {
7017 r_count++;
7018 }
7019 } /* End of passes */
7020
7021 SvREFCNT_dec(inverted_tstr);
7022
7023 DEBUG_y(PerlIO_printf(Perl_debug_log, "After everything: \n"));
7024 DEBUG_y(invmap_dump(t_invlist, r_map));
7025
7026 /* We now have normalized the input into an inversion map.
7027 *
7028 * See if the lhs and rhs are equivalent. If so, this tr/// is a no-op
7029 * except for the count, and streamlined runtime code can be used */
7030 if (!del && !squash) {
7031
7032 /* They are identical if they point to the same address, or if
7033 * everything maps to UNLISTED or to itself. This catches things that
7034 * not looking at the normalized inversion map doesn't catch, like
7035 * tr/aa/ab/ or tr/\x{100}-\x{104}/\x{100}-\x{102}\x{103}-\x{104} */
7036 if (r0 != t0) {
7037 for (i = 0; i < len; i++) {
7038 if (r_map[i] != TR_UNLISTED && r_map[i] != t_array[i]) {
7039 goto done_identical_check;
7040 }
7041 }
7042 }
7043
7044 /* Here have gone through entire list, and didn't find any
7045 * non-identical mappings */
7046 o->op_private |= OPpTRANS_IDENTICAL;
7047
7048 done_identical_check: ;
7049 }
7050
7051 t_array = invlist_array(t_invlist);
7052
7053 /* If has components above 255, we generally need to use the inversion map
7054 * implementation */
7055 if ( can_force_utf8
7056 || ( len > 0
7057 && t_array[len-1] > 255
7058 /* If the final range is 0x100-INFINITY and is a special
7059 * mapping, the table implementation can handle it */
7060 && ! ( t_array[len-1] == 256
7061 && ( r_map[len-1] == TR_UNLISTED
7062 || r_map[len-1] == TR_SPECIAL_HANDLING))))
7063 {
7064 SV* r_map_sv;
7065 SV* temp_sv;
7066
7067 /* A UTF-8 op is generated, indicated by this flag. This op is an
7068 * sv_op */
7069 o->op_private |= OPpTRANS_USE_SVOP;
7070
7071 if (can_force_utf8) {
7072 o->op_private |= OPpTRANS_CAN_FORCE_UTF8;
7073 }
7074
7075 /* The inversion map is pushed; first the list. */
7076 invmap = MUTABLE_AV(newAV());
7077
7078 SvREADONLY_on(t_invlist);
7079 av_push(invmap, t_invlist);
7080
7081 /* 2nd is the mapping */
7082 r_map_sv = newSVpvn((char *) r_map, len * sizeof(UV));
7083 SvREADONLY_on(r_map_sv);
7084 av_push(invmap, r_map_sv);
7085
7086 /* 3rd is the max possible expansion factor */
7087 temp_sv = newSVnv(max_expansion);
7088 SvREADONLY_on(temp_sv);
7089 av_push(invmap, temp_sv);
7090
7091 /* Characters that are in the search list, but not in the replacement
7092 * list are mapped to the final character in the replacement list */
7093 if (! del && r_count < t_count) {
7094 temp_sv = newSVuv(final_map);
7095 SvREADONLY_on(temp_sv);
7096 av_push(invmap, temp_sv);
7097 }
7098
7099 #ifdef USE_ITHREADS
7100 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
7101 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
7102 PAD_SETSV(cPADOPo->op_padix, (SV *) invmap);
7103 SvPADTMP_on(invmap);
7104 SvREADONLY_on(invmap);
7105 #else
7106 cSVOPo->op_sv = (SV *) invmap;
7107 #endif
7108
7109 }
7110 else {
7111 OPtrans_map *tbl;
7112 unsigned short i;
7113
7114 /* The OPtrans_map struct already contains one slot; hence the -1. */
7115 SSize_t struct_size = sizeof(OPtrans_map)
7116 + (256 - 1 + 1)*sizeof(short);
7117
7118 /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
7119 * table. Entries with the value TR_UNMAPPED indicate chars not to be
7120 * translated, while TR_DELETE indicates a search char without a
7121 * corresponding replacement char under /d.
7122 *
7123 * In addition, an extra slot at the end is used to store the final
7124 * repeating char, or TR_R_EMPTY under an empty replacement list, or
7125 * TR_DELETE under /d; which makes the runtime code easier. */
7126
7127 /* Indicate this is an op_pv */
7128 o->op_private &= ~OPpTRANS_USE_SVOP;
7129
7130 tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
7131 tbl->size = 256;
7132 cPVOPo->op_pv = (char*)tbl;
7133
7134 for (i = 0; i < len; i++) {
7135 STATIC_ASSERT_DECL(TR_SPECIAL_HANDLING == TR_DELETE);
7136 short upper = i >= len - 1 ? 256 : (short) t_array[i+1];
7137 short to = (short) r_map[i];
7138 short j;
7139 bool do_increment = TRUE;
7140
7141 /* Any code points above our limit should be irrelevant */
7142 if (t_array[i] >= tbl->size) break;
7143
7144 /* Set up the map */
7145 if (to == (short) TR_SPECIAL_HANDLING && ! del) {
7146 to = (short) final_map;
7147 do_increment = FALSE;
7148 }
7149 else if (to < 0) {
7150 do_increment = FALSE;
7151 }
7152
7153 /* Create a map for everything in this range. The value increases
7154 * except for the special cases */
7155 for (j = (short) t_array[i]; j < upper; j++) {
7156 tbl->map[j] = to;
7157 if (do_increment) to++;
7158 }
7159 }
7160
7161 tbl->map[tbl->size] = del
7162 ? (short) TR_DELETE
7163 : (short) rlen
7164 ? (short) final_map
7165 : (short) TR_R_EMPTY;
7166 DEBUG_y(PerlIO_printf(Perl_debug_log,"%s: %d\n", __FILE__, __LINE__));
7167 for (i = 0; i < tbl->size; i++) {
7168 if (tbl->map[i] < 0) {
7169 DEBUG_y(PerlIO_printf(Perl_debug_log," %02x=>%d",
7170 (unsigned) i, tbl->map[i]));
7171 }
7172 else {
7173 DEBUG_y(PerlIO_printf(Perl_debug_log," %02x=>%02x",
7174 (unsigned) i, tbl->map[i]));
7175 }
7176 if ((i+1) % 8 == 0 || i + 1 == (short) tbl->size) {
7177 DEBUG_y(PerlIO_printf(Perl_debug_log,"\n"));
7178 }
7179 }
7180 DEBUG_y(PerlIO_printf(Perl_debug_log,"Final map 0x%x=>%02x\n",
7181 (unsigned) tbl->size, tbl->map[tbl->size]));
7182
7183 SvREFCNT_dec(t_invlist);
7184
7185 #if 0 /* code that added excess above-255 chars at the end of the table, in
7186 case we ever want to not use the inversion map implementation for
7187 this */
7188
7189 ASSUME(j <= rlen);
7190 excess = rlen - j;
7191
7192 if (excess) {
7193 /* More replacement chars than search chars:
7194 * store excess replacement chars at end of main table.
7195 */
7196
7197 struct_size += excess;
7198 tbl = (OPtrans_map*)PerlMemShared_realloc(tbl,
7199 struct_size + excess * sizeof(short));
7200 tbl->size += excess;
7201 cPVOPo->op_pv = (char*)tbl;
7202
7203 for (i = 0; i < excess; i++)
7204 tbl->map[i + 256] = r[j+i];
7205 }
7206 else {
7207 /* no more replacement chars than search chars */
7208 }
7209 #endif
7210
7211 }
7212
7213 DEBUG_y(PerlIO_printf(Perl_debug_log,
7214 "/d=%d, /s=%d, /c=%d, identical=%d, grows=%d,"
7215 " use_svop=%d, can_force_utf8=%d,\nexpansion=%" NVgf "\n",
7216 del, squash, complement,
7217 cBOOL(o->op_private & OPpTRANS_IDENTICAL),
7218 cBOOL(o->op_private & OPpTRANS_USE_SVOP),
7219 cBOOL(o->op_private & OPpTRANS_GROWS),
7220 cBOOL(o->op_private & OPpTRANS_CAN_FORCE_UTF8),
7221 max_expansion));
7222
7223 Safefree(r_map);
7224
7225 if(del && rlen != 0 && r_count == t_count) {
7226 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
7227 } else if(r_count > t_count) {
7228 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
7229 }
7230
7231 op_free(expr);
7232 op_free(repl);
7233
7234 return o;
7235 }
7236
7237
7238 /*
7239 =for apidoc newPMOP
7240
7241 Constructs, checks, and returns an op of any pattern matching type.
7242 C<type> is the opcode. C<flags> gives the eight bits of C<op_flags>
7243 and, shifted up eight bits, the eight bits of C<op_private>.
7244
7245 =cut
7246 */
7247
7248 OP *
Perl_newPMOP(pTHX_ I32 type,I32 flags)7249 Perl_newPMOP(pTHX_ I32 type, I32 flags)
7250 {
7251 PMOP *pmop;
7252
7253 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
7254 || type == OP_CUSTOM);
7255
7256 NewOp(1101, pmop, 1, PMOP);
7257 OpTYPE_set(pmop, type);
7258 pmop->op_flags = (U8)flags;
7259 pmop->op_private = (U8)(0 | (flags >> 8));
7260 if (PL_opargs[type] & OA_RETSCALAR)
7261 scalar((OP *)pmop);
7262
7263 if (PL_hints & HINT_RE_TAINT)
7264 pmop->op_pmflags |= PMf_RETAINT;
7265 #ifdef USE_LOCALE_CTYPE
7266 if (IN_LC_COMPILETIME(LC_CTYPE)) {
7267 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
7268 }
7269 else
7270 #endif
7271 if (IN_UNI_8_BIT) {
7272 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
7273 }
7274 if (PL_hints & HINT_RE_FLAGS) {
7275 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
7276 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
7277 );
7278 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
7279 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
7280 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
7281 );
7282 if (reflags && SvOK(reflags)) {
7283 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
7284 }
7285 }
7286
7287
7288 #ifdef USE_ITHREADS
7289 assert(SvPOK(PL_regex_pad[0]));
7290 if (SvCUR(PL_regex_pad[0])) {
7291 /* Pop off the "packed" IV from the end. */
7292 SV *const repointer_list = PL_regex_pad[0];
7293 const char *p = SvEND(repointer_list) - sizeof(IV);
7294 const IV offset = *((IV*)p);
7295
7296 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
7297
7298 SvEND_set(repointer_list, p);
7299
7300 pmop->op_pmoffset = offset;
7301 /* This slot should be free, so assert this: */
7302 assert(PL_regex_pad[offset] == &PL_sv_undef);
7303 } else {
7304 SV * const repointer = &PL_sv_undef;
7305 av_push(PL_regex_padav, repointer);
7306 pmop->op_pmoffset = av_top_index(PL_regex_padav);
7307 PL_regex_pad = AvARRAY(PL_regex_padav);
7308 }
7309 #endif
7310
7311 return CHECKOP(type, pmop);
7312 }
7313
7314 static void
S_set_haseval(pTHX)7315 S_set_haseval(pTHX)
7316 {
7317 PADOFFSET i = 1;
7318 PL_cv_has_eval = 1;
7319 /* Any pad names in scope are potentially lvalues. */
7320 for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
7321 PADNAME *pn = PAD_COMPNAME_SV(i);
7322 if (!pn || !PadnameLEN(pn))
7323 continue;
7324 if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
7325 S_mark_padname_lvalue(aTHX_ pn);
7326 }
7327 }
7328
7329 /* Given some sort of match op o, and an expression expr containing a
7330 * pattern, either compile expr into a regex and attach it to o (if it's
7331 * constant), or convert expr into a runtime regcomp op sequence (if it's
7332 * not)
7333 *
7334 * Flags currently has 2 bits of meaning:
7335 * 1: isreg indicates that the pattern is part of a regex construct, eg
7336 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
7337 * split "pattern", which aren't. In the former case, expr will be a list
7338 * if the pattern contains more than one term (eg /a$b/).
7339 * 2: The pattern is for a split.
7340 *
7341 * When the pattern has been compiled within a new anon CV (for
7342 * qr/(?{...})/ ), then floor indicates the savestack level just before
7343 * the new sub was created
7344 *
7345 * tr/// is also handled.
7346 */
7347
7348 OP *
Perl_pmruntime(pTHX_ OP * o,OP * expr,OP * repl,UV flags,I32 floor)7349 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
7350 {
7351 PMOP *pm;
7352 LOGOP *rcop;
7353 I32 repl_has_vars = 0;
7354 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
7355 bool is_compiletime;
7356 bool has_code;
7357 bool isreg = cBOOL(flags & 1);
7358 bool is_split = cBOOL(flags & 2);
7359
7360 PERL_ARGS_ASSERT_PMRUNTIME;
7361
7362 if (is_trans) {
7363 return pmtrans(o, expr, repl);
7364 }
7365
7366 /* find whether we have any runtime or code elements;
7367 * at the same time, temporarily set the op_next of each DO block;
7368 * then when we LINKLIST, this will cause the DO blocks to be excluded
7369 * from the op_next chain (and from having LINKLIST recursively
7370 * applied to them). We fix up the DOs specially later */
7371
7372 is_compiletime = 1;
7373 has_code = 0;
7374 if (expr->op_type == OP_LIST) {
7375 OP *child;
7376 for (child = cLISTOPx(expr)->op_first; child; child = OpSIBLING(child)) {
7377 if (child->op_type == OP_NULL && (child->op_flags & OPf_SPECIAL)) {
7378 has_code = 1;
7379 assert(!child->op_next);
7380 if (UNLIKELY(!OpHAS_SIBLING(child))) {
7381 assert(PL_parser && PL_parser->error_count);
7382 /* This can happen with qr/ (?{(^{})/. Just fake up
7383 the op we were expecting to see, to avoid crashing
7384 elsewhere. */
7385 op_sibling_splice(expr, child, 0,
7386 newSVOP(OP_CONST, 0, &PL_sv_no));
7387 }
7388 child->op_next = OpSIBLING(child);
7389 }
7390 else if (child->op_type != OP_CONST && child->op_type != OP_PUSHMARK)
7391 is_compiletime = 0;
7392 }
7393 }
7394 else if (expr->op_type != OP_CONST)
7395 is_compiletime = 0;
7396
7397 LINKLIST(expr);
7398
7399 /* fix up DO blocks; treat each one as a separate little sub;
7400 * also, mark any arrays as LIST/REF */
7401
7402 if (expr->op_type == OP_LIST) {
7403 OP *child;
7404 for (child = cLISTOPx(expr)->op_first; child; child = OpSIBLING(child)) {
7405
7406 if (child->op_type == OP_PADAV || child->op_type == OP_RV2AV) {
7407 assert( !(child->op_flags & OPf_WANT));
7408 /* push the array rather than its contents. The regex
7409 * engine will retrieve and join the elements later */
7410 child->op_flags |= (OPf_WANT_LIST | OPf_REF);
7411 continue;
7412 }
7413
7414 if (!(child->op_type == OP_NULL && (child->op_flags & OPf_SPECIAL)))
7415 continue;
7416 child->op_next = NULL; /* undo temporary hack from above */
7417 scalar(child);
7418 LINKLIST(child);
7419 if (cLISTOPx(child)->op_first->op_type == OP_LEAVE) {
7420 LISTOP *leaveop = cLISTOPx(cLISTOPx(child)->op_first);
7421 /* skip ENTER */
7422 assert(leaveop->op_first->op_type == OP_ENTER);
7423 assert(OpHAS_SIBLING(leaveop->op_first));
7424 child->op_next = OpSIBLING(leaveop->op_first);
7425 /* skip leave */
7426 assert(leaveop->op_flags & OPf_KIDS);
7427 assert(leaveop->op_last->op_next == (OP*)leaveop);
7428 leaveop->op_next = NULL; /* stop on last op */
7429 op_null((OP*)leaveop);
7430 }
7431 else {
7432 /* skip SCOPE */
7433 OP *scope = cLISTOPx(child)->op_first;
7434 assert(scope->op_type == OP_SCOPE);
7435 assert(scope->op_flags & OPf_KIDS);
7436 scope->op_next = NULL; /* stop on last op */
7437 op_null(scope);
7438 }
7439
7440 /* XXX optimize_optree() must be called on o before
7441 * CALL_PEEP(), as currently S_maybe_multiconcat() can't
7442 * currently cope with a peephole-optimised optree.
7443 * Calling optimize_optree() here ensures that condition
7444 * is met, but may mean optimize_optree() is applied
7445 * to the same optree later (where hopefully it won't do any
7446 * harm as it can't convert an op to multiconcat if it's
7447 * already been converted */
7448 optimize_optree(child);
7449
7450 /* have to peep the DOs individually as we've removed it from
7451 * the op_next chain */
7452 CALL_PEEP(child);
7453 op_prune_chain_head(&(child->op_next));
7454 if (is_compiletime)
7455 /* runtime finalizes as part of finalizing whole tree */
7456 finalize_optree(child);
7457 }
7458 }
7459 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
7460 assert( !(expr->op_flags & OPf_WANT));
7461 /* push the array rather than its contents. The regex
7462 * engine will retrieve and join the elements later */
7463 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
7464 }
7465
7466 PL_hints |= HINT_BLOCK_SCOPE;
7467 pm = cPMOPo;
7468 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
7469
7470 if (is_compiletime) {
7471 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
7472 regexp_engine const *eng = current_re_engine();
7473
7474 if (is_split) {
7475 /* make engine handle split ' ' specially */
7476 pm->op_pmflags |= PMf_SPLIT;
7477 rx_flags |= RXf_SPLIT;
7478 }
7479
7480 if (!has_code || !eng->op_comp) {
7481 /* compile-time simple constant pattern */
7482
7483 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
7484 /* whoops! we guessed that a qr// had a code block, but we
7485 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
7486 * that isn't required now. Note that we have to be pretty
7487 * confident that nothing used that CV's pad while the
7488 * regex was parsed, except maybe op targets for \Q etc.
7489 * If there were any op targets, though, they should have
7490 * been stolen by constant folding.
7491 */
7492 #ifdef DEBUGGING
7493 SSize_t i = 0;
7494 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
7495 while (++i <= AvFILLp(PL_comppad)) {
7496 # ifdef USE_PAD_RESET
7497 /* under USE_PAD_RESET, pad swipe replaces a swiped
7498 * folded constant with a fresh padtmp */
7499 assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
7500 # else
7501 assert(!PL_curpad[i]);
7502 # endif
7503 }
7504 #endif
7505 /* This LEAVE_SCOPE will restore PL_compcv to point to the
7506 * outer CV (the one whose slab holds the pm op). The
7507 * inner CV (which holds expr) will be freed later, once
7508 * all the entries on the parse stack have been popped on
7509 * return from this function. Which is why its safe to
7510 * call op_free(expr) below.
7511 */
7512 LEAVE_SCOPE(floor);
7513 pm->op_pmflags &= ~PMf_HAS_CV;
7514 }
7515
7516 /* Skip compiling if parser found an error for this pattern */
7517 if (pm->op_pmflags & PMf_HAS_ERROR) {
7518 return o;
7519 }
7520
7521 PM_SETRE(pm,
7522 eng->op_comp
7523 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7524 rx_flags, pm->op_pmflags)
7525 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7526 rx_flags, pm->op_pmflags)
7527 );
7528 op_free(expr);
7529 }
7530 else {
7531 /* compile-time pattern that includes literal code blocks */
7532
7533 REGEXP* re;
7534
7535 /* Skip compiling if parser found an error for this pattern */
7536 if (pm->op_pmflags & PMf_HAS_ERROR) {
7537 return o;
7538 }
7539
7540 re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7541 rx_flags,
7542 (pm->op_pmflags |
7543 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
7544 );
7545 PM_SETRE(pm, re);
7546 if (pm->op_pmflags & PMf_HAS_CV) {
7547 CV *cv;
7548 /* this QR op (and the anon sub we embed it in) is never
7549 * actually executed. It's just a placeholder where we can
7550 * squirrel away expr in op_code_list without the peephole
7551 * optimiser etc processing it for a second time */
7552 OP *qr = newPMOP(OP_QR, 0);
7553 cPMOPx(qr)->op_code_list = expr;
7554
7555 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
7556 SvREFCNT_inc_simple_void(PL_compcv);
7557 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
7558 ReANY(re)->qr_anoncv = cv;
7559
7560 /* attach the anon CV to the pad so that
7561 * pad_fixup_inner_anons() can find it */
7562 (void)pad_add_anon(cv, o->op_type);
7563 SvREFCNT_inc_simple_void(cv);
7564 }
7565 else {
7566 pm->op_code_list = expr;
7567 }
7568 }
7569 }
7570 else {
7571 /* runtime pattern: build chain of regcomp etc ops */
7572 bool reglist;
7573 PADOFFSET cv_targ = 0;
7574
7575 reglist = isreg && expr->op_type == OP_LIST;
7576 if (reglist)
7577 op_null(expr);
7578
7579 if (has_code) {
7580 pm->op_code_list = expr;
7581 /* don't free op_code_list; its ops are embedded elsewhere too */
7582 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
7583 }
7584
7585 if (is_split)
7586 /* make engine handle split ' ' specially */
7587 pm->op_pmflags |= PMf_SPLIT;
7588
7589 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
7590 * to allow its op_next to be pointed past the regcomp and
7591 * preceding stacking ops;
7592 * OP_REGCRESET is there to reset taint before executing the
7593 * stacking ops */
7594 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
7595 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
7596
7597 if (pm->op_pmflags & PMf_HAS_CV) {
7598 /* we have a runtime qr with literal code. This means
7599 * that the qr// has been wrapped in a new CV, which
7600 * means that runtime consts, vars etc will have been compiled
7601 * against a new pad. So... we need to execute those ops
7602 * within the environment of the new CV. So wrap them in a call
7603 * to a new anon sub. i.e. for
7604 *
7605 * qr/a$b(?{...})/,
7606 *
7607 * we build an anon sub that looks like
7608 *
7609 * sub { "a", $b, '(?{...})' }
7610 *
7611 * and call it, passing the returned list to regcomp.
7612 * Or to put it another way, the list of ops that get executed
7613 * are:
7614 *
7615 * normal PMf_HAS_CV
7616 * ------ -------------------
7617 * pushmark (for regcomp)
7618 * pushmark (for entersub)
7619 * anoncode
7620 * entersub
7621 * regcreset regcreset
7622 * pushmark pushmark
7623 * const("a") const("a")
7624 * gvsv(b) gvsv(b)
7625 * const("(?{...})") const("(?{...})")
7626 * leavesub
7627 * regcomp regcomp
7628 */
7629
7630 SvREFCNT_inc_simple_void(PL_compcv);
7631 CvLVALUE_on(PL_compcv);
7632 /* these lines are just an unrolled newANONATTRSUB */
7633 expr = newSVOP(OP_ANONCODE, OPf_REF,
7634 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
7635 cv_targ = expr->op_targ;
7636
7637 expr = list(op_force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr))));
7638 }
7639
7640 rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
7641 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
7642 | (reglist ? OPf_STACKED : 0);
7643 rcop->op_targ = cv_targ;
7644
7645 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
7646 if (PL_hints & HINT_RE_EVAL)
7647 S_set_haseval(aTHX);
7648
7649 /* establish postfix order */
7650 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
7651 LINKLIST(expr);
7652 rcop->op_next = expr;
7653 cUNOPx(expr)->op_first->op_next = (OP*)rcop;
7654 }
7655 else {
7656 rcop->op_next = LINKLIST(expr);
7657 expr->op_next = (OP*)rcop;
7658 }
7659
7660 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
7661 }
7662
7663 if (repl) {
7664 OP *curop = repl;
7665 bool konst;
7666 /* If we are looking at s//.../e with a single statement, get past
7667 the implicit do{}. */
7668 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
7669 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
7670 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
7671 {
7672 OP *sib;
7673 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
7674 if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
7675 && !OpHAS_SIBLING(sib))
7676 curop = sib;
7677 }
7678 if (curop->op_type == OP_CONST)
7679 konst = TRUE;
7680 else if (( (curop->op_type == OP_RV2SV ||
7681 curop->op_type == OP_RV2AV ||
7682 curop->op_type == OP_RV2HV ||
7683 curop->op_type == OP_RV2GV)
7684 && cUNOPx(curop)->op_first
7685 && cUNOPx(curop)->op_first->op_type == OP_GV )
7686 || curop->op_type == OP_PADSV
7687 || curop->op_type == OP_PADAV
7688 || curop->op_type == OP_PADHV
7689 || curop->op_type == OP_PADANY) {
7690 repl_has_vars = 1;
7691 konst = TRUE;
7692 }
7693 else konst = FALSE;
7694 if (konst
7695 && !(repl_has_vars
7696 && (!PM_GETRE(pm)
7697 || !RX_PRELEN(PM_GETRE(pm))
7698 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
7699 {
7700 pm->op_pmflags |= PMf_CONST; /* const for long enough */
7701 op_prepend_elem(o->op_type, scalar(repl), o);
7702 }
7703 else {
7704 rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
7705 rcop->op_private = 1;
7706
7707 /* establish postfix order */
7708 rcop->op_next = LINKLIST(repl);
7709 repl->op_next = (OP*)rcop;
7710
7711 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
7712 assert(!(pm->op_pmflags & PMf_ONCE));
7713 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
7714 rcop->op_next = 0;
7715 }
7716 }
7717
7718 return (OP*)pm;
7719 }
7720
7721 /*
7722 =for apidoc newSVOP
7723
7724 Constructs, checks, and returns an op of any type that involves an
7725 embedded SV. C<type> is the opcode. C<flags> gives the eight bits
7726 of C<op_flags>. C<sv> gives the SV to embed in the op; this function
7727 takes ownership of one reference to it.
7728
7729 =cut
7730 */
7731
7732 OP *
Perl_newSVOP(pTHX_ I32 type,I32 flags,SV * sv)7733 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
7734 {
7735 SVOP *svop;
7736
7737 PERL_ARGS_ASSERT_NEWSVOP;
7738
7739 /* OP_RUNCV is allowed specially so rpeep has room to convert it into an
7740 * OP_CONST */
7741 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7742 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7743 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7744 || type == OP_RUNCV
7745 || type == OP_CUSTOM);
7746
7747 NewOp(1101, svop, 1, SVOP);
7748 OpTYPE_set(svop, type);
7749 svop->op_sv = sv;
7750 svop->op_next = (OP*)svop;
7751 svop->op_flags = (U8)flags;
7752 svop->op_private = (U8)(0 | (flags >> 8));
7753 if (PL_opargs[type] & OA_RETSCALAR)
7754 scalar((OP*)svop);
7755 if (PL_opargs[type] & OA_TARGET)
7756 svop->op_targ = pad_alloc(type, SVs_PADTMP);
7757 return CHECKOP(type, svop);
7758 }
7759
7760 /*
7761 =for apidoc newDEFSVOP
7762
7763 Constructs and returns an op to access C<$_>.
7764
7765 =cut
7766 */
7767
7768 OP *
Perl_newDEFSVOP(pTHX)7769 Perl_newDEFSVOP(pTHX)
7770 {
7771 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
7772 }
7773
7774 #ifdef USE_ITHREADS
7775
7776 /*
7777 =for apidoc newPADOP
7778
7779 Constructs, checks, and returns an op of any type that involves a
7780 reference to a pad element. C<type> is the opcode. C<flags> gives the
7781 eight bits of C<op_flags>. A pad slot is automatically allocated, and
7782 is populated with C<sv>; this function takes ownership of one reference
7783 to it.
7784
7785 This function only exists if Perl has been compiled to use ithreads.
7786
7787 =cut
7788 */
7789
7790 OP *
Perl_newPADOP(pTHX_ I32 type,I32 flags,SV * sv)7791 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
7792 {
7793 PADOP *padop;
7794
7795 PERL_ARGS_ASSERT_NEWPADOP;
7796
7797 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7798 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7799 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7800 || type == OP_CUSTOM);
7801
7802 NewOp(1101, padop, 1, PADOP);
7803 OpTYPE_set(padop, type);
7804 padop->op_padix =
7805 pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
7806 SvREFCNT_dec(PAD_SVl(padop->op_padix));
7807 PAD_SETSV(padop->op_padix, sv);
7808 assert(sv);
7809 padop->op_next = (OP*)padop;
7810 padop->op_flags = (U8)flags;
7811 if (PL_opargs[type] & OA_RETSCALAR)
7812 scalar((OP*)padop);
7813 if (PL_opargs[type] & OA_TARGET)
7814 padop->op_targ = pad_alloc(type, SVs_PADTMP);
7815 return CHECKOP(type, padop);
7816 }
7817
7818 #endif /* USE_ITHREADS */
7819
7820 /*
7821 =for apidoc newGVOP
7822
7823 Constructs, checks, and returns an op of any type that involves an
7824 embedded reference to a GV. C<type> is the opcode. C<flags> gives the
7825 eight bits of C<op_flags>. C<gv> identifies the GV that the op should
7826 reference; calling this function does not transfer ownership of any
7827 reference to it.
7828
7829 =cut
7830 */
7831
7832 OP *
Perl_newGVOP(pTHX_ I32 type,I32 flags,GV * gv)7833 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
7834 {
7835 PERL_ARGS_ASSERT_NEWGVOP;
7836
7837 #ifdef USE_ITHREADS
7838 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7839 #else
7840 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7841 #endif
7842 }
7843
7844 /*
7845 =for apidoc newPVOP
7846
7847 Constructs, checks, and returns an op of any type that involves an
7848 embedded C-level pointer (PV). C<type> is the opcode. C<flags> gives
7849 the eight bits of C<op_flags>. C<pv> supplies the C-level pointer.
7850 Depending on the op type, the memory referenced by C<pv> may be freed
7851 when the op is destroyed. If the op is of a freeing type, C<pv> must
7852 have been allocated using C<PerlMemShared_malloc>.
7853
7854 =cut
7855 */
7856
7857 OP *
Perl_newPVOP(pTHX_ I32 type,I32 flags,char * pv)7858 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
7859 {
7860 const bool utf8 = cBOOL(flags & SVf_UTF8);
7861 PVOP *pvop;
7862
7863 flags &= ~SVf_UTF8;
7864
7865 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7866 || type == OP_CUSTOM
7867 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
7868
7869 NewOp(1101, pvop, 1, PVOP);
7870 OpTYPE_set(pvop, type);
7871 pvop->op_pv = pv;
7872 pvop->op_next = (OP*)pvop;
7873 pvop->op_flags = (U8)flags;
7874 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
7875 if (PL_opargs[type] & OA_RETSCALAR)
7876 scalar((OP*)pvop);
7877 if (PL_opargs[type] & OA_TARGET)
7878 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
7879 return CHECKOP(type, pvop);
7880 }
7881
7882 void
Perl_package(pTHX_ OP * o)7883 Perl_package(pTHX_ OP *o)
7884 {
7885 SV *const sv = cSVOPo->op_sv;
7886
7887 PERL_ARGS_ASSERT_PACKAGE;
7888
7889 SAVEGENERICSV(PL_curstash);
7890 save_item(PL_curstname);
7891
7892 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
7893
7894 sv_setsv(PL_curstname, sv);
7895
7896 PL_hints |= HINT_BLOCK_SCOPE;
7897 PL_parser->copline = NOLINE;
7898
7899 op_free(o);
7900 }
7901
7902 void
Perl_package_version(pTHX_ OP * v)7903 Perl_package_version( pTHX_ OP *v )
7904 {
7905 U32 savehints = PL_hints;
7906 PERL_ARGS_ASSERT_PACKAGE_VERSION;
7907 PL_hints &= ~HINT_STRICT_VARS;
7908 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
7909 PL_hints = savehints;
7910 op_free(v);
7911 }
7912
7913 /* Extract the first two components of a "version" object as two 8bit integers
7914 * and return them packed into a single U16 in the format of PL_prevailing_version.
7915 * This function only ever has to cope with version objects already known
7916 * bounded by the current perl version, so we know its components will fit
7917 * (Up until we reach perl version 5.256 anyway) */
S_extract_shortver(pTHX_ SV * sv)7918 static U16 S_extract_shortver(pTHX_ SV *sv)
7919 {
7920 SV *rv;
7921 if(!SvRV(sv) || !SvOBJECT(rv = SvRV(sv)) || !sv_derived_from(sv, "version"))
7922 return 0;
7923
7924 AV *av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rv), "version", 0)));
7925
7926 U16 shortver = 0;
7927
7928 IV major = av_count(av) > 0 ? SvIV(*av_fetch(av, 0, false)) : 0;
7929 if(major > 255)
7930 shortver |= 255 << 8;
7931 else
7932 shortver |= major << 8;
7933
7934 IV minor = av_count(av) > 1 ? SvIV(*av_fetch(av, 1, false)) : 0;
7935 if(minor > 255)
7936 shortver |= 255;
7937 else
7938 shortver |= minor;
7939
7940 return shortver;
7941 }
7942 #define SHORTVER(maj,min) ((maj << 8) | min)
7943
7944 void
Perl_utilize(pTHX_ int aver,I32 floor,OP * version,OP * idop,OP * arg)7945 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
7946 {
7947 OP *pack;
7948 OP *imop;
7949 OP *veop;
7950 SV *use_version = NULL;
7951
7952 PERL_ARGS_ASSERT_UTILIZE;
7953
7954 if (idop->op_type != OP_CONST)
7955 Perl_croak(aTHX_ "Module name must be constant");
7956
7957 veop = NULL;
7958
7959 if (version) {
7960 SV * const vesv = cSVOPx(version)->op_sv;
7961
7962 if (!arg && !SvNIOKp(vesv)) {
7963 arg = version;
7964 }
7965 else {
7966 OP *pack;
7967 SV *meth;
7968
7969 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
7970 Perl_croak(aTHX_ "Version number must be a constant number");
7971
7972 /* Make copy of idop so we don't free it twice */
7973 pack = newSVOP(OP_CONST, 0, newSVsv(cSVOPx(idop)->op_sv));
7974
7975 /* Fake up a method call to VERSION */
7976 meth = newSVpvs_share("VERSION");
7977 veop = newLISTOPn(OP_ENTERSUB, OPf_STACKED,
7978 pack,
7979 version,
7980 newMETHOP_named(OP_METHOD_NAMED, 0, meth),
7981 NULL);
7982 }
7983 }
7984
7985 /* Fake up an import/unimport */
7986 if (arg && arg->op_type == OP_STUB) {
7987 imop = arg; /* no import on explicit () */
7988 }
7989 else if (SvNIOKp(cSVOPx(idop)->op_sv)) {
7990 imop = NULL; /* use 5.0; */
7991 if (aver)
7992 use_version = cSVOPx(idop)->op_sv;
7993 else
7994 idop->op_private |= OPpCONST_NOVER;
7995 }
7996 else {
7997 SV *meth;
7998
7999 /* Make copy of idop so we don't free it twice */
8000 pack = newSVOP(OP_CONST, 0, newSVsv(cSVOPx(idop)->op_sv));
8001
8002 /* Fake up a method call to import/unimport */
8003 meth = aver
8004 ? newSVpvs_share("import") : newSVpvs_share("unimport");
8005 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED,
8006 op_append_elem(OP_LIST,
8007 op_prepend_elem(OP_LIST, pack, arg),
8008 newMETHOP_named(OP_METHOD_NAMED, 0, meth)
8009 ));
8010 }
8011
8012 /* Fake up the BEGIN {}, which does its thing immediately. */
8013 newATTRSUB(floor,
8014 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
8015 NULL,
8016 NULL,
8017 op_append_elem(OP_LINESEQ,
8018 op_append_elem(OP_LINESEQ,
8019 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
8020 newSTATEOP(0, NULL, veop)),
8021 newSTATEOP(0, NULL, imop) ));
8022
8023 if (use_version) {
8024 /* Enable the
8025 * feature bundle that corresponds to the required version. */
8026 use_version = sv_2mortal(new_version(use_version));
8027 S_enable_feature_bundle(aTHX_ use_version);
8028
8029 U16 shortver = S_extract_shortver(aTHX_ use_version);
8030
8031 if (shortver && PL_prevailing_version) {
8032 /* use VERSION while another use VERSION is in scope
8033 * This should provoke at least a warning, if not an outright error
8034 */
8035 if (PL_prevailing_version < SHORTVER(5, 10)) {
8036 /* if the old version had no side effects, we can allow this
8037 * without any warnings or errors */
8038 }
8039 else if (shortver == PL_prevailing_version) {
8040 /* requesting the same version again is fine */
8041 }
8042 else if (shortver >= SHORTVER(5, 39)) {
8043 croak("use VERSION of 5.39 or above is not permitted while another use VERSION is in scope");
8044 }
8045 else if (PL_prevailing_version >= SHORTVER(5, 39)) {
8046 croak("use VERSION is not permitted while another use VERSION of 5.39 or above is in scope");
8047 }
8048 else if (PL_prevailing_version >= SHORTVER(5, 11) && shortver < SHORTVER(5, 11)) {
8049 /* downgrading from >= 5.11 to < 5.11 is now fatal */
8050 croak("Downgrading a use VERSION declaration to below v5.11 is not permitted");
8051 }
8052 else {
8053 /* OK let's at least warn */
8054 deprecate_fatal_in(WARN_DEPRECATED__SUBSEQUENT_USE_VERSION, "5.44",
8055 "Changing use VERSION while another use VERSION is in scope");
8056 }
8057 }
8058
8059 /* If a version >= 5.11.0 is requested, strictures are on by default! */
8060 if (shortver >= SHORTVER(5, 11)) {
8061 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
8062 PL_hints |= HINT_STRICT_REFS;
8063 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
8064 PL_hints |= HINT_STRICT_SUBS;
8065 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
8066 PL_hints |= HINT_STRICT_VARS;
8067
8068 if (shortver >= SHORTVER(5, 35) && !(PL_dowarn & G_WARN_ALL_MASK)) {
8069 free_and_set_cop_warnings(&PL_compiling, pWARN_ALL);
8070 PL_dowarn |= G_WARN_ONCE;
8071 }
8072 }
8073 /* otherwise they are off */
8074 else {
8075 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
8076 PL_hints &= ~HINT_STRICT_REFS;
8077 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
8078 PL_hints &= ~HINT_STRICT_SUBS;
8079 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
8080 PL_hints &= ~HINT_STRICT_VARS;
8081 }
8082
8083 /* As an optimisation, there's no point scanning for changes of
8084 * visible builtin functions when switching between versions earlier
8085 * than v5.39, when any became visible at all
8086 */
8087 if ((shortver >= SHORTVER(5, 39)) || (PL_prevailing_version >= SHORTVER(5, 39))) {
8088 prepare_export_lexical();
8089 import_builtin_bundle(shortver);
8090 finish_export_lexical();
8091 }
8092
8093 PL_prevailing_version = shortver;
8094 }
8095
8096 /* The "did you use incorrect case?" warning used to be here.
8097 * The problem is that on case-insensitive filesystems one
8098 * might get false positives for "use" (and "require"):
8099 * "use Strict" or "require CARP" will work. This causes
8100 * portability problems for the script: in case-strict
8101 * filesystems the script will stop working.
8102 *
8103 * The "incorrect case" warning checked whether "use Foo"
8104 * imported "Foo" to your namespace, but that is wrong, too:
8105 * there is no requirement nor promise in the language that
8106 * a Foo.pm should or would contain anything in package "Foo".
8107 *
8108 * There is very little Configure-wise that can be done, either:
8109 * the case-sensitivity of the build filesystem of Perl does not
8110 * help in guessing the case-sensitivity of the runtime environment.
8111 */
8112
8113 PL_hints |= HINT_BLOCK_SCOPE;
8114 PL_parser->copline = NOLINE;
8115 COP_SEQMAX_INC; /* Purely for B::*'s benefit */
8116 }
8117
8118 /*
8119 =for apidoc_section $embedding
8120
8121 =for apidoc load_module
8122 =for apidoc_item load_module_nocontext
8123
8124 These load the module whose name is pointed to by the string part of C<name>.
8125 Note that the actual module name, not its filename, should be given.
8126 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
8127 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
8128 trailing arguments can be used to specify arguments to the module's C<import()>
8129 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
8130 on the flags. The flags argument is a bitwise-ORed collection of any of
8131 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
8132 (or 0 for no flags).
8133
8134 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
8135 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
8136 the trailing optional arguments may be omitted entirely. Otherwise, if
8137 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
8138 exactly one C<OP*>, containing the op tree that produces the relevant import
8139 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
8140 will be used as import arguments; and the list must be terminated with C<(SV*)
8141 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
8142 set, the trailing C<NULL> pointer is needed even if no import arguments are
8143 desired. The reference count for each specified C<SV*> argument is
8144 decremented. In addition, the C<name> argument is modified.
8145
8146 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
8147 than C<use>.
8148
8149 C<load_module> and C<load_module_nocontext> have the same apparent signature,
8150 but the former hides the fact that it is accessing a thread context parameter.
8151 So use the latter when you get a compilation error about C<pTHX>.
8152
8153 =for apidoc Amnh||PERL_LOADMOD_DENY
8154 =for apidoc Amnh||PERL_LOADMOD_NOIMPORT
8155 =for apidoc Amnh||PERL_LOADMOD_IMPORT_OPS
8156
8157 =for apidoc vload_module
8158 Like C<L</load_module>> but the arguments are an encapsulated argument list.
8159
8160 =cut */
8161
8162 void
Perl_load_module(pTHX_ U32 flags,SV * name,SV * ver,...)8163 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
8164 {
8165 va_list args;
8166
8167 PERL_ARGS_ASSERT_LOAD_MODULE;
8168
8169 va_start(args, ver);
8170 vload_module(flags, name, ver, &args);
8171 va_end(args);
8172 }
8173
8174 #ifdef MULTIPLICITY
8175 void
Perl_load_module_nocontext(U32 flags,SV * name,SV * ver,...)8176 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
8177 {
8178 dTHX;
8179 va_list args;
8180 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
8181 va_start(args, ver);
8182 vload_module(flags, name, ver, &args);
8183 va_end(args);
8184 }
8185 #endif
8186
8187 void
Perl_vload_module(pTHX_ U32 flags,SV * name,SV * ver,va_list * args)8188 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
8189 {
8190 OP *veop, *imop;
8191 OP * modname;
8192 I32 floor;
8193
8194 PERL_ARGS_ASSERT_VLOAD_MODULE;
8195
8196 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
8197 * that it has a PL_parser to play with while doing that, and also
8198 * that it doesn't mess with any existing parser, by creating a tmp
8199 * new parser with lex_start(). This won't actually be used for much,
8200 * since pp_require() will create another parser for the real work.
8201 * The ENTER/LEAVE pair protect callers from any side effects of use.
8202 *
8203 * start_subparse() creates a new PL_compcv. This means that any ops
8204 * allocated below will be allocated from that CV's op slab, and so
8205 * will be automatically freed if the utilise() fails
8206 */
8207
8208 ENTER;
8209 SAVEVPTR(PL_curcop);
8210 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
8211 floor = start_subparse(FALSE, 0);
8212
8213 modname = newSVOP(OP_CONST, 0, name);
8214 modname->op_private |= OPpCONST_BARE;
8215 if (ver) {
8216 veop = newSVOP(OP_CONST, 0, ver);
8217 }
8218 else
8219 veop = NULL;
8220 if (flags & PERL_LOADMOD_NOIMPORT) {
8221 imop = sawparens(newNULLLIST());
8222 }
8223 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
8224 imop = va_arg(*args, OP*);
8225 }
8226 else {
8227 SV *sv;
8228 imop = NULL;
8229 sv = va_arg(*args, SV*);
8230 while (sv) {
8231 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
8232 sv = va_arg(*args, SV*);
8233 }
8234 }
8235
8236 utilize(!(flags & PERL_LOADMOD_DENY), floor, veop, modname, imop);
8237 LEAVE;
8238 }
8239
8240 PERL_STATIC_INLINE OP *
S_new_entersubop(pTHX_ GV * gv,OP * arg)8241 S_new_entersubop(pTHX_ GV *gv, OP *arg)
8242 {
8243 return newUNOP(OP_ENTERSUB, OPf_STACKED,
8244 newLISTOP(OP_LIST, 0, arg,
8245 newUNOP(OP_RV2CV, 0,
8246 newGVOP(OP_GV, 0, gv))));
8247 }
8248
8249 OP *
Perl_dofile(pTHX_ OP * term,I32 force_builtin)8250 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
8251 {
8252 OP *doop;
8253 GV *gv;
8254
8255 PERL_ARGS_ASSERT_DOFILE;
8256
8257 if (!force_builtin && (gv = gv_override("do", 2))) {
8258 doop = S_new_entersubop(aTHX_ gv, term);
8259 }
8260 else {
8261 doop = newUNOP(OP_DOFILE, 0, scalar(term));
8262 }
8263 return doop;
8264 }
8265
8266 /*
8267 =for apidoc_section $optree_construction
8268
8269 =for apidoc newSLICEOP
8270
8271 Constructs, checks, and returns an C<lslice> (list slice) op. C<flags>
8272 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
8273 be set automatically, and, shifted up eight bits, the eight bits of
8274 C<op_private>, except that the bit with value 1 or 2 is automatically
8275 set as required. C<listval> and C<subscript> supply the parameters of
8276 the slice; they are consumed by this function and become part of the
8277 constructed op tree.
8278
8279 =cut
8280 */
8281
8282 OP *
Perl_newSLICEOP(pTHX_ I32 flags,OP * subscript,OP * listval)8283 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
8284 {
8285 return newBINOP(OP_LSLICE, flags,
8286 list(op_force_list(subscript)),
8287 list(op_force_list(listval)));
8288 }
8289
8290 #define ASSIGN_SCALAR 0
8291 #define ASSIGN_LIST 1
8292 #define ASSIGN_REF 2
8293
8294 /* given the optree o on the LHS of an assignment, determine whether its:
8295 * ASSIGN_SCALAR $x = ...
8296 * ASSIGN_LIST ($x) = ...
8297 * ASSIGN_REF \$x = ...
8298 */
8299
8300 STATIC I32
S_assignment_type(pTHX_ const OP * o)8301 S_assignment_type(pTHX_ const OP *o)
8302 {
8303 unsigned type;
8304 U8 flags;
8305 U8 ret;
8306
8307 if (!o)
8308 return ASSIGN_LIST;
8309
8310 if (o->op_type == OP_SREFGEN)
8311 {
8312 OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
8313 type = kid->op_type;
8314 flags = o->op_flags | kid->op_flags;
8315 if (!(flags & OPf_PARENS)
8316 && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
8317 kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
8318 return ASSIGN_REF;
8319 ret = ASSIGN_REF;
8320 } else {
8321 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
8322 o = cUNOPo->op_first;
8323 flags = o->op_flags;
8324 type = o->op_type;
8325 ret = ASSIGN_SCALAR;
8326 }
8327
8328 if (type == OP_COND_EXPR) {
8329 OP * const sib = OpSIBLING(cLOGOPo->op_first);
8330 const I32 t = assignment_type(sib);
8331 const I32 f = assignment_type(OpSIBLING(sib));
8332
8333 if (t == ASSIGN_LIST && f == ASSIGN_LIST)
8334 return ASSIGN_LIST;
8335 if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
8336 yyerror("Assignment to both a list and a scalar");
8337 return ASSIGN_SCALAR;
8338 }
8339
8340 if (type == OP_LIST &&
8341 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
8342 o->op_private & OPpLVAL_INTRO)
8343 return ret;
8344
8345 if (type == OP_LIST || flags & OPf_PARENS ||
8346 type == OP_RV2AV || type == OP_RV2HV ||
8347 type == OP_ASLICE || type == OP_HSLICE ||
8348 type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
8349 return ASSIGN_LIST;
8350
8351 if (type == OP_PADAV || type == OP_PADHV)
8352 return ASSIGN_LIST;
8353
8354 if (type == OP_RV2SV)
8355 return ret;
8356
8357 return ret;
8358 }
8359
8360 static OP *
S_newONCEOP(pTHX_ OP * initop,OP * padop)8361 S_newONCEOP(pTHX_ OP *initop, OP *padop)
8362 {
8363 const PADOFFSET target = padop->op_targ;
8364 OP *const other = newOP(OP_PADSV,
8365 padop->op_flags
8366 | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
8367 OP *const first = newOP(OP_NULL, 0);
8368 OP *const nullop = newCONDOP(0, first, initop, other);
8369 /* XXX targlex disabled for now; see ticket #124160
8370 newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
8371 */
8372 OP *const condop = first->op_next;
8373
8374 OpTYPE_set(condop, OP_ONCE);
8375 other->op_targ = target;
8376
8377 /* Store the initializedness of state vars in a separate
8378 pad entry. */
8379 condop->op_targ =
8380 pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
8381 /* hijacking PADSTALE for uninitialized state variables */
8382 SvPADSTALE_on(PAD_SVl(condop->op_targ));
8383
8384 return nullop;
8385 }
8386
8387 /*
8388 =for apidoc newARGDEFELEMOP
8389
8390 Constructs and returns a new C<OP_ARGDEFELEM> op which provides a defaulting
8391 expression given by C<expr> for the signature parameter at the index given
8392 by C<argindex>. The expression optree is consumed by this function and
8393 becomes part of the returned optree.
8394
8395 =cut
8396 */
8397
8398 OP *
Perl_newARGDEFELEMOP(pTHX_ I32 flags,OP * expr,I32 argindex)8399 Perl_newARGDEFELEMOP(pTHX_ I32 flags, OP *expr, I32 argindex)
8400 {
8401 PERL_ARGS_ASSERT_NEWARGDEFELEMOP;
8402
8403 OP *o = (OP *)alloc_LOGOP(OP_ARGDEFELEM, expr, LINKLIST(expr));
8404 o->op_flags |= (U8)(flags);
8405 o->op_private = 1 | (U8)(flags >> 8);
8406
8407 /* re-purpose op_targ to hold @_ index */
8408 o->op_targ = (PADOFFSET)(argindex);
8409
8410 return o;
8411 }
8412
8413 /*
8414 =for apidoc newASSIGNOP
8415
8416 Constructs, checks, and returns an assignment op. C<left> and C<right>
8417 supply the parameters of the assignment; they are consumed by this
8418 function and become part of the constructed op tree.
8419
8420 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
8421 a suitable conditional optree is constructed. If C<optype> is the opcode
8422 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
8423 performs the binary operation and assigns the result to the left argument.
8424 Either way, if C<optype> is non-zero then C<flags> has no effect.
8425
8426 If C<optype> is zero, then a plain scalar or list assignment is
8427 constructed. Which type of assignment it is is automatically determined.
8428 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
8429 will be set automatically, and, shifted up eight bits, the eight bits
8430 of C<op_private>, except that the bit with value 1 or 2 is automatically
8431 set as required.
8432
8433 =cut
8434 */
8435
8436 OP *
Perl_newASSIGNOP(pTHX_ I32 flags,OP * left,I32 optype,OP * right)8437 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
8438 {
8439 OP *o;
8440 I32 assign_type;
8441
8442 switch (optype) {
8443 case 0: break;
8444 case OP_ANDASSIGN:
8445 case OP_ORASSIGN:
8446 case OP_DORASSIGN:
8447 right = scalar(right);
8448 return newLOGOP(optype, 0,
8449 op_lvalue(scalar(left), optype),
8450 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
8451 default:
8452 return newBINOP(optype, OPf_STACKED,
8453 op_lvalue(scalar(left), optype), scalar(right));
8454 }
8455
8456 if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
8457 OP *state_var_op = NULL;
8458 static const char no_list_state[] = "Initialization of state variables"
8459 " in list currently forbidden";
8460 OP *curop;
8461
8462 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
8463 left->op_private &= ~ OPpSLICEWARNING;
8464
8465 PL_modcount = 0;
8466 left = op_lvalue(left, OP_AASSIGN);
8467 curop = list(op_force_list(left));
8468 o = newBINOP(OP_AASSIGN, flags, list(op_force_list(right)), curop);
8469 o->op_private = (U8)(0 | (flags >> 8));
8470
8471 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
8472 {
8473 OP *lop = cLISTOPx(left)->op_first, *vop, *eop;
8474 if (!(left->op_flags & OPf_PARENS) &&
8475 lop->op_type == OP_PUSHMARK &&
8476 (vop = OpSIBLING(lop)) &&
8477 (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
8478 !(vop->op_flags & OPf_PARENS) &&
8479 (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
8480 (OPpLVAL_INTRO|OPpPAD_STATE) &&
8481 (eop = OpSIBLING(vop)) &&
8482 eop->op_type == OP_ENTERSUB &&
8483 !OpHAS_SIBLING(eop)) {
8484 state_var_op = vop;
8485 } else {
8486 while (lop) {
8487 if ((lop->op_type == OP_PADSV ||
8488 lop->op_type == OP_PADAV ||
8489 lop->op_type == OP_PADHV ||
8490 lop->op_type == OP_PADANY)
8491 && (lop->op_private & OPpPAD_STATE)
8492 )
8493 yyerror(no_list_state);
8494 lop = OpSIBLING(lop);
8495 }
8496 }
8497 }
8498 else if ( (left->op_private & OPpLVAL_INTRO)
8499 && (left->op_private & OPpPAD_STATE)
8500 && ( left->op_type == OP_PADSV
8501 || left->op_type == OP_PADAV
8502 || left->op_type == OP_PADHV
8503 || left->op_type == OP_PADANY)
8504 ) {
8505 /* All single variable list context state assignments, hence
8506 state ($a) = ...
8507 (state $a) = ...
8508 state @a = ...
8509 state (@a) = ...
8510 (state @a) = ...
8511 state %a = ...
8512 state (%a) = ...
8513 (state %a) = ...
8514 */
8515 if (left->op_flags & OPf_PARENS)
8516 yyerror(no_list_state);
8517 else
8518 state_var_op = left;
8519 }
8520
8521 /* optimise @a = split(...) into:
8522 * @{expr}: split(..., @{expr}) (where @a is not flattened)
8523 * @a, my @a, local @a: split(...) (where @a is attached to
8524 * the split op itself)
8525 */
8526
8527 if ( right
8528 && right->op_type == OP_SPLIT
8529 /* don't do twice, e.g. @b = (@a = split) */
8530 && !(right->op_private & OPpSPLIT_ASSIGN))
8531 {
8532 OP *gvop = NULL;
8533
8534 if ( ( left->op_type == OP_RV2AV
8535 && (gvop=cUNOPx(left)->op_first)->op_type==OP_GV)
8536 || left->op_type == OP_PADAV)
8537 {
8538 /* @pkg or @lex or local @pkg' or 'my @lex' */
8539 OP *tmpop;
8540 if (gvop) {
8541 #ifdef USE_ITHREADS
8542 cPMOPx(right)->op_pmreplrootu.op_pmtargetoff
8543 = cPADOPx(gvop)->op_padix;
8544 cPADOPx(gvop)->op_padix = 0; /* steal it */
8545 #else
8546 cPMOPx(right)->op_pmreplrootu.op_pmtargetgv
8547 = MUTABLE_GV(cSVOPx(gvop)->op_sv);
8548 cSVOPx(gvop)->op_sv = NULL; /* steal it */
8549 #endif
8550 right->op_private |=
8551 left->op_private & OPpOUR_INTRO;
8552 }
8553 else {
8554 cPMOPx(right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
8555 left->op_targ = 0; /* steal it */
8556 right->op_private |= OPpSPLIT_LEX;
8557 }
8558 right->op_private |= left->op_private & OPpLVAL_INTRO;
8559
8560 detach_split:
8561 tmpop = cUNOPo->op_first; /* to list (nulled) */
8562 tmpop = cUNOPx(tmpop)->op_first; /* to pushmark */
8563 assert(OpSIBLING(tmpop) == right);
8564 assert(!OpHAS_SIBLING(right));
8565 /* detach the split subtreee from the o tree,
8566 * then free the residual o tree */
8567 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
8568 op_free(o); /* blow off assign */
8569 right->op_private |= OPpSPLIT_ASSIGN;
8570 right->op_flags &= ~OPf_WANT;
8571 /* "I don't know and I don't care." */
8572 return right;
8573 }
8574 else if (left->op_type == OP_RV2AV) {
8575 /* @{expr} */
8576
8577 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
8578 assert(OpSIBLING(pushop) == left);
8579 /* Detach the array ... */
8580 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
8581 /* ... and attach it to the split. */
8582 op_sibling_splice(right, cLISTOPx(right)->op_last,
8583 0, left);
8584 right->op_flags |= OPf_STACKED;
8585 /* Detach split and expunge aassign as above. */
8586 goto detach_split;
8587 }
8588 else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
8589 cLISTOPx(right)->op_last->op_type == OP_CONST)
8590 {
8591 /* convert split(...,0) to split(..., PL_modcount+1) */
8592 SV ** const svp =
8593 &cSVOPx(cLISTOPx(right)->op_last)->op_sv;
8594 SV * const sv = *svp;
8595 if (SvIOK(sv) && SvIVX(sv) == 0)
8596 {
8597 if (right->op_private & OPpSPLIT_IMPLIM) {
8598 /* our own SV, created in ck_split */
8599 SvREADONLY_off(sv);
8600 sv_setiv(sv, PL_modcount+1);
8601 }
8602 else {
8603 /* SV may belong to someone else */
8604 SvREFCNT_dec(sv);
8605 *svp = newSViv(PL_modcount+1);
8606 }
8607 }
8608 }
8609 }
8610
8611 if (state_var_op)
8612 o = S_newONCEOP(aTHX_ o, state_var_op);
8613 return o;
8614 }
8615 if (assign_type == ASSIGN_REF)
8616 return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
8617 if (!right)
8618 right = newOP(OP_UNDEF, 0);
8619 if (right->op_type == OP_READLINE) {
8620 right->op_flags |= OPf_STACKED;
8621 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
8622 scalar(right));
8623 }
8624 else {
8625 o = newBINOP(OP_SASSIGN, flags,
8626 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
8627 }
8628 return o;
8629 }
8630
8631 /*
8632 =for apidoc newSTATEOP
8633
8634 Constructs a state op (COP). The state op is normally a C<nextstate> op,
8635 but will be a C<dbstate> op if debugging is enabled for currently-compiled
8636 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
8637 If C<label> is non-null, it supplies the name of a label to attach to
8638 the state op; this function takes ownership of the memory pointed at by
8639 C<label>, and will free it. C<flags> gives the eight bits of C<op_flags>
8640 for the state op.
8641
8642 If C<o> is null, the state op is returned. Otherwise the state op is
8643 combined with C<o> into a C<lineseq> list op, which is returned. C<o>
8644 is consumed by this function and becomes part of the returned op tree.
8645
8646 =cut
8647 */
8648
8649 OP *
Perl_newSTATEOP(pTHX_ I32 flags,char * label,OP * o)8650 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
8651 {
8652 const U32 seq = intro_my();
8653 const U32 utf8 = flags & SVf_UTF8;
8654 COP *cop;
8655
8656 assert(PL_parser);
8657 PL_parser->parsed_sub = 0;
8658
8659 flags &= ~SVf_UTF8;
8660
8661 NewOp(1101, cop, 1, COP);
8662 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8663 OpTYPE_set(cop, OP_DBSTATE);
8664 }
8665 else {
8666 OpTYPE_set(cop, OP_NEXTSTATE);
8667 }
8668 cop->op_flags = (U8)flags;
8669 CopHINTS_set(cop, PL_hints);
8670 #ifdef VMS
8671 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
8672 #endif
8673 cop->op_next = (OP*)cop;
8674
8675 cop->cop_seq = seq;
8676 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8677 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
8678 CopFEATURES_setfrom(cop, PL_curcop);
8679 if (label) {
8680 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
8681
8682 PL_hints |= HINT_BLOCK_SCOPE;
8683 /* It seems that we need to defer freeing this pointer, as other parts
8684 of the grammar end up wanting to copy it after this op has been
8685 created. */
8686 SAVEFREEPV(label);
8687 }
8688
8689 if (PL_parser->preambling != NOLINE) {
8690 CopLINE_set(cop, PL_parser->preambling);
8691 PL_parser->copline = NOLINE;
8692 }
8693 else if (PL_parser->copline == NOLINE)
8694 CopLINE_set(cop, CopLINE(PL_curcop));
8695 else {
8696 CopLINE_set(cop, PL_parser->copline);
8697 PL_parser->copline = NOLINE;
8698 }
8699 #ifdef USE_ITHREADS
8700 CopFILE_copy(cop, PL_curcop);
8701 #else
8702 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
8703 #endif
8704 CopSTASH_set(cop, PL_curstash);
8705
8706 if (cop->op_type == OP_DBSTATE) {
8707 /* this line can have a breakpoint - store the cop in IV */
8708 AV *av = CopFILEAVx(PL_curcop);
8709 if (av) {
8710 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
8711 if (svp && *svp != &PL_sv_undef ) {
8712 (void)SvIOK_on(*svp);
8713 SvIV_set(*svp, PTR2IV(cop));
8714 }
8715 }
8716 }
8717
8718 if (flags & OPf_SPECIAL)
8719 op_null((OP*)cop);
8720 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
8721 }
8722
8723 /*
8724 =for apidoc newLOGOP
8725
8726 Constructs, checks, and returns a logical (flow control) op. C<type>
8727 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
8728 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
8729 the eight bits of C<op_private>, except that the bit with value 1 is
8730 automatically set. C<first> supplies the expression controlling the
8731 flow, and C<other> supplies the side (alternate) chain of ops; they are
8732 consumed by this function and become part of the constructed op tree.
8733
8734 =cut
8735 */
8736
8737 OP *
Perl_newLOGOP(pTHX_ I32 type,I32 flags,OP * first,OP * other)8738 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
8739 {
8740 PERL_ARGS_ASSERT_NEWLOGOP;
8741
8742 return new_logop(type, flags, &first, &other);
8743 }
8744
8745
8746 /* See if the optree o contains a single OP_CONST (plus possibly
8747 * surrounding enter/nextstate/null etc). If so, return it, else return
8748 * NULL.
8749 */
8750
8751 STATIC OP *
S_search_const(pTHX_ OP * o)8752 S_search_const(pTHX_ OP *o)
8753 {
8754 PERL_ARGS_ASSERT_SEARCH_CONST;
8755
8756 redo:
8757 switch (o->op_type) {
8758 case OP_CONST:
8759 return o;
8760 case OP_NULL:
8761 if (o->op_flags & OPf_KIDS) {
8762 o = cUNOPo->op_first;
8763 goto redo;
8764 }
8765 break;
8766 case OP_LEAVE:
8767 case OP_SCOPE:
8768 case OP_LINESEQ:
8769 {
8770 OP *kid;
8771 if (!(o->op_flags & OPf_KIDS))
8772 return NULL;
8773 kid = cLISTOPo->op_first;
8774
8775 do {
8776 switch (kid->op_type) {
8777 case OP_ENTER:
8778 case OP_NULL:
8779 case OP_NEXTSTATE:
8780 kid = OpSIBLING(kid);
8781 break;
8782 default:
8783 if (kid != cLISTOPo->op_last)
8784 return NULL;
8785 goto last;
8786 }
8787 } while (kid);
8788
8789 if (!kid)
8790 kid = cLISTOPo->op_last;
8791 last:
8792 o = kid;
8793 goto redo;
8794 }
8795 }
8796
8797 return NULL;
8798 }
8799
8800
8801 STATIC OP *
S_new_logop(pTHX_ I32 type,I32 flags,OP ** firstp,OP ** otherp)8802 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
8803 {
8804 LOGOP *logop;
8805 OP *o;
8806 OP *first;
8807 OP *other;
8808 OP *cstop = NULL;
8809 int prepend_not = 0;
8810
8811 PERL_ARGS_ASSERT_NEW_LOGOP;
8812
8813 first = *firstp;
8814 other = *otherp;
8815
8816 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
8817 return newBINOP(type, flags, scalar(first), scalar(other));
8818
8819 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
8820 || type == OP_CUSTOM);
8821
8822 scalarboolean(first);
8823
8824 if (S_is_control_transfer(aTHX_ first)) {
8825 op_free(other);
8826 first->op_folded = 1;
8827 return first;
8828 }
8829
8830 /* search for a constant op that could let us fold the test */
8831 if ((cstop = search_const(first))) {
8832 if (cstop->op_private & OPpCONST_STRICT)
8833 no_bareword_allowed(cstop);
8834 else if ((cstop->op_private & OPpCONST_BARE))
8835 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
8836 if ((type == OP_AND && SvTRUE(cSVOPx(cstop)->op_sv)) ||
8837 (type == OP_OR && !SvTRUE(cSVOPx(cstop)->op_sv)) ||
8838 (type == OP_DOR && !SvOK(cSVOPx(cstop)->op_sv))) {
8839 /* Elide the (constant) lhs, since it can't affect the outcome */
8840 *firstp = NULL;
8841 if (other->op_type == OP_CONST)
8842 other->op_private |= OPpCONST_SHORTCIRCUIT;
8843 op_free(first);
8844 if (other->op_type == OP_LEAVE)
8845 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
8846 else if (other->op_type == OP_MATCH
8847 || other->op_type == OP_SUBST
8848 || other->op_type == OP_TRANSR
8849 || other->op_type == OP_TRANS)
8850 /* Mark the op as being unbindable with =~ */
8851 other->op_flags |= OPf_SPECIAL;
8852
8853 other->op_folded = 1;
8854 return other;
8855 }
8856 else {
8857 /* Elide the rhs, since the outcome is entirely determined by
8858 * the (constant) lhs */
8859
8860 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
8861 const OP *o2 = other;
8862 if ( ! (o2->op_type == OP_LIST
8863 && (( o2 = cUNOPx(o2)->op_first))
8864 && o2->op_type == OP_PUSHMARK
8865 && (( o2 = OpSIBLING(o2))) )
8866 )
8867 o2 = other;
8868 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
8869 || o2->op_type == OP_PADHV)
8870 && o2->op_private & OPpLVAL_INTRO
8871 && !(o2->op_private & OPpPAD_STATE))
8872 {
8873 Perl_croak(aTHX_ "This use of my() in false conditional is "
8874 "no longer allowed");
8875 }
8876
8877 *otherp = NULL;
8878 if (cstop->op_type == OP_CONST)
8879 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
8880 op_free(other);
8881 return first;
8882 }
8883 }
8884 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
8885 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
8886 {
8887 const OP * const k1 = cUNOPx(first)->op_first;
8888 const OP * const k2 = OpSIBLING(k1);
8889 OPCODE warnop = 0;
8890 switch (first->op_type)
8891 {
8892 case OP_NULL:
8893 if (k2 && k2->op_type == OP_READLINE
8894 && (k2->op_flags & OPf_STACKED)
8895 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8896 {
8897 warnop = k2->op_type;
8898 }
8899 break;
8900
8901 case OP_SASSIGN:
8902 if (k1->op_type == OP_READDIR
8903 || k1->op_type == OP_GLOB
8904 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8905 || k1->op_type == OP_EACH
8906 || k1->op_type == OP_AEACH)
8907 {
8908 warnop = ((k1->op_type == OP_NULL)
8909 ? (OPCODE)k1->op_targ : k1->op_type);
8910 }
8911 break;
8912 }
8913 if (warnop) {
8914 const line_t oldline = CopLINE(PL_curcop);
8915 /* This ensures that warnings are reported at the first line
8916 of the construction, not the last. */
8917 CopLINE_set(PL_curcop, PL_parser->copline);
8918 Perl_warner(aTHX_ packWARN(WARN_MISC),
8919 "Value of %s%s can be \"0\"; test with defined()",
8920 PL_op_desc[warnop],
8921 ((warnop == OP_READLINE || warnop == OP_GLOB)
8922 ? " construct" : "() operator"));
8923 CopLINE_set(PL_curcop, oldline);
8924 }
8925 }
8926
8927 /* optimize AND and OR ops that have NOTs as children */
8928 if (first->op_type == OP_NOT
8929 && (first->op_flags & OPf_KIDS)
8930 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
8931 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
8932 ) {
8933 if (type == OP_AND || type == OP_OR) {
8934 if (type == OP_AND)
8935 type = OP_OR;
8936 else
8937 type = OP_AND;
8938 op_null(first);
8939 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
8940 op_null(other);
8941 prepend_not = 1; /* prepend a NOT op later */
8942 }
8943 }
8944 }
8945
8946 logop = alloc_LOGOP(type, first, LINKLIST(other));
8947 logop->op_flags |= (U8)flags;
8948 logop->op_private = (U8)(1 | (flags >> 8));
8949
8950 /* establish postfix order */
8951 logop->op_next = LINKLIST(first);
8952 first->op_next = (OP*)logop;
8953 assert(!OpHAS_SIBLING(first));
8954 op_sibling_splice((OP*)logop, first, 0, other);
8955
8956 CHECKOP(type,logop);
8957
8958 o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
8959 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
8960 (OP*)logop);
8961 other->op_next = o;
8962
8963 return o;
8964 }
8965
8966 /*
8967 =for apidoc newCONDOP
8968
8969 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
8970 op. C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
8971 will be set automatically, and, shifted up eight bits, the eight bits of
8972 C<op_private>, except that the bit with value 1 is automatically set.
8973 C<first> supplies the expression selecting between the two branches,
8974 and C<trueop> and C<falseop> supply the branches; they are consumed by
8975 this function and become part of the constructed op tree.
8976
8977 =cut
8978 */
8979
8980 OP *
Perl_newCONDOP(pTHX_ I32 flags,OP * first,OP * trueop,OP * falseop)8981 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
8982 {
8983 LOGOP *logop;
8984 OP *start;
8985 OP *o;
8986 OP *cstop;
8987
8988 PERL_ARGS_ASSERT_NEWCONDOP;
8989
8990 if (!falseop)
8991 return newLOGOP(OP_AND, 0, first, trueop);
8992 if (!trueop)
8993 return newLOGOP(OP_OR, 0, first, falseop);
8994
8995 scalarboolean(first);
8996 if (S_is_control_transfer(aTHX_ first)) {
8997 op_free(trueop);
8998 op_free(falseop);
8999 first->op_folded = 1;
9000 return first;
9001 }
9002
9003 if ((cstop = search_const(first))) {
9004 /* Left or right arm of the conditional? */
9005 const bool left = SvTRUE(cSVOPx(cstop)->op_sv);
9006 OP *live = left ? trueop : falseop;
9007 OP *const dead = left ? falseop : trueop;
9008 if (cstop->op_private & OPpCONST_BARE &&
9009 cstop->op_private & OPpCONST_STRICT) {
9010 no_bareword_allowed(cstop);
9011 }
9012 op_free(first);
9013 op_free(dead);
9014 if (live->op_type == OP_LEAVE)
9015 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
9016 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
9017 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
9018 /* Mark the op as being unbindable with =~ */
9019 live->op_flags |= OPf_SPECIAL;
9020 live->op_folded = 1;
9021 return live;
9022 }
9023 logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
9024 logop->op_flags |= (U8)flags;
9025 logop->op_private = (U8)(1 | (flags >> 8));
9026 logop->op_next = LINKLIST(falseop);
9027
9028 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
9029 logop);
9030
9031 /* establish postfix order */
9032 start = LINKLIST(first);
9033 first->op_next = (OP*)logop;
9034
9035 /* make first, trueop, falseop siblings */
9036 op_sibling_splice((OP*)logop, first, 0, trueop);
9037 op_sibling_splice((OP*)logop, trueop, 0, falseop);
9038
9039 o = newUNOP(OP_NULL, 0, (OP*)logop);
9040
9041 trueop->op_next = falseop->op_next = o;
9042
9043 o->op_next = start;
9044 return o;
9045 }
9046
9047 /*
9048 =for apidoc newTRYCATCHOP
9049
9050 Constructs and returns a conditional execution statement that implements
9051 the C<try>/C<catch> semantics. First the op tree in C<tryblock> is executed,
9052 inside a context that traps exceptions. If an exception occurs then the
9053 optree in C<catchblock> is executed, with the trapped exception set into the
9054 lexical variable given by C<catchvar> (which must be an op of type
9055 C<OP_PADSV>). All the optrees are consumed by this function and become part
9056 of the returned op tree.
9057
9058 The C<flags> argument is currently ignored.
9059
9060 =cut
9061 */
9062
9063 OP *
Perl_newTRYCATCHOP(pTHX_ I32 flags,OP * tryblock,OP * catchvar,OP * catchblock)9064 Perl_newTRYCATCHOP(pTHX_ I32 flags, OP *tryblock, OP *catchvar, OP *catchblock)
9065 {
9066 OP *catchop;
9067
9068 PERL_ARGS_ASSERT_NEWTRYCATCHOP;
9069 assert(catchvar->op_type == OP_PADSV);
9070
9071 PERL_UNUSED_ARG(flags);
9072
9073 /* The returned optree is shaped as:
9074 * LISTOP leavetrycatch
9075 * LOGOP entertrycatch
9076 * LISTOP poptry
9077 * $tryblock here
9078 * LOGOP catch
9079 * $catchblock here
9080 */
9081
9082 if(tryblock->op_type != OP_LINESEQ)
9083 tryblock = op_convert_list(OP_LINESEQ, 0, tryblock);
9084 OpTYPE_set(tryblock, OP_POPTRY);
9085
9086 /* Manually construct a naked LOGOP.
9087 * Normally if we call newLOGOP the returned value is a UNOP(OP_NULL)
9088 * containing the LOGOP we wanted as its op_first */
9089 catchop = (OP *)alloc_LOGOP(OP_CATCH, newOP(OP_NULL, 0), catchblock);
9090 OpMORESIB_set(cUNOPx(catchop)->op_first, catchblock);
9091 OpLASTSIB_set(catchblock, catchop);
9092
9093 /* Inject the catchvar's pad offset into the OP_CATCH targ */
9094 cLOGOPx(catchop)->op_targ = catchvar->op_targ;
9095 op_free(catchvar);
9096
9097 /* Build the optree structure */
9098 return newLISTOPn(OP_ENTERTRYCATCH, 0,
9099 tryblock,
9100 catchop,
9101 NULL);
9102 }
9103
9104 /*
9105 =for apidoc newRANGE
9106
9107 Constructs and returns a C<range> op, with subordinate C<flip> and
9108 C<flop> ops. C<flags> gives the eight bits of C<op_flags> for the
9109 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
9110 for both the C<flip> and C<range> ops, except that the bit with value
9111 1 is automatically set. C<left> and C<right> supply the expressions
9112 controlling the endpoints of the range; they are consumed by this function
9113 and become part of the constructed op tree.
9114
9115 =cut
9116 */
9117
9118 OP *
Perl_newRANGE(pTHX_ I32 flags,OP * left,OP * right)9119 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
9120 {
9121 LOGOP *range;
9122 OP *flip;
9123 OP *flop;
9124 OP *leftstart;
9125 OP *o;
9126
9127 PERL_ARGS_ASSERT_NEWRANGE;
9128
9129 range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
9130 range->op_flags = OPf_KIDS;
9131 leftstart = LINKLIST(left);
9132 range->op_private = (U8)(1 | (flags >> 8));
9133
9134 /* make left and right siblings */
9135 op_sibling_splice((OP*)range, left, 0, right);
9136
9137 range->op_next = (OP*)range;
9138 flip = newUNOP(OP_FLIP, flags, (OP*)range);
9139 flop = newUNOP(OP_FLOP, 0, flip);
9140 o = newUNOP(OP_NULL, 0, flop);
9141 LINKLIST(flop);
9142 range->op_next = leftstart;
9143
9144 left->op_next = flip;
9145 right->op_next = flop;
9146
9147 range->op_targ =
9148 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
9149 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
9150 flip->op_targ =
9151 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
9152 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
9153 SvPADTMP_on(PAD_SV(flip->op_targ));
9154
9155 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
9156 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
9157
9158 /* check barewords before they might be optimized away */
9159 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
9160 no_bareword_allowed(left);
9161 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
9162 no_bareword_allowed(right);
9163
9164 flip->op_next = o;
9165 if (!flip->op_private || !flop->op_private)
9166 LINKLIST(o); /* blow off optimizer unless constant */
9167
9168 return o;
9169 }
9170
9171 /*
9172 =for apidoc newLOOPOP
9173
9174 Constructs, checks, and returns an op tree expressing a loop. This is
9175 only a loop in the control flow through the op tree; it does not have
9176 the heavyweight loop structure that allows exiting the loop by C<last>
9177 and suchlike. C<flags> gives the eight bits of C<op_flags> for the
9178 top-level op, except that some bits will be set automatically as required.
9179 C<expr> supplies the expression controlling loop iteration, and C<block>
9180 supplies the body of the loop; they are consumed by this function and
9181 become part of the constructed op tree. C<debuggable> is currently
9182 unused and should always be 1.
9183
9184 =cut
9185 */
9186
9187 OP *
Perl_newLOOPOP(pTHX_ I32 flags,I32 debuggable,OP * expr,OP * block)9188 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
9189 {
9190 PERL_ARGS_ASSERT_NEWLOOPOP;
9191
9192 OP* listop;
9193 OP* o;
9194 const bool once = block && block->op_flags & OPf_SPECIAL &&
9195 block->op_type == OP_NULL;
9196
9197 PERL_UNUSED_ARG(debuggable);
9198
9199 if (once && (
9200 (expr->op_type == OP_CONST && !SvTRUE(cSVOPx(expr)->op_sv))
9201 || ( expr->op_type == OP_NOT
9202 && cUNOPx(expr)->op_first->op_type == OP_CONST
9203 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
9204 )
9205 ))
9206 /* Return the block now, so that S_new_logop does not try to
9207 fold it away. */
9208 {
9209 op_free(expr);
9210 return block; /* do {} while 0 does once */
9211 }
9212
9213 if (expr->op_type == OP_READLINE
9214 || expr->op_type == OP_READDIR
9215 || expr->op_type == OP_GLOB
9216 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
9217 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
9218 expr = newUNOP(OP_DEFINED, 0,
9219 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
9220 } else if (expr->op_flags & OPf_KIDS) {
9221 const OP * const k1 = cUNOPx(expr)->op_first;
9222 const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
9223 switch (expr->op_type) {
9224 case OP_NULL:
9225 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
9226 && (k2->op_flags & OPf_STACKED)
9227 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
9228 expr = newUNOP(OP_DEFINED, 0, expr);
9229 break;
9230
9231 case OP_SASSIGN:
9232 if (k1 && (k1->op_type == OP_READDIR
9233 || k1->op_type == OP_GLOB
9234 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
9235 || k1->op_type == OP_EACH
9236 || k1->op_type == OP_AEACH))
9237 expr = newUNOP(OP_DEFINED, 0, expr);
9238 break;
9239 }
9240 }
9241
9242 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
9243 * op, in listop. This is wrong. [perl #27024] */
9244 if (!block)
9245 block = newOP(OP_NULL, 0);
9246 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
9247 o = new_logop(OP_AND, 0, &expr, &listop);
9248
9249 if (once) {
9250 ASSUME(listop);
9251 }
9252
9253 if (listop)
9254 cLISTOPx(listop)->op_last->op_next = LINKLIST(o);
9255
9256 if (once && o != listop)
9257 {
9258 assert(cUNOPo->op_first->op_type == OP_AND
9259 || cUNOPo->op_first->op_type == OP_OR);
9260 o->op_next = cLOGOPx(cUNOPo->op_first)->op_other;
9261 }
9262
9263 if (o == listop)
9264 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
9265
9266 o->op_flags |= flags;
9267 o = op_scope(o);
9268 o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
9269 return o;
9270 }
9271
9272 /*
9273 =for apidoc newWHILEOP
9274
9275 Constructs, checks, and returns an op tree expressing a C<while> loop.
9276 This is a heavyweight loop, with structure that allows exiting the loop
9277 by C<last> and suchlike.
9278
9279 C<loop> is an optional preconstructed C<enterloop> op to use in the
9280 loop; if it is null then a suitable op will be constructed automatically.
9281 C<expr> supplies the loop's controlling expression. C<block> supplies the
9282 main body of the loop, and C<cont> optionally supplies a C<continue> block
9283 that operates as a second half of the body. All of these optree inputs
9284 are consumed by this function and become part of the constructed op tree.
9285
9286 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
9287 op and, shifted up eight bits, the eight bits of C<op_private> for
9288 the C<leaveloop> op, except that (in both cases) some bits will be set
9289 automatically. C<debuggable> is currently unused and should always be 1.
9290 C<has_my> can be supplied as true to force the
9291 loop body to be enclosed in its own scope.
9292
9293 =cut
9294 */
9295
9296 OP *
Perl_newWHILEOP(pTHX_ I32 flags,I32 debuggable,LOOP * loop,OP * expr,OP * block,OP * cont,I32 has_my)9297 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
9298 OP *expr, OP *block, OP *cont, I32 has_my)
9299 {
9300 OP *redo;
9301 OP *next = NULL;
9302 OP *listop;
9303 OP *o;
9304 U8 loopflags = 0;
9305
9306 PERL_UNUSED_ARG(debuggable);
9307
9308 if (expr) {
9309 if (expr->op_type == OP_READLINE
9310 || expr->op_type == OP_READDIR
9311 || expr->op_type == OP_GLOB
9312 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
9313 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
9314 expr = newUNOP(OP_DEFINED, 0,
9315 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
9316 } else if (expr->op_flags & OPf_KIDS) {
9317 const OP * const k1 = cUNOPx(expr)->op_first;
9318 const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
9319 switch (expr->op_type) {
9320 case OP_NULL:
9321 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
9322 && (k2->op_flags & OPf_STACKED)
9323 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
9324 expr = newUNOP(OP_DEFINED, 0, expr);
9325 break;
9326
9327 case OP_SASSIGN:
9328 if (k1 && (k1->op_type == OP_READDIR
9329 || k1->op_type == OP_GLOB
9330 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
9331 || k1->op_type == OP_EACH
9332 || k1->op_type == OP_AEACH))
9333 expr = newUNOP(OP_DEFINED, 0, expr);
9334 break;
9335 }
9336 }
9337 }
9338
9339 if (!block)
9340 block = newOP(OP_NULL, 0);
9341 else if (cont || has_my) {
9342 block = op_scope(block);
9343 }
9344
9345 if (cont) {
9346 next = LINKLIST(cont);
9347 }
9348 if (expr) {
9349 OP * const unstack = newOP(OP_UNSTACK, 0);
9350 if (!next)
9351 next = unstack;
9352 cont = op_append_elem(OP_LINESEQ, cont, unstack);
9353 }
9354
9355 assert(block);
9356 listop = op_append_list(OP_LINESEQ, block, cont);
9357 assert(listop);
9358 redo = LINKLIST(listop);
9359
9360 if (expr) {
9361 scalar(listop);
9362 o = new_logop(OP_AND, 0, &expr, &listop);
9363 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
9364 op_free((OP*)loop);
9365 return expr; /* listop already freed by new_logop */
9366 }
9367 if (listop)
9368 cLISTOPx(listop)->op_last->op_next =
9369 (o == listop ? redo : LINKLIST(o));
9370 }
9371 else
9372 o = listop;
9373
9374 if (!loop) {
9375 NewOp(1101,loop,1,LOOP);
9376 OpTYPE_set(loop, OP_ENTERLOOP);
9377 loop->op_private = 0;
9378 loop->op_next = (OP*)loop;
9379 }
9380
9381 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
9382
9383 loop->op_redoop = redo;
9384 loop->op_lastop = o;
9385 o->op_private |= loopflags;
9386
9387 if (next)
9388 loop->op_nextop = next;
9389 else
9390 loop->op_nextop = o;
9391
9392 o->op_flags |= flags;
9393 o->op_private |= (flags >> 8);
9394 return o;
9395 }
9396
9397 /*
9398 =for apidoc newFOROP
9399
9400 Constructs, checks, and returns an op tree expressing a C<foreach>
9401 loop (iteration through a list of values). This is a heavyweight loop,
9402 with structure that allows exiting the loop by C<last> and suchlike.
9403
9404 C<sv> optionally supplies the variable(s) that will be aliased to each
9405 item in turn; if null, it defaults to C<$_>.
9406 C<expr> supplies the list of values to iterate over. C<block> supplies
9407 the main body of the loop, and C<cont> optionally supplies a C<continue>
9408 block that operates as a second half of the body. All of these optree
9409 inputs are consumed by this function and become part of the constructed
9410 op tree.
9411
9412 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
9413 op and, shifted up eight bits, the eight bits of C<op_private> for
9414 the C<leaveloop> op, except that (in both cases) some bits will be set
9415 automatically.
9416
9417 =cut
9418 */
9419
9420 OP *
Perl_newFOROP(pTHX_ I32 flags,OP * sv,OP * expr,OP * block,OP * cont)9421 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
9422 {
9423 LOOP *loop;
9424 OP *iter;
9425 PADOFFSET padoff = 0;
9426 PADOFFSET how_many_more = 0;
9427 I32 iterflags = 0;
9428 I32 iterpflags = 0;
9429 bool parens = 0;
9430
9431 PERL_ARGS_ASSERT_NEWFOROP;
9432
9433 if (sv) {
9434 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
9435 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
9436 OpTYPE_set(sv, OP_RV2GV);
9437
9438 /* The op_type check is needed to prevent a possible segfault
9439 * if the loop variable is undeclared and 'strict vars' is in
9440 * effect. This is illegal but is nonetheless parsed, so we
9441 * may reach this point with an OP_CONST where we're expecting
9442 * an OP_GV.
9443 */
9444 if (cUNOPx(sv)->op_first->op_type == OP_GV
9445 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
9446 iterpflags |= OPpITER_DEF;
9447 }
9448 else if (sv->op_type == OP_PADSV) { /* private variable */
9449 if (sv->op_flags & OPf_PARENS) {
9450 /* handle degenerate 1-var form of "for my ($x, ...)" */
9451 sv->op_private |= OPpLVAL_INTRO;
9452 parens = 1;
9453 }
9454 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
9455 padoff = sv->op_targ;
9456 sv->op_targ = 0;
9457 op_free(sv);
9458 sv = NULL;
9459 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
9460 }
9461 else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
9462 NOOP;
9463 else if (sv->op_type == OP_LIST) {
9464 LISTOP *list = cLISTOPx(sv);
9465 OP *pushmark = list->op_first;
9466 OP *first_padsv;
9467 UNOP *padsv;
9468 PADOFFSET i;
9469
9470 iterpflags = OPpLVAL_INTRO; /* for my ($k, $v) () */
9471 parens = 1;
9472
9473 if (!pushmark || pushmark->op_type != OP_PUSHMARK) {
9474 Perl_croak(aTHX_ "panic: newFORLOOP, found %s, expecting pushmark",
9475 pushmark ? PL_op_desc[pushmark->op_type] : "NULL");
9476 }
9477 first_padsv = OpSIBLING(pushmark);
9478 if (!first_padsv || first_padsv->op_type != OP_PADSV) {
9479 Perl_croak(aTHX_ "panic: newFORLOOP, found %s, expecting padsv",
9480 first_padsv ? PL_op_desc[first_padsv->op_type] : "NULL");
9481 }
9482 padoff = first_padsv->op_targ;
9483
9484 /* There should be at least one more PADSV to find, and the ops
9485 should have consecutive values in targ: */
9486 padsv = cUNOPx(OpSIBLING(first_padsv));
9487 do {
9488 if (!padsv || padsv->op_type != OP_PADSV) {
9489 Perl_croak(aTHX_ "panic: newFORLOOP, found %s at %zd, expecting padsv",
9490 padsv ? PL_op_desc[padsv->op_type] : "NULL",
9491 how_many_more);
9492 }
9493 ++how_many_more;
9494 if (padsv->op_targ != padoff + how_many_more) {
9495 Perl_croak(aTHX_ "panic: newFORLOOP, padsv at %zd targ is %zd, not %zd",
9496 how_many_more, padsv->op_targ, padoff + how_many_more);
9497 }
9498
9499 padsv = cUNOPx(OpSIBLING(padsv));
9500 } while (padsv);
9501
9502 /* OK, this optree has the shape that we expected. So now *we*
9503 "claim" the Pad slots: */
9504 first_padsv->op_targ = 0;
9505 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
9506
9507 i = padoff;
9508
9509 padsv = cUNOPx(OpSIBLING(first_padsv));
9510 do {
9511 ++i;
9512 padsv->op_targ = 0;
9513 PAD_COMPNAME_GEN_set(i, PERL_INT_MAX);
9514
9515 padsv = cUNOPx(OpSIBLING(padsv));
9516 } while (padsv);
9517
9518 op_free(sv);
9519 sv = NULL;
9520 }
9521 else
9522 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
9523 if (padoff) {
9524 PADNAME * const pn = PAD_COMPNAME(padoff);
9525 const char * const name = PadnamePV(pn);
9526
9527 if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
9528 iterpflags |= OPpITER_DEF;
9529 }
9530 }
9531 else {
9532 sv = newGVOP(OP_GV, 0, PL_defgv);
9533 iterpflags |= OPpITER_DEF;
9534 }
9535
9536 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
9537 expr = op_lvalue(op_force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
9538 iterflags |= OPf_STACKED;
9539 }
9540 else if (expr->op_type == OP_NULL &&
9541 (expr->op_flags & OPf_KIDS) &&
9542 cBINOPx(expr)->op_first->op_type == OP_FLOP)
9543 {
9544 /* Basically turn for($x..$y) into the same as for($x,$y), but we
9545 * set the STACKED flag to indicate that these values are to be
9546 * treated as min/max values by 'pp_enteriter'.
9547 */
9548 const UNOP* const flip = cUNOPx(cUNOPx(cBINOPx(expr)->op_first)->op_first);
9549 LOGOP* const range = cLOGOPx(flip->op_first);
9550 OP* const left = range->op_first;
9551 OP* const right = OpSIBLING(left);
9552 LISTOP* listop;
9553
9554 range->op_flags &= ~OPf_KIDS;
9555 /* detach range's children */
9556 op_sibling_splice((OP*)range, NULL, -1, NULL);
9557
9558 listop = cLISTOPx(newLISTOP(OP_LIST, 0, left, right));
9559 listop->op_first->op_next = range->op_next;
9560 left->op_next = range->op_other;
9561 right->op_next = (OP*)listop;
9562 listop->op_next = listop->op_first;
9563
9564 op_free(expr);
9565 expr = (OP*)(listop);
9566 op_null(expr);
9567 iterflags |= OPf_STACKED;
9568 }
9569 else {
9570 expr = op_lvalue(op_force_list(expr), OP_GREPSTART);
9571 }
9572
9573 loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
9574 op_append_elem(OP_LIST, list(expr),
9575 scalar(sv)));
9576 assert(!loop->op_next);
9577 /* for my $x () sets OPpLVAL_INTRO;
9578 * for our $x () sets OPpOUR_INTRO */
9579 loop->op_private = (U8)iterpflags;
9580
9581 /* upgrade loop from a LISTOP to a LOOPOP;
9582 * keep it in-place if there's space */
9583 if (loop->op_slabbed
9584 && OpSLOT(loop)->opslot_size
9585 < SIZE_TO_PSIZE(sizeof(LOOP) + OPSLOT_HEADER))
9586 {
9587 /* no space; allocate new op */
9588 LOOP *tmp;
9589 NewOp(1234,tmp,1,LOOP);
9590 Copy(loop,tmp,1,LISTOP);
9591 assert(loop->op_last->op_sibparent == (OP*)loop);
9592 OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
9593 S_op_destroy(aTHX_ (OP*)loop);
9594 loop = tmp;
9595 }
9596 else if (!loop->op_slabbed)
9597 {
9598 /* loop was malloc()ed */
9599 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
9600 OpLASTSIB_set(loop->op_last, (OP*)loop);
9601 }
9602 loop->op_targ = padoff;
9603 if (parens)
9604 /* hint to deparser that this: for my (...) ... */
9605 loop->op_flags |= OPf_PARENS;
9606 iter = newOP(OP_ITER, 0);
9607 iter->op_targ = how_many_more;
9608 return newWHILEOP(flags, 1, loop, iter, block, cont, 0);
9609 }
9610
9611 /*
9612 =for apidoc newLOOPEX
9613
9614 Constructs, checks, and returns a loop-exiting op (such as C<goto>
9615 or C<last>). C<type> is the opcode. C<label> supplies the parameter
9616 determining the target of the op; it is consumed by this function and
9617 becomes part of the constructed op tree.
9618
9619 =cut
9620 */
9621
9622 OP*
Perl_newLOOPEX(pTHX_ I32 type,OP * label)9623 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
9624 {
9625 OP *o = NULL;
9626
9627 PERL_ARGS_ASSERT_NEWLOOPEX;
9628
9629 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
9630 || type == OP_CUSTOM);
9631
9632 if (type != OP_GOTO) {
9633 /* "last()" means "last" */
9634 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
9635 o = newOP(type, OPf_SPECIAL);
9636 }
9637 }
9638 else {
9639 /* Check whether it's going to be a goto &function */
9640 if (label->op_type == OP_ENTERSUB
9641 && !(label->op_flags & OPf_STACKED))
9642 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
9643 }
9644
9645 /* Check for a constant argument */
9646 if (label->op_type == OP_CONST) {
9647 SV * const sv = cSVOPx(label)->op_sv;
9648 STRLEN l;
9649 const char *s = SvPV_const(sv,l);
9650 if (l == strlen(s)) {
9651 o = newPVOP(type,
9652 SvUTF8(cSVOPx(label)->op_sv),
9653 savesharedpv(
9654 SvPV_nolen_const(cSVOPx(label)->op_sv)));
9655 }
9656 }
9657
9658 /* If we have already created an op, we do not need the label. */
9659 if (o)
9660 op_free(label);
9661 else o = newUNOP(type, OPf_STACKED, label);
9662
9663 PL_hints |= HINT_BLOCK_SCOPE;
9664 return o;
9665 }
9666
9667 /* if the condition is a literal array or hash
9668 (or @{ ... } etc), make a reference to it.
9669 */
9670 STATIC OP *
S_ref_array_or_hash(pTHX_ OP * cond)9671 S_ref_array_or_hash(pTHX_ OP *cond)
9672 {
9673 if (cond
9674 && (cond->op_type == OP_RV2AV
9675 || cond->op_type == OP_PADAV
9676 || cond->op_type == OP_RV2HV
9677 || cond->op_type == OP_PADHV))
9678
9679 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
9680
9681 else if(cond
9682 && (cond->op_type == OP_ASLICE
9683 || cond->op_type == OP_KVASLICE
9684 || cond->op_type == OP_HSLICE
9685 || cond->op_type == OP_KVHSLICE)) {
9686
9687 /* anonlist now needs a list from this op, was previously used in
9688 * scalar context */
9689 cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
9690 cond->op_flags |= OPf_WANT_LIST;
9691
9692 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
9693 }
9694
9695 else
9696 return cond;
9697 }
9698
9699 /* These construct the optree fragments representing given()
9700 and when() blocks.
9701
9702 entergiven and enterwhen are LOGOPs; the op_other pointer
9703 points up to the associated leave op. We need this so we
9704 can put it in the context and make break/continue work.
9705 (Also, of course, pp_enterwhen will jump straight to
9706 op_other if the match fails.)
9707 */
9708
9709 STATIC OP *
S_newGIVWHENOP(pTHX_ OP * cond,OP * block,I32 enter_opcode,I32 leave_opcode,PADOFFSET entertarg)9710 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
9711 I32 enter_opcode, I32 leave_opcode,
9712 PADOFFSET entertarg)
9713 {
9714 LOGOP *enterop;
9715 OP *o;
9716
9717 PERL_ARGS_ASSERT_NEWGIVWHENOP;
9718 PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
9719
9720 enterop = alloc_LOGOP(enter_opcode, block, NULL);
9721 enterop->op_targ = 0;
9722 enterop->op_private = 0;
9723
9724 o = newUNOP(leave_opcode, 0, (OP *) enterop);
9725
9726 if (cond) {
9727 /* prepend cond if we have one */
9728 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
9729
9730 o->op_next = LINKLIST(cond);
9731 cond->op_next = (OP *) enterop;
9732 }
9733 else {
9734 /* This is a default {} block */
9735 enterop->op_flags |= OPf_SPECIAL;
9736 o ->op_flags |= OPf_SPECIAL;
9737
9738 o->op_next = (OP *) enterop;
9739 }
9740
9741 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
9742 entergiven and enterwhen both
9743 use ck_null() */
9744
9745 enterop->op_next = LINKLIST(block);
9746 block->op_next = enterop->op_other = o;
9747
9748 return o;
9749 }
9750
9751
9752 /* For the purposes of 'when(implied_smartmatch)'
9753 * versus 'when(boolean_expression)',
9754 * does this look like a boolean operation? For these purposes
9755 a boolean operation is:
9756 - a subroutine call [*]
9757 - a logical connective
9758 - a comparison operator
9759 - a filetest operator, with the exception of -s -M -A -C
9760 - defined(), exists() or eof()
9761 - /$re/ or $foo =~ /$re/
9762
9763 [*] possibly surprising
9764 */
9765 STATIC bool
S_looks_like_bool(pTHX_ const OP * o)9766 S_looks_like_bool(pTHX_ const OP *o)
9767 {
9768 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
9769
9770 switch(o->op_type) {
9771 case OP_OR:
9772 case OP_DOR:
9773 return looks_like_bool(cLOGOPo->op_first);
9774
9775 case OP_AND:
9776 {
9777 OP* sibl = OpSIBLING(cLOGOPo->op_first);
9778 ASSUME(sibl);
9779 return (
9780 looks_like_bool(cLOGOPo->op_first)
9781 && looks_like_bool(sibl));
9782 }
9783
9784 case OP_NULL:
9785 case OP_SCALAR:
9786 return (
9787 o->op_flags & OPf_KIDS
9788 && looks_like_bool(cUNOPo->op_first));
9789
9790 case OP_ENTERSUB:
9791
9792 case OP_NOT: case OP_XOR:
9793
9794 case OP_EQ: case OP_NE: case OP_LT:
9795 case OP_GT: case OP_LE: case OP_GE:
9796
9797 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
9798 case OP_I_GT: case OP_I_LE: case OP_I_GE:
9799
9800 case OP_SEQ: case OP_SNE: case OP_SLT:
9801 case OP_SGT: case OP_SLE: case OP_SGE:
9802
9803 case OP_SMARTMATCH:
9804
9805 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
9806 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
9807 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
9808 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
9809 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
9810 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
9811 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
9812 case OP_FTTEXT: case OP_FTBINARY:
9813
9814 case OP_DEFINED: case OP_EXISTS:
9815 case OP_MATCH: case OP_EOF:
9816
9817 case OP_FLOP:
9818
9819 return TRUE;
9820
9821 case OP_INDEX:
9822 case OP_RINDEX:
9823 /* optimised-away (index() != -1) or similar comparison */
9824 if (o->op_private & OPpTRUEBOOL)
9825 return TRUE;
9826 return FALSE;
9827
9828 case OP_CONST:
9829 /* Detect comparisons that have been optimized away */
9830 if (cSVOPo->op_sv == &PL_sv_yes
9831 || cSVOPo->op_sv == &PL_sv_no)
9832
9833 return TRUE;
9834 else
9835 return FALSE;
9836 /* FALLTHROUGH */
9837 default:
9838 return FALSE;
9839 }
9840 }
9841
9842
9843 /*
9844 =for apidoc newGIVENOP
9845
9846 Constructs, checks, and returns an op tree expressing a C<given> block.
9847 C<cond> supplies the expression to whose value C<$_> will be locally
9848 aliased, and C<block> supplies the body of the C<given> construct; they
9849 are consumed by this function and become part of the constructed op tree.
9850 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
9851
9852 =cut
9853 */
9854
9855 OP *
Perl_newGIVENOP(pTHX_ OP * cond,OP * block,PADOFFSET defsv_off)9856 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
9857 {
9858 PERL_ARGS_ASSERT_NEWGIVENOP;
9859 PERL_UNUSED_ARG(defsv_off);
9860
9861 assert(!defsv_off);
9862 return newGIVWHENOP(
9863 ref_array_or_hash(cond),
9864 block,
9865 OP_ENTERGIVEN, OP_LEAVEGIVEN,
9866 0);
9867 }
9868
9869 /*
9870 =for apidoc newWHENOP
9871
9872 Constructs, checks, and returns an op tree expressing a C<when> block.
9873 C<cond> supplies the test expression, and C<block> supplies the block
9874 that will be executed if the test evaluates to true; they are consumed
9875 by this function and become part of the constructed op tree. C<cond>
9876 will be interpreted DWIMically, often as a comparison against C<$_>,
9877 and may be null to generate a C<default> block.
9878
9879 =cut
9880 */
9881
9882 OP *
Perl_newWHENOP(pTHX_ OP * cond,OP * block)9883 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
9884 {
9885 const bool cond_llb = (!cond || looks_like_bool(cond));
9886 OP *cond_op;
9887
9888 PERL_ARGS_ASSERT_NEWWHENOP;
9889
9890 if (cond_llb)
9891 cond_op = cond;
9892 else {
9893 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
9894 newDEFSVOP(),
9895 scalar(ref_array_or_hash(cond)));
9896 }
9897
9898 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
9899 }
9900
9901 /*
9902 =for apidoc newDEFEROP
9903
9904 Constructs and returns a deferred-block statement that implements the
9905 C<defer> semantics. The C<block> optree is consumed by this function and
9906 becomes part of the returned optree.
9907
9908 The C<flags> argument carries additional flags to set on the returned op,
9909 including the C<op_private> field.
9910
9911 =cut
9912 */
9913
9914 OP *
Perl_newDEFEROP(pTHX_ I32 flags,OP * block)9915 Perl_newDEFEROP(pTHX_ I32 flags, OP *block)
9916 {
9917 OP *o, *start, *blockfirst;
9918
9919 PERL_ARGS_ASSERT_NEWDEFEROP;
9920
9921 forbid_outofblock_ops(block,
9922 (flags & (OPpDEFER_FINALLY << 8)) ? "a \"finally\" block" : "a \"defer\" block");
9923
9924 start = LINKLIST(block);
9925
9926 /* Hide the block inside an OP_NULL with no execution */
9927 block = newUNOP(OP_NULL, 0, block);
9928 block->op_next = block;
9929
9930 o = (OP *)alloc_LOGOP(OP_PUSHDEFER, block, start);
9931 o->op_flags |= OPf_WANT_VOID | (U8)(flags);
9932 o->op_private = (U8)(flags >> 8);
9933
9934 /* Terminate the block */
9935 blockfirst = cUNOPx(block)->op_first;
9936 assert(blockfirst->op_type == OP_SCOPE || blockfirst->op_type == OP_LEAVE);
9937 blockfirst->op_next = NULL;
9938
9939 return o;
9940 }
9941
9942 /*
9943 =for apidoc op_wrap_finally
9944
9945 Wraps the given C<block> optree fragment in its own scoped block, arranging
9946 for the C<finally> optree fragment to be invoked when leaving that block for
9947 any reason. Both optree fragments are consumed and the combined result is
9948 returned.
9949
9950 =cut
9951 */
9952
9953 OP *
Perl_op_wrap_finally(pTHX_ OP * block,OP * finally)9954 Perl_op_wrap_finally(pTHX_ OP *block, OP *finally)
9955 {
9956 PERL_ARGS_ASSERT_OP_WRAP_FINALLY;
9957
9958 /* TODO: If block is already an ENTER/LEAVE-wrapped line sequence we can
9959 * just splice the DEFEROP in at the top, for efficiency.
9960 */
9961
9962 OP *o = newLISTOP(OP_LINESEQ, 0, newDEFEROP((OPpDEFER_FINALLY << 8), finally), block);
9963 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
9964 OpTYPE_set(o, OP_LEAVE);
9965
9966 return o;
9967 }
9968
9969 /* must not conflict with SVf_UTF8 */
9970 #define CV_CKPROTO_CURSTASH 0x1
9971
9972 void
Perl_cv_ckproto_len_flags(pTHX_ const CV * cv,const GV * gv,const char * p,const STRLEN len,const U32 flags)9973 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
9974 const STRLEN len, const U32 flags)
9975 {
9976 SV *name = NULL, *msg;
9977 const char * cvp = SvROK(cv)
9978 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
9979 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
9980 : ""
9981 : CvPROTO(cv);
9982 STRLEN clen = CvPROTOLEN(cv), plen = len;
9983
9984 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
9985
9986 if (p == NULL && cvp == NULL)
9987 return;
9988
9989 if (!ckWARN_d(WARN_PROTOTYPE))
9990 return;
9991
9992 if (p && cvp) {
9993 p = S_strip_spaces(aTHX_ p, &plen);
9994 cvp = S_strip_spaces(aTHX_ cvp, &clen);
9995 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
9996 if (plen == clen && memEQ(cvp, p, plen))
9997 return;
9998 } else {
9999 if (flags & SVf_UTF8) {
10000 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
10001 return;
10002 }
10003 else {
10004 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
10005 return;
10006 }
10007 }
10008 }
10009
10010 msg = sv_newmortal();
10011
10012 if (gv)
10013 {
10014 if (isGV(gv))
10015 gv_efullname3(name = sv_newmortal(), gv, NULL);
10016 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
10017 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
10018 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
10019 name = newSVhek_mortal(HvNAME_HEK(PL_curstash));
10020 sv_catpvs(name, "::");
10021 if (SvROK(gv)) {
10022 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
10023 assert (CvNAMED(SvRV_const(gv)));
10024 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
10025 }
10026 else sv_catsv(name, (SV *)gv);
10027 }
10028 else name = (SV *)gv;
10029 }
10030 sv_setpvs(msg, "Prototype mismatch:");
10031 if (name)
10032 Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
10033 if (cvp)
10034 Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
10035 UTF8fARG(SvUTF8(cv),clen,cvp)
10036 );
10037 else
10038 sv_catpvs(msg, ": none");
10039 sv_catpvs(msg, " vs ");
10040 if (p)
10041 Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
10042 else
10043 sv_catpvs(msg, "none");
10044 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
10045 }
10046
10047 static void const_sv_xsub(pTHX_ CV* cv);
10048 static void const_av_xsub(pTHX_ CV* cv);
10049
10050 /*
10051
10052 =for apidoc_section $optree_manipulation
10053
10054 =for apidoc cv_const_sv
10055
10056 If C<cv> is a constant sub eligible for inlining, returns the constant
10057 value returned by the sub. Otherwise, returns C<NULL>.
10058
10059 Constant subs can be created with C<newCONSTSUB> or as described in
10060 L<perlsub/"Constant Functions">.
10061
10062 =cut
10063 */
10064 SV *
Perl_cv_const_sv(const CV * const cv)10065 Perl_cv_const_sv(const CV *const cv)
10066 {
10067 SV *sv;
10068 if (!cv)
10069 return NULL;
10070 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
10071 return NULL;
10072 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
10073 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
10074 return sv;
10075 }
10076
10077 SV *
Perl_cv_const_sv_or_av(const CV * const cv)10078 Perl_cv_const_sv_or_av(const CV * const cv)
10079 {
10080 if (!cv)
10081 return NULL;
10082 if (SvROK(cv)) return SvRV((SV *)cv);
10083 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
10084 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
10085 }
10086
10087 /* op_const_sv: examine an optree to determine whether it's in-lineable.
10088 * Can be called in 2 ways:
10089 *
10090 * !allow_lex
10091 * look for a single OP_CONST with attached value: return the value
10092 *
10093 * allow_lex && !CvCONST(cv);
10094 *
10095 * examine the clone prototype, and if contains only a single
10096 * OP_CONST, return the value; or if it contains a single PADSV ref-
10097 * erencing an outer lexical, turn on CvCONST to indicate the CV is
10098 * a candidate for "constizing" at clone time, and return NULL.
10099 */
10100
10101 static SV *
S_op_const_sv(pTHX_ const OP * o,CV * cv,bool allow_lex)10102 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
10103 {
10104 SV *sv = NULL;
10105 bool padsv = FALSE;
10106
10107 assert(o);
10108 assert(cv);
10109
10110 for (; o; o = o->op_next) {
10111 const OPCODE type = o->op_type;
10112
10113 if (type == OP_NEXTSTATE || type == OP_LINESEQ
10114 || type == OP_NULL
10115 || type == OP_PUSHMARK)
10116 continue;
10117 if (type == OP_DBSTATE)
10118 continue;
10119 if (type == OP_LEAVESUB)
10120 break;
10121 if (sv)
10122 return NULL;
10123 if (type == OP_CONST && cSVOPo->op_sv)
10124 sv = cSVOPo->op_sv;
10125 else if (type == OP_UNDEF && !o->op_private) {
10126 sv = newSV_type(SVt_NULL);
10127 SAVEFREESV(sv);
10128 }
10129 else if (allow_lex && type == OP_PADSV) {
10130 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEf_OUTER)
10131 {
10132 sv = &PL_sv_undef; /* an arbitrary non-null value */
10133 padsv = TRUE;
10134 }
10135 else
10136 return NULL;
10137 }
10138 else {
10139 return NULL;
10140 }
10141 }
10142 if (padsv) {
10143 CvCONST_on(cv);
10144 return NULL;
10145 }
10146 return sv;
10147 }
10148
10149 static void
S_already_defined(pTHX_ CV * const cv,OP * const block,OP * const o,PADNAME * const name,SV ** const const_svp)10150 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
10151 PADNAME * const name, SV ** const const_svp)
10152 {
10153 assert (cv);
10154 assert (o || name);
10155 assert (const_svp);
10156 if (!block) {
10157 if (CvFLAGS(PL_compcv)) {
10158 /* might have had built-in attrs applied */
10159 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
10160 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
10161 && ckWARN(WARN_MISC))
10162 {
10163 /* protect against fatal warnings leaking compcv */
10164 SAVEFREESV(PL_compcv);
10165 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
10166 SvREFCNT_inc_simple_void_NN(PL_compcv);
10167 }
10168 CvFLAGS(cv) |=
10169 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
10170 & ~(CVf_LVALUE * pureperl));
10171 }
10172 return;
10173 }
10174
10175 /* redundant check for speed: */
10176 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
10177 const line_t oldline = CopLINE(PL_curcop);
10178 SV *namesv = o
10179 ? cSVOPo->op_sv
10180 : newSVpvn_flags( PadnamePV(name)+1,PadnameLEN(name)-1,
10181 (PadnameUTF8(name)) ? SVf_UTF8|SVs_TEMP : SVs_TEMP
10182 );
10183 if (PL_parser && PL_parser->copline != NOLINE)
10184 /* This ensures that warnings are reported at the first
10185 line of a redefinition, not the last. */
10186 CopLINE_set(PL_curcop, PL_parser->copline);
10187 /* protect against fatal warnings leaking compcv */
10188 SAVEFREESV(PL_compcv);
10189 report_redefined_cv(namesv, cv, const_svp);
10190 SvREFCNT_inc_simple_void_NN(PL_compcv);
10191 CopLINE_set(PL_curcop, oldline);
10192 }
10193 SAVEFREESV(cv);
10194 return;
10195 }
10196
10197 /*
10198 =for apidoc newMYSUB
10199
10200 Construct a Perl lexical subroutine, also performing some surrounding jobs, and
10201 returning a pointer to the constructed subroutine.
10202
10203 Similar in action to L<perlintern/C<newATTRSUB_x>>.
10204
10205 =cut
10206 */
10207
10208 CV *
Perl_newMYSUB(pTHX_ I32 floor,OP * o,OP * proto,OP * attrs,OP * block)10209 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
10210 {
10211 CV **spot;
10212 SV **svspot;
10213 const char *ps;
10214 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
10215 U32 ps_utf8 = 0;
10216 CV *cv = NULL;
10217 CV *compcv = PL_compcv;
10218 SV *const_sv;
10219 PADNAME *name;
10220 PADOFFSET pax = o->op_targ;
10221 CV *outcv = CvOUTSIDE(PL_compcv);
10222 CV *clonee = NULL;
10223 HEK *hek = NULL;
10224 bool reusable = FALSE;
10225 OP *start = NULL;
10226 #ifdef PERL_DEBUG_READONLY_OPS
10227 OPSLAB *slab = NULL;
10228 #endif
10229
10230 PERL_ARGS_ASSERT_NEWMYSUB;
10231
10232 PL_hints |= HINT_BLOCK_SCOPE;
10233
10234 /* Find the pad slot for storing the new sub.
10235 We cannot use PL_comppad, as it is the pad owned by the new sub. We
10236 need to look in CvOUTSIDE and find the pad belonging to the enclos-
10237 ing sub. And then we need to dig deeper if this is a lexical from
10238 outside, as in:
10239 my sub foo; sub { sub foo { } }
10240 */
10241 redo:
10242 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
10243 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
10244 pax = PARENT_PAD_INDEX(name);
10245 outcv = CvOUTSIDE(outcv);
10246 assert(outcv);
10247 goto redo;
10248 }
10249 svspot =
10250 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
10251 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
10252 spot = (CV **)svspot;
10253
10254 if (!(PL_parser && PL_parser->error_count))
10255 move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
10256
10257 if (proto) {
10258 assert(proto->op_type == OP_CONST);
10259 ps = SvPV_const(cSVOPx(proto)->op_sv, ps_len);
10260 ps_utf8 = SvUTF8(cSVOPx(proto)->op_sv);
10261 }
10262 else
10263 ps = NULL;
10264
10265 if (proto)
10266 SAVEFREEOP(proto);
10267 if (attrs)
10268 SAVEFREEOP(attrs);
10269
10270 if (PL_parser && PL_parser->error_count) {
10271 op_free(block);
10272 SvREFCNT_dec(PL_compcv);
10273 PL_compcv = 0;
10274 goto done;
10275 }
10276
10277 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
10278 cv = *spot;
10279 svspot = (SV **)(spot = &clonee);
10280 }
10281 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
10282 cv = *spot;
10283 else {
10284 assert (SvTYPE(*spot) == SVt_PVCV);
10285 if (CvNAMED(*spot))
10286 hek = CvNAME_HEK(*spot);
10287 else {
10288 U32 hash;
10289 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
10290 CvNAME_HEK_set(*spot, hek =
10291 share_hek(
10292 PadnamePV(name)+1,
10293 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
10294 hash
10295 )
10296 );
10297 CvLEXICAL_on(*spot);
10298 }
10299 cv = PadnamePROTOCV(name);
10300 svspot = (SV **)(spot = &PadnamePROTOCV(name));
10301 }
10302
10303 if (block) {
10304 /* This makes sub {}; work as expected. */
10305 if (block->op_type == OP_STUB) {
10306 const line_t l = PL_parser->copline;
10307 op_free(block);
10308 block = newSTATEOP(0, NULL, 0);
10309 PL_parser->copline = l;
10310 }
10311 block = CvLVALUE(compcv)
10312 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
10313 ? newUNOP(OP_LEAVESUBLV, 0,
10314 op_lvalue(voidnonfinal(block), OP_LEAVESUBLV))
10315 : newUNOP(OP_LEAVESUB, 0, voidnonfinal(block));
10316 start = LINKLIST(block);
10317 block->op_next = 0;
10318 if (ps && !*ps && !attrs && !CvLVALUE(compcv))
10319 const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
10320 else
10321 const_sv = NULL;
10322 }
10323 else
10324 const_sv = NULL;
10325
10326 if (cv) {
10327 const bool exists = CvROOT(cv) || CvXSUB(cv);
10328
10329 /* if the subroutine doesn't exist and wasn't pre-declared
10330 * with a prototype, assume it will be AUTOLOADed,
10331 * skipping the prototype check
10332 */
10333 if (exists || SvPOK(cv))
10334 cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
10335 ps_utf8);
10336 /* already defined? */
10337 if (exists) {
10338 S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
10339 if (block)
10340 cv = NULL;
10341 else {
10342 if (attrs)
10343 goto attrs;
10344 /* just a "sub foo;" when &foo is already defined */
10345 SAVEFREESV(compcv);
10346 goto done;
10347 }
10348 }
10349 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
10350 cv = NULL;
10351 reusable = TRUE;
10352 }
10353 }
10354
10355 if (const_sv) {
10356 SvREFCNT_inc_simple_void_NN(const_sv);
10357 SvFLAGS(const_sv) |= SVs_PADTMP;
10358 if (cv) {
10359 assert(!CvROOT(cv) && !CvCONST(cv));
10360 cv_forget_slab(cv);
10361 }
10362 else {
10363 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10364 CvFILE_set_from_cop(cv, PL_curcop);
10365 CvSTASH_set(cv, PL_curstash);
10366 *spot = cv;
10367 }
10368 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
10369 CvXSUBANY(cv).any_ptr = const_sv;
10370 CvXSUB(cv) = const_sv_xsub;
10371 CvCONST_on(cv);
10372 CvISXSUB_on(cv);
10373 PoisonPADLIST(cv);
10374 CvFLAGS(cv) |= CvNOWARN_AMBIGUOUS(compcv);
10375 op_free(block);
10376 SvREFCNT_dec(compcv);
10377 PL_compcv = NULL;
10378 goto setname;
10379 }
10380
10381 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
10382 determine whether this sub definition is in the same scope as its
10383 declaration. If this sub definition is inside an inner named pack-
10384 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
10385 the package sub. So check PadnameOUTER(name) too.
10386 */
10387 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
10388 assert(!CvWEAKOUTSIDE(compcv));
10389 SvREFCNT_dec(CvOUTSIDE(compcv));
10390 CvWEAKOUTSIDE_on(compcv);
10391 }
10392 /* XXX else do we have a circular reference? */
10393
10394 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
10395 /* transfer PL_compcv to cv */
10396 if (block) {
10397 bool free_file = CvFILE(cv) && CvDYNFILE(cv);
10398 cv_flags_t preserved_flags =
10399 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
10400 PADLIST *const temp_padl = CvPADLIST(cv);
10401 CV *const temp_cv = CvOUTSIDE(cv);
10402 const cv_flags_t other_flags =
10403 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
10404 OP * const cvstart = CvSTART(cv);
10405
10406 SvPOK_off(cv);
10407 CvFLAGS(cv) =
10408 CvFLAGS(compcv) | preserved_flags;
10409 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
10410 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
10411 CvPADLIST_set(cv, CvPADLIST(compcv));
10412 CvOUTSIDE(compcv) = temp_cv;
10413 CvPADLIST_set(compcv, temp_padl);
10414 CvSTART(cv) = CvSTART(compcv);
10415 CvSTART(compcv) = cvstart;
10416 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10417 CvFLAGS(compcv) |= other_flags;
10418
10419 if (free_file) {
10420 Safefree(CvFILE(cv));
10421 CvFILE(cv) = NULL;
10422 }
10423
10424 /* inner references to compcv must be fixed up ... */
10425 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
10426 if (PERLDB_INTER)/* Advice debugger on the new sub. */
10427 ++PL_sub_generation;
10428 }
10429 else {
10430 /* Might have had built-in attributes applied -- propagate them. */
10431 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
10432 }
10433 /* ... before we throw it away */
10434 SvREFCNT_dec(compcv);
10435 PL_compcv = compcv = cv;
10436 }
10437 else {
10438 cv = compcv;
10439 *spot = cv;
10440 }
10441
10442 setname:
10443 CvLEXICAL_on(cv);
10444 if (!CvNAME_HEK(cv)) {
10445 if (hek) (void)share_hek_hek(hek);
10446 else {
10447 U32 hash;
10448 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
10449 hek = share_hek(PadnamePV(name)+1,
10450 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
10451 hash);
10452 }
10453 CvNAME_HEK_set(cv, hek);
10454 }
10455
10456 if (const_sv)
10457 goto clone;
10458
10459 if (CvFILE(cv) && CvDYNFILE(cv))
10460 Safefree(CvFILE(cv));
10461 CvFILE_set_from_cop(cv, PL_curcop);
10462 CvSTASH_set(cv, PL_curstash);
10463
10464 if (ps) {
10465 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
10466 if (ps_utf8)
10467 SvUTF8_on(MUTABLE_SV(cv));
10468 }
10469
10470 if (block) {
10471 /* If we assign an optree to a PVCV, then we've defined a
10472 * subroutine that the debugger could be able to set a breakpoint
10473 * in, so signal to pp_entereval that it should not throw away any
10474 * saved lines at scope exit. */
10475
10476 PL_breakable_sub_gen++;
10477 CvROOT(cv) = block;
10478 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
10479 itself has a refcount. */
10480 CvSLABBED_off(cv);
10481 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
10482 #ifdef PERL_DEBUG_READONLY_OPS
10483 slab = (OPSLAB *)CvSTART(cv);
10484 #endif
10485 S_process_optree(aTHX_ cv, block, start);
10486 }
10487
10488 attrs:
10489 if (attrs) {
10490 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
10491 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
10492 }
10493
10494 if (block) {
10495 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
10496 SV * const tmpstr = sv_newmortal();
10497 GV * const db_postponed = gv_fetchpvs("DB::postponed",
10498 GV_ADDMULTI, SVt_PVHV);
10499 HV *hv;
10500 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" LINE_Tf "-%" LINE_Tf,
10501 CopFILE(PL_curcop),
10502 (line_t)PL_subline,
10503 CopLINE(PL_curcop));
10504 if (HvNAME_HEK(PL_curstash)) {
10505 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
10506 sv_catpvs(tmpstr, "::");
10507 }
10508 else
10509 sv_setpvs(tmpstr, "__ANON__::");
10510
10511 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
10512 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
10513 (void)hv_store_ent(GvHV(PL_DBsub), tmpstr, sv, 0);
10514 hv = GvHVn(db_postponed);
10515 if (HvTOTALKEYS(hv) > 0 && hv_exists_ent(hv, tmpstr, 0)) {
10516 CV * const pcv = GvCV(db_postponed);
10517 if (pcv) {
10518 PUSHMARK(PL_stack_sp);
10519 #ifdef PERL_RC_STACK
10520 assert(rpp_stack_is_rc());
10521 #endif
10522 rpp_xpush_1(tmpstr);
10523 call_sv(MUTABLE_SV(pcv), G_DISCARD);
10524 }
10525 }
10526 }
10527 }
10528
10529 clone:
10530 if (clonee) {
10531 assert(CvDEPTH(outcv));
10532 spot = (CV **)
10533 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
10534 if (reusable)
10535 cv_clone_into(clonee, *spot);
10536 else *spot = cv_clone(clonee);
10537 SvREFCNT_dec_NN(clonee);
10538 cv = *spot;
10539 }
10540
10541 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
10542 PADOFFSET depth = CvDEPTH(outcv);
10543 while (--depth) {
10544 SV *oldcv;
10545 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
10546 oldcv = *svspot;
10547 *svspot = SvREFCNT_inc_simple_NN(cv);
10548 SvREFCNT_dec(oldcv);
10549 }
10550 }
10551
10552 done:
10553 if (PL_parser)
10554 PL_parser->copline = NOLINE;
10555 LEAVE_SCOPE(floor);
10556 #ifdef PERL_DEBUG_READONLY_OPS
10557 if (slab)
10558 Slab_to_ro(slab);
10559 #endif
10560 op_free(o);
10561 return cv;
10562 }
10563
10564 /*
10565 =for apidoc newATTRSUB_x
10566
10567 Construct a Perl subroutine, also performing some surrounding jobs.
10568
10569 This function is expected to be called in a Perl compilation context,
10570 and some aspects of the subroutine are taken from global variables
10571 associated with compilation. In particular, C<PL_compcv> represents
10572 the subroutine that is currently being compiled. It must be non-null
10573 when this function is called, and some aspects of the subroutine being
10574 constructed are taken from it. The constructed subroutine may actually
10575 be a reuse of the C<PL_compcv> object, but will not necessarily be so.
10576
10577 If C<block> is null then the subroutine will have no body, and for the
10578 time being it will be an error to call it. This represents a forward
10579 subroutine declaration such as S<C<sub foo ($$);>>. If C<block> is
10580 non-null then it provides the Perl code of the subroutine body, which
10581 will be executed when the subroutine is called. This body includes
10582 any argument unwrapping code resulting from a subroutine signature or
10583 similar. The pad use of the code must correspond to the pad attached
10584 to C<PL_compcv>. The code is not expected to include a C<leavesub> or
10585 C<leavesublv> op; this function will add such an op. C<block> is consumed
10586 by this function and will become part of the constructed subroutine.
10587
10588 C<proto> specifies the subroutine's prototype, unless one is supplied
10589 as an attribute (see below). If C<proto> is null, then the subroutine
10590 will not have a prototype. If C<proto> is non-null, it must point to a
10591 C<const> op whose value is a string, and the subroutine will have that
10592 string as its prototype. If a prototype is supplied as an attribute, the
10593 attribute takes precedence over C<proto>, but in that case C<proto> should
10594 preferably be null. In any case, C<proto> is consumed by this function.
10595
10596 C<attrs> supplies attributes to be applied the subroutine. A handful of
10597 attributes take effect by built-in means, being applied to C<PL_compcv>
10598 immediately when seen. Other attributes are collected up and attached
10599 to the subroutine by this route. C<attrs> may be null to supply no
10600 attributes, or point to a C<const> op for a single attribute, or point
10601 to a C<list> op whose children apart from the C<pushmark> are C<const>
10602 ops for one or more attributes. Each C<const> op must be a string,
10603 giving the attribute name optionally followed by parenthesised arguments,
10604 in the manner in which attributes appear in Perl source. The attributes
10605 will be applied to the sub by this function. C<attrs> is consumed by
10606 this function.
10607
10608 If C<o_is_gv> is false and C<o> is null, then the subroutine will
10609 be anonymous. If C<o_is_gv> is false and C<o> is non-null, then C<o>
10610 must point to a C<const> OP, which will be consumed by this function,
10611 and its string value supplies a name for the subroutine. The name may
10612 be qualified or unqualified, and if it is unqualified then a default
10613 stash will be selected in some manner. If C<o_is_gv> is true, then C<o>
10614 doesn't point to an C<OP> at all, but is instead a cast pointer to a C<GV>
10615 by which the subroutine will be named.
10616
10617 If there is already a subroutine of the specified name, then the new
10618 sub will either replace the existing one in the glob or be merged with
10619 the existing one. A warning may be generated about redefinition.
10620
10621 If the subroutine has one of a few special names, such as C<BEGIN> or
10622 C<END>, then it will be claimed by the appropriate queue for automatic
10623 running of phase-related subroutines. In this case the relevant glob will
10624 be left not containing any subroutine, even if it did contain one before.
10625 In the case of C<BEGIN>, the subroutine will be executed and the reference
10626 to it disposed of before this function returns.
10627
10628 The function returns a pointer to the constructed subroutine. If the sub
10629 is anonymous then ownership of one counted reference to the subroutine
10630 is transferred to the caller. If the sub is named then the caller does
10631 not get ownership of a reference. In most such cases, where the sub
10632 has a non-phase name, the sub will be alive at the point it is returned
10633 by virtue of being contained in the glob that names it. A phase-named
10634 subroutine will usually be alive by virtue of the reference owned by the
10635 phase's automatic run queue. But a C<BEGIN> subroutine, having already
10636 been executed, will quite likely have been destroyed already by the
10637 time this function returns, making it erroneous for the caller to make
10638 any use of the returned pointer. It is the caller's responsibility to
10639 ensure that it knows which of these situations applies.
10640
10641 =for apidoc newATTRSUB
10642 Construct a Perl subroutine, also performing some surrounding jobs,
10643 returning a pointer to the constructed subroutine.
10644
10645 This is the same as L<perlintern/C<newATTRSUB_x>> with its C<o_is_gv> parameter
10646 set to FALSE. This means that if C<o> is null, the new sub will be anonymous;
10647 otherwise the name will be derived from C<o> in the way described (as with all
10648 other details) in L<perlintern/C<newATTRSUB_x>>.
10649
10650 =for apidoc newSUB
10651 Construct a Perl subroutine without attributes, and also performing some
10652 surrounding jobs, returning a pointer to the constructed subroutine.
10653
10654 This is the same as L<perlintern/C<newATTRSUB_x>> with its C<o_is_gv> parameter
10655 set to FALSE, and its C<attrs> parameter to NULL. This means that if C<o> is
10656 null, the new sub will be anonymous; otherwise the name will be derived from
10657 C<o> in the way described (as with all other details) in
10658 L<perlintern/C<newATTRSUB_x>>.
10659
10660 =cut
10661 */
10662
10663 /* _x = extended */
10664 CV *
Perl_newATTRSUB_x(pTHX_ I32 floor,OP * o,OP * proto,OP * attrs,OP * block,bool o_is_gv)10665 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
10666 OP *block, bool o_is_gv)
10667 {
10668 GV *gv;
10669 const char *ps;
10670 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
10671 U32 ps_utf8 = 0;
10672 CV *cv = NULL; /* the previous CV with this name, if any */
10673 SV *const_sv;
10674 const bool ec = PL_parser && PL_parser->error_count;
10675 /* If the subroutine has no body, no attributes, and no builtin attributes
10676 then it's just a sub declaration, and we may be able to get away with
10677 storing with a placeholder scalar in the symbol table, rather than a
10678 full CV. If anything is present then it will take a full CV to
10679 store it. */
10680 const I32 gv_fetch_flags
10681 = ec ? GV_NOADD_NOINIT :
10682 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
10683 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
10684 STRLEN namlen = 0;
10685 const char * const name =
10686 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
10687 bool has_name;
10688 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
10689 bool evanescent = FALSE;
10690 bool isBEGIN = FALSE;
10691 OP *start = NULL;
10692 #ifdef PERL_DEBUG_READONLY_OPS
10693 OPSLAB *slab = NULL;
10694 #endif
10695
10696 if (o_is_gv) {
10697 gv = (GV*)o;
10698 o = NULL;
10699 has_name = TRUE;
10700 } else if (name) {
10701 /* Try to optimise and avoid creating a GV. Instead, the CV’s name
10702 hek and CvSTASH pointer together can imply the GV. If the name
10703 contains a package name, then GvSTASH(CvGV(cv)) may differ from
10704 CvSTASH, so forego the optimisation if we find any.
10705 Also, we may be called from load_module at run time, so
10706 PL_curstash (which sets CvSTASH) may not point to the stash the
10707 sub is stored in. */
10708 /* XXX This optimization is currently disabled for packages other
10709 than main, since there was too much CPAN breakage. */
10710 const I32 flags =
10711 ec ? GV_NOADD_NOINIT
10712 : (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
10713 || PL_curstash != PL_defstash
10714 || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
10715 ? gv_fetch_flags
10716 : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
10717 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
10718 has_name = TRUE;
10719 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
10720 SV * const sv = sv_newmortal();
10721 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" LINE_Tf "]",
10722 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
10723 CopFILE(PL_curcop), CopLINE(PL_curcop));
10724 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
10725 has_name = TRUE;
10726 } else if (PL_curstash) {
10727 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
10728 has_name = FALSE;
10729 } else {
10730 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
10731 has_name = FALSE;
10732 }
10733
10734 if (!ec) {
10735 if (isGV(gv)) {
10736 move_proto_attr(&proto, &attrs, gv, 0);
10737 } else {
10738 assert(cSVOPo);
10739 move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
10740 }
10741 }
10742
10743 if (o)
10744 SAVEFREEOP(o);
10745 if (proto)
10746 SAVEFREEOP(proto);
10747 if (attrs)
10748 SAVEFREEOP(attrs);
10749
10750 /* we need this in two places later on, so set it up here */
10751 if (name && block) {
10752 const char *s = (char *) my_memrchr(name, ':', namlen);
10753 s = s ? s+1 : name;
10754 isBEGIN = strEQ(s,"BEGIN");
10755 }
10756
10757 if (isBEGIN) {
10758 /* Make sure that we do not have any prototypes or
10759 * attributes associated with this BEGIN block, as the block
10760 * is already done and dusted, and we will assert or worse
10761 * if we try to attach the prototype to the now essentially
10762 * nonexistent sub. */
10763 if (proto)
10764 /* diag_listed_as: %s on BEGIN block ignored */
10765 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Prototype on BEGIN block ignored");
10766 if (attrs)
10767 /* diag_listed_as: %s on BEGIN block ignored */
10768 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Attribute on BEGIN block ignored");
10769 proto = NULL;
10770 attrs = NULL;
10771 }
10772
10773 if (proto) {
10774 assert(proto->op_type == OP_CONST);
10775 ps = SvPV_const(cSVOPx(proto)->op_sv, ps_len);
10776 ps_utf8 = SvUTF8(cSVOPx(proto)->op_sv);
10777 }
10778 else
10779 ps = NULL;
10780
10781 if (ec) {
10782 op_free(block);
10783
10784 if (name)
10785 SvREFCNT_dec(PL_compcv);
10786 else
10787 cv = PL_compcv;
10788
10789 PL_compcv = 0;
10790 if (isBEGIN) {
10791 if (PL_in_eval & EVAL_KEEPERR)
10792 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
10793 else {
10794 SV * const errsv = ERRSV;
10795 /* force display of errors found but not reported */
10796 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
10797 Perl_croak_nocontext("%" SVf, SVfARG(errsv));
10798 }
10799 }
10800 goto done;
10801 }
10802
10803 if (!block && SvTYPE(gv) != SVt_PVGV) {
10804 /* If we are not defining a new sub and the existing one is not a
10805 full GV + CV... */
10806 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
10807 /* We are applying attributes to an existing sub, so we need it
10808 upgraded if it is a constant. */
10809 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
10810 gv_init_pvn(gv, PL_curstash, name, namlen,
10811 SVf_UTF8 * name_is_utf8);
10812 }
10813 else { /* Maybe prototype now, and had at maximum
10814 a prototype or const/sub ref before. */
10815 if (SvTYPE(gv) > SVt_NULL) {
10816 cv_ckproto_len_flags((const CV *)gv,
10817 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10818 ps_len, ps_utf8);
10819 }
10820
10821 if (!SvROK(gv)) {
10822 if (ps) {
10823 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
10824 if (ps_utf8)
10825 SvUTF8_on(MUTABLE_SV(gv));
10826 }
10827 else
10828 sv_setiv(MUTABLE_SV(gv), -1);
10829 }
10830
10831 SvREFCNT_dec(PL_compcv);
10832 cv = PL_compcv = NULL;
10833 goto done;
10834 }
10835 }
10836
10837 cv = (!name || (isGV(gv) && GvCVGEN(gv)))
10838 ? NULL
10839 : isGV(gv)
10840 ? GvCV(gv)
10841 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
10842 ? (CV *)SvRV(gv)
10843 : NULL;
10844
10845 if (block) {
10846 assert(PL_parser);
10847 if (CvIsMETHOD(PL_compcv))
10848 block = class_wrap_method_body(block);
10849 /* This makes sub {}; work as expected. */
10850 if (block->op_type == OP_STUB) {
10851 const line_t l = PL_parser->copline;
10852 op_free(block);
10853 block = newSTATEOP(0, NULL, 0);
10854 PL_parser->copline = l;
10855 }
10856 block = CvLVALUE(PL_compcv)
10857 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
10858 && (!isGV(gv) || !GvASSUMECV(gv)))
10859 ? newUNOP(OP_LEAVESUBLV, 0,
10860 op_lvalue(voidnonfinal(block), OP_LEAVESUBLV))
10861 : newUNOP(OP_LEAVESUB, 0, voidnonfinal(block));
10862 start = LINKLIST(block);
10863 block->op_next = 0;
10864 if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
10865 const_sv =
10866 S_op_const_sv(aTHX_ start, PL_compcv,
10867 cBOOL(CvCLONE(PL_compcv)));
10868 else
10869 const_sv = NULL;
10870 }
10871 else
10872 const_sv = NULL;
10873
10874 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
10875 cv_ckproto_len_flags((const CV *)gv,
10876 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10877 ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
10878 if (SvROK(gv)) {
10879 /* All the other code for sub redefinition warnings expects the
10880 clobbered sub to be a CV. Instead of making all those code
10881 paths more complex, just inline the RV version here. */
10882 const line_t oldline = CopLINE(PL_curcop);
10883 assert(IN_PERL_COMPILETIME);
10884 if (PL_parser && PL_parser->copline != NOLINE)
10885 /* This ensures that warnings are reported at the first
10886 line of a redefinition, not the last. */
10887 CopLINE_set(PL_curcop, PL_parser->copline);
10888 /* protect against fatal warnings leaking compcv */
10889 SAVEFREESV(PL_compcv);
10890
10891 if (ckWARN(WARN_REDEFINE)
10892 || ( ckWARN_d(WARN_REDEFINE)
10893 && ( !const_sv || SvRV(gv) == const_sv
10894 || SvTYPE(const_sv) == SVt_PVAV
10895 || SvTYPE(SvRV(gv)) == SVt_PVAV
10896 || sv_cmp(SvRV(gv), const_sv) ))) {
10897 assert(cSVOPo);
10898 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10899 "Constant subroutine %" SVf " redefined",
10900 SVfARG(cSVOPo->op_sv));
10901 }
10902
10903 SvREFCNT_inc_simple_void_NN(PL_compcv);
10904 CopLINE_set(PL_curcop, oldline);
10905 SvREFCNT_dec(SvRV(gv));
10906 }
10907 }
10908
10909 if (cv) {
10910 const bool exists = CvROOT(cv) || CvXSUB(cv);
10911
10912 /* if the subroutine doesn't exist and wasn't pre-declared
10913 * with a prototype, assume it will be AUTOLOADed,
10914 * skipping the prototype check
10915 */
10916 if (exists || SvPOK(cv))
10917 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
10918 /* already defined (or promised)? */
10919 if (exists || (isGV(gv) && GvASSUMECV(gv))) {
10920 S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
10921 if (block)
10922 cv = NULL;
10923 else {
10924 if (attrs)
10925 goto attrs;
10926 /* just a "sub foo;" when &foo is already defined */
10927 SAVEFREESV(PL_compcv);
10928 goto done;
10929 }
10930 }
10931 }
10932
10933 if (const_sv) {
10934 SvREFCNT_inc_simple_void_NN(const_sv);
10935 SvFLAGS(const_sv) |= SVs_PADTMP;
10936 if (cv) {
10937 assert(!CvROOT(cv) && !CvCONST(cv));
10938 cv_forget_slab(cv);
10939 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
10940 CvXSUBANY(cv).any_ptr = const_sv;
10941 CvXSUB(cv) = const_sv_xsub;
10942 CvCONST_on(cv);
10943 CvISXSUB_on(cv);
10944 PoisonPADLIST(cv);
10945 CvFLAGS(cv) |= CvNOWARN_AMBIGUOUS(PL_compcv);
10946 }
10947 else {
10948 if (isGV(gv) || CvNOWARN_AMBIGUOUS(PL_compcv)) {
10949 if (name && isGV(gv))
10950 GvCV_set(gv, NULL);
10951 cv = newCONSTSUB_flags(
10952 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
10953 const_sv
10954 );
10955 assert(cv);
10956 assert(SvREFCNT((SV*)cv) != 0);
10957 CvFLAGS(cv) |= CvNOWARN_AMBIGUOUS(PL_compcv);
10958 }
10959 else {
10960 if (!SvROK(gv)) {
10961 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10962 prepare_SV_for_RV((SV *)gv);
10963 SvOK_off((SV *)gv);
10964 SvROK_on(gv);
10965 }
10966 SvRV_set(gv, const_sv);
10967 }
10968 }
10969 op_free(block);
10970 SvREFCNT_dec(PL_compcv);
10971 PL_compcv = NULL;
10972 goto done;
10973 }
10974
10975 /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
10976 if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
10977 cv = NULL;
10978
10979 if (cv) { /* must reuse cv if autoloaded */
10980 /* transfer PL_compcv to cv */
10981 if (block) {
10982 bool free_file = CvFILE(cv) && CvDYNFILE(cv);
10983 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
10984 PADLIST *const temp_av = CvPADLIST(cv);
10985 CV *const temp_cv = CvOUTSIDE(cv);
10986 const cv_flags_t other_flags =
10987 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
10988 OP * const cvstart = CvSTART(cv);
10989
10990 if (isGV(gv)) {
10991 CvGV_set(cv,gv);
10992 assert(!CvCVGV_RC(cv));
10993 assert(CvGV(cv) == gv);
10994 }
10995 else {
10996 U32 hash;
10997 PERL_HASH(hash, name, namlen);
10998 CvNAME_HEK_set(cv,
10999 share_hek(name,
11000 name_is_utf8
11001 ? -(SSize_t)namlen
11002 : (SSize_t)namlen,
11003 hash));
11004 }
11005
11006 SvPOK_off(cv);
11007 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
11008 | CvNAMED(cv);
11009 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
11010 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
11011 CvPADLIST_set(cv,CvPADLIST(PL_compcv));
11012 CvOUTSIDE(PL_compcv) = temp_cv;
11013 CvPADLIST_set(PL_compcv, temp_av);
11014 CvSTART(cv) = CvSTART(PL_compcv);
11015 CvSTART(PL_compcv) = cvstart;
11016 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
11017 CvFLAGS(PL_compcv) |= other_flags;
11018
11019 if (free_file) {
11020 Safefree(CvFILE(cv));
11021 }
11022 CvFILE_set_from_cop(cv, PL_curcop);
11023 CvSTASH_set(cv, PL_curstash);
11024
11025 /* inner references to PL_compcv must be fixed up ... */
11026 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
11027 if (PERLDB_INTER)/* Advice debugger on the new sub. */
11028 ++PL_sub_generation;
11029 }
11030 else {
11031 /* Might have had built-in attributes applied -- propagate them. */
11032 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
11033 }
11034 /* ... before we throw it away */
11035 SvREFCNT_dec(PL_compcv);
11036 PL_compcv = cv;
11037 }
11038 else {
11039 cv = PL_compcv;
11040 if (name && isGV(gv)) {
11041 GvCV_set(gv, cv);
11042 GvCVGEN(gv) = 0;
11043 if (HvENAME_HEK(GvSTASH(gv)))
11044 /* sub Foo::bar { (shift)+1 } */
11045 gv_method_changed(gv);
11046 }
11047 else if (name) {
11048 if (!SvROK(gv)) {
11049 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
11050 prepare_SV_for_RV((SV *)gv);
11051 SvOK_off((SV *)gv);
11052 SvROK_on(gv);
11053 }
11054 SvRV_set(gv, (SV *)cv);
11055 if (HvENAME_HEK(PL_curstash))
11056 mro_method_changed_in(PL_curstash);
11057 }
11058 }
11059 assert(cv);
11060 assert(SvREFCNT((SV*)cv) != 0);
11061
11062 if (!CvHASGV(cv)) {
11063 if (isGV(gv))
11064 CvGV_set(cv, gv);
11065 else {
11066 U32 hash;
11067 PERL_HASH(hash, name, namlen);
11068 CvNAME_HEK_set(cv, share_hek(name,
11069 name_is_utf8
11070 ? -(SSize_t)namlen
11071 : (SSize_t)namlen,
11072 hash));
11073 }
11074 CvFILE_set_from_cop(cv, PL_curcop);
11075 CvSTASH_set(cv, PL_curstash);
11076 }
11077
11078 if (ps) {
11079 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
11080 if ( ps_utf8 )
11081 SvUTF8_on(MUTABLE_SV(cv));
11082 }
11083
11084 if (block) {
11085 /* If we assign an optree to a PVCV, then we've defined a
11086 * subroutine that the debugger could be able to set a breakpoint
11087 * in, so signal to pp_entereval that it should not throw away any
11088 * saved lines at scope exit. */
11089
11090 PL_breakable_sub_gen++;
11091 CvROOT(cv) = block;
11092 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
11093 itself has a refcount. */
11094 CvSLABBED_off(cv);
11095 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
11096 #ifdef PERL_DEBUG_READONLY_OPS
11097 slab = (OPSLAB *)CvSTART(cv);
11098 #endif
11099 S_process_optree(aTHX_ cv, block, start);
11100 }
11101
11102 attrs:
11103 if (attrs) {
11104 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
11105 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
11106 ? GvSTASH(CvGV(cv))
11107 : PL_curstash;
11108 if (!name)
11109 SAVEFREESV(cv);
11110 apply_attrs(stash, MUTABLE_SV(cv), attrs);
11111 if (!name)
11112 SvREFCNT_inc_simple_void_NN(cv);
11113 }
11114
11115 if (block && has_name) {
11116 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
11117 SV * const tmpstr = cv_name(cv,NULL,0);
11118 GV * const db_postponed = gv_fetchpvs("DB::postponed",
11119 GV_ADDMULTI, SVt_PVHV);
11120 HV *hv;
11121 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" LINE_Tf "-%" LINE_Tf,
11122 CopFILE(PL_curcop),
11123 (line_t)PL_subline,
11124 CopLINE(PL_curcop));
11125 (void)hv_store_ent(GvHV(PL_DBsub), tmpstr, sv, 0);
11126 hv = GvHVn(db_postponed);
11127 if (HvTOTALKEYS(hv) > 0 && hv_exists_ent(hv, tmpstr, 0)) {
11128 CV * const pcv = GvCV(db_postponed);
11129 if (pcv) {
11130 PUSHMARK(PL_stack_sp);
11131 #ifdef PERL_RC_STACK
11132 assert(rpp_stack_is_rc());
11133 #endif
11134 rpp_xpush_1(tmpstr);
11135 call_sv(MUTABLE_SV(pcv), G_DISCARD);
11136 }
11137 }
11138 }
11139
11140 if (name) {
11141 if (PL_parser && PL_parser->error_count)
11142 clear_special_blocks(name, gv, cv);
11143 else
11144 evanescent =
11145 process_special_blocks(floor, name, gv, cv);
11146 }
11147 }
11148 assert(cv);
11149
11150 done:
11151 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
11152 if (PL_parser)
11153 PL_parser->copline = NOLINE;
11154 LEAVE_SCOPE(floor);
11155
11156 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
11157 if (!evanescent) {
11158 #ifdef PERL_DEBUG_READONLY_OPS
11159 if (slab)
11160 Slab_to_ro(slab);
11161 #endif
11162 if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
11163 pad_add_weakref(cv);
11164 }
11165 return cv;
11166 }
11167
11168 STATIC void
S_clear_special_blocks(pTHX_ const char * const fullname,GV * const gv,CV * const cv)11169 S_clear_special_blocks(pTHX_ const char *const fullname,
11170 GV *const gv, CV *const cv) {
11171 const char *colon;
11172 const char *name;
11173
11174 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
11175
11176 colon = strrchr(fullname,':');
11177 name = colon ? colon + 1 : fullname;
11178
11179 if ((*name == 'B' && strEQ(name, "BEGIN"))
11180 || (*name == 'E' && strEQ(name, "END"))
11181 || (*name == 'U' && strEQ(name, "UNITCHECK"))
11182 || (*name == 'C' && strEQ(name, "CHECK"))
11183 || (*name == 'I' && strEQ(name, "INIT"))) {
11184 if (!isGV(gv)) {
11185 (void)CvGV(cv);
11186 assert(isGV(gv));
11187 }
11188 GvCV_set(gv, NULL);
11189 SvREFCNT_dec_NN(MUTABLE_SV(cv));
11190 }
11191 }
11192
11193 /* Returns true if the sub has been freed. */
11194 STATIC bool
S_process_special_blocks(pTHX_ I32 floor,const char * const fullname,GV * const gv,CV * const cv)11195 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
11196 GV *const gv,
11197 CV *const cv)
11198 {
11199 const char *const colon = strrchr(fullname,':');
11200 const char *const name = colon ? colon + 1 : fullname;
11201
11202 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
11203
11204 if (*name == 'B') {
11205 if (strEQ(name, "BEGIN")) {
11206 /* can't goto a declaration, but a null statement is fine */
11207 module_install_hack: ;
11208 const I32 oldscope = PL_scopestack_ix;
11209 SV *max_nest_sv = NULL;
11210 IV max_nest_iv;
11211 dSP;
11212 (void)CvGV(cv);
11213 if (floor) LEAVE_SCOPE(floor);
11214 ENTER;
11215
11216 /* Make sure we don't recurse too deeply into BEGIN blocks,
11217 * but let the user control it via the new control variable
11218 *
11219 * ${^MAX_NESTED_EVAL_BEGIN_BLOCKS}
11220 *
11221 * Note that this code (when max_nest_iv is 1) *looks* like
11222 * it would block the following code:
11223 *
11224 * BEGIN { $n |= 1; BEGIN { $n |= 2; BEGIN { $n |= 4 } } }
11225 *
11226 * but it does *not*; this code will happily execute when
11227 * the nest limit is 1. The reason is revealed in the
11228 * execution order. If we could watch $n in this code, we
11229 * would see the following order of modifications:
11230 *
11231 * $n |= 4;
11232 * $n |= 2;
11233 * $n |= 1;
11234 *
11235 * This is because nested BEGIN blocks execute in FILO
11236 * order; this is because BEGIN blocks are defined to
11237 * execute immediately once they are closed. So the
11238 * innermost block is closed first, and it executes, which
11239 * increments the eval_begin_nest_depth by 1, and then it
11240 * finishes, which drops eval_begin_nest_depth back to its
11241 * previous value. This happens in turn as each BEGIN is
11242 * completed.
11243 *
11244 * The *only* place these counts matter is when BEGIN is
11245 * inside of some kind of string eval, either a require or a
11246 * true eval. Only in that case would there be any nesting
11247 * and would perl try to execute a BEGIN before another had
11248 * completed.
11249 *
11250 * Thus this logic puts an upper limit on module nesting.
11251 * Hence the reason we let the user control it, although it
11252 * is hard to imagine a 1000-level-deep module use
11253 * dependency even in a very large codebase. The real
11254 * objective is to prevent code like this:
11255 *
11256 * perl -e'sub f { eval "BEGIN { f() }" } f()'
11257 *
11258 * from segfaulting due to stack exhaustion.
11259 *
11260 */
11261 max_nest_sv = get_sv(PERL_VAR_MAX_NESTED_EVAL_BEGIN_BLOCKS, GV_ADD);
11262 if (!SvOK(max_nest_sv))
11263 sv_setiv(max_nest_sv, PERL_MAX_NESTED_EVAL_BEGIN_BLOCKS_DEFAULT);
11264 max_nest_iv = SvIV(max_nest_sv);
11265 if (max_nest_iv < 0) {
11266 max_nest_iv = PERL_MAX_NESTED_EVAL_BEGIN_BLOCKS_DEFAULT;
11267 sv_setiv(max_nest_sv, max_nest_iv);
11268 }
11269
11270 /* (UV) below is just to silence a compiler warning, and should be
11271 * effectively a no-op, as max_nest_iv will never be negative here.
11272 */
11273 if (PL_eval_begin_nest_depth >= (UV)max_nest_iv) {
11274 Perl_croak(aTHX_ "Too many nested BEGIN blocks, maximum of %" IVdf " allowed",
11275 max_nest_iv);
11276 }
11277 SAVEINT(PL_eval_begin_nest_depth);
11278 PL_eval_begin_nest_depth++;
11279
11280 SAVEVPTR(PL_curcop);
11281 if (PL_curcop == &PL_compiling) {
11282 /* Avoid pushing the "global" &PL_compiling onto the
11283 * context stack. For example, a stack trace inside
11284 * nested use's would show all calls coming from whoever
11285 * most recently updated PL_compiling.cop_file and
11286 * cop_line. So instead, temporarily set PL_curcop to a
11287 * private copy of &PL_compiling. PL_curcop will soon be
11288 * set to point back to &PL_compiling anyway but only
11289 * after the temp value has been pushed onto the context
11290 * stack as blk_oldcop.
11291 * This is slightly hacky, but necessary. Note also
11292 * that in the brief window before PL_curcop is set back
11293 * to PL_compiling, IN_PERL_COMPILETIME/IN_PERL_RUNTIME
11294 * will give the wrong answer.
11295 */
11296 PL_curcop = (COP*)newSTATEOP(PL_compiling.op_flags, NULL, NULL);
11297 CopLINE_set(PL_curcop, CopLINE(&PL_compiling));
11298 SAVEFREEOP(PL_curcop);
11299 }
11300
11301 PUSHSTACKi(PERLSI_REQUIRE);
11302 SAVECOPFILE(&PL_compiling);
11303 SAVECOPLINE(&PL_compiling);
11304
11305 DEBUG_x( dump_sub(gv) );
11306 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
11307 GvCV_set(gv,0); /* cv has been hijacked */
11308 call_list(oldscope, PL_beginav);
11309
11310 POPSTACK;
11311 LEAVE;
11312 return !PL_savebegin;
11313 }
11314 else
11315 return FALSE;
11316 } else {
11317 if (*name == 'E') {
11318 if (strEQ(name, "END")) {
11319 DEBUG_x( dump_sub(gv) );
11320 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
11321 } else
11322 return FALSE;
11323 } else if (*name == 'U') {
11324 if (strEQ(name, "UNITCHECK")) {
11325 /* It's never too late to run a unitcheck block */
11326 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
11327 }
11328 else
11329 return FALSE;
11330 } else if (*name == 'C') {
11331 if (strEQ(name, "CHECK")) {
11332 if (PL_main_start)
11333 /* diag_listed_as: Too late to run %s block */
11334 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
11335 "Too late to run CHECK block");
11336 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
11337 }
11338 else
11339 return FALSE;
11340 } else if (*name == 'I') {
11341 if (strEQ(name, "INIT")) {
11342 #ifdef MI_INIT_WORKAROUND_PACK
11343 {
11344 HV *hv = CvSTASH(cv);
11345 STRLEN len = hv ? HvNAMELEN(hv) : 0;
11346 char *pv = (len == sizeof(MI_INIT_WORKAROUND_PACK)-1)
11347 ? HvNAME_get(hv) : NULL;
11348 if ( pv && strEQ(pv, MI_INIT_WORKAROUND_PACK) ) {
11349 /* old versions of Module::Install::DSL contain code
11350 * that creates an INIT in eval, which expects to run
11351 * after an exit(0) in BEGIN. This unfortunately
11352 * breaks a lot of code in the CPAN river. So we magically
11353 * convert INIT blocks from Module::Install::DSL to
11354 * be BEGIN blocks. Which works out, since the INIT
11355 * blocks it creates are eval'ed and so are late.
11356 */
11357 Perl_warn(aTHX_ "Treating %s::INIT block as BEGIN block as workaround",
11358 MI_INIT_WORKAROUND_PACK);
11359 goto module_install_hack;
11360 }
11361
11362 }
11363 #endif
11364 if (PL_main_start)
11365 /* diag_listed_as: Too late to run %s block */
11366 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
11367 "Too late to run INIT block");
11368 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
11369 }
11370 else
11371 return FALSE;
11372 } else
11373 return FALSE;
11374 DEBUG_x( dump_sub(gv) );
11375 (void)CvGV(cv);
11376 GvCV_set(gv,0); /* cv has been hijacked */
11377 return FALSE;
11378 }
11379 }
11380
11381 CV *
Perl_newCONSTSUB(pTHX_ HV * stash,const char * name,SV * sv)11382 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
11383 {
11384 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
11385 }
11386
11387 /*
11388 =for apidoc newCONSTSUB
11389 =for apidoc_item newCONSTSUB_flags
11390
11391 Construct a constant subroutine, also performing some surrounding
11392 jobs. A scalar constant-valued subroutine is eligible for inlining
11393 at compile-time, and in Perl code can be created by S<C<sub FOO () {
11394 123 }>>. Other kinds of constant subroutine have other treatment.
11395
11396 The subroutine will have an empty prototype and will ignore any arguments
11397 when called. Its constant behaviour is determined by C<sv>. If C<sv>
11398 is null, the subroutine will yield an empty list. If C<sv> points to a
11399 scalar, the subroutine will always yield that scalar. If C<sv> points
11400 to an array, the subroutine will always yield a list of the elements of
11401 that array in list context, or the number of elements in the array in
11402 scalar context. This function takes ownership of one counted reference
11403 to the scalar or array, and will arrange for the object to live as long
11404 as the subroutine does. If C<sv> points to a scalar then the inlining
11405 assumes that the value of the scalar will never change, so the caller
11406 must ensure that the scalar is not subsequently written to. If C<sv>
11407 points to an array then no such assumption is made, so it is ostensibly
11408 safe to mutate the array or its elements, but whether this is really
11409 supported has not been determined.
11410
11411 The subroutine will have C<CvFILE> set according to C<PL_curcop>.
11412 Other aspects of the subroutine will be left in their default state.
11413 The caller is free to mutate the subroutine beyond its initial state
11414 after this function has returned.
11415
11416 If C<name> is null then the subroutine will be anonymous, with its
11417 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
11418 subroutine will be named accordingly, referenced by the appropriate glob.
11419
11420
11421 C<name> is a string, giving a sigilless symbol name.
11422 For C</newCONSTSUB>, C<name> is NUL-terminated, interpreted as Latin-1.
11423
11424 For C</newCONSTSUB_flags>, C<name> has length C<len> bytes, hence may contain
11425 embedded NULs. It is interpreted as UTF-8 if C<flags> has the C<SVf_UTF8> bit
11426 set, and Latin-1 otherwise. C<flags> should not have bits set other than
11427 C<SVf_UTF8>.
11428
11429 The name may be either qualified or unqualified. If the
11430 name is unqualified then it defaults to being in the stash specified by
11431 C<stash> if that is non-null, or to C<PL_curstash> if C<stash> is null.
11432 The symbol is always added to the stash if necessary, with C<GV_ADDMULTI>
11433 semantics.
11434
11435 If there is already a subroutine of the specified name, then the new sub
11436 will replace the existing one in the glob. A warning may be generated
11437 about the redefinition.
11438
11439 If the subroutine has one of a few special names, such as C<BEGIN> or
11440 C<END>, then it will be claimed by the appropriate queue for automatic
11441 running of phase-related subroutines. In this case the relevant glob will
11442 be left not containing any subroutine, even if it did contain one before.
11443 Execution of the subroutine will likely be a no-op, unless C<sv> was
11444 a tied array or the caller modified the subroutine in some interesting
11445 way before it was executed. In the case of C<BEGIN>, the treatment is
11446 buggy: the sub will be executed when only half built, and may be deleted
11447 prematurely, possibly causing a crash.
11448
11449 The function returns a pointer to the constructed subroutine. If the sub
11450 is anonymous then ownership of one counted reference to the subroutine
11451 is transferred to the caller. If the sub is named then the caller does
11452 not get ownership of a reference. In most such cases, where the sub
11453 has a non-phase name, the sub will be alive at the point it is returned
11454 by virtue of being contained in the glob that names it. A phase-named
11455 subroutine will usually be alive by virtue of the reference owned by
11456 the phase's automatic run queue. A C<BEGIN> subroutine may have been
11457 destroyed already by the time this function returns, but currently bugs
11458 occur in that case before the caller gets control. It is the caller's
11459 responsibility to ensure that it knows which of these situations applies.
11460
11461 =cut
11462 */
11463
11464 CV *
Perl_newCONSTSUB_flags(pTHX_ HV * stash,const char * name,STRLEN len,U32 flags,SV * sv)11465 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
11466 U32 flags, SV *sv)
11467 {
11468 CV* cv;
11469 const char *const file = CopFILE(PL_curcop);
11470
11471 ENTER;
11472
11473 if (IN_PERL_RUNTIME) {
11474 /* at runtime, it's not safe to manipulate PL_curcop: it may be
11475 * an op shared between threads. Use a non-shared COP for our
11476 * dirty work */
11477 SAVEVPTR(PL_curcop);
11478 SAVECOMPILEWARNINGS();
11479 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
11480 PL_curcop = &PL_compiling;
11481 }
11482 SAVECOPLINE(PL_curcop);
11483 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
11484
11485 SAVEHINTS();
11486 PL_hints &= ~HINT_BLOCK_SCOPE;
11487
11488 if (stash) {
11489 SAVEGENERICSV(PL_curstash);
11490 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
11491 }
11492
11493 /* Protect sv against leakage caused by fatal warnings. */
11494 if (sv) SAVEFREESV(sv);
11495
11496 /* file becomes the CvFILE. For an XS, it's usually static storage,
11497 and so doesn't get free()d. (It's expected to be from the C pre-
11498 processor __FILE__ directive). But we need a dynamically allocated one,
11499 and we need it to get freed. */
11500 cv = newXS_len_flags(name, len,
11501 sv && SvTYPE(sv) == SVt_PVAV
11502 ? const_av_xsub
11503 : const_sv_xsub,
11504 file ? file : "", "",
11505 &sv, XS_DYNAMIC_FILENAME | flags);
11506 assert(cv);
11507 assert(SvREFCNT((SV*)cv) != 0);
11508 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
11509 CvCONST_on(cv);
11510
11511 LEAVE;
11512
11513 return cv;
11514 }
11515
11516 /*
11517 =for apidoc newXS
11518
11519 Used by C<xsubpp> to hook up XSUBs as Perl subs. C<filename> needs to be
11520 static storage, as it is used directly as CvFILE(), without a copy being made.
11521
11522 =cut
11523 */
11524
11525 CV *
Perl_newXS(pTHX_ const char * name,XSUBADDR_t subaddr,const char * filename)11526 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
11527 {
11528 PERL_ARGS_ASSERT_NEWXS;
11529 return newXS_len_flags(
11530 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
11531 );
11532 }
11533
11534 CV *
Perl_newXS_flags(pTHX_ const char * name,XSUBADDR_t subaddr,const char * const filename,const char * const proto,U32 flags)11535 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
11536 const char *const filename, const char *const proto,
11537 U32 flags)
11538 {
11539 PERL_ARGS_ASSERT_NEWXS_FLAGS;
11540 return newXS_len_flags(
11541 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
11542 );
11543 }
11544
11545 CV *
Perl_newXS_deffile(pTHX_ const char * name,XSUBADDR_t subaddr)11546 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
11547 {
11548 PERL_ARGS_ASSERT_NEWXS_DEFFILE;
11549 return newXS_len_flags(
11550 name, strlen(name), subaddr, NULL, NULL, NULL, 0
11551 );
11552 }
11553
11554 /*
11555 =for apidoc newXS_len_flags
11556
11557 Construct an XS subroutine, also performing some surrounding jobs.
11558
11559 The subroutine will have the entry point C<subaddr>. It will have
11560 the prototype specified by the nul-terminated string C<proto>, or
11561 no prototype if C<proto> is null. The prototype string is copied;
11562 the caller can mutate the supplied string afterwards. If C<filename>
11563 is non-null, it must be a nul-terminated filename, and the subroutine
11564 will have its C<CvFILE> set accordingly. By default C<CvFILE> is set to
11565 point directly to the supplied string, which must be static. If C<flags>
11566 has the C<XS_DYNAMIC_FILENAME> bit set, then a copy of the string will
11567 be taken instead.
11568
11569 Other aspects of the subroutine will be left in their default state.
11570 If anything else needs to be done to the subroutine for it to function
11571 correctly, it is the caller's responsibility to do that after this
11572 function has constructed it. However, beware of the subroutine
11573 potentially being destroyed before this function returns, as described
11574 below.
11575
11576 If C<name> is null then the subroutine will be anonymous, with its
11577 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
11578 subroutine will be named accordingly, referenced by the appropriate glob.
11579 C<name> is a string of length C<len> bytes giving a sigilless symbol name,
11580 in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 otherwise.
11581 The name may be either qualified or unqualified, with the stash defaulting
11582 in the same manner as for C<gv_fetchpvn_flags>. C<flags> may contain
11583 flag bits understood by C<gv_fetchpvn_flags> with the same meaning as
11584 they have there, such as C<GV_ADDWARN>. The symbol is always added to
11585 the stash if necessary, with C<GV_ADDMULTI> semantics.
11586
11587 If there is already a subroutine of the specified name, then the new sub
11588 will replace the existing one in the glob. A warning may be generated
11589 about the redefinition. If the old subroutine was C<CvCONST> then the
11590 decision about whether to warn is influenced by an expectation about
11591 whether the new subroutine will become a constant of similar value.
11592 That expectation is determined by C<const_svp>. (Note that the call to
11593 this function doesn't make the new subroutine C<CvCONST> in any case;
11594 that is left to the caller.) If C<const_svp> is null then it indicates
11595 that the new subroutine will not become a constant. If C<const_svp>
11596 is non-null then it indicates that the new subroutine will become a
11597 constant, and it points to an C<SV*> that provides the constant value
11598 that the subroutine will have.
11599
11600 If the subroutine has one of a few special names, such as C<BEGIN> or
11601 C<END>, then it will be claimed by the appropriate queue for automatic
11602 running of phase-related subroutines. In this case the relevant glob will
11603 be left not containing any subroutine, even if it did contain one before.
11604 In the case of C<BEGIN>, the subroutine will be executed and the reference
11605 to it disposed of before this function returns, and also before its
11606 prototype is set. If a C<BEGIN> subroutine would not be sufficiently
11607 constructed by this function to be ready for execution then the caller
11608 must prevent this happening by giving the subroutine a different name.
11609
11610 The function returns a pointer to the constructed subroutine. If the sub
11611 is anonymous then ownership of one counted reference to the subroutine
11612 is transferred to the caller. If the sub is named then the caller does
11613 not get ownership of a reference. In most such cases, where the sub
11614 has a non-phase name, the sub will be alive at the point it is returned
11615 by virtue of being contained in the glob that names it. A phase-named
11616 subroutine will usually be alive by virtue of the reference owned by the
11617 phase's automatic run queue. But a C<BEGIN> subroutine, having already
11618 been executed, will quite likely have been destroyed already by the
11619 time this function returns, making it erroneous for the caller to make
11620 any use of the returned pointer. It is the caller's responsibility to
11621 ensure that it knows which of these situations applies.
11622
11623 =cut
11624 */
11625
11626 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)11627 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
11628 XSUBADDR_t subaddr, const char *const filename,
11629 const char *const proto, SV **const_svp,
11630 U32 flags)
11631 {
11632 CV *cv;
11633 bool interleave = FALSE;
11634 bool evanescent = FALSE;
11635
11636 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
11637
11638 {
11639 GV * const gv = gv_fetchpvn(
11640 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
11641 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
11642 sizeof("__ANON__::__ANON__") - 1,
11643 GV_ADDMULTI | flags, SVt_PVCV);
11644
11645 if ((cv = (name ? GvCV(gv) : NULL))) {
11646 if (GvCVGEN(gv)) {
11647 /* just a cached method */
11648 SvREFCNT_dec(cv);
11649 cv = NULL;
11650 }
11651 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
11652 /* already defined (or promised) */
11653 /* Redundant check that allows us to avoid creating an SV
11654 most of the time: */
11655 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
11656 report_redefined_cv(newSVpvn_flags(
11657 name,len,(flags&SVf_UTF8)|SVs_TEMP
11658 ),
11659 cv, const_svp);
11660 }
11661 interleave = TRUE;
11662 ENTER;
11663 SAVEFREESV(cv);
11664 cv = NULL;
11665 }
11666 }
11667
11668 if (cv) /* must reuse cv if autoloaded */
11669 cv_undef(cv);
11670 else {
11671 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
11672 if (name) {
11673 GvCV_set(gv,cv);
11674 GvCVGEN(gv) = 0;
11675 if (HvENAME_HEK(GvSTASH(gv)))
11676 gv_method_changed(gv); /* newXS */
11677 }
11678 }
11679 assert(cv);
11680 assert(SvREFCNT((SV*)cv) != 0);
11681
11682 CvGV_set(cv, gv);
11683 if(filename) {
11684 /* XSUBs can't be perl lang/perl5db.pl debugged
11685 if (PERLDB_LINE_OR_SAVESRC)
11686 (void)gv_fetchfile(filename); */
11687 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
11688 if (flags & XS_DYNAMIC_FILENAME) {
11689 CvDYNFILE_on(cv);
11690 CvFILE(cv) = savepv(filename);
11691 } else {
11692 /* NOTE: not copied, as it is expected to be an external constant string */
11693 CvFILE(cv) = (char *)filename;
11694 }
11695 } else {
11696 assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
11697 CvFILE(cv) = (char*)PL_xsubfilename;
11698 }
11699 CvISXSUB_on(cv);
11700 CvXSUB(cv) = subaddr;
11701 #ifndef MULTIPLICITY
11702 CvHSCXT(cv) = &PL_stack_sp;
11703 #else
11704 PoisonPADLIST(cv);
11705 #endif
11706
11707 if (name)
11708 evanescent = process_special_blocks(0, name, gv, cv);
11709 else
11710 CvANON_on(cv);
11711 } /* <- not a conditional branch */
11712
11713 assert(cv);
11714 assert(evanescent || SvREFCNT((SV*)cv) != 0);
11715
11716 if (!evanescent) sv_setpv(MUTABLE_SV(cv), proto);
11717 if (interleave) LEAVE;
11718 assert(evanescent || SvREFCNT((SV*)cv) != 0);
11719 return cv;
11720 }
11721
11722 /* Add a stub CV to a typeglob.
11723 * This is the implementation of a forward declaration, 'sub foo';'
11724 */
11725
11726 CV *
Perl_newSTUB(pTHX_ GV * gv,bool fake)11727 Perl_newSTUB(pTHX_ GV *gv, bool fake)
11728 {
11729 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
11730 GV *cvgv;
11731 PERL_ARGS_ASSERT_NEWSTUB;
11732 assert(!GvCVu(gv));
11733 GvCV_set(gv, cv);
11734 GvCVGEN(gv) = 0;
11735 if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
11736 gv_method_changed(gv);
11737 if (SvFAKE(gv)) {
11738 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
11739 SvFAKE_off(cvgv);
11740 }
11741 else cvgv = gv;
11742 CvGV_set(cv, cvgv);
11743 CvFILE_set_from_cop(cv, PL_curcop);
11744 CvSTASH_set(cv, PL_curstash);
11745 GvMULTI_on(gv);
11746 return cv;
11747 }
11748
11749 void
Perl_newFORM(pTHX_ I32 floor,OP * o,OP * block)11750 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
11751 {
11752 CV *cv;
11753 GV *gv;
11754 OP *root;
11755 OP *start;
11756
11757 if (PL_parser && PL_parser->error_count) {
11758 op_free(block);
11759 goto finish;
11760 }
11761
11762 gv = o
11763 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
11764 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
11765
11766 GvMULTI_on(gv);
11767 if ((cv = GvFORM(gv))) {
11768 if (ckWARN(WARN_REDEFINE)) {
11769 const line_t oldline = CopLINE(PL_curcop);
11770 if (PL_parser && PL_parser->copline != NOLINE)
11771 CopLINE_set(PL_curcop, PL_parser->copline);
11772 if (o) {
11773 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11774 "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
11775 } else {
11776 /* diag_listed_as: Format %s redefined */
11777 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11778 "Format STDOUT redefined");
11779 }
11780 CopLINE_set(PL_curcop, oldline);
11781 }
11782 SvREFCNT_dec(cv);
11783 }
11784 cv = PL_compcv;
11785 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
11786 CvGV_set(cv, gv);
11787 CvFILE_set_from_cop(cv, PL_curcop);
11788
11789
11790 root = newUNOP(OP_LEAVEWRITE, 0, voidnonfinal(block));
11791 CvROOT(cv) = root;
11792 start = LINKLIST(root);
11793 root->op_next = 0;
11794 S_process_optree(aTHX_ cv, root, start);
11795 cv_forget_slab(cv);
11796
11797 finish:
11798 op_free(o);
11799 if (PL_parser)
11800 PL_parser->copline = NOLINE;
11801 LEAVE_SCOPE(floor);
11802 PL_compiling.cop_seq = 0;
11803 }
11804
11805 /*
11806 =for apidoc newANONLIST
11807
11808 Constructs, checks, and returns an anonymous list op.
11809
11810 =cut
11811 */
11812
11813 OP *
Perl_newANONLIST(pTHX_ OP * o)11814 Perl_newANONLIST(pTHX_ OP *o)
11815 {
11816 return (o) ? op_convert_list(OP_ANONLIST, OPf_SPECIAL, o)
11817 : newOP(OP_EMPTYAVHV, 0);
11818 }
11819
11820 /*
11821 =for apidoc newANONHASH
11822
11823 Constructs, checks, and returns an anonymous hash op.
11824
11825 =cut
11826 */
11827
11828 OP *
Perl_newANONHASH(pTHX_ OP * o)11829 Perl_newANONHASH(pTHX_ OP *o)
11830 {
11831 OP * anon = (o) ? op_convert_list(OP_ANONHASH, OPf_SPECIAL, o)
11832 : newOP(OP_EMPTYAVHV, 0);
11833 if (!o)
11834 anon->op_private |= OPpEMPTYAVHV_IS_HV;
11835 return anon;
11836 }
11837
11838 /*
11839 =for apidoc newANONSUB
11840
11841 Construct a nameless (anonymous) Perl subroutine without attributes, also
11842 performing some surrounding jobs.
11843
11844 This is the same as L<perlintern/C<newATTRSUB_x>> with its C<o_is_gv> parameter
11845 set to FALSE, and its C<o> and C<attrs> parameters to NULL.
11846 For more details, see L<perlintern/C<newATTRSUB_x>>.
11847
11848 =cut
11849 */
11850
11851 OP *
Perl_newANONSUB(pTHX_ I32 floor,OP * proto,OP * block)11852 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
11853 {
11854 return newANONATTRSUB(floor, proto, NULL, block);
11855 }
11856
11857 /*
11858 =for apidoc newANONATTRSUB
11859
11860 Construct a nameless (anonymous) Perl subroutine, also performing some
11861 surrounding jobs.
11862
11863 This is the same as L<perlintern/C<newATTRSUB_x>> with its C<o_is_gv> parameter
11864 set to FALSE, and its C<o> parameter to NULL.
11865 For more details, see L<perlintern/C<newATTRSUB_x>>.
11866
11867 =cut
11868 */
11869
11870 OP *
Perl_newANONATTRSUB(pTHX_ I32 floor,OP * proto,OP * attrs,OP * block)11871 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
11872 {
11873 SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
11874
11875 bool is_const = CvANONCONST(cv);
11876
11877 OP * anoncode =
11878 newSVOP(OP_ANONCODE, is_const ? 0 : OPf_REF,
11879 cv);
11880
11881 if (is_const) {
11882 anoncode = newUNOP(OP_ANONCONST, OPf_REF,
11883 newLISTOPn(OP_ENTERSUB, OPf_STACKED|OPf_WANT_SCALAR,
11884 anoncode,
11885 NULL));
11886 }
11887
11888 return anoncode;
11889 }
11890
11891 OP *
Perl_oopsAV(pTHX_ OP * o)11892 Perl_oopsAV(pTHX_ OP *o)
11893 {
11894
11895 PERL_ARGS_ASSERT_OOPSAV;
11896
11897 switch (o->op_type) {
11898 case OP_PADSV:
11899 case OP_PADHV:
11900 OpTYPE_set(o, OP_PADAV);
11901 return ref(o, OP_RV2AV);
11902
11903 case OP_RV2SV:
11904 case OP_RV2HV:
11905 OpTYPE_set(o, OP_RV2AV);
11906 ref(o, OP_RV2AV);
11907 break;
11908
11909 default:
11910 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
11911 break;
11912 }
11913 return o;
11914 }
11915
11916 OP *
Perl_oopsHV(pTHX_ OP * o)11917 Perl_oopsHV(pTHX_ OP *o)
11918 {
11919
11920 PERL_ARGS_ASSERT_OOPSHV;
11921
11922 switch (o->op_type) {
11923 case OP_PADSV:
11924 case OP_PADAV:
11925 OpTYPE_set(o, OP_PADHV);
11926 return ref(o, OP_RV2HV);
11927
11928 case OP_RV2SV:
11929 case OP_RV2AV:
11930 OpTYPE_set(o, OP_RV2HV);
11931 /* rv2hv steals the bottom bit for its own uses */
11932 o->op_private &= ~OPpARG1_MASK;
11933 ref(o, OP_RV2HV);
11934 break;
11935
11936 default:
11937 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
11938 break;
11939 }
11940 return o;
11941 }
11942
11943 /*
11944 =for apidoc newAVREF
11945
11946 Constructs, checks, and returns an arrary reference op.
11947
11948 =cut
11949 */
11950
11951 OP *
Perl_newAVREF(pTHX_ OP * o)11952 Perl_newAVREF(pTHX_ OP *o)
11953 {
11954
11955 PERL_ARGS_ASSERT_NEWAVREF;
11956
11957 if (o->op_type == OP_PADANY) {
11958 OpTYPE_set(o, OP_PADAV);
11959 return o;
11960 }
11961 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
11962 Perl_croak(aTHX_ "Can't use an array as a reference");
11963 }
11964 return newUNOP(OP_RV2AV, 0, scalar(o));
11965 }
11966
11967 /*
11968 =for apidoc newGVREF
11969
11970 Constructs, checks, and returns a glob reference op.
11971
11972 =cut
11973 */
11974
11975 OP *
Perl_newGVREF(pTHX_ I32 type,OP * o)11976 Perl_newGVREF(pTHX_ I32 type, OP *o)
11977 {
11978 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
11979 return newUNOP(OP_NULL, 0, o);
11980
11981 if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED &&
11982 ((PL_opargs[type] >> OASHIFT) & 7) == OA_FILEREF &&
11983 o->op_type == OP_CONST && (o->op_private & OPpCONST_BARE)) {
11984 no_bareword_filehandle(SvPVX(cSVOPo_sv));
11985 }
11986
11987 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
11988 }
11989
11990 /*
11991 =for apidoc newHVREF
11992
11993 Constructs, checks, and returns a hash reference op.
11994
11995 =cut
11996 */
11997
11998 OP *
Perl_newHVREF(pTHX_ OP * o)11999 Perl_newHVREF(pTHX_ OP *o)
12000 {
12001
12002 PERL_ARGS_ASSERT_NEWHVREF;
12003
12004 if (o->op_type == OP_PADANY) {
12005 OpTYPE_set(o, OP_PADHV);
12006 return o;
12007 }
12008 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
12009 Perl_croak(aTHX_ "Can't use a hash as a reference");
12010 }
12011 return newUNOP(OP_RV2HV, 0, scalar(o));
12012 }
12013
12014 /*
12015 =for apidoc newCVREF
12016
12017 Constructs, checks, and returns a code reference op.
12018
12019 =cut
12020 */
12021
12022 OP *
Perl_newCVREF(pTHX_ I32 flags,OP * o)12023 Perl_newCVREF(pTHX_ I32 flags, OP *o)
12024 {
12025 if (o->op_type == OP_PADANY) {
12026 OpTYPE_set(o, OP_PADCV);
12027 }
12028 return newUNOP(OP_RV2CV, flags, scalar(o));
12029 }
12030
12031 /*
12032 =for apidoc newSVREF
12033
12034 Constructs, checks, and returns a scalar reference op.
12035
12036 =cut
12037 */
12038
12039 OP *
Perl_newSVREF(pTHX_ OP * o)12040 Perl_newSVREF(pTHX_ OP *o)
12041 {
12042
12043 PERL_ARGS_ASSERT_NEWSVREF;
12044
12045 if (o->op_type == OP_PADANY) {
12046 OpTYPE_set(o, OP_PADSV);
12047 scalar(o);
12048 return o;
12049 }
12050 return newUNOP(OP_RV2SV, 0, scalar(o));
12051 }
12052
12053 /* Check routines. See the comments at the top of this file for details
12054 * on when these are called */
12055
12056 OP *
Perl_ck_anoncode(pTHX_ OP * o)12057 Perl_ck_anoncode(pTHX_ OP *o)
12058 {
12059 PERL_ARGS_ASSERT_CK_ANONCODE;
12060
12061 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
12062 cSVOPo->op_sv = NULL;
12063 return o;
12064 }
12065
12066 static void
S_io_hints(pTHX_ OP * o)12067 S_io_hints(pTHX_ OP *o)
12068 {
12069 #if O_BINARY != 0 || O_TEXT != 0
12070 HV * const table =
12071 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
12072 if (table) {
12073 SV **svp = hv_fetchs(table, "open_IN", FALSE);
12074 if (svp && *svp) {
12075 STRLEN len = 0;
12076 const char *d = SvPV_const(*svp, len);
12077 const I32 mode = mode_from_discipline(d, len);
12078 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
12079 # if O_BINARY != 0
12080 if (mode & O_BINARY)
12081 o->op_private |= OPpOPEN_IN_RAW;
12082 # endif
12083 # if O_TEXT != 0
12084 if (mode & O_TEXT)
12085 o->op_private |= OPpOPEN_IN_CRLF;
12086 # endif
12087 }
12088
12089 svp = hv_fetchs(table, "open_OUT", FALSE);
12090 if (svp && *svp) {
12091 STRLEN len = 0;
12092 const char *d = SvPV_const(*svp, len);
12093 const I32 mode = mode_from_discipline(d, len);
12094 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
12095 # if O_BINARY != 0
12096 if (mode & O_BINARY)
12097 o->op_private |= OPpOPEN_OUT_RAW;
12098 # endif
12099 # if O_TEXT != 0
12100 if (mode & O_TEXT)
12101 o->op_private |= OPpOPEN_OUT_CRLF;
12102 # endif
12103 }
12104 }
12105 #else
12106 PERL_UNUSED_CONTEXT;
12107 PERL_UNUSED_ARG(o);
12108 #endif
12109 }
12110
12111 OP *
Perl_ck_backtick(pTHX_ OP * o)12112 Perl_ck_backtick(pTHX_ OP *o)
12113 {
12114 GV *gv;
12115 OP *newop = NULL;
12116 OP *sibl;
12117 PERL_ARGS_ASSERT_CK_BACKTICK;
12118 o = ck_fun(o);
12119 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
12120 if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
12121 && (gv = gv_override("readpipe",8)))
12122 {
12123 /* detach rest of siblings from o and its first child */
12124 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
12125 newop = S_new_entersubop(aTHX_ gv, sibl);
12126 }
12127 else if (!(o->op_flags & OPf_KIDS))
12128 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
12129 if (newop) {
12130 op_free(o);
12131 return newop;
12132 }
12133 S_io_hints(aTHX_ o);
12134 return o;
12135 }
12136
12137 OP *
Perl_ck_bitop(pTHX_ OP * o)12138 Perl_ck_bitop(pTHX_ OP *o)
12139 {
12140 PERL_ARGS_ASSERT_CK_BITOP;
12141
12142 /* get rid of arg count and indicate if in the scope of 'use integer' */
12143 o->op_private = (PL_hints & HINT_INTEGER) ? OPpUSEINT : 0;
12144
12145 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
12146 && OP_IS_INFIX_BIT(o->op_type))
12147 {
12148 const OP * const left = cBINOPo->op_first;
12149 const OP * const right = OpSIBLING(left);
12150 if ((OP_IS_NUMCOMPARE(left->op_type) &&
12151 (left->op_flags & OPf_PARENS) == 0) ||
12152 (OP_IS_NUMCOMPARE(right->op_type) &&
12153 (right->op_flags & OPf_PARENS) == 0))
12154 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
12155 "Possible precedence problem on bitwise %s operator",
12156 o->op_type == OP_BIT_OR
12157 ||o->op_type == OP_NBIT_OR ? "|"
12158 : o->op_type == OP_BIT_AND
12159 ||o->op_type == OP_NBIT_AND ? "&"
12160 : o->op_type == OP_BIT_XOR
12161 ||o->op_type == OP_NBIT_XOR ? "^"
12162 : o->op_type == OP_SBIT_OR ? "|."
12163 : o->op_type == OP_SBIT_AND ? "&." : "^."
12164 );
12165 }
12166 return o;
12167 }
12168
12169 PERL_STATIC_INLINE bool
is_dollar_bracket(pTHX_ const OP * const o)12170 is_dollar_bracket(pTHX_ const OP * const o)
12171 {
12172 const OP *kid;
12173 PERL_UNUSED_CONTEXT;
12174 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
12175 && (kid = cUNOPx(o)->op_first)
12176 && kid->op_type == OP_GV
12177 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
12178 }
12179
12180 /* for lt, gt, le, ge, eq, ne and their i_ variants */
12181
12182 OP *
Perl_ck_cmp(pTHX_ OP * o)12183 Perl_ck_cmp(pTHX_ OP *o)
12184 {
12185 bool is_eq;
12186 bool neg;
12187 bool reverse;
12188 bool iv0;
12189 OP *indexop, *constop, *start;
12190 SV *sv;
12191 IV iv;
12192
12193 PERL_ARGS_ASSERT_CK_CMP;
12194
12195 is_eq = ( o->op_type == OP_EQ
12196 || o->op_type == OP_NE
12197 || o->op_type == OP_I_EQ
12198 || o->op_type == OP_I_NE);
12199
12200 if (!is_eq && ckWARN(WARN_SYNTAX)) {
12201 const OP *kid = cUNOPo->op_first;
12202 if (kid &&
12203 (
12204 ( is_dollar_bracket(aTHX_ kid)
12205 && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
12206 )
12207 || ( kid->op_type == OP_CONST
12208 && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
12209 )
12210 )
12211 )
12212 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12213 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
12214 }
12215
12216 /* convert (index(...) == -1) and variations into
12217 * (r)index/BOOL(,NEG)
12218 */
12219
12220 reverse = FALSE;
12221
12222 indexop = cUNOPo->op_first;
12223 constop = OpSIBLING(indexop);
12224 start = NULL;
12225 if (indexop->op_type == OP_CONST) {
12226 constop = indexop;
12227 indexop = OpSIBLING(constop);
12228 start = constop;
12229 reverse = TRUE;
12230 }
12231
12232 if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
12233 return o;
12234
12235 /* ($lex = index(....)) == -1 */
12236 if (indexop->op_private & OPpTARGET_MY)
12237 return o;
12238
12239 if (constop->op_type != OP_CONST)
12240 return o;
12241
12242 sv = cSVOPx_sv(constop);
12243 if (!(sv && SvIOK_notUV(sv)))
12244 return o;
12245
12246 iv = SvIVX(sv);
12247 if (iv != -1 && iv != 0)
12248 return o;
12249 iv0 = (iv == 0);
12250
12251 if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
12252 if (!(iv0 ^ reverse))
12253 return o;
12254 neg = iv0;
12255 }
12256 else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
12257 if (iv0 ^ reverse)
12258 return o;
12259 neg = !iv0;
12260 }
12261 else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
12262 if (!(iv0 ^ reverse))
12263 return o;
12264 neg = !iv0;
12265 }
12266 else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
12267 if (iv0 ^ reverse)
12268 return o;
12269 neg = iv0;
12270 }
12271 else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
12272 if (iv0)
12273 return o;
12274 neg = TRUE;
12275 }
12276 else {
12277 assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
12278 if (iv0)
12279 return o;
12280 neg = FALSE;
12281 }
12282
12283 indexop->op_flags &= ~OPf_PARENS;
12284 indexop->op_flags |= (o->op_flags & OPf_PARENS);
12285 indexop->op_private |= OPpTRUEBOOL;
12286 if (neg)
12287 indexop->op_private |= OPpINDEX_BOOLNEG;
12288 /* cut out the index op and free the eq,const ops */
12289 (void)op_sibling_splice(o, start, 1, NULL);
12290 op_free(o);
12291
12292 return indexop;
12293 }
12294
12295
12296 OP *
Perl_ck_concat(pTHX_ OP * o)12297 Perl_ck_concat(pTHX_ OP *o)
12298 {
12299 const OP * const kid = cUNOPo->op_first;
12300
12301 PERL_ARGS_ASSERT_CK_CONCAT;
12302 PERL_UNUSED_CONTEXT;
12303
12304 /* reuse the padtmp returned by the concat child */
12305 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
12306 !(kUNOP->op_first->op_flags & OPf_MOD))
12307 {
12308 o->op_flags |= OPf_STACKED;
12309 o->op_private |= OPpCONCAT_NESTED;
12310 }
12311 return o;
12312 }
12313
12314 OP *
Perl_ck_spair(pTHX_ OP * o)12315 Perl_ck_spair(pTHX_ OP *o)
12316 {
12317
12318 PERL_ARGS_ASSERT_CK_SPAIR;
12319
12320 if (o->op_flags & OPf_KIDS) {
12321 OP* newop;
12322 OP* kid;
12323 OP* kidkid;
12324 const OPCODE type = o->op_type;
12325 o = modkids(ck_fun(o), type);
12326 kid = cUNOPo->op_first;
12327 kidkid = kUNOP->op_first;
12328 newop = OpSIBLING(kidkid);
12329 if (newop) {
12330 const OPCODE type = newop->op_type;
12331 if (OpHAS_SIBLING(newop))
12332 return o;
12333 if (o->op_type == OP_REFGEN
12334 && ( type == OP_RV2CV
12335 || ( !(newop->op_flags & OPf_PARENS)
12336 && ( type == OP_RV2AV || type == OP_PADAV
12337 || type == OP_RV2HV || type == OP_PADHV))))
12338 NOOP; /* OK (allow srefgen for \@a and \%h) */
12339 else if (OP_GIMME(newop,0) != G_SCALAR)
12340 return o;
12341 }
12342 /* excise first sibling */
12343 op_sibling_splice(kid, NULL, 1, NULL);
12344 op_free(kidkid);
12345 }
12346 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
12347 * and OP_CHOMP into OP_SCHOMP */
12348 o->op_ppaddr = PL_ppaddr[++o->op_type];
12349 return ck_fun(o);
12350 }
12351
12352 OP *
Perl_ck_delete(pTHX_ OP * o)12353 Perl_ck_delete(pTHX_ OP *o)
12354 {
12355 PERL_ARGS_ASSERT_CK_DELETE;
12356
12357 o = ck_fun(o);
12358 o->op_private = 0;
12359 if (o->op_flags & OPf_KIDS) {
12360 OP * const kid = cUNOPo->op_first;
12361 switch (kid->op_type) {
12362 case OP_ASLICE:
12363 o->op_flags |= OPf_SPECIAL;
12364 /* FALLTHROUGH */
12365 case OP_HSLICE:
12366 o->op_private |= OPpSLICE;
12367 break;
12368 case OP_AELEM:
12369 o->op_flags |= OPf_SPECIAL;
12370 /* FALLTHROUGH */
12371 case OP_HELEM:
12372 break;
12373 case OP_KVASLICE:
12374 o->op_flags |= OPf_SPECIAL;
12375 /* FALLTHROUGH */
12376 case OP_KVHSLICE:
12377 o->op_private |= OPpKVSLICE;
12378 break;
12379 default:
12380 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
12381 "element or slice");
12382 }
12383 if (kid->op_private & OPpLVAL_INTRO)
12384 o->op_private |= OPpLVAL_INTRO;
12385 op_null(kid);
12386 }
12387 return o;
12388 }
12389
12390 OP *
Perl_ck_eof(pTHX_ OP * o)12391 Perl_ck_eof(pTHX_ OP *o)
12392 {
12393 PERL_ARGS_ASSERT_CK_EOF;
12394
12395 if (o->op_flags & OPf_KIDS) {
12396 OP *kid;
12397 if (cLISTOPo->op_first->op_type == OP_STUB) {
12398 OP * const newop
12399 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
12400 op_free(o);
12401 o = newop;
12402 }
12403 o = ck_fun(o);
12404 kid = cLISTOPo->op_first;
12405 if (kid->op_type == OP_RV2GV)
12406 kid->op_private |= OPpALLOW_FAKE;
12407 }
12408 return o;
12409 }
12410
12411
12412 OP *
Perl_ck_eval(pTHX_ OP * o)12413 Perl_ck_eval(pTHX_ OP *o)
12414 {
12415
12416 PERL_ARGS_ASSERT_CK_EVAL;
12417
12418 PL_hints |= HINT_BLOCK_SCOPE;
12419 if(PL_prevailing_version != 0)
12420 PL_hints |= HINT_LOCALIZE_HH;
12421 if (o->op_flags & OPf_KIDS) {
12422 SVOP * const kid = cSVOPx(cUNOPo->op_first);
12423 assert(kid);
12424
12425 if (o->op_type == OP_ENTERTRY) {
12426 LOGOP *enter;
12427
12428 /* cut whole sibling chain free from o */
12429 op_sibling_splice(o, NULL, -1, NULL);
12430 op_free(o);
12431
12432 enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
12433
12434 /* establish postfix order */
12435 enter->op_next = (OP*)enter;
12436
12437 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
12438 OpTYPE_set(o, OP_LEAVETRY);
12439 enter->op_other = o;
12440 return o;
12441 }
12442 else {
12443 scalar((OP*)kid);
12444 S_set_haseval(aTHX);
12445 }
12446 }
12447 else {
12448 const U8 priv = o->op_private;
12449 op_free(o);
12450 /* the newUNOP will recursively call ck_eval(), which will handle
12451 * all the stuff at the end of this function, like adding
12452 * OP_HINTSEVAL
12453 */
12454 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
12455 }
12456 o->op_targ = (PADOFFSET)PL_hints;
12457 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
12458 if ((PL_hints & HINT_LOCALIZE_HH) != 0
12459 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
12460 /* Store a copy of %^H that pp_entereval can pick up. */
12461 HV *hh = hv_copy_hints_hv(GvHV(PL_hintgv));
12462 hv_stores(hh, "CORE/prevailing_version", newSVuv(PL_prevailing_version));
12463 OP *hhop;
12464 hhop = newSVOP(OP_HINTSEVAL, 0, MUTABLE_SV(hh));
12465 /* append hhop to only child */
12466 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
12467
12468 o->op_private |= OPpEVAL_HAS_HH;
12469 }
12470 if (!(o->op_private & OPpEVAL_BYTES)
12471 && FEATURE_UNIEVAL_IS_ENABLED)
12472 o->op_private |= OPpEVAL_UNICODE;
12473 return o;
12474 }
12475
12476 OP *
Perl_ck_trycatch(pTHX_ OP * o)12477 Perl_ck_trycatch(pTHX_ OP *o)
12478 {
12479 LOGOP *enter;
12480 OP *to_free = NULL;
12481 OP *trykid, *catchkid;
12482 OP *catchroot, *catchstart;
12483
12484 PERL_ARGS_ASSERT_CK_TRYCATCH;
12485
12486 trykid = cUNOPo->op_first;
12487 if(trykid->op_type == OP_NULL || trykid->op_type == OP_PUSHMARK) {
12488 to_free = trykid;
12489 trykid = OpSIBLING(trykid);
12490 }
12491 catchkid = OpSIBLING(trykid);
12492
12493 assert(trykid->op_type == OP_POPTRY);
12494 assert(catchkid->op_type == OP_CATCH);
12495
12496 /* cut whole sibling chain free from o */
12497 op_sibling_splice(o, NULL, -1, NULL);
12498 op_free(to_free);
12499 op_free(o);
12500
12501 enter = alloc_LOGOP(OP_ENTERTRYCATCH, NULL, NULL);
12502
12503 /* establish postfix order */
12504 enter->op_next = (OP*)enter;
12505
12506 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, trykid);
12507 op_append_elem(OP_LINESEQ, (OP*)o, catchkid);
12508
12509 OpTYPE_set(o, OP_LEAVETRYCATCH);
12510
12511 /* The returned optree is actually threaded up slightly nonobviously in
12512 * terms of its ->op_next pointers.
12513 *
12514 * This way, if the tryblock dies, its retop points at the OP_CATCH, but
12515 * if it does not then its leavetry skips over that and continues
12516 * execution past it.
12517 */
12518
12519 /* First, link up the actual body of the catch block */
12520 catchroot = OpSIBLING(cUNOPx(catchkid)->op_first);
12521 catchstart = LINKLIST(catchroot);
12522 cLOGOPx(catchkid)->op_other = catchstart;
12523
12524 o->op_next = LINKLIST(o);
12525
12526 /* die within try block should jump to the catch */
12527 enter->op_other = catchkid;
12528
12529 /* after try block that doesn't die, just skip straight to leavetrycatch */
12530 trykid->op_next = o;
12531
12532 /* after catch block, skip back up to the leavetrycatch */
12533 catchroot->op_next = o;
12534
12535 return o;
12536 }
12537
12538 OP *
Perl_ck_exec(pTHX_ OP * o)12539 Perl_ck_exec(pTHX_ OP *o)
12540 {
12541 PERL_ARGS_ASSERT_CK_EXEC;
12542
12543 if (o->op_flags & OPf_STACKED) {
12544 OP *kid;
12545 o = ck_fun(o);
12546 kid = OpSIBLING(cUNOPo->op_first);
12547 if (kid->op_type == OP_RV2GV)
12548 op_null(kid);
12549 }
12550 else
12551 o = listkids(o);
12552 return o;
12553 }
12554
12555 OP *
Perl_ck_exists(pTHX_ OP * o)12556 Perl_ck_exists(pTHX_ OP *o)
12557 {
12558 PERL_ARGS_ASSERT_CK_EXISTS;
12559
12560 o = ck_fun(o);
12561 if (o->op_flags & OPf_KIDS) {
12562 OP * const kid = cUNOPo->op_first;
12563 if (kid->op_type == OP_ENTERSUB) {
12564 (void) ref(kid, o->op_type);
12565 if (kid->op_type != OP_RV2CV
12566 && !(PL_parser && PL_parser->error_count))
12567 Perl_croak(aTHX_
12568 "exists argument is not a subroutine name");
12569 o->op_private |= OPpEXISTS_SUB;
12570 }
12571 else if (kid->op_type == OP_AELEM)
12572 o->op_flags |= OPf_SPECIAL;
12573 else if (kid->op_type != OP_HELEM)
12574 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
12575 "element or a subroutine");
12576 op_null(kid);
12577 }
12578 return o;
12579 }
12580
12581 OP *
Perl_ck_helemexistsor(pTHX_ OP * o)12582 Perl_ck_helemexistsor(pTHX_ OP *o)
12583 {
12584 PERL_ARGS_ASSERT_CK_HELEMEXISTSOR;
12585
12586 o = ck_fun(o);
12587
12588 OP *first;
12589 if(!(o->op_flags & OPf_KIDS) ||
12590 !(first = cLOGOPo->op_first) ||
12591 first->op_type != OP_HELEM)
12592 /* As this opcode isn't currently exposed to pure-perl, only core or XS
12593 * authors are ever going to see this message. We don't need to list it
12594 * in perldiag as to do so would require documenting OP_HELEMEXISTSOR
12595 * itself
12596 */
12597 /* diag_listed_as: SKIPME */
12598 croak("OP_HELEMEXISTSOR argument is not a HASH element");
12599
12600 OP *hvop = cBINOPx(first)->op_first;
12601 OP *keyop = OpSIBLING(hvop);
12602 assert(!OpSIBLING(keyop));
12603
12604 op_null(first); // null out the OP_HELEM
12605
12606 keyop->op_next = o;
12607
12608 return o;
12609 }
12610
12611 OP *
Perl_ck_rvconst(pTHX_ OP * o)12612 Perl_ck_rvconst(pTHX_ OP *o)
12613 {
12614 SVOP * const kid = cSVOPx(cUNOPo->op_first);
12615
12616 PERL_ARGS_ASSERT_CK_RVCONST;
12617
12618 if (o->op_type == OP_RV2HV)
12619 /* rv2hv steals the bottom bit for its own uses */
12620 o->op_private &= ~OPpARG1_MASK;
12621
12622 o->op_private |= (PL_hints & HINT_STRICT_REFS);
12623
12624 if (kid->op_type == OP_CONST) {
12625 int iscv;
12626 GV *gv;
12627 SV * const kidsv = kid->op_sv;
12628
12629 /* Is it a constant from cv_const_sv()? */
12630 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
12631 return o;
12632 }
12633 if (SvTYPE(kidsv) == SVt_PVAV) return o;
12634 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
12635 const char *badthing;
12636 switch (o->op_type) {
12637 case OP_RV2SV:
12638 badthing = "a SCALAR";
12639 break;
12640 case OP_RV2AV:
12641 badthing = "an ARRAY";
12642 break;
12643 case OP_RV2HV:
12644 badthing = "a HASH";
12645 break;
12646 default:
12647 badthing = NULL;
12648 break;
12649 }
12650 if (badthing)
12651 Perl_croak(aTHX_
12652 "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
12653 SVfARG(kidsv), badthing);
12654 }
12655 /*
12656 * This is a little tricky. We only want to add the symbol if we
12657 * didn't add it in the lexer. Otherwise we get duplicate strict
12658 * warnings. But if we didn't add it in the lexer, we must at
12659 * least pretend like we wanted to add it even if it existed before,
12660 * or we get possible typo warnings. OPpCONST_ENTERED says
12661 * whether the lexer already added THIS instance of this symbol.
12662 */
12663 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
12664 gv = gv_fetchsv(kidsv,
12665 o->op_type == OP_RV2CV
12666 && o->op_private & OPpMAY_RETURN_CONSTANT
12667 ? GV_NOEXPAND
12668 : iscv | !(kid->op_private & OPpCONST_ENTERED),
12669 iscv
12670 ? SVt_PVCV
12671 : o->op_type == OP_RV2SV
12672 ? SVt_PV
12673 : o->op_type == OP_RV2AV
12674 ? SVt_PVAV
12675 : o->op_type == OP_RV2HV
12676 ? SVt_PVHV
12677 : SVt_PVGV);
12678 if (gv) {
12679 if (!isGV(gv)) {
12680 assert(iscv);
12681 assert(SvROK(gv));
12682 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
12683 && SvTYPE(SvRV(gv)) != SVt_PVCV)
12684 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
12685 }
12686 OpTYPE_set(kid, OP_GV);
12687 SvREFCNT_dec(kid->op_sv);
12688 #ifdef USE_ITHREADS
12689 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
12690 STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
12691 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
12692 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
12693 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
12694 #else
12695 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
12696 #endif
12697 kid->op_private = 0;
12698 /* FAKE globs in the symbol table cause weird bugs (#77810) */
12699 SvFAKE_off(gv);
12700 }
12701 }
12702 return o;
12703 }
12704
12705 OP *
Perl_ck_ftst(pTHX_ OP * o)12706 Perl_ck_ftst(pTHX_ OP *o)
12707 {
12708 const I32 type = o->op_type;
12709
12710 PERL_ARGS_ASSERT_CK_FTST;
12711
12712 if (o->op_flags & OPf_REF) {
12713 NOOP;
12714 }
12715 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
12716 SVOP * const kid = cSVOPx(cUNOPo->op_first);
12717 const OPCODE kidtype = kid->op_type;
12718
12719 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
12720 && !kid->op_folded) {
12721 if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED) {
12722 no_bareword_filehandle(SvPVX(kSVOP_sv));
12723 }
12724 OP * const newop = newGVOP(type, OPf_REF,
12725 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
12726 op_free(o);
12727 return newop;
12728 }
12729
12730 if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
12731 SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
12732 if (name) {
12733 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
12734 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
12735 array_passed_to_stat, name);
12736 }
12737 else {
12738 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
12739 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
12740 }
12741 }
12742 scalar((OP *) kid);
12743 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
12744 o->op_private |= OPpFT_ACCESS;
12745 if (OP_IS_FILETEST(type)
12746 && OP_IS_FILETEST(kidtype)
12747 ) {
12748 o->op_private |= OPpFT_STACKED;
12749 kid->op_private |= OPpFT_STACKING;
12750 if (kidtype == OP_FTTTY && (
12751 !(kid->op_private & OPpFT_STACKED)
12752 || kid->op_private & OPpFT_AFTER_t
12753 ))
12754 o->op_private |= OPpFT_AFTER_t;
12755 }
12756 }
12757 else {
12758 op_free(o);
12759 if (type == OP_FTTTY)
12760 o = newGVOP(type, OPf_REF, PL_stdingv);
12761 else
12762 o = newUNOP(type, 0, newDEFSVOP());
12763 }
12764 return o;
12765 }
12766
12767 OP *
Perl_ck_fun(pTHX_ OP * o)12768 Perl_ck_fun(pTHX_ OP *o)
12769 {
12770 const int type = o->op_type;
12771 I32 oa = PL_opargs[type] >> OASHIFT;
12772
12773 PERL_ARGS_ASSERT_CK_FUN;
12774
12775 if (o->op_flags & OPf_STACKED) {
12776 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
12777 oa &= ~OA_OPTIONAL;
12778 else
12779 return no_fh_allowed(o);
12780 }
12781
12782 if (o->op_flags & OPf_KIDS) {
12783 OP *prev_kid = NULL;
12784 OP *kid = cLISTOPo->op_first;
12785 I32 numargs = 0;
12786 bool seen_optional = FALSE;
12787
12788 if (kid->op_type == OP_PUSHMARK ||
12789 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
12790 {
12791 prev_kid = kid;
12792 kid = OpSIBLING(kid);
12793 }
12794 if (kid && kid->op_type == OP_COREARGS) {
12795 bool optional = FALSE;
12796 while (oa) {
12797 numargs++;
12798 if (oa & OA_OPTIONAL) optional = TRUE;
12799 oa = oa >> 4;
12800 }
12801 if (optional) o->op_private |= numargs;
12802 return o;
12803 }
12804
12805 while (oa) {
12806 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
12807 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
12808 kid = newDEFSVOP();
12809 /* append kid to chain */
12810 op_sibling_splice(o, prev_kid, 0, kid);
12811 }
12812 seen_optional = TRUE;
12813 }
12814 if (!kid) break;
12815
12816 numargs++;
12817 switch (oa & 7) {
12818 case OA_SCALAR:
12819 /* list seen where single (scalar) arg expected? */
12820 if (numargs == 1 && !(oa >> 4)
12821 && kid->op_type == OP_LIST && type != OP_SCALAR)
12822 {
12823 return too_many_arguments_pv(o,PL_op_desc[type], 0);
12824 }
12825 if (type != OP_DELETE) scalar(kid);
12826 break;
12827 case OA_LIST:
12828 if (oa < 16) {
12829 kid = 0;
12830 continue;
12831 }
12832 else
12833 list(kid);
12834 break;
12835 case OA_AVREF:
12836 if ((type == OP_PUSH || type == OP_UNSHIFT)
12837 && !OpHAS_SIBLING(kid))
12838 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
12839 "Useless use of %s with no values",
12840 PL_op_desc[type]);
12841
12842 if (kid->op_type == OP_CONST
12843 && ( !SvROK(cSVOPx_sv(kid))
12844 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
12845 )
12846 bad_type_pv(numargs, "array", o, kid);
12847 else if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV
12848 || kid->op_type == OP_RV2GV) {
12849 bad_type_pv(1, "array", o, kid);
12850 }
12851 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
12852 yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
12853 PL_op_desc[type]), 0);
12854 }
12855 else {
12856 op_lvalue(kid, type);
12857 }
12858 break;
12859 case OA_HVREF:
12860 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
12861 bad_type_pv(numargs, "hash", o, kid);
12862 op_lvalue(kid, type);
12863 break;
12864 case OA_CVREF:
12865 {
12866 /* replace kid with newop in chain */
12867 OP * const newop =
12868 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
12869 newop->op_next = newop;
12870 kid = newop;
12871 }
12872 break;
12873 case OA_FILEREF:
12874 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
12875 if (kid->op_type == OP_CONST &&
12876 (kid->op_private & OPpCONST_BARE))
12877 {
12878 OP * const newop = newGVOP(OP_GV, 0,
12879 gv_fetchsv(kSVOP->op_sv, GV_ADD, SVt_PVIO));
12880 /* a first argument is handled by toke.c, ideally we'd
12881 just check here but several ops don't use ck_fun() */
12882 if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED) {
12883 no_bareword_filehandle(SvPVX(kSVOP_sv));
12884 }
12885 /* replace kid with newop in chain */
12886 op_sibling_splice(o, prev_kid, 1, newop);
12887 op_free(kid);
12888 kid = newop;
12889 }
12890 else if (kid->op_type == OP_READLINE) {
12891 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
12892 bad_type_pv(numargs, "HANDLE", o, kid);
12893 }
12894 else {
12895 I32 flags = OPf_SPECIAL;
12896 I32 priv = 0;
12897 PADOFFSET targ = 0;
12898
12899 /* is this op a FH constructor? */
12900 if (is_handle_constructor(o,numargs)) {
12901 const char *name = NULL;
12902 STRLEN len = 0;
12903 U32 name_utf8 = 0;
12904 bool want_dollar = TRUE;
12905
12906 flags = 0;
12907 /* Set a flag to tell rv2gv to vivify
12908 * need to "prove" flag does not mean something
12909 * else already - NI-S 1999/05/07
12910 */
12911 priv = OPpDEREF;
12912 if (kid->op_type == OP_PADSV) {
12913 PADNAME * const pn
12914 = PAD_COMPNAME_SV(kid->op_targ);
12915 name = PadnamePV (pn);
12916 len = PadnameLEN(pn);
12917 name_utf8 = PadnameUTF8(pn);
12918 }
12919 else if (kid->op_type == OP_RV2SV
12920 && kUNOP->op_first->op_type == OP_GV)
12921 {
12922 GV * const gv = cGVOPx_gv(kUNOP->op_first);
12923 name = GvNAME(gv);
12924 len = GvNAMELEN(gv);
12925 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
12926 }
12927 else if (kid->op_type == OP_AELEM
12928 || kid->op_type == OP_HELEM)
12929 {
12930 OP *firstop;
12931 OP *op = kBINOP->op_first;
12932 name = NULL;
12933 if (op) {
12934 SV *tmpstr = NULL;
12935 const char * const a =
12936 kid->op_type == OP_AELEM ?
12937 "[]" : "{}";
12938 if (((op->op_type == OP_RV2AV) ||
12939 (op->op_type == OP_RV2HV)) &&
12940 (firstop = cUNOPx(op)->op_first) &&
12941 (firstop->op_type == OP_GV)) {
12942 /* packagevar $a[] or $h{} */
12943 GV * const gv = cGVOPx_gv(firstop);
12944 if (gv)
12945 tmpstr =
12946 Perl_newSVpvf(aTHX_
12947 "%s%c...%c",
12948 GvNAME(gv),
12949 a[0], a[1]);
12950 }
12951 else if (op->op_type == OP_PADAV
12952 || op->op_type == OP_PADHV) {
12953 /* lexicalvar $a[] or $h{} */
12954 const char * const padname =
12955 PAD_COMPNAME_PV(op->op_targ);
12956 if (padname)
12957 tmpstr =
12958 Perl_newSVpvf(aTHX_
12959 "%s%c...%c",
12960 padname + 1,
12961 a[0], a[1]);
12962 }
12963 if (tmpstr) {
12964 name = SvPV_const(tmpstr, len);
12965 name_utf8 = SvUTF8(tmpstr);
12966 sv_2mortal(tmpstr);
12967 }
12968 }
12969 if (!name) {
12970 name = "__ANONIO__";
12971 len = 10;
12972 want_dollar = FALSE;
12973 }
12974 op_lvalue(kid, type);
12975 }
12976 if (name) {
12977 SV *namesv;
12978 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
12979 namesv = PAD_SVl(targ);
12980 if (want_dollar && *name != '$')
12981 sv_setpvs(namesv, "$");
12982 else
12983 SvPVCLEAR(namesv);
12984 sv_catpvn(namesv, name, len);
12985 if ( name_utf8 ) SvUTF8_on(namesv);
12986 }
12987 }
12988 scalar(kid);
12989 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
12990 OP_RV2GV, flags);
12991 kid->op_targ = targ;
12992 kid->op_private |= priv;
12993 }
12994 }
12995 scalar(kid);
12996 break;
12997 case OA_SCALARREF:
12998 if ((type == OP_UNDEF || type == OP_POS)
12999 && numargs == 1 && !(oa >> 4)
13000 && kid->op_type == OP_LIST)
13001 return too_many_arguments_pv(o,PL_op_desc[type], 0);
13002 op_lvalue(scalar(kid), type);
13003 break;
13004 }
13005 oa >>= 4;
13006 prev_kid = kid;
13007 kid = OpSIBLING(kid);
13008 }
13009 /* FIXME - should the numargs or-ing move after the too many
13010 * arguments check? */
13011 o->op_private |= numargs;
13012 if (kid)
13013 return too_many_arguments_pv(o,OP_DESC(o), 0);
13014 listkids(o);
13015 }
13016 else if (PL_opargs[type] & OA_DEFGV) {
13017 /* Ordering of these two is important to keep f_map.t passing. */
13018 op_free(o);
13019 return newUNOP(type, 0, newDEFSVOP());
13020 }
13021
13022 if (oa) {
13023 while (oa & OA_OPTIONAL)
13024 oa >>= 4;
13025 if (oa && oa != OA_LIST)
13026 return too_few_arguments_pv(o,OP_DESC(o), 0);
13027 }
13028 return o;
13029 }
13030
13031 OP *
Perl_ck_glob(pTHX_ OP * o)13032 Perl_ck_glob(pTHX_ OP *o)
13033 {
13034 GV *gv;
13035
13036 PERL_ARGS_ASSERT_CK_GLOB;
13037
13038 o = ck_fun(o);
13039 if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
13040 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
13041
13042 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
13043 {
13044 /* convert
13045 * glob
13046 * \ null - const(wildcard)
13047 * into
13048 * null
13049 * \ enter
13050 * \ list
13051 * \ mark - glob - rv2cv
13052 * | \ gv(CORE::GLOBAL::glob)
13053 * |
13054 * \ null - const(wildcard)
13055 */
13056 o->op_flags |= OPf_SPECIAL;
13057 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
13058 o = S_new_entersubop(aTHX_ gv, o);
13059 o = newUNOP(OP_NULL, 0, o);
13060 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
13061 return o;
13062 }
13063 else o->op_flags &= ~OPf_SPECIAL;
13064 #if !defined(PERL_EXTERNAL_GLOB)
13065 if (!PL_globhook) {
13066 ENTER;
13067 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
13068 newSVpvs("File::Glob"), NULL, NULL, NULL);
13069 LEAVE;
13070 }
13071 #endif /* !PERL_EXTERNAL_GLOB */
13072 gv = (GV *)newSV_type(SVt_NULL);
13073 gv_init(gv, 0, "", 0, 0);
13074 gv_IOadd(gv);
13075 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
13076 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
13077 scalarkids(o);
13078 return o;
13079 }
13080
13081 OP *
Perl_ck_grep(pTHX_ OP * o)13082 Perl_ck_grep(pTHX_ OP *o)
13083 {
13084 LOGOP *gwop;
13085 OP *kid;
13086 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
13087
13088 PERL_ARGS_ASSERT_CK_GREP;
13089
13090 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
13091
13092 if (o->op_flags & OPf_STACKED) {
13093 kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
13094 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
13095 return no_fh_allowed(o);
13096 o->op_flags &= ~OPf_STACKED;
13097 }
13098 kid = OpSIBLING(cLISTOPo->op_first);
13099 if (type == OP_MAPWHILE)
13100 list(kid);
13101 else
13102 scalar(kid);
13103 o = ck_fun(o);
13104 if (PL_parser && PL_parser->error_count)
13105 return o;
13106 kid = OpSIBLING(cLISTOPo->op_first);
13107 if (kid->op_type != OP_NULL)
13108 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
13109 kid = kUNOP->op_first;
13110
13111 gwop = alloc_LOGOP(type, o, LINKLIST(kid));
13112 kid->op_next = (OP*)gwop;
13113 o->op_private = gwop->op_private = 0;
13114 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
13115
13116 kid = OpSIBLING(cLISTOPo->op_first);
13117 for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
13118 op_lvalue(kid, OP_GREPSTART);
13119
13120 return (OP*)gwop;
13121 }
13122
13123 OP *
Perl_ck_index(pTHX_ OP * o)13124 Perl_ck_index(pTHX_ OP *o)
13125 {
13126 PERL_ARGS_ASSERT_CK_INDEX;
13127
13128 if (o->op_flags & OPf_KIDS) {
13129 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13130 if (kid)
13131 kid = OpSIBLING(kid); /* get past "big" */
13132 if (kid && kid->op_type == OP_CONST) {
13133 const bool save_taint = TAINT_get;
13134 SV *sv = kSVOP->op_sv;
13135 if ( (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
13136 && SvOK(sv) && !SvROK(sv))
13137 {
13138 sv = newSV_type(SVt_NULL);
13139 sv_copypv(sv, kSVOP->op_sv);
13140 SvREFCNT_dec_NN(kSVOP->op_sv);
13141 kSVOP->op_sv = sv;
13142 }
13143 if (SvOK(sv)) fbm_compile(sv, 0);
13144 TAINT_set(save_taint);
13145 #ifdef NO_TAINT_SUPPORT
13146 PERL_UNUSED_VAR(save_taint);
13147 #endif
13148 }
13149 }
13150 return ck_fun(o);
13151 }
13152
13153 OP *
Perl_ck_lfun(pTHX_ OP * o)13154 Perl_ck_lfun(pTHX_ OP *o)
13155 {
13156 const OPCODE type = o->op_type;
13157
13158 PERL_ARGS_ASSERT_CK_LFUN;
13159
13160 return modkids(ck_fun(o), type);
13161 }
13162
13163 OP *
Perl_ck_defined(pTHX_ OP * o)13164 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
13165 {
13166 PERL_ARGS_ASSERT_CK_DEFINED;
13167
13168 if ((o->op_flags & OPf_KIDS)) {
13169 switch (cUNOPo->op_first->op_type) {
13170 case OP_RV2AV:
13171 case OP_PADAV:
13172 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
13173 " (Maybe you should just omit the defined()?)");
13174 NOT_REACHED; /* NOTREACHED */
13175 break;
13176 case OP_RV2HV:
13177 case OP_PADHV:
13178 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
13179 " (Maybe you should just omit the defined()?)");
13180 NOT_REACHED; /* NOTREACHED */
13181 break;
13182 default:
13183 /* no warning */
13184 break;
13185 }
13186 }
13187 return ck_rfun(o);
13188 }
13189
13190 OP *
Perl_ck_readline(pTHX_ OP * o)13191 Perl_ck_readline(pTHX_ OP *o)
13192 {
13193 PERL_ARGS_ASSERT_CK_READLINE;
13194
13195 if (o->op_flags & OPf_KIDS) {
13196 OP *kid = cLISTOPo->op_first;
13197 if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED
13198 && kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
13199 no_bareword_filehandle(SvPVX(kSVOP_sv));
13200 }
13201 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
13202 scalar(kid);
13203 }
13204 else {
13205 OP * const newop
13206 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
13207 op_free(o);
13208 return newop;
13209 }
13210 return o;
13211 }
13212
13213 OP *
Perl_ck_rfun(pTHX_ OP * o)13214 Perl_ck_rfun(pTHX_ OP *o)
13215 {
13216 const OPCODE type = o->op_type;
13217
13218 PERL_ARGS_ASSERT_CK_RFUN;
13219
13220 return refkids(ck_fun(o), type);
13221 }
13222
13223 OP *
Perl_ck_listiob(pTHX_ OP * o)13224 Perl_ck_listiob(pTHX_ OP *o)
13225 {
13226 OP *kid;
13227
13228 PERL_ARGS_ASSERT_CK_LISTIOB;
13229
13230 kid = cLISTOPo->op_first;
13231 if (!kid) {
13232 o = op_force_list(o);
13233 kid = cLISTOPo->op_first;
13234 }
13235 if (kid->op_type == OP_PUSHMARK)
13236 kid = OpSIBLING(kid);
13237 if (kid && o->op_flags & OPf_STACKED)
13238 kid = OpSIBLING(kid);
13239 else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */
13240 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
13241 && !kid->op_folded) {
13242 if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED) {
13243 no_bareword_filehandle(SvPVX(kSVOP_sv));
13244 }
13245 o->op_flags |= OPf_STACKED; /* make it a filehandle */
13246 scalar(kid);
13247 /* replace old const op with new OP_RV2GV parent */
13248 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
13249 OP_RV2GV, OPf_REF);
13250 kid = OpSIBLING(kid);
13251 }
13252 }
13253
13254 if (!kid)
13255 op_append_elem(o->op_type, o, newDEFSVOP());
13256
13257 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
13258 return listkids(o);
13259 }
13260
13261 OP *
Perl_ck_smartmatch(pTHX_ OP * o)13262 Perl_ck_smartmatch(pTHX_ OP *o)
13263 {
13264 PERL_ARGS_ASSERT_CK_SMARTMATCH;
13265 if (0 == (o->op_flags & OPf_SPECIAL)) {
13266 OP *first = cBINOPo->op_first;
13267 OP *second = OpSIBLING(first);
13268
13269 /* Implicitly take a reference to an array or hash */
13270
13271 /* remove the original two siblings, then add back the
13272 * (possibly different) first and second sibs.
13273 */
13274 op_sibling_splice(o, NULL, 1, NULL);
13275 op_sibling_splice(o, NULL, 1, NULL);
13276 first = ref_array_or_hash(first);
13277 second = ref_array_or_hash(second);
13278 op_sibling_splice(o, NULL, 0, second);
13279 op_sibling_splice(o, NULL, 0, first);
13280
13281 /* Implicitly take a reference to a regular expression */
13282 if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
13283 OpTYPE_set(first, OP_QR);
13284 }
13285 if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
13286 OpTYPE_set(second, OP_QR);
13287 }
13288 }
13289
13290 return o;
13291 }
13292
13293
13294 static OP *
S_maybe_targlex(pTHX_ OP * o)13295 S_maybe_targlex(pTHX_ OP *o)
13296 {
13297 OP * const kid = cLISTOPo->op_first;
13298 /* has a disposable target? */
13299 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
13300 && !(kid->op_flags & OPf_STACKED)
13301 /* Cannot steal the second time! */
13302 && !(kid->op_private & OPpTARGET_MY)
13303 )
13304 {
13305 OP * const kkid = OpSIBLING(kid);
13306
13307 /* Can just relocate the target. */
13308 if (kkid && kkid->op_type == OP_PADSV) {
13309 if (kid->op_type == OP_EMPTYAVHV) {
13310 kid->op_flags |= kid->op_flags |
13311 (o->op_flags & (OPf_WANT|OPf_PARENS));
13312 kid->op_private |= OPpTARGET_MY |
13313 (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
13314 goto swipe_and_detach;
13315 } else if (!(kkid->op_private & OPpLVAL_INTRO)
13316 || (kkid->op_private & OPpPAD_STATE))
13317 {
13318 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
13319 /* give the lexical op the context of the parent sassign */
13320 kid->op_flags = (kid->op_flags & ~OPf_WANT)
13321 | (o->op_flags & OPf_WANT);
13322 swipe_and_detach:
13323 kid->op_targ = kkid->op_targ;
13324 kkid->op_targ = 0;
13325 /* Now we do not need PADSV and SASSIGN.
13326 * Detach kid and free the rest. */
13327 op_sibling_splice(o, NULL, 1, NULL);
13328 op_free(o);
13329 return kid;
13330 }
13331 }
13332 }
13333 return o;
13334 }
13335
13336 OP *
Perl_ck_sassign(pTHX_ OP * o)13337 Perl_ck_sassign(pTHX_ OP *o)
13338 {
13339 OP * const kid = cBINOPo->op_first;
13340
13341 PERL_ARGS_ASSERT_CK_SASSIGN;
13342
13343 if (OpHAS_SIBLING(kid)) {
13344 OP *kkid = OpSIBLING(kid);
13345 /* For state variable assignment with attributes, kkid is a list op
13346 whose op_last is a padsv. */
13347 if ((kkid->op_type == OP_PADSV ||
13348 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
13349 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
13350 )
13351 )
13352 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
13353 == (OPpLVAL_INTRO|OPpPAD_STATE)) {
13354 return S_newONCEOP(aTHX_ o, kkid);
13355 }
13356 }
13357 return S_maybe_targlex(aTHX_ o);
13358 }
13359
13360
13361 OP *
Perl_ck_match(pTHX_ OP * o)13362 Perl_ck_match(pTHX_ OP *o)
13363 {
13364 PERL_UNUSED_CONTEXT;
13365 PERL_ARGS_ASSERT_CK_MATCH;
13366
13367 return o;
13368 }
13369
13370 OP *
Perl_ck_method(pTHX_ OP * o)13371 Perl_ck_method(pTHX_ OP *o)
13372 {
13373 SV *sv, *methsv, *rclass;
13374 const char* method;
13375 char* compatptr;
13376 int utf8;
13377 STRLEN len, nsplit = 0, i;
13378 OP* new_op;
13379 OP * const kid = cUNOPo->op_first;
13380
13381 PERL_ARGS_ASSERT_CK_METHOD;
13382 if (kid->op_type != OP_CONST) return o;
13383
13384 sv = kSVOP->op_sv;
13385
13386 /* replace ' with :: */
13387 while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
13388 SvEND(sv) - SvPVX(sv) )))
13389 {
13390 *compatptr = ':';
13391 sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
13392 }
13393
13394 method = SvPVX_const(sv);
13395 len = SvCUR(sv);
13396 utf8 = SvUTF8(sv) ? -1 : 1;
13397
13398 for (i = len - 1; i > 0; --i) if (method[i] == ':') {
13399 nsplit = i+1;
13400 break;
13401 }
13402
13403 methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
13404
13405 if (!nsplit) { /* $proto->method() */
13406 op_free(o);
13407 return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
13408 }
13409
13410 if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
13411 op_free(o);
13412 return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
13413 }
13414
13415 /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
13416 if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
13417 rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
13418 new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
13419 } else {
13420 rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
13421 new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
13422 }
13423 #ifdef USE_ITHREADS
13424 op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
13425 #else
13426 cMETHOPx(new_op)->op_rclass_sv = rclass;
13427 #endif
13428 op_free(o);
13429 return new_op;
13430 }
13431
13432 OP *
Perl_ck_null(pTHX_ OP * o)13433 Perl_ck_null(pTHX_ OP *o)
13434 {
13435 PERL_ARGS_ASSERT_CK_NULL;
13436 PERL_UNUSED_CONTEXT;
13437 return o;
13438 }
13439
13440 OP *
Perl_ck_open(pTHX_ OP * o)13441 Perl_ck_open(pTHX_ OP *o)
13442 {
13443 PERL_ARGS_ASSERT_CK_OPEN;
13444
13445 S_io_hints(aTHX_ o);
13446 {
13447 /* In case of three-arg dup open remove strictness
13448 * from the last arg if it is a bareword. */
13449 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
13450 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
13451 OP *oa;
13452 const char *mode;
13453
13454 if ((last->op_type == OP_CONST) && /* The bareword. */
13455 (last->op_private & OPpCONST_BARE) &&
13456 (last->op_private & OPpCONST_STRICT) &&
13457 (oa = OpSIBLING(first)) && /* The fh. */
13458 (oa = OpSIBLING(oa)) && /* The mode. */
13459 (oa->op_type == OP_CONST) &&
13460 SvPOK(cSVOPx(oa)->op_sv) &&
13461 (mode = SvPVX_const(cSVOPx(oa)->op_sv)) &&
13462 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
13463 (last == OpSIBLING(oa))) /* The bareword. */
13464 last->op_private &= ~OPpCONST_STRICT;
13465 }
13466 return ck_fun(o);
13467 }
13468
13469 OP *
Perl_ck_prototype(pTHX_ OP * o)13470 Perl_ck_prototype(pTHX_ OP *o)
13471 {
13472 PERL_ARGS_ASSERT_CK_PROTOTYPE;
13473 if (!(o->op_flags & OPf_KIDS)) {
13474 op_free(o);
13475 return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
13476 }
13477 return o;
13478 }
13479
13480 OP *
Perl_ck_refassign(pTHX_ OP * o)13481 Perl_ck_refassign(pTHX_ OP *o)
13482 {
13483 OP * const right = cLISTOPo->op_first;
13484 OP * const left = OpSIBLING(right);
13485 OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
13486 bool stacked = 0;
13487
13488 PERL_ARGS_ASSERT_CK_REFASSIGN;
13489 assert (left);
13490 assert (left->op_type == OP_SREFGEN);
13491
13492 o->op_private = 0;
13493 /* we use OPpPAD_STATE in refassign to mean either of those things,
13494 * and the code assumes the two flags occupy the same bit position
13495 * in the various ops below */
13496 assert(OPpPAD_STATE == OPpOUR_INTRO);
13497
13498 switch (varop->op_type) {
13499 case OP_PADAV:
13500 o->op_private |= OPpLVREF_AV;
13501 goto settarg;
13502 case OP_PADHV:
13503 o->op_private |= OPpLVREF_HV;
13504 /* FALLTHROUGH */
13505 case OP_PADSV:
13506 settarg:
13507 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
13508 o->op_targ = varop->op_targ;
13509 if (!(o->op_private & (OPpPAD_STATE|OPpLVAL_INTRO)))
13510 varop->op_targ = 0;
13511 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
13512 break;
13513
13514 case OP_RV2AV:
13515 o->op_private |= OPpLVREF_AV;
13516 goto checkgv;
13517 NOT_REACHED; /* NOTREACHED */
13518 case OP_RV2HV:
13519 o->op_private |= OPpLVREF_HV;
13520 /* FALLTHROUGH */
13521 case OP_RV2SV:
13522 checkgv:
13523 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
13524 if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
13525 detach_and_stack:
13526 /* Point varop to its GV kid, detached. */
13527 varop = op_sibling_splice(varop, NULL, -1, NULL);
13528 stacked = TRUE;
13529 break;
13530 case OP_RV2CV: {
13531 OP * const kidparent =
13532 OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
13533 OP * const kid = cUNOPx(kidparent)->op_first;
13534 o->op_private |= OPpLVREF_CV;
13535 if (kid->op_type == OP_GV) {
13536 SV *sv = (SV*)cGVOPx_gv(kid);
13537 varop = kidparent;
13538 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
13539 /* a CVREF here confuses pp_refassign, so make sure
13540 it gets a GV */
13541 CV *const cv = (CV*)SvRV(sv);
13542 SV *name_sv = newSVhek_mortal(CvNAME_HEK(cv));
13543 (void)gv_init_sv((GV*)sv, CvSTASH(cv), name_sv, 0);
13544 assert(SvTYPE(sv) == SVt_PVGV);
13545 }
13546 goto detach_and_stack;
13547 }
13548 if (kid->op_type != OP_PADCV) goto bad;
13549 o->op_targ = kid->op_targ;
13550 kid->op_targ = 0;
13551 break;
13552 }
13553 case OP_AELEM:
13554 case OP_HELEM:
13555 o->op_private |= (varop->op_private & OPpLVAL_INTRO);
13556 o->op_private |= OPpLVREF_ELEM;
13557 op_null(varop);
13558 stacked = TRUE;
13559 /* Detach varop. */
13560 op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
13561 break;
13562 default:
13563 bad:
13564 /* diag_listed_as: Can't modify reference to %s in %s assignment */
13565 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
13566 "assignment",
13567 OP_DESC(varop)));
13568 return o;
13569 }
13570 if (!FEATURE_REFALIASING_IS_ENABLED)
13571 Perl_croak(aTHX_
13572 "Experimental aliasing via reference not enabled");
13573 Perl_ck_warner_d(aTHX_
13574 packWARN(WARN_EXPERIMENTAL__REFALIASING),
13575 "Aliasing via reference is experimental");
13576 if (stacked) {
13577 o->op_flags |= OPf_STACKED;
13578 op_sibling_splice(o, right, 1, varop);
13579 }
13580 else {
13581 o->op_flags &=~ OPf_STACKED;
13582 op_sibling_splice(o, right, 1, NULL);
13583 }
13584 if (o->op_private & OPpPAD_STATE && o->op_private & OPpLVAL_INTRO) {
13585 o = S_newONCEOP(aTHX_ o, varop);
13586 }
13587 op_free(left);
13588 return o;
13589 }
13590
13591 OP *
Perl_ck_repeat(pTHX_ OP * o)13592 Perl_ck_repeat(pTHX_ OP *o)
13593 {
13594 PERL_ARGS_ASSERT_CK_REPEAT;
13595
13596 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
13597 OP* kids;
13598 o->op_private |= OPpREPEAT_DOLIST;
13599 kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
13600 kids = op_force_list(kids); /* promote it to a list */
13601 op_sibling_splice(o, NULL, 0, kids); /* and add back */
13602 }
13603 else
13604 scalar(o);
13605 return o;
13606 }
13607
13608 OP *
Perl_ck_require(pTHX_ OP * o)13609 Perl_ck_require(pTHX_ OP *o)
13610 {
13611 GV* gv;
13612
13613 PERL_ARGS_ASSERT_CK_REQUIRE;
13614
13615 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
13616 SVOP * const kid = cSVOPx(cUNOPo->op_first);
13617 U32 hash;
13618 char *s;
13619 STRLEN len;
13620 if (kid->op_type == OP_CONST) {
13621 SV * const sv = kid->op_sv;
13622 U32 const was_readonly = SvREADONLY(sv);
13623 if (kid->op_private & OPpCONST_BARE) {
13624 const char *end;
13625 HEK *hek;
13626
13627 if (was_readonly) {
13628 SvREADONLY_off(sv);
13629 }
13630
13631 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
13632
13633 s = SvPVX(sv);
13634 len = SvCUR(sv);
13635 end = s + len;
13636 /* treat ::foo::bar as foo::bar */
13637 if (len >= 2 && s[0] == ':' && s[1] == ':')
13638 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
13639 if (s == end)
13640 DIE(aTHX_ "Bareword in require maps to empty filename");
13641
13642 for (; s < end; s++) {
13643 if (*s == ':' && s[1] == ':') {
13644 *s = '/';
13645 Move(s+2, s+1, end - s - 1, char);
13646 --end;
13647 }
13648 }
13649 SvEND_set(sv, end);
13650 sv_catpvs(sv, ".pm");
13651 PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
13652 hek = share_hek(SvPVX(sv),
13653 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
13654 hash);
13655 sv_sethek(sv, hek);
13656 unshare_hek(hek);
13657 SvFLAGS(sv) |= was_readonly;
13658 }
13659 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
13660 && !SvVOK(sv)) {
13661 s = SvPV(sv, len);
13662 if (SvREFCNT(sv) > 1) {
13663 kid->op_sv = newSVpvn_share(
13664 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
13665 SvREFCNT_dec_NN(sv);
13666 }
13667 else {
13668 HEK *hek;
13669 if (was_readonly) SvREADONLY_off(sv);
13670 PERL_HASH(hash, s, len);
13671 hek = share_hek(s,
13672 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
13673 hash);
13674 sv_sethek(sv, hek);
13675 unshare_hek(hek);
13676 SvFLAGS(sv) |= was_readonly;
13677 }
13678 }
13679 }
13680 }
13681
13682 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
13683 /* handle override, if any */
13684 && (gv = gv_override("require", 7))) {
13685 OP *kid, *newop;
13686 if (o->op_flags & OPf_KIDS) {
13687 kid = cUNOPo->op_first;
13688 op_sibling_splice(o, NULL, -1, NULL);
13689 }
13690 else {
13691 kid = newDEFSVOP();
13692 }
13693 op_free(o);
13694 newop = S_new_entersubop(aTHX_ gv, kid);
13695 return newop;
13696 }
13697
13698 return ck_fun(o);
13699 }
13700
13701 OP *
Perl_ck_return(pTHX_ OP * o)13702 Perl_ck_return(pTHX_ OP *o)
13703 {
13704 OP *kid;
13705
13706 PERL_ARGS_ASSERT_CK_RETURN;
13707
13708 if (o->op_flags & OPf_STACKED) {
13709 kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
13710 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
13711 yyerror("Missing comma after first argument to return");
13712 o->op_flags &= ~OPf_STACKED;
13713 }
13714
13715 kid = OpSIBLING(cLISTOPo->op_first);
13716 if (PL_compcv && CvLVALUE(PL_compcv)) {
13717 for (; kid; kid = OpSIBLING(kid))
13718 op_lvalue(kid, OP_LEAVESUBLV);
13719 }
13720
13721 return o;
13722 }
13723
13724 OP *
Perl_ck_select(pTHX_ OP * o)13725 Perl_ck_select(pTHX_ OP *o)
13726 {
13727 OP* kid;
13728
13729 PERL_ARGS_ASSERT_CK_SELECT;
13730
13731 if (o->op_flags & OPf_KIDS) {
13732 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13733 if (kid && OpHAS_SIBLING(kid)) {
13734 OpTYPE_set(o, OP_SSELECT);
13735 o = ck_fun(o);
13736 return fold_constants(op_integerize(op_std_init(o)));
13737 }
13738 }
13739 o = ck_fun(o);
13740 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13741 if (kid && kid->op_type == OP_RV2GV)
13742 kid->op_private &= ~HINT_STRICT_REFS;
13743 return o;
13744 }
13745
13746 OP *
Perl_ck_shift(pTHX_ OP * o)13747 Perl_ck_shift(pTHX_ OP *o)
13748 {
13749 const I32 type = o->op_type;
13750
13751 PERL_ARGS_ASSERT_CK_SHIFT;
13752
13753 if (!(o->op_flags & OPf_KIDS)) {
13754 OP *argop;
13755
13756 if (!CvUNIQUE(PL_compcv)) {
13757 o->op_flags |= OPf_SPECIAL;
13758 return o;
13759 }
13760
13761 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
13762 op_free(o);
13763 return newUNOP(type, 0, scalar(argop));
13764 }
13765 return scalar(ck_fun(o));
13766 }
13767
13768 OP *
Perl_ck_sort(pTHX_ OP * o)13769 Perl_ck_sort(pTHX_ OP *o)
13770 {
13771 OP *firstkid;
13772 OP *kid;
13773 U8 stacked;
13774
13775 PERL_ARGS_ASSERT_CK_SORT;
13776
13777 if (o->op_flags & OPf_STACKED)
13778 simplify_sort(o);
13779 firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13780
13781 if (!firstkid)
13782 return too_few_arguments_pv(o,OP_DESC(o), 0);
13783
13784 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
13785 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
13786
13787 /* if the first arg is a code block, process it and mark sort as
13788 * OPf_SPECIAL */
13789 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
13790 LINKLIST(kid);
13791 if (kid->op_type == OP_LEAVE)
13792 op_null(kid); /* wipe out leave */
13793 /* Prevent execution from escaping out of the sort block. */
13794 kid->op_next = 0;
13795
13796 /* provide scalar context for comparison function/block */
13797 kid = scalar(firstkid);
13798 kid->op_next = kid;
13799 o->op_flags |= OPf_SPECIAL;
13800 }
13801 else if (kid->op_type == OP_CONST
13802 && kid->op_private & OPpCONST_BARE) {
13803 char tmpbuf[256];
13804 STRLEN len;
13805 PADOFFSET off;
13806 const char * const name = SvPV(kSVOP_sv, len);
13807 *tmpbuf = '&';
13808 assert (len < 256);
13809 Copy(name, tmpbuf+1, len, char);
13810 off = pad_findmy_pvn(tmpbuf, len+1, 0);
13811 if (off != NOT_IN_PAD) {
13812 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
13813 SV * const fq =
13814 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
13815 sv_catpvs(fq, "::");
13816 sv_catsv(fq, kSVOP_sv);
13817 SvREFCNT_dec_NN(kSVOP_sv);
13818 kSVOP->op_sv = fq;
13819 }
13820 else {
13821 /* replace the const op with the pad op */
13822 op_sibling_splice(firstkid, NULL, 1,
13823 newPADxVOP(OP_PADCV, 0, off));
13824 op_free(kid);
13825 }
13826 }
13827 }
13828
13829 firstkid = OpSIBLING(firstkid);
13830 }
13831
13832 for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
13833 /* provide list context for arguments */
13834 list(kid);
13835 if (stacked)
13836 op_lvalue(kid, OP_GREPSTART);
13837 }
13838
13839 return o;
13840 }
13841
13842 /* for sort { X } ..., where X is one of
13843 * $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
13844 * elide the second child of the sort (the one containing X),
13845 * and set these flags as appropriate
13846 OPpSORT_NUMERIC;
13847 OPpSORT_INTEGER;
13848 OPpSORT_DESCEND;
13849 * Also, check and warn on lexical $a, $b.
13850 */
13851
13852 STATIC void
S_simplify_sort(pTHX_ OP * o)13853 S_simplify_sort(pTHX_ OP *o)
13854 {
13855 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13856 OP *k;
13857 int descending;
13858 GV *gv;
13859 const char *gvname;
13860 bool have_scopeop;
13861
13862 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
13863
13864 kid = kUNOP->op_first; /* get past null */
13865 if (!(have_scopeop = kid->op_type == OP_SCOPE)
13866 && kid->op_type != OP_LEAVE)
13867 return;
13868 kid = kLISTOP->op_last; /* get past scope */
13869 switch(kid->op_type) {
13870 case OP_NCMP:
13871 case OP_I_NCMP:
13872 case OP_SCMP:
13873 if (!have_scopeop) goto padkids;
13874 break;
13875 default:
13876 return;
13877 }
13878 k = kid; /* remember this node*/
13879 if (kBINOP->op_first->op_type != OP_RV2SV
13880 || kBINOP->op_last ->op_type != OP_RV2SV)
13881 {
13882 /*
13883 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
13884 then used in a comparison. This catches most, but not
13885 all cases. For instance, it catches
13886 sort { my($a); $a <=> $b }
13887 but not
13888 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
13889 (although why you'd do that is anyone's guess).
13890 */
13891
13892 padkids:
13893 if (!ckWARN(WARN_SYNTAX)) return;
13894 kid = kBINOP->op_first;
13895 do {
13896 if (kid->op_type == OP_PADSV) {
13897 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
13898 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
13899 && ( PadnamePV(name)[1] == 'a'
13900 || PadnamePV(name)[1] == 'b' ))
13901 /* diag_listed_as: "my %s" used in sort comparison */
13902 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13903 "\"%s %s\" used in sort comparison",
13904 PadnameIsSTATE(name)
13905 ? "state"
13906 : "my",
13907 PadnamePV(name));
13908 }
13909 } while ((kid = OpSIBLING(kid)));
13910 return;
13911 }
13912 kid = kBINOP->op_first; /* get past cmp */
13913 if (kUNOP->op_first->op_type != OP_GV)
13914 return;
13915 kid = kUNOP->op_first; /* get past rv2sv */
13916 gv = kGVOP_gv;
13917 if (GvSTASH(gv) != PL_curstash)
13918 return;
13919 gvname = GvNAME(gv);
13920 if (*gvname == 'a' && gvname[1] == '\0')
13921 descending = 0;
13922 else if (*gvname == 'b' && gvname[1] == '\0')
13923 descending = 1;
13924 else
13925 return;
13926
13927 kid = k; /* back to cmp */
13928 /* already checked above that it is rv2sv */
13929 kid = kBINOP->op_last; /* down to 2nd arg */
13930 if (kUNOP->op_first->op_type != OP_GV)
13931 return;
13932 kid = kUNOP->op_first; /* get past rv2sv */
13933 gv = kGVOP_gv;
13934 if (GvSTASH(gv) != PL_curstash)
13935 return;
13936 gvname = GvNAME(gv);
13937 if ( descending
13938 ? !(*gvname == 'a' && gvname[1] == '\0')
13939 : !(*gvname == 'b' && gvname[1] == '\0'))
13940 return;
13941 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
13942 if (descending)
13943 o->op_private |= OPpSORT_DESCEND;
13944 if (k->op_type == OP_NCMP)
13945 o->op_private |= OPpSORT_NUMERIC;
13946 if (k->op_type == OP_I_NCMP)
13947 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
13948 kid = OpSIBLING(cLISTOPo->op_first);
13949 /* cut out and delete old block (second sibling) */
13950 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
13951 op_free(kid);
13952 }
13953
13954 OP *
Perl_ck_split(pTHX_ OP * o)13955 Perl_ck_split(pTHX_ OP *o)
13956 {
13957 OP *kid;
13958 OP *sibs;
13959
13960 PERL_ARGS_ASSERT_CK_SPLIT;
13961
13962 assert(o->op_type == OP_LIST);
13963
13964 if (o->op_flags & OPf_STACKED)
13965 return no_fh_allowed(o);
13966
13967 kid = cLISTOPo->op_first;
13968 /* delete leading NULL node, then add a CONST if no other nodes */
13969 assert(kid->op_type == OP_NULL);
13970 op_sibling_splice(o, NULL, 1,
13971 OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
13972 op_free(kid);
13973 kid = cLISTOPo->op_first;
13974
13975 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
13976 /* remove match expression, and replace with new optree with
13977 * a match op at its head */
13978 op_sibling_splice(o, NULL, 1, NULL);
13979 /* pmruntime will handle split " " behavior with flag==2 */
13980 kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
13981 op_sibling_splice(o, NULL, 0, kid);
13982 }
13983
13984 assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
13985
13986 if (kPMOP->op_pmflags & PMf_GLOBAL) {
13987 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
13988 "Use of /g modifier is meaningless in split");
13989 }
13990
13991 /* eliminate the split op, and move the match op (plus any children)
13992 * into its place, then convert the match op into a split op. i.e.
13993 *
13994 * SPLIT MATCH SPLIT(ex-MATCH)
13995 * | | |
13996 * MATCH - A - B - C => R - A - B - C => R - A - B - C
13997 * | | |
13998 * R X - Y X - Y
13999 * |
14000 * X - Y
14001 *
14002 * (R, if it exists, will be a regcomp op)
14003 */
14004
14005 op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
14006 sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
14007 op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
14008 OpTYPE_set(kid, OP_SPLIT);
14009 kid->op_flags = (o->op_flags | (kid->op_flags & OPf_KIDS));
14010 kid->op_private = o->op_private;
14011 op_free(o);
14012 o = kid;
14013 kid = sibs; /* kid is now the string arg of the split */
14014
14015 if (!kid) {
14016 kid = newDEFSVOP();
14017 op_append_elem(OP_SPLIT, o, kid);
14018 }
14019 scalar(kid);
14020
14021 kid = OpSIBLING(kid);
14022 if (!kid) {
14023 kid = newSVOP(OP_CONST, 0, newSViv(0));
14024 op_append_elem(OP_SPLIT, o, kid);
14025 o->op_private |= OPpSPLIT_IMPLIM;
14026 }
14027 scalar(kid);
14028
14029 if (OpHAS_SIBLING(kid))
14030 return too_many_arguments_pv(o,OP_DESC(o), 0);
14031
14032 return o;
14033 }
14034
14035 OP *
Perl_ck_stringify(pTHX_ OP * o)14036 Perl_ck_stringify(pTHX_ OP *o)
14037 {
14038 OP * const kid = OpSIBLING(cUNOPo->op_first);
14039 PERL_ARGS_ASSERT_CK_STRINGIFY;
14040 if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
14041 || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
14042 || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
14043 && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
14044 {
14045 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
14046 op_free(o);
14047 return kid;
14048 }
14049 return ck_fun(o);
14050 }
14051
14052 OP *
Perl_ck_join(pTHX_ OP * o)14053 Perl_ck_join(pTHX_ OP *o)
14054 {
14055 OP * const kid = OpSIBLING(cLISTOPo->op_first);
14056
14057 PERL_ARGS_ASSERT_CK_JOIN;
14058
14059 if (kid && kid->op_type == OP_MATCH) {
14060 if (ckWARN(WARN_SYNTAX)) {
14061 const REGEXP *re = PM_GETRE(kPMOP);
14062 const SV *msg = re
14063 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
14064 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
14065 : newSVpvs_flags( "STRING", SVs_TEMP );
14066 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14067 "/%" SVf "/ should probably be written as \"%" SVf "\"",
14068 SVfARG(msg), SVfARG(msg));
14069 }
14070 }
14071 if (kid
14072 && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
14073 || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
14074 || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
14075 && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
14076 {
14077 const OP * const bairn = OpSIBLING(kid); /* the list */
14078 if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
14079 && OP_GIMME(bairn,0) == G_SCALAR)
14080 {
14081 OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
14082 op_sibling_splice(o, kid, 1, NULL));
14083 op_free(o);
14084 return ret;
14085 }
14086 }
14087
14088 return ck_fun(o);
14089 }
14090
14091 /*
14092 =for apidoc rv2cv_op_cv
14093
14094 Examines an op, which is expected to identify a subroutine at runtime,
14095 and attempts to determine at compile time which subroutine it identifies.
14096 This is normally used during Perl compilation to determine whether
14097 a prototype can be applied to a function call. C<cvop> is the op
14098 being considered, normally an C<rv2cv> op. A pointer to the identified
14099 subroutine is returned, if it could be determined statically, and a null
14100 pointer is returned if it was not possible to determine statically.
14101
14102 Currently, the subroutine can be identified statically if the RV that the
14103 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
14104 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
14105 suitable if the constant value must be an RV pointing to a CV. Details of
14106 this process may change in future versions of Perl. If the C<rv2cv> op
14107 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
14108 the subroutine statically: this flag is used to suppress compile-time
14109 magic on a subroutine call, forcing it to use default runtime behaviour.
14110
14111 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
14112 of a GV reference is modified. If a GV was examined and its CV slot was
14113 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
14114 If the op is not optimised away, and the CV slot is later populated with
14115 a subroutine having a prototype, that flag eventually triggers the warning
14116 "called too early to check prototype".
14117
14118 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
14119 of returning a pointer to the subroutine it returns a pointer to the
14120 GV giving the most appropriate name for the subroutine in this context.
14121 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
14122 (C<CvANON>) subroutine that is referenced through a GV it will be the
14123 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
14124 A null pointer is returned as usual if there is no statically-determinable
14125 subroutine.
14126
14127 =for apidoc Amnh||OPpEARLY_CV
14128 =for apidoc Amnh||OPpENTERSUB_AMPER
14129 =for apidoc Amnh||RV2CVOPCV_MARK_EARLY
14130 =for apidoc Amnh||RV2CVOPCV_RETURN_NAME_GV
14131
14132 =cut
14133 */
14134
14135 /* shared by toke.c:yylex */
14136 CV *
Perl_find_lexical_cv(pTHX_ PADOFFSET off)14137 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
14138 {
14139 const PADNAME *name = PAD_COMPNAME(off);
14140 CV *compcv = PL_compcv;
14141 while (PadnameOUTER(name)) {
14142 compcv = CvOUTSIDE(compcv);
14143 if (LIKELY(PARENT_PAD_INDEX(name))) {
14144 name = PadlistNAMESARRAY(CvPADLIST(compcv))
14145 [off = PARENT_PAD_INDEX(name)];
14146 }
14147 else {
14148 /* In an eval() in an inner scope like a function, the
14149 intermediate pad in the sub might not be populated with the
14150 sub. So search harder.
14151
14152 It is possible we won't find the name in this
14153 particular scope, but that's fine, if we don't we'll
14154 find it in some outer scope. Finding it here will let us
14155 go back to following the PARENT_PAD_INDEX() chain.
14156 */
14157 const PADNAMELIST * const names = PadlistNAMES(CvPADLIST(compcv));
14158 PADNAME * const * const name_p = PadnamelistARRAY(names);
14159 int offset;
14160 for (offset = PadnamelistMAXNAMED(names); offset > 0; offset--) {
14161 const PADNAME * const thisname = name_p[offset];
14162 /* The pv is copied from the outer PADNAME to the
14163 inner PADNAMEs so we don't need to compare the
14164 string contents
14165 */
14166 if (thisname && PadnameLEN(thisname) == PadnameLEN(name)
14167 && PadnamePV(thisname) == PadnamePV(name)) {
14168 name = thisname;
14169 break;
14170 }
14171 }
14172 }
14173 }
14174 assert(!PadnameIsOUR(name));
14175 if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
14176 return PadnamePROTOCV(name);
14177 }
14178 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
14179 }
14180
14181 CV *
Perl_rv2cv_op_cv(pTHX_ OP * cvop,U32 flags)14182 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
14183 {
14184 OP *rvop;
14185 CV *cv;
14186 GV *gv;
14187 PERL_ARGS_ASSERT_RV2CV_OP_CV;
14188 if (flags & ~RV2CVOPCV_FLAG_MASK)
14189 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
14190 if (cvop->op_type != OP_RV2CV)
14191 return NULL;
14192 if (cvop->op_private & OPpENTERSUB_AMPER)
14193 return NULL;
14194 if (!(cvop->op_flags & OPf_KIDS))
14195 return NULL;
14196 rvop = cUNOPx(cvop)->op_first;
14197 switch (rvop->op_type) {
14198 case OP_GV: {
14199 gv = cGVOPx_gv(rvop);
14200 if (!isGV(gv)) {
14201 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
14202 cv = MUTABLE_CV(SvRV(gv));
14203 gv = NULL;
14204 break;
14205 }
14206 if (flags & RV2CVOPCV_RETURN_STUB)
14207 return (CV *)gv;
14208 else return NULL;
14209 }
14210 cv = GvCVu(gv);
14211 if (!cv) {
14212 if (flags & RV2CVOPCV_MARK_EARLY)
14213 rvop->op_private |= OPpEARLY_CV;
14214 return NULL;
14215 }
14216 } break;
14217 case OP_CONST: {
14218 SV *rv = cSVOPx_sv(rvop);
14219 if (!SvROK(rv))
14220 return NULL;
14221 cv = (CV*)SvRV(rv);
14222 gv = NULL;
14223 } break;
14224 case OP_PADCV: {
14225 cv = find_lexical_cv(rvop->op_targ);
14226 gv = NULL;
14227 } break;
14228 default: {
14229 return NULL;
14230 } NOT_REACHED; /* NOTREACHED */
14231 }
14232 if (SvTYPE((SV*)cv) != SVt_PVCV)
14233 return NULL;
14234 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
14235 if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
14236 gv = CvGV(cv);
14237 return (CV*)gv;
14238 }
14239 else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
14240 if (CvLEXICAL(cv) || CvNAMED(cv))
14241 return NULL;
14242 if (!CvANON(cv) || !gv)
14243 gv = CvGV(cv);
14244 return (CV*)gv;
14245
14246 } else {
14247 return cv;
14248 }
14249 }
14250
14251 /*
14252 =for apidoc ck_entersub_args_list
14253
14254 Performs the default fixup of the arguments part of an C<entersub>
14255 op tree. This consists of applying list context to each of the
14256 argument ops. This is the standard treatment used on a call marked
14257 with C<&>, or a method call, or a call through a subroutine reference,
14258 or any other call where the callee can't be identified at compile time,
14259 or a call where the callee has no prototype.
14260
14261 =cut
14262 */
14263
14264 OP *
Perl_ck_entersub_args_list(pTHX_ OP * entersubop)14265 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
14266 {
14267 OP *aop;
14268
14269 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
14270
14271 aop = cUNOPx(entersubop)->op_first;
14272 if (!OpHAS_SIBLING(aop))
14273 aop = cUNOPx(aop)->op_first;
14274 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
14275 /* skip the extra attributes->import() call implicitly added in
14276 * something like foo(my $x : bar)
14277 */
14278 if ( aop->op_type == OP_ENTERSUB
14279 && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
14280 )
14281 continue;
14282 list(aop);
14283 op_lvalue(aop, OP_ENTERSUB);
14284 }
14285 return entersubop;
14286 }
14287
14288 /*
14289 =for apidoc ck_entersub_args_proto
14290
14291 Performs the fixup of the arguments part of an C<entersub> op tree
14292 based on a subroutine prototype. This makes various modifications to
14293 the argument ops, from applying context up to inserting C<refgen> ops,
14294 and checking the number and syntactic types of arguments, as directed by
14295 the prototype. This is the standard treatment used on a subroutine call,
14296 not marked with C<&>, where the callee can be identified at compile time
14297 and has a prototype.
14298
14299 C<protosv> supplies the subroutine prototype to be applied to the call.
14300 It may be a normal defined scalar, of which the string value will be used.
14301 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
14302 that has been cast to C<SV*>) which has a prototype. The prototype
14303 supplied, in whichever form, does not need to match the actual callee
14304 referenced by the op tree.
14305
14306 If the argument ops disagree with the prototype, for example by having
14307 an unacceptable number of arguments, a valid op tree is returned anyway.
14308 The error is reflected in the parser state, normally resulting in a single
14309 exception at the top level of parsing which covers all the compilation
14310 errors that occurred. In the error message, the callee is referred to
14311 by the name defined by the C<namegv> parameter.
14312
14313 =cut
14314 */
14315
14316 OP *
Perl_ck_entersub_args_proto(pTHX_ OP * entersubop,GV * namegv,SV * protosv)14317 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
14318 {
14319 STRLEN proto_len;
14320 const char *proto, *proto_end;
14321 OP *aop, *prev, *cvop, *parent;
14322 int optional = 0;
14323 I32 arg = 0;
14324 I32 contextclass = 0;
14325 const char *e = NULL;
14326 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
14327 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
14328 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
14329 "flags=%lx", (unsigned long) SvFLAGS(protosv));
14330 if (SvTYPE(protosv) == SVt_PVCV)
14331 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
14332 else proto = SvPV(protosv, proto_len);
14333 proto = S_strip_spaces(aTHX_ proto, &proto_len);
14334 proto_end = proto + proto_len;
14335 parent = entersubop;
14336 aop = cUNOPx(entersubop)->op_first;
14337 if (!OpHAS_SIBLING(aop)) {
14338 parent = aop;
14339 aop = cUNOPx(aop)->op_first;
14340 }
14341 prev = aop;
14342 aop = OpSIBLING(aop);
14343 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14344 while (aop != cvop) {
14345 OP* o3 = aop;
14346
14347 if (proto >= proto_end)
14348 {
14349 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
14350 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14351 SVfARG(namesv)), SvUTF8(namesv));
14352 return entersubop;
14353 }
14354
14355 switch (*proto) {
14356 case ';':
14357 optional = 1;
14358 proto++;
14359 continue;
14360 case '_':
14361 /* _ must be at the end */
14362 if (proto[1] && !memCHRs(";@%", proto[1]))
14363 goto oops;
14364 /* FALLTHROUGH */
14365 case '$':
14366 proto++;
14367 arg++;
14368 scalar(aop);
14369 break;
14370 case '%':
14371 case '@':
14372 list(aop);
14373 arg++;
14374 break;
14375 case '&':
14376 proto++;
14377 arg++;
14378 if ( o3->op_type != OP_UNDEF
14379 && o3->op_type != OP_ANONCODE
14380 && (o3->op_type != OP_SREFGEN
14381 || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
14382 != OP_ANONCODE
14383 && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
14384 != OP_RV2CV)))
14385 bad_type_gv(arg, namegv, o3,
14386 arg == 1 ? "block or sub {}" : "sub {}");
14387 break;
14388 case '*':
14389 /* '*' allows any scalar type, including bareword */
14390 proto++;
14391 arg++;
14392 if (o3->op_type == OP_RV2GV)
14393 goto wrapref; /* autoconvert GLOB -> GLOBref */
14394 else if (o3->op_type == OP_CONST)
14395 o3->op_private &= ~OPpCONST_STRICT;
14396 scalar(aop);
14397 break;
14398 case '+':
14399 proto++;
14400 arg++;
14401 if (o3->op_type == OP_RV2AV ||
14402 o3->op_type == OP_PADAV ||
14403 o3->op_type == OP_RV2HV ||
14404 o3->op_type == OP_PADHV
14405 ) {
14406 goto wrapref;
14407 }
14408 scalar(aop);
14409 break;
14410 case '[': case ']':
14411 goto oops;
14412
14413 case '\\':
14414 proto++;
14415 arg++;
14416 again:
14417 switch (*proto++) {
14418 case '[':
14419 if (contextclass++ == 0) {
14420 e = (char *) memchr(proto, ']', proto_end - proto);
14421 if (!e || e == proto)
14422 goto oops;
14423 }
14424 else
14425 goto oops;
14426 goto again;
14427
14428 case ']':
14429 if (contextclass) {
14430 const char *p = proto;
14431 const char *const end = proto;
14432 contextclass = 0;
14433 while (*--p != '[')
14434 /* \[$] accepts any scalar lvalue */
14435 if (*p == '$'
14436 && Perl_op_lvalue_flags(aTHX_
14437 scalar(o3),
14438 OP_READ, /* not entersub */
14439 OP_LVALUE_NO_CROAK
14440 )) goto wrapref;
14441 bad_type_gv(arg, namegv, o3,
14442 Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
14443 } else
14444 goto oops;
14445 break;
14446 case '*':
14447 if (o3->op_type == OP_RV2GV)
14448 goto wrapref;
14449 if (!contextclass)
14450 bad_type_gv(arg, namegv, o3, "symbol");
14451 break;
14452 case '&':
14453 if (o3->op_type == OP_ENTERSUB
14454 && !(o3->op_flags & OPf_STACKED))
14455 goto wrapref;
14456 if (!contextclass)
14457 bad_type_gv(arg, namegv, o3, "subroutine");
14458 break;
14459 case '$':
14460 if (o3->op_type == OP_RV2SV ||
14461 o3->op_type == OP_PADSV ||
14462 o3->op_type == OP_HELEM ||
14463 o3->op_type == OP_AELEM)
14464 goto wrapref;
14465 if (!contextclass) {
14466 /* \$ accepts any scalar lvalue */
14467 if (Perl_op_lvalue_flags(aTHX_
14468 scalar(o3),
14469 OP_READ, /* not entersub */
14470 OP_LVALUE_NO_CROAK
14471 )) goto wrapref;
14472 bad_type_gv(arg, namegv, o3, "scalar");
14473 }
14474 break;
14475 case '@':
14476 if (o3->op_type == OP_RV2AV ||
14477 o3->op_type == OP_PADAV)
14478 {
14479 o3->op_flags &=~ OPf_PARENS;
14480 goto wrapref;
14481 }
14482 if (!contextclass)
14483 bad_type_gv(arg, namegv, o3, "array");
14484 break;
14485 case '%':
14486 if (o3->op_type == OP_RV2HV ||
14487 o3->op_type == OP_PADHV)
14488 {
14489 o3->op_flags &=~ OPf_PARENS;
14490 goto wrapref;
14491 }
14492 if (!contextclass)
14493 bad_type_gv(arg, namegv, o3, "hash");
14494 break;
14495 wrapref:
14496 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
14497 OP_REFGEN, 0);
14498 if (contextclass && e) {
14499 proto = e + 1;
14500 contextclass = 0;
14501 }
14502 break;
14503 default: goto oops;
14504 }
14505 if (contextclass)
14506 goto again;
14507 break;
14508 case ' ':
14509 proto++;
14510 continue;
14511 default:
14512 oops: {
14513 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
14514 SVfARG(cv_name((CV *)namegv, NULL, 0)),
14515 SVfARG(protosv));
14516 }
14517 }
14518
14519 op_lvalue(aop, OP_ENTERSUB);
14520 prev = aop;
14521 aop = OpSIBLING(aop);
14522 }
14523 if (aop == cvop && *proto == '_') {
14524 /* generate an access to $_ */
14525 op_sibling_splice(parent, prev, 0, newDEFSVOP());
14526 }
14527 if (!optional && proto_end > proto &&
14528 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
14529 {
14530 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
14531 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
14532 SVfARG(namesv)), SvUTF8(namesv));
14533 }
14534 return entersubop;
14535 }
14536
14537 /*
14538 =for apidoc ck_entersub_args_proto_or_list
14539
14540 Performs the fixup of the arguments part of an C<entersub> op tree either
14541 based on a subroutine prototype or using default list-context processing.
14542 This is the standard treatment used on a subroutine call, not marked
14543 with C<&>, where the callee can be identified at compile time.
14544
14545 C<protosv> supplies the subroutine prototype to be applied to the call,
14546 or indicates that there is no prototype. It may be a normal scalar,
14547 in which case if it is defined then the string value will be used
14548 as a prototype, and if it is undefined then there is no prototype.
14549 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
14550 that has been cast to C<SV*>), of which the prototype will be used if it
14551 has one. The prototype (or lack thereof) supplied, in whichever form,
14552 does not need to match the actual callee referenced by the op tree.
14553
14554 If the argument ops disagree with the prototype, for example by having
14555 an unacceptable number of arguments, a valid op tree is returned anyway.
14556 The error is reflected in the parser state, normally resulting in a single
14557 exception at the top level of parsing which covers all the compilation
14558 errors that occurred. In the error message, the callee is referred to
14559 by the name defined by the C<namegv> parameter.
14560
14561 =cut
14562 */
14563
14564 OP *
Perl_ck_entersub_args_proto_or_list(pTHX_ OP * entersubop,GV * namegv,SV * protosv)14565 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
14566 GV *namegv, SV *protosv)
14567 {
14568 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
14569 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
14570 return ck_entersub_args_proto(entersubop, namegv, protosv);
14571 else
14572 return ck_entersub_args_list(entersubop);
14573 }
14574
14575 OP *
Perl_ck_entersub_args_core(pTHX_ OP * entersubop,GV * namegv,SV * protosv)14576 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
14577 {
14578 IV cvflags = SvIVX(protosv);
14579 int opnum = cvflags & 0xffff;
14580 OP *aop = cUNOPx(entersubop)->op_first;
14581
14582 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
14583
14584 if (!opnum) {
14585 OP *cvop;
14586 if (!OpHAS_SIBLING(aop))
14587 aop = cUNOPx(aop)->op_first;
14588 aop = OpSIBLING(aop);
14589 for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14590 if (aop != cvop) {
14591 SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
14592 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14593 SVfARG(namesv)), SvUTF8(namesv));
14594 }
14595
14596 op_free(entersubop);
14597 switch(cvflags >> 16) {
14598 case 'C': /* __CLASS__ */
14599 return newOP(OP_CLASSNAME, 0);
14600 case 'F': /* __FILE__ */
14601 return newSVOP(OP_CONST, 0,
14602 newSVpv(CopFILE(PL_curcop),0));
14603 case 'L': /* __LINE__ */
14604 return newSVOP(OP_CONST, 0,
14605 Perl_newSVpvf(aTHX_ "%" LINE_Tf, CopLINE(PL_curcop)));
14606 case 'P': /* __PACKAGE__ */
14607 return newSVOP(OP_CONST, 0,
14608 (PL_curstash
14609 ? newSVhek(HvNAME_HEK(PL_curstash))
14610 : &PL_sv_undef));
14611 }
14612 NOT_REACHED; /* NOTREACHED */
14613 }
14614 else {
14615 OP *prev, *cvop, *first, *parent;
14616 U32 flags = 0;
14617
14618 parent = entersubop;
14619 if (!OpHAS_SIBLING(aop)) {
14620 parent = aop;
14621 aop = cUNOPx(aop)->op_first;
14622 }
14623
14624 first = prev = aop;
14625 aop = OpSIBLING(aop);
14626 /* find last sibling */
14627 for (cvop = aop;
14628 OpHAS_SIBLING(cvop);
14629 prev = cvop, cvop = OpSIBLING(cvop))
14630 ;
14631 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
14632 /* Usually, OPf_SPECIAL on an op with no args means that it had
14633 * parens, but these have their own meaning for that flag: */
14634 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
14635 && opnum != OP_DELETE && opnum != OP_EXISTS)
14636 flags |= OPf_SPECIAL;
14637 /* excise cvop from end of sibling chain */
14638 op_sibling_splice(parent, prev, 1, NULL);
14639 op_free(cvop);
14640 if (aop == cvop) aop = NULL;
14641
14642 /* detach remaining siblings from the first sibling, then
14643 * dispose of original optree */
14644
14645 if (aop)
14646 op_sibling_splice(parent, first, -1, NULL);
14647 op_free(entersubop);
14648
14649 if (cvflags == (OP_ENTEREVAL | (1<<16)))
14650 flags |= OPpEVAL_BYTES <<8;
14651
14652 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
14653 case OA_UNOP:
14654 case OA_BASEOP_OR_UNOP:
14655 case OA_FILESTATOP:
14656 if (!aop)
14657 return newOP(opnum,flags); /* zero args */
14658 if (aop == prev)
14659 return newUNOP(opnum,flags,aop); /* one arg */
14660 /* too many args */
14661 /* FALLTHROUGH */
14662 case OA_BASEOP:
14663 if (aop) {
14664 SV *namesv;
14665 OP *nextop;
14666
14667 namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
14668 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14669 SVfARG(namesv)), SvUTF8(namesv));
14670 while (aop) {
14671 nextop = OpSIBLING(aop);
14672 op_free(aop);
14673 aop = nextop;
14674 }
14675
14676 }
14677 return opnum == OP_RUNCV
14678 ? newSVOP(OP_RUNCV, 0, &PL_sv_undef)
14679 : newOP(opnum,0);
14680 default:
14681 return op_convert_list(opnum,0,aop);
14682 }
14683 }
14684 NOT_REACHED; /* NOTREACHED */
14685 return entersubop;
14686 }
14687
14688 /*
14689 =for apidoc cv_get_call_checker_flags
14690
14691 Retrieves the function that will be used to fix up a call to C<cv>.
14692 Specifically, the function is applied to an C<entersub> op tree for a
14693 subroutine call, not marked with C<&>, where the callee can be identified
14694 at compile time as C<cv>.
14695
14696 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
14697 for it is returned in C<*ckobj_p>, and control flags are returned in
14698 C<*ckflags_p>. The function is intended to be called in this manner:
14699
14700 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
14701
14702 In this call, C<entersubop> is a pointer to the C<entersub> op,
14703 which may be replaced by the check function, and C<namegv> supplies
14704 the name that should be used by the check function to refer
14705 to the callee of the C<entersub> op if it needs to emit any diagnostics.
14706 It is permitted to apply the check function in non-standard situations,
14707 such as to a call to a different subroutine or to a method call.
14708
14709 C<namegv> may not actually be a GV. If the C<CALL_CHECKER_REQUIRE_GV>
14710 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
14711 instead, anything that can be used as the first argument to L</cv_name>.
14712 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
14713 check function requires C<namegv> to be a genuine GV.
14714
14715 By default, the check function is
14716 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
14717 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
14718 flag is clear. This implements standard prototype processing. It can
14719 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
14720
14721 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
14722 indicates that the caller only knows about the genuine GV version of
14723 C<namegv>, and accordingly the corresponding bit will always be set in
14724 C<*ckflags_p>, regardless of the check function's recorded requirements.
14725 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
14726 indicates the caller knows about the possibility of passing something
14727 other than a GV as C<namegv>, and accordingly the corresponding bit may
14728 be either set or clear in C<*ckflags_p>, indicating the check function's
14729 recorded requirements.
14730
14731 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
14732 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
14733 (for which see above). All other bits should be clear.
14734
14735 =for apidoc Amnh||CALL_CHECKER_REQUIRE_GV
14736
14737 =for apidoc cv_get_call_checker
14738
14739 The original form of L</cv_get_call_checker_flags>, which does not return
14740 checker flags. When using a checker function returned by this function,
14741 it is only safe to call it with a genuine GV as its C<namegv> argument.
14742
14743 =cut
14744 */
14745
14746 void
Perl_cv_get_call_checker_flags(pTHX_ CV * cv,U32 gflags,Perl_call_checker * ckfun_p,SV ** ckobj_p,U32 * ckflags_p)14747 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
14748 Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
14749 {
14750 MAGIC *callmg;
14751 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
14752 PERL_UNUSED_CONTEXT;
14753 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
14754 if (callmg) {
14755 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
14756 *ckobj_p = callmg->mg_obj;
14757 *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
14758 } else {
14759 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
14760 *ckobj_p = (SV*)cv;
14761 *ckflags_p = gflags & MGf_REQUIRE_GV;
14762 }
14763 }
14764
14765 void
Perl_cv_get_call_checker(pTHX_ CV * cv,Perl_call_checker * ckfun_p,SV ** ckobj_p)14766 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
14767 {
14768 U32 ckflags;
14769 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
14770 PERL_UNUSED_CONTEXT;
14771 cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
14772 &ckflags);
14773 }
14774
14775 /*
14776 =for apidoc cv_set_call_checker_flags
14777
14778 Sets the function that will be used to fix up a call to C<cv>.
14779 Specifically, the function is applied to an C<entersub> op tree for a
14780 subroutine call, not marked with C<&>, where the callee can be identified
14781 at compile time as C<cv>.
14782
14783 The C-level function pointer is supplied in C<ckfun>, an SV argument for
14784 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
14785 The function should be defined like this:
14786
14787 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
14788
14789 It is intended to be called in this manner:
14790
14791 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
14792
14793 In this call, C<entersubop> is a pointer to the C<entersub> op,
14794 which may be replaced by the check function, and C<namegv> supplies
14795 the name that should be used by the check function to refer
14796 to the callee of the C<entersub> op if it needs to emit any diagnostics.
14797 It is permitted to apply the check function in non-standard situations,
14798 such as to a call to a different subroutine or to a method call.
14799
14800 C<namegv> may not actually be a GV. For efficiency, perl may pass a
14801 CV or other SV instead. Whatever is passed can be used as the first
14802 argument to L</cv_name>. You can force perl to pass a GV by including
14803 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
14804
14805 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
14806 bit currently has a defined meaning (for which see above). All other
14807 bits should be clear.
14808
14809 The current setting for a particular CV can be retrieved by
14810 L</cv_get_call_checker_flags>.
14811
14812 =for apidoc cv_set_call_checker
14813
14814 The original form of L</cv_set_call_checker_flags>, which passes it the
14815 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility. The effect
14816 of that flag setting is that the check function is guaranteed to get a
14817 genuine GV as its C<namegv> argument.
14818
14819 =cut
14820 */
14821
14822 void
Perl_cv_set_call_checker(pTHX_ CV * cv,Perl_call_checker ckfun,SV * ckobj)14823 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
14824 {
14825 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
14826 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
14827 }
14828
14829 void
Perl_cv_set_call_checker_flags(pTHX_ CV * cv,Perl_call_checker ckfun,SV * ckobj,U32 ckflags)14830 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
14831 SV *ckobj, U32 ckflags)
14832 {
14833 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
14834 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
14835 if (SvMAGICAL((SV*)cv))
14836 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
14837 } else {
14838 MAGIC *callmg;
14839 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
14840 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
14841 assert(callmg);
14842 if (callmg->mg_flags & MGf_REFCOUNTED) {
14843 SvREFCNT_dec(callmg->mg_obj);
14844 callmg->mg_flags &= ~MGf_REFCOUNTED;
14845 }
14846 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
14847 callmg->mg_obj = ckobj;
14848 if (ckobj != (SV*)cv) {
14849 SvREFCNT_inc_simple_void_NN(ckobj);
14850 callmg->mg_flags |= MGf_REFCOUNTED;
14851 }
14852 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
14853 | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
14854 }
14855 }
14856
14857 static void
S_entersub_alloc_targ(pTHX_ OP * const o)14858 S_entersub_alloc_targ(pTHX_ OP * const o)
14859 {
14860 o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
14861 o->op_private |= OPpENTERSUB_HASTARG;
14862 }
14863
14864 OP *
Perl_ck_subr(pTHX_ OP * o)14865 Perl_ck_subr(pTHX_ OP *o)
14866 {
14867 OP *aop, *cvop;
14868 CV *cv;
14869 GV *namegv;
14870 SV **const_class = NULL;
14871 OP *const_op = NULL;
14872
14873 PERL_ARGS_ASSERT_CK_SUBR;
14874
14875 aop = cUNOPx(o)->op_first;
14876 if (!OpHAS_SIBLING(aop))
14877 aop = cUNOPx(aop)->op_first;
14878 aop = OpSIBLING(aop);
14879 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14880 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
14881 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
14882
14883 o->op_private &= ~1;
14884 o->op_private |= (PL_hints & HINT_STRICT_REFS);
14885 if (PERLDB_SUB && PL_curstash != PL_debstash)
14886 o->op_private |= OPpENTERSUB_DB;
14887 switch (cvop->op_type) {
14888 case OP_RV2CV:
14889 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
14890 op_null(cvop);
14891 break;
14892 case OP_METHOD:
14893 case OP_METHOD_NAMED:
14894 case OP_METHOD_SUPER:
14895 case OP_METHOD_REDIR:
14896 case OP_METHOD_REDIR_SUPER:
14897 o->op_flags |= OPf_REF;
14898 if (aop->op_type == OP_CONST) {
14899 aop->op_private &= ~OPpCONST_STRICT;
14900 const_class = &cSVOPx(aop)->op_sv;
14901 const_op = aop;
14902 }
14903 else if (aop->op_type == OP_LIST) {
14904 OP * const sib = OpSIBLING(cUNOPx(aop)->op_first);
14905 if (sib && sib->op_type == OP_CONST) {
14906 sib->op_private &= ~OPpCONST_STRICT;
14907 const_class = &cSVOPx(sib)->op_sv;
14908 const_op = sib;
14909 }
14910 }
14911 /* make class name a shared cow string to speedup method calls */
14912 /* constant string might be replaced with object, f.e. bigint */
14913 if (const_class && SvPOK(*const_class)) {
14914 assert(const_op);
14915 STRLEN len;
14916 const char* str = SvPV(*const_class, len);
14917 if (len) {
14918 if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED
14919 && !is_standard_filehandle_name(str)
14920 && (const_op->op_private & OPpCONST_BARE)) {
14921 cvop->op_private |= OPpMETH_NO_BAREWORD_IO;
14922 }
14923
14924 SV* const shared = newSVpvn_share(
14925 str, SvUTF8(*const_class)
14926 ? -(SSize_t)len : (SSize_t)len,
14927 0
14928 );
14929 if (SvREADONLY(*const_class))
14930 SvREADONLY_on(shared);
14931 SvREFCNT_dec(*const_class);
14932 *const_class = shared;
14933 }
14934 }
14935 break;
14936 }
14937
14938 if (!cv) {
14939 S_entersub_alloc_targ(aTHX_ o);
14940 return ck_entersub_args_list(o);
14941 } else {
14942 Perl_call_checker ckfun;
14943 SV *ckobj;
14944 U32 ckflags;
14945 cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
14946 if (CvISXSUB(cv) || !CvROOT(cv))
14947 S_entersub_alloc_targ(aTHX_ o);
14948 if (!namegv) {
14949 /* The original call checker API guarantees that a GV will
14950 be provided with the right name. So, if the old API was
14951 used (or the REQUIRE_GV flag was passed), we have to reify
14952 the CV’s GV, unless this is an anonymous sub. This is not
14953 ideal for lexical subs, as its stringification will include
14954 the package. But it is the best we can do. */
14955 if (ckflags & CALL_CHECKER_REQUIRE_GV) {
14956 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
14957 namegv = CvGV(cv);
14958 }
14959 else namegv = MUTABLE_GV(cv);
14960 /* After a syntax error in a lexical sub, the cv that
14961 rv2cv_op_cv returns may be a nameless stub. */
14962 if (!namegv) return ck_entersub_args_list(o);
14963
14964 }
14965 return ckfun(aTHX_ o, namegv, ckobj);
14966 }
14967 }
14968
14969 OP *
Perl_ck_svconst(pTHX_ OP * o)14970 Perl_ck_svconst(pTHX_ OP *o)
14971 {
14972 SV * const sv = cSVOPo->op_sv;
14973 PERL_ARGS_ASSERT_CK_SVCONST;
14974 PERL_UNUSED_CONTEXT;
14975 #ifdef PERL_COPY_ON_WRITE
14976 /* Since the read-only flag may be used to protect a string buffer, we
14977 cannot do copy-on-write with existing read-only scalars that are not
14978 already copy-on-write scalars. To allow $_ = "hello" to do COW with
14979 that constant, mark the constant as COWable here, if it is not
14980 already read-only. */
14981 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
14982 SvIsCOW_on(sv);
14983 CowREFCNT(sv) = 0;
14984 # ifdef PERL_DEBUG_READONLY_COW
14985 sv_buf_to_ro(sv);
14986 # endif
14987 }
14988 #endif
14989 SvREADONLY_on(sv);
14990 return o;
14991 }
14992
14993 OP *
Perl_ck_trunc(pTHX_ OP * o)14994 Perl_ck_trunc(pTHX_ OP *o)
14995 {
14996 PERL_ARGS_ASSERT_CK_TRUNC;
14997
14998 if (o->op_flags & OPf_KIDS) {
14999 SVOP *kid = cSVOPx(cUNOPo->op_first);
15000
15001 if (kid->op_type == OP_NULL)
15002 kid = cSVOPx(OpSIBLING(kid));
15003 if (kid && kid->op_type == OP_CONST &&
15004 (kid->op_private & OPpCONST_BARE) &&
15005 !kid->op_folded)
15006 {
15007 o->op_flags |= OPf_SPECIAL;
15008 kid->op_private &= ~OPpCONST_STRICT;
15009 if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED) {
15010 no_bareword_filehandle(SvPVX(cSVOPx_sv(kid)));
15011 }
15012 }
15013 }
15014 return ck_fun(o);
15015 }
15016
15017 OP *
Perl_ck_substr(pTHX_ OP * o)15018 Perl_ck_substr(pTHX_ OP *o)
15019 {
15020 PERL_ARGS_ASSERT_CK_SUBSTR;
15021
15022 o = ck_fun(o);
15023 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
15024 OP *kid = cLISTOPo->op_first;
15025
15026 if (kid->op_type == OP_NULL)
15027 kid = OpSIBLING(kid);
15028 if (kid)
15029 /* Historically, substr(delete $foo{bar},...) has been allowed
15030 with 4-arg substr. Keep it working by applying entersub
15031 lvalue context. */
15032 op_lvalue(kid, OP_ENTERSUB);
15033
15034 }
15035 return o;
15036 }
15037
15038 OP *
Perl_ck_tell(pTHX_ OP * o)15039 Perl_ck_tell(pTHX_ OP *o)
15040 {
15041 PERL_ARGS_ASSERT_CK_TELL;
15042 o = ck_fun(o);
15043 if (o->op_flags & OPf_KIDS) {
15044 OP *kid = cLISTOPo->op_first;
15045 if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
15046 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
15047 }
15048 return o;
15049 }
15050
15051 PERL_STATIC_INLINE OP *
S_last_non_null_kid(OP * o)15052 S_last_non_null_kid(OP *o) {
15053 OP *last = NULL;
15054 if (cUNOPo->op_flags & OPf_KIDS) {
15055 OP *k = cLISTOPo->op_first;
15056 while (k) {
15057 if (k->op_type != OP_NULL) {
15058 last = k;
15059 }
15060 k = OpSIBLING(k);
15061 }
15062 }
15063
15064 return last;
15065 }
15066
15067 OP *
Perl_ck_each(pTHX_ OP * o)15068 Perl_ck_each(pTHX_ OP *o)
15069 {
15070 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
15071 const unsigned orig_type = o->op_type;
15072
15073 PERL_ARGS_ASSERT_CK_EACH;
15074
15075 if (kid) {
15076 switch (kid->op_type) {
15077 case OP_PADHV:
15078 break;
15079
15080 case OP_RV2HV:
15081 /* Catch out an anonhash here, since the behaviour might be
15082 * confusing.
15083 *
15084 * The typical tree is:
15085 *
15086 * rv2hv
15087 * scope
15088 * null
15089 * anonhash
15090 *
15091 * If the contents of the block is more complex you might get:
15092 *
15093 * rv2hv
15094 * leave
15095 * enter
15096 * ...
15097 * anonhash
15098 *
15099 * Similarly for the anonlist version below.
15100 */
15101 if (orig_type == OP_EACH &&
15102 ckWARN(WARN_SYNTAX) &&
15103 (cUNOPx(kid)->op_flags & OPf_KIDS) &&
15104 ( cUNOPx(kid)->op_first->op_type == OP_SCOPE ||
15105 cUNOPx(kid)->op_first->op_type == OP_LEAVE) &&
15106 (cUNOPx(kid)->op_first->op_flags & OPf_KIDS)) {
15107 /* look for last non-null kid, since we might have:
15108 each %{ some code ; +{ anon hash } }
15109 */
15110 OP *k = S_last_non_null_kid(cUNOPx(kid)->op_first);
15111 if (k && k->op_type == OP_ANONHASH) {
15112 /* diag_listed_as: each on anonymous %s will always start from the beginning */
15113 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "each on anonymous hash will always start from the beginning");
15114 }
15115 }
15116 break;
15117 case OP_RV2AV:
15118 if (orig_type == OP_EACH &&
15119 ckWARN(WARN_SYNTAX) &&
15120 (cUNOPx(kid)->op_flags & OPf_KIDS) &&
15121 (cUNOPx(kid)->op_first->op_type == OP_SCOPE ||
15122 cUNOPx(kid)->op_first->op_type == OP_LEAVE) &&
15123 (cUNOPx(kid)->op_first->op_flags & OPf_KIDS)) {
15124 OP *k = S_last_non_null_kid(cUNOPx(kid)->op_first);
15125 if (k && k->op_type == OP_ANONLIST) {
15126 /* diag_listed_as: each on anonymous %s will always start from the beginning */
15127 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "each on anonymous array will always start from the beginning");
15128 }
15129 }
15130 /* FALLTHROUGH */
15131 case OP_PADAV:
15132 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
15133 : orig_type == OP_KEYS ? OP_AKEYS
15134 : OP_AVALUES);
15135 break;
15136 case OP_CONST:
15137 if (kid->op_private == OPpCONST_BARE
15138 || !SvROK(cSVOPx_sv(kid))
15139 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
15140 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
15141 )
15142 goto bad;
15143 /* FALLTHROUGH */
15144 default:
15145 qerror(Perl_mess(aTHX_
15146 "Experimental %s on scalar is now forbidden",
15147 PL_op_desc[orig_type]));
15148 bad:
15149 bad_type_pv(1, "hash or array", o, kid);
15150 return o;
15151 }
15152 }
15153 return ck_fun(o);
15154 }
15155
15156 OP *
Perl_ck_length(pTHX_ OP * o)15157 Perl_ck_length(pTHX_ OP *o)
15158 {
15159 PERL_ARGS_ASSERT_CK_LENGTH;
15160
15161 o = ck_fun(o);
15162
15163 if (ckWARN(WARN_SYNTAX)) {
15164 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
15165
15166 if (kid) {
15167 SV *name = NULL;
15168 const bool hash = kid->op_type == OP_PADHV
15169 || kid->op_type == OP_RV2HV;
15170 switch (kid->op_type) {
15171 case OP_PADHV:
15172 case OP_PADAV:
15173 case OP_RV2HV:
15174 case OP_RV2AV:
15175 name = op_varname(kid);
15176 break;
15177 default:
15178 return o;
15179 }
15180 if (name)
15181 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
15182 "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
15183 ")\"?)",
15184 SVfARG(name), hash ? "keys " : "", SVfARG(name)
15185 );
15186 else if (hash)
15187 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
15188 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
15189 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
15190 else
15191 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
15192 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
15193 "length() used on @array (did you mean \"scalar(@array)\"?)");
15194 }
15195 }
15196
15197 return o;
15198 }
15199
15200
15201 OP *
Perl_ck_isa(pTHX_ OP * o)15202 Perl_ck_isa(pTHX_ OP *o)
15203 {
15204 OP *classop = cBINOPo->op_last;
15205
15206 PERL_ARGS_ASSERT_CK_ISA;
15207
15208 /* Convert barename into PV */
15209 if(classop->op_type == OP_CONST && classop->op_private & OPpCONST_BARE) {
15210 /* TODO: Optionally convert package to raw HV here */
15211 classop->op_private &= ~(OPpCONST_BARE|OPpCONST_STRICT);
15212 }
15213
15214 return o;
15215 }
15216
15217
15218 /* Check for in place reverse and sort assignments like "@a = reverse @a"
15219 and modify the optree to make them work inplace */
15220
15221 STATIC void
S_inplace_aassign(pTHX_ OP * o)15222 S_inplace_aassign(pTHX_ OP *o) {
15223
15224 OP *modop, *modop_pushmark;
15225 OP *oright;
15226 OP *oleft, *oleft_pushmark;
15227
15228 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
15229
15230 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
15231
15232 assert(cUNOPo->op_first->op_type == OP_NULL);
15233 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
15234 assert(modop_pushmark->op_type == OP_PUSHMARK);
15235 modop = OpSIBLING(modop_pushmark);
15236
15237 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
15238 return;
15239
15240 /* no other operation except sort/reverse */
15241 if (OpHAS_SIBLING(modop))
15242 return;
15243
15244 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
15245 if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
15246
15247 if (modop->op_flags & OPf_STACKED) {
15248 /* skip sort subroutine/block */
15249 assert(oright->op_type == OP_NULL);
15250 oright = OpSIBLING(oright);
15251 }
15252
15253 assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
15254 oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
15255 assert(oleft_pushmark->op_type == OP_PUSHMARK);
15256 oleft = OpSIBLING(oleft_pushmark);
15257
15258 /* Check the lhs is an array */
15259 if (!oleft ||
15260 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
15261 || OpHAS_SIBLING(oleft)
15262 || (oleft->op_private & OPpLVAL_INTRO)
15263 )
15264 return;
15265
15266 /* Only one thing on the rhs */
15267 if (OpHAS_SIBLING(oright))
15268 return;
15269
15270 /* check the array is the same on both sides */
15271 if (oleft->op_type == OP_RV2AV) {
15272 if (oright->op_type != OP_RV2AV
15273 || !cUNOPx(oright)->op_first
15274 || cUNOPx(oright)->op_first->op_type != OP_GV
15275 || cUNOPx(oleft )->op_first->op_type != OP_GV
15276 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
15277 cGVOPx_gv(cUNOPx(oright)->op_first)
15278 )
15279 return;
15280 }
15281 else if (oright->op_type != OP_PADAV
15282 || oright->op_targ != oleft->op_targ
15283 )
15284 return;
15285
15286 /* This actually is an inplace assignment */
15287
15288 modop->op_private |= OPpSORT_INPLACE;
15289
15290 /* transfer MODishness etc from LHS arg to RHS arg */
15291 oright->op_flags = oleft->op_flags;
15292
15293 /* remove the aassign op and the lhs */
15294 op_null(o);
15295 op_null(oleft_pushmark);
15296 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
15297 op_null(cUNOPx(oleft)->op_first);
15298 op_null(oleft);
15299 }
15300
15301
15302 /*
15303 =for apidoc_section $custom
15304
15305 =for apidoc Perl_custom_op_xop
15306 Return the XOP structure for a given custom op. This macro should be
15307 considered internal to C<OP_NAME> and the other access macros: use them instead.
15308 This macro does call a function. Prior
15309 to 5.19.6, this was implemented as a
15310 function.
15311
15312 =cut
15313 */
15314
15315
15316 /* use PERL_MAGIC_ext to call a function to free the xop structure when
15317 * freeing PL_custom_ops */
15318
15319 static int
custom_op_register_free(pTHX_ SV * sv,MAGIC * mg)15320 custom_op_register_free(pTHX_ SV *sv, MAGIC *mg)
15321 {
15322 XOP *xop;
15323
15324 PERL_UNUSED_ARG(mg);
15325 xop = INT2PTR(XOP *, SvIV(sv));
15326 Safefree(xop->xop_name);
15327 Safefree(xop->xop_desc);
15328 Safefree(xop);
15329 return 0;
15330 }
15331
15332
15333 static const MGVTBL custom_op_register_vtbl = {
15334 0, /* get */
15335 0, /* set */
15336 0, /* len */
15337 0, /* clear */
15338 custom_op_register_free, /* free */
15339 0, /* copy */
15340 0, /* dup */
15341 #ifdef MGf_LOCAL
15342 0, /* local */
15343 #endif
15344 };
15345
15346
15347 XOPRETANY
Perl_custom_op_get_field(pTHX_ const OP * o,const xop_flags_enum field)15348 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
15349 {
15350 SV *keysv;
15351 HE *he = NULL;
15352 XOP *xop;
15353
15354 static const XOP xop_null = { 0, 0, 0, 0, 0 };
15355
15356 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
15357 assert(o->op_type == OP_CUSTOM);
15358
15359 /* This is wrong. It assumes a function pointer can be cast to IV,
15360 * which isn't guaranteed, but this is what the old custom OP code
15361 * did. In principle it should be safer to Copy the bytes of the
15362 * pointer into a PV: since the new interface is hidden behind
15363 * functions, this can be changed later if necessary. */
15364 /* Change custom_op_xop if this ever happens */
15365 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
15366
15367 if (PL_custom_ops)
15368 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
15369
15370 /* See if the op isn't registered, but its name *is* registered.
15371 * That implies someone is using the pre-5.14 API,where only name and
15372 * description could be registered. If so, fake up a real
15373 * registration.
15374 * We only check for an existing name, and assume no one will have
15375 * just registered a desc */
15376 if (!he && PL_custom_op_names &&
15377 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
15378 ) {
15379 const char *pv;
15380 STRLEN l;
15381
15382 /* XXX does all this need to be shared mem? */
15383 Newxz(xop, 1, XOP);
15384 pv = SvPV(HeVAL(he), l);
15385 XopENTRY_set(xop, xop_name, savepvn(pv, l));
15386 if (PL_custom_op_descs &&
15387 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
15388 ) {
15389 pv = SvPV(HeVAL(he), l);
15390 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
15391 }
15392 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
15393 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
15394 /* add magic to the SV so that the xop struct (pointed to by
15395 * SvIV(sv)) is freed. Normally a static xop is registered, but
15396 * for this backcompat hack, we've alloced one */
15397 (void)sv_magicext(HeVAL(he), NULL, PERL_MAGIC_ext,
15398 &custom_op_register_vtbl, NULL, 0);
15399
15400 }
15401 else {
15402 if (!he)
15403 xop = (XOP *)&xop_null;
15404 else
15405 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
15406 }
15407
15408 {
15409 XOPRETANY any;
15410 if(field == XOPe_xop_ptr) {
15411 any.xop_ptr = xop;
15412 } else {
15413 const U32 flags = XopFLAGS(xop);
15414 if(flags & field) {
15415 switch(field) {
15416 case XOPe_xop_name:
15417 any.xop_name = xop->xop_name;
15418 break;
15419 case XOPe_xop_desc:
15420 any.xop_desc = xop->xop_desc;
15421 break;
15422 case XOPe_xop_class:
15423 any.xop_class = xop->xop_class;
15424 break;
15425 case XOPe_xop_peep:
15426 any.xop_peep = xop->xop_peep;
15427 break;
15428 default:
15429 field_panic:
15430 Perl_croak(aTHX_
15431 "panic: custom_op_get_field(): invalid field %d\n",
15432 (int)field);
15433 break;
15434 }
15435 } else {
15436 switch(field) {
15437 case XOPe_xop_name:
15438 any.xop_name = XOPd_xop_name;
15439 break;
15440 case XOPe_xop_desc:
15441 any.xop_desc = XOPd_xop_desc;
15442 break;
15443 case XOPe_xop_class:
15444 any.xop_class = XOPd_xop_class;
15445 break;
15446 case XOPe_xop_peep:
15447 any.xop_peep = XOPd_xop_peep;
15448 break;
15449 default:
15450 goto field_panic;
15451 break;
15452 }
15453 }
15454 }
15455 return any;
15456 }
15457 }
15458
15459 /*
15460 =for apidoc custom_op_register
15461 Register a custom op. See L<perlguts/"Custom Operators">.
15462
15463 =cut
15464 */
15465
15466 void
Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr,const XOP * xop)15467 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
15468 {
15469 SV *keysv;
15470
15471 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
15472
15473 /* see the comment in custom_op_xop */
15474 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
15475
15476 if (!PL_custom_ops)
15477 PL_custom_ops = newHV();
15478
15479 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
15480 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
15481 }
15482
15483 /*
15484
15485 =for apidoc core_prototype
15486
15487 This function assigns the prototype of the named core function to C<sv>, or
15488 to a new mortal SV if C<sv> is C<NULL>. It returns the modified C<sv>, or
15489 C<NULL> if the core function has no prototype. C<code> is a code as returned
15490 by C<keyword()>. It must not be equal to 0.
15491
15492 =cut
15493 */
15494
15495 SV *
Perl_core_prototype(pTHX_ SV * sv,const char * name,const int code,int * const opnum)15496 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
15497 int * const opnum)
15498 {
15499 int i = 0, n = 0, seen_question = 0, defgv = 0;
15500 I32 oa;
15501 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
15502 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
15503 bool nullret = FALSE;
15504
15505 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
15506
15507 assert (code);
15508
15509 if (!sv) sv = sv_newmortal();
15510
15511 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
15512
15513 switch (code < 0 ? -code : code) {
15514 case KEY_and : case KEY_chop: case KEY_chomp:
15515 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
15516 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
15517 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
15518 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
15519 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
15520 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
15521 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
15522 case KEY_x : case KEY_xor :
15523 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
15524 case KEY_glob: retsetpvs("_;", OP_GLOB);
15525 case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
15526 case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
15527 case KEY_each: retsetpvs("\\[%@]", OP_EACH);
15528 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
15529 case KEY___CLASS__:
15530 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
15531 retsetpvs("", 0);
15532 case KEY_evalbytes:
15533 name = "entereval"; break;
15534 case KEY_readpipe:
15535 name = "backtick";
15536 }
15537
15538 #undef retsetpvs
15539
15540 findopnum:
15541 while (i < MAXO) { /* The slow way. */
15542 if (strEQ(name, PL_op_name[i])
15543 || strEQ(name, PL_op_desc[i]))
15544 {
15545 if (nullret) { assert(opnum); *opnum = i; return NULL; }
15546 goto found;
15547 }
15548 i++;
15549 }
15550 return NULL;
15551 found:
15552 defgv = PL_opargs[i] & OA_DEFGV;
15553 oa = PL_opargs[i] >> OASHIFT;
15554 while (oa) {
15555 if (oa & OA_OPTIONAL && !seen_question && (
15556 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
15557 )) {
15558 seen_question = 1;
15559 str[n++] = ';';
15560 }
15561 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
15562 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
15563 /* But globs are already references (kinda) */
15564 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
15565 ) {
15566 str[n++] = '\\';
15567 }
15568 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
15569 && !scalar_mod_type(NULL, i)) {
15570 str[n++] = '[';
15571 str[n++] = '$';
15572 str[n++] = '@';
15573 str[n++] = '%';
15574 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
15575 str[n++] = '*';
15576 str[n++] = ']';
15577 }
15578 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
15579 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
15580 str[n-1] = '_'; defgv = 0;
15581 }
15582 oa = oa >> 4;
15583 }
15584 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
15585 str[n++] = '\0';
15586 sv_setpvn(sv, str, n - 1);
15587 if (opnum) *opnum = i;
15588 return sv;
15589 }
15590
15591 OP *
Perl_coresub_op(pTHX_ SV * const coreargssv,const int code,const int opnum)15592 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
15593 const int opnum)
15594 {
15595 OP * const argop = (opnum == OP_SELECT && code) ? NULL :
15596 newSVOP(OP_COREARGS,0,coreargssv);
15597 OP *o;
15598
15599 PERL_ARGS_ASSERT_CORESUB_OP;
15600
15601 switch(opnum) {
15602 case 0:
15603 return op_append_elem(OP_LINESEQ,
15604 argop,
15605 newSLICEOP(0,
15606 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
15607 newOP(OP_CALLER,0)
15608 )
15609 );
15610 case OP_EACH:
15611 case OP_KEYS:
15612 case OP_VALUES:
15613 o = newUNOP(OP_AVHVSWITCH,0,argop);
15614 o->op_private = opnum-OP_EACH;
15615 return o;
15616 case OP_SELECT: /* which represents OP_SSELECT as well */
15617 if (code)
15618 return newCONDOP(
15619 0,
15620 newBINOP(OP_GT, 0,
15621 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
15622 newSVOP(OP_CONST, 0, newSVuv(1))
15623 ),
15624 coresub_op(newSVuv((UV)OP_SSELECT), 0,
15625 OP_SSELECT),
15626 coresub_op(coreargssv, 0, OP_SELECT)
15627 );
15628 /* FALLTHROUGH */
15629 default:
15630 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
15631 case OA_BASEOP:
15632 return op_append_elem(
15633 OP_LINESEQ, argop,
15634 newOP(opnum,
15635 opnum == OP_WANTARRAY || opnum == OP_RUNCV
15636 ? OPpOFFBYONE << 8 : 0)
15637 );
15638 case OA_BASEOP_OR_UNOP:
15639 if (opnum == OP_ENTEREVAL) {
15640 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
15641 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
15642 }
15643 else o = newUNOP(opnum,0,argop);
15644 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
15645 else {
15646 onearg:
15647 if (is_handle_constructor(o, 1))
15648 argop->op_private |= OPpCOREARGS_DEREF1;
15649 if (scalar_mod_type(NULL, opnum))
15650 argop->op_private |= OPpCOREARGS_SCALARMOD;
15651 }
15652 return o;
15653 default:
15654 o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
15655 if (is_handle_constructor(o, 2))
15656 argop->op_private |= OPpCOREARGS_DEREF2;
15657 if (opnum == OP_SUBSTR) {
15658 o->op_private |= OPpMAYBE_LVSUB;
15659 return o;
15660 }
15661 else goto onearg;
15662 }
15663 }
15664 }
15665
15666 void
Perl_report_redefined_cv(pTHX_ const SV * name,const CV * old_cv,SV * const * new_const_svp)15667 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
15668 SV * const *new_const_svp)
15669 {
15670 const char *hvname;
15671 bool is_const = cBOOL(CvCONST(old_cv));
15672 SV *old_const_sv = is_const ? cv_const_sv_or_av(old_cv) : NULL;
15673
15674 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
15675
15676 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
15677 return;
15678 /* They are 2 constant subroutines generated from
15679 the same constant. This probably means that
15680 they are really the "same" proxy subroutine
15681 instantiated in 2 places. Most likely this is
15682 when a constant is exported twice. Don't warn.
15683 */
15684 if (
15685 (ckWARN(WARN_REDEFINE)
15686 && !(
15687 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
15688 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
15689 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
15690 strEQ(hvname, "autouse"))
15691 )
15692 )
15693 || (is_const
15694 && ckWARN_d(WARN_REDEFINE)
15695 && (!new_const_svp ||
15696 !*new_const_svp ||
15697 !old_const_sv ||
15698 SvTYPE(old_const_sv) == SVt_PVAV ||
15699 SvTYPE(*new_const_svp) == SVt_PVAV ||
15700 sv_cmp(old_const_sv, *new_const_svp))
15701 )
15702 ) {
15703 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
15704 is_const
15705 ? "Constant subroutine %" SVf " redefined"
15706 : CvIsMETHOD(old_cv)
15707 ? "Method %" SVf " redefined"
15708 : "Subroutine %" SVf " redefined",
15709 SVfARG(name));
15710 }
15711 }
15712
15713 /*
15714 =for apidoc_section $hook
15715
15716 These functions provide convenient and thread-safe means of manipulating
15717 hook variables.
15718
15719 =cut
15720 */
15721
15722 /*
15723 =for apidoc wrap_op_checker
15724
15725 Puts a C function into the chain of check functions for a specified op
15726 type. This is the preferred way to manipulate the L</PL_check> array.
15727 C<opcode> specifies which type of op is to be affected. C<new_checker>
15728 is a pointer to the C function that is to be added to that opcode's
15729 check chain, and C<old_checker_p> points to the storage location where a
15730 pointer to the next function in the chain will be stored. The value of
15731 C<new_checker> is written into the L</PL_check> array, while the value
15732 previously stored there is written to C<*old_checker_p>.
15733
15734 L</PL_check> is global to an entire process, and a module wishing to
15735 hook op checking may find itself invoked more than once per process,
15736 typically in different threads. To handle that situation, this function
15737 is idempotent. The location C<*old_checker_p> must initially (once
15738 per process) contain a null pointer. A C variable of static duration
15739 (declared at file scope, typically also marked C<static> to give
15740 it internal linkage) will be implicitly initialised appropriately,
15741 if it does not have an explicit initialiser. This function will only
15742 actually modify the check chain if it finds C<*old_checker_p> to be null.
15743 This function is also thread safe on the small scale. It uses appropriate
15744 locking to avoid race conditions in accessing L</PL_check>.
15745
15746 When this function is called, the function referenced by C<new_checker>
15747 must be ready to be called, except for C<*old_checker_p> being unfilled.
15748 In a threading situation, C<new_checker> may be called immediately,
15749 even before this function has returned. C<*old_checker_p> will always
15750 be appropriately set before C<new_checker> is called. If C<new_checker>
15751 decides not to do anything special with an op that it is given (which
15752 is the usual case for most uses of op check hooking), it must chain the
15753 check function referenced by C<*old_checker_p>.
15754
15755 Taken all together, XS code to hook an op checker should typically look
15756 something like this:
15757
15758 static Perl_check_t nxck_frob;
15759 static OP *myck_frob(pTHX_ OP *op) {
15760 ...
15761 op = nxck_frob(aTHX_ op);
15762 ...
15763 return op;
15764 }
15765 BOOT:
15766 wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
15767
15768 If you want to influence compilation of calls to a specific subroutine,
15769 then use L</cv_set_call_checker_flags> rather than hooking checking of
15770 all C<entersub> ops.
15771
15772 =cut
15773 */
15774
15775 void
Perl_wrap_op_checker(pTHX_ Optype opcode,Perl_check_t new_checker,Perl_check_t * old_checker_p)15776 Perl_wrap_op_checker(pTHX_ Optype opcode,
15777 Perl_check_t new_checker, Perl_check_t *old_checker_p)
15778 {
15779
15780 PERL_UNUSED_CONTEXT;
15781 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
15782 if (*old_checker_p) return;
15783 OP_CHECK_MUTEX_LOCK;
15784 if (!*old_checker_p) {
15785 *old_checker_p = PL_check[opcode];
15786 PL_check[opcode] = new_checker;
15787 }
15788 OP_CHECK_MUTEX_UNLOCK;
15789 }
15790
15791 #include "XSUB.h"
15792
15793 /* Efficient sub that returns a constant scalar value. */
15794 static void
const_sv_xsub(pTHX_ CV * cv)15795 const_sv_xsub(pTHX_ CV* cv)
15796 {
15797 dXSARGS;
15798 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
15799 PERL_UNUSED_ARG(items);
15800 if (!sv) {
15801 XSRETURN(0);
15802 }
15803 EXTEND(sp, 1);
15804 ST(0) = sv;
15805 XSRETURN(1);
15806 }
15807
15808 static void
const_av_xsub(pTHX_ CV * cv)15809 const_av_xsub(pTHX_ CV* cv)
15810 {
15811 dXSARGS;
15812 AV * const av = MUTABLE_AV(XSANY.any_ptr);
15813 SP -= items;
15814 assert(av);
15815 #ifndef DEBUGGING
15816 if (!av) {
15817 XSRETURN(0);
15818 }
15819 #endif
15820 if (SvRMAGICAL(av))
15821 Perl_croak(aTHX_ "Magical list constants are not supported");
15822 if (GIMME_V != G_LIST) {
15823 EXTEND(SP, 1);
15824 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
15825 XSRETURN(1);
15826 }
15827 EXTEND(SP, AvFILLp(av)+1);
15828 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
15829 XSRETURN(AvFILLp(av)+1);
15830 }
15831
15832 /* Copy an existing cop->cop_warnings field.
15833 * If it's one of the standard addresses, just re-use the address.
15834 * This is the e implementation for the DUP_WARNINGS() macro
15835 */
15836
15837 char *
Perl_dup_warnings(pTHX_ char * warnings)15838 Perl_dup_warnings(pTHX_ char* warnings)
15839 {
15840 if (warnings == NULL || specialWARN(warnings))
15841 return warnings;
15842
15843 return rcpv_copy(warnings);
15844 }
15845
15846 /*
15847 =for apidoc rcpv_new
15848
15849 Create a new shared memory refcounted string with the requested size, and
15850 with the requested initialization and a refcount of 1. The actual space
15851 allocated will be 1 byte more than requested and rcpv_new() will ensure that
15852 the extra byte is a null regardless of any flags settings.
15853
15854 If the RCPVf_NO_COPY flag is set then the pv argument will be
15855 ignored, otherwise the contents of the pv pointer will be copied into
15856 the new buffer or if it is NULL the function will do nothing and return NULL.
15857
15858 If the RCPVf_USE_STRLEN flag is set then the len argument is ignored and
15859 recomputed using C<strlen(pv)>. It is an error to combine RCPVf_USE_STRLEN
15860 and RCPVf_NO_COPY at the same time.
15861
15862 Under DEBUGGING rcpv_new() will assert() if it is asked to create a 0 length
15863 shared string unless the RCPVf_ALLOW_EMPTY flag is set.
15864
15865 The return value from the function is suitable for passing into rcpv_copy() and
15866 rcpv_free(). To access the RCPV * from the returned value use the RCPVx() macro.
15867 The 'len' member of the RCPV struct stores the allocated length (including the
15868 extra byte), but the RCPV_LEN() macro returns the requested length (not
15869 including the extra byte).
15870
15871 Note that rcpv_new() does NOT use a hash table or anything like that to
15872 dedupe inputs given the same text content. Each call with a non-null pv
15873 parameter will produce a distinct pointer with its own refcount regardless of
15874 the input content.
15875
15876 =cut
15877 */
15878
15879 char *
Perl_rcpv_new(pTHX_ const char * pv,STRLEN len,U32 flags)15880 Perl_rcpv_new(pTHX_ const char *pv, STRLEN len, U32 flags) {
15881 RCPV *rcpv;
15882
15883 PERL_ARGS_ASSERT_RCPV_NEW;
15884
15885 PERL_UNUSED_CONTEXT;
15886
15887 /* Musn't use both at the same time */
15888 assert((flags & (RCPVf_NO_COPY|RCPVf_USE_STRLEN))!=
15889 (RCPVf_NO_COPY|RCPVf_USE_STRLEN));
15890
15891 if (!pv && (flags & RCPVf_NO_COPY) == 0)
15892 return NULL;
15893
15894 if (flags & RCPVf_USE_STRLEN) {
15895 assert(pv);
15896 len = strlen(pv);
15897 }
15898
15899 assert(len || (flags & RCPVf_ALLOW_EMPTY));
15900
15901 len++; /* add one for the null we will add to the end */
15902
15903 rcpv = (RCPV *)PerlMemShared_malloc(sizeof(struct rcpv) + len);
15904 if (!rcpv)
15905 croak_no_mem_ext(STR_WITH_LEN("op:rcpv_new"));
15906
15907 rcpv->len = len; /* store length including null,
15908 RCPV_LEN() subtracts 1 to account for this */
15909 rcpv->refcount = 1;
15910
15911 if ((flags & RCPVf_NO_COPY) == 0) {
15912 (void)memcpy(rcpv->pv, pv, len-1);
15913 }
15914 rcpv->pv[len-1]= '\0'; /* the last byte should always be null */
15915 return rcpv->pv;
15916 }
15917
15918 /*
15919 =for apidoc rcpv_free
15920
15921 refcount decrement a shared memory refcounted string, and when
15922 the refcount goes to 0 free it using perlmemshared_free().
15923
15924 it is the callers responsibility to ensure that the pv is the
15925 result of a rcpv_new() call.
15926
15927 Always returns NULL so it can be used like this:
15928
15929 thing = rcpv_free(thing);
15930
15931 =cut
15932 */
15933
15934 char *
Perl_rcpv_free(pTHX_ char * pv)15935 Perl_rcpv_free(pTHX_ char *pv) {
15936
15937 PERL_ARGS_ASSERT_RCPV_FREE;
15938
15939 PERL_UNUSED_CONTEXT;
15940
15941 if (!pv)
15942 return NULL;
15943 RCPV *rcpv = RCPVx(pv);
15944
15945 assert(rcpv->refcount);
15946 assert(rcpv->len);
15947
15948 OP_REFCNT_LOCK;
15949 if (--rcpv->refcount == 0) {
15950 rcpv->len = 0;
15951 PerlMemShared_free(rcpv);
15952 }
15953 OP_REFCNT_UNLOCK;
15954 return NULL;
15955 }
15956
15957 /*
15958 =for apidoc rcpv_copy
15959
15960 refcount increment a shared memory refcounted string, and when
15961 the refcount goes to 0 free it using PerlMemShared_free().
15962
15963 It is the callers responsibility to ensure that the pv is the
15964 result of a rcpv_new() call.
15965
15966 Returns the same pointer that was passed in.
15967
15968 new = rcpv_copy(pv);
15969
15970 =cut
15971 */
15972
15973
15974 char *
Perl_rcpv_copy(pTHX_ char * pv)15975 Perl_rcpv_copy(pTHX_ char *pv) {
15976
15977 PERL_ARGS_ASSERT_RCPV_COPY;
15978
15979 PERL_UNUSED_CONTEXT;
15980
15981 if (!pv)
15982 return NULL;
15983 RCPV *rcpv = RCPVx(pv);
15984 OP_REFCNT_LOCK;
15985 rcpv->refcount++;
15986 OP_REFCNT_UNLOCK;
15987 return pv;
15988 }
15989
15990 /*
15991 * ex: set ts=8 sts=4 sw=4 et:
15992 */
15993